commit d682fae50678ed52534dee24afef635fedd9732a Author: zolliker Date: Fri Aug 19 15:22:33 2022 +0200 Initial commit diff --git a/CVS/Entries b/CVS/Entries new file mode 100644 index 0000000..3ad73f9 --- /dev/null +++ b/CVS/Entries @@ -0,0 +1,14 @@ +/makefile_alpha_f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/makefile_cygwin/1.1.1.1/Tue Nov 2 15:54:57 2004// +D/gen//// +D/libs//// +D/pgm//// +D/unix//// +D/vms//// +/makefile/1.2/Thu Nov 18 09:03:11 2004// +/maketree/1.2/Thu Nov 18 09:03:54 2004// +/README/1.2/Fri Dec 8 08:08:20 2006// +/makefile_alpha/1.3/Fri Dec 15 06:53:36 2006// +/makefile_macosx/1.4/Fri Jun 22 09:34:38 2007// +/makefile_linux/1.3/Fri Aug 19 13:16:13 2022// +/make_gen/1.9/Fri Jun 22 10:48:34 2018// diff --git a/CVS/Repository b/CVS/Repository new file mode 100644 index 0000000..8465196 --- /dev/null +++ b/CVS/Repository @@ -0,0 +1 @@ +analysis/fit diff --git a/CVS/Root b/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/README b/README new file mode 100644 index 0000000..dca8e0e --- /dev/null +++ b/README @@ -0,0 +1,118 @@ +FIT + +FIT is a program to display data files and to fit standard or user-defined +functions. It can read many types of data files, mainly neutron scattering +data. It is extensible for other datafiles types, please ask the author listed +below how to implement new data files structures. It may also be used as a +library for automatic fit programs or simply to convert data files. +The original FIT program was based on an old version of the CERN Minuit +library. Since 1990, it was extended and improved continuosly. +There is a built-in help facility, where you can find most of the features +FIT offers (HELP command). +For the copyright notice, look at the end of this file. + +Installations instructions +-------------------------- + +Various flavors of Unix (Tru64, Linux, Mac OS X): + + for installing fit from source you need the pgplot and readline libraries, + if you like nexus support you need also the nexus API, hdf and hdf5 + and the compilers gcc and g77 (other fortran compilers may need source + adjustments) + + Unpack the sources, creating the directory tree ./fitsrc/... + and go to the source directory: + + > gunzip fit.tar.gz + > tar -xvf fit.tar + > rm fit.tar (assuming you dont want fit.tar as a backup) + > cd fitsrc + + Here you can find several system specific makefiles: + + > ls makefile_* + makefile_alpha makefile_alpha_f makefile_linux makefile_macosx + + These files are for Tru64 Unix (normal and fast version), RedHat Linux + and Mac OS X. + + Edit one of these file to define where the needed libraries are. + + Define an environment variable for your version, for example + + > setenv FIT_VERSION linux + + You may define this also at login. + + Then simply enter + + > make all + + to make all of fit. + + On Linux and Mac OSX systems you should use DEB=D for the debugger + friendly, non-optimizing version. The optimized version is buggy. + On Tru64 Unix the optimized version is substantially faster. + +VMS: + + To build FIT and some related programs execute the CONFIG.COM command + file. It will give you further instructions. + + + Example: + + Let us assume that the sources are in directory [USER.FIT.SRC...] + and that the prompt is $ + + $ @[USER.FIT.SRC]CONFIG + DRA0:[USER.FIT.EXE] created + DRA0:[USER.FIT.DEB] created + DRA0:[USER.FIT.EXE]MAKE.CFG; created + modify this file to define where to find the libraries + then use MAKE to make all targets in directory DRA0:[USER.FIT.EXE] + or MAKE -D to make a debugger friendly version in directory + DRA0:[USER.FIT.DEB]. + To get some help on the MAKE command type MAKE ? + + $ MAKE + ... + +Last revision: 28.08.2003 (Version 4.6) +-- +Markus Zolliker +Laboratory for Neutron Scattering, ETH Zurich & PSI Villigen +CH-5232 Villigen PSI +Tel: +41 56 310 20 89 +Fax: +41 56 310 29 39 +E-mail: markus.zolliker@psi.ch +-- + + +Copyright notice + +The author hereby grant permission to use, copy, and distribute +this software for any purpose, provided that existing copyright notices +are retained in all copies and that this notice is included verbatim in +any distributions. Modifications are also allowed, but before distributing +modified software, you are kindly asked to notify the author, as long as +his address is still valid. +No written agreement, license, or royality fee is required for any of the +authorized uses. + +Ask the Author if this copyright is too strong for your purpose. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + diff --git a/fit_help.html b/fit_help.html new file mode 100644 index 0000000..0d80305 --- /dev/null +++ b/fit_help.html @@ -0,0 +1,137 @@ +
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/fitlor.py b/fitlor.py new file mode 100755 index 0000000..c72b494 --- /dev/null +++ b/fitlor.py @@ -0,0 +1,72 @@ +#!/usr/bin/python +import sys +from math import sin, cos, radians +from subprocess import call +from collections import Mapping +from tempfile import NamedTemporaryFile + +output_format = '{n:6d}{h:4d}{k:4d}{l:4d}'\ + '{i1:10.2f}{sigi1:10.2f}'\ + '{th1:8.2f}{p1:8.2f}{chi:8.2f}{phi:8.2f}' + +if len(sys.argv) > 0 and sys.argv[0] == '-fit': + call_fit = True + sys.argv.pop(0) +else: + call_fit = False + +if len(sys.argv) > 0: + datfile = sys.argv[0] + sys.argv.pop(0) +else: + datfile = 'fitlor_data.txt' + +if len(sys.argv) > 0: + outfile = sys.argv[0] + sys.argv.pop(0) +else: + outfile = 'fitlor_out.txt' + +if call_fit: + with NamedTemporaryFile('w') as cmdfil: + cmdfil.write('k h,k,l,i1,p1,intexp,two_theta,chi,phi\n') + cmdfil.write('open %s\n' % outfile) + call(('fit', '-F', cmdfil.name)) + +tilt_geometry = False +lorentz_correction = True + +class Row(object): + def __init__(self, keys, values): + if keys is None: + raise ValueError('no keys') + for k,v in zip(keys, values): + v = float(v) + if v == int(v): + v = int(v) + setattr(self, k.lower(), v) + +keys = None +rows = [] +with open(datfile) as inp: + for line in inp: + values = line.split() + try: + row = Row(keys, values) + except ValueError: + keys = values + continue + rows.append(row) + row.n = len(rows) + row.th1=row.two_theta * 0.2 + if lorentz_correction: + lor_cor = sin(abs(radians(row.two_theta))) + if tilt_geometry: + lor_cor *= cos(radians(row.chi)) + row.intcor = row.i1 * lor_cor + row.sigcor = row.sigi1 * lor_cor + +with open(outfile, 'w') as out: + for row in rows: + out.write(output_format.format(row.__dict__) + '\n') + \ No newline at end of file diff --git a/gen/CVS/Entries b/gen/CVS/Entries new file mode 100644 index 0000000..0403b73 --- /dev/null +++ b/gen/CVS/Entries @@ -0,0 +1,99 @@ +/cho_deb.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_d1a.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_fullp.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_ida.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_nexus_dum.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_utils.inc/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_xxx.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_xy.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_xys.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/dat_xysm.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit.vers/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_array.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_bars.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_connect.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_cor.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_exit.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_fit.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_fix.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_help.f_old/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_merge.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_peak.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_print.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_range.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_rel.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_scale.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_set.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_style.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_subtract.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_title.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fit_win.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/fitv.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/inex.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/intprt.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/lib.fvi/1.1.1.1/Tue Nov 2 15:54:57 2004// +/metaf.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/migrad.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/myc_err.c/1.1.1.1/Tue Nov 2 15:54:57 2004// +/myc_err.h/1.1.1.1/Tue Nov 2 15:54:57 2004// +/myc_list.h/1.1.1.1/Tue Nov 2 15:54:57 2004// +/myc_mem.h/1.1.1.1/Tue Nov 2 15:54:57 2004// +/myc_str.c/1.1.1.1/Tue Nov 2 15:54:57 2004// +/myc_str.h/1.1.1.1/Tue Nov 2 15:54:57 2004// +/quick_sort.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/simplex.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// +/dat_2t.f/1.2/Mon Nov 22 14:56:06 2004// +/dat_5c2.f/1.2/Mon Nov 22 14:56:05 2004// +/dat_oldtas.f/1.2/Mon Nov 22 14:56:01 2004// +/dat_rita.f/1.3/Wed Apr 13 07:34:34 2005// +/dat.inc/1.3/Fri Oct 21 07:16:05 2005// +/fit_user.inc/1.2/Fri Oct 21 07:17:42 2005// +/fit_bgedit.f/1.2/Fri Aug 25 07:00:13 2006// +/fit_user.f/1.4/Thu Dec 1 13:21:13 2005// +/make_custom.f/1.4/Fri Aug 25 07:03:16 2006// +/make_vers.f/1.2/Fri Aug 25 07:04:12 2006// +/dat_init.f/1.3/Wed Nov 8 12:01:08 2006// +/dat_inx.f/1.3/Fri Apr 20 13:46:31 2007// +/dat_lnsp.f/1.4/Tue Sep 19 13:37:14 2006// +/dat_sics.f/1.3/Thu Sep 3 11:26:43 2009// +/dat_tasmad.f/1.3/Fri May 29 08:36:13 2009// +/dat_utils.f/1.4/Fri Aug 15 07:23:39 2008// +/fifun.f/1.2/Mon Aug 28 08:51:40 2006// +/fit.f/1.3/Fri Dec 8 09:40:07 2006// +/fit_list.f/1.2/Wed Dec 19 09:10:36 2007// +/fit_mon.f/1.2/Wed Aug 26 11:37:49 2009// +/fit_multiply.f/1.3/Tue Dec 19 09:28:10 2006// +/fvi.f/1.3/Tue Jan 29 15:16:40 2008// +/make_fvi.f/1.4/Tue Jan 29 15:54:07 2008// +/make_help.f/1.3/Mon Mar 5 15:11:54 2007// +/myc_fortran.h/1.2/Wed Aug 26 11:54:28 2009// +/str.f/1.2/Tue Aug 25 11:24:48 2009// +/sys_util.h/1.2/Tue Jan 29 15:06:00 2008// +/cho.f/1.3/Mon Mar 12 15:57:43 2012// +/fit_init.f/1.2/Fri Feb 15 15:37:29 2008// +/dat_fit3.f/1.2/Mon Mar 12 16:11:40 2012// +/dat_spec.f/1.5/Mon Jul 25 07:46:42 2011// +/fit_abskor.f/1.5/Fri Aug 20 13:40:37 2010// +/fit_file.f/1.5/Mon Mar 12 16:13:11 2012// +/gra.f/1.3/Thu Feb 2 07:47:54 2012// +/fit.help/1.8/Thu Nov 29 09:14:34 2012// +/fit_plot.f/1.3/Thu Nov 29 09:19:48 2012// +/metac.c/1.4/Thu Sep 17 13:39:02 2015// +/dat_ccl.f/1.6/Tue Nov 17 12:07:20 2015// +/fit_export.f/1.4/Wed Mar 30 11:33:12 2016// +/napi_err.c/1.3/Fri May 13 05:50:48 2016// +/cvt.f/1.4/Wed Jan 10 16:07:55 2018// +/dat_c.c/1.6/Mon Apr 19 12:12:54 2021// +/dat_nexus.f/1.8/Mon Jan 17 10:26:01 2022// +/dat_nexus.inc/1.4/Wed Sep 20 07:44:22 2017// +/dat_open.f/1.9/Mon Sep 7 11:39:57 2020// +/dat_table.f/1.4/Fri Jan 19 15:01:12 2018// +/fit.inc/1.6/Mon May 30 12:00:34 2016// +/fit_auto.f/1.3/Fri Sep 9 09:27:53 2016// +/fit_command.f/1.9/Fri Jun 22 07:46:26 2018// +/fit_dat.f/1.4/Thu Nov 19 16:28:52 2020// +/fit_fun.f/1.2/Fri Sep 9 09:28:33 2016// +/fit_main.f/1.6/Fri Jun 22 07:30:18 2018// +/fit_out.f/1.6/Fri Jun 22 07:01:21 2018// +D diff --git a/gen/CVS/Repository b/gen/CVS/Repository new file mode 100644 index 0000000..b23fecb --- /dev/null +++ b/gen/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/gen diff --git a/gen/CVS/Root b/gen/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/gen/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/gen/cho.f b/gen/cho.f new file mode 100644 index 0000000..bb4afb8 --- /dev/null +++ b/gen/cho.f @@ -0,0 +1,726 @@ + subroutine cho_inq(arg, gdev, pps, cols, rows) + + implicit none + + character arg*(*), pps*(*), gdev*(*) + integer cols, rows + + character str*80, old1*80, old2*80, line*80 + character typ*2, host*80, system*16 + integer c,r,i,l,cnt,inter,n,j + + cols=0 + rows=0 + call pgqndt(n) + str=' ' + pps=' ' + gdev=' ' + r=0 + c=0 + + call sys_remote_host(host, typ) + if (typ .eq. 'XW') then + gdev='XWINDOW' + goto 30 + endif + if (typ .eq. 'LO') goto 90 ! local without XWINDOW + call sys_check_system(system) + if (system .ne. 'TRU64') goto 90 ! on linux no other devices supported + + ! remote login without XWINDOW + if (arg .ne. ' ') then + cnt=5 + call str_trim(str, arg, l) + goto 21 + endif + cnt=0 +20 cnt=cnt+1 + if (cnt .eq. 2) then + old1=str + elseif (cnt .eq. 3) then + if (str .eq. old1) goto 80 + print *,'Please do not touch the keyboard!',char(7) + call sys_wait(1.0) + old2=str + elseif (cnt .eq. 4) then + if (str .eq. old1 .or. str .eq. old2) goto 80 + print *,'Do not touch the keyboard, please !!!',char(7) + call sys_wait(2.0) + elseif (cnt .gt. 4) then + goto 90 + endif + r=0 + c=0 + + print '(X,A,$)', ' ' + call sys_rd_tmo(char(5),str,l) +c print *,str(1:max(1,l)) + +21 if (l .gt. 2 .and. str(1:2) .eq. '_ ') then + i=index(str(1:l),',') + if (i .ne. 0) then + if (i .le. 3 .or. i .ge. l) goto 20 + r=-1 + read(str(i+1:l), *, err=22,end=22) r,c +22 if (r .lt. 0) goto 20 + l=i-1 + endif + i=index(str(1:l),';') + if (i .eq. 0) then + gdev=str(3:l) + else + if (i .gt. 3) gdev=str(3:i-1) + if (i .lt. l) pps=str(i+1:l) + endif + + goto 60 + + endif + + +30 cnt=10 ! exit anyway + + call cho_load(host, gdev, pps) + +60 if (gdev .ne. ' ') then + do i=1,n + call pgqdt(i, str, l, line, j, inter) + if (l .gt. 0 .and. inter .eq. 1) then + if (str(2:) .eq. gdev) goto 70 + endif + enddo + if (gdev .eq. 'VT240') then + gdev='VT125' + else if (gdev .eq. 'VMAC') then ! if VMAC not installed, do not ask again + gdev=' ' + cnt=10 + else + gdev=' ' + endif +70 continue + endif + +80 if (r .gt. 3 .and. r .lt. 100) then + rows=r + endif + if (c .ge. 40 .and. c .le. 255) then + cols=c + endif + if (gdev .eq. ' ' .and. cnt .le. 4) goto 20 ! try again +90 call cho_vpp_cups(pps) + end + + + subroutine cho_load(host, gdev, pps) +! +! load graphic device GDEV and print destination PPS from the line +! starting with HOME from preferences file +! + character*(*) host, gdev, pps + + integer lun, l, j, ld, iostat + character line*80, home*80 + + call sys_get_lun(lun) + call sys_home(home) + call str_trim(home, home, l) + call str_trim(host, host, ld) + + call sys_open(lun, home(1:l)//'terinq.pref', 'r', iostat) + if (iostat .ne. 0) goto 29 + +25 read(lun, '(a)',end=27,err=27) line + l=index(line,':') + if (l .gt. 1) then +c print *,'host: "',host(1:ld),'"' + if (index(line(1:l-1), host(1:ld)) .ne. 0) then + j=index(line(l+1:),';') + if (gdev .eq. ' ') then + if (j .eq. 0) then + gdev=line(l+1:) + elseif (j .gt. 1) then + gdev=line(l+1:l+j-1) + endif + endif + if (pps .eq. ' ') then + if (j .gt. 0 .and. l+j .le. len(line)) then + pps=line(l+j+1:) + endif + endif + close(lun) + goto 29 + endif + endif + goto 25 +27 close(lun) +29 call sys_free_lun(lun) + end + + + subroutine cho_save(host, devdest) + + character host*(*), devdest*(*) ! no trailing blanks, please + integer lun, lun1 + + character home*128, line*128 + logical done + integer l,ll,lh,iostat + + call sys_get_lun(lun) + call sys_home(home) + call str_trim(home, home, lh) + + done=.false. + + call sys_get_lun(lun1) + call sys_open(lun1, home(1:lh)//'terinq.pref1', 'w', iostat) + if (iostat .ne. 0) goto 91 + + call sys_open(lun, home(1:lh)//'terinq.pref', 'r', iostat) + if (iostat .ne. 0) goto 12 + +10 read(lun, '(a)',end=11,err=11) line + l=index(line,':') + if (l .gt. 1) then + if (index(line(1:l), host) .ne. 0) then + done=.true. + write(lun1, '(2a)') line(1:l),devdest + goto 10 + endif + endif + call cho_vpp_cups(line) + call str_trim(line, line, ll) + write(lun1, '(a)') line(1:ll) + goto 10 +11 close(lun) +12 if (.not. done) then + write(lun1, '(3a)') host,':',devdest + endif +27 close(lun1) +91 call sys_free_lun(lun) + call sys_free_lun(lun1) + call sys_rename_file(home(1:lh)//'terinq.pref1' + 1,home(1:lh)//'terinq.pref') + end + + + subroutine cho_choose(ask) !! + + character ask*1 ! ' ': info only + ! '?': ask for all parameters + ! 'G' ask for graphic device, if not defined + ! 'P' ask for printer device, if not defined + + character popt*1, pan*8, file*48, pcmd*48, gdev*8, pdev*8 + character dest*32, host*64 + save popt, pan, file, pcmd, gdev, pdev, dest, host + + character ans*80, typ*8, desc*64, gdesc*64, pdesc*64 + character pdev2*8, dev0*8, cfg*64 + integer i, j, l, m, n, inter, la, h, v, ipan, lc + logical savepref, init/.true./, initg/.true./ + integer n_names, i_gdev, i_popt, i_pan, i_file + integer i_pcmd, i_pdev, i_dest + parameter (n_names=7, i_gdev=1, i_popt=2, i_pan=3, i_file=4 + 1 , i_pcmd=5, i_pdev=6, i_dest=7) + character names(n_names)*16 + data names(i_gdev)/'CHOOSER_GDEV'/ + data names(i_popt)/'CHOOSER_POPT'/ + data names(i_pan )/'CHOOSER_PAN' / + data names(i_file)/'CHOOSER_FILE'/ + data names(i_pcmd)/'CHOOSER_PCMD'/ + data names(i_pdev)/'CHOOSER_PDEV'/ + data names(i_dest)/'CHOOSER_DEST'/ + + character opt(4)*50/ + 1 'F write a file (one file per page)' + 1,'A write a file (all pages on one file)' + 1,'L send plots to printer (all together on exit)' + 1,'I send plots immediately to printer'/ + + savepref=.false. + call pgqndt(n) + + if (init) then + init=.false. + + call sys_loadenv + + call sys_getenv(names(i_gdev), gdev) + call sys_getenv(names(i_popt), popt) + call sys_getenv(names(i_pan ), pan) + call sys_getenv(names(i_file), file) + call sys_getenv(names(i_pcmd), pcmd) + call sys_getenv(names(i_pdev), pdev) + call sys_getenv(names(i_dest), dest) + + if (pan .eq. ' ') then + pan='1' + call sys_setenv(names(i_pan ), pan) + endif + if (file .eq. ' ') then + file='pgplot.ps' + call sys_setenv(names(i_file), file) + endif + if (popt .eq. ' ') then + popt='L' + call sys_setenv(names(i_popt), popt) + endif + if (pdev .eq. ' ') then + pdev='PS' + call sys_setenv(names(i_pdev), pdev) + endif + endif + if (ask .eq. 'G') then + if (initg) then + initg=.false. + if (gdev .eq. ' ') then + call cho_inq(' ', gdev, dest, i, j) + call sys_setenv(names(i_gdev), gdev) + call sys_setenv(names(i_dest), dest) + endif + call sys_setenv('PGPLOT_DEV', '/'//gdev) + endif + endif + + ans=' ' + if (ask .eq. 'G') then + if (gdev .ne. ' ') goto 99 + ans='G' + elseif (ask .eq. 'P') then + if (popt .eq. 'A' .or. popt .eq. 'F') then + if (file .ne. ' ') goto 99 + ans='F' + else + i=index(pcmd, '*') + if (i .ne. 0) then + if (dest .ne. ' ') goto 99 + call str_trim(pcmd, pcmd, l) + print *,'Print command: ',pcmd(1:l) + ans='D' + else + if (pcmd .ne. ' ') goto 99 + ans='C' + endif + endif + endif + +20 continue + + gdesc='unknown' + pdesc='unknown' + read(pan, *, err=21,end=21) ipan +21 call cho_calc_pan(ipan, h, v) + if (v .gt. h) then + if (pdev(1:1) .ne. 'V' .and. pdev(2:2) .ne. 'V') then + pdev2=pdev(1:1)//'V'//pdev(2:) + pdev='V'//pdev + endif + else + if (pdev(1:1) .eq. 'V') then + pdev=pdev(2:) + elseif (pdev(2:2) .eq. 'V') then + pdev=pdev(1:1)//pdev(3:) + endif + pdev2=' ' + endif + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0) then + if (inter .eq. 1) then + if (gdev .eq. typ(2:) .or. + 1 gdev .eq. 'VT240' .and. typ(2:) .eq. 'VT125') then + gdesc=typ(2:l)//' '//desc + endif + elseif (pdev .eq. typ(2:)) then + pdesc=typ(2:l)//' '//desc + elseif (pdev2 .eq. typ(2:)) then + pdev=pdev2 + pdesc=typ(2:l)//' '//desc + endif + endif + enddo + call sys_setenv(names(i_pdev), pdev) + + if (ask .eq. ' ') then ! info only + call str_trim(gdesc, gdesc, l) + print *,'Display device type: ',gdesc(1:l) + call str_trim(pdesc, pdesc, l) + print *,'Printer device type: ',pdesc(1:l) + if (popt .eq. 'F' .or. popt .eq. 'A') then + call str_trim(file, file, l) + if (popt .eq. 'F') then + print *,'one file per page, filename: ', file(1:l),'_n' + else + print *,'all pages on one page. filename: ', file(1:l) + endif + else + call str_trim(pcmd, pcmd, l) + call str_trim(dest, dest, i) + if (pcmd .eq. ' ') then + print *,'print command undefined' + elseif (dest .eq. ' ' .and. index(pcmd,'*') .ne. 0) then + print *,'print destination undefined' + elseif (dest .ne. ' ' .and. index(pcmd,'*') .eq. 0) then + print *,'print destination ignored' + 1,' (print command does not contain *)' + elseif (popt .eq. 'L') then + print *,'print later on ',dest(1:i) + 1 ,' with command: ', pcmd(1:l) + else + print *,'print immediately on ',dest(1:i) + 1 ,' with command: ', pcmd(1:l) + endif + endif + if (pan .ne. '1') then + print *,pan,' graphs per page' + else + print *,'one graph per page' + endif + print * + goto 99 + endif + + if (ans .eq. ' ') then + print *, 'Option Description Actual State' + print '(X,79(''-''))' + call str_trim(gdesc, gdesc, l) + l=min(l,42) + print *, ' G change display device type '//gdesc(1:l) + call str_trim(pdesc, pdesc, l) + l=min(l,42) + print *, ' P change printer device type '//pdesc(1:l) + + print * + do j=1,4 + if (popt .eq. opt(j)(1:1)) then + print *,'>> ',opt(j) + else + print *,' ',opt(j) + endif + enddo +c if (popt .eq. 'F') then +c print *,' ',opt(2),' every page will be written to' +c print *,' ',opt(3),' a separate file' +c print *,' ',opt(4) +c elseif (popt .eq. 'A') then +c print *,' ',opt(1),' all pages will be written to one' +c print *,' ',opt(3),' large file' +c print *,' ',opt(4) +c elseif (popt .eq. 'L') then +c print *,' ',opt(1),' all pages will be sent on exit to' +c print *,' ',opt(2),' the selected printer' +c print *,' ',opt(4),' (select F or A to write on a file)' +c elseif (popt .eq. 'I') then +c print *,' ',opt(1),' every page will be sent immediately' +c print *,' ',opt(2),' to the selected printer' +c print *,' ',opt(3),' (select F or A to write on a file)' +c endif +! i=index('FALI',popt) + +! do j=1,4 +! if (j .ne. i) then +! print *,' ',opt(j) +! endif +! enddo + print * + + if (popt .eq. 'F' .or. popt .eq. 'A') then + call str_trim(file, file, l) + print *, ' N change print file name ',file(1:l) + else + call str_trim(pcmd, pcmd, l) + print *, ' C change print command ',pcmd(1:l) + call str_trim(dest, dest, l) + print *, ' D change print destination ',dest(1:l) + endif + print '(x,2a)' + 1 , ' 1...99 number of graphs per page ',pan + print * + print '(x,a,$)' + 1 ,'Enter option or to continue: ' + ans=' ' + read(*,'(a)',end=40,err=40) ans + endif + +40 if (ans .eq. ' ') then + if (popt .eq. 'L' .or. popt .eq. 'I') then + if (pcmd .ne. ' ') then + if (index(pcmd,'*') .eq. 0) then + if (dest .eq. ' ') goto 99 + print * + print *,'Print destination ignored' + 1,' (print command does not contain *)' + goto 99 + else + if (dest .ne. ' ') goto 99 + print * + print *,'Print destination undefined' + endif + else + print * + print *,'Print command undefined' + endif + call str_trim(file, file, l) + if (popt .eq. 'L') then + popt='A' + print *, 'Save all pages on: ',file(1:l) + else + popt='F' + print *, 'Save pages on: ',file(1:l),'_n' + endif + print * + call sys_setenv('CHOOSER_POPT', popt) + endif + goto 99 + endif + call str_upcase(ans(1:1), ans(1:1)) + if (ans(1:1) .eq. 'G') then +41 if (ans(2:) .eq. ' ') then + print * + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 1) then + m=max(1,m) + print *,typ(2:),' ',desc(1:m) + endif + enddo + endif + print * + call cho_get_arg('Display device type: ', ans) + call str_upcase(ans, ans) + call str_trim(ans, ans, la) + if (la .gt. 7) la=7 + if (ans .ne. ' ' .and. gdev(1:la) .ne. ans(1:la)) then + dev0=' ' + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 1) then + if (typ(2:) .eq. ans) then + dev0=ans + goto 411 + endif + if (typ(2:la+1) .eq. ans(1:la)) then + if (dev0 .ne. ' ') then + print *,'Ambiguous device type: ',ans(1:la) + ans=' ' + goto 41 + endif + dev0=typ(2:) + endif + endif + enddo + if (dev0 .eq. ' ') then + print *,'Unknown display device: ',ans(1:la) + ans=' ' + goto 41 + endif +411 gdev=dev0 + call sys_setenv(names(i_gdev), gdev) + call sys_setenv('PGPLOT_DEV', '/'//gdev) + savepref=.true. + endif + elseif (ans(1:1) .eq. 'P') then +42 if (ans(2:) .eq. ' ') then + print * + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 0) then + m=max(1,m) + print *,typ(2:),' ',desc(1:m) + endif + enddo + endif + print * + call cho_get_arg('Printer device type: ', ans) + call str_upcase(ans, ans) + call str_trim(ans, ans, la) + if (ans .ne. ' ' .and. pdev(1:la) .ne. ans(1:la)) then + dev0=' ' + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 0) then + if (typ(2:) .eq. ans) then + dev0=ans + goto 421 + endif + if (typ(2:la+1) .eq. ans(1:la)) then + if (dev0 .ne. ' ') then + print *,'Ambiguous device type: ',ans(1:la) + ans=' ' + goto 42 + endif + dev0=typ(2:) + endif + endif + enddo + if (dev0 .eq. ' ') then + print *,'Unknown printer device: ',ans(1:la) + ans=' ' + goto 42 + endif +421 pdev=dev0 + if (index(pdev, 'PS') .eq. 0) then ! non postscript variants + popt='F' + call sys_setenv(names(i_popt), popt) + file='?' + call sys_setenv(names(i_file), file) + endif + call sys_setenv(names(i_pdev), pdev) + endif + elseif (ans(1:1) .eq. 'N') then + call cho_get_arg('File Name: ', ans) + if (ans .ne. ' ' .and. ans .ne. file) then + file=ans + call sys_setenv(names(i_file), file) + endif + elseif (ans(1:1) .eq. 'C') then + print * + print * + 1 ,'Note: the print command should contain * (asterisk)' + 1 ,'as a placeholder for the print destination' + print * + call cho_get_arg('Print Command: ', ans) + if (ans .ne. ' ' .and. ans .ne. pcmd) then + pcmd=ans + call sys_setenv(names(i_pcmd), pcmd) + endif + elseif (ans(1:1) .eq. 'D') then + call cho_get_arg('Print destination: ', ans) + if (ans .ne. ' ' .and. ans .ne. dest) then + call str_trim(ans, ans, i) + if (i .lt. 3) then + print *,ans(1:i),' is an illegal destination' + else + dest=ans + call sys_setenv(names(i_dest), dest) + savepref=.true. + endif + endif + else + i=index('FALI',ans(1:1)) + if (i .ne. 0) then + if (popt .ne. ans(1:1)) then + popt=ans(1:1) + call sys_setenv(names(i_popt), popt) + endif + else + read(ans, '(bn,i8)', err=50,end=50) i + if (i .gt. 0 .and. i .le. 99) then + call cho_calc_pan(i, h, v) + i=h*v + if (i .ne. ipan) then + if (i .le. 9) then + write(pan, '(i1)') i + else + write(pan, '(i2)') i + endif + call sys_setenv(names(i_pan ), pan) + endif + else + print *,'unknown option' + endif + endif + endif +50 ans=' ' + goto 20 + +99 call sys_saveenv + if (savepref) then + call sys_getenv('CHOOSER_TERINQ', ans) + if (ans(1:1) .ne. '1') goto 999 ! save only if terinq used + if (gdev .ne. 'XWINDOW' .and. gdev .ne. 'XSERVE') then + call str_trim(cfg,gdev,lc) + else + lc=0 + endif + print * + if (lc .gt. 0) then + print *,'Graphic device: ',cfg(1:lc) + endif + call str_append(cfg,lc,';') + call str_trim(pdev, pdev, l) + if (index('VCPS VPS ',pdev(1:l+1)) .ne. 0) then + if (dest .ne. ' ') then + print *,'Printer destination: ',dest + call str_append(cfg,lc,dest) + call str_trim(cfg,cfg(1:lc),lc) + endif + endif + if (lc .gt. 1) then + call sys_remote_host(host, typ) + call str_trim(host,host,l) + print '(x,3a,$)','Save this for next session from ' + 1 ,host(1:l),'? [N/y]: ' + read(*,'(a)',end=999,err=999) ans + call str_upcase(ans(1:1), ans(1:1)) + if (ans(1:1) .eq. 'Y') then + call str_trim(host, host, l) + print *,'saved' + call cho_save(host(1:l),cfg(1:lc)) + endif + endif + endif +999 end + + + subroutine cho_get_arg(prompt, ans) + + character prompt*(*), ans*(*) + + integer i + if (ans(2:) .ne. ' ') then + i=2 +10 if (ans(i:i) .eq. ' ') then + i=i+1 + goto 10 + endif + ans=ans(i:) + else + print '(x,a,$)',prompt + ans=' ' + read(*,'(a)',end=9,err=9) ans + endif +9 end + + + subroutine cho_calc_pan(p, h, v) + +! calculate h, v from number of panels p, in order that h*v~=p or h*v*2~=p + + integer p + integer h,v + + if (p .le. 1) goto 9 + + v=nint(sqrt(p*1.0)) + h=nint(sqrt(p*0.5)) + if (abs(v*v-p) .lt. abs(h*h*2-p)) then + h=v + else + v=h*2 + endif + return + +9 h=1 + v=1 + end + + + + subroutine cho_vpp_cups(str) + + character str*(*) + character up*80 + integer i + + call str_upcase(up, str) + i=index(up,'PSW') + if (i .gt. 0) then + if (up(i:i+4) .eq. 'PSW18') str(i:)='WHGA_138_1' + if (up(i:i+4) .eq. 'PSW21') str(i:)='SINQ_LHO_1' + if (up(i:i+4) .eq. 'PSW22') str(i:)='WHGA_243_1' + if (up(i:i+4) .eq. 'PSW24') str(i:)='SINQ_LHW_1' + if (up(i:i+4) .eq. 'PSW25') str(i:)='SINQ_THO_1' + end if + end diff --git a/gen/cho_deb.f b/gen/cho_deb.f new file mode 100644 index 0000000..e8c958c --- /dev/null +++ b/gen/cho_deb.f @@ -0,0 +1,725 @@ + subroutine cho_inq(arg, gdev, pps, cols, rows) + + implicit none + + character arg*(*), pps*(*), gdev*(*) + integer cols, rows + + character str*80, old1*80, old2*80, line*80 + character typ*2, home*128, host*80, system*16 + integer c,r,i,l,id,tim,cnt,inter,n,j + integer iostat + logical homeflag + + cols=0 + rows=0 + call pgqndt(n) + str=' ' + pps=' ' + gdev=' ' + r=0 + + call sys_remote_host(host, typ) + if (typ .eq. 'XW') then + gdev='XWINDOW' + goto 30 + endif + if (typ .eq. 'LO') goto 90 ! local without XWINDOW + call sys_check_system(system) + if (system .ne. 'TRU64') goto 90 ! on linux no other devices supported + + ! remote login without XWINDOW + if (arg .ne. ' ') then + cnt=5 + call str_trim(str, arg, l) + goto 21 + endif + cnt=0 +20 cnt=cnt+1 + if (cnt .eq. 2) then + old1=str + elseif (cnt .eq. 3) then + if (str .eq. old1) goto 80 + print *,'Please do not touch the keyboard!',char(7) + call sys_wait(1.0) + old2=str + elseif (cnt .eq. 4) then + if (str .eq. old1 .or. str .eq. old2) goto 80 + print *,'Do not touch the keyboard, please !!!',char(7) + call sys_wait(2.0) + elseif (cnt .gt. 4) then + goto 90 + endif + r=0 + c=0 + + print '(X,A,$)', ' ' + call sys_rd_tmo(char(5),str,l) +c print *,str(1:max(1,l)) + +21 if (l .gt. 2 .and. str(1:2) .eq. '_ ') then + i=index(str(1:l),',') + if (i .ne. 0) then + if (i .le. 3 .or. i .ge. l) goto 20 + r=-1 + read(str(i+1:l), *, err=22,end=22) r,c +22 if (r .lt. 0) goto 20 + if (r .eq. 58) print *,'terinq_debug: r=58' + l=i-1 + endif + i=index(str(1:l),';') + if (i .eq. 0) then + gdev=str(3:l) + else + if (i .gt. 3) gdev=str(3:i-1) + if (i .lt. l) pps=str(i+1:l) + endif + + goto 60 + + endif + + +30 cnt=10 ! exit anyway + + call cho_load(host, gdev, pps) + +60 if (gdev .ne. ' ') then + do i=1,n + call pgqdt(i, str, l, line, j, inter) + if (l .gt. 0 .and. inter .eq. 1) then + if (str(2:) .eq. gdev) goto 70 + endif + enddo + if (gdev .eq. 'VT240') then + gdev='VT125' + else if (gdev .eq. 'VMAC') then ! if VMAC not installed, do not ask again + gdev=' ' + cnt=10 + else + gdev=' ' + endif +70 continue + endif + +80 if (r .eq. 58 .or. rows .eq. 58) then + print *,'terinq_debug:',r,rows + endif + if (r .gt. 3 .and. r .lt. 100) then + rows=r + endif + if (c .ge. 40 .and. c .le. 255) then + cols=c + endif + if (gdev .eq. ' ' .and. cnt .le. 4) goto 20 ! try again +90 call cho_vpp_cups(pps) + end + + + subroutine cho_load(host, gdev, pps) +! +! load graphic device GDEV and print destination PPS from the line +! starting with HOME from preferences file +! + character*(*) host, gdev, pps + + integer lun, l, j, ld, iostat + character line*80, home*80 + + call sys_get_lun(lun) + call sys_home(home) + call str_trim(home, home, l) + call str_trim(host, host, ld) + + call sys_open(lun, home(1:l)//'terinq.pref', 'r', iostat) + if (iostat .ne. 0) goto 29 + +25 read(lun, '(a)',end=27,err=27) line + l=index(line,':') + if (l .gt. 1) then +c print *,'host: "',host(1:ld),'"' + if (index(line(1:l-1), host(1:ld)) .ne. 0) then + j=index(line(l+1:),';') + if (gdev .eq. ' ') then + if (j .eq. 0) then + gdev=line(l+1:) + elseif (j .gt. 1) then + gdev=line(l+1:l+j-1) + endif + endif + if (pps .eq. ' ') then + if (j .gt. 0 .and. l+j .le. len(line)) then + pps=line(l+j+1:) + endif + endif + close(lun) + goto 29 + endif + endif + goto 25 +27 close(lun) +29 call sys_free_lun(lun) + end + + + subroutine cho_save(host, devdest) + + character host*(*), devdest*(*) ! no trailing blanks, please + integer lun, lun1 + + character home*128, line*128 + logical done + integer l,ll,lh,iostat + + call sys_get_lun(lun) + call sys_home(home) + call str_trim(home, home, lh) + + done=.false. + + call sys_get_lun(lun1) + call sys_open(lun1, home(1:lh)//'terinq.pref1', 'w', iostat) + if (iostat .ne. 0) goto 91 + + call sys_open(lun, home(1:lh)//'terinq.pref', 'r', iostat) + if (iostat .ne. 0) goto 12 + +10 read(lun, '(a)',end=11,err=11) line + l=index(line,':') + if (l .gt. 1) then + if (index(line(1:l), host) .ne. 0) then + done=.true. + write(lun1, '(2a)') line(1:l),devdest + goto 10 + endif + endif + call cho_vpp_cups(line) + call str_trim(line, line, ll) + write(lun1, '(a)') line(1:ll) + goto 10 +11 close(lun) +12 if (.not. done) then + write(lun1, '(3a)') host,':',devdest + endif +27 close(lun1) +91 call sys_free_lun(lun) + call sys_free_lun(lun1) + call sys_rename_file(home(1:lh)//'terinq.pref1' + 1,home(1:lh)//'terinq.pref') + end + + + subroutine cho_choose(ask) !! + + character ask*1 ! ' ': info only + ! '?': ask for all parameters + ! 'G' ask for graphic device, if not defined + ! 'P' ask for printer device, if not defined + + character popt*1, pan*8, file*48, pcmd*48, gdev*8, pdev*8 + character dest*32, host*64 + save popt, pan, file, pcmd, gdev, pdev, dest, host + + character ans*80, typ*8, desc*64, gdesc*64, pdesc*64 + character pdev2*8, dev0*8, cfg*64 + integer i, j, l, m, n, inter, crit, la, h, v, ipan, lc + integer lun/0/, lunr/0/ + logical savepref, quit, init/.true./, initg/.true./ + integer n_names, i_gdev, i_popt, i_pan, i_file + integer i_pcmd, i_pdev, i_dest + parameter (n_names=7, i_gdev=1, i_popt=2, i_pan=3, i_file=4 + 1 , i_pcmd=5, i_pdev=6, i_dest=7) + character names(n_names)*16 + data names(i_gdev)/'CHOOSER_GDEV'/ + data names(i_popt)/'CHOOSER_POPT'/ + data names(i_pan )/'CHOOSER_PAN' / + data names(i_file)/'CHOOSER_FILE'/ + data names(i_pcmd)/'CHOOSER_PCMD'/ + data names(i_pdev)/'CHOOSER_PDEV'/ + data names(i_dest)/'CHOOSER_DEST'/ + + character opt(4)*34/ + 1 'F write one file per page' + 1,'A write all pages on one file' + 1,'L send plots later to printer' + 1,'I send immediately to printer'/ + + savepref=.false. + call pgqndt(n) + + if (init) then + init=.false. + + call sys_loadenv + + call sys_getenv(names(i_gdev), gdev) + call sys_getenv(names(i_popt), popt) + call sys_getenv(names(i_pan ), pan) + call sys_getenv(names(i_file), file) + call sys_getenv(names(i_pcmd), pcmd) + call sys_getenv(names(i_pdev), pdev) + call sys_getenv(names(i_dest), dest) + + if (pan .eq. ' ') then + pan='1' + call sys_setenv(names(i_pan ), pan) + endif + if (file .eq. ' ') then + file='posts.dat' + call sys_setenv(names(i_file), file) + endif + if (popt .eq. ' ') then + popt='L' + call sys_setenv(names(i_popt), popt) + endif + if (pdev .eq. ' ') then + pdev='PS' + call sys_setenv(names(i_pdev), pdev) + endif + endif + if (ask .eq. 'G') then + if (initg) then + initg=.false. + if (gdev .eq. ' ') then + call cho_inq(' ', gdev, dest, i, j) + call sys_setenv(names(i_gdev), gdev) + call sys_setenv(names(i_dest), dest) + endif + call sys_setenv('PGPLOT_DEV', '/'//gdev) + endif + endif + + ans=' ' + if (ask .eq. 'G') then + if (gdev .ne. ' ') goto 99 + ans='G' + elseif (ask .eq. 'P') then + if (popt .eq. 'A' .or. popt .eq. 'F') then + if (file .ne. ' ') goto 99 + ans='F' + else + i=index(pcmd, '*') + if (i .ne. 0) then + if (dest .ne. ' ') goto 99 + call str_trim(pcmd, pcmd, l) + print *,'Print command: ',pcmd(1:l) + ans='D' + else + if (pcmd .ne. ' ') goto 99 + ans='C' + endif + endif + endif + +20 continue + + gdesc='unknown' + pdesc='unknown' + read(pan, *, err=21,end=21) ipan +21 call cho_calc_pan(ipan, h, v) + if (v .gt. h) then + if (pdev(1:1) .ne. 'V' .and. pdev(2:2) .ne. 'V') then + pdev2=pdev(1:1)//'V'//pdev(2:) + pdev='V'//pdev + endif + else + if (pdev(1:1) .eq. 'V') then + pdev=pdev(2:) + elseif (pdev(2:2) .eq. 'V') then + pdev=pdev(1:1)//pdev(3:) + endif + pdev2=' ' + endif + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0) then + if (inter .eq. 1) then + if (gdev .eq. typ(2:) .or. + 1 gdev .eq. 'VT240' .and. typ(2:) .eq. 'VT125') then + gdesc=typ(2:l)//' '//desc + endif + elseif (pdev .eq. typ(2:)) then + pdesc=typ(2:l)//' '//desc + elseif (pdev2 .eq. typ(2:)) then + pdev=pdev2 + pdesc=typ(2:l)//' '//desc + endif + endif + enddo + call sys_setenv(names(i_pdev), pdev) + + if (ask .eq. ' ') then ! info only + call str_trim(gdesc, gdesc, l) + print *,'Display device type: ',gdesc(1:l) + call str_trim(pdesc, pdesc, l) + print *,'Printer device type: ',pdesc(1:l) + if (popt .eq. 'F' .or. popt .eq. 'A') then + call str_trim(file, file, l) + if (popt .eq. 'F') then + print *,'one file per page, filename: ', file(1:l),'_n' + else + print *,'all pages on one page. filename: ', file(1:l) + endif + else + call str_trim(pcmd, pcmd, l) + call str_trim(dest, dest, i) + if (pcmd .eq. ' ') then + print *,'print command undefined' + elseif (dest .eq. ' ' .and. index(pcmd,'*') .ne. 0) then + print *,'print destination undefined' + elseif (dest .ne. ' ' .and. index(pcmd,'*') .eq. 0) then + print *,'print destination ignored' + 1,' (print command does not contain *)' + elseif (popt .eq. 'L') then + print *,'print later on ',dest(1:i) + 1 ,' with command: ', pcmd(1:l) + else + print *,'print immediately on ',dest(1:i) + 1 ,' with command: ', pcmd(1:l) + endif + endif + if (pan .ne. '1') then + print *,pan,' graphs per page' + else + print *,'one graph per page' + endif + print * + goto 99 + endif + + if (ans .eq. ' ') then + print *, 'Option Description Actual State' + print '(X,79(''-''))' + call str_trim(gdesc, gdesc, l) + l=min(l,42) + print *, ' G change display device type '//gdesc(1:l) + call str_trim(pdesc, pdesc, l) + l=min(l,42) + print *, ' P change printer device type '//pdesc(1:l) + + print * + if (popt .eq. 'F') then + print *,' ',opt(2),' every page will be written to' + print *,' ',opt(3),' a separate file' + print *,' ',opt(4) + elseif (popt .eq. 'A') then + print *,' ',opt(1),' all pages will be written to one' + print *,' ',opt(3),' large file' + print *,' ',opt(4) + elseif (popt .eq. 'L') then + print *,' ',opt(1),' all pages will be sent on exit to' + print *,' ',opt(2),' the selected printer' + print *,' ',opt(4),' (select F or A to write on a file)' + elseif (popt .eq. 'I') then + print *,' ',opt(1),' every page will be sent immediately' + print *,' ',opt(2),' to the selected printer' + print *,' ',opt(3),' (select F or A to write on a file)' + endif +! i=index('FALI',popt) + +! do j=1,4 +! if (j .ne. i) then +! print *,' ',opt(j) +! endif +! enddo + print * + + if (popt .eq. 'F' .or. popt .eq. 'A') then + call str_trim(file, file, l) + print *, ' N change print file name ',file(1:l) + else + call str_trim(pcmd, pcmd, l) + print *, ' C change print command ',pcmd(1:l) + call str_trim(dest, dest, l) + print *, ' D change print destination ',dest(1:l) + endif + print '(x,2a)' + 1 , ' 1...99 number of graphs per page ',pan + print * + print '(x,a,$)' + 1 ,'Enter option or to continue: ' + ans=' ' + read(*,'(a)',end=40,err=40) ans + endif + +40 if (ans .eq. ' ') then + if (popt .eq. 'L' .or. popt .eq. 'I') then + if (pcmd .ne. ' ') then + if (index(pcmd,'*') .eq. 0) then + if (dest .eq. ' ') goto 99 + print * + print *,'Print destination ignored' + 1,' (print command does not contain *)' + goto 99 + else + if (dest .ne. ' ') goto 99 + print * + print *,'Print destination undefined' + endif + else + print * + print *,'Print command undefined' + endif + call str_trim(file, file, l) + if (popt .eq. 'L') then + popt='A' + print *, 'Save all pages on: ',file(1:l) + else + popt='F' + print *, 'Save pages on: ',file(1:l),'_n' + endif + print * + call sys_setenv('CHOOSER_POPT', popt) + endif + goto 99 + endif + call str_upcase(ans(1:1), ans(1:1)) + if (ans(1:1) .eq. 'G') then +41 if (ans(2:) .eq. ' ') then + print * + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 1) then + m=max(1,m) + print *,typ(2:),' ',desc(1:m) + endif + enddo + endif + print * + call cho_get_arg('Display device type: ', ans) + call str_upcase(ans, ans) + call str_trim(ans, ans, la) + if (la .gt. 7) la=7 + if (ans .ne. ' ' .and. gdev(1:la) .ne. ans(1:la)) then + dev0=' ' + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 1) then + if (typ(2:) .eq. ans) then + dev0=ans + goto 411 + endif + if (typ(2:la+1) .eq. ans(1:la)) then + if (dev0 .ne. ' ') then + print *,'Ambiguous device type: ',ans(1:la) + ans=' ' + goto 41 + endif + dev0=typ(2:) + endif + endif + enddo + if (dev0 .eq. ' ') then + print *,'Unknown display device: ',ans(1:la) + ans=' ' + goto 41 + endif +411 gdev=dev0 + call sys_setenv(names(i_gdev), gdev) + call sys_setenv('PGPLOT_DEV', '/'//gdev) + savepref=.true. + endif + elseif (ans(1:1) .eq. 'P') then +42 if (ans(2:) .eq. ' ') then + print * + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 0) then + m=max(1,m) + print *,typ(2:),' ',desc(1:m) + endif + enddo + endif + print * + call cho_get_arg('Printer device type: ', ans) + call str_upcase(ans, ans) + call str_trim(ans, ans, la) + if (ans .ne. ' ' .and. pdev(1:la) .ne. ans(1:la)) then + dev0=' ' + do i=1,n + call pgqdt(i, typ, l, desc, m, inter) + if (l .gt. 0 .and. inter .eq. 0) then + if (typ(2:) .eq. ans) then + dev0=ans + goto 421 + endif + if (typ(2:la+1) .eq. ans(1:la)) then + if (dev0 .ne. ' ') then + print *,'Ambiguous device type: ',ans(1:la) + ans=' ' + goto 42 + endif + dev0=typ(2:) + endif + endif + enddo + if (dev0 .eq. ' ') then + print *,'Unknown printer device: ',ans(1:la) + ans=' ' + goto 42 + endif +421 pdev=dev0 + if (index(pdev, 'PS') .eq. 0) then ! non postscript variants + popt='F' + call sys_setenv(names(i_popt), popt) + file='?' + call sys_setenv(names(i_file), file) + endif + call sys_setenv(names(i_pdev), pdev) + endif + elseif (ans(1:1) .eq. 'N') then + call cho_get_arg('File Name: ', ans) + if (ans .ne. ' ' .and. ans .ne. file) then + file=ans + call sys_setenv(names(i_file), file) + endif + elseif (ans(1:1) .eq. 'C') then + print * + print * + 1 ,'Note: the print command should contain * (asterisk)' + 1 ,'as a placeholder for the print destination' + print * + call cho_get_arg('Print Command: ', ans) + if (ans .ne. ' ' .and. ans .ne. pcmd) then + pcmd=ans + call sys_setenv(names(i_pcmd), pcmd) + endif + elseif (ans(1:1) .eq. 'D') then + call cho_get_arg('Print destination: ', ans) + if (ans .ne. ' ' .and. ans .ne. dest) then + call str_trim(ans, ans, i) + if (i .lt. 3) then + print *,ans(1:i),' is an illegal destination' + else + dest=ans + call sys_setenv(names(i_dest), dest) + savepref=.true. + endif + endif + else + i=index('FALI',ans(1:1)) + if (i .ne. 0) then + if (popt .ne. ans(1:1)) then + popt=ans(1:1) + call sys_setenv(names(i_popt), popt) + endif + else + read(ans, '(bn,i8)', err=50,end=50) i + if (i .gt. 0 .and. i .le. 99) then + call cho_calc_pan(i, h, v) + i=h*v + if (i .ne. ipan) then + if (i .le. 9) then + write(pan, '(i1)') i + else + write(pan, '(i2)') i + endif + call sys_setenv(names(i_pan ), pan) + endif + else + print *,'unknown option' + endif + endif + endif +50 ans=' ' + goto 20 + +99 call sys_saveenv + if (savepref) then + call sys_getenv('CHOOSER_TERINQ', ans) + if (ans(1:1) .ne. '1') goto 999 ! save only if terinq used + if (gdev .ne. 'XWINDOW' .and. gdev .ne. 'XSERVE') then + call str_trim(cfg,gdev,lc) + else + lc=0 + endif + print * + if (lc .gt. 0) then + print *,'Graphic device: ',cfg(1:lc) + endif + call str_append(cfg,lc,';') + call str_trim(pdev, pdev, l) + if (index('VCPS VPS ',pdev(1:l+1)) .ne. 0) then + if (dest .ne. ' ') then + print *,'Printer destination: ',dest + call str_append(cfg,lc,dest) + call str_trim(cfg,cfg(1:lc),lc) + endif + endif + if (lc .gt. 1) then + call sys_remote_host(host, typ) + call str_trim(host,host,l) + print '(x,3a,$)','Save this for next session from ' + 1 ,host(1:l),'? [N/y]: ' + read(*,'(a)',end=999,err=999) ans + call str_upcase(ans(1:1), ans(1:1)) + if (ans(1:1) .eq. 'Y') then + call str_trim(host, host, l) + print *,'saved' + call cho_save(host(1:l),cfg(1:lc)) + endif + endif + endif +999 end + + + subroutine cho_get_arg(prompt, ans) + + character prompt*(*), ans*(*) + + integer i + if (ans(2:) .ne. ' ') then + i=2 +10 if (ans(i:i) .eq. ' ') then + i=i+1 + goto 10 + endif + ans=ans(i:) + else + print '(x,a,$)',prompt + ans=' ' + read(*,'(a)',end=9,err=9) ans + endif +9 end + + + subroutine cho_calc_pan(p, h, v) + +! calculate h, v from number of panels p, in order that h*v~=p or h*v*2~=p + + integer p + integer h,v + + if (p .le. 1) goto 9 + + v=nint(sqrt(p*1.0)) + h=nint(sqrt(p*0.5)) + if (abs(v*v-p) .lt. abs(h*h*2-p)) then + h=v + else + v=h*2 + endif + return + +9 h=1 + v=1 + end + + + + subroutine cho_vpp_cups(str) + + character str*(*) + character up*80 + integer i + + call str_upcase(up, str) + i=index(up,'PSW') + if (i .gt. 0) then + if (up(i:i+4) .eq. 'PSW18') str(i:)='WHGA_138_1' + if (up(i:i+4) .eq. 'PSW21') str(i:)='SINQ_LHO_1' + if (up(i:i+4) .eq. 'PSW22') str(i:)='WHGA_243_1' + if (up(i:i+4) .eq. 'PSW24') str(i:)='SINQ_LHW_1' + if (up(i:i+4) .eq. 'PSW25') str(i:)='SINQ_THO_1' + end if + end diff --git a/gen/cvt.f b/gen/cvt.f new file mode 100644 index 0000000..32acc15 --- /dev/null +++ b/gen/cvt.f @@ -0,0 +1,240 @@ +!!------------------------------------------------------------------------------ +!! + subroutine CVT_REAL_STR(RESULT, RESLEN, X, !! + 1 WIDTH, FIXLEN, DIGITS, TRUNC) !! +!! ===================================================== +!! +!! Convert X to RESULT (subroutine version) +!! +!! The number is converted using Fortran format F.. +!! If the number is too large or the number of significant digits is to +!! low, the number digits after the decimal point is changed or, if this is +!! is not possible, an E-format is choosen. If WIDTH is lower than 6, the +!! result length will be larger in some cases. +!! +!! Default format (WIDTH < 0, FIXLEN < -1, DIGITS < 0) +!! + implicit none + +!! Arguments + character*(*) RESULT !! + integer RESLEN !! length of result + real X !! number to be converted + integer WIDTH !! minimum width + integer FIXLEN !! minimum digits after comma + integer DIGITS !! minimum significant digits + integer TRUNC !! TRUNC=1,3: omit trailing zeros + !! TRUNC=0,1: decimal point always shown + + integer bufmax + parameter (bufmax=32) + integer wid, fix, dig, trc + character*(bufmax) fixbuf, expbuf ! internal buffers + integer exponent + real mantissa + integer f0, fl, e0, el ! start and end of used buffer F/E + integer fdig, edig ! digits after decimal point F/E format + integer overhd ! overhead + integer p ! position of decimal point + integer digf ! number of digits-1 shown (F-Format) + integer le, l + character*8 rfmt + real xlog + + trc=trunc + if (mod(trc,2) .eq. 1) then ! defaults + wid=1 + fix=0 + dig=4 + if (width .ge. 0) wid=width + else + wid=min(8,len(result)) + if (width .ge. 0) wid=width + fix=max(0,wid/2-1) + dig=1 + endif + if (fixlen .ge. 0) fix=fixlen + if (digits .ge. 0) dig=digits + + wid=min(bufmax, wid, len(result)) + dig=min(bufmax, dig) + + if (x .eq. 0) then + exponent=0 + mantissa=0 + else + xlog=log10(abs(x)) + exponent=int(xlog+100)-100 + mantissa=x/10.0**exponent + endif + + + edig=min(max(wid-4,dig-1),len(result)-4) + fdig=min(max(fix,dig-1-exponent),len(result)-1) + +! F-Format + +11 f0=0 + fl=bufmax+1 ! in case of write error + digf=-1 + if (fdig .lt. -exponent) goto 14 + write(rfmt, '(''(F'',I2.2,''.'',I2.2,'')'')') bufmax, fdig + write(fixbuf, rfmt, err=14) x + +! reduce + + f0=bufmax-fdig + if (exponent .gt. 0) f0=f0-exponent + if (abs(f0) .gt. 99999) goto 19 + do while(f0 .gt. 0 .and. fixbuf(f0:f0) .ne. ' ') + f0=f0-1 + enddo + fl=bufmax-1 + do while(fixbuf(fl+1:fl+1) .eq. ' ') + fl=fl-1 + enddo + overhd=fl+1-f0-len(result) + do while (fixbuf(fl+1:fl+1) .eq. '0' + 1 .and. (overhd .gt. 0 .or. mod(trc,2) .eq. 1)) + fl=fl-1 + overhd=overhd-1 + enddo + if (fixbuf(fl+1:fl+1) .eq. '.' .and. trc .ge. 2) then + overhd=overhd-1 + else + fl=fl+1 + endif + if (overhd .gt. 0) then +12 if (fdig .ge. overhd) then + fdig=fdig-overhd + goto 11 ! try again with less digits + endif + fl=bufmax+1 + endif + digf=fdig+exponent + +! E-Format mantissa + +14 if (x .eq. 0 .or. edig .lt. 0) goto 13 + +15 write(rfmt, '(''(F'',I2.2,''.'',I2.2,'')'')') bufmax-4, edig + write(expbuf(1:bufmax-4), rfmt, err=19) mantissa + + if (exponent .gt. -10) then + if (exponent .lt. 10 .and. exponent .ge. 0) then + le=2 + else + le=3 + endif + else + le=4 + endif + +! reduce + + e0=bufmax-6-edig + if (e0 .gt. 0) then + if (expbuf(e0:e0) .eq. '1') then ! 9.9 was rounded to 10 + exponent=exponent+1 + mantissa=mantissa/10.0 + goto 15 + endif + if (expbuf(e0:e0) .eq. '-') e0=e0-1 + endif + + el=bufmax-5 + do while(expbuf(el+1:el+1) .eq. ' ') + el=el-1 + enddo + overhd=el+le+1-e0-len(result) + do while (expbuf(el+1:el+1) .eq. '0' .and. + 1 (overhd .gt. 0 .or. mod(trc,2) .ne. 0)) + el=el-1 + overhd=overhd-1 + enddo + if (expbuf(el+1:el+1) .eq. '.' .and. trc .ge. 2) then + overhd=overhd-1 + else + el=el+1 + endif + + if (overhd .gt. 0) then + if (edig .ge. overhd) then + edig=edig-overhd + goto 14 ! try again with less digits + endif + el=bufmax+1 + else + write(rfmt, '(''(A,I'',I2.2,'')'')') le-1 + write(expbuf(el+1:el+le), rfmt) 'E',exponent + el=el+le + endif + + +! Compare + + l=fl-f0 + if (l .gt. wid .and. + 1 (edig .gt. digf .or. + 1 edig .eq. digf .and. l .gt. el-e0 .or. + 1 l .gt. len(result))) then ! E-format is better + fixbuf=expbuf + f0=e0 + fl=el + p=bufmax-4-edig + goto 18 + endif + +! F-Format is better +13 p=bufmax-fdig + if (fix .eq. 0 .and. trc .ge. 2) p=p-1 ! Decimal point not needed if fix=0 + +18 l=fl-f0 + if (l .gt. len(result)) then + goto 19 + elseif (p-f0 .gt. wid-fix .or. l .ge. wid) then ! Left just + result=fixbuf(f0+1:fl) + elseif (fl-p .gt. fix) then ! Right just + result=fixbuf(fl-wid+1:fl) + l=wid + else ! Decimal just + result=fixbuf(p+fix-wid+1:fl) + l=fl+wid-p-fix + endif + reslen=min(l, len(result)) + return + +19 result='******' + reslen=len(result) + end + + subroutine cvt_bintim + stop 'CVT_BINTIM: obsolete' + end + +!!------------------------------------------------------------------------------ +!! + real function CVT_RATIO(STR, FAILUREVALUE) !! +!! ========================================== +!! +!! decode a ratio (value1/value) to a real number +!! + character STR*(*) !! string to convert + real FAILUREVALUE !! value to return on failure + + integer i + real r1,r2 + + i=index(str, '/') + if (i .eq. 0) then + read(str,*,err=999,end=999) cvt_ratio + return + else + if (i .eq. 1 .or. i .eq. len(str)) goto 999 + read(str(1:i),*,err=999,end=999) r1 + read(str(i+1:),*,err=999,end=999) r2 + cvt_ratio = r1/r2 + return + endif +999 cvt_ratio=failurevalue + end diff --git a/gen/dat.inc b/gen/dat.inc new file mode 100644 index 0000000..c9913c8 --- /dev/null +++ b/gen/dat.inc @@ -0,0 +1,14 @@ + integer maxtypes, maxcodes + parameter (maxtypes=64, maxcodes=3) + integer ntypes, dtype, year, last_type + character spec*128 + integer desc_hdl(maxtypes) + integer read_hdl(maxtypes) + integer high_hdl(maxtypes) + integer opts_hdl(maxtypes) + + common/dat_handlers/desc_hdl, read_hdl, high_hdl, opts_hdl + 1, ntypes, dtype, year, last_type, spec + + character specin*1, specout*1 + common /specinout/specin,specout diff --git a/gen/dat_2t.f b/gen/dat_2t.f new file mode 100644 index 0000000..283efde --- /dev/null +++ b/gen/dat_2t.f @@ -0,0 +1,198 @@ + subroutine dat_2t +c ----------------- + + external dat_2t_desc +! external dat_2t_high ! this line for raw data files only + external dat_2t_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_2t_desc) + call dat_init_read(dtype, dat_2t_read) + end + + + subroutine dat_2t_desc(text) +! ---------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='2T 2T format (LLB Saclay)' + end + + + subroutine dat_2t_opts +! ---------------------- + print '(x,a)' + 1,'x: x-axis, y: y-axis' + end + + + subroutine dat_2t_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer mcol + parameter (mcol=32) + + character header*1024 + character line*1024, xaxis*8, yaxis*8, name*8, col1*8 + real values(32), s, y, ymon + real tt, tm, ts, td + integer i,j,l,ncol,ccol,xcol,tcol + + + nread=0 + read(lun,'(a)',err=98,end=98) header + if (forced .le. 0) then + if (header(1:11) .ne. '# qh') goto 100 + endif + header(1:1)=' ' + read(lun,'(a)',err=98,end=98) line + if (line(1:1) .ne. '#') goto 100 + line(1:1)=' ' + + xaxis=' ' + yaxis=' ' + + call dat_start_options + call dat_str_option('x', xaxis) + call dat_str_option('y', yaxis) + + call str_upcase(xaxis, xaxis) + call str_upcase(yaxis, yaxis) + + call putval('Instrument=2T',0.0) + + call dat_group(2, putval) + do i=1,mcol + values(i)=0.0 + enddo + ncol=0 + i=1 + read(line, *, err=15,end=15) values +15 call str_get_elem(header, i, name) + if (name .ne. ' ') then + ncol=ncol+1 + if (name .eq. 'm') then + name='Monitor' + ymon=values(ncol) + call putval('Preset=m', 0.0) + else if (name .eq. 't') then + name='Monitor' + ymon=values(ncol) + call putval('Preset=t', 0.0) + endif + call putval(name, values(ncol)) + goto 15 + endif + + read(lun, '(a)') line + if (line(1:1) .ne. '#') goto 100 + read(lun, '(a)') line + if (line(1:1) .ne. '#') goto 100 + line(1:1)=' ' + +12 i=1 + line(len(line):len(line))=' ' + ncol=0 + ccol=0 + xcol=0 + tcol=0 + col1=' ' +31 do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 39 + enddo + l=i + do while (line(i:i) .ne. ' ') + i=i+1 + enddo + ncol=ncol+1 + if (ncol .eq. 1) col1=line(l:i) + if (line(l:i) .eq. yaxis .or. yaxis .eq. ' ' + 1 .and. line(l:i) .eq. 'comptage') ccol=ncol + if (line(l:i) .eq. xaxis) xcol=ncol + if (line(l:i) .eq. 'K') tcol=ncol + goto 31 + +39 if (yaxis .eq. ' ') yaxis='comptage' + if (ccol .eq. 0) then + print *,'no values found for ',yaxis + goto 99 + endif + if (xcol .eq. 0) then + if (xaxis .ne. ' ') then + print *,'no values found for ',xaxis,', take ',col1 + endif + xcol=1 + xaxis=col1 + endif + + call dat_group(2, putval) + call putval('XAxis='//xaxis, 0.0) + call putval('YAxis='//yaxis, 0.0) + call dat_group(1, putval) + + l=min(mcol,max(xcol,ccol,tcol)) + tm=0 + ts=0 + +4 read(lun,*,err=19,end=9) (values(j),j=1,l) + if (nread .ge. nmax) goto 29 + y=values(ccol) + if (y .gt. 0) then + s=sqrt(y) ! statistical error of detector + else + s=1 + endif + nread=nread+1 + xx(nread)=values(xcol) + yy(nread)=y + ss(nread)=s + ww(nread)=ymon + if (tcol .ne. 0) then + tt=values(tcol) + td=(tt-tm)/nread + tm=tm+td ! mean temp. + ts=ts+(tt-tm)**2+td*td*(nread-1) ! sum of (temp(i)-mean)**2 + endif + goto 4 + +9 close(lun) + call putval('Monitor', ymon) + if (tcol .ne. 0) then + call putval('Temp', tm) + if (nread .gt. 1) call putval('dTemp', sqrt(ts/(nread-1))) + endif + return + +19 print *,'DAT_2T: error at point ',nread + goto 4 +29 print *,'DAT_2T: too many points' + goto 100 +98 if (forced .le. 0) goto 100 +99 print *,'DAT_2T: error during read' + rewind lun + nread=-2 + return +100 nread=-1 + rewind lun + end diff --git a/gen/dat_5c2.f b/gen/dat_5c2.f new file mode 100644 index 0000000..46bbb84 --- /dev/null +++ b/gen/dat_5c2.f @@ -0,0 +1,133 @@ + subroutine dat_5c2 +c ------------------ + + external dat_5c2_desc + external dat_5c2_opts + external dat_5c2_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_5c2_desc) + call dat_init_opts(dtype, dat_5c2_opts) + call dat_init_read(dtype, dat_5c2_read) + end + + + subroutine dat_5c2_desc(text) +! ----------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='5C2 Saclay instrument 5c2' + end + + + subroutine dat_5c2_opts +! ----------------------- + print '(x,a)' + 1,'from,to: dataset range' + end + + + subroutine dat_5c2_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer i, idx, n, i1, i2, j, idum + real h, k, l, step, rdum + real ymon + character line*132 + + + read(lun, '(a)', err=100, end=100) line + if (line(1:6) .ne. 'File= ') then + if (forced .le. 0) goto 100 + rewind lun + endif + + call dat_start_options + i1=0 + call dat_int_option('from', i1) + i2=0 + call dat_int_option('to', i2) + if (i2 .eq. 0) then + if (i1 .eq. 0) then + i1=1 + else + i2=i1 + endif + endif + + call dat_get_index(idx) + if (idx .eq. 0) then + if (i2 .gt. i1) then + print *,'for 5C2 files only one dataset allowed' + endif + else + i1=i1+idx-1 + if (i1 .gt. i2 .and. i2 .ne. 0) goto 98 + endif + + do i=1,6 + read(lun, *, err=100, end=100) + enddo + ymon=0 + do i=1,i1 + read(lun, *, end=97, err=99) h,k,l,idum,rdum,rdum,idum,n + read(lun, *, end=99, err=99) rdum,rdum,rdum,step + read(lun,'(20f5.0)',err=99,end=99) (yy(j),j=1,n),(ww(j),j=1,n) + enddo + + if (n .gt. nmax) goto 99 + do j=1,n + ss(j)=sqrt(max(1.0,yy(j))) + xx(j)=(j-n/2-1)*step + ymon=ymon+ww(j) + enddo + ymon=ymon/n + + write(line,'(3(a,f8.3))') 'h=',h,' k=',k,' l=',l + call putval('Monitor', ymon) + call putval('Title='//line, 0.0) + call putval('h', h) + call putval('k', k) + call putval('l', l) + call putval('step', step) + call putval('XAxis=omega',0.0) + + write(line, '(i4)') i1 + call putval('Range='//line,0.0) + + close(lun) + nread=n + return + +97 print *,'DAT_5C2: Only ',n,' scans in this file' +98 nread=-2 + rewind lun + return +99 print *,'DAT_5C2: error during read' + nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_c.c b/gen/dat_c.c new file mode 100644 index 0000000..648c7cf --- /dev/null +++ b/gen/dat_c.c @@ -0,0 +1,302 @@ +#include +#include +#include +#include "myc_fortran.h" + +void F_FUN(dat_axis_range)(float *xin, int *nin, float *xstart, float *xend, float *pMargin, int *i1, int *i2) { + int i; + float x1, x2, margin; + + margin=*pMargin; + if (margin<0) margin=-margin; + if (*xstart>*xend) { + x1=*xend-margin; + x2=*xstart+margin; + } else { + x1=*xstart-margin; + x2=*xend+margin; + } + *i1=*nin; + *i2=0; + for (i=0; i<*nin; i++) { + if (x1 < xin[i] && xin[i] < x2) { + if (i>*i2) *i2=i; + if (i<*i1) *i1=i; + } + } +} + +void dat_fillin(float *src, float *dst, int size, float *wsum, int j, float weight) { + int k; + + dst += j*size; + if (wsum!=NULL) wsum[j] += weight; + for (k=0; k| +** +** The values from the source are distributed to the destination according to the overlap +** of the intervals. Output channel 0 will get a small part from input channel 0 and +** a large part from channel 1, output channel 5 will get all of channel 4 plus +** some part of channel 3 and channel 5. +** +** xin x-values (size nin) (may be NULL, if x-values are [0.0,1.0,2.0,3.0,4.0,....]) +** src source (size grpsize*nin*nblocks) +** xstart start value +** xs x-step for output +** nout number of output channels +** dst destination (size grpsize*nout*nblocks) +** wout output weights (size nout, may be NULL if not needed) +*/ + int i, j, m, ja, jb, bsize; + float w, x, xl, xr, xa, xb, dx0, dx1, dx; + + assert(nin>=1 && src !=NULL && grpsize>0 && nblocks>0 && xs!=0.0 && nout>0 && dst!=NULL && wout!=NULL); + for (j=0; j-0.5) { + if (xb<0.5) { + w=1.0; + } else { + w=(0.5-xa)/dx; + } + } else { + if (xb<0.5) { + w=(xb+0.5)/dx; + } else { + w=1.0; + } + } + if (w>0.0) { + dat_fillin(src, dst, grpsize, wout, 0, w); + } + src+=grpsize; + } + } else { + for (i=0; ixa) ja--; + xb=xa+dx; + jb=xb; if (jb=nout) { + jb=nout; + if (xb>nout) xb=nout; + } + if (ja=0) dat_fillin(src, dst, grpsize, wout, ja, (1-x)*w); + if (jb=0) dat_fillin(src, dst, grpsize, wout, ja, xl*xl*w/2); + if (ja+2==jb) { + dat_fillin(src, dst, grpsize, wout, ja+1, ((1-xl/2)*xl+(1-xr/2)*xr)*w); + } else { + dat_fillin(src, dst, grpsize, wout, ja+1, ((1-xl/2)*xl+0.5)*w); + for (j=ja+1; j32) return NX_ERROR; /* for now, support only f32, i32 and f64 */ + ncells=1; + for (i=0; i<*rank; i++) { + cstart[i]=start[*rank-i-1]; + csize[i]=size[*rank-i-1]; + ncells=ncells*size[i]; + } + for (;i<32;i++) { + cstart[i]=0; + csize[i]=1; + } + data=calloc(ncells, cellsize); + if (data==NULL) return NX_ERROR; + flts=(float *)data; + + status=NXgetslab(handle, data, cstart, csize); + if (status!=NX_OK) { free(data); return NX_ERROR; } + + if (type==NX_INT32) { /* convert int32 to float 32 */ + ip=(int *)data; + for (i=0; i=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer i, idx, nranges, i1, i2, j, m, cnt(10) + real temp, h, k, l, step, offset, junk, mf + real twoth, omega, chi, phi, ymon + character line*132, date*20, tail*32 + + + read(lun, '(a)', err=100, end=100) line + if (line(1:3) .ne. 'CCL') then + if (forced .le. 0) goto 100 + rewind lun + endif + + if (line(4:) .eq. ' ') then ! new syntax + do while (line(1:6) .ne. '# data' + 1 .and. line(1:5) .ne. '#data') + read(lun, '(a)', err=100, end=100) line + enddo + endif + + call dat_start_options + i1=0 + call dat_int_option('from', i1) + i2=0 + call dat_int_option('to', i2) + if (i2 .eq. 0) then + if (i1 .eq. 0) then + i1=1 + else + i2=i1 + endif + endif + + call dat_get_index(idx) + if (idx .eq. 0) then + if (i2 .gt. i1) then + print *,'for CCL files only one dataset allowed' + endif + else + i1=i1+idx-1 + if (i1 .gt. i2 .and. i2 .ne. 0) goto 98 + endif + + nranges=0 + do i=1,i1-1 + nranges=i-1 + read(lun, *, err=97, end=97) + read(lun, *, err=99, end=99) nread + do j=1,nread,10 + read(lun,*,err=99, end=99) + enddo + enddo + + + if (nread .ge. nmax) goto 99 + ymon=1 + read(lun, '(a)', err=97, end=97) line + read(line, *, err=33, end=33) junk,h,k,l,twoth,omega,chi,phi + 1 ,junk,junk +33 read(lun, '(i3,f8.0,f10.0,f8.0,x,a)', err=99, end=99) + 1 nread, step , ymon, temp, tail + i=index(tail,':') + mf=-9999 + if (i .gt. 13) then + date=tail(i-13:) + if (tail(1:12) .ne. ' -0.000000') then + read(tail, *, err=34, end=34) mf +34 endif + else + date=tail + endif + + write(line,'(3(a,f8.3))') 'h=',h,' k=',k,' l=',l + call putval('Monitor', ymon) + call putval('Temp', temp) + call putval('Date='//date, 0.0) + call putval('Title='//line, 0.0) + call putval('two_theta', twoth) + call putval('omega', omega) + call putval('chi', chi) + call putval('phi', phi) + call putval('h', h) + call putval('k', k) + call putval('l', l) + call putval('step', step) + if (mf .ne. -9999) then + call putval('magfield', mf) + endif + call putval('XAxis=omega',0.0) + + write(line, '(i4)') i1 + call putval('Range='//line,0.0) + + offset=omega-0.5*step*(nread+1) + do j=1,nread,10 + read(lun,'(10i8)',err=99, end=99) cnt + do m=j,min(nread,j+9) + xx(m)=offset+step*m + yy(m)=cnt(m-j+1) + ss(m)=sqrt(float(max(1,cnt(m-j+1)))) + ww(m)=ymon + enddo + enddo + + close(lun) + return + +97 print *,'DAT_CCL: Only ',nranges,' scans in this file' +98 nread=-2 + rewind lun + return +99 print *,'DAT_CCL: error during read' + nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_d1a.f b/gen/dat_d1a.f new file mode 100644 index 0000000..47174c6 --- /dev/null +++ b/gen/dat_d1a.f @@ -0,0 +1,118 @@ + subroutine dat_d1a +c ------------------- + + external dat_d1a_desc + external dat_d1a_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_d1a_desc) + call dat_init_read(dtype, dat_d1a_read) + end + + + subroutine dat_d1a_desc(text) +! ----------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='D1A ILL D1A6 data format' + end + + + subroutine dat_d1a_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + character line*132, title*80 + integer j,i,ndet,l + integer ival(2,10) + real temp, xstep, thmin, ymon + + nread=0 + xstep=0 + ymon=0 + + read(lun,'(a)',err=900,end=900) line + + if (line(1:4) .ne. 'D1A6') then + rewind lun + goto 900 + endif + + call dat_start_options + + call dat_group(1, putval) + + title=line(6:) + read(lun,'(16x,f8.0,i8)', err=901,end=901) xstep, ndet + read(lun,'(f8.0)', err=901,end=901) thmin + read(lun,'(f8.0,8x,f8.0)', err=901,end=901) ymon, temp + + if (xstep .eq. 0) goto 901 + + j=-1 +1 read(lun,'(10(i2,i6))',err=902,end=9) ival + if (ival(2,1) .eq. -1000) goto 9 + do i=1,10 + if (ival(1,i) .gt. 0 .and. ival(2,i) .ge. 0) then + if (nread .ge. nmax) then + print *,'DAT_LNSP: Too many datapoints, truncated' + goto 9 + endif + nread=nread+1 + xx(nread)=(i+j)*xstep+thmin + yy(nread)=ival(2,i) + ss(nread)=max(1.0,sqrt(yy(nread)/float(ival(1,i)))) + ww(nread)=ymon*ival(1,i) + endif + enddo + j=j+10 + goto 1 + +9 call dat_group(3, putval) + call putval('XAxis=2-Theta [deg]', 0.0) + call putval('YAxis=Intensity', 0.0) + call dat_group(1, putval) + call putval('Monitor', ymon) + call str_trim(title, title, l) + call putval('Title='//title(1:l), 0.0) + call putval('Temp', temp) + +990 close(lun) + return + +! error messages + +900 nread=-1 + rewind lun + return + +901 print *,'DAT_D1A: Error in header' + goto 990 + +902 print *,'DAT_D1A: Error in intensity block' + goto 990 + +99 print *,'DAT_D1A: error during read' + rewind lun + nread=-2 + return + end diff --git a/gen/dat_fda.f b/gen/dat_fda.f new file mode 100644 index 0000000..20f1e67 --- /dev/null +++ b/gen/dat_fda.f @@ -0,0 +1,168 @@ + subroutine dat_fda +c -------------------- + + external dat_fda_desc + external dat_fda_opts + external dat_fda_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_fda_desc) + call dat_init_opts(dtype, dat_fda_opts) + call dat_init_read(dtype, dat_fda_read) + end + + + subroutine dat_fda_desc(text) +! ------------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='FDA FDA (focus data analysis) output files' + end + + + subroutine dat_fda_opts +! ----------------------- + print '(x,a)' + 1,'from,to: dataset range' + end + + + subroutine dat_fda_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer i, i1, i2, j, idx, m, j0, ipdp, iset, iostat + real x, y, s, gval, f + character line*132, zaxis*132 + + zaxis='z' + read(lun, '(a)',err=100,end=100) line + if (line(1:4) .ne. '#FDA' .and. + 1 line .ne. '#DAVE ASCII OUTPUT') goto 100 +1 read(lun, '(a)', err=100, end=100) line + i = index(line,':') + if (i .gt. 1) then + call str_lowcase(line(1:i), line(1:i)) + if (line(i+1:i+1) .eq. ' ') i=i+1 + if (line(1:i) .eq. '#instrument:') then + call putval('Instrument='//line(i+1:), 0.0) + else if (line(1:i) .eq. '#sample:') then + call putval('Sample='//line(i+1:), 0.0) + else if (line(1:i) .eq. '#title:') then + call putval('Title='//line(i+1:), 0.0) + else if (line(1:i) .eq. '#x units:') then + call putval('XAxis='//line(i+1:), 0.0) + else if (line(1:i) .eq. '#y units:') then + call putval('YAxis='//line(i+1:), 0.0) + else if (line(1:i) .eq. '#group label:') then + call putval('ZAxis='//line(i+1:), 0.0) + zaxis = line(i+1:) + else if (line(1:12) .eq. '#temperature') then + f = 0 + read(line(i+1:), *, iostat=iostat) f + if (f .ne. 0) call putval('Temp', f) + endif + else + call str_lowcase(line, line) + endif + if (line .ne. '#begin') goto 1 + + call fit_dat_pdp_idx(zaxis, ipdp) + + call dat_start_options + i1=0 + call dat_int_option('from', i1) + i2=0 + call dat_int_option('to', i2) + + if (i2 .eq. 0) then + if (i1 .eq. 0) then + i1=1 + i2=999999 + else + i2=i1 + endif + endif + call dat_get_index(idx) + if (idx .ne. 0) then + i1=i1+idx-1 + i2=i1 + endif + + j=0 + iset=1 + gval=0 + m=0 + +3 read(lun, '(a)', err=90, end=90) line +4 call str_lowcase(line, line) + if (line(1:13) .eq. '#group value:') then + gval=0 + read(line(14:), *, err=41, end=41) gval +41 continue + endif + if (line(1:1) .eq. '#') goto 3 + + j0=j + +5 continue + read(line, *, err=20,end=20) x,y,s + if (s .gt. 0.0 .and. iset .ge. i1) then + if (j .ge. nmax) then + i2=iset + print *,'DAT_FDA: too many data points, truncated' + goto 29 + endif + j=j+1 + ww(j)=1.0 + ss(j)=s + yy(j)=y + xx(j)=x + endif +20 continue + read(lun, '(a)', err=29, end=29) line + if (line(1:1) .ne. '#') goto 5 + +29 iset=iset+1 + + if (j .gt. j0) then + m=m+1 + if (ipdp .ne. 0) then + call fit_dat_pdp_set(ipdp, m, gval) + endif + call fit_dat_table(m, 1, j-j0) + endif + if (iset .le. i2) goto 4 + +90 nread=j + call putval('Monitor', 0.0) + close(lun) + return + +99 print *,'DAT_FDA: error during read' +98 nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_fit3.f b/gen/dat_fit3.f new file mode 100644 index 0000000..faf468d --- /dev/null +++ b/gen/dat_fit3.f @@ -0,0 +1,144 @@ + subroutine dat_fit3 +c ------------------- + + external dat_fit3_desc + external dat_fit3_read + + external handler + + integer dtype/0/ + + call dat_init_desc(dtype, dat_fit3_desc) + call dat_init_read(dtype, dat_fit3_read) + return + + entry dat_fit3_replace(handler) + call dat_init_read(dtype, handler) + end + + + subroutine dat_fit3_desc(text) +! ------------------------------ + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='FIT3 Fit data file' + end + + + subroutine dat_fit3_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer n,nu0,i,j,ififu0 + real ymon0 + character line*132 + external dat_fit3_val + real y, s + + + read(lun, '(A)',err=100,end=100) line + + if (line(1:8) .ne. 'FitSave ' .or. line(9:11) .lt. '3.3') goto 100 + + if (line(9:11) .lt. '3.4') then + read(lun,*,err=100,end=100) ! filename + endif + nu0=0 + read(lun, *, err=99,end=99) nu0,ififu0 + do i=1,nu0 + read(lun,*,err=99,end=99) + enddo + if (ififu0 .eq. 7) read(lun,*,err=99,end=99) + + if (line(9:11) .lt. '3.4') then + + n=0 + ymon0=0 + read(lun, *, err=99,end=99) n,ymon0 + if (ymon0 .le. 0) ymon0=1 + call putval('Monitor', ymon0) + + else + + call dat_delimiters(';', '=', '''') + +10 read(lun, '(a)', err=99,end=99) line + call str_trim(line, line, i) + if (line(1:i) .eq. ' ') goto 19 + j=1 +11 if (line(j:j) .eq. ' ') then + j=j+1 + goto 11 + endif + call dat_group(j-1, putval) + call dat_intprt(line(j:i), dat_fit3_val, putval) + goto 10 +19 continue + + endif + + i=0 +20 i=i+1 + if (i .gt. nmax) then + print *,'too many data points --> truncated' + goto 29 + endif + read(lun,'(a)',err=99,end=29) line + j=index(line,'/') ! for compatibility with versions 3.3 and older + if (j .gt. 0) line(j:)=' ' ! " +! read(line,'(bn,4f20.0,i20)') xx(i),y,s,ww(i),j + read(line,*,err=99,end=99) xx(i),y,s,ww(i),j + ss(i)=s + yy(i)=y + nread=i + goto 20 + +29 close(lun) + return + +99 print *,'error in FitSave file' + nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end + + + subroutine dat_fit3_val(str, val, putval) + + character*(*) str + real val + external putval + + integer i + + if (val .eq. 0) then + i=index(str, '=') + else + i=0 + endif + if (i .gt. 1) then + if (str(1:i-1) .eq. 'File') return + endif + call putval(str, val) + end diff --git a/gen/dat_frm.f b/gen/dat_frm.f new file mode 100644 index 0000000..ee19f90 --- /dev/null +++ b/gen/dat_frm.f @@ -0,0 +1,233 @@ + subroutine dat_frm +c ------------------ + + external dat_frm_desc + external dat_frm_opts + external dat_frm_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_frm_desc) + call dat_init_opts(dtype, dat_frm_opts) + call dat_init_read(dtype, dat_frm_read) + end + + + subroutine dat_frm_desc(text) +! ----------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='FRM PUMA & PANDA at FRM2 Munich' + end + + + subroutine dat_frm_opts +! ----------------------- + print '(x,a)' + 1,'x: x-axis (default: first column or first variable' + 1,' with step in Qscan)' + 1,'y: y-axis (default: last column)' + 1,'mon: monitor (default: mon1)' + end + + + subroutine dat_frm_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer mcol + parameter (mcol=64) + real y,s,r,f,ymon,values(mcol) + integer i,j,l,errcnt,ncol + integer xcol,ycol,mncol + integer iostat + character line*1024 + character xaxis*16, yaxis*16, moncol*16, col1*16 + integer headcnt + real qh,qk,ql,en,dh,dk,dl,de + + headcnt=0 +1 read(lun,'(a)',err=100,end=100) line + headcnt=headcnt+1 + if (line(1:15) .eq. 'filename : ') then + goto 1 + else if (line(1:15) .eq. 'created at : ') then + call putval('Date='//line(16:), 0.0) + goto 1 + else if (line(1:15) .eq. 'instrument : ') then + call putval('Instrument='//line(16:), 0.0) + goto 1 + else if (line(1:15) .eq. 'user : ') then + call putval('User='//line(16:), 0.0) + goto 1 + else if (line(14:15) .eq. ': ') then + goto 1 + endif + if (headcnt .lt. 3 .and. forced .le. 0) goto 100 + + call dat_start_options + xaxis=' ' + call dat_str_option('x', xaxis) + yaxis=' ' + call dat_str_option('y', yaxis) + moncol=' ' + call dat_str_option('mon', moncol) + if (moncol .eq. ' ') then + moncol='mon1' + elseif (moncol .gt. '0' .and. moncol .le. '9') then + moncol='mon'//moncol(1:) + endif + +2 read(lun,'(a)',err=100,end=100) line + if (line(1:10) .ne. 'scan data:') goto 2 + + nread=0 + errcnt=0 + + read(lun, '(a)', err=99,end=99) line + if (xaxis .eq. ' ') then + i = index(line, 'Qscan') + if (i .ne. 0 .and. xaxis .eq. ' ') then + line=line(i+5:) + i=index(line,'(') + if (i .ne. 0) line(i:i)=' ' + i=index(line,')') + if (i .ne. 0) line(i:i)=' ' + read(line, *, iostat=iostat) qh,qk,ql,en,dh,dk,dl,de + call putval('QH', qh) + call putval('QK', qk) + call putval('QL', ql) + call putval('EN', en) + call putval('DQH', qh) + call putval('DQK', dk) + call putval('DQL', dl) + call putval('DEN', de) + if (dh .ne. 0) then + xaxis='h' + elseif (dk .ne. 0) then + xaxis='k' + elseif (dl .ne. 0) then + xaxis='l' + elseif (de .ne. 0) then + xaxis='E' + endif + else +! ignore other scan types + endif + endif + + read(lun,'(a)',err=99,end=99) line + + i=1 + line(len(line):len(line))=' ' + ncol=0 + xcol=0 + ycol=0 + mncol=0 +31 do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 39 + enddo + l=i + do while (line(i:i) .ne. ' ') + i=i+1 + enddo + if (line(l:i) .eq. ';') goto 31 + ncol=ncol+1 + if (ncol .eq. 1) col1=line(l:i) + if (line(l:i) .eq. yaxis .and. ycol .eq. 0) then + ycol=ncol + elseif (line(l:i) .eq. xaxis .and. xcol .eq. 0) then + xcol=ncol + elseif (line(l:i) .eq. moncol .and. mncol .eq. 0) then + mncol=ncol + endif + goto 31 + +39 if (ycol .eq. 0) then + ycol=ncol + yaxis=line(l:) + endif + if (xcol .eq. 0) then + xcol=1 + xaxis=col1 + endif + + call putval('XAxis='//xaxis, 0.0) + call putval('YAxis='//yaxis, 0.0) + +! ignore units + read(lun, '(a)', err=99,end=99) line + ymon=0 + l=min(mcol,max(xcol,ycol,mncol)) + +40 read(lun,'(a)',end=88,err=88) line + if (line(2:5) .eq. '****') goto 88 + i=index(line,';') + if (i .ne. 0) line(i:i)=' ' + + read(line,*,err=99,end=99) (values(j),j=1,l) + if (nread .ge. nmax) goto 29 + + if (mncol .eq. 0) then + if (ymon .eq. 0) ymon=1. + r=ymon + else + r=values(mncol) + if (r .gt. 0) then + if (ymon .eq. 0) ymon=r + else + if (ymon .eq. 0) ymon=1. + r=ymon + endif + endif + f=ymon/r + if (f .le. 0.0) f=1.0 + + nread=nread+1 + xx(nread)=values(xcol) + y=values(ycol) + if (y .gt. 0) then + s=sqrt(y) ! statistical error of detector + else + s=1 + endif + yy(nread)=y*f + ss(nread)=s*f + ww(nread)=r + goto 40 + +29 print *,'too many points - truncated' +88 close(lun) + call putval('NP', nread*1.0) + call putval('Monitor', ymon) + return + +99 nread=-2 + rewind lun + print *,'DAT_FRM: error during read' + call putval('Monitor', 0.0) + return + +100 nread=-1 + rewind lun + call putval('Monitor', 0.0) + end diff --git a/gen/dat_fullp.f b/gen/dat_fullp.f new file mode 100644 index 0000000..a6c6bfb --- /dev/null +++ b/gen/dat_fullp.f @@ -0,0 +1,196 @@ + subroutine dat_fullp +c -------------------- + + external dat_fullp_desc + external dat_fullp_opts + external dat_fullp_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_fullp_desc) + call dat_init_opts(dtype, dat_fullp_opts) + call dat_init_read(dtype, dat_fullp_read) + end + + + subroutine dat_fullp_desc(text) +! ------------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='FULLP Fullprof output (Prf=3 like for Kaleida)' + end + + + subroutine dat_fullp_opts +! ------------------------- + print '(x,a)' + 1,'x: xaxis (2theta,d,Q)' + end + + + subroutine dat_fullp_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + real none + parameter (none=-8.7654e29) + real x, y4(4), ymax, dmax, shift, lambda, nan_value, diffshift + integer i,j,jex,npeak,nphase,npkt,nexcl,ntic(8),nlin(8) + real fact + integer istyle(5) + real excl1(30),excl2(30) + character title*132, line*132 + character xaxis*64 + + + read(lun,'(a)', err=100, end=100) title + if (title(1:1) .eq. ' ') title=title(2:) + read(lun,*, err=100, end=100) nphase, npkt, lambda + if (nphase .gt. 8) goto 100 + read(lun,*, err=100, end=100) (ntic(j),j=1,nphase) + 1 ,(nlin(j),j=1,nphase),nexcl + do j=1,nphase + do i=1,nlin(j) + read(lun,*,err=100,end=100) ! skip propagation vectors + enddo + enddo + do j=1,nexcl + read(lun,*,err=100,end=100) excl1(min(j,30)), excl2(min(j,30)) + enddo + read(lun,'(a)', err=100, end=100) line + i=index(line, 'Yobs') + if (i .eq. 0) goto 100 + i=index(line, 'Ycal') + if (i .eq. 0) goto 100 + i=index(line, 'Backg') + if (i .eq. 0) goto 100 + i=index(line, char(9)) + if (i .le. 1) goto 100 + + call dat_start_options + xaxis=' ' + call dat_str_option('x', xaxis) + + if (line(2:i-1) .eq. '2Theta') then + call dat_powder_init(lambda, '2theta', xaxis) + if (xaxis .eq. ' ') then + call putval('XAxis='//line(2:i-1), 0.0) + else + call putval('XAxis='//xaxis, 0.0) + endif + else + call dat_powder_init(0.0, ' ', ' ') + endif + + npeak=0 + do j=1,nphase + npeak=npeak+ntic(j) ! calc number of peaks + enddo + + ymax=0.0 + nread=npeak+npkt + if (nread .ge. nmax) goto 99 + + call gra_get_nan_value(nan_value) + + jex=1 + dmax=-1.0e30 + do i=1,npkt + read(lun,*, err=99, end=99) x,y4 + if (i .eq. 1) then + shift=y4(2)-y4(4) + diffshift=y4(3) + endif + fact=1.0 + call dat_powder_trf(x, xx(npeak+i), fact) + yy(npeak+i)=y4(1)*fact ! obs + ss(npeak+i)=1 ! we do not have the error + ww(npeak+i)=1 + ymax=max(ymax,yy(npeak+i)) + y4(1)=(y4(4)+shift)*fact ! unshifted background + y4(2)=y4(2)*fact ! cal + y4(3)=(y4(3)-diffshift)*fact ! unshifted diff + dmax=max(dmax,y4(3)) + +10 if (jex .le. nexcl) then + if (x .ge. excl2(jex)) then + jex=jex+1 + goto 10 + endif + if (x .gt. excl1(jex)) then ! value is within excl. region + if (yy(nread) .eq. nan_value) goto 15 + y4(1)=nan_value + y4(2)=nan_value + y4(3)=nan_value + endif + endif + do j=1,3 + nread=nread+1 + if (nread .gt. nmax) then + print *,'too much data' + goto 99 + endif + xx(nread)=xx(npeak+i) + yy(nread)=y4(j) + ss(nread)=1 + ww(nread)=1 + enddo +15 continue + enddo + do i=1,npeak + read(lun,*, err=99, end=99) x, yy(i) + call dat_powder_trf(x, xx(i), fact) + yy(i)=(yy(i)-ymax/32)*0.5 + ss(i)=ymax/100 + ww(i)=1 + enddo + close(lun) + shift=-nphase*ymax/32-dmax + do i=npeak+npkt+3,nread,3 ! shift diff + if (yy(i) .ne. nan_value) then + yy(i)=yy(i)+shift + endif + enddo + call fit_dat_table(1,1,npeak) + call fit_dat_table(2,1,npkt) + call fit_dat_table(3,3,(nread-npeak-npkt)/3) + + call dat_group(1, putval) + call putval('Title='//title, 0.0) + call putval('lambda', lambda) + call putval('Monitor', 0.0) + istyle(1)=8 + istyle(2)=6 + istyle(3)=-10 + istyle(4)=-10 + istyle(5)=-10 + call fit_style(5, istyle) + call fit_legend('|obs|bgr|cal|dif') + call fit_colors(999) + return + +99 print *,'DAT_FULLP: error during read' + nread=-2 + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_ida.f b/gen/dat_ida.f new file mode 100644 index 0000000..400d065 --- /dev/null +++ b/gen/dat_ida.f @@ -0,0 +1,165 @@ + subroutine dat_ida +c ------------------ + + external dat_ida_desc + external dat_ida_opts + external dat_ida_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_ida_desc) + call dat_init_opts(dtype, dat_ida_opts) + call dat_init_read(dtype, dat_ida_read) + end + + + subroutine dat_ida_desc(text) +! ----------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='IDA IDA output files' + end + + + subroutine dat_ida_opts +! ----------------------- + print '(x,a)' + 1,'from,to: dataset range' + end + + + subroutine dat_ida_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer i, i1, i2, j, idx, m, j0, ipdp, iset, nspec + real x, y, s, z + character line*132 + + read(lun, '(a)',err=100,end=100) line + if (line .ne. 'ASCII-96') goto 100 +1 read(lun, '(a)', err=100, end=100) line + if (line(1:4) .ne. 'x') goto 1 + call putval('XAxis='//line(5:28),0.0) + read(lun, '(a)', err=100, end=100) line + if (line(1:4) .ne. 'y') then + print *,'missing line starting with "y"' + goto 99 + endif + call putval('YAxis='//line(5:28),0.0) + read(lun, '(a)', err=99, end=99) line + if (line(1:4) .eq. 'z1') then + call putval('ZAxis='//line(5:28),0.0) + call fit_dat_pdp_idx(line(5:28), ipdp) + else + ipdp=0 + endif +2 read(lun, '(a)', err=99, end=99) line + if (line(1:4) .ne. '&eob') goto 2 + read(lun, '(a)', err=99, end=99) line + if (line(1:5) .eq. '(a80)') then + read(lun, '(a)', err=99, end=99) line + i=index(line,char(0)) + if (i .gt. 1) then + call putval('Instrument='//line(1:i-1), 0.0) + endif + read(lun, '(a)', err=99, end=99) line + i=index(line,char(0)) + if (i .gt. 2) then + call putval('Title='//line(2:i-1), 0.0) + endif + endif + + call dat_start_options + i1=0 + call dat_int_option('from', i1) + i2=0 + call dat_int_option('to', i2) + + if (i2 .eq. 0) then + if (i1 .eq. 0) then + i1=1 + i2=999999 + else + i2=i1 + endif + endif + call dat_get_index(idx) + if (idx .ne. 0) then + i1=i1+idx-1 + i2=i1 + endif + +3 read(lun, '(a)', err=99, end=99) line + if (line(1:9) .ne. '&spectrum') goto 3 + j=0 + iset=1 + m=0 +4 read(lun, '(a)', err=99, end=99) line + if (ipdp .ne. 0) then + read(line, *, err=99, end=99) nspec,z + else + read(line, *, err=99, end=99) nspec + endif + + j0=j + do i=1,nspec + read(lun, *, err=20,end=29) x,y,s + if (s .gt. 0.0 .and. iset .ge. i1) then + if (j .ge. nmax) then + i2=iset + print *,'DAT_IDA: too many data points, truncated' + goto 29 + endif + j=j+1 + ww(j)=1.0 + ss(j)=s + yy(j)=y + xx(j)=x + endif +20 continue + enddo +29 if (j .gt. j0) then + m=m+1 + if (ipdp .ne. 0) then + call fit_dat_pdp_set(ipdp, m, z) + endif + call fit_dat_table(m, 1, j-j0) + endif + read(lun, '(a)', err=50, end=50) line + if (line(1:9) .eq. '&spectrum' .and. iset .lt. i2) then + iset=iset+1 + goto 4 + endif + +50 nread=j + call putval('Monitor', 0.0) + close(lun) + return + +99 print *,'DAT_IDA: error during read' +98 nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_init.f b/gen/dat_init.f new file mode 100644 index 0000000..4a4c2e9 --- /dev/null +++ b/gen/dat_init.f @@ -0,0 +1,28 @@ + subroutine dat_init +c +c initialize interfaces to all supported data file types +c + logical init/.true./ + + if (init) then + call dat_tasmad + call dat_lnsp + call dat_d1a + call dat_nexus + call dat_oldtas + call dat_rita + call dat_sics + call dat_ccl + call dat_frm + call dat_5c2 + call dat_inx + call dat_ida + call dat_fda + call dat_fullp + call dat_spec + call dat_2t + call dat_fit3 + call dat_table + init=.false. + endif + end diff --git a/gen/dat_inx.f b/gen/dat_inx.f new file mode 100644 index 0000000..f8ead54 --- /dev/null +++ b/gen/dat_inx.f @@ -0,0 +1,138 @@ + subroutine dat_inx +c ------------------ + + external dat_inx_desc + external dat_inx_opts + external dat_inx_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_inx_desc) + call dat_init_opts(dtype, dat_inx_opts) + call dat_init_read(dtype, dat_inx_read) + end + + + subroutine dat_inx_desc(text) +! ----------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='INX INX output files' + end + + + subroutine dat_inx_opts +! ----------------------- + print '(x,a)' + 1,'from,to: dataset range' + end + + + subroutine dat_inx_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer i, n, i1, i2, j, idx + integer nlines, nzone(6) + real angle, einc, qinc, temp, dTau, x, y, s + character line*132 + + + read(lun, '(8i5)', err=100,end=100) nlines, nzone, nread + n=0 + do i=1,5 + n=n+nzone(i) + enddo + if (nzone(1) .ne. 1 .or. nzone(2) .ne. 2 + 1 .or. n .ne. nlines-nread) then + if (forced .le. 0) goto 100 + endif + + call dat_start_options + i1=1 + call dat_int_option('from', i1) + i2=i1 + call dat_int_option('to', i2) + + call dat_get_index(idx) + + if (idx .eq. 0) then + if (i2 .gt. i1) then + print *,'for INX files only one dataset allowed' + endif + else + i1=i1+idx-1 + if (i1 .gt. i1) goto 98 + endif + + write(line(1:3), '(i3)') i1 + call putval('Range='//line(1:3),0.0) + do i=1,i1-1 + do j=1,nlines + read(lun,*,err=99,end=99) + enddo + read(lun, '(8i5)', err=99,end=99) nlines, nzone, nread + enddo + + read(lun, '(a)', err=99,end=99) line + call putval('Title='//line,0.0) + read(lun, '(f7.0,2f8.0,f9.0,f6.0)', err=99,end=99) + 1 angle, einc, qinc, temp + call putval('two_theta', angle) + call putval('Ei', einc) + call putval('Temp', temp) + read(lun, '(24x,f8.0)', err=99,end=99) dTau + call putval('dTau', dTau) + + n=nlines-nread-3 + do i=1,n + read(lun,*,err=99,end=99) + enddo + j=0 + do i=1,nread + read(lun, *, err=20,end=29) x,y,s + if (s .gt. 0.0) then + if (j .ge. nmax) then + print *,'DAT_INX: too many data points, truncated' + goto 29 + endif + j=j+1 + ww(j)=1.0 + ss(j)=s + yy(j)=y + xx(j)=x + endif +20 continue + enddo +29 nread=j + + call putval('Monitor', 0.0) + close(lun) + return + +99 print *,'DAT_INX: error during read' +98 nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_lnsp.f b/gen/dat_lnsp.f new file mode 100644 index 0000000..7df3f53 --- /dev/null +++ b/gen/dat_lnsp.f @@ -0,0 +1,290 @@ + subroutine dat_lnsp +c ------------------- + + external dat_lnsp_desc + external dat_lnsp_opts + external dat_lnsp_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_lnsp_desc) + call dat_init_opts(dtype, dat_lnsp_opts) + call dat_init_read(dtype, dat_lnsp_read) + end + + + subroutine dat_lnsp_desc(text) +! ------------------------------ + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='LNSP LNS powder Ascii format (DMC, HRPT)' + end + + + subroutine dat_lnsp_opts +! ------------------------ + print '(x,a)' + 1,'x: xaxis (2theta,d,Q), default= 2theta' + 1,'lambda: used for transformation, if not given if file' + end + + + subroutine dat_lnsp_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + character line*132, title*80, short*8 + character date*20, preset*4, instr*8 + character xaxis*64 + integer npk + integer i, l, j + real ymon + real meastime, lambda, temp, dtemp + real uur + real xmin, xstep, xend, xval, fact + real yint(0:99) + logical overflow + external dat_lnsp_val + + + nread=0 + preset=' ' + overflow=.false. + xstep=0 + ymon=0 + + read(lun,'(a)',err=900,end=900) line + rewind lun + + i=index(line, ',') + if (i .gt. 1 .and. i .le. 9) then + instr=line(1:i-1) + else + instr=' ' + endif + if (instr .eq. ' ') then + if (line(32:40) .eq. 'Phase No:') then ! fullprof sub output + read(line(1:31), *, err=901,end=901) xmin, xstep, xend + title=line(32:) + read(lun,*,err=901,end=901) + instr='fp' + else + if (forced .le. 0 .and. line(64:67) .ne. 'YTIM') then + inquire(lun, name=line) + call sys_parse(short, l, line, ' ', 2) + call str_upcase(short(1:4), short(1:4)) + if (short(1:4) .ne. '.DMC') goto 900 + endif + instr='DMC' + endif + elseif (instr .ne. 'DMC' .and. instr .ne. 'HRPT' + 1 .and. instr .ne. 'LNSP') then + goto 900 + endif + + call dat_start_options + xaxis=' ' + call dat_str_option('x', xaxis) + lambda=0.0 + call dat_real_option('lambda', lambda) + + call dat_group(1, putval) + if (instr .eq. 'fp') goto 108 + + read(lun,'(a)',err=99,end=99) line + if (line(64:67) .eq. 'YTIM') then ! old header + date=' ' + meastime=0.0 + read(line, '(21x,a20,27x,f8.0)', err=101,end=101) date, meastime +101 read(lun, '(a)',err=901,end=99) title + if (title(67:69) .eq. 'WL:') then + if (lambda .eq. 0.0) then + read(title(70:80), *, err=102,end=99) lambda + endif + title(67:)=' ' +102 continue + endif + temp=0 + dtemp=0 + uur=0 + read(lun, '(3f8.0,8x,f8.0,3x,f5.0,8x,f8.0,5x,f8.0)' + 1 , err=103,end=99) + 1 xmin, xstep, xend, temp, dtemp, uur, ymon +103 if (temp .ne. 0) then + call putval('Temp', temp) + if (dtemp .ne. 0) call putval('dTemp', dtemp) + endif + if (date .ne. ' ') call putval('Date='//date, 0.0) + call dat_group(2, putval) + if (meastime .ne. 0) call putval('MeasTime', meastime) + if (uur .ne. 0) call putval('MuR', uur) + if (ymon .gt. 0) ymon=ymon*1000. + else ! new header + title=line(6:) + read(lun,'(a)',err=99,end=99) line + call dat_delimiters(',','=','''') + call dat_intprt(line, dat_lnsp_val, putval) + read(lun,'(a)',err=99,end=99) line + read(line, *, err=107,end=107) xmin, xstep, xend, ymon +107 j=index(line, ',') + call dat_delimiters(',','=',' ') + if (j .ne. 0 .and. line(j+1:) .ne. ' ') then + call dat_intprt(line(j+1:), dat_lnsp_val, putval) + endif + endif +108 if (xstep .eq. 0) goto 901 + + if (ymon .gt. 0) then + preset='MN' + elseif (ymon .lt. 0) then + ymon=-ymon + preset='TI' + else + ymon=0. ! was 1. + endif + + call dat_group(3, putval) + if (preset .ne. ' ') call putval('Preset='//preset, 0.0) + if (lambda .eq. 0.0) then + call sym_get_real('lambda', lambda) + else if (lambda .ne. 0.0) then + call putval('lambda', lambda) + endif + call dat_powder_init(lambda, '2theta', xaxis) + + if (xstep .eq. 0) goto 901 + npk=nint((xend-xmin)/xstep)+1 + +! read intensity block + do i=0,npk-1,10 + read(lun, '(10F8.0)', err=902,end=902) (yint(j),j=0,9) + do j=0,min(9,npk-1-i) + if (nread .ge. nmax) then + if (.not. overflow) then + print *,'DAT_LNSP: Too many datapoints, truncated' + overflow=.true. + endif + else + xval=xmin+nread*xstep + nread=nread+1 + call dat_powder_trf(xval, xx(nread), fact) + yy(nread)=yint(j)*fact + ww(nread)=fact + if (yint(j) .gt. 0) then + ss(nread)=sqrt(yint(j)) + else + ss(nread)=0.0 + endif + endif + enddo + enddo + +! read sigma block + yint(0)=0 + do i=1,npk,10 + read(lun, '(10F8.0)', err=290,end=290) (yint(j),j=0,9) + do j=0,9 + if (i+j .ge. nread) goto 202 + ss(i+j)=yint(j) + enddo + enddo +202 goto 500 + +290 if (i .le. 1 .and. yint(0) .eq. 0) then + if (instr .ne. 'fp') then + print *,'--- Old LNSP format, no sigma block' + endif + else + print *,'--- Error in sigma block' + endif + +500 do i=1,nread + if (ss(i) .eq. 0.0) then + ss(i)=1.0 + else + ss(i)=ss(i)*ww(i) + endif + ww(i)=ymon + enddo + call dat_group(3, putval) + if (xaxis .eq. ' ') then + call putval('XAxis=2-Theta [deg]', 0.0) + else + call putval('XAxis='//xaxis, 0.0) + endif + call putval('YAxis=Intensity', 0.0) + call dat_group(1, putval) + call putval('Monitor', ymon) + call str_trim(title, title, l) + call putval('Title='//title(1:l), 0.0) + call putval('Instrument='//instr, 0.0) + call sym_read(lun, dat_lnsp_val) + +990 close(lun) + return + +! error messages + +900 nread=-1 + rewind lun + return + +901 print *,'DAT_LNSP: Error in header' + goto 990 + +902 print *,'DAT_LNSP: Error in intensity block' + goto 990 + +99 print *,'DAT_LNSP: error during read' + rewind lun + nread=-2 + return + end + + + subroutine dat_lnsp_val(str, val, putval) + + character*(*) str + real val + external putval + + integer i + + if (val .eq. 0) then + i=index(str, '=') + else + i=0 + endif + if (i .eq. 0) then ! numeric + if (str .eq. 'T') then + call putval('Temp', val) + return + elseif (str .eq. 'dT') then + call putval('dTemp', val) + return + elseif (str .eq. ' ') then + return + endif + else + if (str(1:i) .eq. 'Filelist=') return + endif + call putval(str, val) + end diff --git a/gen/dat_nexus.f b/gen/dat_nexus.f new file mode 100644 index 0000000..8055596 --- /dev/null +++ b/gen/dat_nexus.f @@ -0,0 +1,906 @@ + subroutine dat_nexus +c -------------------- + + external dat_nexus_desc + external dat_nexus_opts + external dat_get_datanumber ! get number on first line + external dat_nexus_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_nexus_desc) + call dat_init_opts(dtype, dat_nexus_opts) + call dat_init_high(dtype, dat_get_datanumber) + call dat_init_read(dtype, dat_nexus_read) + end + + + subroutine dat_nexus_desc(text) +! ------------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='NEXUS NeXus data format' + end + + + subroutine dat_nexus_opts +! ------------------------- + implicit none + character spec*16 + + call sys_getenv('dat_defspec', spec) + call str_upcase(spec, spec) + if (spec .ne. ' ') then + print '(x,2a/)','valid only for instrument ',spec + endif + if (spec(1:5) .eq. 'FOCUS') then + print '(x,a)' + 1 ,'from,to: detector range (default: averaged over all)' + 1 ,'bank: detector bank, u,b,l,m (default: m=merged)' + 1 ,'axis: time or theta' + else if (spec(1:4) .eq. 'RITA') then + print '(x,a)' + 1 ,'from: window number (default: middle window)' + 1 ,'from,to: window range' + 1 ,'axis: x-axis to be choosen' + 1 ,'y: y-axis to be choosen (aux, mon)' + else if (spec(1:5) .eq. 'CAMEA') then + print '(x,a)' + 1 ,'axis: x-axis to be choosen' + 1 ,'y: y-axis to be choosen (0 (summed_counts), 1, 8 (segment number), tot (total_counts), mon, aux)' + else if (spec(1:5) .eq. 'TRICS') then + print '(x,a)' + 1 ,'from,to: detector range' + 1 ,'axis: x-axis to be choosen' + 1 ,'frame: frame number (default: all frames)' + 1 ,'det: detector number (default: 2)' + else if (spec(1:3) .eq. 'DMC') then + print '(x,a)' + 1 ,'cal: calibration file' + 1 ,'filter: threshold for spike filter (default: 4)' + else if (spec(1:4) .eq. 'HRPT') then + print '(x,a)' + 1 ,'from,to: time channel range (default: averaged over all)' + 1 ,'cal: calibration file' + 1 ,'filter: threshold for spike filter (default: 4)' + else if (spec(1:5) .eq. 'MARS') then + print '(x,a)' + 1 ,'bank: detector bank, e,i,m1,m2' + 1 ,' (elastic, inelastic, mon1, mon2)' + 1 ,'from,to: detector range (default: averaged over all)' + else if (spec .eq. ' ') then + print '(x,a)' + 1 ,'from: first or only dataset (default: 1, RITA: middle window)' + 1 ,'to: last dataset (default: max. or single)' + 1 ,'bank: on FOCUS: detector bank, u,b,l,m (default: m=merged)' + 1 ,'axis: x-axis to be choosen' + 1 ,'frame: on TRICS: frame number (default 0)' + 1 ,'det: on TRICS: detector number (default: 1)' + 1 ,'cal: calibration file' + endif + print '(x,a)' + 1 ,'mon: monitor for normalisation (auto, smon, pmon, bmon, time)' + end + + + subroutine dat_nexus_read + 1 (lun, forced, nread, pv, nmax, xx, yy, ss, ww) +! ------------------------------------------------ + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external pv ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + include 'dat_nexus.inc' + + integer i,j + character magic*4, filename*256 + integer li, lc, lm + character cnt*64, mono*64, ins*64, axis2*64, signal*64 + character yaxis*64 + integer nsum, ngrp, nblk, xlen, nset + real totcnts, sta, stp, weight + integer from, to, lb, idet, icomp, iframe + character bank*64, buf*16 + character monarray*64 + integer p_weight(2), p_monarray(2) + integer istart + integer n_monarray + + integer dat_comp + external dat_comp, dat_nexus_putval + + + if (forced .le. 0) then ! check for HDF-file + magic=' ' + read(lun,'(a4)',err=9,end=9) magic +9 if (magic .ne. char(14)//char(3)//char(19)//char(1) .and. + 1 magic(2:4) .ne. 'HDF') then + rewind lun + nread=-1 + return + endif + endif + +c assume that we can open the HDF file, even when it is opened already by Fortran + + inquire(lun, name=filename) + call NXswitchReport(0) + status=NXopen(filename, NXacc_read, fileid) + + if (status .ne. NX_ok) then + rewind lun + call NXswitchReport(1) + nread=-1 + return + endif + lp=1 + path='/' + + call dat_nexus_get('/instrument') + if (type .ne. NX_char .or. status .ne. NX_OK) then + if (index(filename,'rita') .ne. 0) then + cdata = 'RITA2' + elseif (index(filename,'camea') .ne. 0) then + cdata = 'CAMEA' + else + goto 999 ! no instrument attribute + endif + endif + + i=index(cdata, ' ') + j=index(cdata, ',') + if (j .eq. 0) j=len(cdata) + i=min(i,j)-1 + if (i .lt. 1) goto 999 ! bad instrument attribute + + call dat_group(2, pv) ! importance level 2 + call pv('instrument='//cdata(1:i), 0.0) + + call str_upcase(instr, cdata(1:1)) ! take the first letter as code for the instrument + + call dat_start_options + from=0 + to=0 + bank=' ' + xaxis=' ' + yaxis=' ' + iframe=-1 + idet=2 + if (instr .eq. 'F') then + call dat_int_option('from', from) + call dat_int_option('to', to) + call dat_str_option('bank', bank) + call dat_str_option('axis', xaxis) + elseif (instr .eq. 'R') then + call dat_int_option('from', from) + call dat_int_option('to', to) + call dat_str_option('axis', xaxis) + call str_lowcase(xaxis, xaxis) + call dat_str_option('y', yaxis) + call str_lowcase(yaxis, yaxis) + elseif (instr .eq. 'C') then + call dat_str_option('axis', xaxis) + call str_lowcase(xaxis, xaxis) + call dat_str_option('y', yaxis) + call str_lowcase(yaxis, yaxis) + elseif (instr .eq. 'T') then + call dat_int_option('from', from) + call dat_int_option('to', to) + call dat_int_option('det', idet) + call dat_str_option('axis', xaxis) + call dat_int_option('frame', iframe) + elseif (instr .eq. 'H') then + call dat_int_option('from', from) + call dat_int_option('to', to) + elseif (instr .eq. 'M') then + call dat_str_option('bank', bank) + call dat_int_option('from', from) + call dat_int_option('to', to) + endif + ymon=0 + monitor='auto' + call dat_str_option('mon', monitor) + icomp=0 + call dat_int_option('bin', icomp) + nframes=0 + axis2=' ' + n_monarray=0 + if (yaxis .eq. ' ') yaxis='counts' + + if (instr .eq. 'D') then ! dmc + call str_trim(ins, '/nxentry/dmc/', li) + call str_trim(cnt, ins(1:li)//'nxpsd/', lc) + xaxis='two_theta' + axis1=cnt(1:lc)//'two_theta' + signal=cnt(1:lc)//'counts' + else if (instr .eq. 'H') then ! hrpt + call str_trim(ins, '/nxentry/hrpt/', li) + call str_trim(cnt, ins(1:li)//'nxdetector/', lc) + xaxis='two_theta' + axis1=cnt(1:lc)//'two_theta' + signal=cnt(1:lc)//'counts' + axis2=cnt(1:lc)//'stroboscopic_time' + monarray='/nxentry/stroboscopic_monitor/data' + if (monitor .eq. 'auto' .or. monitor .eq. 'smon') then + n_monarray=-1 + endif + elseif (instr .eq. 'F') then ! focus + call str_trim(ins, '/nxentry/focus/', li) + call str_trim(cnt, ins(1:li)//'counter/', lc) + if (xaxis .eq. ' ') xaxis='time' + call str_lowcase(bank, bank) + if (bank(1:1) .eq. 't') then + call str_trim(bank, ins(1:li)//'tof_monitor/', lb) + axis1=ins(1:li)//'merged/time_binning' + signal=ins(1:li)//'tof_monitor' + else + if (bank(1:1) .eq. 'u') then + call str_trim(bank,'upperbank',lb) + elseif (bank(1:1) .eq. 'l') then + call str_trim(bank,'lowerbank',lb) + elseif (bank(1:1) .eq. 'b') then + call str_trim(bank,'bank1',lb) + else + call str_trim(bank,'merged',lb) + endif + call str_trim(bank, ins(1:li)//bank(1:lb)//'/', lb) + if (xaxis .eq. 'time') then + axis1=bank(1:lb)//'time_binning' + axis2=bank(1:lb)//'theta' + else + axis2=bank(1:lb)//'time_binning' + axis1=bank(1:lb)//'theta' + endif + signal=bank(1:lb)//'counts' + endif + elseif (instr .eq. 'T') then ! trics + call str_trim(ins, '/frame0000/trics/', li) + if (iframe .ge. 0) write(ins(1:10), '(a,i4.4)') '/frame',iframe + call str_trim(cnt, ins(1:li)//'count_control/', lc) + if (xaxis .eq. ' ') xaxis='x' + if (idet .le. 0) idet=1 + if (idet .gt. 3) idet=3 + call str_trim(bank, ins(1:li)//'detector'//char(48+idet)//'/' + 1 , lb) + if (xaxis .eq. 'x') then + axis1=bank(1:lb)//'x' + axis2=bank(1:lb)//'y' + else + axis1=bank(1:lb)//'y' + axis2=bank(1:lb)//'x' + endif + signal=bank(1:lb)//'counts' + nframes=1 + elseif (instr .eq. 'C') then ! camea + call str_trim(ins, '/nxentry/CAMEA/', li) + call str_trim(cnt, ins(1:li)//'detector/', lc) + axis1=' ' + if (yaxis .eq. 'aux') then + signal='/nxentry/aux_detector/data' + elseif (yaxis .eq. 'mon') then + signal='/nxentry/control/data' + elseif (yaxis .eq. 'tot') then + signal=cnt(1:lc)//'total_counts' + elseif (yaxis(2:) .eq. ' ' .and. yaxis(1:1) .ge. '0' .and. yaxis(1:1) .le. '9') then + signal='/nxentry/CAMEA/segment_'//yaxis(1:1)//'/data' + else + signal='/nxentry/data/summed_counts' + endif + call dat_nexus_get('/nxentry/data/*') + elseif (instr .eq. 'R') then ! rita + call str_trim(ins, '/nxentry/rita-2/', li) + call str_trim(cnt, ins(1:li)//'detector/', lc) + axis1=' ' + if (yaxis .eq. 'aux') then + signal='/nxentry/aux_detector/data' + elseif (yaxis .eq. 'mon') then + signal='/nxentry/control/data' + else + axis2='w' + yaxis='counts' + signal=cnt(1:lc-1)//'windows/counts' + endif + if (from .gt. 0) then + if (to .lt. from) to=from + else if (from .eq. 0) then + from = 5 + to = 5 + endif + call dat_nexus_get('/nxentry/data/*') + elseif (instr .eq. 'M') then + call str_lowcase(bank, bank) + if (bank(1:1) .eq. 'i') then + call str_trim(ins, '/inelastic/MARS/', li) + call str_trim(cnt, ins(1:li)//'inelastic_bank/', lc) + axis1=cnt(1:lc)//'time_binning' + axis2=cnt(1:lc)//'scattering_angle' + else + call str_trim(ins, '/elastic/MARS/', li) + if (bank .eq. 'm1') then + call str_trim(cnt, '/elastic/pre_sample_monitor/', lc) + axis1=cnt(1:lc)//'time_of_flight' + else if (bank .eq. 'm2') then + call str_trim(cnt, '/elastic/after_sample_monitor/', lc) + axis1=cnt(1:lc)//'time_of_flight' + else + call str_trim(cnt, ins(1:li)//'elastic_bank/', lc) + axis1=cnt(1:lc)//'time_binning' + axis2=cnt(1:lc)//'scattering_angle' + endif + endif + signal=cnt(1:lc)//'data' + else ! any instrument + call str_trim(ins, '/nxentry/nxinstrument/', li) + call str_trim(cnt, ins(1:li)//'count_control/', lc) + axis1=' ' + signal=cnt(1:lc)//'counts' + endif + call str_trim(mono, ins(1:li)//'monochromator/', lm) + + call dat_group(1, pv) ! importance level 1 + + ! the first column is a code (first letter of the instrument) saying that the item is present + ! a question mark is used for optional items + + call dat_nexus_r(pv,'DHFT M/owner') + call dat_nexus_r(pv,' T /nxentry/currentframenumber=frames') + call dat_nexus_r(pv,'DHFTRCM/nxentry/title=Title') + call dat_nexus_r(pv,'DHFTRCM/nxentry/start_time=Date') + call dat_nexus_r(pv,'DHF '//mono(1:lm)//'lambda') + call dat_nexus_r(pv,' T '//mono(1:lm)//'wavelength') + call dat_nexus_r(pv,'DH /nxentry/sample/sample_name=sample') + call dat_nexus_r(pv,' FTRCM/nxentry/sample/name=sample') + call dat_nexus_r(pv,' FTRCM?/nxentry/sample/temperature=Temp') + fvalue=0.0 + call dat_nexus_r( + 1 dat_nexus_putval,'DH ?/nxentry/sample/temperature_mean=Temp') + if (fvalue .ne. 0.0) then + call pv('Temp', fvalue) + else + call dat_nexus_r(pv + 1 ,'DH TRC ?/nxentry/sample/sample_temperature=Temp') + end if + call dat_nexus_r(pv + 1 ,'DH RC ?/nxentry/sample/temperature_stdDev=dTemp') + call dat_nexus_r(pv,'DHFT ?/nxentry/sample/magfield') + call dat_nexus_r(pv,' RC ?/nxentry/sample/magnetic_field') + call dat_nexus_r(pv,' T /nxentry/sample/omega=om') + call dat_nexus_r(pv,' H ?/nxentry/sample/x_translation=stx') + call dat_nexus_r(pv,' H ?/nxentry/sample/y_translation=sty') + call dat_nexus_r(pv,' H ?/nxentry/sample/sample_stick_rotation=dom') + call dat_nexus_r(pv,'DH '//cnt(1:lc)//'two_theta_start=a4') + + call dat_group(2, pv) ! importance level 2 + + call dat_nexus_r(pv,'D F '//mono(1:lm)//'theta=a1') + call dat_nexus_r(pv,'D FT '//mono(1:lm)//'two_theta=a2') + call dat_nexus_r(pv + 1 ,'DH ?/nxentry/sample/sample_table_rotation=a3') + call dat_nexus_r(pv,'DHFTRC ?/nxentry/sample/device_name') + call dat_nexus_r(pv,'D '//mono(1:lm)//'curvature=mcv') + call dat_nexus_r(pv,'D '//mono(1:lm)//'x_translation=mtx') + call dat_nexus_r(pv,'D '//mono(1:lm)//'y_translation=mty') + call dat_nexus_r(pv,'D '//mono(1:lm)//'phi=mgu') + call dat_nexus_r(pv,'D '//mono(1:lm)//'chi=mgl') + call dat_nexus_r(pv,'DH '//cnt(1:lc)//'countermode=Preset') + call dat_nexus_r(pv,' F '//cnt(1:lc)//'count_mode=Preset') + call dat_nexus_r(pv,' T '//cnt(1:lc)//'countmode=Preset') + call dat_nexus_r(pv,' RC /nxentry/control/mode=Preset') + call dat_nexus_r(pv,' RC /nxentry/control/preset=sMon') + call dat_nexus_r(pv,'DHFT ?'//cnt(1:lc)//'time') + call dat_nexus_r(pv,'DHFT '//cnt(1:lc)//'monitor=sMon') + call dat_nexus_r(pv,'DHFT '//cnt(1:lc)//'beam_monitor=bMon') + call dat_nexus_r(pv,'D '//cnt(1:lc)//'additional_monitor=aMon') + call dat_nexus_r(pv, + 1 ' H '//cnt(1:lc)//'radial_collimator_status=radcolstat') + call dat_nexus_r(pv, + 1 ' H '//cnt(1:lc)//'radial_collimator_type=radcol') + call dat_nexus_r(pv,'DH '//cnt(1:lc)//'proton_monitor=pMon') + call dat_nexus_r(pv,'DH /nxentry/sample/sample_mur=muR') + call dat_nexus_r(pv,' T /nxentry/sample/chi') + call dat_nexus_r(pv,' T /nxentry/sample/phi') + call dat_nexus_r(pv, + 1 ' H /nxentry/sample/sample_changer_position=chpos') + call dat_nexus_r(pv, + 1 ' H /nxentry/sample/sample_rotation_state=sarot') + call dat_nexus_r(pv,' T '//ins(1:li)//'detector2/two_theta=stt') + call dat_nexus_r(pv,' T ?'//ins(1:li)//'detector1/tilt=dg1') + call dat_nexus_r(pv,' T ?'//ins(1:li)//'detector2/tilt=dg2') + call dat_nexus_r(pv,' T ?'//ins(1:li)//'detector3/tilt=dg3') + call dat_nexus_r(pv,' F /nxentry/end_time') + call dat_nexus_r(pv + 1 ,' H '//ins(1:li)//'Kollimator1/kollimator1=cex1') + call dat_nexus_r(pv + 1 ,' H '//ins(1:li)//'Kollimator1/kollimator2=cex2') + call dat_nexus_r(pv + 1 ,' H '//ins(1:li)//'exit_slit/width=d1w') + call dat_nexus_r(pv + 1 ,' H ?'//ins(1:li)//'beam_reduction/bottom=brbo') + call dat_nexus_r(pv + 1 ,' H ?'//ins(1:li)//'beam_reduction/left=brle') + call dat_nexus_r(pv + 1 ,' H ?'//ins(1:li)//'beam_reduction/right=brri') + call dat_nexus_r(pv + 1 ,' H ?'//ins(1:li)//'beam_reduction/top=brto') + call dat_nexus_r(pv,' H '//mono(1:lm)//'curvature_lower=mcvl') + call dat_nexus_r(pv,' H '//mono(1:lm)//'curvature_upper=mcvu') + call dat_nexus_r(pv,' H '//mono(1:lm)//'lift=mexz') + call dat_nexus_r(pv,' H '//mono(1:lm)//'omega_lower=moml') + call dat_nexus_r(pv,' H '//mono(1:lm)//'omega_upper=momu') + call dat_nexus_r(pv,' H '//mono(1:lm)//'vertical_tilt_upper=mgvu') + call dat_nexus_r(pv,' H '//mono(1:lm)//'paralell_tilt_upper=mgpu') + + call dat_group(3, pv) ! importance level 3 + call pv('Xaxis='//xaxis, 0.0) + call pv('Yaxis='//yaxis, 0.0) + + if (axis1 .ne. ' ') then + call dat_nexus_get(axis1) + if (status .ne. NX_ok) then + print *,'axis ',axis1,' not found' + xlen=0 + else + xlen=min(nmax,length) + if (icomp .gt. 1) then + stp=icomp + if (stp .lt. 1) stp = 1 + xlen=dat_comp(0,0, p_array, xlen, 1, 1, 0.0 + 1 , stp, xlen/icomp,0) + call dat_copy2f(p_array, xx, xlen, 1) + do i=1,xlen + xx(i)=xx(i)/icomp + enddo + else + if (rank .eq. 2) then ! for rita: take 'from' window + if (sdate .gt. '2006-12-20') then ! new rita + if (from .ge. dim(1)) then + istart = 4 + else + istart = (from - 1) + endif + xlen = dim(2) + call dat_extract(p_array, istart, dim(1), xx, xlen, 1) + else + if (from .ge. dim(2)) from = dim(2) + istart = dim(1) * (from - 1) + xlen = dim(1) + call dat_extract(p_array, istart, 1, xx, xlen, 1) + endif + else if (rank .eq. 1) then + call dat_copy2f(p_array, xx, xlen, 1) + else + xx(1)=0 + endif + endif + endif + else + xlen=0 + endif + nread=0 + nset=0 +70 if (n_monarray .ne. 0) then + call dat_nexus_get(monarray) + if (status .eq. NX_ok) then ! monitor array present + p_monarray(1)=p_array(1) + p_monarray(2)=p_array(2) + if (rank .eq. 1) then + n_monarray=dim(1) + else + print *,'illegal stroboscopic monitor dimension' + n_monarray=0 + endif + endif + endif + call dat_nexus_get(signal) + if (status .ne. NX_ok) then + if (instr .eq. 'R') then + call dat_nexus_get('/nxentry/data/summed_counts') + axis2=' ' + endif + if (status .ne. NX_ok) then + print *,'signal ',signal,' not found' + goto 999 + endif + endif + if (rank .eq. 0) then + call dat_copy2p(p_array, fvalue) + endif + if (instr .eq. 'H') then + if (rank .ne. 2) then + axis2=' ' + if (n_monarray .ne. 0) then + n_monarray=0 + endif + endif + endif + if (axis2 .ne. ' ') then ! reduction axis + if (from .le. 0) then + if (to .eq. 0) to=999999 + from=1 + endif + if (to .lt. from) to=from + if (instr .eq. 'H' .or. xaxis .eq. 'x' .or. xaxis .eq. 'theta') then ! x on TriCS, theta on FOCUS + nsum=dim(1) + ngrp=1 + nblk=dim(2) + else if (instr(1:1) .eq. 'R' .and. sdate .gt. '2006-12-20') then ! new rita + nsum=dim(1) + ngrp=1 + nblk=dim(2) + else ! old rita or focus + nsum=dim(2) + ngrp=dim(1) + nblk=1 + endif + if (from .gt. nsum) from=nsum + if (to .gt. nsum) to=nsum + if (from .eq. to) then + write(buf, '(9x,i7)') from + else + write(buf, '(i7,a,i7)') from,'..',to + endif + i=10 + do while (buf(i:i) .eq. ' ') + i=i+1 + enddo + buf(10:)=buf(i:) + i=1 + do while (buf(i+1:i+1) .eq. ' ') + i=i+1 + enddo + call pv('Range='//buf(i:), 0.0) + sta=(from+to)*0.5-1 + stp=to+1-from + length=dat_comp(2,0, p_array, nsum, ngrp, nblk + 1 , sta, stp, 1, p_weight) + if (n_monarray .gt. 0) then + i=dat_comp(0,0,p_monarray, nsum, ngrp, 1 + 1 , sta, stp, 1, 0) + call dat_copy2f(p_monarray, weight, 1, 1) + if (ymon .ne. 0) then + weight = weight / ymon + endif + else + call dat_copy2f(p_weight, weight, 1, 1) + endif + if (icomp .gt. 1) then + stp=icomp + weight=weight*icomp + length=dat_comp(0,0, p_array, length,1,1,-0.5 + 1 ,stp,length/icomp,0) + endif + else + weight=1 + endif + if (nset .eq. 0) then + if (xlen .eq. 0) then + xlen=length + do i=1,length + xx(nread+i)=i + enddo + endif + if (length .ne. xlen) then + print *,'xaxis and signal length do not match', length, xlen + endif + endif + length=min(length,xlen) + if (status .ne. NX_ok) then + print *,'signal ',signal,'not found' + goto 999 + endif + if (length .gt. nmax) then + print *,'too large, data truncated from', length,' to',nmax + length=nmax + endif + call dat_copy2f(p_array, yy(nread+1), length, 1) + if (ymon .eq. 0) ymon=1. + totcnts=0.0 + ymon=ymon*weight + do i=1,length + j=nread+i + totcnts=totcnts+yy(j) + ss(j)=sqrt(max(1.0,yy(j))) + ww(j)=ymon + enddo + if (nset .gt. 0) then + do i=1,length + xx(nread+i)=xx(i) + enddo + endif + nread=nread+length + if (nframes .gt. 0 .and. iframe .le. 0) then + nset=nset+1 + write(signal(1:10), '(a,i4.4)') '/frame',nset + if (nset .lt. nframes) goto 70 + call fit_dat_table(1, 1, length) + endif + call dat_group(1, pv) + call pv('Monitor', ymon) + call pv('Counts', totcnts) + i=NXclose(fileid) + close(lun) + call NXswitchReport(1) +! call nxlistreport + RETURN + +999 i=NXclose(fileid) + nread=-2 + call NXswitchReport(1) +! call nxlistreport + end + + + subroutine dat_nexus_get(datapath) + + include 'dat_nexus.inc' + + character datapath*(*) + + character attr*64, nam*64, clss*64, low*64 + integer i, j, atype, l + integer start0(32)/32*0/ + real*8 dvalue + + logical end_of_path + byte idata(257) + + integer dat_nexus_getslab + + if (datapath(1:1) .ne. '/') then + status=NX_error + RETURN + endif + do while (path(1:lp) .ne. datapath(1:min(lp,len(datapath)))) + ! go up in path + status=NXclosegroup(fileid) + lp=lp-1 + do while (path(lp:lp) .ne. '/') + lp=lp-1 + if (lp .lt. 1) then + lp=1 + path='/' + status=NX_error + RETURN + endif + enddo + enddo + + end_of_path=.false. +10 continue ! loop + i=index(datapath(lp+1:), '/')-1 + if (i .lt. 0) then + if (lp .eq. 1) then ! get global attribute + ! assume global attributes are all of type char + type=NX_char + length=len(cdata) + axis_signal=0 + units=' ' + name=datapath(2:) + status=NXgetattr(fileid, name, idata, length, type) + if (status .ne. NX_ok) RETURN + type=NX_char + call replace_string(cdata, idata) + if (length .le. 0) then + cdata=' ' + length=1 + endif + call str_trim(cdata, cdata(1:length), length) + RETURN + endif + call str_trim(datapath(lp+1:), datapath(lp+1:), i) + end_of_path=.true. + endif + call str_lowcase(low, datapath(lp+1:lp+i)) + status=NXinitgroupdir(fileid) + if (status .ne. NX_ok) RETURN +11 status=NXgetnextentry(fileid, name, class, type) + do while (status .eq. NX_ok) + call str_lowcase(nam, name) + call str_lowcase(clss, class) + if (nam .eq. low .or. clss .eq. low) goto 12 + if (low .eq. '*') then + if (nam .eq. xaxis) then + axis1=datapath(1:lp)//name + xaxis=name + else + status=NXopendata(fileid, name) + l=2 + atype=NX_char + attr='axis' + status=NXgetattr(fileid, attr, axis_signal, l, atype) + if (status .eq. NX_ok + 1 .and. axis_signal .eq. ichar('1') + 1 .and. xaxis .eq. ' ') then + axis1=datapath(1:lp)//name + xaxis=name + endif + endif + endif + status=NXgetnextentry(fileid, name, class, type) + enddo + RETURN ! not found +12 continue ! go down in path + if (end_of_path) goto 19 + if (class .eq. 'SDS') goto 11 ! skip SDS when looking for groups + status=NXopengroup(fileid, name, class) + if (status .ne. NX_ok) RETURN + i=i+1 + low(i:i)='/' + path(lp+1:)=low(1:i) + lp=lp+i + status=NXinitgroupdir(fileid) + i=index(datapath(lp+1:), '/') + goto 10 +19 continue ! open data + status=NXopendata(fileid, name) + if (status .ne. NX_ok) RETURN ! not found + status=NXgetinfo(fileid, rank, dim, type) + if (status .ne. NX_ok) goto 9 + if (rank .gt. 16) status=NX_error + j=0 + length=1 + do i=1,rank + if (dim(i) .gt. 1) then + j=i + length=length*dim(i) + endif + enddo + rank0=rank + if (j .eq. 0) then + dim(1)=1 + rank=1 + else + rank=j + endif + if (rank .le. 1 .and. length .le. len(cdata) .and. + 1 (type .eq. nx_char .or. + 1 type .eq. nx_uint8 .or. type .eq. nx_int8)) then ! character (up to 256 chars) + type=nx_char + status=NXgetdata(fileid, idata) + if (status .ne. NX_ok) goto 9 + call replace_string(cdata, idata) + call str_trim(cdata, cdata(1:length), length) + elseif (rank .eq. 0) then ! scalar data + if (type .eq. nx_int32) then + status=NXgetdata(fileid, ivalue) + if (status .ne. NX_ok) goto 9 + fvalue=ivalue + elseif (type .eq. nx_float32) then + status=NXgetdata(fileid, fvalue) + if (status .ne. NX_ok) goto 9 + elseif (type .eq. nx_float64) then + dvalue = 0 + status=NXgetdata(fileid, dvalue) + if (status .ne. NX_ok) goto 9 + fvalue = dvalue + endif + else + if (type .eq. nx_char) type=nx_uint8 + status=dat_nexus_getslab(fileid, type, rank0, start0 + 1 , dim, p_array) + if (status .ne. NX_ok) goto 9 + endif + status=NXgetnextattr(fileid, attr, l, atype) + axis_signal=0 + units=' ' + do while (status .ne. NX_eod) + if (status .ne. NX_ok) goto 9 + if (attr .eq. 'signal') then + axis_signal=-1 + else if (attr .eq. 'axis') then + l=1 + status=NXgetattr(fileid, attr, axis_signal, l, atype) + else if (attr .eq. 'units') then + l=len(units) + status=NXgetattr(fileid, attr, idata, l, atype) + call replace_string(cdata, idata) + endif + status=NXgetnextattr(fileid, attr, l, atype) + enddo + status=NXclosedata(fileid) + RETURN + +9 i=NXclosedata(fileid) + end + + + + subroutine dat_nexus_r(pv, desc) + + include 'dat_nexus.inc' + + external pv + character desc*(*) + + integer l,j,i + character enam*64 + + i=index(desc, '/') + if (i .eq. 0) stop 'DAT_NEXUS_R: illegal descriptor' + j=index(desc(1:i), instr) + if (j .eq. 0) RETURN + l=index(desc(i:), '=') + if (l .eq. 0) then + call str_trim(desc, desc, l) + j=l + do while (desc(j:j) .ne. '/') + j=j-1 + enddo + enam=desc(j+1:l) + else + enam=desc(i+l:) + l=i+l-2 + endif + call dat_nexus_get(desc(i:l)) + if (status .ne. NX_ok) then + ! optional items are marked with a question mark + if (index(desc(1:i), '?') .eq. 0) then + print *,'path ',desc(i:l),' not found' + endif + else if (type .eq. nx_char) then + if (enam .eq. 'Date') then + sdate=cdata + endif + if (enam .eq. 'Preset') then + if (monitor .eq. 'auto') then + call str_lowcase(monitor, cdata) + if (monitor(1:1) .eq. 'm') then + monitor='smon' + else + monitor='time' + endif + endif + endif + call pv(enam//'='//cdata(1:length), 0.0) + else if (type .eq. nx_int32 .or. type .eq. nx_float32 .or. type .eq. nx_float64) then + if (rank .gt. 0) call dat_nexus_average + if (enam .eq. 'frames' .and. nframes .gt. 0) then + nframes=nint(fvalue) + else + call pv(enam, fvalue) + call str_lowcase(enam, enam) + if (enam .eq. monitor) then + ymon=fvalue + endif + endif + else + print *,enam,' has a strange type' + if (rank .gt. 0) then + call dat_copy2f(p_array, 0, 0, 1) ! free p_array + endif + endif + end + + subroutine dat_nexus_average + + include 'dat_nexus.inc' + + integer l + integer dat_comp + external dat_comp + + l=dat_comp(0,0,p_array,length,1,1,(length-1)*0.5,length*1.0,1,0) + call dat_copy2f(p_array, fvalue, 1, 1) + fvalue=fvalue/length + end + + subroutine dat_nexus_putval(name, value) + + character name*(*) + real value + end diff --git a/gen/dat_nexus.inc b/gen/dat_nexus.inc new file mode 100644 index 0000000..4f1daab --- /dev/null +++ b/gen/dat_nexus.inc @@ -0,0 +1,15 @@ + include 'napif.inc' + + integer fileid(NXhandlesize) + integer lp, status, type + character path*1024, name*64, class*64, axis1*64, xaxis*32 + character cdata*256, units*64, monitor*32, instr*1 + character sdate*20 + integer ivalue, axis_signal, rank, rank0, length, nframes + real fvalue, ymon + integer p_array(2), dim(32) + + common /dat_hdf_com/fileid,path,name,class,status,lp,type + 1,cdata,ivalue,axis_signal,rank,rank0,length,fvalue + 1,p_array,dim,nframes,ymon + 1,units,monitor,instr,axis1,xaxis,sdate diff --git a/gen/dat_nexus_dum.f b/gen/dat_nexus_dum.f new file mode 100644 index 0000000..c6e3aa2 --- /dev/null +++ b/gen/dat_nexus_dum.f @@ -0,0 +1,2 @@ + subroutine dat_nexus + end diff --git a/gen/dat_oldtas.f b/gen/dat_oldtas.f new file mode 100644 index 0000000..bee2fb1 --- /dev/null +++ b/gen/dat_oldtas.f @@ -0,0 +1,347 @@ + subroutine dat_oldtas +c --------------------- + + external dat_oldtas_desc + external dat_oldtas_opts + external dat_oldtas_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_oldtas_desc) + call dat_init_opts(dtype, dat_oldtas_opts) + call dat_init_read(dtype, dat_oldtas_read) + end + + + subroutine dat_oldtas_desc(text) +! -------------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='OLDTAS old ILL TAS format (IN3)' + end + + + subroutine dat_oldtas_opts +! -------------------------- + print '(x,a)' + 1,'x,y,mon: xaxis,yaxis,monitor to be choosen' + end + + + subroutine dat_oldtas_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + real none + parameter (none=-8.7654e29) + + character line*132, preset*4, xaxis*8, yaxis*8, monam*8, col2*8 + character pnt*8 + real values(15), r, f, s, y, ymon, qhkle(4) + integer i,j,l,mondiv,ncol,ccol,pcol,xcol + + external dat_oldtas_val + +! common + real dqhkle(4) + common/dat_oldtas_com/dqhkle + + nread=0 + read(lun,'(a)',err=100,end=100) line + + if (forced .le. 0) then + if (line(1:2).ne.'IN' .or. line(39:44).ne.'A00120') goto 100 + else + if (line(1:2).ne.'IN' .and. line(39:44).ne.'A00120') goto 100 + endif + + xaxis=' ' + yaxis=' ' + monam=' ' + + call dat_start_options + call dat_str_option('x', xaxis) + call dat_str_option('y', yaxis) + call dat_str_option('mon', monam) + + call str_upcase(xaxis, xaxis) + call str_upcase(yaxis, yaxis) + call str_upcase(monam,monam) + + call dat_group(1, putval) + call putval('Instrument='//line(1:4),0.0) + call putval('User='//line(11:20), 0.0) + call putval('Date='//line(21:38), 0.0) + + if (line(1:4) .eq. 'IN3 ' .and. + 1 (line(24:31) .eq. 'FEB-1995' .or. + 1 line(24:31) .eq. 'MAR-1995' ) ) then + mondiv=100 + else + mondiv=1 + endif + call dat_delimiters(';', '=', '''') + read(lun,'(a)',err=99,end=99) line + if (line(32:35) .eq. 'HKLE') then + call putval('Title='//line(20:31), 0.0) + do i=1,4 + qhkle(i)=none + dqhkle(i)=none + enddo + read(line(36:),*,err=11,end=11) qhkle, dqhkle +11 continue + if (qhkle(4) .ne. none) call putval('EN',qhkle(4)) + if (qhkle(3) .ne. none) then + call putval('QH', qhkle(1)) + call putval('QK', qhkle(2)) + call putval('QL', qhkle(3)) + endif + if (dqhkle(4) .ne. none) call putval('DEN',dqhkle(4)) + if (dqhkle(3) .ne. none) then + call putval('DQH', dqhkle(1)) + call putval('DQK', dqhkle(2)) + call putval('DQL', dqhkle(3)) + endif + + read(lun,*,err=99,end=99) + call dat_group(2, putval) + do i=1,4 + read(lun, '(a)') line + call dat_intprt(line, dat_oldtas_val, putval) + enddo + else + call putval('Title='//line(20:99), 0.0) + read(lun,*,err=99,end=99) + call dat_group(2, putval) + do i=1,5 + read(lun, '(a)') line + call dat_intprt(line, dat_oldtas_val, putval) + enddo + endif + if (xaxis .eq. ' ') then + if (dqhkle(1) .ne. 0) then + xaxis='QH' + elseif (dqhkle(2) .ne. 0) then + xaxis='QK' + elseif (dqhkle(3) .ne. 0) then + xaxis='QL' + elseif (dqhkle(4) .ne. 0) then + xaxis='EN' + endif + endif + +1 read(lun,'(a)',err=99,end=99) line + if (line(1:4) .eq. '!POS') then + read(line(5:),'(15F7.3)') values +ccc call sym_put_array('Angles', values, 12,0) + goto 1 + elseif (line(1:4) .eq. '!Z**') then + read(line(5:),'(15F7.3)') values +ccc call sym_put_array('Zeroes', values, 12,0) + goto 1 + else + if (line .ne. ' ') then + call str_trim(line, line, l) + print *,'DAT_OLDTAS: superflous text: ', line(1:l) + goto 1 + endif + endif +2 continue + call dat_group(1, putval) + read(lun,'(a,F12.0)',err=99,end=99) preset, ymon + preset=preset(2:3) + if (preset .eq. 'MN') then + preset='M1' + ymon=ymon*mondiv + elseif (preset .eq. 'TI') then + preset='TIME' + endif + if (monam .eq. ' ') then + monam=preset + elseif (preset .ne. monam) then + ymon=0 + endif + + call putval('Preset='//preset, 0.0) + +3 read(lun,'(a)',err=99,end=99) line + if (line .eq. ' ') goto 3 + i=1 + line(len(line):len(line))=' ' + ncol=0 + ccol=0 + pcol=0 + xcol=0 + col2=' ' +31 do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 39 + enddo + l=i + do while (line(i:i) .ne. ' ') + i=i+1 + enddo + ncol=ncol+1 + if (ncol .eq. 2) col2=line(l:i) + if (line(l:i) .eq. 'EN(MEV)') line(l:i)='EN' + if (line(l:i) .eq. yaxis .or. yaxis .eq. ' ' .and. + 1 (line(l:i) .eq. 'CNTS' .or. line(l:i) .eq. 'D1')) ccol=ncol + if (line(l:i) .eq. monam) pcol=ncol + if (line(l:i) .eq. xaxis) xcol=ncol + goto 31 + +39 if (ccol .eq. 0) then + if (yaxis .eq. ' ') yaxis='CNTS/D1' + print *,'no values found for ',yaxis + goto 99 + endif + if (pcol .eq. 0) then + if (monam .eq. ' ') monam='Monitor' + print *,'no values found for ',monam + goto 99 + endif + if (xcol .eq. 0) then + if (xaxis .ne. ' ') then + print *,'no values found for ',xaxis,', take ',col2 + endif + xcol=2 + xaxis=col2 + endif + + call putval('XAxis='//xaxis, 0.0) + call putval('YAxis=Intensity', 0.0) + call dat_group(1, putval) + + l=max(xcol,pcol,ccol) + f=1.0 + values(1)=0 + +4 read(lun,'(a8,15f8.0)',err=19,end=9) pnt, (values(j),j=2,l) + i=0 + read(pnt, *, err=5, end=5) i ! special treatment for FLEX, where there may be stars in the first column +5 if (i .eq. 0) then + values(1)=values(1)+1 ! illegal value: add 1 + else + values(1)=i + endif + if (nread .ge. nmax) goto 29 + y=values(ccol) + r=values(pcol) + if (ymon .eq. 0) then + ymon=r + if (r .eq. 0) r=1. + endif + if (r .le. 0.0) r=ymon + f=ymon/r + if (f .le. 0.0) f=1.0 + if (y .gt. 0) then + s=sqrt(y) ! statistical error of detector + else + s=1 + endif + nread=nread+1 + xx(nread)=values(xcol) + yy(nread)=y*f + ss(nread)=s*f + ww(nread)=r + goto 4 + +9 close(lun) + call putval('Monitor', ymon) + return + +19 print *,'DAT_OLDTAS: error at point ',nread + goto 4 +29 print *,'DAT_OLDTAS: too many points' + goto 100 +99 print *,'DAT_OLDTAS: error during read' + rewind lun + nread=-2 + return +100 nread=-1 + rewind lun + end + + + subroutine dat_oldtas_val(str, val, putval) + + character*(*) str + real val + external putval + + real dqhkle(4) + common/dat_oldtas_com/dqhkle + integer i, nq/0/, ndq/0/ + +c the names with include number sign (#) are for compatibility +c with an intermediate version of IN3 data files, +c where QHKL and DQHKL were stored as an array + + if (str .eq. ' ') then ! reset + ndq=0 + nq=0 + return + endif + if (val .eq. 0) then + i=index(str, '=') + else + i=0 + endif + if (i .eq. 0) then ! numeric + if (str .eq. 'DQHKL') then + ndq=ndq+1 + if (ndq .le. 4) dqhkle(ndq)=val + if (ndq .eq. 1) then + call putval('DQH', val) + else if (ndq .eq. 2) then + call putval('DQK', val) + else if (ndq .eq. 3) then + call putval('DQL', val) + else if (ndq .eq. 4) then + call putval('DEN', val) + endif + return + endif + if (str .eq. 'QHKL') then + nq=nq+1 + if (nq .eq. 1) then + call putval('QH', val) + else if (nq .eq. 2) then + call putval('QK', val) + else if (nq .eq. 3) then + call putval('QL', val) + else if (nq .eq. 4) then + call putval('EN', val) + endif + return + endif + if (str .eq. 'DQH') then + dqhkle(1)=val + elseif (str .eq. 'DQK') then + dqhkle(2)=val + elseif (str .eq. 'DQL') then + dqhkle(3)=val + elseif (str .eq. 'DEN') then + dqhkle(4)=val + endif + endif + call putval(str, val) + end diff --git a/gen/dat_open.f b/gen/dat_open.f new file mode 100644 index 0000000..ecf47f3 --- /dev/null +++ b/gen/dat_open.f @@ -0,0 +1,1326 @@ + subroutine dat_init_desc(datype, handler) + + integer datype + external handler + + include 'dat.inc' + + data desc_hdl/maxtypes*0/ + data high_hdl/maxtypes*0/ + data read_hdl/maxtypes*0/ + data opts_hdl/maxtypes*0/ + data last_type/0/, dtype/0/, year/0/ + integer sys_adr_c, sys_adr_iiieirrrr, sys_adr_ci, sys_adr_0 + + call dat_init_handler(datype) + desc_hdl(datype)=sys_adr_c(handler) + return + + entry dat_init_read(datype, handler) + + call dat_init_handler(datype) + read_hdl(datype)=sys_adr_iiieirrrr(handler) + return + + entry dat_init_high(datype, handler) + + call dat_init_handler(datype) + high_hdl(datype)=sys_adr_ci(handler) + return + + entry dat_init_opts(datype, handler) + + call dat_init_handler(datype) + opts_hdl(datype)=sys_adr_0(handler) + return + + end + + + subroutine dat_init_hdl + end + + + subroutine dat_desc(datype, text) + +C get description (syntax: filetype, space(s), description) + + integer datype ! (in) data type code + character text*(*) + + include 'dat.inc' + + call sys_call_c(desc_hdl(datype), text) + end + + + + subroutine dat_high(datype, file, numor) + +C get highest numor + + integer datype ! (in) data type code + integer numor + character file*(*) + + include 'dat.inc' + + call sys_call_ci(high_hdl(datype), file, numor) + end + + + + subroutine dat_desc_opt(done, typ) + +! print options description + character typ*(*) ! file type + + include 'dat.inc' + + integer done + + if (last_type .eq. 0) then + done=0 + else + print *,'Options for filetype ',typ,':' + print * + call sys_call_0(opts_hdl(last_type)) + endif + end + + + + subroutine dat_read(datype, lun, forced, nread + 1 , putval, nmax, xx, yy, ss, ww) +C + integer datype ! (in) data type code + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! -1: read only if type is really sure + ! 0: read only if type is quite sure + ! 1: try to read anyway, as there is no alternative + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file still open + ! -2: correct type, but unreadable, still open + external putval ! (in) subroutine putval(str, val) + ! character*(*) str + ! real val + integer nmax ! max. number of points + real xx(nmax) ! x-values + real yy(nmax) ! y-values + real ss(nmax) ! sigma + real ww(nmax) ! weights + + include 'dat.inc' + + if (datype .ne. 0) last_type=datype + if (last_type .eq. 0) then + print *,'DAT_READ: datype illegal' + nread=-1 + else + rewind lun + call sys_call_iiieirrrr(read_hdl(last_type), lun, forced, nread + 1, putval, nmax, xx, yy, ss, ww) + endif + end + + + subroutine dat_init_handler(datype) +! +! datype = 0: return new type id in datype +! else: change handler for datype +! + include 'dat.inc' + + integer datype + + integer i,j + character system*32 + external dat_do_nothing + + if (ntypes .eq. 0) then + call sys_loadenv + spec=' ' + call sys_getenv('dat_defyear', spec) + year=0 + read(spec,*,iostat=i) year + if (year .eq. 0) call sys_date(year, i, j) + call sys_getenv('dat_defspec', spec) + call str_lowcase(spec, spec) + call sys_check_system(system) + + if (system .eq. 'VMS') then + specin='/' + specout='/' + else + specin=':' + specout=':' + endif + endif + + if (datype .eq. 0) then + ntypes=ntypes+1 + if (ntypes .gt. maxtypes) + 1 stop 'DAT_INIT_HANDLER: too many handlers' + datype=ntypes + endif + end + + + subroutine dat_do_nothing + end + + + subroutine dat_open_next(listin, pin, listout, pout + 1 , putval, nmax, nread, xx, yy, ss, ww) + +c open next file from file-list LISTIN at position PIN, +c put item on LISTOUT, position POUT + +c first call to DAT_OPEN_NEXT: POUT=0 +c between subsequent calls, LISTOUT and POUT must not be altered + + character listin*(*) ! (in) input file list + integer pin ! (in/out) input list position + character listout*(*) ! (out) output file list + integer pout ! (in/out) output list position + external putval ! (in) subroutine to treat name value pairs + ! subroutine putval(str, val) + ! character*(*) str + ! real val + integer nmax ! max number of points (if NMAX=0: check syntax only) + integer nread ! (out) number of points read + real xx(nmax) ! x-values + real yy(nmax) ! y-values + real ss(nmax) ! sigmas + real ww(nmax) ! weights + +! arguments for entries DAT_SETTYP, DAT_GETTYP, DAT_SETYEAR, DAT_GETHIGH: + + character spec_def*(*) ! default instrument specification + integer year_def ! default year + integer high_numor ! highest numor + character filnam*(*) ! full filename + integer len_name ! length of filename + logical silent + + integer undef_numor + parameter (undef_numor=-2) + + integer i,l,m,n,ny,hyp,num1,num2,stat,tf,idx,lcf + integer lf/0/ + integer np/0/ + integer namend,ityp,iname,ispec1,ispec2 + integer irange/0/,jrange/0/,krange/0/ + character delim*1 + logical spec_out, year_out, inq, ok, syntaxonly, nam_out + logical range_out/.false./ + + character filename*256/' '/ + character filtype*32, tmpfil*256 + character calspec*32, calfil*256, cyr*4 + character text*128, calast*256/' '/, caltxt*256 + integer numor/0/, lun/0/, iostat + logical dirty/.false./, do_calib, log_it/.true./, hint/.true./ + logical log_filter + real calib, filter, sigoff, s2, ymn, ymx + integer spikecnt, lt + character shortspec*32, filtertext*32 + + include 'dat.inc' + + call dat_init + + if (specout .eq. ':') then + if (index(listin, ':') .eq. 0) then + specin='/' + else + specin=':' + endif + endif + + if (nmax .eq. 0) then + syntaxonly=.true. + else + syntaxonly=.false. + if (log_it) print * + endif + + nread=0 + +5 if (pin .ge. len(listin)) goto 98 + if (listin(pin+1:pin+1) .le. ' ') then + pin=pin+1 + goto 5 + endif + + if (lun .eq. 0) call sys_get_lun(lun) + ny=-1 + iname=pin + ispec1=0 + ispec2=0 + call dat_get_item(listin, pin, delim) + if (delim .eq. specin) then ! separator found + num1=0 + if (pin .gt. iname+1) then ! item is not empty + call dat_cvt_number(listin(iname+1:pin-1), ny) + if (ny .lt. 1900 .or. ny .gt. 2064) then ! item is not year + if (ny .lt. 0) then + ispec1=iname ! first item is spec + ispec2=pin + ny = -1 ! no number + else + ny = -2 ! bad number + endif + endif + endif + n=pin + call dat_get_item(listin, pin, delim) + if (delim .eq. specin) then ! 2nd separator found + if (pin .gt. n+1) then ! 2nd item not empty and year is not yet given + if (ny .eq. -1) then ! year not yet given + call dat_cvt_number(listin(n+1:pin-1), ny) + if (ny .lt. 1900 .or. ny .gt. 2064) then ! 2nd item is not year + ny = -2 ! bad year + endif + else + ispec1 = n ! 2nd item is spec + ispec2 = pin + endif + endif + n=pin + l=pin + call dat_get_item(listin, pin, delim) + endif + else + n=iname + endif + if (pin .gt. n+1) then + if (listin(n+1:) .eq. ' ') then + num1=0 + else + call dat_cvt_number(listin(n+1:pin-1), num1) + endif + elseif (delim .eq. '-') then + num1=numor+1 + else + num1=numor + endif + if (delim .eq. '-') then + hyp=pin + call dat_get_item(listin, pin, delim) + if (pin .gt. hyp+1) then + call dat_cvt_number(listin(hyp+1:pin-1), num2) + else + num2=-1 + endif + else + hyp=0 + num2=num1 + endif +10 if (delim .eq. '-' .or. delim .eq. specin) then + call dat_get_item(listin, pin, delim) + num1=-1 ! illegal syntax + goto 10 + endif + + namend=pin + + if (delim .eq. '(') then + ityp=pin + call dat_get_item(listin, pin, delim) + if (pin .gt. ityp+2) then + call str_upcase(filtype, listin(ityp+1:pin-2)) + call dat_find_type(filtype, i) + if (i .ne. 0) then + dtype=i + else + filtype=' ' + endif + endif + inq=.false. + else + inq=.true. + endif + + if (delim .eq. '[') then + irange=pin + call dat_get_item(listin, pin, delim) + jrange=pin-1 + if (jrange .ge. len(listin)) + 1 call str_trim(listin, listin, jrange) + if (.not. syntaxonly) then + if (jrange .gt. irange+1) then + call dat_set_options(listin(irange+1:jrange-1)) + else + call dat_set_options(' ') + endif + endif + range_out=.true. + if (delim .ne. ',' .and. delim .ne. ' ') then + num1=-1 + goto 10 + endif + else + jrange=irange + if (.not. syntaxonly) then + call dat_set_options(' ') + endif + endif + + if (num1 .ge. 0 .and. num2 .ge. num1 .and. ny .ge. -1) then ! numor given + + spec_out=.false. + if (ispec2 .gt. ispec1+1) then + if (listin(ispec1+1:ispec2-1) .ne. spec) then + call str_lowcase(spec,listin(ispec1+1:ispec2-1)) + spec_out=.true. + endif + elseif (numor .eq. undef_numor) then + spec_out=.true. + endif + + year_out=.false. + if (ny .ge. 0) then + if (ny .lt. 64) then + ny=2000+ny + elseif (ny .lt. 100) then + ny=1900+ny + endif + if (ny .ge. 1900 .and. ny .lt. 2100) then + if (ny .ne. year) then + year=ny + year_out=.true. + endif + else + call str_trim(filename, listin, lf) + goto 99 + endif + elseif (numor .eq. undef_numor) then + year_out=.true. + endif + + i = index(spec, '/') + if (i .gt. 1) then + shortspec=spec(1:i-1) + else + shortspec=spec + endif + call sys_getenv('dat_alias_'//shortspec, filtype) + if (filtype .ne. ' ') spec=filtype + call sys_getenv('dat_type_'//shortspec, filtype) + call str_upcase(filtype, filtype) + call dat_find_type(filtype, i) + if (i .ne. 0) dtype=i + + if (syntaxonly) then + stat=1 + if (ny .gt. 0) stat=2 + call dat_open_raw(0,spec,num1,year,filename,stat) ! syntax only + else + if (spec .eq. ' ' .and. hint) then + hint=.false. + print *,'run number(s) without instrument entered' + print '(x,a,$)','enter the instrument or project name: ' + read(*,'(a)',end=19,err=19) spec + call str_lowcase(spec, spec) + endif +19 stat=1 + if (ny .gt. 0) stat=2 + call dat_open_raw(lun,spec,num1,year,filename,stat) + endif + if (spec .ne. ' ') then + write(cyr, '(i4.4)') year + call sys_setenv('dat_defyear', cyr) + call sys_setenv('dat_defspec', spec) + call sys_saveenv + endif + + if (stat .eq. 0) then + lf=0 + call dat_put_str(filename, lf, spec) + call dat_put_str(filename, lf, specout) + call dat_put_int(filename, lf, year) + call dat_put_str(filename, lf, specout) + call dat_put_int(filename, lf, num1) + print *,filename(1:lf),' not found' + filename=' ' + + else + if (.not. syntaxonly) then + + if (dtype .ne. 0) then + call dat_read(dtype,lun,0,nread,putval,nmax,xx,yy,ss,ww) + else + nread=-1 + endif + if (nread .eq. -1) then + do_calib=.false. + do i=1,ntypes + if (i .ne. dtype) then + call dat_read(i, lun, 0, nread, putval, nmax + 1 , xx,yy,ss,ww) + if (nread .ne. -1) goto 20 + endif + enddo +20 continue + else + do_calib=.true. + endif + +! call str_trim(filename, filename, lf) + call sys_parse(filename, lf, filename, ' ', 0) + if (nread .lt. 0) then + close(lun) + print *,filename(1:lf),' unreadable' + dirty=.true. + if (log_it) call dat_end_options + goto 29 + endif + + call dat_group(2, putval) + call putval('File='//filename(1:lf), 0.0) + call dat_group(1, putval) + + text=' ' + if (do_calib) then + calfil=' ' + call dat_str_option('cal', calfil) + filter=-1 + call dat_real_option('filter', filter) + log_filter=.true. + if (filter .lt. 0) then + log_filter=.false. + calspec='spikefilter_'//shortspec + call sys_getenv(calspec, filtertext) + filter=0 + read(filtertext, '(f32.0)', iostat=iostat) filter + endif + if (calfil .eq. '0') then + text='(uncalibrated)' + call dat_group(2, putval) + call putval('calibration=0',0.0) + goto 230 + endif + idx=0 + +200 continue ! try-again loop + + if (idx .lt. 10) then + calspec='dat_calist_'//shortspec + call sys_getenv_idx(calspec, tmpfil, idx) + else + calspec='dat_calib_'//shortspec + call sys_getenv_idx(calspec, tmpfil, idx-10) + endif + if (tmpfil .eq. ' ') then + if (idx .ge. 10) goto 221 ! give up + ! end of dat_calist_xxx list, try dat_calib_xxx list + idx=10 + goto 200 + endif + idx=idx+1 + + call dat_insert_year(tmpfil, year, ok) + if (calfil .ne. ' ') then + call sys_parse(tmpfil, tf, calfil, tmpfil, 0) + else + call str_trim(tmpfil, tmpfil, tf) + endif +205 call sys_open(lun,tmpfil(1:tf),'r',iostat) ! readonly + if (iostat .ne. 0) then + if (idx .lt. 100) goto 200 ! try again + goto 221 ! give up + endif +! calibration + read(lun, '(a)',end=227,err=227) text + if (text(1:6) .eq. 'calist') then + idx=100 ! do not try again + read(lun, '(i10,a)',end=227,err=227) i, text + if (i .ne. 1) then + print *,'first numor in CALIST must be 1' + goto 227 + endif +210 call str_trim(calfil, text, lcf) + read(lun, '(i10,a)',end=211,err=211) i, text + if (i .le. num1) goto 210 +211 close(lun) + if (calfil(1:lcf) .eq. ' ') goto 226 + call str_first_nonblank(calfil(1:lcf), i) + call sys_parse(tmpfil, tf, calfil(i:lcf), tmpfil, 0) + goto 205 + endif + if (text(1:1) .eq. '#') then + call str_trim(caltxt, text(2:), l) +220 read(lun, '(a)',end=227,err=227) text + if (text(1:1) .eq. '#') goto 220 + else + l=0 + endif + if (tmpfil(1:tf) .ne. calast) then + calast=tmpfil(1:tf) + if (log_it) then + print '(x,2a)' + 1 ,'calibration file: ',tmpfil(1:tf) + if (l .gt. 0) + 1 print '(x,3a)' + 1 ,' (',caltxt(1:l),')' + endif + endif + read(text,*,err=227,end=227) n + if (n .ne. nread) then + write(text, '(a,2i5,a)') + 1 'calibration file does not match file length ' + 1 , n, nread, ' -> no calibration' + goto 230 + endif + nread=0 + do i=1,n + read(lun,*,end=227,err=227) calib + if (calib .gt. 0) then + nread=nread+1 + xx(nread)=xx(i) + ss(nread)=ss(i)/calib + yy(nread)=yy(i)/calib + ww(nread)=ww(i) + endif + enddo + text='and calibrated' + if (filter .ne. 0 .and. nread .ge. 5) then +c -- spike filter + spikecnt=0 + n=nread + nread=0 + do i=1,n + s2=ss(i)**2 + if (i .ge. 3) then + ymx=max(yy(i-1),2*yy(i-1)-yy(i-2)) + ymn=min(yy(i-1),2*yy(i-1)-yy(i-2)) + s2=s2+0.25*ss(i-1)**2 + else + ymx=yy(i+1) + ymn=yy(i+1) + s2=s2+0.25*ss(i+1)**2 + endif + if (i .le. n-2) then + ymx=max(ymx,yy(i+1),2*yy(i+1)-yy(i+2)) + ymn=min(ymn,yy(i+1),2*yy(i+1)-yy(i+2)) + s2=s2+0.25*ss(i+1)**2 + else + s2=s2+0.25*ss(i-1)**2 + endif + sigoff=0 + if (s2 .gt. 0) then + if (yy(i) .gt. ymx) then + sigoff = (yy(i)-ymx) / sqrt(s2) + elseif (yy(i) .lt. ymn) then + sigoff = (ymn-yy(i)) / sqrt(s2) + endif + endif + if (yy(i) .eq. 0) then + if (log_filter) then + print '(i6,a,f7.2,a,i5,a)' + 1 ,num1,': zero at',xx(i) + 1 ,' (channel ',i,')' + endif + spikecnt=spikecnt+1 + elseif (sigoff .gt. filter) then + if (log_filter) then + print '(i6,a,f7.2,a,i5,a,g8.2,a)' + 1 ,num1,': spike at',xx(i) + 1 ,' (channel ',i,',',sigoff, ' sigma)' + endif + spikecnt=spikecnt+1 + else + nread=nread+1 + xx(nread)=xx(i) + ss(nread)=ss(i) + yy(nread)=yy(i) + ww(nread)=ww(i) + endif + enddo + call str_trim(text, text, lt) + if (spikecnt .gt. 10) then + write(text(lt+1:), '(i5,a)') spikecnt, ' spikes' + elseif (spikecnt .gt. 0) then + write(text(lt+1:), '(i2,a)') spikecnt, ' spikes' + endif + endif + call dat_group(2, putval) + call putval('calibration='//caltxt(1:l),0.0) + goto 230 + +221 if (tmpfil .eq. ' ') then + call sys_getenv_idx(calspec, tmpfil, 0) + endif + call sys_parse(tmpfil, tf, tmpfil, ' ', 3) + call str_trim(text, tmpfil, tf) + if (text(1:tf) .ne. ' ') then + text(tf+1:)=' not found -> no calibration' + endif + calast=' ' + goto 230 + +226 text='(uncalibrated)' + calast=' ' + goto 230 + +227 text='error in ' + call sys_parse(text(10:), tf, tmpfil, ' ', 3) + text(10+tf:)=' -> no calibration' + calast=' ' + +230 close(lun) + endif + if (log_it) call dat_end_options + + call str_trim(text, text, l) + if (log_it) then + print *,filename(1:lf),' opened ',text(1:l) + endif + call dat_group(1, putval) + call putval('Numor', float(num1)) + + endif + + if (pout .eq. 0) then + spec_out=.true. + year_out=.true. + krange=-1 + endif + + if (spec_out) then + call dat_put_str(listout, pout, spec) + call dat_put_str(listout, pout, specout) + numor=undef_numor + endif + if (stat .eq. 2 .and. year_out) then + call dat_put_int(listout, pout, year) + call dat_put_str(listout, pout, specout) + endif + + if (num1 .ne. numor+1 .or. dirty .or. irange .ne. krange) then + if (num1 .ne. numor) call dat_put_int(listout, pout, num1) + np=pout + if (irange .lt. jrange) then + call dat_put_str(listout, pout, listin(irange:jrange)) + endif + krange=irange + call dat_put_str(listout, pout, ',') + else + pout=np + call dat_put_str(listout, pout, '-') + call dat_put_int(listout, pout, num1) + if (irange .lt. jrange) then + call dat_put_str(listout, pout, listin(irange:jrange)) + endif + krange=irange + call dat_put_str(listout, pout, ',') + endif + + endif + + dirty=.false. +29 numor=num1 + if (num1 .lt. num2) then + pin=hyp-1 + endif + + goto 98 + endif + + if (namend .gt. iname+1) then ! file name given + + call sys_parse(filename, lf, listin(iname+1:namend-1), ' ', 0) + if (lf .eq. 0) + 1 call str_trim(filename,listin(iname+1:namend-1),lf) + nam_out=.true. + + elseif (irange .lt. jrange) then + + nam_out=.false. ! take last filename + + else + + goto 98 ! neither filename nor range given + + endif + + numor=undef_numor + if (syntaxonly) goto 39 + + call sys_open(lun,filename(1:lf),'r',iostat) ! readonly + if (iostat .ne. 0) goto 99 + + call dat_group(2, putval) + call putval('File='//filename(1:lf), 0.0) + call dat_group(1, putval) + if (log_it) print *,filename(1:lf),' opened' + + if (dtype .ne. 0) then ! try first with default type + call dat_read(dtype, lun, -1, nread, putval, nmax, xx,yy,ss,ww) + if (nread .ne. -1) goto 39 + endif + + do i=1,ntypes + if (i .ne. dtype) then + call dat_read(i, lun, 0, nread, putval, nmax, xx, yy, ss, ww) + if (nread .ne. -1) goto 39 + endif + enddo + + if (dtype .ne. 0) then ! forced read with default type + call dat_read(dtype, lun, 1, nread, putval, nmax, xx,yy,ss,ww) + if (nread .ne. -1) goto 39 + endif + +35 if (nread .ge. 0) goto 39 + if (inq) then + print *,'Select file type' + print * + do i=1,ntypes + call dat_desc(i, text) + call str_trim(text, text, l) + print '(i3,x,a)',i,text(1:l) + enddo + print * + print '(x,a,$)','Type:' + read(5,'(a)',end=37,err=37) filtype + if (filtype .eq. ' ') goto 37 + endif + + call str_upcase(filtype, filtype) + call dat_find_type(filtype, i) + if (i .ne. 0) then + dtype=i + else + if (inq) then + read(filtype,*,err=35,end=35) dtype + if (dtype .le. 0 .or. dtype .gt. ntypes) goto 35 + else + print *,'unknown file type: ',filtype + endif + endif + + call dat_read(dtype, lun, 1, nread, putval, nmax, xx, yy, ss, ww) + if (nread .lt. 0) then + print *,filename(1:lf),' unreadable' + goto 95 + endif + +39 if (log_it) call dat_end_options + if (pout .eq. 0) krange=-1 + if (nam_out .or. pout.eq.0) then + call dat_put_str(listout, pout, filename(1:lf)) + endif + if (irange .lt. jrange .and. irange .ne. krange) then + call dat_put_str(listout, pout, listin(irange:jrange)) + krange=irange + endif + call dat_put_str(listout, pout, ',') + if (nmax .gt. 0) log_it=.true. + goto 100 + +37 print *,'illegal type' +95 close(lun) + goto 98 + +99 print *,filename(1:lf),' not found' +98 if (nmax .gt. 0) log_it=.true. +100 return + + + entry dat_read_again(putval, nmax, nread, xx, yy, ss, ww) + + if (lf .gt. 0 .and. lun .ne. 0) then + call sys_open(lun,filename(1:lf),'r',iostat) ! readonly + if (iostat .ne. 0) goto 99 + + call dat_read(0, lun, 0, nread, putval, nmax, xx, yy, ss, ww) + if (nread .lt. 0) then +c print *,'error in ',filename(1:lf) + close(lun) + endif + endif + return + + + entry dat_get_filename(filnam, len_name) + + call str_trim(filnam, filename, len_name) + return + + + entry dat_settyp(spec_def) + + call dat_init + call dat_find_type(spec_def, i) + if (i .ne. 0) dtype=i + return + + + entry dat_silent + + log_it=.false. + return + + entry dat_get_silent(silent) + + silent=.not. log_it + return + + entry dat_setyear(year_def) + + if (year_def .lt. 1900 .or. year_def .gt. 2200) then + print *,year_def + stop 'illegal year' + endif + call dat_init + year=year_def + return + + + entry dat_getdef(spec_def) + + call dat_init + if (spec .eq. ' ') then + spec_def=' ' + else + i=index(spec, '/') + if (i .le. 1) then + shortspec=spec + else + shortspec=spec(1:i-1) + endif + call sys_getenv_idx('dat_spec_'//shortspec, tmpfil, 0) + call str_trim(spec, spec, l) + if (index(tmpfil, '%%') .ne. 0) then + write(tmpfil, '(2a,i4.4,a)') spec(1:l), specout, year, specout + spec_def=tmpfil(1:l+6) + else + spec_def=spec(1:l)//specout + endif + endif + return + + + entry dat_gettyp(spec_def) + + call dat_init + if (last_type .eq. 0) last_type=dtype + if (last_type .eq. 0) then + spec_def=' ' + else + call dat_desc(last_type, spec_def) + i=index(spec_def, ' ') + if (i .ne. 0) spec_def=spec_def(1:i) + endif + return + + + entry dat_get_high(high_numor) + + high_numor=0 ! assume failure + call dat_init + i=index(spec, '/') + if (i .le. 1) then + shortspec=spec + else + shortspec=spec(1:i-1) + endif + call sys_getenv('dat_type_'//shortspec, filtype) + call dat_find_type(filtype, i) + if (i .eq. 0) return + do m=0,32 + call sys_getenv_idx('dat_high_'//shortspec, tmpfil, m) + if (tmpfil .eq. ' ') RETURN + call dat_insert_year(tmpfil, year, ok) + call dat_high(i, tmpfil, high_numor) + if (high_numor .ne. 0) RETURN + enddo + end + + + subroutine dat_find_type(type, idx) + + character type*(*) + integer idx + + include 'dat.inc' + + integer i, j + character text*80 + +c try first default type + i=dtype + if (i .gt. 0 .and. i .le. ntypes) then + call dat_desc(i, text) + j=index(text, ' ') + if (j .ne. 0 .and. type .eq. text(1:j)) then + idx=i + return + endif + endif + +c and then all the others + + do i=1,ntypes + if (i .ne. dtype) then + call dat_desc(i, text) + j=index(text, ' ') + if (j .ne. 0 .and. type .eq. text(1:j)) then + idx=i + return + endif + endif + enddo + + idx=0 + + end + + + subroutine dat_cvt_number(str, number) + + implicit none + + character str*(*) + integer number + + integer i + logical valid + + number=0 + valid=.false. + do i=1,len(str) + if (str(i:i) .eq. ' ') then + if (valid) then + if (str(i:) .ne. ' ') then ! trailing spaces + number=-1 + endif + return + endif + elseif (str(i:i) .lt. '0' .or. str(i:i) .gt. '9') then + number=-1 + return + endif + valid=.true. + number=number*10+ichar(str(i:i))-ichar('0') + enddo + if (.not. valid) number=-1 + end + + + subroutine dat_get_item(listin, pos, delim) + + character listin*(*) + character delim*1 + integer pos + + integer i,j + include 'dat.inc' + + if (pos .gt. 0) then + if (listin(pos:pos) .eq. '[') then + pos=pos+index(listin(pos+1:), ']') ! skip what is between + endif + if (listin(pos:pos) .eq. '(') then + pos=pos+index(listin(pos+1:), ')') ! skip what is between + endif + endif + do i=pos+1,len(listin) + if (listin(i:i) .eq. ',') then + delim=',' + pos=i + return + endif + if (listin(i:i) .eq. specin) then + delim=specin + pos=i + return + endif + if (listin(i:i) .eq. '-') then + delim='-' + pos=i + return + endif + if (listin(i:i) .eq. '(') then + delim='(' + pos=i + return + endif + if (listin(i:i) .eq. '[') then + j=index(listin(i:),']') + if (j .gt. 0) then + j=i+j + if (j .gt. len(listin)) then ! ']' is at end + delim='[' + pos=i + return + endif + if (listin(j:j) .eq. ',' .or. listin(j:j) .eq. ' ') then ! ']' is at end or before a ',' + delim='[' + pos=i + return + endif + endif + endif + enddo + delim=' ' + pos=len(listin)+1 + end + + + subroutine dat_put_str(listout, pout, str) + + character listout*(*), str*(*) + integer pout + + integer l + + if (pout .lt. len(listout)) then + call str_trim(listout(pout+1:), str, l) + pout=pout+l + if (pout .lt. len(listout)) return + endif + listout(len(listout)-2:)='...' + end + + + subroutine dat_put_int(listout, pout, ival) + + character listout*(*) + integer pout, ival + + character str*12 + integer i + + write(str, '(i12)') ival + do i=11,1,-1 + if (str(i:i) .eq. ' ') then + call dat_put_str(listout, pout, str(i+1:)) + return + endif + enddo + print *,ival + stop 'DAT_PUT_INT: integer conversion error' + end + + + + subroutine dat_open_raw(lun,instr,num,year,filename,status) +! ----------------------------------------------------------- + + integer lun ! (in) logical unit number (lun=0: sytax only) + character instr*(*) ! (in) instrument name + integer num ! (in) numor (0 if not used) + integer year ! (in) year (0 if not used) + character filename*(*) ! (out) filename + integer status ! (out) 0: not found + ! 1: specification without year + ! 2: specification with year + ! (in) 1: year was not given + ! (in) 2: year was given + +! create a raw data file name from instrument name, year, num +! and the environment variable dat_spec_INSTR +! dat_spec_INSTR may contain several paths separated with "," +! if only an extension is given, the preceding path is used +! with exchanged extension +! %%%% are replaced by year, ***** by numor, ### by thousands of numor +! if a numor does not fit into the space forseen, the filename +! will be lengthened. For the ### substitution, overflow digits are +! skipped. + + character numor*12, filnam*128, path*128, rawname*128, spec*128 + character tascomdir*80, dyear*4 + integer l,n,m,i,j,iraw,lr,idx, iostat + logical ok, hint/.true./, slash + + l=index(instr, '/')-1 + if (l .le. 0) then + call str_trim(spec, instr, l) + slash = .false. + else + spec=instr(1:l) + slash = .true. + endif + do idx=0,32 + call sys_loadenv + call sys_getenv_idx('dat_spec_'//spec(1:l),path,idx) + if (path .eq. ' ') then + if (idx .ne. 0 .or. num .le. 0 .or. .not. hint + 1 .or. spec(1:l) .eq. ' ') goto 19 + hint=.false. + print *,spec(1:l),' is unknown' + print * + print * + 1 ,'Reading many files with a number in the name is much simpler ' + 1 ,'when the path is known to fit. You may define now how your ' + 1 ,'filenames for '//spec(1:l) + 1 //' look like. Put asterisks at the place where the ' + 1 ,'number should appear. ' + print * + print *,'Example:' + print *,'path for ',spec(1:l),': iron***.dat' + print * + 1,'When you later enter: ',spec(1:l),'/98-100' + print * + 1,'the files iron098.dat,iron099.dat,iron100.dat will be read in.' +5 print * + print '(x,3a,$)','path for ',spec(1:l),': ' + read(*,'(a)',end=19,err=19) path + print * + if (path .eq. ' ') goto 19 + if (index(path,'*') .eq. 0) then + print * + 1,'the path does not contain an asterisk (*), enter it again' + goto 5 + endif + call sys_setenv('dat_spec_'//spec(1:l), path) + call sys_saveenv + endif + if (path(1:1) .eq. '.' .and. idx .gt. 0) then + do j=lr,1,-1 + if (rawname(j:j) .eq. '.') then + lr=j-1 + goto 9 + endif + enddo +9 continue + call str_trim(rawname, rawname(1:lr)//path, lr) + else + call str_trim(rawname, path, lr) + endif + +c print *,'raw:',rawname(1:lr),' num:',num + + i=index(rawname, '%t') ! special case: tascom data + if (i .gt. 0 .and. .not. slash .and. status .eq. 1) then + print '(x,a,i4,a,$)', 'year [',year,']: ' + n=0 + read(*,'(i10)',iostat=iostat) n + if (n .ge. 1900 .and. n .le. 2064) then + year=n + endif + write(dyear, '(i4.4)') year + call sys_setenv('dat_defyear', dyear) + call sys_saveenv + endif + + status=1 + call dat_insert_year(rawname(1:lr), year, ok) + if (ok) then + if (year .lt. 1900 .or. year .gt. 2200) then + print *,'illegal year: ', year + goto 19 + endif + status=2 + endif + + if (i .gt. 0) then ! special case: tascom data + rawname(i:)=' ' + if (.not. slash) then + call dat_tascom_datadir(rawname, tascomdir) + if (tascomdir .eq. '0') goto 18 + if (tascomdir .eq. ' ') goto 19 + if (l .gt. len(instr)-2) goto 19 + instr(l+1:l+1)='/' + slash=.true. + instr(l+2:)=tascomdir + rawname(i:)=tascomdir + else + if (l .gt. len(instr)-2) goto 19 + rawname(i:)=instr(l+2:) + endif + call str_trim(rawname, rawname, lr) + n=i + do j=i,lr + if (rawname(j:j) .eq. '/') then + n=j + endif + enddo + if (n+12 .lt. len(rawname)) then + do j=lr+1,n+8 + rawname(j:j) = '*' + enddo + rawname(n+9:)='.dat' + lr=n+12 + endif + endif + iraw=index(rawname(1:lr),'*') + if (iraw .eq. 0) then + call str_trim(filnam, rawname(1:lr), j) + if (num .gt. 0) then + print *,'path does not contain "*":',rawname(1:lr) + goto 19 + endif + else + if (num .eq. 0) then + call str_trim(instr, instr, i) + if (status .eq. 2) then + print '(x,3a,i4,a,$)', + 1 'Numor for ',instr(1:i),' (',year,'): ' + else + print '(x,3a,$)','Numor for ',instr(1:i),': ' + endif + read(*,'(i10)', iostat=iostat) num + endif + if (num .le. 0) then + print *,'numor must be positive: ', num + goto 19 + endif + if (iraw .gt. 1) filnam(1:iraw-1)=rawname(1:iraw-1) ! copy first part of filename + write(numor,'(X,I11)') num + n=13 + m=10 + do i=1,lr + if (rawname(i:i) .eq. '*') then + n=n-1 ! count down position in string numor + if (numor(n:n) .lt. '0') numor(n:n)='0' + else if (rawname(i:i) .eq. '#') then ! count down from thousand pos. + m=m-1 + endif + enddo + i=n-1 + do while (numor(i:i) .ge. '0') ! find head of number (space) + i=i-1 + enddo + numor(1:i)='00000000000' + i=i+1 + if (i .lt. n) then + filnam(iraw:iraw+n-i-1)=numor(i:n-1) ! insert head part of number + j=iraw+n-i + else + j=iraw + endif + do i=iraw,lr ! replace stars by number and copy rest of name + if (rawname(i:i) .eq. '*') then + filnam(j:j)=numor(n:n) + n=n+1 + else + filnam(j:j)=rawname(i:i) + endif + j=j+1 + enddo + j=j-1 + do i=1,j + if (filnam(i:i) .eq. '#') then + filnam(i:i)=numor(m:m) + m=m+1 + endif + enddo + endif + filename=filnam(1:j) + if (lun .ne. 0) then + call sys_open(lun,filnam(1:j),'r',iostat) ! readonly + if (iostat .eq. 0) RETURN + else + RETURN + endif +18 continue + enddo + +19 status=0 + filename=' ' + return + end diff --git a/gen/dat_rita.f b/gen/dat_rita.f new file mode 100644 index 0000000..4183ae5 --- /dev/null +++ b/gen/dat_rita.f @@ -0,0 +1,258 @@ + subroutine dat_rita +c ------------------- + + external dat_rita_desc + external dat_rita_opts + external dat_rita_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_rita_desc) + call dat_init_opts(dtype, dat_rita_opts) + call dat_init_read(dtype, dat_rita_read) + end + + + subroutine dat_rita_desc(text) +! ------------------------------ + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='RITA TASCOM (RITA) format' + end + + + subroutine dat_rita_opts +! ------------------------ + print '(x,a)' + 1,'x,y,mon: xaxis,yaxis,monitor to be choosen' + end + + + subroutine dat_rita_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer mcol + parameter (mcol=64) + + character line*1024, xaxis*8, yaxis*8, monam*8, name*8, col1*8 + character fih*132 + real values(64), r, f, s, y, ymon + real tt, tm, ts, td, xmon + integer i,j,l,ncol,ccol,pcol,xcol,tcol + integer iostat + + nread=0 +10 read(lun,'(a)',err=98,end=98) line + if (line .eq. ' ') goto 10 + + if (forced .le. 0) then + if (line(1:4).ne.'#fdt') goto 100 + endif + + xaxis=' ' + yaxis=' ' + monam='MON' + + call dat_start_options + call dat_str_option('x', xaxis) + call dat_str_option('y', yaxis) + call dat_str_option('mon', monam) + + call str_upcase(xaxis, xaxis) + call str_upcase(yaxis, yaxis) + call str_upcase(monam,monam) + + call dat_group(1, putval) + call putval('Instrument=RITA',0.0) + +11 continue + call str_trim(line, line, l) + l=max(10,min(l,len(line))) + + if (line(1:4) .eq. '#fdt') then + call dat_group(2, putval) + i=index(line(10:l), ' ')+9 + call putval('OrigFile='//line(10:i), 0.0) + call dat_group(1, putval) + call putval('Date='//line(i+1:l), 0.0) + else if (line(1:4) .eq. '#txt') then + call dat_group(1, putval) + call putval('Title='//line(10:l), 0.0) + else if (line(1:4) .eq. '#cmd') then + call dat_group(2, putval) + call putval('cmd='//line(10:l), 0.0) + else if (line(1:4) .eq. '#fih') then + fih=line(5:) + else if (line(1:4) .eq. '#fhp') then + call dat_group(2, putval) + do i=1,mcol + values(i)=0.0 + enddo + ncol=0 + i=1 + read(line(5:), *, err=15,end=15) values +15 call str_get_elem(fih, i, name) + if (name .ne. ' ') then + ncol=ncol+1 + call putval(name, values(ncol)) + goto 15 + endif + else if (line(1:4) .eq. '#fip') then + line(1:4)=' ' + goto 12 + else if (line(1:4) .eq. '#plp') then + continue ! ignore + else if (line(1:4) .eq. '#pls') then + continue ! ignore + else if (line(1:4) .eq. '#fmp') then + continue ! ignore + else if (line(1:4) .eq. '#plv') then + i=5 + call str_get_elem(line, i, name) + if (xaxis .eq. ' ') xaxis=name + call str_get_elem(line, i, name) + if (yaxis .eq. ' ') yaxis=name + else if (line(1:4) .eq. '#com') then + continue + elseif (line(1:l) .ne. ' ') then + print *,'unknown header line: ',line(1:l) + endif + read(lun, '(a)') line + goto 11 + +12 i=1 + line(len(line):len(line))=' ' + ncol=0 + ccol=0 + pcol=0 + tcol=0 + xcol=0 + col1=' ' + ymon=0 +31 do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 39 + enddo + l=i + do while (line(i:i) .ne. ' ') + i=i+1 + enddo + ncol=ncol+1 + if (ncol .eq. 1) col1=line(l:i) + if (line(l:i) .eq. yaxis .or. yaxis .eq. ' ' + 1 .and. line(l:i) .eq. 'I') ccol=ncol + if (line(l:i) .eq. monam) pcol=ncol + if (line(l:i) .eq. xaxis) xcol=ncol + if (line(l:i) .eq. 'TT') tcol=ncol + if (tcol .eq. 0 .and. line(min(i,l+1):i) .eq. 'TEM') tcol=ncol + goto 31 + +39 if (yaxis .eq. ' ') yaxis='I' + if (ccol .eq. 0) then + print *,'no values found for ',yaxis + goto 99 + endif + if (pcol .eq. 0) then + xmon=0 + read(monam, *, iostat=iostat) xmon + if (xmon .le. 0) then + if (monam .eq. ' ') monam='Monitor' + print *,'no values found for ',monam,' take 1' + xmon=1 + endif + endif + if (xcol .eq. 0) then + if (xaxis .ne. ' ') then + print *,'no values found for ',xaxis,', take ',col1 + endif + xcol=1 + xaxis=col1 + endif + + call dat_group(2, putval) + call putval('XAxis='//xaxis, 0.0) + if (yaxis .eq. 'I') then + call putval('YAxis=Intensity', 0.0) + else + call putval('YAxis='//yaxis, 0.0) + endif + call dat_group(1, putval) + + l=min(mcol,max(xcol,pcol,ccol,tcol)) + f=1.0 + tm=0 + ts=0 + +4 read(lun,*,err=19,end=9) (values(j),j=1,l) + if (nread .ge. nmax) goto 29 + y=values(ccol) + if (pcol .eq. 0) then + r=xmon + else + r=values(pcol) + endif + if (ymon .eq. 0) then + ymon=r + if (r .eq. 0) r=1. + endif + if (r .le. 0.0) r=ymon + f=ymon/r + if (f .le. 0.0) f=1.0 + if (y .gt. 0) then + s=sqrt(y) ! statistical error of detector + else + s=1 + endif + nread=nread+1 + xx(nread)=values(xcol) + yy(nread)=y*f + ss(nread)=s*f + ww(nread)=r + if (tcol .ne. 0) then + tt=values(tcol) + td=(tt-tm)/nread + tm=tm+td ! mean temp. + ts=ts+(tt-tm)**2+td*td*(nread-1) ! sum of (temp(i)-mean)**2 +c print *,'temp',tt,tm,ts + endif + goto 4 + +9 close(lun) + call putval('Monitor', ymon) + if (tcol .ne. 0) then + call putval('Temp', tm) + if (nread .gt. 1) call putval('dTemp', sqrt(ts/(nread-1))) + endif + return + +19 print *,'DAT_RITA: error at point ',nread + goto 4 +29 print *,'DAT_RITA: too many points' + goto 100 +98 if (forced .le. 0) goto 100 +99 print *,'DAT_RITA: error during read' + rewind lun + nread=-2 + return +100 nread=-1 + rewind lun + end diff --git a/gen/dat_sics.f b/gen/dat_sics.f new file mode 100644 index 0000000..26d35c0 --- /dev/null +++ b/gen/dat_sics.f @@ -0,0 +1,317 @@ + subroutine dat_sics +c ------------------- + + external dat_sics_desc + external dat_sics_opts + external dat_get_datanumber + external dat_sics_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_sics_desc) + call dat_init_opts(dtype, dat_sics_opts) + call dat_init_high(dtype, dat_get_datanumber) + call dat_init_read(dtype, dat_sics_read) + end + + + subroutine dat_sics_desc(text) +! ------------------------------ + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='SICS SICS-ASCII (TOPSI,TriCS)' + end + + + subroutine dat_sics_opts +! ------------------------ + print '(x,a)' + 1,'x,y: x-axis and y-axis column name' + end + + + subroutine dat_sics_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer mcol + parameter (mcol=32) + real y,s,r,f,ymon,values(mcol),val + integer i,j,l,errcnt,ncol,ycol,pcol,xcol,ycol2,ipol,xcol0 + integer iostat, lz + logical pol + character line*132, preset*16, col2*16 + character xaxis*16, xaxis0*16, yaxis*16, yaxis2*16 + + read(lun,'(a)',err=100,end=100) line + + if (line(1:16) .eq. '##SICS ASCII at ') then + call putval('Instrument='//line(17:),0.0) + else + i=index(line,'Data File ****') + if (i .eq. 0) i=index(line,'SCAN File ****') + if (i .eq. 0) then + if (forced .le. 0) goto 100 + else + j=index(line,'*** ') + if (j .lt. i) call putval('Instrument='//line(j+4:i-2),0.0) + endif + endif + + nread=0 + errcnt=0 + xcol=0 + xcol0=0 + +1 read(lun, '(a)', err=99,end=99) line + iostat=1 + if (line(1:20) .ne. 'Scanning Variables: ' + 1 .and. line(1:20) .ne. 'scanning variables: ') then + i=index(line,'=') + if (i .le. 1) goto 1 + call str_first_nonblank(line(i+1:), j) + call str_trim(line(1:i-1), line(1:i-1), l) + iostat=1 + if (line(1:l) .eq. 'Sample Name') then + l=6 + elseif (line(1:l) .eq. 'Original Filename' .or. + 1 line(1:l) .eq. 'original_filename') then + goto 1 + elseif (line(1:l) .eq. 'Title' .or. + 1 line(1:l) .eq. 'title') then + call dat_group(1, putval) + elseif (line(1:13) .eq. 'File Creation' .or. + 1 line(1:4) .eq. 'date') then + line(1:l)='Date' + l=4 + else if (line(i+j:i+j) .eq. '-' .or. + 1 line(i+j:i+j) .ge. '0' .and. + 1 line(i+j:i+j) .le. '9') then + if (line(1:l) .eq. 'Sample Theta') then + line(1:l)='2-theta' + l=7 + else if (line(1:l) .eq. 'Temperature' .or. + 1 line(1:l) .eq. 'temp') then + line(1:l)='Temp' + l=4 + endif + lz=index(line(1:l),' ') + if (lz .ne. 0) then + if (line(lz:lz+4) .eq. ' zero') then + l=lz+1 + line(1:l)='Z'//line(1:lz) + else + line(1:l)=line(lz+1:l) + l=l-lz + endif + endif + if (index(line(i+j:),':') .ne. 0) then + iostat=1 + else + read(line(i+j:), *, iostat=iostat) val + endif + endif + if (iostat .eq. 0) then + call putval(line(1:l), val) + else + call putval(line(1:l)//'='//line(i+j:), 0.0) + endif + if (line(1:l) .eq. 'wavelength') then + call dat_group(2, putval) + endif + goto 1 + endif + l=index(line, 'Steps:') + if (l .gt. 0) then + do j=1,mcol + values(j)=0 + enddo + read(line(l+6:), *,iostat=iostat) values + do j=1,mcol + if (values(j) .ne. 0) then + xcol0=j+1 + goto 19 + endif + enddo + endif + l=index(line(21:), ',') + if (l .eq. 0) l=10 + xaxis=line(21:20+l-1) +19 continue + + read(lun, '(a)', err=99,end=99) line + l=index(line, 'Mode: ') + if (l .ne. 0) then + preset=line(l+6:) + l=index(preset, ',') + if (l .eq. 0) goto 99 + preset(l:)=' ' + call putval('Preset='//preset, 0.0) + l=index(line, 'Preset') + if (l .eq. 0) goto 99 + read(line(l+6:), *, err=99,end=99) ymon + pol=.false. + else ! polarized scan +22 read(lun, '(a)', err=99,end=99) line + if (line(1:17) .eq. 'zero for plotting') goto 22 + preset='mn' + ymon=0 + pol=.true. + endif + + ipol=1 + yaxis2=' ' + call dat_start_options + i=0 + call dat_str_option('x', xaxis) + yaxis='Counts' + call dat_str_option('y', yaxis) + call dat_str_option('y2', yaxis2) + if (yaxis .eq. '1') then + if (pol) then + yaxis='up' + else + yaxis='Monitor1' + endif + elseif (yaxis .eq. '2') then + if (pol) then + yaxis='dn' + else + yaxis='Monitor2' + endif + elseif (yaxis .eq. '3') then + yaxis='Monitor3' + else if (yaxis .eq. 'Counts') then + if (pol) then + yaxis='up' + yaxis2='dn' + ipol=2 + endif + endif + + read(lun,'(a)',err=99,end=99) line + + i=1 + line(len(line):len(line))=' ' + ncol=0 + ycol=0 + ycol2=0 + pcol=0 + col2=' ' +31 do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 39 + enddo + l=i + do while (line(i:i) .ne. ' ') + i=i+1 + enddo + ncol=ncol+1 + if (ncol .eq. 2) col2=line(l:i) + if (line(l:i) .eq. yaxis .and. ycol .eq. 0) then + ycol=ncol + elseif (line(l:i) .eq. yaxis2 .and. ycol2 .eq. 0) then + ycol2=ncol + elseif (line(l:i) .eq. preset .or. + 1 line(l:i) .eq. 'Monitor1' .and. preset .eq. 'Monitor') then + pcol=ncol + elseif (line(l:i) .eq. xaxis) then + xcol=ncol + elseif (xcol0 .eq. ncol) then + xaxis0 = line(l:i) + endif + goto 31 + +39 if (ycol .eq. 0) goto 99 + if (xcol .eq. 0) then + if (xcol0 .ne. 0) then + xcol = xcol0 + xaxis = xaxis0 + else + xcol=2 + xaxis=col2 + endif + endif + call dat_group(1, putval) + call putval('XAxis='//xaxis, 0.0) + call putval('YAxis='//yaxis, 0.0) + if (ycol2 .eq. 0) ipol=1 + + l=min(mcol,max(xcol,pcol,ycol,ycol2)) +40 read(lun,'(a)',end=88,err=88) line + if (line .eq. ' ') goto 40 + if (line .eq. 'END-OF-DATA') goto 88 + read(line,*,err=99,end=99) (values(j),j=1,l) + if (nread .ge. nmax) goto 29 + + if (pcol .eq. 0) then + if (ymon .eq. 0) ymon=1. + r=ymon + else + r=values(pcol) + if (r .gt. 0) then + if (ymon .eq. 0) ymon=r + else + if (ymon .eq. 0) ymon=1. + r=ymon + endif + endif + f=ymon/r + if (f .le. 0.0) f=1.0 + + do i=1,ipol + nread=nread+1 + xx(nread)=values(xcol) + if (i .eq. 1) then + y=values(ycol) + else + y=values(ycol2) + endif + if (y .gt. 0) then + s=sqrt(y) ! statistical error of detector + else + s=1 + endif + yy(nread)=y*f + ss(nread)=s*f + ww(nread)=r + enddo + goto 40 + +29 print *,'too many points - truncated' +88 close(lun) + if (ipol .gt. 0) then + call fit_dat_table(1, ipol, (nread+ipol-1)/ipol) + endif + call putval('NP', nread*1.0) + call putval('Monitor', ymon) + return + +99 nread=-2 + rewind lun + print *,'DAT_SICS: error during read' + call putval('Monitor', 0.0) + return + +100 nread=-1 + rewind lun + call putval('Monitor', 0.0) + end diff --git a/gen/dat_spec.f b/gen/dat_spec.f new file mode 100644 index 0000000..e94ecc5 --- /dev/null +++ b/gen/dat_spec.f @@ -0,0 +1,343 @@ + subroutine dat_spec +! ------------------- + + external dat_spec_desc + external dat_spec_opts + external dat_spec_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_spec_desc) + call dat_init_opts(dtype, dat_spec_opts) + call dat_init_read(dtype, dat_spec_read) + end + + + subroutine dat_spec_desc(text) +! ------------------------------ + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='SPEC spec data format (esrf)' + end + + + subroutine dat_spec_opts +! ------------------------ + print '(x,a)' + 1,'from: first dataset (default: 1)' + 1,'to: last dataset (default: from)' + 1,'x,y,mon: columns to be read (as number or name)' + 1,'space: spaces between header items (sls:1,esrf:2)' + 1,' ' + 1,'err: how to calculate error:' + 1,' err=s for sqrt(y), this is the default' + 1,' err=c for constant value' + 1,' err=p for a factor to be multiplied with y' + 1,'val: value for err=c and err=p' + end + + + subroutine dat_spec_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer maxcol, n_nn, n_nl + parameter (maxcol=64,n_nn=1024,n_nl=64) + real values(maxcol) + integer i, i1, i2, idx, l, m, nread0, iset, spc + integer nc, ncol, mcol, xcol, ycol, ycol0 + real r, ymon, errvalue + integer iostat + character line*1024, title*132, errtype*1 + character xaxis*16, yaxis*16, monam*16, xup*16, yup*16, mup*16 + character unam*16, yaxis0*16 + character prefix(n_nl)*4, names(n_nn)*16 + integer nidx(n_nl) + integer nn, nl, ni, j + + read(lun, '(a)',err=100,end=100) line + if (line(1:3) .ne. '#F') goto 100 + read(lun, '(a)',err=100,end=100) line + if (line(1:3) .ne. '#E') goto 100 + read(lun, '(a)',err=100,end=100) line + if (line(1:3) .ne. '#D') goto 100 + read(lun, '(a)',err=100,end=100) title + if (title(1:3) .ne. '#C') goto 100 + call putval('Date='//line(4:), 0.0) + call putval('Title='//title(4:), 0.0) + +!----- options ------ + call dat_start_options + i1=0 + call dat_int_option('from', i1) + i2=0 + call dat_int_option('to', i2) + spc=0 + call dat_int_option('space', spc) + if (spc .le. 0) then + spc=-1 + else + spc=spc-1 + endif + + if (i2 .eq. 0) then + if (i1 .eq. 0) then + i1=1 + i2=999999 + else + i2=i1 + endif + endif + call dat_get_index(idx) + if (idx .ne. 0) then + i1=i1+idx-1 + i2=i1 + endif + xaxis=' ' + call dat_str_option('x', xaxis) + yaxis=' ' + call dat_str_option('y', yaxis) + monam='Monitor' + call dat_str_option('mon', monam) + + call str_upcase(xup, xaxis) + call str_upcase(yup, yaxis) + call str_upcase(mup, monam) + + errtype='s' + call dat_str_option('err', errtype) + call str_upcase(errtype, errtype) + errvalue=1.0 + call dat_real_option('val', errvalue) + if (errvalue .le. 0.0) then + print *,'value for error must be > 0' + errvalue=1.0 + endif + ymon=0 + +!----- end options ------ + + nn=0 + nl=0 +!--- read parameter names --- +5 read(lun, '(a)', err=99, end=50) line + if (nl .ge. n_nl) goto 9 + if (line(1:3) .eq. '#UE') then ! this is not present at ESRF + if (spc .lt. 0) spc = 0 ! assume SLS format (one space as separator) + nl=nl+1 + prefix(nl)='UH'//line(4:5) + else if (line(1:2) .eq. '#O') then + nl=nl+1 + prefix(nl)='P'//line(3:4) + else if (line(1:1) .eq. '#') then + goto 5 + else + goto 9 + endif + if (spc .lt. 0) spc=1 ! of no #UE lines, ESRF format (2 spaces as sep.) + nidx(nl)=nn + line(len(line)-spc:)=' ' ! stopper at end + i=5 +6 continue + do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 5 + enddo + l=i + do while (line(i:i+spc) .ne. ' ') + i=i+1 + enddo + if (nn .lt. n_nn) then + nn=nn+1 + names(nn)=line(l:i) + endif + goto 6 + +9 continue + nidx(nl+1)=nn + m=0 + nread=0 + +10 read(lun, '(a)', err=99, end=50) line + if (line(1:3) .ne. '#S') goto 10 + read(line(4:), *, err=99, end=99) iset + if (iset .gt. i2) goto 50 + if (iset .lt. i1) goto 10 + + call dat_group(2, putval) +12 read(lun, '(a)', err=99, end=99) line + if (line(1:2) .eq. '#P' .or. line(1:3) .eq. '#UH') then + if (line(1:2) .eq. '#P') then + l=4 + else + l=5 + endif + do i=1,nl + if (prefix(i) .eq. line(2:l)) then + ni=nidx(i+1)-nidx(i) + do j=1,ni + values(j)=0 + enddo + read(line(l:), *, iostat=iostat) (values(j),j=1,ni) + do j=1,ni + call putval(names(nidx(i)+j), values(j)) + enddo + endif + enddo + endif + if (line(1:3) .ne. '#N') goto 12 + + call dat_group(1, putval) + + read(line(4:), *, err=99, end=99) ncol + read(lun, '(a)', err=99, end=99) line + if (line(1:3) .ne. '#L') goto 99 + xcol=0 + mcol=0 + ycol=0 + ycol0=0 + yaxis0=' ' + i=3 + line(len(line)-1:)=' ' + do nc=1,ncol + if (line(i:) .eq. ' ') goto 39 + do while (line(i:i) .eq. ' ') + i=i+1 + enddo + l=i +31 do while (line(i:i+spc) .ne. ' ') + i=i+1 + enddo + call str_upcase(unam, line(l:i-1)) + if (unam .eq. xup) then + xcol=nc + xaxis=line(l:i-1) + endif + if (unam .eq. yup) then + ycol=nc + yaxis=line(l:i-1) + endif + if (ycol .eq. 0 .and. ycol0 .eq. 0) then + if (unam .eq. 'DETECTOR' .or. unam .eq. 'APD') then + ycol0=nc + yaxis0=line(l:i-1) + endif + endif + if (unam .eq. mup) mcol=nc + enddo +39 continue + + if (xcol .eq. 0) then + read(xup, *, iostat=iostat) xcol + endif + if (ycol .eq. 0) then + read(yup, *, iostat=iostat) ycol + endif + if (mcol .eq. 0) then + read(mup, *, iostat=iostat) mcol + endif + + if (xcol .eq. 0) then + xcol=1 + if (xaxis .ne. ' ') then + call str_trim(xaxis, xaxis, l) + print *,'DAT_SPEC: ',xaxis(1:l),' not found, take 1st column' + endif + endif + if (ycol .eq. 0) then + if (ycol0 .eq. 0) then + print *,'DAT_SPEC: column not found: ',yaxis + goto 99 + endif + if (yup .ne. ' ') then + call str_trim(yaxis, yaxis, l) + print *,'DAT_SPEC: ',yaxis(1:l),' not found, take ',yaxis0 + endif + ycol=ycol0 + yaxis=yaxis0 + endif + call putval('XAxis='//xaxis,0.0) + call putval('YAxis='//yaxis,0.0) + l=min(maxcol,max(mcol,xcol,ycol)) + + nread0=nread +40 read(lun, *, err=49,end=49) (values(i),i=1,l) + if (nread .ge. nmax) goto 49 + nread=nread+1 + if (mcol .eq. 0) then + r=1 + else + r=values(mcol) + if (ymon .eq. 0) ymon=r + if (r .eq. 0) r=1 + endif + ww(nread)=r + yy(nread)=values(ycol) + xx(nread)=values(xcol) + goto 40 + +49 m=m+1 + call fit_dat_table(m, 1, nread-nread0) + goto 10 + +50 continue + if (errtype .eq. 'S') then + do i=1,nread + ss(i)=sqrt(max(1.0,yy(i)*errvalue)) + if (ymon .gt. 0) then + yy(i)=yy(i)*ymon/ww(i) + ss(i)=ss(i)*ymon/ww(i) + endif + enddo + else if (errtype .eq. 'P') then + do i=1,nread + ss(i)=yy(i)*errvalue + if (ss(i) .eq. 0.0) ss(i)=1.0 + if (ymon .gt. 0) then + yy(i)=yy(i)*ymon/ww(i) + ss(i)=ss(i)*ymon/ww(i) + endif + enddo + else + if (errtype .ne. 'C') then + print *,'illegal option: err=',errtype + endif + do i=1,nread + ss(i)=errvalue + if (ymon .gt. 0) then + yy(i)=yy(i)*ymon/ww(i) + endif + enddo + endif + + call putval('Monitor', ymon) + close(lun) + return + +99 print *,'DAT_SPEC: error during read' +98 nread=-2 + rewind lun + return + +100 nread=-1 + rewind lun + end diff --git a/gen/dat_table.f b/gen/dat_table.f new file mode 100644 index 0000000..0c445b7 --- /dev/null +++ b/gen/dat_table.f @@ -0,0 +1,468 @@ + subroutine dat_table +c -------------------- + + external dat_table_desc + external dat_table_opts + external dat_table_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_table_desc) + call dat_init_opts(dtype, dat_table_opts) + call dat_init_read(dtype, dat_table_read) + end + + + + subroutine dat_table_desc(text) +c ------------------------------- + character*(*) text ! (out) description + + text='TABLE table format (XY, XYS, XYSM ... see options)' + end + + subroutine dat_table_opts +c -------------------------- + print '(x,a)' + 1,'x: column to be used as x-axis' + 1,'y: column to be used as y-axis' + 1,'s: column to be used as sigma' + 1,'m: column to be used as monitor' + 1,' any column may be specified as' + 1,' - an integer (column number starting from 1)' + 1,' - as a name (if a header is present)' + 1,' - as a float (containing a decimal point)' + 1,' for x, this is a step between equidistant x-values' + 1,' else it is a constant value' + 1,' - an asterisk (*) for a special meaning' + 1,' for x, this is (1,2,3,....)' + 1,' for y, this is 0.0' + 1,' for s, this is sqrt(y)' + 1,' for m, this is 1.0' + 1,' the defaults are' + 1,' x=*,y=1,s=*,m=* for 1 column' + 1,' x=1,y=2,s=*,m=* for 2 columns' + 1,' x=1,y=2,s=3,m=* for 3 columns or more' +! 1,' ' +! 1,'n: n=0 y and s are already normalized (default)' +! 1,' n=1 y and s are not yet normalized by monitor' + end + + + subroutine dat_table_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + integer mcol, rows + parameter (mcol=64, rows=30) + + character header*1024, elem*64 + character line*1024 + character labx*80, laby*80, labs*80, labw*80 + real values(mcol), ymon + integer i, j, pos +! integer normalize + integer nrows, njunk, n, ncol, lin, lin0, lin1, iostat + integer ncolmax + integer ncolx, ncoly, ncols, ncolw + integer colx(mcol), coly(mcol), cols(mcol), colw(mcol) + real valx, valy, vals, valw, x, y, s, w + integer errcnt, errlin, errcol, s0cnt + integer nset, lastcol + +! a table block should appear before (rows=30) junk lines +! junk lines are lines that does contain something else than numbers, +! comment lines and empty lines not counted. +! if a the file does not contain more junk lines than the last table block, +! it is considered as a table file. The last table block is used, or the +! first block with at least (rows=30) lines. +! the column header line is the last line before the used table block +! this may also be a comment line + +! check the above conditions + nread=0 + lin=0 + lin0=0 + lin1=0 + ncol=0 + ncolmax=0 + nrows=0 + njunk=0 + ymon=0 + +1 read(lun,'(a)',err=98,end=19) line + lin=lin+1 + if (line(1:1) .eq. '#') then + if (forced .lt. 0) goto 100 + lin1=lin + goto 1 + endif + if (line .eq. ' ') goto 1 + j=nread+1 + pos=1 + iostat=0 + n=0 + i=0 + do while (iostat .eq. 0) + call str_get_elem(line, pos, elem) + if (elem .eq. ' ') then + n=i + iostat=1 + else if (line(1:1) .gt. '9') then + iostat=1 + else + read(elem, *, iostat=iostat) valx + i=i+1 + endif + enddo + if (n .eq. 0) then ! a junk line + if (forced .lt. 0) goto 100 + if (nrows .gt. 3 .and. forced .le. 0) goto 100 + njunk=njunk+nrows+1 + if (njunk .gt. rows .and. forced .le. 0) goto 100 + nrows=0 + lin0=lin + lin1=0 + else + if (lin1 .ne. 0) then + lin0=lin1 + lin1=0 + endif + nrows=nrows+1 + if (n .ne. ncol) then + if (ncol .ne. 0 .and. nrows .gt. 3 .and. forced .le. 0) + 1 goto 100 + ncol=n + endif + if (nrows .gt. 3 .and. n .gt. ncolmax) ncolmax=n + if (nrows .gt. rows) goto 20 + endif + goto 1 + +19 if (nrows .lt. njunk .and. forced .le. 0) goto 100 + +20 continue + rewind lun + + if (ncolmax .eq. 0) then + ncolmax = n + endif + if (ncolmax .gt. mcol) then + print *,'DAT_TABLE: use only the first',mcol,' columns' + ncolmax=mcol + endif + do i=1,lin0 + read(lun,'(a)',err=98,end=98) line + enddo + lin=lin0 + if (line(1:1) .eq. '#') then + line(1:1)=' ' + endif + header=line + + call dat_start_options + + call dat_table_col_options(header + 1 , 'x', colx, mcol, ncolx, valx, labx) + call dat_table_col_options(header + 1 , 'y', coly, mcol, ncoly, valy, laby) + call dat_table_col_options(header + 1 , 's', cols, mcol, ncols, vals, labs) + call dat_table_col_options(header + 1 , 'm', colw, mcol, ncolw, valw, labw) + if (ncolx .lt. 0 .or. ncoly .lt. 0 .or. + 1 ncols .lt. 0 .or. ncolw .lt. 0) goto 99 + +! normalize=0 +! call dat_int_option('n', normalize) + + if (ncolx .eq. 0) then + ncolx=1 + if (ncolmax .eq. 1) then + colx(1)=-1 + labx='linear' + else + colx(1)=1 + labx='col1' + endif + endif + if (ncoly .eq. 0) then + ncoly=1 + if (ncolmax .lt. 2) then + coly(1)=1 + laby='col1' + else + coly(1)=2 + laby='col2' + endif + endif + if (ncols .eq. 0) then + ncols=1 + if (ncolmax .lt. 3) then + cols(1)=-1 + labs='sqrt' + else + cols(1)=3 + labs='col3' + endif + endif + if (ncolw .eq. 0) then + ncolw=1 + colw(1)=-1 ! monitor 1.0 + labw=' ' + endif + + lastcol=0 + do i=1,ncolx + lastcol=max(lastcol,colx(i)) + enddo + do i=1,ncoly + lastcol=max(lastcol,coly(i)) + enddo + do i=1,ncols + lastcol=max(lastcol,cols(i)) + enddo + do i=1,ncolw + lastcol=max(lastcol,colw(i)) + enddo + + if (lastcol .gt. ncolmax) then + print *,'DAT_TABLE: column ',lastcol,' does not exist' + goto 99 + endif + if (lastcol .eq. 0) then + print *,'DAT_TABLE: ignoring all columns' + endif + + call putval('XAxis='//labx, 0.0) + call putval('YAxis='//laby, 0.0) + call putval('Sigma='//labs, 0.0) + call putval('Weight='//labw, 0.0) + nset=max(ncolx,ncoly,ncols,ncolw) + do i=ncolx+1,nset + colx(i)=colx(ncolx) + enddo + do i=ncoly+1,nset + coly(i)=coly(ncoly) + enddo + do i=ncols+1,nset + cols(i)=cols(ncols) + enddo + do i=ncolw+1,nset + colw(i)=colw(ncolw) + enddo + +! call dat_group(2, putval) +! call putval('XAxis='//xaxis, 0.0) +! call putval('YAxis='//yaxis, 0.0) + call dat_group(1, putval) + + nrows=0 + errcnt=0 + s0cnt=0 +4 continue + read(lun,'(a)',err=99,end=90) line + lin=lin+1 + if (line(1:1) .eq. '#') goto 4 + if (line .eq. ' ') goto 4 + pos=1 + do j=1,lastcol + call str_get_elem(line, pos, elem) + values(j)=0.0 + read(elem, *, iostat=iostat) values(j) + if (iostat .ne. 0) then + if (errcnt .eq. 0) then + errlin=lin + errcol=j + endif + errcnt=errcnt+1 + endif + enddo + nrows=nrows+1 + do i=1,nset + + if (colx(i) .eq. -1) then ! linear starting from 1 + x=nrows + else if (colx(i) .eq. 0) then + x=(nrows-1)*valx + else + x=values(colx(i)) + endif + + if (coly(i) .eq. -1) then ! not really useful: constant 0 + y=0.0 + else if (coly(i) .eq. 0) then + y=valy + else + y=values(coly(i)) + endif + + if (cols(i) .eq. -1) then ! sqrt(y) + if (y .lt. 1.0) then + s=1.0 + else + s=sqrt(y) ! statistical counting error + endif + else if (cols(i) .eq. 0) then + s=vals + else + s=values(cols(i)) + endif + + if (colw(i) .eq. -1) then ! fixed weight + w=1.0 + else if (colw(i) .eq. 0) then + w=valw + else + w=values(colw(i)) + endif + if (w .le. 0) w=1.0 + if (ymon .eq. 0) ymon=w + + if (nread .ge. nmax) goto 29 + if (s .le. 0) then + s0cnt=s0cnt+1 + else + nread=nread+1 + xx(nread)=x + yy(nread)=y*ymon/w + ss(nread)=s*ymon/w + ww(nread)=w + endif + enddo + goto 4 + +90 close(lun) + if (s0cnt .gt. 0) then + print *,'DAT_TABLE: skipped',s0cnt + 1 ,' lines with sigma = 0' + endif + if (errcnt .gt. 0) then + print *,'DAT_TABLE: found',errcnt,'errors, first at line ' + 1 ,errlin ,' column ', errcol + endif + call putval('Monitor', ymon) + if (nset .gt. 1) then + call fit_dat_table(1, nset, nrows) + endif + return + +29 print *,'DAT_TABLE: too many points' + goto 100 + +98 if (forced .le. 0) goto 100 +99 print *,'DAT_TABLE: error during read' + rewind lun + nread=-2 + return +100 nread=-1 + rewind lun + end + + + subroutine dat_table_col_options(header, name, cols, mcols, ncols + 1 , val, axlabel) + + integer mcols, ncols + integer cols(mcols) + character name*(*), header*(*), axlabel*(*) + real val + + character colname*64, axname*64 + integer idx, l, iax, iostat, ll + + integer str_find_elem + external str_find_elem + + colname=' ' + ncols=0 + iax=0 + axlabel=' ' + ll=0 + call dat_str_option(name, colname) + if (colname .eq. ' ') then + iax=1 + write(axname, '(a,i1)') name, iax + call dat_str_option(axname, colname) + endif + do while (colname .ne. ' ') + call str_trim(colname, colname, l) + if (colname .eq. '*') then + ncols=ncols+1 + cols(ncols)=-1 ! special meaning + if (name .eq. 'x') then + colname='linear' + l=6 + else if (name .eq. 'y') then + colname='0.0' + l=3 + else if (name .eq. 's') then + colname='sqrt(y)' + l=7 + else if (name .eq. 'm') then + colname='1.0' + l=3 + endif + goto 10 + endif + idx=0 + if (index(colname, '.') .ne. 0) then + read(colname, *, iostat=iostat) val ! try to get colname as a real + if (iostat .eq. 0) then + ncols=ncols+1 + cols(ncols)=0 ! special value + goto 10 + endif + else + read(colname, *, iostat=iostat) idx ! try to get colname as an int + endif + if (iostat .ne. 0) then + idx=str_find_elem(header, colname) + else + colname='col'//colname(1:l) + l=l+3 + endif + if (idx .eq. 0) then + print *,'DAT_TABLE: column ',colname(1:l),' not found' + goto 9 + endif + ncols=ncols+1 + cols(ncols)=idx +10 continue + call str_append(axlabel, ll, colname(1:l)//',') + colname=' ' + if (iax .ne. 0) then + iax=iax+1 + if (iax .le. 9) then + write(axname, '(a,i1)') name, iax + call dat_str_option(axname, colname) + else if (iax .le. 99) then + write(axname, '(a,i2)') name, iax + call dat_str_option(axname, colname) + endif + endif + enddo + if (ll .gt. 1) then + axlabel(ll:ll)=' ' + endif + RETURN + +9 ncols=-1 + end diff --git a/gen/dat_tascom_dir.c b/gen/dat_tascom_dir.c new file mode 100644 index 0000000..a82168d --- /dev/null +++ b/gen/dat_tascom_dir.c @@ -0,0 +1,223 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "myc_str.h" +#include "myc_fortran.h" + +typedef struct NameList { + struct NameList *next; + int l; + char name[16]; +} NameList; + +typedef struct { + char path[PATH_MAX]; + int start; + time_t newestTime; + char newestPath[PATH_MAX]; + char newestItem[PATH_MAX]; + int numor; + int cnt; + int mode; + int level; + int maxlevel; +} TascomDirScan; + +void TascomScanDir(TascomDirScan *scan, int length, char *name) { + DIR *dir; + struct dirent *ent; + struct stat st; + int l, n; + char rp[PATH_MAX]; + int cnt; + char *ename; + NameList *list, *p, *q; + + l = strlen(name); + if (length+l > PATH_MAX-2) { + printf(" filename too long\n"); + exit(1); + } + if (strcmp(name, ".") != 0) { + scan->path[length]='/'; + length++; + strcpy(scan->path+length, name); + length += l; + } + realpath(scan->path, rp); + if (strcmp(scan->path, rp) != 0) return; /* check for symbolic link */ + if (0>stat(scan->path, &st)) return; + if (! S_ISDIR(st.st_mode)) return; + dir=opendir(scan->path); + if (dir == NULL) return; + ent = readdir(dir); + cnt = scan->cnt; + list = NULL; + while (ent != NULL) { + ename = ent->d_name; + if (strchr(ename,'.') == NULL) { + scan->level++; + TascomScanDir(scan, length, ename); + scan->level--; + scan->path[length+1]='\0'; + } else { + l = strlen(ename); + if (l == 12 && strcmp(ename+8,".dat") == 0) { + l = 7; + while (l>0 && ename[l] >= '0' && ename[l] <= '9') { + l--; + } + l++; + if (l != 8) { + p = list; + while (p != NULL && (p->l != l || strncmp(p->name, ename, l) != 0)) { + p = p->next; + } + if (!p) { + p = calloc(1, sizeof *p); + p->next = list; + list = p; + p->l = l; + if (scan->level > scan->maxlevel) scan->maxlevel = scan->level; + } + if (strcmp(ename, p->name) > 0) { + strncpy(p->name, ename, 12); + p->name[12]='\0'; + } + } + } + } + ent = readdir(dir); + } + p = list; + while (p != NULL) { + scan->path[length]='/'; + scan->path[length+1]='\0'; + str_copy(rp, scan->path); + str_append(rp, p->name); + n=0; + sscanf(p->name + p->l, "%d", &n); + if (stat(rp, &st) >= 0) { + if (st.st_mtime > scan->newestTime) { + scan->newestTime = st.st_mtime; + str_copy(scan->newestPath, rp); + snprintf(scan->newestItem, sizeof scan->newestItem, + "%.*s%.*s", length-scan->start+1, scan->path+scan->start, p->l, p->name); + scan->numor = n; + } + } + if (scan->mode == 0) { + printf(" %.*s%.*s (%d)\n", length-scan->start+1, scan->path+scan->start, p->l, p->name, n); + } + scan->cnt++; + q = p; + p = p->next; + free(q); + } + if (scan->mode == 1 && scan->level == 1 && scan->cnt > cnt) { + scan->path[length]='\0'; + printf(" %s\n", scan->path + scan->start); + } +} + +char *TascomGetDir(char *path) { + char answer[128]; + char *nl, *slash; + DIR *dir; + static TascomDirScan scan; + static char subdir[PATH_MAX]; + int start; + + realpath(path, scan.path); + dir=opendir(scan.path); + if (dir == NULL) return NULL; + closedir(dir); + start = strlen(scan.path) + 1; + scan.start = start; + scan.newestTime = 0; + scan.newestPath[0] = '\0'; + scan.mode = 1; + scan.level = 0; + scan.maxlevel = 0; + scan.cnt = 0; + printf("\n User directories on %s:\n", path); + printf("\n"); + TascomScanDir(&scan, start-1, "."); + slash = strchr(scan.newestPath+scan.start+1, '/'); + if (slash) *slash = '\0'; + + printf("\n user directory [%s]: ", scan.newestPath+scan.start); + answer[0]='\0'; + fgets(answer, sizeof answer, stdin); + nl = strchr(answer, '\n'); + if (nl) *nl='\0'; + if (answer[0] == '\0') { + str_copy(subdir, scan.newestPath+start); + } else { + scan.path[start]='/'; + scan.path[start+1]='\0'; + str_append(scan.path, answer); + dir = opendir(scan.path); + if (!dir) { + perror(answer); + return ""; + } + closedir(dir); + str_copy(subdir, answer); + } + printf("\n"); + + scan.start = start + strlen(subdir) + 1; + scan.newestTime = 0; + scan.newestPath[0] = '\0'; + scan.mode = 0; + scan.level = 0; + scan.maxlevel = 0; + scan.cnt = 0; + TascomScanDir(&scan, start-1, subdir); + + scan.newestPath[scan.start+strlen(scan.newestItem)]='\0'; + printf("\n"); + if (scan.cnt == 0) { + return ""; + } + if (scan.cnt == 1) { + return scan.newestPath + start; + } + printf(" "); + if (scan.maxlevel > 0) { + printf("(subdirectory/)"); + } + printf("filename [%s]: ", scan.newestItem); + answer[0]='\0'; + fgets(answer, sizeof answer, stdin); + printf("\n"); + nl = strchr(answer, '\n'); + if (nl) *nl='\0'; + if (answer[0] == '\0') { + return scan.newestPath + start; + } else { + scan.path[scan.start+1]='\0'; + str_append(scan.path, answer); + return scan.path + start; + } +} + +void F_FUN(dat_tascom_datadir)(F_CHAR(root), F_CHAR(path) F_CLEN(root) F_CLEN(path)) { + char rootc[PATH_MAX]; + char *out; + + STR_TO_C(rootc, root); + out=TascomGetDir(rootc); + if (out) { + STR_TO_F(path, out); + } else { + STR_TO_F(path, "0"); + } +} diff --git a/gen/dat_tasmad.f b/gen/dat_tasmad.f new file mode 100644 index 0000000..40df371 --- /dev/null +++ b/gen/dat_tasmad.f @@ -0,0 +1,467 @@ + subroutine dat_tasmad +c --------------------- + external dat_tasmad_desc + external dat_tasmad_opts + external dat_tasmad_read + external dat_get_datanumber + + integer dtype/0/ + + call dat_init_desc(dtype, dat_tasmad_desc) + call dat_init_opts(dtype, dat_tasmad_opts) + call dat_init_read(dtype, dat_tasmad_read) + call dat_init_high(dtype, dat_get_datanumber) + end + + + subroutine dat_tasmad_desc(text) +c -------------------------------- + character*(*) text ! (out) description + + text='TASMAD DrueChaL, TASP and ILL TAS' + end + + subroutine dat_tasmad_opts +c -------------------------- + print '(x,a)' + 1,'p1,p2: polarisation' + 1,'x: column to be used as x-axis *' + 1,'y: column to be used as y-axis (default: CNTS)' + 1,'mon: column to be used as Monitor (default: M1 or TIME)' + end + + + subroutine dat_tasmad_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + real none + integer mcol + parameter (none=-8.7654e29, mcol=32) + + character line*160, preset*4, old*6, col2*8 + real values(mcol), r, f, s, y, ymon, tm, ts, td + integer r1,r2 + integer i,j,l,ncol,ccol,pcol,xcol,tcol,pacol + integer ip,ip1,ip2 + character word*32 + integer muco, mubgr + real codemu + real mucode(36) + + external dat_tasmad_val + +! common + real tt, tem, mon, tim, qe(4) + character xaxis*8, yaxis*8, monam*8 + integer mode + common /dat_tasmad_com/tt, tem, mon, tim, mode, xaxis, qe + + + xaxis=' ' + preset=' ' + old=' ' + nread=0 + read(lun,'(a)',err=100,end=100) line + if (line(1:16) .eq. 'RRRRRRRRRRRRRRRR') then +1 read(lun,'(a)',err=100,end=100) line + if (line(1:16) .ne. 'VVVVVVVVVVVVVVVV') goto 1 + read(lun,'(a)',err=100,end=100) line + elseif (line(1:7) .ne. 'INSTR: ') then + if (forced .le. 0) goto 100 + endif + tt=none + tem=none + mon=none + tim=none + mubgr=-1 + muco=0 + call dat_delimiters(',', '=', '''') +12 if (line(1:6) .eq. 'INSTR:') then + call dat_group(1, putval) + call putval('Instrument='//line(8:19), 0.0) + elseif (line(1:6) .eq. 'USER_:') then + call dat_group(1, putval) + call putval('User='//line(8:80), 0.0) + elseif (line(1:6) .eq. 'DATE_:') then + call dat_group(1, putval) + call putval('Date='//line(8:80), 0.0) + elseif (line(1:6) .eq. 'TITLE:') then + call dat_group(1, putval) + call putval('Title='//line(8:80), 0.0) + elseif (line(1:6) .eq. 'STEPS:' .or. + 1 line(1:6) .eq. 'POSQE:' .or. + 1 line(1:6) .eq. 'VARIA:' .or. + 1 line(1:6) .eq. 'ZEROS:' .or. + 1 line(1:6) .eq. 'PARAM:') then + call dat_group(2, putval) + old=line(1:6) + j=7 + mode=index('SZ',line(1:1)) ! mode=0: normal, 1: steps, 2: zeros (see dat_tasmad_val) + call dat_intprt(line(7:), dat_tasmad_val, putval) + + elseif (line(1:6) .eq. 'DATA_:') then + goto 20 + elseif (line(1:6) .eq. 'EXPNO:' .or. + 1 line(1:6) .eq. 'LOCAL:' .or. + 1 line(1:6) .eq. 'COMND:') then + call dat_group(2, putval) + call str_trim(line, line, l) + if (l .ge. 8) call putval(line(1:5)//'='//line(8:l), 0.0) + elseif (line(1:6) .eq. 'POLAN:') then + call str_trim(line, line, l) + if (l .lt. len(line)) l=l+1 + if (muco .ge. 0) then + j=1 + call str_get_elem(line(7:l), j, word) + if (word .ne. 'muco' .and. word .ne. '#muco') then + if (word .eq. '#signal') then + call dat_group(1, putval) + call putval('mukind=signal',0.0) + mubgr=0 + goto 19 + endif + if (word .eq. '#background') then + call dat_group(1, putval) + call putval('mukind=background',0.0) + mubgr=1 + goto 19 + endif + muco=-1 + goto 19 + endif + if (muco .eq. 0) then + if (mubgr .eq. -1) then + mubgr = 0 + call dat_group(1, putval) + call putval('mukind=single', 0.0) + endif + do i=1,36 + mucode(i) = 0 + enddo + endif + muco=muco+1 + if (muco .gt. 36) then + if (muco .eq. 37) then + print *,'DAT_TASMAD: too many POLAN muco lines' + endif + goto 19 + endif + call str_get_elem(line(7:l), j, word) + if (word(1:1) .eq. '-') then + codemu=3.0 + word=word(2:) + else + codemu=1.0 + endif + i = index('x y z ', word(1:2)) + if (i .eq. 0) then + print *,'DAT_TASMAD: 1st arg bad ',line(7:l) + endif + ! increase codemu by 0, 30 or 60 for x, y or z + codemu = codemu + (i - 1) * 15 + call str_get_elem(line(7:l), j, word) + if (word(1:1) .eq. '-') then + codemu=codemu+1 + word=word(2:) + endif + i = index('x y z ', word(1:2)) + if (i .eq. 0) then + print *,'DAT_TASMAD: 2nd arg bad ',line(7:l) + endif + ! increase codemu by 10, 20 or 30 for x, y or z + mucode(muco) = codemu + mubgr * 0.1 + (i + 1) * 5 + +c the coding for the x-value ip.b is: +c where i is 1..9 for xx, yx, yz, zy, yy, zy, xz, yz, zz +c p is 1..4 for ++, +-, -+, -- +c b is 0 for signal and 1 for background + + endif + elseif (line(1:6) .ne. 'FILE_:' .and. line(1:6) .ne. 'FORMT:' + 1 .and. line(1:6).ne.' ') then +! if (line(6:6) .ne. ':') goto 100 + call str_trim(line, line, l) + print *,'DAT_TASMAD: superflous line: ',line(1:l) + endif +19 continue + read(lun,'(a)',err=99,end=99) line + goto 12 + +20 continue + call dat_group(1, putval) + ymon=0 + if (mon .eq. none) then + if (tim .eq. none) then + print *,'DAT_TASMAD: neither TI nor MN present' + goto 100 + endif + ymon=tim + preset='TIME' + call putval('Preset=TIME', 0.0) + else + ymon=mon + preset='M1' + call putval('Preset=M1', 0.0) + endif + +!----- options ------ + yaxis=' ' + monam=' ' + call dat_start_options + r1=0 + call dat_int_option('p1', r1) + r2=0 + call dat_int_option('p2', r2) + call dat_str_option('x', xaxis) + call dat_str_option('y', yaxis) + call dat_str_option('mon', monam) + + call str_upcase(xaxis, xaxis) + call str_upcase(yaxis, yaxis) + call str_upcase(monam, monam) +!----- end options ------ + + if (monam .eq. ' ') then + monam=preset + elseif (preset .ne. monam) then + ymon=0 + endif + +21 read(lun,'(a)',err=99,end=99) line + if (line .eq. ' ') goto 21 + i=1 + line(len(line):len(line))=' ' + ncol=0 + ccol=0 + pcol=0 + xcol=0 + tcol=0 + pacol=0 + col2=' ' + if (yaxis .eq. ' ') yaxis='CNTS' +31 do while (line(i:i) .eq. ' ') + i=i+1 + if (i .gt. len(line)) goto 39 + enddo + l=i + do while (line(i:i) .ne. ' ') + i=i+1 + enddo + ncol=ncol+1 + if (ncol .eq. 2) col2=line(l:i) + if (line(l:i) .eq. yaxis) ccol=ncol + if (line(l:i) .eq. monam) pcol=ncol + if (line(l:i) .eq. xaxis) xcol=ncol + if (line(l:i) .eq. 'TEM') tcol=ncol + if (line(l:i) .eq. 'TT' .and. tcol .eq. 0) tcol=ncol + if (line(l:i) .eq. 'PAL') pacol=ncol + goto 31 + +39 if (ccol .eq. 0) then + print *,'no values found for ',yaxis + goto 99 + endif + if (pcol .eq. 0) then + if (monam .eq. ' ') monam='Monitor' + print *,'no values found for ',monam + goto 99 + endif + if (xcol .eq. 0) then + if (xaxis .ne. ' ') then + print *,'no values found for ',xaxis,', take ',col2 + endif + xcol=2 + xaxis=col2 + endif + + if (pacol .ne. 0) then + if (r1 .gt. 9 .or. r2 .gt. 9) then + r1=0 + print *,'DAT_TASMAD: illegal PAL index' + elseif (r1 .le. 0) then + r1=0 + else + line(1:3)=char(ichar('0')+r1) + if (r2 .eq. r1) r2=0 + if (r2 .ne. 0) then + line(2:3)=','//char(ichar('0')+r2) + endif + call putval('Range='//line(1:3),0.0) + call putval('Pal',0.1*r1+0.01*r2) + endif + endif + call putval('XAxis='//xaxis, 0.0) + call putval('YAxis=Intensity', 0.0) + call dat_group(1, putval) + + tm=0 + ts=0 + l=min(mcol,max(xcol,pcol,ccol,tcol)) + ip=0 + ip1=0 + ip2=0 +40 read(lun,*,err=89,end=88) (values(j),j=1,l) + if (pacol .ne. 0) then + if (r1 .eq. 0) then + ip=nint(values(pacol)) + else + ip=0 + if (abs(values(pacol)-r1) .gt. 1e-3 .and. + 1 abs(values(pacol)-r2) .gt. 1e-3) goto 40 ! do not read when PAL value does not match + endif + endif + if (nread .ge. nmax) goto 29 + y=values(ccol) + r=values(pcol) + if (ymon .eq. 0) then + ymon=r + if (r .eq. 0) r=1. + endif + if (r .le. 0.0) r=ymon + f=ymon/r + if (f .le. 0.0) f=1.0 + if (y .gt. 0) then + s=sqrt(y) ! statistical error of detector + else + s=1 + endif + nread=nread+1 + if (ip .ne. 0) then + ip1=ip1+1 + if (ip .ne. ip1) then + if (ip2 .eq. 0) then + ip2=ip1-1 + elseif (ip .ne. 1 .and. ip2 .ne. ip1-1) then + print *,'DAT_TASMAD: PAL code not in order' + ip2=1 + endif + ip1=1 + endif + endif + if (muco .ne. 0 .and. xcol .eq. pacol) then + xx(nread) = mucode(nint(values(pacol))) + else + xx(nread)=values(xcol) + endif + yy(nread)=y*f + ss(nread)=s*f + ww(nread)=r + if (tcol .ne. 0) then + tt=values(tcol) + td=(tt-tm)/nread + tm=tm+td ! mean temp. + ts=ts+(tt-tm)**2+td*td*(nread-1) ! sum of (temp(i)-mean)**2 +c print *,'temp',tt,tm,ts + endif + goto 40 + +88 close(lun) + if (ip2 .ne. 0) then + call fit_dat_table(1, ip2, (nread+ip2-1)/ip2) + endif + call putval('Monitor', ymon) + if (tcol .ne. 0) then + call putval('Temp', tm) + if (nread .gt. 1) call putval('dTemp', sqrt(ts/(nread-1))) + tm = tt + elseif (tem .eq. none .and. tt .ne. none) then + call putval('Temp', tt) + endif + if (muco .ne. 0) then + call dat_group(3, putval) + if (mubgr .eq. 1) then + call putval('QH_B', qe(1)) + call putval('QK_B', qe(2)) + call putval('QL_B', qe(3)) + call putval('EN_B', qe(4)) + call putval('TEMP_B', tm) + else + call putval('QH_S', qe(1)) + call putval('QK_S', qe(2)) + call putval('QL_S', qe(3)) + call putval('EN_S', qe(4)) + call putval('TEMP_S', tm) + endif + endif + return + +89 print *,'DAT_TASMAD: error at point ',nread + goto 40 +29 print *,'DAT_TASMAD: too many points' + goto 100 +99 print *,'DAT_TASMAD: error during read' + rewind lun + nread=-2 + return + +100 rewind lun + nread=-1 + end + + + subroutine dat_tasmad_val(str, val, putval) + + character*(*) str + real val + external putval + + integer i + + real tt, tem, mon, tim, qe(4) + character xaxis*8, zstr*8 + integer mode + common /dat_tasmad_com/tt, tem, mon, tim, mode, xaxis, qe + + if (val .eq. 0) then + i=index(str, '=') + else + i=0 + endif + if (i .eq. 0) then ! numeric + if (mode .eq. 1) then ! steps + if (val .ne. 0 .and. xaxis .eq. ' ') then ! get first step not zero + xaxis=str(2:) + endif + elseif (mode .eq. 2) then ! zeros + zstr(1:1)='Z' + zstr(2:)=str + call putval(zstr, val) + return + elseif (str .eq. 'TT') then + tt=val + elseif (str .eq. 'Temp') then + tem=val + elseif (str .eq. 'MN' .or. str .eq. 'mn') then + mon=val + elseif (str .eq. 'TI' .or. str .eq. 'ti') then + tim=val + elseif (str .eq. 'QH') then + qe(1)=val + elseif (str .eq. 'QK') then + qe(2)=val + elseif (str .eq. 'QL') then + qe(3)=val + elseif (str .eq. 'EN') then + qe(4)=val + endif + endif + call putval(str, val) + end diff --git a/gen/dat_utils.f b/gen/dat_utils.f new file mode 100644 index 0000000..94f049b --- /dev/null +++ b/gen/dat_utils.f @@ -0,0 +1,626 @@ + subroutine dat_filelist(file_list) + + include 'dat_utils.inc' + + character*(*) file_list + + lpos=0 + filelist=file_list + end + + + subroutine dat_init_list + + include 'dat_utils.inc' + + call dat_init + lout=0 + end + + + subroutine dat_read_next(putval, nmax, nread, xx, yy, ss, ww) + + external putval + integer nread + integer nmax ! max. number of points + real xx(nmax) ! x-values + real yy(nmax) ! y-values + real ss(nmax) ! sigma + real ww(nmax) ! weights + + include 'dat_utils.inc' + logical silent + + call dat_init + call dat_get_silent(silent) +10 if (lpos .ge. len(filelist)) then + nread=-1 + else + if (nmax .eq. 0) then + print *,'no more datapoints accepted' + nread=0 + else + if (silent) call dat_silent + call dat_open_next(filelist, lpos, outlist, lout + 1 , putval, nmax, nread, xx, yy, ss, ww) + endif + if (nread .le. 0) then + call sym_purge(1) ! a little hack + goto 10 + endif + endif + end + + + subroutine dat_get_filelist(file_list) + + character*(*) file_list + include 'dat_utils.inc' + + if (lout .lt. 2) then + file_list=' ' + else + file_list=outlist(1:lout-1) + endif + end + + + subroutine dat_read_all(filename, putval, nread, nmax,xx,yy,ss,ww) + + character filename*(*) + external putval + integer nread + integer nmax ! max. number of points + real xx(nmax) ! x-values + real yy(nmax) ! y-values + real ss(nmax) ! sigma + real ww(nmax) ! weights + + include 'dat_utils.inc' + + integer n,k + + call dat_init + lpos=0 + lout=0 + k=0 +1 if (k .ge. nmax) then + print *,'no more datapoints accepted' + n=0 + else + call dat_open_next(filename, lpos, outlist, lout + 1 , putval, nmax-k, n, xx(k+1),yy(k+1),ss(k+1),ww(k+1)) + endif + if (n .le. 0) goto 1 + k=k+n + if (lpos .lt. len(filename)) goto 1 + if (lout .gt. 1) then + print *,'files read: ',outlist(1:lout-1) + nread=k + else + print *,'no files read' + nread=-1 + endif + end + + + subroutine dat_put_filelist(filename) + + character filename*(*) + + include 'dat_utils.inc' + integer n + + + + external dat_put_none + + + call dat_init + lpos=0 + lout=0 +1 call dat_open_next(filename, lpos, outlist, lout + 1 , dat_put_none, 0, n, 0.0, 0.0, 0.0, 0.0) ! check syntax only + if (lpos .lt. len(filename)) goto 1 + end + + + subroutine dat_next_filename(filename, len_name) + + character filename*(*) + integer len_name + integer n + + + include 'dat_utils.inc' + + + external dat_put_none + + + if (lpos .ge. len(filelist)) then + len_name=0 + return + endif + call dat_open_next(filelist, lpos, outlist, lout + 1 , dat_put_none, 0, n, 0.0, 0.0, 0.0, 0.0) ! syntax only + call dat_get_filename(filename, len_name) + end + + + subroutine dat_group(show, putval) + + integer show + external putval + + call putval('ShowLevel', float(show)) + end + + + subroutine dat_put_none(name, value) +c +c dummy routine +c + character name*(*) + real value + end + + + subroutine dat_put_one(name, value) + +c put a real value: NAME must not contain '=' +c +c put a string value: NAME must contain '=' +c syntax name=text, VALUE must be 0.0 + + character name*(*), text*(*) + real value + + integer i + character name0*32/' '/, text0*80 + save name0, text0 + + i=index(name, '=') + if (i .gt. 1 .and. i .lt. len(name)) then + name0=name(1:i-1) + text0=name(i+1:) + endif + return + + entry dat_get_one(name, text) + + name=name0 + text=text0 + name0=' ' + end + + + subroutine dat_insert_year(str, year, ok) + + character str*(*) + integer year + logical ok + + integer i,y,m,d + + ok=.false. +1 i=index(str,'%%') + if (i .ne. 0) then + if (year .eq. 0) then + call sys_date(y,m,d) + else + y=year + endif + if (str(i:min(i+3,len(str))) .eq. '%%%%') then + write(str(i:i+3), '(i4.4)') mod(y,10000) + else + write(str(i:i+1), '(i2.2)') mod(y,100) + endif + ok=.true. + goto 1 + endif + end + + + subroutine dat_set_options(options) + + character options*(*) + character defopt*256/' '/ + integer leng/0/, deflen/1/ + + leng=0 + call dat_insert_options(options, leng) + if (defopt(1:deflen) .ne. ' ') then + call dat_insert_options(defopt(1:deflen), leng) + endif + return + + + entry dat_def_options(options) + +! set default options + + call str_trim(defopt, options, deflen) + return + + + entry dat_get_def_options(options) + + options=defopt + end + + subroutine dat_insert_options(options, leng) + + character name*(*), value*(*), options*(*) + integer leng + + character opt*256/' '/ + integer idx/0/ + integer nam1(32), nam2(32) + integer val1(32), val2(32) + integer cnt(32) + character nam*16 + integer i,j,nopt,mopt,found,named + integer start,ende + save mopt,nopt,nam1,nam2,val1,val2,cnt + + if (leng .eq. 0) then + opt=' ' + leng=1 + named=0 + nopt=0 + mopt=0 + else + mopt=nopt + endif + + start=0 + ende=0 + do while (ende .ge. 0) + if (nopt .ge. 32) then + print *,'too many options, truncated' + return + endif + + call str_split(options, ',', start, ende) + if (start .le. ende) then + call str_first_nonblank(options(start:ende), j) + if (j .gt. 0) start=start+j-1 + endif + if (start .le. ende) then + i=index(options(start:ende), '=') + if (i .eq. 0) then + if (options(start:ende) .ne. ' ' .or. start .gt. 1) then + if (named .ne. 0) then + print *,'unnamed options must appear first: ',options + endif + nopt=nopt+1 + nam1(nopt)=1 + nam2(nopt)=1 + val1(nopt)=leng+1 + call str_append(opt, leng, options(start:ende)) + val2(nopt)=leng +! print *,'unnamed "',options(start:ende),'"' + endif + else + named=1 + if (i .eq. 1) then + print *,'syntax error in options: ',options(start:ende) + else + nopt=nopt+1 + nam1(nopt)=leng+1 + call str_append(opt, leng, options(start:start+i-2)) + nam2(nopt)=leng + call str_upcase(opt(nam1(nopt):leng),opt(nam1(nopt):leng)) + if (start+i .le. ende) then + val1(nopt)=leng+1 + call str_append(opt, leng, options(start+i:ende)) + val2(nopt)=leng +! print *,'named "',options(start:ende),'"' + else + val1(nopt)=1 + val2(nopt)=1 +! print *,'named empty "',options(start:ende),'"' + endif + endif + endif + endif + enddo + if (leng .eq. len(opt)) then + print *,'too many options, truncated' + endif + return + + + + entry dat_start_options + + if (mopt .eq. 0) mopt=nopt + do i=1,nopt + cnt(i)=0 + enddo + idx=0 + return + + + entry dat_str_option(name, value) ! for dat_xxx + + found=0 + idx=idx+1 + if (idx .le. mopt .and. nam2(idx) .eq. 1) then + value=opt(val1(idx):val2(idx)) + cnt(idx)=cnt(idx)+1 + found=1 + endif + call str_upcase(nam, name) + do i=1,nopt + if (opt(nam1(i):nam2(i)) .eq. nam) then + if (found .ne. 0) then + if (value .ne. opt(val1(i):val2(i)) .and. i .le. mopt) then + cnt(i)=cnt(i)+1 + endif + RETURN + endif + value=opt(val1(i):val2(i)) + cnt(i)=cnt(i)+1 + found=1 + endif + enddo + return + + + entry dat_end_options + + do i=1,mopt + if (cnt(i) .eq. 0) then + if (nam2(i) .eq. 1) then + print *,'superflous option: ', opt(val1(i):val2(i)) + else + print *,'unknown option: ' + 1 ,opt(nam1(i):nam2(i)), '=', opt(val1(i):val2(i)) + endif + elseif (cnt(i) .eq. 2) then + print *,'ambigous option: ' + 1 ,opt(nam1(i):nam2(i)), '=', opt(val1(i):val2(i)) + endif + enddo + return + end + + + subroutine dat_set_index(idx) + + integer idx, flg + + integer indx/0/, flag/0/ + + indx=idx + flag=1 + return + + + entry dat_get_index(idx) ! for dat_xxx, call only when index is supported + idx=indx + flag=2 + return + + + entry dat_next_index(flg) + if (indx .gt. 0) then + indx=indx+1 + flg=flag + else + flg=flag + endif + end + + + subroutine dat_real_option(name, value) + + character name*(*) + integer ivalue + real value + + character str*64 + integer l + + str=' ' + call dat_str_option(name, str) + if (str .eq. ' ') RETURN + value=0.0 + read(str, *, err=9, end=9) value + RETURN +9 call str_trim(str, str, l) + print *,'option ',name,'=',str(1:l),' must be a real number' + RETURN + + entry dat_int_option(name, ivalue) + + str=' ' + call dat_str_option(name, str) + if (str .eq. ' ') RETURN + ivalue=0 + read(str, *, err=19, end=19) ivalue + RETURN +19 call str_trim(str, str, l) + print *,'option ',name,'=',str(1:l),' must be an integer' + RETURN + end + + + subroutine dat_use_mon(imon) +! +! convention: 0: auto, 1: standard, 2: primary beam, 3: auxiliary, 4: time, 5: proton current/reactor power +! + integer imon + + integer used_mon/1/ + + used_mon=imon + return + + entry dat_used_mon(imon) + + imon=used_mon + end + + + subroutine dat_use_axis(xaxis, yaxis) + + character xaxis*(*), yaxis*(*) + + character xax*64/' '/, yax*64/' '/ + + xax=xaxis + yax=yaxis + + entry dat_used_axis(xaxis, yaxis) + + xaxis=xax + yaxis=yax + end + + + subroutine dat_ask_filelist(filelist, text) + + character filelist*(*), text*(*) + + character spec*32 + integer high, ls + + call dat_getdef(spec) + call str_trim(spec, spec, ls) + high=0 + call dat_get_high(high) + +20 print * + if (ls .ne. 0) then + if (high .eq. 0) then + print '(X,3A)', + 1 'Default for numors: ', spec(1:ls) + else + print '(X,3A,i6,a)', + 1 'Default for numors: ', spec(1:ls),' (highest: ',high,')' + endif + endif + +c call dat_gettyp(spec) +c if (spec .ne. ' ') then +c call str_trim(spec, spec, ls) +c print '(x,3a)', 'Default type for files (', spec(1:ls), ')' +c endif + + if (text .ne.' ') print *,text + print '(/X,A,$)', 'Filename(s) or numor(s) (? to get help): ' + read(*, '(a)',err=91,end=91) filelist + if (filelist .eq. '?') then + print '(X,A)' + 1, 'Valid examples:' + 1, ' ' + 1, '1001 a numor of the default instrument' + 1, 'TASP/1997/1234 numor 1234 of year 1997 of TASP' + 1, 'IN3/923-925,927 numors 923,924,925 and 927 of IN3' + 1, 'TEST.FIT3 or any other file specification' + goto 20 + endif +91 end + + + subroutine dat_powder_trf(xin,xout,yfact) + + real xin + real xout + real yfact + real lambda_i + character xaxis*(*), oaxis*(*) + + real pi + parameter (pi=3.14159265) + + real lambda/0.0/ + integer mode/0/ ! 1: 2theta to q, 2: 2theta to d + + real sint + character up*16, oup*16 + + real sind, asind, x + + sind(x)=sin(x*3.14159265/180.0) + asind(x)=asin(x)*180./3.14159265 + + yfact=1.0 ! the feature to change y was not appreciated + if (mode .eq. 0) then + xout=xin + RETURN + endif + if (mode .le. 2) then ! 2t -> q + xout=max(1.0e-6,min(xin,179.999)) + if (mode .eq. 1) then + xout=(4*pi)*sind(xin/2)/lambda +! yfact=1.0/cosd(xin/2) ! removed + elseif (mode .eq. 2) then ! 2t -> d + sint=sind(xin/2) + if (sint .eq. 0) sint=1e-3 + xout=lambda/2/sint +! yfact=tand(xin/2)*sint ! removed + endif + elseif (mode .eq. 3) then ! q -> 2t + xout=2*asind(max(-1.0,min(xin*lambda/(4*pi), 1.0))) + elseif (mode .eq. 6) then ! d -> 2t + xout=2*asind(min(1.0,lambda/2/max(1e-6,xin))) + elseif (mode .eq. 5 .or. mode .eq. 7) then ! q <-> d + xout=(2*pi)/max(1e-6,xin) + endif + RETURN + + entry dat_powder_init(lambda_i, oaxis, xaxis) + + mode=0 + call str_upcase(oup, oaxis) + call str_upcase(up, xaxis) + if (oup .eq. 'Q') then + mode=3 + else if (oup .eq. 'D') then + mode=6 + else if (oup .ne. ' ' .and. oup(1:1) .ne. '2' + 1 .and. oup(1:1) .ne. 'T') then + print *,'cannot transform from ',oaxis + xaxis=' ' + goto 9 + endif + if (up .eq. 'Q') then + mode=mode+1 + elseif (up .eq. 'D') then + mode=mode+2 + elseif (up .eq. ' ' .or. up(1:1) .eq. '2') then + xaxis='2-Theta' + else + print *,'cannot transform to ',xaxis + xaxis=' ' + endif + if (lambda_i .eq. 0 .and. mode .gt. 0 .and. + 1 mode .le. 3 .or. mode .eq. 6) then + print *,'no wavelength lambda defined' + xaxis=' ' + mode=0 + endif + +9 lambda=lambda_i + end + + + subroutine dat_get_datanumber(file, numor) + + character file*(*) + integer numor + + integer luntmp, iostat + + call sys_get_lun(luntmp) + call sys_open(luntmp, file, 'r', iostat) + if (iostat .eq. 0) then + read(luntmp, *, err=18,end=18) numor + 18 close(luntmp) + endif + call sys_free_lun(luntmp) + end diff --git a/gen/dat_utils.inc b/gen/dat_utils.inc new file mode 100644 index 0000000..0c92b74 --- /dev/null +++ b/gen/dat_utils.inc @@ -0,0 +1,4 @@ + integer lpos, lout + character filelist*8192, outlist*8192 + + common/dat_utils_com/lpos, lout, filelist, outlist diff --git a/gen/dat_xxx.f b/gen/dat_xxx.f new file mode 100644 index 0000000..25db220 --- /dev/null +++ b/gen/dat_xxx.f @@ -0,0 +1,63 @@ + subroutine dat_xxx +! ------------------ + + external dat_xxx_desc + external dat_xxx_opts + external dat_xxx_high ! this line for raw data files only + external dat_xxx_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_xxx_desc) + call dat_init_opts(dtype, dat_xxx_opts) + call dat_init_high(dtype, dat_xxx_high) ! this line for raw data files only + call dat_init_read(dtype, dat_xxx_read) + end + + + subroutine dat_xxx_desc(text) +! ----------------------------- + character*(*) text ! (out) description + +! type description +! ---------------------------------- + text='XXX test example' + end + + + subroutine dat_xxx_opts +! ----------------------- + print '(x,a)' + 1,'opts description' + end + + + subroutine dat_xxx_high(file, numor) +! ------------------------------------ +! only to implement for raw data files +! returns highest NUMOR. FILE is the location of the file holding the last numor + + character*(*) file ! (in) filename containing info for last numor + integer numor ! (out) last numor + + end + + + subroutine dat_xxx_read + 1 (lun, forced, nread, putval, nmax, xx, yy, ss, ww) +! ---------------------------------------------------- + implicit none + + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) diff --git a/gen/dat_xy.f b/gen/dat_xy.f new file mode 100644 index 0000000..629ab1b --- /dev/null +++ b/gen/dat_xy.f @@ -0,0 +1,144 @@ + subroutine dat_xy +c ------------------ + + external dat_xy_desc + external dat_xy_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_xy_desc) + call dat_init_read(dtype, dat_xy_read) + end + + + subroutine dat_xy_desc(text, opt) +c --------------------------------- + + implicit none + +! arguments dat_xy_desc + character*(*) text ! (out) description + character*(*) opt ! (out) options description + +! arguments dat_xy_read + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + real none + parameter (none=-8.7654e29) + real x,y,s,errvalue,ymon + integer i,j,l,errcnt + character line*132, errtype*1 + +c type description +c ------------------------------------ + text='XY (x,y)-table, ev. with header' + opt='err: s (square root of y), c (constant), p (percentage), ' + 1//'val: value of error, mon: monitor' + return + + + entry dat_xy_read(lun, forced, nread, putval, nmax,xx,yy,ss,ww) +! ---------------------------------------------------------------- + +! check 10 lines (up to 30 header lines) for containing exactly two numeric values + + if (forced .eq. 0) then + read(lun,'(a)', err=29, end=26) line + i=1 + j=0 +20 read(line, *, err=25, end=25) x,y + read(line, *, err=25, end=21) x,y,s +25 if (j .eq. 0 .and. i .le. 30) goto 22 ! header line + goto 29 +21 j=j+1 ! count good line (exactly 2 numbers) +22 read(lun,'(a)', err=29, end=26) line + i=i+1 ! count line + if (j .lt. 10) goto 20 + goto 28 +29 nread=-1 + rewind lun + return +26 if (j .lt. i/2) goto 29 +28 rewind lun + endif + + call dat_start_options + errtype='c' + call dat_str_option('err', errtype) + call str_upcase(errtype, errtype) + errvalue=1.0 + call dat_real_option('val', errvalue) + if (errvalue .le. 0.0) then + print *,'value for error must be > 0' + errvalue=1.0 + endif + ymon=0 + call dat_real_option('mon', ymon) + nread=0 + errcnt=0 + call putval('Monitor', ymon) + +1 read(lun, '(a)', end=9,err=9) line + if (nread .ge. nmax) goto 5 + read(line, *, err=7,end=7) x,y + nread=nread+1 + ww(nread)=1. + yy(nread)=y + xx(nread)=x + goto 1 + +5 errcnt=errcnt+1 + print *,'DAT_XY: File too long' + goto 9 + +7 if (nread .gt. 0) then ! count error only if not header + errcnt=errcnt+1 + if (errcnt .le. 10) then + print *,'Error in line ',nread+1 + endif + endif + goto 1 + +9 if (errtype .eq. 'S') then + do i=1,nread + ss(i)=sqrt(max(1.0,yy(i)*errvalue)) + enddo + else if (errtype .eq. 'P') then + do i=1,nread + ss(i)=yy(i)*errvalue + if (ss(i) .eq. 0.0) ss(i)=1.0 + enddo + else + if (errtype .ne. 'C') then + print *,'illegal option: err=',errtype + endif + do i=1,nread + ss(i)=errvalue + enddo + endif + inquire(lun, name=line) + call sys_parse(line, l, line, '.', 0) + if (errcnt .gt. 0) then + print '(x,a,i5,2a,a1)','DAT_XY: ',errcnt, + 1 ' errors during read ', line(1:max(1,l)), 7 + endif + if (nread .eq. 0) then + nread=-1 + rewind lun + else + close(lun) + endif + end diff --git a/gen/dat_xys.f b/gen/dat_xys.f new file mode 100644 index 0000000..4532b30 --- /dev/null +++ b/gen/dat_xys.f @@ -0,0 +1,125 @@ + subroutine dat_xys +c ------------------ + + external dat_xys_desc + external dat_xys_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_xys_desc) + call dat_init_read(dtype, dat_xys_read) + end + + + subroutine dat_xys_desc(text, opt) +c ---------------------------------- + + implicit none + +! arguments dat_xys_desc + character*(*) text ! (out) description + character*(*) opt ! (out) options description + +! arguments dat_xys_read + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + real none + parameter (none=-8.7654e29) + real x,y,s,ymon + integer i,j,l,errcnt + character line*132 + + +c type description +c ---------------------------------- + text='XYS (x,y,sigma) table, ev. with header' + opt='mon: monitor' + return + + + entry dat_xys_read(lun, forced, nread, putval, nmax,xx,yy,ss,ww) +! ----------------------------------------------------------------- + +! check 10 lines (up to 30 header lines) for containing exactly three numeric values + + if (forced .eq. 0) then + read(lun,'(a)', err=29, end=26) line + i=1 + j=0 +20 read(line, *, err=25, end=25) x,y,s + read(line, *, err=25, end=21) x,y,s,s +25 if (j .eq. 0 .and. i .le. 30) goto 22 ! header line + goto 29 +21 j=j+1 ! count good line (exactly 3 numbers) +22 read(lun,'(a)', err=29, end=26) line + i=i+1 ! count line + if (j .lt. 10) goto 20 + goto 28 +29 nread=-1 +c print *,j,i,' check XYS' + rewind lun + return +26 if (j .lt. i/2) goto 29 +28 rewind lun + endif + + call dat_start_options + ymon=0 + call dat_real_option('mon', ymon) + nread=0 + errcnt=0 + call putval('Monitor', 0.0) + +1 read(lun, '(a)', end=9,err=9) line + if (nread .ge. nmax) goto 5 + read(line, *, err=7,end=7) x,y,s + nread=nread+1 + if (s .eq. 0) then + ww(nread)=1. + s=1 + else + ww(nread)=1.0/abs(s) + endif + ss(nread)=s + yy(nread)=y + xx(nread)=x + goto 1 + +5 errcnt=errcnt+1 + print *,'DAT_XYS: File too long' + goto 9 + +7 if (nread .gt. 0) then ! count error only if not header + errcnt=errcnt+1 + if (errcnt .le. 10) then + print *,'Error in line ',nread+1 + endif + endif + goto 1 + +9 inquire(lun, name=line) + call sys_parse(line, l, line, '.', 0) + if (errcnt .gt. 0) then + print '(x,a,i5,2a,a1)','DAT_XYS: ',errcnt, + 1 ' errors during read ', line(1:max(1,l)), 7 + endif + if (nread .eq. 0) then + rewind lun + nread=-1 + else + close(lun) + endif + end diff --git a/gen/dat_xysm.f b/gen/dat_xysm.f new file mode 100644 index 0000000..20f1edf --- /dev/null +++ b/gen/dat_xysm.f @@ -0,0 +1,126 @@ + subroutine dat_xysm +c ------------------ + + external dat_xysm_desc + external dat_xysm_read + + integer dtype/0/ + + call dat_init_desc(dtype, dat_xysm_desc) + call dat_init_read(dtype, dat_xysm_read) + end + + + subroutine dat_xysm_desc(text, opt) +c ---------------------------------- + + implicit none + +! arguments dat_xysm_desc + character*(*) text ! (out) description + character*(*) opt ! (out) options description + +! arguments dat_xysm_read + integer lun ! (in) logical unit number (file will be closed if successful) + integer forced ! 0: read only if type is sure; 1: forced read + integer nread ! (out) >=0: = number of points read, file closed + ! -1: not correct type, file rewinded + ! -2: correct type, but unreadable, file rewinded + external putval ! (in) subroutine to put name/value pairs. + ! for numeric data: call putval('name', value) ! value must be real + ! for character data: call putval('name=text', 0.0) + integer nmax ! max. number of points + real xx(*) ! x-values + real yy(*) ! y-values + real ss(*) ! sigma + real ww(*) ! weights (original monitor) + +! local + real none + parameter (none=-8.7654e29) + real x,y,s,m,ymon + integer i,j,l,errcnt + character line*132 + + +c type description +c ---------------------------------- + text='XYSM (x,y,sigma,monitor) table, ev. with header' + opt=' ' + return + + + entry dat_xysm_read(lun, forced, nread, putval, nmax, xx,yy,ss,ww) +! ------------------------------------------------------------------ + +! check 10 lines (up to 30 header lines) for containing exactly three numeric values + + if (forced .eq. 0) then + read(lun,'(a)', err=29, end=26) line + i=1 + j=0 +20 read(line, *, err=25, end=25) x,y,s,m + read(line, *, err=25, end=21) x,y,s,m,m +25 if (j .eq. 0 .and. i .le. 30) goto 22 ! header line + goto 29 +21 j=j+1 ! count good line (exactly 4 numbers) +22 read(lun,'(a)', err=29, end=26) line + i=i+1 ! count line + if (j .lt. 10) goto 20 + goto 28 +29 nread=-1 +c print *,j,i,' check XYSM' + rewind lun + return +26 if (j .lt. i/2) goto 29 +28 rewind lun + endif + + nread=0 + errcnt=0 + ymon=0 + +1 read(lun, '(a)', end=9,err=9) line + if (line(1:1) .eq. '#' .or. line .eq. ' ') goto 1 + if (nread .ge. nmax) goto 5 + read(line, *, err=7,end=7) x,y,s,m + if (m .eq. 0) m=1.0 + nread=nread+1 + xx(nread)=x + yy(nread)=y + ss(nread)=max(s,y*1e-6,1e-6) + ww(nread)=m + ymon=max(ymon,m) + goto 1 + +5 errcnt=errcnt+1 + print *,'DAT_XYSM: File too long' + goto 9 + +7 if (nread .gt. 0) then ! count error only if not header + errcnt=errcnt+1 + if (errcnt .le. 10) then + print *,'Error in line ',nread+1 + endif + endif + goto 1 + +9 call putval('Monitor', ymon) + do i=1,nread + yy(i)=yy(i)*ymon/ww(i) + ss(i)=ss(i)*ymon/ww(i) + ww(i)=ymon + enddo + if (errcnt .gt. 0) then + inquire(lun, name=line) + call sys_parse(line, l, line, '.', 0) + print '(x,a,i5,2a,a1)','DAT_XYSM: ',errcnt, + 1 ' errors during read ', line(1:max(1,l)), 7 + endif + if (nread .eq. 0) then + rewind lun + nread=-1 + else + close(lun) + endif + end diff --git a/gen/fifun.f b/gen/fifun.f new file mode 100644 index 0000000..10f8add --- /dev/null +++ b/gen/fifun.f @@ -0,0 +1,232 @@ + real function FIFUN(XX) +C ----------------------- + + include 'fit.inc' + + real xx + + real fifunp + + fifun=fifunp(xx, u) + end + + + subroutine FNCTN(PINT,F) +c ------------------------ + include 'fit.inc' +c + real pint(*),f + + integer i,j + real sum + + real fifun ! function + + call intoex(pint) + nfcn=nfcn+1 + + if (ififu .eq. 6) then + j=0 + sum = 0. + DO I=NXMIN,NXMAX + if (abs(xval(i)-u(3)) .gt. u(4)/2) then + sum = sum + ((YVAL(I)-FIFUN(XVAL(I)))/SIG(I))**2 + j=j+1 + endif + ENDDO + if (j .lt. 2) then + sum = sum + ((YVAL(nxmin)-FIFUN(XVAL(nxmin)))/SIG(nxmin))**2 + 1 + ((YVAL(nxmax)-FIFUN(XVAL(nxmax)))/SIG(nxmax))**2 + j=j+2 + endif + nfree=max(1,j-npar) + F = sum/nfree + else + if (ififu .eq. 7) call fit_user1st + sum = 0. + DO I=NXMIN,NXMAX + actset=iset(i) + sum = sum + ((YVAL(I)-FIFUN(XVAL(I)))/SIG(I))**2 + ENDDO + F = sum/nfree + endif + END + + + real FUNCTION FIFUNP(XX, P) +C --------------------------- + + include 'fit.inc' + + real xx, p(maxext) + + real xr + integer i,j + real sys_rfun_rriii, voigt + + goto (100,100,100,100,500,600,700) ififu + fifunp=0 + return + +C. . . . . VOIGT . . . + +100 continue + if (nu .eq. 2) then + fifunp = p(1)+p(2)*xx + return + endif + fifunp = p(1)+p(2)*(xx-p(3)) + do i=3,nu,5 + fifunp=fifunp+p(i+2)*voigt(xx-p(i), p(i+3), p(i+4)) + enddo + return + +C. . . . . CRITICAL EXPONENT. . . + + 500 IF (P(5).EQ.0.) THEN + XR = P(6)*(XX-P(1))/P(1) + IF (XR.LT.1E-6) then + fifunp=p(4) + else + FIFUNP = P(3)*(XR**P(2)) + P(4) + endif + RETURN + ENDIF + XR = (XX-P(1))/P(1) + IF (XR.LE.-1.E-10) THEN + FIFUNP = P(3)*((-XR)**P(2)) + P(5)*EXP((-XR*P(6))*P(4)) + P(7) + RETURN + ENDIF + FIFUNP = P(5)*EXP(XR*P(4)) + P(7) + RETURN + +C. . . . . STRANGE . . . . . . . . + + 600 fifunp = p(1)+p(2)*(xx-p(3)) + return + +C. . . . . SPECIAL FUNCTION . . . + + 700 if (nu .gt. 0) then + if (npd .eq. 0) then + fifunp=sys_rfun_rriii(userfun, xx, p, nu, 0, actset) + else + j=nu + do i=1,npd + j=j+1 + p(j)=pdpar(i,min(actset,maxset)) + enddo + fifunp=sys_rfun_rriii(userfun, xx, p, nu+npd, 0, actset) + endif + else + fifunp=0 + endif + return + end + + + real function voigt(x, gg, gl) + + implicit none + + real x,gg,gl + + real vint, sqrtln2, pi + parameter (vint=0.939437278699651, sqrtln2=0.832554611157697) + parameter (pi=3.14159265) + + real xg, c + + complex cwerf + + if (gl .eq. 0) then ! pure gaussian + if (gg .eq. 0) then + if (x .eq. 0) then + voigt=1e18 + else + voigt=0 + endif + else + xg=(x/gg*(sqrtln2*2))**2 + if (xg .lt. 50.) then + voigt=exp(-xg)*vint/abs(gg) + else + voigt=0 + endif + endif + elseif (abs(gl) .gt. abs(gg)*100) then ! pure lorentzian + voigt=abs(gl)/(gl*gl/4+x*x)/(2*pi) + elseif (abs(x) .gt. 12*abs(gg) .and. + 1 (abs(gg) .gt. abs(gl) .or. + 1 abs(x/gl) .gt. 12*sqrt(abs(gg/gl)))) then ! approx. for high x + voigt=abs(gl)/(gl*gl/4+x*x)/(2*pi)/(1-0.541*(gg/x)**2) + else + c=sqrtln2/abs(gg) + voigt=real(cwerf(2*x*c, abs(gl)*c))*vint/abs(gg) + endif + end + + + COMPLEX FUNCTION CWERF(xx,yy) + + COMPLEX VALUE + REAL LAMBDA + real const + parameter (CONST=1.12837916709551) + + real xx,yy,x,y,h,s,h2,r1,r2,s1,s2,fn,c,t1,t2 + integer nc,nu,n + + X=ABS(XX) + Y=ABS(YY) + IF (Y .GE. 4.29 .OR. X .GE. 5.33) THEN + H=0. + NC=0 + NU=9 + LAMBDA=0. + ELSE + S=(1.0-Y/4.29)*SQRT(1.0-X*X/28.41) + H=1.6*S + H2=2.0*H + NC=6+INT(23.0*S) + NU=10+INT(21.0*S) + LAMBDA=H2**NC + NC=NC+1 + IF (LAMBDA .EQ. 0.0) NC=0 + END IF + R1=0. + R2=0. + S1=0. + S2=0. + DO N=NU,1,-1 + FN=N + T1=Y+H+FN*R1 + T2=X-FN*R2 + C=0.5/(T1*T1+T2*T2) + R1=C*T1 + R2=C*T2 + IF (N .LE. NC) THEN + T1=LAMBDA+S1 + S1=R1*T1-R2*S2 + S2=R2*T1+R1*S2 + LAMBDA=LAMBDA/H2 + ENDIF + ENDDO + IF (NC .EQ. 0) THEN + S1=R1 + S2=R2 + ENDIF + S1=CONST*S1 +c IF (Y .EQ. 0.0) RS1=EXP(-X*X) + VALUE=CMPLX(S1,CONST *S2) + IF(YY .GE. 0.0) THEN + IF(XX .LT. 0.0) VALUE=CONJG(VALUE) + ELSE + value=-value + VALUE=2.0*CEXP(-CMPLX(X,Y)**2)-VALUE +ccc print *,xx,yy,value + IF(XX .GT. 0.0) VALUE=CONJG(VALUE) + ENDIF + CWERF=VALUE + RETURN + END diff --git a/gen/fit.f b/gen/fit.f new file mode 100644 index 0000000..35f245f --- /dev/null +++ b/gen/fit.f @@ -0,0 +1,64 @@ + program FIT ! change FIT to your own program name +! ----------- +! +! Simple user function example (straight line). +! + implicit none + real FIT_LIN_FUN + external FIT_LIN_FUN ! change FIT_LIN_FUN to your own function name + + character vers*32 + integer i,l +!--- +! Welcome message + + call fit_vers(vers) + call str_trim(vers, vers, l) + + print '(X)' + print '(X,2A)','Program FIT Version ',vers(1:l) + do i=1,l + vers(i:i)='-' + enddo + print '(X,2A/)','-----------------------------',vers(1:l) +!--- +! Function title and parameter names +! + call fit_userfun('STRAIGHT LINE', fit_lin_fun) ! function title, function + call fit_userpar('Bg(0)') ! first parameter: background at zero + call fit_userpar('dBg/dX') ! second parameter: slope + call fit_main + end + + + + real function fit_lin_fun(x,p,n,mode,cinfo) +! ------------------------------------------- + + implicit none + + real x ! x-value + integer n ! number of parameters + real p(n) ! parameters + integer mode ! mode + integer cinfo ! calculation information (see below) + + if (mode .eq. 0) then + +! Define here your own function + + fit_lin_fun=p(1)+x*p(2) + + elseif (mode .lt. 0) then + +! Use this part to do some initialisations. +! (e.g. read files, write out comments on your user function) +! This section is called by FIT_FUN (command FUN) + + print * + print *, 'to define your own user function', + 1 ' leave FIT and type MYFIT' + print *, 'Example: STRAIGHT LINE' + + endif + end diff --git a/gen/fit.help b/gen/fit.help new file mode 100644 index 0000000..cbe0933 --- /dev/null +++ b/gen/fit.help @@ -0,0 +1,748 @@ +mzhelp +=main========================================================================= +Available fit functions: + 1-20 Gaussian, Lorentzian or Gaussian folded with Lorentzian + Critical exponents, Strange peaks, User defineable functions + +Data files supported: + TASMAD, NeXus (DMC, HRPT, FOCUS, MARS, RITA) + ASCII multicolumn format, SICS ascii, + LNS Powder Ascii, TASCOM, Fullprof plot output + 5c2, INX, IDA, 2T, PANDA, CCL + +Most fit commands can also be linked to a user FORTRAN program. + +Report bugs & wishes to markus.zolliker@psi.ch + +Topic Available keyword +----------------------------------------------------------------------------- +Command syntax "commands" +Features in plot window "graphics" +New features since 1990 "history" +Programming your own user function "user_function" "cinfo" "init" +Control FIT from a FORTRAN program "callable" +Fortran interface of any FIT command fit_X (where X is any FIT command) +Datafile specific options "opt" + +Commands Available keywords +----------------------------------------------------------------------------- +fitting commands: "fit" "mig" "sim" "epsi" "vtest" "err" "pri" +function definiton: "fun" "auto" "newpeak" +parameter handling: "set" "lim" "fix" "cor" "rel" "fcn" "reserr" +input: "load" "dat" "link" "next" "opt" +output: "save" "file" "out" "list" "export" +fit region: "win" "exclude" "include" "keep" +data manipulation: "mon" "merge" "mul" "sub" "add" "abskor" "trans" "bgedit" +plot: "plot" "scal" "rsc" "choose" "plog" "plin" "file" +plot style: "bars" "connect" "style" "colors" "legend" +miscellaneous: "help" "info" "exit" "tit" "@" +=commands===================================================================== +Syntax of an interactive command: + +Command parameter1,parameter2,parameter3,... + +If you omit some parameters, usually default values are taken or, +if it is explicitly documented, the program asks for missing +parameters. +Some commands can be shortened (indicated in brackets []) +=fit=mig=sim=epsi=vtest=err=pri============================================ +FIT n Start fitting by minimum gradient method (Davidon-Fletcher-Powell +[F] algorithm). If the algorithm fails, simplex is called. + +MIG n Start fitting by minimum gradient method. Even if the algorithm + fails, simplex is not called. + +SIM n Start fitting by simplex method. + +MIN n Start fitting by simplex followed by gradient method +[M] + (n: Limit for the number of function calls, default n=1000) + +ERR f Errors correspond to a FCN change of f (default: f=1.0). + + FCN = sum over { (Ycal(i)-Yobs(i)) / Sig(i) }**2 + Chi**2 = FCN / Nfree + +EPSI e Convergence criterion (Estimated distance to minimum). + Default e=0.1*f + +VTEST v Second convergence criterion for gradient method + (fractional change in variance matrix). Default: v=0.01 + +PRI i Amount of printout during fit algorithm (i=0..5, default: i=0) +=set=lim=fix=cor=rel=fcn=reserr============================================= +FCN Show all parameters + +SET i,v,e Set parameter i to value v with estimated error e +i=v,e Alternative command syntax + +LIM i,l,u Set limits of parameter i to l and u. +LIM i Remove limits of parameter i + +SET i,v,e,l,u a combination of the commands SET and LIM + +FIX i,j,... FIX parameter i and j and ... at actual value + +COR i,j,f,c Correlate parameters p(i)=p(j)*f+c + Default: f=1.0, c=0.0 + +REL i,j,... Release parameter i and j and ... from FIX or COR + If MaxInt or IntInt is released, the other of the two will be + correlated automatically. +REL Release all parameters + +RESERR should be called when after an unsuccesful fit the errors are + set to very small values. A further FIT step will then often + be successful. + +Note: instead of the parameter number i you can use the short parameter name. +=load=dat=link=next=========================================================== +LOAD filename Load data and parameters. +LOAD Ask for filename to load context. + +DAT Ask for filetype, filename/version number + (parameters are not loaded) +DAT filelist Load data file(s) (syntax for filelist see below) + +LINK filelist Add more data (syntax for filelist see below) + +NEXT [N] The same as DAT; MON; WIN; BARS; FUN + +Filelist syntax examples: + +101,103-105 Read numors 101,103,104,105 (actual year, actual instrument) +TASP/2000/10 Read numor 10 (year 2000 from TASP) +dmc/33 Read numor 33 from DMC (actual year, case not relevant) +2001/203,2002/10 Read numor 203 from 2001 and numor 10 from 2002 +&101,103-105 Read numors 101,103,104,105 and merge them ++103-105 Read numors 103-105, conserving old data (as in the LINK command) + +Example with options (see also command "OPT"): + +focus/101[bank=b] Read middle bank from numor 101 on focus +=options======================================================================= +You can preset options with the OPT command for successive data input, or +you may specify the options directly after the filename or numor enclosed +by square brackets [ ]. + +OPT Show a list of options for the type of the last read + file, show the previous selected options, and enter new options + +OPT ? Show a list of possible options and actually selected options +=save=file=out=list=export===================================================== +SAVE filename Save data, fit parameters, window and scaling +SAVE Ask for filename before saving + +FILE xstep, filename Save two files with observed and calculated dataset + for other plot software (xstep for calculated dataset, + xstep=0: a default value of (xmax-xmin)/100 is taken). + Give TT as filename for output at terminal directly +FILE Ask for filename and step + +LIST [L] Listing on terminal (x, y, yfit) + +OUT Output of listing (not a program-readable format!) + +OPEN file Open a file for output of fit results (default: fit.txt) + +K par1,par2 .. (K=keep) Write a line with values of given parameters +K Write parameters used last time or all parameters + You might use 'K' in the plot window for this command + +EXPORT type,filename export data (file types available: DMC, D1A) +EXPORT step,type,filename export with given x step +=win=exclude=include=keep====================================================== +WIN xmin,xmax Set fit window. +WIN Ask for fit window +WIN 1,1 Maximal fit window. +[W] + +EXCLUDE x1,x2 Exclude range x1..x2 +EXCLUDE x1,x2,y1,y2 Exclude rectangle (x1,x2,y1,y2) +EXCLUDE 1,1,y1,y2 Exclude range y1..y2 +[EXCL] + +INCLUDE ... Re-include regions (syntax as for EXCLUDE) +[INCL] + +KEEP List window and in-/excluded regions and + ask if they have to be kept on new data +KEEP Y Enable persistent window/regions +KEEP N Disable persistent window/regions +=mon=merge=mul=sub=abskor=add=bgedit=usemon=trans====================================== +MON m Change Monitor +MON Ask for Monitor + +USEMON Choose which channel to use as monitor + +MERGE s Add datapoints with same x (within a limit s). + If s is omitted, it is determined automatically + Overall monitor is changed, if appropriate + +MUL s1,s2,s3... Multiply datasets with scale factor. + +ABSKOR muR,ri,ra Correct for absorption + muR<0 inverse correction (muR as for a full cylinder) + ri>0: hollow cylinder (inner radius/outer radius) + ra: sample radius/radial collimator fwhm + +TRANS d,lambda Transform x-axis from to d (powder diffraction) +TRANS q Transform x-axis to q (lambda is taken from file or last cmd) +TRANS 2theta Transform back to 2-Theta +TRANS Ask for x-axis to transform to + +SUB filename Subtract a file from actual data + +ADD constant Add a constant to data + +BGEDIT file Edit graphically a background file +[BG] +=fun=auto=newpeak================================================================ +FUN Ask for fit function and start parameters. + +FUN n Select fit function n (ask for start parameters, if needed) + + n=0,1 Single Gaussian/Lorentzian (auto start parameters) + n=2,3 Multiple (1..4) Gaussian/Lorentzian + n=4 Gaussian+Lorentzian + n=5 Critical exponent + n=6 Strange peak (auto start parameters) + n=7 User function (see topic "User_function") + n=8 Plot only (no parameters) + +AUTO Determine start values for first peak (for function 0,1,2,3,4) + +NEWPEAK Create a new peak (for function 0,1,2,3,4). + + Delete a peak by setting intensity and error to zero. +=plot=scal=rsc=choose=plog=plin================================================= +PLOT [P] Plot (See also topic "Graphics") +PLOT yes Plot, make hardcopy file and do not wait. +PLOT auto automatic plot after every command +PLOT off switch off automatic plot + +SCAL xmin,xmax,ymin,ymax Set plot scale +SCAL [SC] Ask for scale + +RSC Reset plot scale (auto scale). + +PLOG shift Set logarithmic mode (and set shift between datasets) +PLIN shift Set linear mode (and set shift between datasets) + +CHOOSE [CHO] Select printer and printer options + +See also: + + "FILE" (export for other plot software) + "STYLE" (plot style, legend) + "Graphics" (hot keys in plot window) +=style=bars=connect=colors=legend=ncurves======================================= +BARS Yes/No Enable/disable error bars. + +CONNECT Yes/No [CON] Enable/disable lines between data points + +STYLE s1,s2,s3... Change style of dataset points +STYLE Ask for dataset styles + +COLORS [COL] Use colors for different datasets +COLORS n Use n colors for different datasets +COLORS 0 Use black and white + +NCURVES n Set number of curves for User-Function + +LEGEND [LEG] Show legend (Numor is default) +LEGEND var Use 'var' for legend ('LEGEND Temp' for temperature) +LEGEND 0 Do not show legend +LEGEND label1|label2|label3 .... + Show a customized legend +LEGEND |label4|label5|label6 .... + Append to a customized legend +LEGEND @x,y Set top left coordinate of legend (percent of window + width/height, y is measured from the top) + +See also: + "PLOT" (other commands related to plot) + "Graphics" (hot keys in plot window) +=help=info=exit=quit=tit=@======================================================= +@filename Execute commandfile + +HELP [H] Get help +HELP command Get help on command. + +INFO Show additional information from the last + read data file. +INFO level level is a small number controlling the amount + of output for the info command + +INFO variable show the value of this variable + +variable=value set a variable + +EXIT [EX] Exit program and save parameters and datapoints. + +QUIT [QU] Quit program without saving.. + +TITLE title [TIT] Change title. +TITLE Ask for title. + +FULLMESS After this command, error messages are more detailed, and + the program quits after an error. +=user_function=build_program===================================================== +On Unix: + + Get an example file: myfit + + Rename fitexample.f to a name of your choice (i.e. xxx.f) + and edit the parameters and the fit function. + + Compile: myfit -o xxx xxx.f + Run: ./xxx + +You may add any g77 option or parameter to the myfit argument list. + + +On VMS: + +To define your own user function, type MYFIT and change the file +FIT.FOR to your own function, rename the file to your own program +name xxx, compile it, link the program with + + LINK xxx,FIT4_SHR/OPT + +and start your program with + + RUN xxx + + +Related keywords: init (inititalisation of user function) + function () + cinfo (how to speed up complex fit functions) +=init============================================================================= +User function initialisation + +You have to call FIT_USERFUN to define title and function reference, and +you have to call FIT_USERPAR to define the name of each parameter. +Short name of variables can be given before long name, separated by +a colon ':'. + +Call FIT_MAIN afterwards to switch to fit command mode. + +If you want to keep control by program, you can call almost +every command (prefix FIT_, i.e. for plot you call FIT_PLOT). +In that case you must call FIT_INIT before calling other subroutines. + +Short help is available under the name of the subroutine. +=function========================================================================= +You have to program a user function, whitch will be called from three +different places within FIT: + +1. when command FUN is called or a new function is loaded: + MODE=-1 + all other arguments are undefined + +2. before each calculation of Chi-Square, i.e. before each Fit-Step: + MODE=1 + X=0.0 + N: number of parameters + P(1..N): parameters + CINFO: Info about changed parameters (See Topic "CINFO") + +3. for each point of Dataset(s) and when plotting function: + MODE=0 + X: X-value + N: number of parameters + P(1..N): parameters + CINFO: Dataset number or curve number +=cinfo============================================================================= +how to speed up complex fit functions + +this section is useful only, if the main part of the calculation +does not depend on X, i.e. matrix diagonalisation + +- split your calculation into several parts +- the subroutine FIT_USERCINFO(CINFO) determine the dependencies of the + calc. parts and the parameters. The integer CINFO is a bit map, where + each bit corresponds to a part of the calculation. The bit should be + set if the part depends on the parameters named in the following calls + to FIT_USERPAR. +- The integer CINFO within the fit user function determines, which + part of the calculation has to be redone (corresponding + bit set) and which part remains unchanged (bit clear) +=callable====================================================================== +For example for automatic fitting of many files, you probably want +to call the fit-commands from a FORTRAN program. Before any call +to the FIT subroutines you have to call FIT_INIT. + + for instructions on compile and link see topic "build" + +Explanations for the topics below: + +Specified arguments: Call with specified arguments. +Default arguments: For unspecified arguments, the subroutine uses + default values. +Ask for arguments: The subroutine asks for unspecified arguments. + If you want to start your program in batch + mode you normally have to avoid these calls. + +Available routines (use routine name as help keyword): +------------------------------------------------------- +fitting: fit_fit fit_sim fit_min fit_chisq + fit_pri fit_err fit_epsi fit_vtest +function definiton: fit_fun fit_newpeak fit_auto +parameter handling: fit_set fit_fix fit_rel fit_cor fit_get_array +input / output: fit_save fit_load fit_init fit_command fit_exit fit_range + fit_dat fit_link +data manipulation: fit_win fit_mon fit_dat fit_link fit_subtract fit_merge + fit_auto_mon fit_multiply fit_add fit_abskor + fit_dat_put fit_bgedit fit_keep + fit_include fit_exclude + fit_get_array, fit_get_real, fit_get_str + fit_put_array, fit_put_real, fit_put_str +plot: fit_plot fit_scale fit_rsc fit_bars fit_connect fit_title + fit_file +user commands: fit_usercmd + arg_check_cmd arg_str arg_real arg_int arg_par arg_lit +library routines: str_upcase, str_trim, str_append + sys_get_cmdpar, sys_setenv, sys_getenv +=fit_fit=fit_sim=fit_min=fit_pri=fit_err=fit_epsi=fit_vtest=fit_chisq========= +Specified arguments Default arguments Default value +-------------------------------------------------------------- +CALL FIT_FIT(n) CALL FIT_FIT(0) n=1000 +CALL FIT_SIM(n) CALL FIT_SIM(0) n=1000 +CALL FIT_MIN(n) CALL FIT_MIN(0) n=1000 +CALL FIT_PRI(n) CALL FIT_PRI(0) n=0 +CALL FIT_ERR(err) CALL FIT_ERR(0) err=0.5 +CALL FIT_EPSI(eps) CALL FIT_EPSI(0) eps=0,1*err +CALL FIT_VTEST(v) CALL FIT_VTEST(0) vtest=0.01 + +CALL FIT_CHISQ(chisq, istat) get chi square and fit success status + + INTEGER n, istat + REAL err,eps,v, chisq + +=fit_set=fit_fix=fit_rel=fit_cor=============================================== +Specified arguments Default arguments Default value +------------------------------------------------------------------ +CALL FIT_SET(i,p,e,l,u) CALL FIT_SET(i,p,e,0,0) l=0,u=0: no limit +CALL FIT_LIM(i,l,u) +CALL FIT_FIX(i) +CALL FIT_REL(i) +CALL FIT_COR(i,j,f,c) CALL FIT_COR(i,j,0,0) f=1.0, c=0.0 + + INTEGER i, j + REAL p, e, l, u, f, c +=fit_get_array=fit_put_array=fit_get_real=fit_get_str=fit_put_real=fit_put_str========== +Get and put parameters and or data + +CALL FIT_GET_ARRAY(name, array, ndim, nret) +where: + INTEGER ndim ! dimension (input) + REAL array(ndim) ! resultant array (output) + INTEGER nret ! array length returned (output) + CHARACTER*(*) name ! name of array + ! 'P': fit parameter, 'E': parameter error + ! 'X','Y': data, 'S': data error, 'W': data weight + +CALL FIT_PUT_ARRAY(name, array, nlen) +where: + INTEGER nlen ! length of array (must match length of data) + REAL array(nlen) ! array (input) + CHARACTER*(*) name ! name of array + ! 'X','Y': data, 'S': data error, 'W': data weight + ! to change parameters use subroutine FIT_SET + +CALL FIT_GET_REAL(name, value) +CALL FIT_GET_STR(name, l, str) +CALL FIT_PUT_REAL(name, value) +CALL FIT_PUT_STR(name, str) +where: + REAL value ! value to get or put + INTEGER l ! string length returned + CHARACTER*(*) str ! value to get or put + CHARACTER*(*) name ! call INFO 99 to see what variables are available +=fit_usercmd=arg_check_cmd=arg_str=arg_real=arg_int=arg_par=arg_lit========================= +User defineable commands + +CALL FIT_USERCMD(cmds) ! install command dispatch routine + +logical fucntion to check command: +ARG_CHECK_CMD(command, len) ! check for command (significant length: len) + +subroutines returning arguments: + +CALL ARG_REAL(value, default) ! get a real value argument from command line +CALL ARG_INT(value, default) ! get an integer value argument from command line +CALL ARG_PAR(value) ! get a parameter name/number as argument from .. +CALL ARG_LIT(string) ! get a name as argument from command line +CALL ARG_STR(string) ! get remaining arguments as string from comm... + +Usage: + external cmds + call fit_usercmd(cmds) ! call this within main module, after fit_init + + subroutine cmds(done) ! subroutine to define + logical done + + if (arg_check_cmd('DAT', 3)) then + ... treat command dat ... + done=.true. + elseif (arg_check_cmd('PLOT', 1)) then ! P is accepted as well + ... treat command plot ... + done=.true. + endif + end +=fit_dat=fit_win=fit_mon=fit_link=fit_subtract=fit_merge=fit_multiply=fit_abskor=fit_bgedit=fit_auto_mon=fit_add=fit_mon= +Specified arguments Default arguments Ask for arguments +--------------------------------------------------------------------- +CALL FIT_DAT(filename) CALL FIT_DAT(' ') +CALL FIT_WIN(xmin, xmax) CALL FIT_WIN(1.,1.) (= max. window) + CALL FIT_WIN(0,0) + +CALL FIT_MON(m) CALL FIT_MON(0) +CALL FIT_USEMON(m) CALL FIT_USEMON(0) +CALL FIT_LINK(filename) CALL FIT_LINK(' ') +CALL FIT_SUBTRACT(filename) CALL FIT_SUBTRACT(' ') + +CALL FIT_RANGE(r1, r2, filenames) ! attention: r1, r2 are REALs + +CALL FIT_MERGE(step) CALL FIT_MERGE(0.0) +CALL FIT_AUTO_MON adjust monitor after a FIT_MERGE + +CALL FIT_MULTIPLY(scale,0) one scale factor for all data +CALL FIT_MULTIPLY(scale,n) scale is an array of factors for each dataset + +CALL FIT_ABSKOR(mur,ri) CALL FIT_ABSKOR(0.0,0.0) +CALL FIT_ABSKOR2(mur,ri,ra) CALL FIT_ABSKOR(0.0,0.0,0.0) + +CALL FIT_ADD(const,0) const to add to all data +CALL FIT_ADD(const,n) const is an array for constants for each dataset + +CALL FIT_BGEDIT(file) + +CALL FIT_EXCLUDE(x1,x2,y1,y2) + +CALL FIT_INCLUDE(x1,x2,y1,y2) + +CALL FIT_KEEP('Y') CALL FIT_KEEP(' ') +CALL FIT_KEEP('N') +=fit_dat_put=========================================================================== +Put new datapoints into FIT + +CALL FIT_DAT_PUT(mode, x, nx, y, ny, s, ns, w, nw) +where: + INTEGER mode ! 0: purge before, 1: link new dataset, 2: link to existing dataset + INTEGER nx ! nx=1: x-values are xx(1),xx(1)+1,xx(1)+2,...,xx(1)+(nx-1) + INTEGER ny ! number of data points + INTEGER ns ! ns=1: ss(1) <> 0.0: sigma values are ss(1) + ! ss(1) = 0.0: sigma values are sqrt(max(1.0,yy(i))) + INTEGER nw ! nw=1: weights are ww(1) + REAL xx(nx) ! x-values + REAL yy(ny) ! y-values + REAL ss(ns) ! sigma values + REAL ww(nw) ! weights + +! precondition: (ny>0) and (nx=ny or nx=1 or nx=2) +! and (nx=ny or ns=1) and (nw=ny or nw=1) + +=fit_fun=fit_newpeak=fit_auto================================================== +Specified/auto arguments Ask for start parameters +---------------------------------------------------------------------- +CALL FIT_FUN(0, 0, 0.0,0.0) Gaussian +CALL FIT_FUN(1, 0, 0.0,0.0) Voigtian +CALL FIT_FUN(0, 1, pos,poserr) Gaussian at given start pos +CALL FIT_FUN(1, 1, pos,poserr) Voigtian at given start pos +CALL FIT_FUN(2, n, par,err) CALL FIT_FUN(2, 0) Multi-Gaussian +CALL FIT_FUN(3, n, par,err) CALL FIT_FUN(3, 0) Multi-Voigtian +CALL FIT_FUN(4, 12,par,err) CALL FIT_FUN(4, 0) Gaussian+Voigtian + CALL FIT_FUN(5) Crit. exponent +CALL FIT_FUN(6, 0, 0.0,0.0) Strange +CALL FIT_FUN(7, n, par,err) CALL FIT_FUN(7, 0) User function +CALL FIT_FUN(8, 0, 0.0,0.0) Plot only + + Ask for function and start parameters + ------------------------------------- + CALL FIT_FUN(-1, 0) + +CALL FIT_NEWPEAK +CALL FIT_AUTO + +where: + REAL par(np), err(np), pos, poserr + INTEGER n +=fit_plot=fit_scale=fit_rsc=fit_bars=fit_connect=fit_title=fit_file============== +Specified arguments Default arguments Ask for arguments +----------------------------------------------------------------------- +CALL FIT_PLOT('Y') CALL FIT_PLOT(' ') +CALL FIT_SCALE(x1,x2,y1,y2) + CALL FIT_SCALE(0,0,0,0) + + CALL FIT_SCAL(1.,1.,y1,y2) (auto x-range) + CALL FIT_SCAL(x1,y1,1.,1.) (auto y-range) +CALL FIT_RSC (auto range) + +CALL FIT_BARS('Y') CALL FIT_BARS(' ') +CALL FIT_BARS('N') +CALL FIT_CONNECT('Y') CALL FIT_CONNECT(' ') +CALL FIT_CONNECT('N') +CALL FIT_PLOG(log,shift) ! log=0,1 +CALL FIT_TITLE(title) CALL FIT_TITLE(' ') +CALL FIT_FILE(xstep, filename) CALL FIT_FILE(0,' ') +=fit_print=fit_list=fit_out==================================================== +Specified arguments Ask for filename +--------------------------------------- +CALL FIT_PRINT(1) (equivalent to command FCN) +CALL FIT_PRINT(0) (print variable parameters) + CALL FIT_LIST + CALL FIT_OUT +=fit_save=fit_load=fit_init=fit_command=fit_exit=fit_export==================== +Specified arguments Ask for arguments +-------------------------------------------- +CALL FIT_SAVE(filename) CALL FIT_SAVE(' ') +CALL FIT_LOAD(filename) CALL FIT_LOAD(' ') +CALL FIT_EXPORT(step, type, filename) (auto step: step=0) + +CALL FIT_INIT (has to be called first) +CALL FIT_COMMAND(filename) (equivalent to command @filename) +CALL FIT_COMMAND(' ') (switch to interactive mode) +CALL FIT_EXIT +=fit_userfun=fit_userpar=fit_usercinfo=fit_main================================ +CALL FIT_USERFUN(title,function) define user function (has to be called + before FIT_USERPAR +CALL FIT_USERPAR(name) define user parameter name (call once + for each parameter) +CALL FIT_USERCINFO(mask) define user calculation info mask for + following calls to FIT_USERPAR +CALL FIT_MAIN start fit command mode +=str_upcase=str_append=str_trim=sys_get_cmdpar=sys_setenv=sys_getenv=========== +CALL STR_UPCASE(out, in) convert to upper case +CALL STR_TRIM(out, in, length) determine string length without trailing space +CALL STR_APPEND(inout, length, in) append in to inout(1:length) + +CALL SYS_GET_CMDPAR(out, length) get command line parameters +CALL SYS_SETENV(name, value) set environment variable +CALL SYS_GETENV(name, value) get environment variable +=graphics====================================================================== +Within the graphic window, you hit a key for a command: + +Command Shortcut + +Print P Printing Graphics +Insert I Insert peak at the actual x/y position. + the halfwidth is determined automaticaly. + (BGEDIT: insert point) +Delete D Delete peak (BGEDIT: delete point) +Repaint R Repaint graph +Zoom in Z Zoom in*. +Zoom out O Zoom out by a factor 2:1 +Jump J Center graph at cursor position without changing scale +max.Scale X Automatic scaling (observed data fits the data window) +Window W Set fit window* +Exclude E Mark excluded region* +Include N Mark region to re-include* +Log/Lin L Switch between log and lin +Colors C Switch between colors and b/w +Show Coord. S Show (X,Y) value of cursor +Quit Q Leave graphic user-interface + +* move to the first corner, click the correspoding key, move to the second + corner, press the key again. If you want to perform the command only in one + dimension, move to locations below the x-axis or left to the y-axis. +=history======================================================================= +Version 2.0 +- FIT saves all parameters and the data file name on exit. +- You can now enter directly to command mode by pressing RETURN at the + first prompt. +- The parameters of most commands can now be passed directly via + command line. +- Command line editing (recall of previous 20 commands). +- Command-files can be executed. +- Old command WIN is now separated into the commands WIN, MON and BARS. +- New command MIG (call migrad only) +- Abort of fit algorithm by pressing (return to command level). +- All commands of FIT are now callable FORTRAN subroutines. +- Enhanced user fit-function definition. +- Extended HELP + +Version 3.0 +- All peak functions (Gaussian, Lorentzian, Voigtian) have now the same + parameters and switching between them can be done by changing parameters + (If fwhm L = 0: Gaussian, if fwhm G =0: pure Lorentzian, else Voigtian) +- Graphics package is changed from PLOT10 to GRAPHX. FIT runs now on most + graphic devices, including X-Window. +- Graphic user-interface: zoom, edit peaks, create new peaks, delete peaks. +- New peaks can be created by command NEWPEAK +- Peaks can be deleted by setting intensity to 0 +- New command CHOOSE (printer options) +- COR i1,i2,f no longer has the restriction i1>i2 + +Version 3.3 +- Load multiple data files +- Command LINK to load additional data +- Data from different files are plotted with different symbols +- Command MERGE to add points with same X-value +- New data file types available: IN3, D1A5, D1A6, 3-column + +Version 3.5 +- MULtiply data with scale factor +- SUBtract datafiles +- D2B-files readable + +Version 3.6 +- Data can be saved as DMC or D1A format + use command SAVE with extension .DMC (or .D1A respectively) +- Command ABSKOR for absorption correction +- Parameter can be given as name instead of number (Example: FIX P1 = FIX 3) +- Short form for SET command. Example: G1=0.4 +- Command STYLE to set marker symbols or to connect points +- Enhanced output for Mac Plot Software (Kaleidagraph, ProFit...) + use command FILE TT and Copy-Table in VersaTerm +- New command AUTO: determine start-values for Gaussian Fit without loosing + FIX and COR settings. +- Bug corrected: Sometimes fit was not correct and errors were very small + after a DAT command. This is now corrected. + +Version 3.7 +- Command CONNECT Y to connect data points + +Version 4.0 +- Now available on Digital Unix +- PGPLOT Graphics package instead of GRAPHX + +Version 4.1 +- Background editing command BGEDIT (replaces GEDIT program) +- Export command (actually supporting DMC and D1A datafile type) +- Enhanced Fortran-Interface + +Version 4.2 +- ADD a constant do data +- new data types: INX, CCL +- RANGE command for 2D data and multi-dataset files like INX or CCL +- subroutine FIT_DAT_PUT: load data from memory of calling program +- subroutines FIT_GET_ARRAY, FIT_GET_REAL and FIT_GET_STR: inquire data + and parameters +- subroutines FIT_PUT_ARRAY, FIT_PUT_REAL and FIT_PUT_STR: modifiy data +- subroutine FIT_USERCMD: plug-in commands +- subroutine FIT_DAT_MERGE: fit_dat and fit_merge in one command + (to avoid memory overflow) +- made available some library soutines: STR_UPCASE, STR_TRIM, STR_APPEND + SYS_GET_CMDPAR, SYS_SETENV, SYS_GETENV +- subroutine FIT_VERS: get actual version + +Version 4.3 +- new commands EXCLUDE, INCLUDE: excluded regions +- new command KEEP: persistent fit-window (select if fit window and + excluded regions are kept on DAT command) + +Version 4.4 +- new commands PLOG and PLIN for logarithmic plots and shifted + datasets +- new commands LEGEND and COLORS +- can read RITA single detector files + +Version 4.5 +- absorption correction for hollow cylinders +- plot fullprof output files +- new command TRANS (transform x-axis between 2theta/d/q for powder diffraction) +- more options for calibration of powder diffraction data +- user function may be folded with gaussian (example: program BOSE) +- can read HDF5 files (TriCS NeXus files) diff --git a/gen/fit.inc b/gen/fit.inc new file mode 100755 index 0000000..55d3236 --- /dev/null +++ b/gen/fit.inc @@ -0,0 +1,149 @@ +C ======================================================================== +C ###### FIT.INC ###### +C ======================================================================== +C + integer maxext,maxpar,maxpeak,maxplug,maxflen + integer maxdat, maxset, maxpd + real none + parameter (maxdat=250000) ! max. number of datapoints + ! this value is actually determined by fullprof synchrotron data + ! (number of points)*4 + number of reflections + parameter (maxext=400) ! max. number of parameters + parameter (maxpar=200) ! max. number of fitted parameters + parameter (maxpeak=(maxext-2)/5)! max. number of peaks + parameter (maxplug=16) ! max. number of plugin commands + parameter (maxset=256) ! max. number of datasets + parameter (maxpd=8) ! max. number of per-dataset parameters + parameter (maxflen=8192) ! max. filelist length + parameter (none=-9.876543e-21) ! undefined value + + real v(maxpar,maxpar) ! covariance matrix (must be first in common) + integer npar, nu, ni ! number of internal, external parameters, informational parameters + character*8 pnam(maxext) ! actual parameter names + character*4 psho(maxext) ! actual short parameter names + real u(maxext) ! parameter values + real werr(maxext),werrs(maxext) ! parameter errors, saved errors + real dirin(maxext) ! internal steps + real alim(maxext), blim(maxext) ! limits + integer lcode(maxext) ! <0: fixed, 1: normal, else: limited + integer lcorsp(maxext) ! index of internal parameter + integer icsw(maxext) ! correlation flag (0: not corr., 1: corr., -1: special I=M*G) + integer icto(maxext) ! correlation pointer + integer ncor, icord(maxext) ! correlation order + real cfac(maxext) ! correlation factors + real coff(maxext) ! correlation offsets + real x(maxpar) ! internal parameters + + real amin ! function value + real apsi, epsi, vtest ! convergence criteria + integer ififu ! fit function (1: multi Gauss / Lorentz / Voigt + ! 5: crit. Exponent, 6: strange, 7: your own funct, 8: plot only + integer nfree ! degrees of freedom + integer nfcn, nfcnmx ! number of function calls, maximum + integer isw(5) ! isw(1)=0,1(max number of fit calls exceeded) + ! isw(2)=0,1,2,3(normal convergence) + real up ! value for error calc. + integer itaur ! ? + real sigma ! ? + + character*(maxflen) filnam ! file name + character*(maxflen) fillis ! file name list + character*(maxflen) filesave ! saved file name (for RANGE) + real ymon, ymon0 ! overall monitor (perm./temp.) + integer titlen + parameter (titlen=80) + character*(titlen) itit ! title + real temp,dtemp,wtemp,wavlen ! parameters for plot output + integer load_state ! 0: no load, 1: accept, 2: done, 3: done, but load data from filnam + + real xval(maxdat) ! x-values + real yval(maxdat) ! y-values + real rmon(maxdat) ! original monitors + real sig(maxdat) ! errors + integer iset(maxdat) ! dataset number + integer nset ! highest number of dataset + + integer npkt ! total number of points + integer nback ! end of background points + integer isysrd, isyswr ! logical units + + integer iscx, iscy ! auto scale flags + integer nstyl, styl(maxset) ! dataset styles + integer autostyle ! automatic style (used for powder diffraction) + logical autoplot ! automatic plot after each command + + integer ncolor ! number of colors used (0 for b/w) + integer npd ! number of per-dataset parameters + real pdpar(maxpd, maxset) ! per-dataset parameters + integer nmult ! number of tables + integer cols(maxset) ! number of cols + integer rows(maxset) ! number of rows + integer legend ! legend parameter + character legendlabels*2048 ! custom legend + real legendx,legendy ! legend position + + integer nxmin, nxmax ! fit window + real xbeg, xend, ybeg, yend ! plot scale + real yinteg, dyinteg ! integrated experimental intensity, error + integer gradev ! graph device + + integer userfun ! user function number + character*4 usersho(maxext) ! user function parameter short names + character*32 userpar(maxext) ! user function parameter names + integer usernp ! number of user function parameters + integer usercct(maxext) ! calc. flags for user function + character*16 usertit ! user function title + integer cinfo ! calc. info + real pold(maxext) ! last parameters + + integer actset ! set number of point calc. + integer trfmode ! 0: normal, 1: logarithmic + real shift(0:1) ! shifts for quasi 3-d + + logical argok ! command arguments ok + logical quit ! quit flag + character cmdline*8192 ! commandline + character separator*1 ! command argument separator + integer cmdpos, cmdlen, linlen ! position, length of command, length of command line + integer nplug ! number of plugin command routins + integer plug_cmds(maxplug) ! plug-in command routines + + + integer maxregion + parameter (maxregion=33) + logical keepregion ! keep window/excluded region on DAT command + integer nregion ! region list length + real regx1(maxregion) ! included region: regx1<=regx2 and regy1<=regy2 + real regx2(maxregion) ! excluded region: else + real regy1(maxregion) ! regx1=regx2: infinite x-range + real regy2(maxregion) ! regy1=regy2: infinite y-range + + common/fitint8/plug_cmds,userfun + + common/fitreal8/v + + common/fitchari/usertit,filesave,itit + + common/fitchar/cmdline,userpar,usersho,legendlabels + 1,psho,pnam,filnam,fillis,separator + + common/fitinti/nset,isysrd,isyswr,nstyl,styl,autostyle,cinfo + 1,usernp,nplug,trfmode,ncolor,legend + + common/fitint/npar,nu,ni,lcode,lcorsp,icsw,icto,ncor,icord + 1,ififu,nfree,nfcn,nfcnmx,isw,itaur + 1,iset,npkt,iscx,iscy,nxmin,nxmax,usercct + 1,actset, cmdpos, cmdlen, linlen, gradev, load_state + 1,npd,nmult,rows,cols,nback,nregion + + common/fitreal/u,werr,werrs,dirin,alim,blim,cfac,coff,x + 1,amin,apsi,epsi,vtest,up,sigma + 1,ymon,ymon0,temp,dtemp,wtemp,wavlen + 1,xval,yval,rmon,sig + 1,xbeg,xend,ybeg,yend,pdpar + 1,yinteg,dyinteg,pold,regx1,regx2,regy1,regy2 + 1,legendx,legendy + + common/fitreali/shift + + common/fitlog/autoplot,quit,argok,keepregion diff --git a/gen/fit.vers b/gen/fit.vers new file mode 100644 index 0000000..20c05e6 --- /dev/null +++ b/gen/fit.vers @@ -0,0 +1,2 @@ +vers +4.6 diff --git a/gen/fit_abskor.f b/gen/fit_abskor.f new file mode 100644 index 0000000..c08c65e --- /dev/null +++ b/gen/fit_abskor.f @@ -0,0 +1,262 @@ + subroutine fit_abskor(muRinp, rinp) + real muRinp, rinp + call fit_abskor2(muRinp, rinp, 0.0) + end + + subroutine fit_abskor2(muRinp, rinp, radc) + +c absorption correction for neutron powder diffraction +c cylindrical geometry +c + implicit none + + include 'fit.inc' + real muRinp, rinp, radc + + real muR,ri,ra + character*64 value + + real cvt_ratio + + if (muRinp .eq. 0) then + write(isyswr,'(x,a)') 'Absorption correction' + write(isyswr,'(x,2a)') '-- for hollow cyclinders, the muR' + 1 ,' of a full cylinder has to be given' + muR=0 + call sym_get_real('muR', muR) + if (muR .eq. 0) then + write(isyswr,'(x,a,$)') 'muR: ' + else + write(isyswr,'(x,a,f8.4,a,$)') 'muR (default:', muR, '): ' + endif + read(isysrd,'(F20.0)',end=999,err=999) muR + write(isyswr,'(x,a,$)') 'r/R (default: 0.0 / full cyclinder): ' + read(isysrd,'(A)',end=999,err=999) value + ri=cvt_ratio(value, -1.0) + if (ri .lt. 0) goto 999 + write(isyswr,'(/3(x,a/),x,a,$)') 'Radial collimator correction' + 1 ,'on DMC, in general, no correction is needed' + 1 ,'on HRPT, coll. is 7 or 14 mm' + 1 ,'sample radius/collimation fwhm (default: 0 = no corr.): ' + read(isysrd,'(A)',end=999,err=999) value + ra=cvt_ratio(value, -1.0) + if (ra .lt. 0.0) goto 999 + else + muR=muRinp + ri=rinp + ra=radc + endif + call sym_put_real('muR', abs(muR)) + if (muR .gt. 0.0) then + write(isyswr,'(x,a,f8.4)') 'Correct for absorption, muR=',muR + call abscorn(muR, ri, ra, 2, nxmax+1-nxmin + 1 , xval(nxmin), yval(nxmin), sig(nxmin)) + elseif (muR .lt. 0.0) then + write(isyswr,'(x,a,f8.4)') + 1 'Inverse absorption correction, muR=',-muR + call abscorn(-muR, ri, ra, -2, nxmax+1-nxmin + 1 , xval(nxmin), yval(nxmin), sig(nxmin)) + endif + if (ri .eq. 0) then + write(isyswr,'(x,a)') 'for a full cyclinder' + else + write(isyswr,'(x,a,f8.4)') 'for a hollow cyclinder, r/R=',ri + endif + if (ra .ne. 0) then + write(isyswr,'(x,a,f5.1,a)') 'correction for radial collimator ' + 1 ,ra,' ra/rc' + endif + return +999 print *,'input error' + end + + + + subroutine abscorn(muR, ri, ra, mode, npt, twoth, yy, sig) + + ! calculate absorption correction of hollow cylinders + + real muR ! absorption coefficient + real ri ! (inner radius)/(outer radius) + real ra ! radial collimator 1/fwhm + integer mode ! mode = 0 transmission is returned in YY + ! mode = 1 correction of YY + ! mode =-1 inverse correction of YY + ! mode = 2 correction of YY and SIG + ! mode =-2 inverse correction of YY and SIG + integer npt ! number of data points + real twoth(npt) ! two_theta values + real yy(npt) ! returned transmission or Y to correct + real sig(*) ! sigma to correct + + integer nmax + parameter (nmax=60) + + double precision th1, th2, dt, tc0, tcn + real t, tnorm + real tcalc(0:nmax) + real slope(0:nmax), x + integer i, j, n + + external spline, abscor1 + real spline + double precision abscor1 + + if (abs(mode) .gt. 3) stop 'illegal mode' + + if (mode .eq. 0) then + do i=1,npt + yy(i)=1.0 + enddo + else + tnorm=abscor1(dble(muR), dble(ri), dble(ra), 0.0D0) + endif + if (npt .le. nmax) then + do i=1,npt + t=abscor1(dble(muR), dble(ri), dble(ra), dble(twoth(i)*0.5)) + if (mode .gt. 0) t=1/t + yy(i)=yy(i)*t + if (abs(mode) .eq. 2) then + sig(i)=sig(i)*t + endif + enddo + else + th1=90. + th2=0. + do i=1,npt + th1=min(th1, max(0.0D0,dble(twoth(i)*0.5-90/nmax))) + th2=max(th2, min(90.D0,dble(twoth(i)*0.5+90/nmax))) + enddo + n=nint(nmax*min(1.D0,(th2-th1)/90)) + dt=(th2-th1)/n + tc0=abscor1(dble(muR), dble(ri), dble(ra), th1) + tcalc(0)=tc0 + tcn=abscor1(dble(muR), dble(ri), dble(ra), th2) + tcalc(n)=tcn + do i=1,n-1 + tcalc(i)=abscor1(dble(muR), dble(ri), dble(ra), th1+dble(i*dt)) + enddo + slope(0)=-10.*(tc0-abscor1(dble(muR),dble(ri),dble(ra),th1+dt*0.1)) + slope(n)= 10.*(tcn-abscor1(dble(muR),dble(ri),dble(ra),th2-dt*0.1)) + do i=1,n-1 + slope(i)=(tcalc(i+1)-tcalc(i-1))*0.5 + enddo + do i=1,npt + x=(twoth(i)*0.5-th1)/dt + j=min(n-1,int(x)) + t=spline(x-j, tcalc(j), slope(j)) + if (mode .gt. 0) t=1/t + yy(i)=yy(i)*t + if (abs(mode) .eq. 2) then + sig(i)=sig(i)*t + endif + enddo + endif + if (mode .ne. 0) then + if (mode .lt. 0) tnorm=1/tnorm + do i=1,npt + yy(i)=yy(i)*tnorm + if (abs(mode) .eq. 2) then + sig(i)=sig(i)*tnorm + endif + enddo + endif + end + + + real function spline(x, y, s) + + real x, y(2), s(2) + real dy + + dy=y(2)-y(1) + spline=y(1)+x*((x-1)*(s(2)*x+s(1)*(x-1))+dy*x*(3-2*x)) + end + + + double precision function abscor1(muR, ri, ra, th) + + double precision th, mur, ri, ra + + double precision sum, sums, p, w, r, dphi + double precision dr, phi, ri2, pa + integer nr, nf, j, k, ip + + double precision path + + double precision cosd,x + cosd(x)=cos(x/180.*3.14159265) + + nr=100 + nf=200 + + ri2=ri*ri + dr=(1-ri)/nr + ! simpson integration over r + sums=0 + do j=0,nr + if (mod(j,2) .eq. 1) then + w=4./3. + else if (j .ne. 0 .and. j .ne. nr) then + w=2./3. + else + w=1./3. + endif + r=min(1.D0,ri+j*dr) + ! simple integration over phi (simpson would not help, as the integration goes over a circle) + sum=0 + dphi=360./nf + do k=1,nf + phi=(k-0.5)*dphi + pa=path(phi, th, r, ri2) + ip=nint(pa*10) + p=mur*pa + if (ra .eq. 0) then + sum=sum+exp(-p) + else + sum=sum+exp(-p)*max(0D0,1D0-r*abs(cosd(phi+th))*ra) + endif + enddo + sums=sums+w*sum*r*dphi + enddo + abscor1=sums/(1.+ri)/dble(nr*180) + end + + + double precision function path(phi, th, r, ri2) +! +! calculate path length through a hollow cylinder sample of an +! outer radius ro=1 and an inner radius ri +! +! phi: angle (scatterer,sample center,y-direction) +! r: distance scatterer - sample center +! th: scattering angle theta (deg) +! ri2 = ri*ri +! the incoming beam has direction -theta, the outgoing beam direction +theta + + + double precision phi, th, r, ri2 + + double precision r1, r2, p1, p2, ph + + double precision sind, cosd, x + cosd(x)=cos(x/180.*3.14159265) + sind(x)=sin(x/180.*3.14159265) + + ph=mod(phi,360.D0) + if (ph .gt. 180.D0) ph=360.D0-ph ! problem is symmetric (y-axis is mirror axis) + + r1=(r*cosd(th-ph))**2 ! square of distance of incoming beam from center + p1=sqrt(1.0D0-r1)-r*sind(th-ph) ! path from entry point + if (r1 .lt. ri2 .and. ph .gt. th) then ! incoming beam cuts inner cylinder before scatterer + p1=p1-2.D0*sqrt(ri2-r1) ! subtract path through inner cylinder + endif + + r2=(r*cosd(th+ph))**2 ! square of distance of outgoing beam from center + p2=sqrt(1-r2)-r*sind(th+ph) ! path to exit point + if (r2 .lt. ri2 .and. ph .gt. 180.D0-th) then ! outgoing beam cuts inner cylinder after scatterer + p2=p2-2.D0*sqrt(ri2-r2) ! subtract path through inner cylinder + endif + + path=p1+p2 + end diff --git a/gen/fit_array.f b/gen/fit_array.f new file mode 100644 index 0000000..4a21c5a --- /dev/null +++ b/gen/fit_array.f @@ -0,0 +1,92 @@ + subroutine fit_get_array(name, array, maxn, retn) + + character name*(*) + integer maxn, retn + real array(maxn) + + include 'fit.inc' + + integer m, l + character nam*16 + + m=maxn + call str_upcase(nam, name) + call str_trim(nam, nam, l) + goto (1,98,2,98,3,98,4,98,5,98,6) index('P E X Y S W ',nam(1:l+1)) +98 retn=0 + +1 if (ni .lt. 0) call fit_print(2) ! recalc exp.int + call fit_cop_array0(u, nu+ni, array, m) + goto 99 + +2 if (ni .lt. 0) call fit_print(2) ! recalc exp.int + call fit_cop_array0(werr, nu+ni, array, m) + goto 99 + +3 call fit_cop_array0(xval(nxmin), nxmax-nxmin+1, array, m) + goto 99 + +4 call fit_cop_array0(YVAL(nxmin), nxmax-nxmin+1, array, m) + goto 99 + +5 call fit_cop_array0(sig(nxmin), nxmax-nxmin+1, array, m) + goto 99 + +6 call fit_cop_array0(rmon(nxmin), nxmax-nxmin+1, array, m) + goto 99 + +99 retn=m + end + + + subroutine fit_put_array(name, array, maxn) + + character name*(*) + integer maxn + real array(maxn) + + include 'fit.inc' + + integer m, l + character nam*16 + + m=nxmax-nxmin+1 + if (maxn .ne. m) + 1 stop 'FIT_PUT_ARRAY: array length must not change' + + call str_upcase(nam, name) + call str_trim(nam, nam, l) + goto (1,98,2,98,3,98,4,98,5,98,6) index('P E X Y S W ',nam(1:l+1)) +98 stop 'FIT_PUT_ARRAY: illegal array name' + +1 stop 'FIT_PUT_ARRAY: array P not allowed, use FIT_SET' + +2 stop 'FIT_PUT_ARRAY: array E not allowed, use FIT_SET' + +3 call fit_cop_array0(array, maxn, xval(nxmin), m) + goto 99 + +4 call fit_cop_array0(array, maxn, YVAL(nxmin), m) + goto 99 + +5 call fit_cop_array0(array, maxn, sig(nxmin), m) + goto 99 + +6 call fit_cop_array0(array, maxn, rmon(nxmin), m) + goto 99 + +99 end + + + subroutine fit_cop_array0(src, nsrc, array, maxn) + + integer maxn, nsrc + real array(maxn), src(nsrc) + + integer i + + do i=1,min(maxn, nsrc) + array(i)=src(i) + enddo + maxn=nsrc + end diff --git a/gen/fit_auto.f b/gen/fit_auto.f new file mode 100644 index 0000000..a087695 --- /dev/null +++ b/gen/fit_auto.f @@ -0,0 +1,234 @@ + subroutine fit_auto + + implicit none + + include 'fit.inc' + + call fit_findauto + call fit_set(0,0.0,0.0,0.0,0.0) + end + + + + subroutine fit_findauto + + implicit none + + include 'fit.inc' + + real wid, ewid, u5, yk, yk1, yk2, xk1, xk2, xd + character str*32 + integer l,i,k + + real voigt + + l=0 + + if (lcode(3) .eq. 0) then + xd = 1.0e37 + yk = 0 + do i=nxmin,nxmax ! find neareset x-value + if (abs(xval(i)-u(3)) .lt. xd) then + xd=abs(xval(i)-u(3)) + yk = YVAL(i) + k = i + endif + enddo + else + yk = 0. + k = (nxmin + nxmax) / 2 ! initialize k for bad cases + do i=nxmin,nxmax ! find max. intensity + if (YVAL(i) .gt. yk) then + yk = YVAL(i) + k = i + endif + enddo + endif + if (yk .le. 0) then + yk=1.0 + endif + yk1 = yk + xk1=nxmin + do i=nxmin,k ! find min. int. left + if (YVAL(i) .ne. 0. .and. YVAL(i) .lt. yk1) then + yk1 = YVAL(i) + xk1 = xval(i) + endif + enddo + yk2 = yk + xk2=nxmax + do i=k,nxmax ! find min. int. right + if (YVAL(i) .ne. 0. .and. YVAL(i) .lt. yk2) then + yk2 = YVAL(i) + xk2 = xval(i) + endif + enddo + if (lcode(2) .le. 0 .and. u(2) .eq. 0) then ! background horizontal + if (lcode(1) .gt. 0) then ! Bgr .not. fixed + u(1)=(yk1+yk2)/2 + werr(1) = max(1e-5,yk2/100,yk1/100,u(1)/10) + l=l+4 + str(l-3:l)=psho(1) + endif + else + if (lcode(2) .gt. 0) then ! dBg/dX not fixed + u(2) = (yk2-yk1)/(xk2-xk1) + werr(2) = max(1e-5,abs((yk2+yk2)/(xk2-xk1))/100.,abs(u(2)/10)) + l=l+4 + str(l-3:l)=psho(2) + endif + if (lcode(1) .gt. 0) then ! Bgr. not fixed + u(1) = yk1+(xval(k)-xk1)*u(2) + werr(1) = max(1e-5,yk2/100,yk1/100,u(1)/10) + l=l+4 + str(l-3:l)=psho(1) + endif + endif + + u5=u(5) + u(5)=0.0 + call fit_findhw(k, xval(k), wid, ewid) + u(5)=u5 + + if (lcode(3) .gt. 0) then + u(3)=xval(k) + werr(3)=ewid + l=l+4 + str(l-3:l)=psho(3) + endif + + if (lcode(7) .gt. 0) then + if (lcode(6) .gt. 0) then + u(6)=wid/10. + werr(6)=ewid + l=l+4 + str(l-3:l)=psho(6) + endif + u(7)=wid + werr(7)=ewid + l=l+4 + str(l-3:l)=psho(7) + elseif (lcode(6) .gt. 0) then + u(6)=wid + werr(6)=ewid + l=l+4 + str(l-3:l)=psho(6) + endif + + if (lcode(4) .gt. 0) then + u(4) = yk-u(1) + werr(4) = max(1e-5, abs(sig(k))) + l=l+4 + str(l-3:l)=psho(4) + elseif (lcode(5) .gt. 0) then + u(4) = yk-u(1) + werr(4) = max(1e-5, abs(sig(k))) + yk=voigt(0.0,u(6),u(7)) + u(5)=u(4)/yk + werr(5)=werr(4)/yk + l=l+4 + str(l-3:l)=psho(5) + endif + + if (l .gt. 0 .and. isyswr .ne. 0) then + write(isyswr,'(x,2a)') 'Auto parameters: ',str(1:l) + endif + end + + + + subroutine fit_findhw(ipos, pos, hw, hwe) + + implicit none + + include 'fit.inc' + + integer ipos + real pos, hw, hwe + + real tm,t0,t,d,dd,x1,x2,halfmax + integer m,i,i1,i2 + + real fifun ! function + + if (ipos .eq. 0) then + +! find nearest point to pos + m=nxmin + d=abs(xval(nxmin)-pos) + do i=nxmin,nxmax + dd=abs(xval(i)-pos) + if (dd .lt. d) then + m=i + d=dd + endif + enddo + + else + + m=ipos + + endif + + if (nu .eq. 2) then + u(3)=pos + nu=3 ! fifun won't use u(3) if nu=2 (workaround) + endif + +! find points > half height left + +1 tm=(YVAL(m)-fifun(xval(m))) + t0=tm + halfmax=t0/2 + do i=m-1,nxmin,-1 + t=YVAL(i)-fifun(xval(i)) + if (t .gt. tm) then ! pos was not good + m=i + goto 1 + endif + if (t .le. halfmax) then + i1=i + if (t0-t .eq. 0.0) then + d=0 + else + d=(xval(i1+1)-xval(i1))/(t0-t) + endif + goto 2 + endif + t0=t + enddo + i1=nxmin + d=0 +2 x1=xval(i1)+(halfmax-t)*d + +! find points > half height right + + t0=tm + do i=m+1,nxmax + t=YVAL(i)-fifun(xval(i)) + if (t .gt. tm) then ! pos was not good + m=i + goto 1 + endif + if (t .le. halfmax) then + i2=i + if (t0 - t0 .eq. 0) then + d=0 + else + d=(xval(i2)-xval(i2-1))/(t0-t) + endif + goto 3 + endif + t0=t + enddo + i2=nxmax + d=0 +3 x2=xval(i2)-(halfmax-t)*d + if (x2 - x1 .eq. 0.0) then + x2=xval(nxmax) + x1=xval(nxmin) + endif + hw=max(abs(xval(min(m+1,nxmax))-xval(max(1,m-1)))/2,abs(x2-x1)) + hwe=hw*0.1 + if (nu .eq. 3) nu=2 ! put back fifun + end diff --git a/gen/fit_bars.f b/gen/fit_bars.f new file mode 100644 index 0000000..39a5433 --- /dev/null +++ b/gen/fit_bars.f @@ -0,0 +1,28 @@ + subroutine fit_bars(errb) +! ------------------------- + + implicit none + include 'fit.inc' + character errbar*1, errb*(*) + integer i + + 1002 FORMAT (4X,'Errorbars (Y/N, default:Yes): ',$) + + if (errb .eq. ' ') then + 102 WRITE (ISYSWR,1002) + READ (ISYSRD,'(a1)',ERR=102,END=999) ERRBAR + else + errbar=errb + endif + IF (errbar .EQ. 'N' .OR. errbar .EQ.'n' .or. + 1 errbar .eq. '0') then + do i=1,maxset + styl(i)=-abs(styl(i)) + enddo + else + do i=1,maxset + styl(i)=abs(styl(i)) + enddo + endif + autostyle=0 +999 end diff --git a/gen/fit_bgedit.f b/gen/fit_bgedit.f new file mode 100644 index 0000000..49762da --- /dev/null +++ b/gen/fit_bgedit.f @@ -0,0 +1,42 @@ + subroutine fit_bgedit(bgfile) + + include 'fit.inc' + + character bgfile*(*) + + integer l, i, iostat + character fil*128 + + if (bgfile .eq. ' ') then + write(6, '(x,a,$)') 'Enter background file: ' + read(isysrd, '(a)',err=999,end=999) fil + if (fil .eq. ' ') return + else + fil=bgfile + endif + nback=npkt + call sys_open(1, fil, 'r', iostat) + if (iostat .eq. 0) then +1 if (nback .ge. maxdat) goto 9 + read(1,*,err=9,end=9) xval(nback+1), YVAL(nback+1) + nback=nback+1 + goto 1 +9 close(1) + endif + call fit_connect('Y') + call fit_bars('N') + call fit_plot('B') + call str_trim(fil, fil, l) + call sys_open(1, fil, 'w', iostat) + if (iostat .ne. 0) goto 99 +20 print *,'write background file ', fil(1:l) + do i=npkt+1,nback + write(1, *) xval(i), YVAL(i) + enddo + close(1) + goto 100 +999 print *,'input error' + goto 100 +99 print *, 'cannot write to background file: ', fil(1:l) +100 npkt=nxmax + end diff --git a/gen/fit_command.f b/gen/fit_command.f new file mode 100755 index 0000000..9237f13 --- /dev/null +++ b/gen/fit_command.f @@ -0,0 +1,1005 @@ + SUBROUTINE FIT_COMMAND(input) +C ----------------------------- + + include 'fit.inc' + + character INPUT*(*) !! commandfile name, if blank: input from terminal + + character*5 prompt/'fit> '/ + integer maxlev + parameter (maxlev=32) + integer sp, st(maxlev) ! lun stack for nested @ + + integer lun + logical terminal + integer rlun, iostat + character fullm*1 + + external fit_docmd + + quit=.false. + sp=0 + if (input .eq. ' ') then + rlun=isysrd + terminal=.true. + else + terminal=.false. + rlun=0 + cmdline(1:1)='@' + cmdline(2:)=input + linlen=len(input)+1 + sp=0 + goto 20 + endif + +10 write(isyswr, *) +11 continue +12 if (terminal .and. sp .eq. 0) then + call sys_rd_line(cmdline, linlen, prompt) + if (linlen .lt. 0) return + if (linlen .eq. 0) goto 12 + cmdline=cmdline(1:linlen) + if (cmdline(1:linlen) .eq. ' ') goto 12 + else + read(rlun, '(a)', end=998, err=998) cmdline + call str_trim(cmdline, cmdline, linlen) + if (cmdline(1:linlen) .eq. ' ') goto 12 + write(isyswr, *) prompt, cmdline(1:linlen) + endif + +20 if (cmdline(1:1).eq. '@' .and. linlen .gt. 1) then + + call sys_get_lun(lun) + if (sp .ge. maxlev .or. lun .lt. 0) then + write(isyswr,*) 'To many @ nested' + if (lun .ge. 0) call sys_free_lun(lun) + else + call sys_open(lun, cmdline(2:linlen), 'r', iostat) ! readonly + if (iostat .ne. 0) then + write(isyswr,*) 'Can not open ',cmdline(2:linlen) + else + sp=sp+1 + st(sp)=rlun + rlun=lun + endif + endif + + else + + isysrd=rlun + call sys_getenv('FIT_ERRHANDLING', fullm) + call str_upcase(fullm, fullm) + if (fullm .ne. 'N') then + call sys_try(fit_docmd) + else + call fit_docmd + endif + isysrd=5 + if (quit) then + call gra_close !cgt + return + endif + if (autoplot) then + if (npkt .ne. 0) then + CALL fit_PLOT('s') ! cgt + endif + endif + + endif + goto 10 + +998 if (sp .le. 0) return + close(rlun) + if (sp .gt. 1) call sys_free_lun(rlun) + rlun=st(sp) + if (rlun .eq. 0) return + sp=sp-1 + goto 11 + + end + + + + subroutine fit_docmd +C -------------------- + + implicit none + include 'fit.inc' + + real rarg, rpar(maxset) + character line*8192, opt*32 + integer l,i,iarg,ll + logical done + +! functions + logical arg_check_cmd, arg_check_opt + + linlen=min(linlen,len(cmdline)-1) + cmdpos=0 + argok=.true. + + separator='=' + call arg_gen(i,cmdlen) + if (i .ne. 0) cmdline(1:i+cmdlen)=cmdline(i+1:i+cmdlen) + + if (cmdline(cmdpos:cmdpos) .eq. '=') then ! SET can be omitted + cmdpos=0 + goto 10 + endif + + do i=nplug,1,-1 + done=.false. + call sys_call_i(plug_cmds(i), done) + if (done) return + enddo + + if (arg_check_cmd('INFO',1)) then + + argok=.false. + call arg_par_sym_num(iarg, i, l) + if (iarg .eq. 0) then + iarg=-2 + i=3 + endif + if (iarg .eq. -2) then ! was number + call str_trim(fillis, fillis, l) + print '(x,a,i6,2a)','Ntot=',npkt,'; Filelist=',fillis(1:l) + call sym_list(isyswr, 1, i, ' ') + else if (iarg .eq. -1) then ! was name + call meta_show(cmdline(i+1:i+l)) + else ! was parameter name + print *,cmdline(i+1:i+l),'=',u(iarg) + endif + + elseif (arg_check_cmd('HELP',1)) then + + call arg_str(line) + call fit_help(line) + + elseif (arg_check_cmd('BARS',3)) then + + call arg_str(line(1:1)) + call fit_bars(line(1:1)) + + elseif (arg_check_cmd('CONNECT',3)) then + + call arg_str(line(1:1)) + call fit_connect(line(1:1)) + + elseif (arg_check_cmd('STYLE',3)) then + + call fit_style(0,0) + + elseif (arg_check_cmd('COLORS',3)) then + + call arg_int(iarg, 999) + call fit_colors(iarg) + if (iarg .eq. 999) then + print *,'maximum available number of colors used' + else + print *,iarg,' colors used' + endif + + elseif (arg_check_cmd('NCURVES',7)) then + + call arg_int(iarg, 0) + call fit_ncurves(iarg) + + elseif (arg_check_cmd('LEGEND',3)) then + + call arg_str(line) + print * + call fit_legend(line) + if (line(1:1) .eq. '@') then + print '(x,2(a,f5.1))','draw legend at ',legendx, ',',legendy + elseif (legend .ge. 1) then + print *,'draw legend using ',userpar(usernp+legend) + elseif (legend .lt. 0) then + print *,'draw custom legend' + else + print *,'draw no legend' + endif + + elseif (arg_check_cmd('ERR',3)) then + + call arg_real(rarg, 0.0) + if (argok) call fit_err(rarg) + + elseif (arg_check_cmd('RESERR',5)) then + + call fit_reserr + + elseif (arg_check_cmd('EPSI',3)) then + + call arg_real(rarg, 0.0) + if (argok) call fit_epsi(rarg) + + elseif (arg_check_cmd('VTEST',4)) then + + call arg_real(rarg, 0.0) + if (argok) call fit_vtest(rarg) + + elseif (arg_check_cmd('PRI',3)) then + + call arg_int(iarg, 0) + if (argok) call fit_pri(iarg) + + elseif (arg_check_cmd('DAT',3)) then + + call arg_str(line) + call fit_dat(line) + + elseif (arg_check_cmd('RANGE',3)) then + + call arg_real(rpar(1), 0.0) + call arg_real(rpar(2), 0.0) + call arg_str(line) + call fit_range(rpar(1), rpar(2), line) + + elseif (arg_check_cmd('OPTIONS',3)) then + + call arg_str(line) + call fit_dat_options(line) + + elseif (arg_check_cmd('LINK',4)) then + + call arg_str(line) + call fit_link(line) + + elseif (arg_check_cmd('NEXT',1)) then + + call fit_dat(' ') + call fit_mon(0.) + call fit_win(0.0,0.0) + call fit_bars(' ') + call fit_fun(-1,0,0.0,0.0) + + elseif (arg_check_cmd('MERGE',3)) then + + call arg_real(rarg, 0.0) + if (argok) then + call fit_merge(rarg) + call fit_auto_mon + endif + + elseif (arg_check_cmd('SUBTRACT',3)) then + + call arg_str(line) + call fit_subtract(line) + + elseif (arg_check_cmd('ADD',3)) then + + do i=1,maxset + call arg_real(rpar(i), 1.0) + enddo + if (argok) then + call fit_add(rpar,maxset) + else + print * + 1,'Command ADD: add one or more constant(s) to the dataset(s)' + print *,'Use command LINK to link new data.' + print * + endif + + elseif (arg_check_cmd('MULTIPLY',3)) then + + do i=1,maxset + call arg_real(rpar(i), 1.0) + enddo + if (argok) call fit_multiply(rpar,maxset) + + elseif (arg_check_cmd('ABSKOR',3)) then + + call arg_real(rarg, 0.0) + call arg_real(rpar(1), 0.0) + if (argok) call fit_abskor(rarg, rpar(1)) + + elseif (arg_check_cmd('TRANS',5)) then + + call arg_lit(opt) + call arg_real(rarg, 0.0) + call fit_trans(opt, rarg) + + elseif (arg_check_cmd('PLOG',4)) then + + call arg_real(rarg, shift(1)) + call fit_plog(1, rarg) + print *,'plots with logarithmic y-axis' + + elseif (arg_check_cmd('PLIN',4)) then + + call arg_real(rarg, shift(0)) + call fit_plog(0, rarg) + print *,'plots with linear y-axis' + + elseif (arg_check_cmd('PLOT',1)) then + + call arg_lit(opt) + call str_upcase(opt,opt) + if (arg_check_opt(opt, 'AUTO', 1) .or. + 1 arg_check_opt(opt, '1', 1)) then + autoplot = .true. + call sys_setenv('FIT_AUTOPLOT', '1') + call sys_saveenv + return + elseif (arg_check_opt(opt, 'OFF', 1) .or. + 1 arg_check_opt(opt, '0', 1)) then + autoplot = .false. + call sys_setenv('FIT_AUTOPLOT', '0') + call sys_saveenv + call gra_close !cgt + return + endif + if (arg_check_opt(opt, 'YES', 1) .or. + 1 arg_check_opt(opt, 'PRINT', 1)) then + opt='Y' + else + opt=' ' + endif + if (nxmin .ge. nxmax) then + if (npkt .eq. 0) then + write(isyswr, *) 'no data loaded' + else + write(isyswr,*)'no data points present - enlarge fit window' + endif + else + if (autoplot) call gra_close + CALL fit_PLOT(opt) + endif + + elseif (arg_check_cmd('BGEDIT', 2)) then + + call arg_str(line) + call fit_bgedit(line) + + elseif (arg_check_cmd('CHOOSER',3)) then + + call cho_choose('?') + + elseif (arg_check_cmd('SCALE',2)) then + + do i=1,4 + call arg_real(rpar(i), 0.0) + enddo + if (argok) call fit_scale(rpar(1),rpar(2),rpar(3),rpar(4)) + + elseif (arg_check_cmd('RSC',3)) then + + call fit_rsc + + elseif (arg_check_cmd('TITLE',3)) then + + call arg_str(line) + CALL fit_TITLE(line) + + elseif (arg_check_cmd('MON',3)) then + + call arg_real(rarg, 0.0) + if (argok .and. nxmin .lt. nxmax) call fit_mon(rarg) + + elseif (arg_check_cmd('USEMON',3)) then + + call arg_int(iarg, 0) + if (argok) call fit_usemon(iarg) + + elseif (arg_check_cmd('FUN',3)) then + + if (nxmin .ge. nxmax) then + if (npkt .eq. 0) then + write(isyswr, *) 'no data loaded' + else + write(isyswr,*)'no data points present - enlarge fit window' + endif + else + call arg_int(iarg, -1) + if (argok) call fit_fun(iarg,0,0.0,0.0) + endif + + elseif (arg_check_cmd('AUTO',2)) then + + call fit_auto + + elseif (arg_check_cmd('NEWPEAK',3)) then + + if (nu .gt. 0) call fit_newpeak + + elseif (arg_check_cmd('LOAD',4)) then + + call arg_str(line) + if (line .eq. ' ') then + write(isyswr, '(/X,A/X,A,$)') 'Load parameter-file' + 1 , 'Filename: ' + read(isysrd, '(a)',end=999,err=999) line + endif + if (line .ne. ' ') call fit_load(line) + + elseif (arg_check_cmd('FIT',1)) then + + if (nu .le. 0) then + write(isyswr, *) 'Nothing to fit' + else + call arg_int(iarg, 0) + if (argok) call fit_fit(iarg) + endif + +c elseif (arg_check_cmd('TEST',1)) then +c +c call fit_test + + elseif (arg_check_cmd('MIN',1)) then + + if (nu .le. 0) then + write(isyswr, *) 'Nothing to fit' + else + call arg_int(iarg, 0) + if (argok) call fit_min(iarg) + endif + + elseif (arg_check_cmd('MIG',3)) then + + if (nu .le. 0) then + write(isyswr, *) 'Nothing to fit' + else + call arg_int(iarg, 0) + if (argok) call fit_mig(iarg) + endif + + elseif (arg_check_cmd('SIM',3)) then + + if (nu .le. 0) then + write(isyswr, *) 'Nothing to fit' + else + call arg_int(iarg, 0) + if (argok) call fit_sim(iarg) + endif + + elseif (arg_check_cmd('TRUERR',3)) then + + call arg_par(iarg) + call arg_real(rarg, 1.0) + if (argok) call fit_true_err(iarg,rarg) + + elseif (arg_check_cmd('COVAR',3)) then + + call fit_covar + + elseif (arg_check_cmd('SET',3)) then + + goto 10 + + elseif (arg_check_cmd('LIM',3)) then + + call arg_par(iarg) + call arg_real(rpar(1), 0.0) + call arg_real(rpar(2), 0.0) + if (argok) then + call fit_lim(iarg, rpar(1), rpar(2)) + call fit_print(1) + endif + + elseif (arg_check_cmd('FIX',3)) then + + call arg_par(iarg) + if (argok) call fit_fix(iarg) + call arg_par(iarg) + do while (argok .and. iarg .ne. 0) + call fit_fix(iarg) + call arg_par(iarg) + enddo + + elseif (arg_check_cmd('COR',3)) then + + separator='=' + call arg_par(iarg) + separator='*' + call arg_par(i) + separator='+' + call arg_real(rarg, 1.0) + call arg_real(rpar(1), 0.0) + if (argok) call fit_cor(iarg, i, rarg, rpar(1)) + + elseif (arg_check_cmd('REL',3)) then + + call arg_par(iarg) + if (argok) call fit_rel(iarg) + call arg_par(iarg) + do while (argok .and. iarg .ne. 0) + call fit_rel(iarg) + call arg_par(iarg) + enddo + + elseif (arg_check_cmd('WIN',1)) then + + call arg_real(rarg, 0.0) + call arg_real(rpar(2), 0.0) + if (argok) CALL fit_win(rarg, rpar(2)) + + elseif (arg_check_cmd('EXCLUDE', 4)) then + + do i=1,4 + call arg_real(rpar(i), 0.0) + enddo + if (argok) call fit_exclude(rpar(1),rpar(2),rpar(3),rpar(4)) + + elseif (arg_check_cmd('INCLUDE', 4)) then + + do i=1,4 + call arg_real(rpar(i), 0.0) + enddo + if (argok) call fit_include(rpar(1),rpar(2),rpar(3),rpar(4)) + + elseif (arg_check_cmd('KEEP',4)) then + + call arg_str(line(1:1)) + call fit_keep(line(1:1)) + + elseif (arg_check_cmd('FILE',4)) then + + call arg_str(line) + rarg=0 + read(line,'(f20.0)',err=11,end=11) rarg + l=index(line,',') + if (l .eq. 0) goto 11 + line=line(l+1:) +11 call fit_file(rarg, line) + + elseif (arg_check_cmd('EXPORT',3)) then + + call arg_lit(opt) + rarg=0 + read(opt,*,err=12,end=12) rarg + call arg_lit(opt) +12 call arg_str(line) + call fit_export(rarg, opt, line) + + elseif (arg_check_cmd('FCN',3)) then + + call fit_check_range + call fnctn(x,amin) + call fit_print(1) + + elseif (arg_check_cmd('LIST',1)) then + + CALL fit_LIST + + elseif (arg_check_cmd('OUT',3)) then + + if (nu .le. 0) then + write(isyswr, *) 'Nothing to save' + else + CALL fit_OUT + endif + + elseif (arg_check_cmd('WRITE',5)) then + + call fit_write(' ') + + elseif (arg_check_cmd('K',1)) then + + call fit_write(' ') + + elseif (arg_check_cmd('OPEN',4)) then + + call arg_str(line) + call fit_write(line) + + elseif (arg_check_cmd('SAVE',4)) then + + call arg_str(line) + call fit_save(line) + + elseif (arg_check_cmd('FULLMESS',4)) then ! on error write full message and exit + + call sys_setenv('FIT_ERRHANDLING', 'N') + call sys_saveenv + + elseif (arg_check_cmd('EXIT',2) .or. arg_check_cmd('BYE',3)) then + + quit=.true. + + elseif (arg_check_cmd('QUIT',2) .or. arg_check_cmd('END',3)) then + + call gra_print + stop 'quit FIT' + + else + + write(isyswr, '(/5X,3A)' ) + 1 'Unknown command: "',cmdline(1:cmdlen),'"' + + endif + + return + +999 print *,'input error' + return + + ! SET command + +10 separator='=' + call arg_par_sym_num(iarg, i, l) + if (iarg .eq. -2) iarg=i ! was parameter number + if (iarg .eq. -1) then ! was name + call arg_str(line) + argok=.false. + call arg_real(rarg, none) + if (rarg .ne. none .and. cmdline(cmdpos+1:) .eq. ' ') then + call fit_put_real(cmdline(i+1:i+l), rarg) + call meta_show(cmdline(i+1:i+l)) + else + call str_trim(line, line, ll) + call fit_put_str(cmdline(i+1:i+l), line(1:ll)) + if (cmdline(i+1:i+l) .eq. 'TITLE') then + itit=line(1:ll) + endif + call meta_show(cmdline(i+1:i+l)) + endif + return + endif + call arg_real(rpar(1), 0.0) + call arg_real(rpar(2),-1.0) + call arg_real(rpar(3), 0.0) + call arg_real(rpar(4),-1.0) + if (argok) then + call fit_set(iarg, rpar(1), rpar(2), rpar(3), rpar(4)) + call fit_print(1) + endif + end + + + + logical function arg_check_cmd(name, abbr) +! ------------------------------------------ + + implicit none + + include 'fit.inc' + + character name*(*) ! test for that name + integer abbr ! minimum characters for abbreviation + + arg_check_cmd=name(1:min(cmdlen,len(name))) .eq. cmdline(1:cmdlen) + 1 .and. cmdlen .ge. abbr + end + + + + logical function arg_check_opt(opt, name, abbr) +! ----------------------------------------------- + + implicit none + + character opt*(*) ! test option + character name*(*) ! for that name + integer abbr ! minimum characters for abbreviation + + integer l + + call str_trim(opt, opt, l) + l=min(l, len(name)) + arg_check_opt=name(1:l) .eq. opt(1:l) .and. l .ge. abbr + end + + + + subroutine arg_gen(start, length) +! --------------------------------- + + implicit none + + include 'fit.inc' + + integer start, length + + integer p,l,ispc,icom,isep + + p=cmdpos + l=linlen + + if (p .ge. l) goto 9 + do while (cmdline(p+1:p+1) .eq. ' ') + p=p+1 + if (p .ge. l) goto 9 + enddo + start=p +! find separator (one of space, comma, custom separator) + ispc=index(cmdline(p+1:l), ' ') + if (ispc .eq. 0) ispc=l+1 + icom=index(cmdline(p+1:l), ',') + if (icom .eq. 0) icom=l+1 + isep=index(cmdline(p+1:l), separator) + if (isep .eq. 0) isep=l+1 + + p=start+min(ispc,icom,isep)-1 + + length=max(1,p-start) +! skip spaces + do while (cmdline(p+1:p+1) .eq. ' ') + p=p+1 + if (p .ge. l) goto 2 + enddo +2 if (cmdline(p+1:p+1) .eq. ',' .or. + 1 cmdline(p+1:p+1) .eq. separator) p=p+1 + call str_upcase(cmdline(start+1:p),cmdline(start+1:p)) + cmdpos=p + separator=',' + return + +9 length=1 + start=p + separator=',' + end + + + subroutine arg_err(start) +! ------------------------- + + implicit none + include 'fit.inc' + integer start + + character tab*132/' '/ + + if (argok) then + print '(6x,a)',cmdline(1:linlen) + print '(5x,a,a)',tab(1:start+1),'^ syntax error' + cmdpos=linlen + argok=.false. + endif + end + + + + + subroutine arg_real(rarg, rdefault) +! ----------------------------------- + + implicit none + + include 'fit.inc' + + real rarg, rdefault + integer p,l,j + character rfmt*12 + + call arg_gen(p,l) + if (cmdline(p+1:p+l) .eq. ' ') then + rarg=rdefault + else + do j=1,nu + if (cmdline(p+1:p+l) .eq. psho(j) .or. + 1 cmdline(p+1:p+l) .eq. pnam(j)) then + rarg=u(j) + return + endif + enddo + write(rfmt, '(a,i2,a)') '(BN,F',l,'.0)' + read(cmdline(p+1:p+l), rfmt, err=91,end=91) rarg + endif + return +91 call arg_err(p) + rarg=rdefault + end + + + + subroutine arg_int(iarg, idefault) +! ---------------------------------- + + implicit none + + include 'fit.inc' + + integer iarg, idefault + + integer p,l + real r + character rfmt*12 + + call arg_gen(p,l) + if (cmdline(p+1:p+l) .eq. ' ') then + iarg=idefault + else + write(rfmt, '(a,i2,a)') '(BN,F',l,'.0)' + read(cmdline(p+1:p+l), rfmt, err=91,end=91) r + iarg=nint(r) + if (abs(r-iarg) .gt. abs(r/1e5)) goto 91 + endif + return +91 call arg_err(p) + iarg=idefault + end + + + function get_par_no(parname) +! ---------------------------- + implicit none + include 'fit.inc' + + character*(*) parname + + integer get_par_no + integer j + real r + character rfmt*12 + + do j=1,nu + if (parname .eq. psho(j) .or. + 1 parname .eq. pnam(j)) then + get_par_no = j + return + endif + enddo + write(rfmt, '(a,i2,a)') '(BN,F',len(parname),'.0)' + read(parname, rfmt, err=91,end=91) r + get_par_no=nint(r) + if (r .lt. 0 .or. abs(r-get_par_no) .gt. abs(r/1e5)) goto 91 + return + +91 get_par_no = 0 + end + + + subroutine arg_par(iarg) +! ------------------------ + + implicit none + + include 'fit.inc' + + integer iarg + + integer p,l,j + real r + character rfmt*12 + integer get_par_no + + call arg_gen(p,l) + if (cmdline(p+1:p+l) .eq. ' ') then + iarg=0 + else + iarg = get_par_no(cmdline(p+1:p+l)) + if (iarg .le. 0) then + call arg_err(p) + iarg=0 + endif + endif + return + end + + + subroutine arg_par_sym_num(iarg, p, l) +! -------------------------------------- +! +! returns: iarg = -2: p is given number +! iarg = -1: cmdline(p+1:p+l) is literal +! iarg = 0: empty argument +! iarg > 0: parameter number of given parameter name cmdline(p+1:p+l) +! + + implicit none + + include 'fit.inc' + + integer iarg, p,l + + integer j + real r + character rfmt*12 + + call arg_gen(p,l) + if (cmdline(p+1:p+l) .eq. ' ') then + iarg=0 + else + do j=1,nu + if (cmdline(p+1:p+l) .eq. psho(j) .or. + 1 cmdline(p+1:p+l) .eq. pnam(j)) then + iarg=j + return + endif + enddo + if (ni .gt. 0 .and. cmdline(p+1:p+l) .eq. 'INTEXP') then + iarg = nu + ni + return + endif + write(rfmt, '(a,i2,a)') '(BN,F',l,'.0)' + read(cmdline(p+1:p+l), rfmt, err=91,end=91) r + p=nint(r) + if (abs(r-p) .gt. abs(r/1e5)) goto 91 + iarg=-2 + endif + return +91 iarg=-1 + end + + + subroutine arg_str(str) +! ----------------------- +! +! this function does NOT step forward to the next item +! as it must be the last argument +! + implicit none + include 'fit.inc' + + character str*(*) + integer i,p + + if (cmdpos .lt. linlen) then + if (cmdline(cmdpos+1:cmdpos+1) .eq. '"' .or. + 1 cmdline(cmdpos+1:cmdpos+1) .eq. '''') then + p=cmdpos+1 + if (p .lt. linlen) then + i=index(cmdline(p+1:),cmdline(p:p)) + if (i .eq. 1) then + str=' ' + else if (i .eq. 0) then + str=cmdline(p+1:linlen) + else + str=cmdline(p+1:p+i-1) + endif + else + str=' ' + endif + else + call str_first_nonblank(cmdline(cmdpos+1:linlen),i) + if (i .eq. 0) i=1 + str=cmdline(cmdpos+i:linlen) + endif + else + str=' ' + endif + end + + + subroutine arg_lit(str) +! ----------------------- + + implicit none + include 'fit.inc' + + character str*(*) + integer l,i + + if (cmdpos .lt. linlen) then + l=index(cmdline(cmdpos+1:linlen),',') + if (l .eq. 0) then + call str_first_nonblank(cmdline(cmdpos+1:linlen),i) + if (i .eq. 0) i=1 + str=cmdline(cmdpos+i:linlen) + cmdpos=linlen + else + if (l .eq. 1) then + str=' ' + else + call str_first_nonblank(cmdline(cmdpos+1:cmdpos+l-1),i) + if (i .eq. 0) i=1 + str=cmdline(cmdpos+i:cmdpos+l-1) + endif + cmdpos=cmdpos+l + endif + else + str=' ' + endif + end + + + subroutine fit_usercmd(sub) + + include 'fit.inc' + external sub + + integer i,funno + integer sys_adr_i + + if (nplug+1 .gt. maxplug) then + print *,'too much plug-in commands' + RETURN + endif + funno=sys_adr_i(sub) + do i=1,nplug + if (plug_cmds(i) .eq. funno) RETURN + enddo + nplug=nplug+1 + plug_cmds(nplug)=funno + end diff --git a/gen/fit_connect.f b/gen/fit_connect.f new file mode 100644 index 0000000..c6fd65c --- /dev/null +++ b/gen/fit_connect.f @@ -0,0 +1,29 @@ + subroutine fit_connect(conn) +! ---------------------------- + + implicit none + include 'fit.inc' + character conc*1, conn*(*) + integer i + + 1002 FORMAT (4X,'Connect lines (Y/N, default:No): ',$) + + if (conn .eq. ' ') then + 102 WRITE (ISYSWR,1002) + READ (ISYSRD,'(a1)',ERR=102,END=999) CONC + else + conc=conn + endif + IF (conc .EQ. 'Y' .OR. conc .EQ.'y' .or. + 1 conc .eq. '1') then + do i=1,maxset + styl(i)=mod(styl(i),10)+sign(10,styl(i)) + enddo + else + do i=1,maxset + styl(i)=mod(styl(i),10) + enddo + endif + autostyle=0 +999 end + diff --git a/gen/fit_cor.f b/gen/fit_cor.f new file mode 100644 index 0000000..38ec612 --- /dev/null +++ b/gen/fit_cor.f @@ -0,0 +1,54 @@ + subroutine FIT_COR(K,K1,FAC,OFF) +C -------------------------------- + + include 'fit.inc' + + integer k,k1 + real fac, off + + integer j + + if (ififu .eq. 6) then + write(isyswr,*) 'Strange: correlation not possible' + return + endif + + if (k.gt.nu .or. k.le.0) then + write(isyswr,'(4x,a,i3)') 'Illegal parameter no.:',k + endif + if (k1.gt.nu .or. k1.le.0) then + write(isyswr,'(4x,a,i3)') 'Illegal parameter no.:',k1 + return + endif + if (k.gt.nu .or. k.le.0) return + + if (icsw(k) .lt. 0 .or. icsw(k) .gt. 0 .and. icto(k) .ne. k1) then + write (isyswr,'(4x,3a)') + 1 pnam(k),' already correlated to ',pnam(icto(k)) + return + endif + + j=k1 + do while (icsw(j) .ne. 0) + if (j .eq. k) goto 9 + j=icto(j) + enddo +9 if (j .eq. k) then + write(isyswr,*) 'recursive correlation not allowed' + return + endif + + if (lcode(k) .gt. 0) lcode(k)=-lcode(k) + icsw(k)=1 + icto(k)=k1 + cfac(k)=fac + coff(k)=off + if (off .eq. 0) then + write (isyswr,'(/4x,5a,f7.3)') + 1 'Correlation: ',pnam(k),' = ',pnam(k1),' *',fac + else + write (isyswr,'(/4x,5a,f7.3,a,g12.5)') + 1 'Correlation: ',pnam(k),' = ',pnam(k1),' *',fac,' +',off + endif + call extoin + end diff --git a/gen/fit_dat.f b/gen/fit_dat.f new file mode 100644 index 0000000..980e7b6 --- /dev/null +++ b/gen/fit_dat.f @@ -0,0 +1,718 @@ + subroutine fit_dat(filenames) + + character*(*) filenames + + integer iret, fit_dat_opt + + iret=fit_dat_opt(filenames, 0, 0.0) ! option 0: standard + end + + + subroutine fit_link(filenames) + + character*(*) filenames + + integer iret, fit_dat_opt + + iret=fit_dat_opt(filenames, 1, 0.0) ! option 1: link to existing data + end + + + subroutine fit_dat_merge(filenames, step) + + character*(*) filenames + real step + + integer iret, fit_dat_opt + + iret=fit_dat_opt(filenames, 2, step) ! option 2: merge read data + end + + + subroutine fit_open(filenames) + + character*(*) filenames + + integer iret, fit_dat_opt + + iret=fit_dat_opt(filenames, 4, 0.0) ! option 4: reads last.fit3 + end + + + subroutine fit_dat_next(filenames, flag) + + character*(*) filenames + integer flag ! input: 0: start read, 1: read next file, 2: read next range + ! output: 0: end of list reached, 1: o.k., no range, 2: o.k., next range + + + call fit_dat_next_opt(filenames, flag, 0, 0.0) + end + + + subroutine fit_dat_next_opt(filenames, flag, opt, step) + + character*(*) filenames + integer flag ! input: 0: start read, 1: read next file, 2: read next range + ! output: 0: end of list reached, 1: o.k., no range, 2: o.k., next range + integer opt ! 0: DAT, 1: LINK, 2: DAT&MERGE + real step + + integer lopt, fit_dat_opt + integer iret + integer idx/0/ + + logical silent, silent0 + common/fit_dat_com/silent + + if (flag .eq. 0) then + call dat_set_index(1) + lopt=8 ! read 1st + else if (flag .eq. 1) then + call dat_set_index(1) + lopt=16 ! read next file + else + idx=idx+1 + lopt=24 ! read again + endif + silent0=silent + iret=fit_dat_opt(filenames, lopt+opt, step) + if (iret .eq. 0 .and. flag .eq. 2) then + call dat_set_index(1) + silent=silent0 + iret=fit_dat_opt(filenames, 16+opt, step) ! read next file + endif + if (iret .eq. 0) then + flag=0 + else + call dat_next_index(flag) + endif + end + + + integer function fit_dat_opt(filenames, opt, step) +! -------------------------------------------------- + + implicit none + + include 'fit.inc' + + character filenames*(*) + integer opt + real step + + integer n_mul + parameter (n_mul=256) + character filelist*(maxflen), sample*80 + integer i,j,l,ll,nread,n1 + integer merge, list_mode + integer fidx, sets/0/ + logical init, init_dat/.true./, purged + integer nmax, ncol, nset0 + external fit_putval, fit_fit3_read + real stp, t1, dt1, w1, tmean, wmean, ds, upar + + logical silent + common/fit_dat_com/silent + data silent/.false./ + +! setup different flags + init=mod(opt,2) .eq. 0 ! bit0=0: purge old data + merge=mod(opt,4)/2 ! bit1=1: merge data ? + if (merge .ne. 0) stp=step ! step for merge + load_state=mod(opt,8)/4 ! bit2: do a load for FitSave files + list_mode=mod(opt,32)/8 ! bit3+4: 1: read first file, 2: read next file (ignore filenames argument), 3: read again + + fit_dat_opt=1 + if (list_mode .gt. 0) then + if (list_mode .ne. 3) then + call dat_init_list + if (list_mode .eq. 1) then + call dat_filelist(filenames) + endif + endif + goto 15 + endif + fidx=1 +11 if (filenames(fidx:fidx) .eq. '+') then + fidx=fidx+1 + if (load_state .eq. 0) init=.false. + goto 11 + elseif (filenames(fidx:fidx) .eq. '&') then + fidx=fidx+1 + merge=1 + goto 11 + endif + + if (init_dat) then + call dat_init + call dat_fit3_replace(fit_fit3_read) + init_dat=.false. + endif + if (filenames(fidx:) .eq. ' ') then + if (load_state .eq. 1) then + call dat_ask_filelist(filelist + 1 , 'Hit to continue with last data') + else + call dat_ask_filelist(filelist, ' ') + endif + if (filelist .eq. ' ') then + if (load_state .eq. 1) then + filelist='last.fit3' + else + fit_dat_opt=0 + goto 91 + endif + endif + fidx=1 +12 if (filelist(fidx:fidx) .eq. '+') then + fidx=fidx+1 + if (load_state .eq. 0) init=.false. + goto 12 + elseif (filelist(fidx:fidx) .eq. '&') then + fidx=fidx+1 + merge=1 + goto 12 + endif + call str_trim(filelist,filelist(fidx:),ll) + else + call str_trim(filelist,filenames(fidx:),ll) + endif + + + if (init) then + sets=0 + call dat_init_list + else + call dat_put_filelist(fillis) + endif + + call dat_filelist(filelist(1:ll)) + filesave=filelist(1:ll) + +15 if (init) then + npkt=0 + call sym_purge(1) + temp=0 + dtemp=0 + wtemp=0 + endif + + purged=.false. + n1=npkt+1 +30 if (silent) call dat_silent + call fit_dat_init_table + call fit_ncurves(0) + if (list_mode .ne. 3) then + call dat_read_next(fit_putval, maxdat-npkt, nread + 1 , xval(npkt+1), YVAL(npkt+1), sig(npkt+1), rmon(npkt+1)) + else + call dat_read_again(fit_putval, maxdat-npkt, nread + 1 , xval(npkt+1), YVAL(npkt+1), sig(npkt+1), rmon(npkt+1)) + endif + if (nread .gt. 0) then + if (npkt .ne. 0) then + if (ymon0 .ne. ymon) then + if (ymon .eq. 0) then + ymon=ymon0 + elseif (ymon0 .eq. 0) then + if (ymon .ne. 0) then + do i=npkt+1,npkt+nread + rmon(i)=ymon + enddo + endif + else + do i=npkt+1,npkt+nread + YVAL(i)=YVAL(i)*ymon/ymon0 + sig(i)=sig(i)*ymon/ymon0 + enddo + endif + endif + else + nset=0 + ymon=ymon0 + endif + + w1=0 + j=1 + nset0=nset + nmax=npkt+nread + do while (npkt .lt. nmax) + ncol=cols(j) + do i=0,min(nmax-npkt,rows(j)*ncol-1) + if (npkt .lt. nmax) then + npkt=npkt+1 + iset(npkt)=nset+mod(i,ncol)+1 + w1=w1+rmon(npkt) ! weight for temperature stddev + endif + enddo + nset=nset+ncol + j=min(nmult,j+1) + enddo + t1=0 + dt1=0 + call sym_get_real('Temp', t1) + if (t1 .eq. 0) then + call sym_get_real('sTemp', t1) ! this is for old DMC/HRPT files + endif + call sym_get_real('dTemp', dt1) + + if (t1 .ne. 0 .and. w1 .ne. 0) then ! calculate merged temperature stddev + wmean=wtemp+w1 + tmean=(temp*wtemp+t1*w1)/wmean + dtemp=sqrt((wtemp*(dtemp**2+(temp-tmean)**2) + 1 + w1*( dt1**2+ (t1-tmean)**2))/wmean ) + temp=tmean + wtemp=wmean + endif + + if (nset .gt. maxset) goto 31 + + do i=1,npd + upar=none + call sym_get_real(userpar(usernp+i), upar) + if (upar .eq. none) then + if (pdpar(i, nset) .eq. none .and. + 1 userpar(usernp+i) .ne. 'Numor' .and. + 1 userpar(usernp+i) .ne. 'Temp') then + print *,'parameter ',userpar(usernp+i),' not found' + pdpar(i, nset)=0.0 + endif + else + if (userpar(usernp+i) .eq. 'Numor') then + if (nset0+1 .eq. nset) then + ds=0.0 + call sym_get_real('Pal', ds) + else + ds=0.1 + endif + do j=nset0+1,nset + pdpar(i, j)=upar+ds + ds=ds+0.1 + enddo + else + do j=nset0+1,nset + pdpar(i, j)=upar + enddo + endif + endif + enddo + +31 continue + ISW(1) = 0 + ISW(2) = 0 + ISW(3) = 0 + NFCN = 1 + SIGMA = 0. + + if (ififu .eq. 0) ififu=8 ! set to plot only mode +c print '(x,a,i7)','Npkt=',nread + call sym_show(1) + call meta_put('Npkt', float(nread)) + call meta_set_format('Npkt', 5003) + call meta_set_format('Numor', 5003) + call meta_set_format('Counts', 5003) + if (.not. silent) call sym_list(isyswr,2,1,' ') + sets=sets+1 + if (merge .ne. 0 .and. sets .gt. 1) then + if (npkt .gt. n1 .and. + 1 (npkt .gt. maxdat/2 .or. nset .ge. maxset)) then ! probably not enough space -> merge + nxmin=n1 + nxmax=npkt + call fit_merge(stp) + merge=1 + else + merge=2 + endif + endif + + if (keepregion) then + if (npkt .gt. n1 .and. npkt .gt. maxdat/2) then ! probably not enough space -> purge + call fit_restore_region(.true.) + purged=.true. + endif + endif + + if (list_mode .eq. 0) then + if (npkt .lt. maxdat) goto 30 + print *,'no more datapoints accepted' + endif + else if (list_mode .ne. 0) then + fit_dat_opt=0 + endif + + if (merge .eq. 2 .and. npkt .ge. n1) then ! merge (if not yet done) + nxmin=n1 + nxmax=npkt + call fit_merge(stp) + endif + if (keepregion) then + call fit_restore_region(purged) + if (purged) then + print *,'points outside window/region were purged' + endif + else + call fit_win(1.0,1.0) ! disable window + endif + + if (load_state .gt. 1) then + if (load_state .eq. 3) then ! for FitSave 3.2 and older + call dat_init_list + call dat_filelist(filnam) + load_state=0 + goto 30 + endif + else + call dat_get_filelist(fillis) + call str_trim(fillis, fillis, l) + if (.not. silent) then + print * + if (list_mode .eq. 0) then + if (fillis(1:l) .eq. ' ') then + print *,'no file read' + else + print *,'Files read: ',fillis(1:l) + endif + endif + endif + + wavlen=0 + call sym_get_real('lambda', wavlen) + call sym_get_str('Title', ll, itit) + sample=' ' + call sym_get_str('sample', l, sample) + if (sample(1:l) .ne. ' ' + 1 .and. index(itit(1:ll),sample(1:l)) .eq. 0) then + if (ll+l .lt. len(itit)) then + if (ll+l+7 .lt. len(itit)) then + itit(ll+1:)=' Sample=' + ll=ll+8 + else + ll=ll+1 + endif + itit(ll+1:)=sample + endif + endif + + call sym_show(1) + call sym_put_real('Temp', temp) + call sym_put_real('dTemp', dtemp) + call sym_put_real('Monitor', ymon) + + if (npkt .gt. 0) call fit_set(0,0.0,0.0,0.0,0.0) + endif +91 silent=.false. + end + + + subroutine fit_dat_silent + + logical silent + common/fit_dat_com/silent + + silent=.true. + end + + + subroutine fit_datraw +! --------------------- + print *,'Subroutine FIT_DATRAW no longer available' + end + + + subroutine fit_spec +! ------------------- + print *,'Subroutine FIT_SPEC is no longer available' + END + + + + subroutine fit_dat_put(mode, xx, nx, yy, ny, ss, ns, ww, nw) !! +!! ------------------------------------------------------------ + +! preconditions: (ny>0) and (nx=ny or nx=1 or nx=2) and (ns=ny or ns=1) and (nw=ny or nw=1) +! nx=1: x-values are xx(1),xx(1)+1,xx(1)+2,...,xx(1)+(nx-1) +! nx=2: x-values are xx(1),xx(2),...,xx(1)+(xx(2)-xx(1))*(nx-1) +! ns=1: ss(1) <> 0.0: sigma values are ss(1) +! ss(1) = 0.0: sigma values are sqrt(max(1.0,yy(i))) +! nw=1: weights are ww(1) + + include 'fit.inc' + + integer mode !! mode=0: purge before, mode=1: link new dataset, mode=2: link to existing dataset + integer nx, ny, ns, nw !! + real xx(nx), yy(ny), ss(ns), ww(nw) !! + + integer i,j,nread + real x0,xs + + if (mode .eq. 0) then + npkt=0 + call sym_purge(1) + endif + + if (ny .lt. 0) stop 'FIT_DAT_INT: illegal ny' + + nread=ny + if (npkt+ny .gt. maxdat) then + print *,'Too many datapoints: truncated' + nread=maxdat-npkt + endif + + j=npkt + do i=1,nread + j=j+1 + YVAL(j)=yy(i) + enddo + + j=npkt + if (nx .eq. ny) then + do i=1,nread + j=j+1 + xval(j)=xx(i) + enddo + else + x0=xx(1) + if (nx .eq. 1) then + xs=1 + elseif (nx .eq. 2) then + xs=(xval(nx)-x0)/(nx-1) + else + stop 'FIT_DAT_INT: illegal nx' + endif + x0=x0-xs + do i=nx+1,nread + j=j+1 + xval(j)=x0+xs*i + enddo + endif + + j=npkt + if (ns .eq. ny) then + do i=1,nread + j=j+1 + sig(j)=ss(i) + enddo + elseif (ns .eq. 1) then + xs=ss(1) + if (xs .eq. 0.0) then + do i=1,nread + j=j+1 + sig(j)=sqrt(max(1.0,YVAL(j))) + enddo + else + do i=1,nread + j=j+1 + sig(j)=xs + enddo + endif + else + stop 'FIT_DAT_INT: illegal ns' + endif + + j=npkt + if (nw .eq. ny) then + ymon0=ww(1) + do i=1,nread + j=j+1 + rmon(j)=ww(i) + enddo + elseif (nw .eq. 1) then + ymon0=ww(1) + do i=1,nread + j=j+1 + rmon(j)=ymon0 + enddo + else + stop 'FIT_DAT_INT: illegal nw' + endif + + if (npkt .ne. 0) then + if (mode .eq. 1) nset=nset+1 + if (ymon0 .ne. ymon) then + if (ymon .eq. 0) then + ymon=ymon0 + elseif (ymon0 .eq. 0) then + if (ymon .ne. 0) then + do i=npkt+1,npkt+nread + rmon(i)=ymon + enddo + endif + else + do i=npkt+1,npkt+nread + YVAL(i)=YVAL(i)*ymon/ymon0 + sig(i)=sig(i)*ymon/ymon0 + enddo + endif + endif + else + nset=1 + ymon=ymon0 + endif + do i=npkt+1,npkt+nread + iset(i)=nset + enddo + npkt=npkt+nread + + ISW(1) = 0 + ISW(2) = 0 + ISW(3) = 0 + NFCN = 1 + SIGMA = 0. + + nxmin=1 + nxmax=npkt + end + + + subroutine fit_putval(str, val) + + character*(*) str + real val + + include 'fit.inc' + + if (str .eq. 'ShowLevel') then + call sym_show(nint(val)) + return + elseif (str .eq. 'Monitor' .or. str .eq. 'monitor') then + ymon0=val + endif + call meta_put(str, val) + end + + + subroutine fit_fit3_read(lun,forced,nread,putval,nmax,xx,yy,ss,ww) +! ------------------------------------------------------------------ + implicit none + + include 'fit.inc' + + integer lun, forced, nread, nmax + external putval + real xx(nmax), yy(nmax), ss(nmax), ww(nmax) + + character str*8 + + if (load_state .eq. 1) then + read(lun, '(a)') str + rewind lun + if (str .eq. 'FitSave') then + load_state=2 + call fit_load_nopn(lun) + nread=0 + return + endif + endif + call dat_fit3_read(lun, forced, nread, putval, nmax,xx,yy,ss,ww) + end + + + subroutine fit_dat_options(options) + + include 'fit.inc' + + character*(*) options + + character typ*16, desc*256 + integer done + integer l + + if (options .eq. '?' .or. options .eq. ' ') then + call dat_gettyp(typ) + call str_trim(typ, typ, l) + print * + done = 1 + call dat_desc_opt(done, typ(1:l)) + if (done .eq. 0) then + print '(x,2a)','No options available for filetype ',typ(1:l) + else + call dat_get_def_options(desc) + if (desc .ne. ' ') then + call str_trim(desc, desc, l) + print '(x,2a)','Actual options: ',desc(1:l) + endif + if (options .eq. ' ') then + print * + print '(x,a)','Syntax: option1=value1,option2=value2 ...' + print '(x/x,a,$)','Enter default options: ' + read(*,'(a)',end=9,err=9) desc + call dat_def_options(desc) + endif + endif + else + call dat_def_options(options) + endif +9 end + + + subroutine fit_dat_table(itbl, icols, irows) +! to be called within dat_..._read routines +! table number itbl has icols columns and irows rows + include 'fit.inc' + + integer itbl, irows, icols + integer i + + if (itbl .gt. nmult) then + do i=nmult+1,itbl + rows(i)=0 + cols(i)=1 + enddo + nmult=itbl + endif + rows(itbl)=irows + cols(itbl)=icols + end + + + subroutine fit_dat_init_table + + include 'fit.inc' + + nmult=1 + rows(1)=maxdat + cols(1)=1 + end + + + subroutine fit_dat_pdp_idx(name, ipdp) + ! to be called within dat_..._read routines + include 'fit.inc' + + character name*(*) + integer ipdp + + integer i + character unam*32, upar*32 + + call str_upcase(unam, name) + do i=1,npd + call str_upcase(upar, userpar(usernp+i)) + if (upar .eq. unam) then + ipdp=i + return + endif + enddo + if (usernp .lt. maxext) then + call fit_userpdp(name) + ipdp=npd + else + ipdp=0 + endif + end + + + subroutine fit_dat_pdp_set(ipdp, idx, value) + ! to be called within dat_..._read routines + + include 'fit.inc' + + integer ipdp, idx + real value + + if (ipdp .gt. 0 .and. ipdp .le. npd .and. + 1 idx .gt. 0 .and. nset+idx .le. maxset) then + pdpar(ipdp, nset+idx)=value + endif + end diff --git a/gen/fit_exit.f b/gen/fit_exit.f new file mode 100644 index 0000000..eaecac3 --- /dev/null +++ b/gen/fit_exit.f @@ -0,0 +1,17 @@ + SUBROUTINE FIT_EXIT +! ------------------- + + include 'fit.inc' + character ans*1 + + if (npkt .gt. 0) then + if (npkt .gt. 1000) then + write(isyswr, '(/X,A,$)') + 1 'Do you want to save current data and parameters [n]? ' + read(isysrd, '(a)',err=9,end=9) ans + if (ans .ne. 'Y' .and. ans .ne. 'y') goto 9 + endif + call fit_save('last.fit3') + endif +9 call gra_print + END diff --git a/gen/fit_export.f b/gen/fit_export.f new file mode 100644 index 0000000..b84a99f --- /dev/null +++ b/gen/fit_export.f @@ -0,0 +1,223 @@ + subroutine fit_export(steparg, typ, file) +! ----------------------------------------- + + implicit none + + include 'fit.inc' + + character typ*(*), file*(*) + real steparg + + integer ntry + parameter (ntry=30) + + character date*20, line*80, filename*256, typup*32, instr*32 + character sample*80 + real start, step, endr, q0, q1, xv, dq + real sum, suml, stp, xi, best, prec + + integer i,l,n,j,dig,k,jj,nbest,i0 + integer lun/2/ + integer iran, iostat + + if (typ .eq. ' ') then + write (isyswr,'(/X,A,$)') 'Step size (0: automatic):' + read(isysrd,'(f40.0)',err=999,end=999) step + write (isyswr,'(/X,A,$)') 'Output file type:' + read (isysrd, '(A)',err=999,end=999) typup + call str_upcase(typup, typup) + else + step=steparg + call str_upcase(typup, typ) + endif + if (typup .eq. 'D1A') then + prec=1.0e-4 + else ! DMC, HRPT, LNSP + prec=1.0e-3 + endif + call fit_merge(step) + start=xval(nxmin) + endr=xval(nxmax) + if (nxmax .le. nxmin .or. endr .eq. start) then + write(isyswr,*) 'not enough points to save' + goto 99 + endif + if (step .eq. 0) then ! find best step size + nbest=0 + best=1e30 + iran=12345 ! make random numbers reproducible + k=nxmax-nxmin +5 do n=k,2*k ! loop over possible values n + stp=(endr-start)/n ! step sizes checked between average step size and one half of average + if (k .gt. ntry*2) then ! try statistically + sum=0 + suml=ntry*0.15 + do j=1,ntry + iran=mod(iran*3125,524287) ! quick and dirty random number generator + i=mod(iran,k)+nxmin+1 + xi=(xval(i)-start)/stp + sum=sum+abs(xi-nint(xi)) + if (sum .gt. suml) then + sum=sum*ntry/j + goto 6 + endif + enddo + endif + sum=0 + suml=(nxmax-nxmin)*0.1 + do i=nxmin+1,nxmax + xi=(xval(i)-start)/stp + sum=sum+abs(xi-nint(xi)) + if (sum .gt. suml) then + sum=sum*k/(i-nxmin) + goto 6 + endif + enddo + sum=sum/suml + if (sum .lt. 1.0) then + nbest=n + goto 7 + endif +6 if (sum .lt. best) then + best=sum + nbest=n + endif + + continue + enddo + +7 continue + + if (nbest .eq. 0) stop 'error in FIT_EXPORT' + step=(endr-start)/nbest + endif + if (step .eq. 0) step=1 + + if (file .eq. ' ') then + write (isyswr,'(/X,A,$)') 'Output file name:' + read (isysrd, '(A)',err=999,end=999) filename + else + filename=file + endif + + step=nint(step/prec)*prec ! correct step for output precision + print *,'step used: ',step + + i=nxmin + n=nint((endr-start)/step)+1 + if (npkt+n .gt. maxdat) then + write(isyswr,*) 'not enough memory to save all points' + n=maxdat-npkt + endif + i=nxmin+1 + k=1 + jj=npkt+1 + if (endr .lt. 0) then + k=-1 + jj=npkt+n + endif + do j=0,n-1 + xv=start+j*step + do while (xval(i) .lt. xv .and. i .lt. nxmax) + i=i+1 + enddo +c cosmetics for x-axis rounding errors + q0=(xval(i)-xv)/(xval(i)-xval(i-1)) + dq=abs(xv*5E-7/(xval(i)-xval(i-1))) + if (q0 .lt. dq) then + q0=0 + elseif (q0 .gt. 1-dq) then + q0=1 + endif + q1=1-q0 + YVAL(jj)=YVAL(i-1)*q0+YVAL(i)*q1 + call cvt_real_str(line(2:8), i0, YVAL(jj), 7,0,0,0) + sig(jj)=sig(i-1)*q0+sig(i)*q1 + jj=jj+k + enddo + if (k .lt. 0) then + start=-xval(nxmax) + endif + endr=start+(n-1)*step + + if (typup .eq. 'DMC' .or. typup .eq. 'HRPT' + 1 .or. typup .eq. 'LNSP') then + call sys_parse(filename, l, filename, '.dat', 0) + + call sys_open(lun, filename, 'w', iostat) + if (iostat .ne. 0) then + print *,'Can not open ',filename(1:l) + return + endif + date=' ' + call sym_get_str('Date', l, date) + call sym_get_str('Instrument', jj, instr) + if (instr(1:jj) .ne. 'DMC' .and. instr(1:jj) .ne. 'HRPT') + 1 call str_trim(instr,typup,jj) + call sym_get_str('Title', k, line) + write(lun,'(3a)') instr(1:jj),', ',line(1:k) + + write (lun,'(a,f9.5,a,f8.3,a,f7.3,3a)') + 1 'lambda=',wavlen,', T=',temp,', dT=',dtemp + 1 ,', Date=''',date(1:l),'''' + + line(1:1)=' ' + call cvt_real_str(line(2:), l, ymon, 8, 0, 6, 1) + l=l+1 + + call sym_get_str('sample', j, sample) + if (sample(1:j) .ne. ' ') then + call str_trim(line + 1 , line(1:l)//', sample="'//sample(1:j)//'"', l) + endif + write(lun,'(3f8.3,a)') start, step, endr, line(1:l) + dig=1 + elseif (typup .eq. 'D1A') then + call sys_parse(filename, l, filename, '.d1a', 0) + + call sys_open(lun, filename, 'w', iostat) + if (iostat .ne. 0) then + print *,'Can not open ',filename(1:l) + return + endif + + write(lun,'(a,a68)') 'D1A5 Title: ',itit + write(lun,*) + write(lun,'(a)') itit + write(lun,44) n, temp, 0.0, ymon, 0.0 +44 format(i6,f11.3,f10.3,' 1',2f10.1) + write(lun,'(3f10.4)') start, step, endr + dig=2 + else + write(isyswr,*) 'data type ',typup, ' not yet implemented' + goto 99 + endif + + l=0 + line=' ' + do j=npkt+1,npkt+n + call cvt_real_str(line(l+2:l+8), i, YVAL(j), 7,dig-1,0,0) + l=l+8 + if (l .eq. 80) then + write(lun,'(a)') line(1:80) + l=0 + endif + enddo + if (l .gt. 0) write(lun,'(a)') line(1:l) + l=0 + do j=npkt+1,npkt+n + call cvt_real_str(line(l+2:l+8), i, sig(j), 7,dig,0,0) + l=l+8 + if (l .eq. 80) then + write(lun,'(a)') line(1:80) + l=0 + endif + enddo + if (l .gt. 0) write(lun,'(a)') line(1:l) + call str_trim(fillis, fillis, l) + write(lun, '(x,3a)') 'Filelist=''',fillis(1:l),'''' + call sym_list(lun, 0, 2 + 1,' file monitor instrument title date lambda ' + 1//'temp dtemp sample ') +99 close(lun) +999 end diff --git a/gen/fit_file.f b/gen/fit_file.f new file mode 100644 index 0000000..2bef487 --- /dev/null +++ b/gen/fit_file.f @@ -0,0 +1,579 @@ + subroutine fit_file(calstep, filename) +! -------------------------------------- + + implicit none + include 'fit.inc' + + real calstep + character filename*(*) + + real step, s, xx + character fname*132 + integer l,i,jset,j,iostat + + real xm1, xm2, a1, a2 + + real fifun, voigt ! function + + if (iscx .eq. 0) then + xm1=xval(nxmin) + xm2=xval(nxmax) + do i=nxmin,nxmax + if (xval(i) .lt. xm1) xm1=xval(i) + if (xval(i) .gt. xm2) xm2=xval(i) + enddo + a2=0.5/(nxmax+2-nxmin) + a1=1+a2 + xbeg=xm1*a1-xm2*a2 + xend=xm2*a1-xm1*a2 + endif + + step=(xend-xbeg)/200.0 + + if (filename .eq. ' ') then + + write (isyswr,'(/X,A,$)') 'Output file name:' + read (isysrd, '(A)', end=999,err=999) fname + if (fname .eq. ' ') fname='out' + + if (nu .gt. 0) then + write (isyswr,'(/X,A,F10.3,A,$)') + 1 'X-Step for calculated data (',abs(step),'):' + read (isysrd, '(F20.0)', err=999,end=999) s + if (s .ne. 0) step=sign(s,step) + endif + + else + + fname=filename + if (calstep .ne. 0) then + step=sign(calstep,step) + endif + + endif + + call save_delimiter(char(9)) + do jset=1,nset + if (nu .eq. 0 .and. nset .le. 1) then ! no calculation, single dataset + call sys_parse(fname, l, fname, '.obs', 0) + else + call sys_parse(fname, l, '.obs', fname, 0) + if (nset .gt. 1 .and. l .lt. len(fname)) then + call cvt_real_str(fname(l+1:), j, float(jset), 0,0,6,3) + l=l+j + endif + endif + call sys_open(2, fname, 'w', iostat) + if (iostat .ne. 0) then + print *,'Cannot open ',fname(1:l) + return + endif + + write(isyswr, '(/x,2a)') 'Observed data: ', fname(1:l) + + do i=nxmin,nxmax + if (iset(i) .eq. jset) then + call save_fill(xval(i)) + call save_fill(YVAL(i)) + call save_fill(sig(i)) + call save_wrt(2) + endif + enddo + close(2) + enddo + + if (nu .le. 0) return + + call sys_parse(fname, l, '.cal', fname, 0) + + call sys_open(2, fname, 'w', iostat) + if (iostat .ne. 0) then + print *,'Can not open ',fname(1:l) + return + endif + + write(isyswr, '(x,2a)') 'Calculated data: ', fname(1:l) + + xx=xbeg + do while (xx .le. xend+step*1e-3) + call save_fill(xx) + actset=1 + call save_fill(fifun(xx)) + if (ififu .eq. 1) then + call save_fill(u(1)+u(2)*(xx-u(3))) ! Background + do i=3,nu,5 + call save_fill(u(1)+u(2)*(xx-u(3)) ! Peaks + 1 +voigt(xx-u(i), u(i+3), u(i+4))*u(i+2)) + enddo + elseif (ififu .eq. 7 .and. nset .gt. 1) then + do actset=2,nset + call save_fill(fifun(xx)) + enddo + endif + call save_wrt(2) + xx=xx+step + enddo + close(2) + return +999 print *,'input error' + end + + + + subroutine fit_save(filename) +! ----------------------------- + + implicit none + include 'fit.inc' + character filename*(*) + integer lunit + + character fname*132/' '/, line*132, filtyp*8 + character utit*16, parname*16 + + integer i,l,j,nx1,nx2,ispec,lun,iostat,nu_user + real sbuf(32) + + integer fit_userini + external fit_userini + external fit_wrapper + + call save_delimiter(',') + if (fname .le. ' ') then + fname='last.fit3' + endif + if (filename .ne. ' ') then + line=filename + else + call sys_parse(fname, l, fname, '.FIT3', 0) + write(isyswr, '(/X,3A,$)') 'Filename [',fname(1:l),']: ' + read(isysrd, '(a)', end=999,err=999) line + endif + + call sys_parse(line, l, line, fname, 0) + + lun=2 + call sys_parse(line, l, line, ' ', 0) + call sys_open(lun, line, 'w', iostat) + if (iostat .ne. 0) then + print *,'can not open ',line(1:l) + return + endif + write(isyswr, '(/1x,2a)') 'Save parameters and data on ' + 1 ,line(1:l) + + write(2,'(A)') 'FitSave 3.8' + call save_fill(float(nu)) + call save_fill(float(ififu)) + call dat_gettyp(filtyp) + call save_str(filtyp) + call save_fill(float(nxmin)) + call save_fill(float(nxmax)) + if (iscx .eq. 0) then + xbeg=1 + xend=1 + endif + if (iscy .eq. 0) then + ybeg=1 + yend=1 + endif + call save_fill(xbeg) + call save_fill(xend) + call save_fill(ybeg) + call save_fill(yend) + if (nu .gt. 0) then + call save_fill(amin) + else + call save_fill(0.0) + endif + call save_wrt(lun) + do i=1,nu + if (psho(i) .ne. ' ') then + call str_trim(psho(i),psho(i),l) + call save_str(psho(i)(1:l)//':'//pnam(i)) + else + call save_str(pnam(i)) + endif + call save_fill(u(i)) + call save_fill(werr(i)) + call save_fill(alim(i)) + call save_fill(blim(i)) + call save_fill(float(lcode(i))) + call save_fill(cfac(i)) + call save_fill(coff(i)) + call save_fill(float(icsw(i))) + call save_fill(float(icto(i))) + call save_fill(werrs(i)) + call save_wrt(lun) + enddo + if (ififu .eq. 7) then + write(lun,'(a)') usertit + endif + + call sym_put_real('Monitor', ymon) + call sym_list(lun, 0, 3, ' ') + do i=1,min(nstyl,32) + sbuf(i)=styl(i) + enddo + call save_array('Style', sbuf, nstyl) + call save_wrt(lun) + if (keepregion) then + call save_array('RegX1', regx1, nregion) + call save_wrt(lun) + call save_array('RegX2', regx2, nregion) + call save_wrt(lun) + call save_array('RegY1', regy1, nregion) + call save_wrt(lun) + call save_array('RegY2', regy2, nregion) + call save_wrt(lun) + endif + call str_trim(fillis, fillis, l) + write(lun,'(3a)') 'Filelist=''',fillis(1:l),'''' + write(lun,*) + do i=1,npkt + call save_fill(xval(i)) + call save_fill(YVAL(i)) + call save_fill(sig(i)) + call save_fill(rmon(i)) + call save_fill(float(iset(i))) + call save_wrt(lun) + enddo + close(lun) + return + +999 print *,'input error' + return + + entry fit_load_nopn(lunit) +! -------------------------- + + lun=lunit + rewind lun + inquire(lun, name=line) + call sys_parse(line, l, line, '.', 0) + goto 20 + + + entry fit_load(filename) +! ------------------------ + + call sys_parse(line, l, filename, '.FIT3', 0) + + lun=2 + call sys_open(lun, line(1:l), 'r', iostat) + if (iostat .ne. 0) goto 29 + +20 write(isyswr, '(/x,2a)') 'Load parameters and data from ' + 1 ,line(1:l) + + line=' ' + read(lun, '(A)',err=23,end=23) line +23 if (line(1:8) .ne. 'FitSave ') then + write(isyswr,*) 'Unknown file format' + close(lun) + return + endif + call sym_purge(1) + line(1:1)=' ' + if (line(9:11) .gt. '1.0' .and. line(9:11) .lt. '3.4') then + read(lun, '(A)',err=23,end=23) filnam + endif + nu=0 + ififu=0 + xbeg=1 + xend=1 + ybeg=1 + yend=1 + filtyp=' ' + if (line(9:11) .lt. '3.2') then + read(lun, *, err=23,end=23) nu,ififu,ispec,nx1,nx2 + 1,xbeg,xend,ybeg,yend + if (ispec .eq. 1) then + filtyp='IN3' + elseif (ispec .ne. 0) then + filtyp='LNS' + endif + else + read(lun, *, err=23,end=23) nu,ififu,filtyp,nx1,nx2 + 1 ,xbeg,xend,ybeg,yend + endif + if (filtyp .ne. ' ') call dat_settyp(filtyp) + + if (line(9:11) .lt. '3.0') then + ififu=ififu-1 + if (ififu .le. 4 .or. ififu .eq. 9) then + write(isyswr,*) 'Incompatible version (older than 3.0)' + nu=0 + ififu=8 + close(lun) + return + endif + endif + + do i=1,nu + u(i)=0 + werr(i)=0 + alim(i)=0 + blim(i)=0 + lcode(i)=0 + cfac(i)=0 + coff(i)=0.0 + icsw(i)=0 + icto(i)=0 + werrs(i)=0 + if (line(9:11) .ge. '3.8') then + read(lun,*,err=27,end=27) parname, u(i), werr(i) + 1 , alim(i), blim(i), lcode(i), cfac(i), coff(i) + 1 , icsw(i), icto(i), werrs(i) + else + read(lun,*,err=27,end=27) parname, u(i), werr(i) + 1 , alim(i), blim(i), lcode(i), cfac(i) + 1 , icsw(i), icto(i), werrs(i) + endif + j=index(parname,':') + pnam(i)=parname(j+1:) + if (j .gt. 1) then + psho(i)=parname(1:j-1) + else + psho(i)=' ' + endif + enddo + + if (ififu .eq. 7 .and. line(9:11) .ge. '3.5') then + read(lun,'(a)',err=23,end=23) utit + if (line(9:11) .lt. '3.7') read(lun,*,err=23,end=23) + if (usernp .lt. nu .or. utit .ne. usertit) goto 25 + do i=1,nu + if (pnam(i) .ne. userpar(i)(1:8)) goto 25 + enddo + goto 26 +25 do i=nu+1,usernp + pnam(i)=' ' + enddo + do i=usernp+1,nu + userpar(i)=' ' + enddo + write(isyswr,*) + write(isyswr,*) 'Present function data file' + write(isyswr,*) '---------------------------' + write(isyswr,*) usertit,' ',utit + write(isyswr,*) + do i=1,max(nu,usernp) + write(isyswr,'(x,a,10x,a)') userpar(i)(1:8),pnam(i) + pnam(i)=userpar(i) + psho(i)=usersho(i) + enddo + nu=usernp + write(isyswr,'(/x,a/)') + 1 'User function mismatch, check Parameters for validity' +26 continue + endif + + + if (line(9:11) .lt. '3.3') then + close(lun) + if (filnam .eq. ' ') then + write(isyswr,*) 'No datafile' + else + load_state=3 + endif + else + if (line(9:11) .lt. '3.4') then + j=0 + ymon=0 + read(lun, *, err=27,end=27) j,ymon + else + call sym_read(lun, fit_wrapper) + call fit_get_real('Monitor', ymon) + keepregion=(nregion .ne. 0) + ymon0=ymon + endif + + i=0 +30 i=i+1 + if (i .gt. maxdat) then + print *,'too many data points --> truncated' + npkt=maxdat + goto 39 + endif +31 read(lun,'(a)',err=27,end=39) line + j=index(line,'/') ! for compatibility with versions 3.3 and older + if (j .gt. 0) line(j:)=' ' ! " +! read(line,'(bn,4f20.0,i20)',err=37,end=37) +! 1 xval(i),YVAL(i),sig(i),rmon(i),j + read(line,*,err=37,end=37) xval(i),YVAL(i),sig(i),rmon(i),j + iset(i)=max(1,j) + npkt=i + goto 30 + +37 print *,'error at point ',i + goto 31 + +39 if (ymon .eq. 0) ymon=rmon(1) + close(lun) + + endif + wavlen=0 + call sym_get_real('lambda', wavlen) + temp=0 + call sym_get_real('Temp', temp) + dtemp=0 + call sym_get_real('dTemp', dtemp) + call sym_get_str('Title', l, itit) + if (nx1 .lt. npkt .and. nx2 .le. npkt .and. nx2 .gt. nx1) then + nxmin=nx1 + nxmax=nx2 + else + nxmin=1 + nxmax=npkt + endif + nset=0 + do i=nxmin,nxmax + nset=max(iset(i),nset) + enddo + if (ififu .eq. 7) then + nu_user=fit_userini(7) + endif + nfcn=0 + call sym_list(isyswr, 1, 1, ' ') + if (load_state .eq. 3) return + call fit_set(0,0.0,0.0,0.0,0.0) + call fit_print(1) + call fit_scale(xbeg,xend,ybeg,yend) + return + +27 write(isyswr,*) 'Error in ',filename + close(lun) + return + +29 write(isyswr, *) 'Can not open ',filename + end + + + + subroutine save_fill(val) + + implicit none + real val, values(*) + integer lun, nsize + character str*(*), delim*1 + + character line*132 + integer i,j,l/0/,ll + save line,delim,l,ll + + if (delim .eq. char(9)) then + ll=7 + else + ll=12 + endif + if (l+ll .ge. len(line)) return + call cvt_real_str(line(l+1:l+ll), j, val, 0,0,6,3) + l=l+j + line(l+1:l+1)=delim + l=l+1 + return + + entry save_str(str) + + if (l+len(str)+3 .ge. len(line)) return + line(l+1:l+1)='''' + l=l+1 + call str_trim(line(l+1:l+len(str)), str, j) + if (j .eq. 0) j=1 + l=l+j + line(l+1:l+1)='''' + l=l+1 + line(l+1:l+1)=delim + l=l+1 + return + + entry save_array(str, values, nsize) + + if (l+len(str)+1 .ge. len(line)) goto 39 + call str_trim(line(l+1:l+len(str)), str, j) + if (j .eq. 0) j=1 + l=l+j + line(l+1:l+1)='=' + l=l+1 + do i=1,min(32,nsize) + if (l+9 .ge. len(line)) goto 39 + call cvt_real_str(line(l+1:l+7), j, values(i), 0,0,6,3) + l=l+j + line(l+1:l+1)=' ' + l=l+1 + enddo + line(l:l)=delim + return +39 print *,str,' truncated' + return + + entry save_wrt(lun) + l=l-1 + write(lun, '(a)') line(1:l) + l=0 + return + + entry save_delimiter(str) + delim=str + end + + subroutine fit_wrapper(str, value, putval) + + include 'fit.inc' + + character str*(*) + real value + external putval + + integer ns/0/, nx1/0/, nx2/0/, ny1/0/, ny2/0/ + + if (str .eq. ' ') then ! reset + ns=0 + nx1=0 + nx2=0 + ny1=0 + ny2=0 + return + endif + if (str(1:min(len(str),9)) .eq. 'Filelist=') then + fillis=str(10:) + return + endif + if (str .eq. 'Style') then + if (ns .lt. maxset) then + ns=ns+1 + styl(ns)=nint(value) + endif + nstyl=ns + return + endif + if (len(str) .eq. 5 .and. str(1:min(len(str),3)) .eq. 'Reg') then + if (str .eq. 'RegX1') then + if (nx1 .lt. maxregion) then + nx1=nx1+1 + regx1(nx1)=value + endif + else if (str .eq. 'RegX2') then + if (nx2 .lt. maxregion) then + nx2=nx2+1 + regx2(nx2)=value + endif + else if (str .eq. 'RegY1') then + if (ny1 .lt. maxregion) then + ny1=ny1+1 + regy1(ny1)=value + endif + else if (str .eq. 'RegY2') then + if (ny2 .lt. maxregion) then + ny2=ny2+1 + regy2(ny2)=value + endif + else + goto 9 + endif + nregion=min(nx1,nx2,ny1,ny2) + return + endif +9 call putval(str, value) + end diff --git a/gen/fit_fit.f b/gen/fit_fit.f new file mode 100644 index 0000000..a19a8db --- /dev/null +++ b/gen/fit_fit.f @@ -0,0 +1,297 @@ + subroutine fit_min(narg) +! ------------------------ + + include 'fit.inc' + integer narg, nf + real earg + + call fit_set_inthdl + call fit_check_range + + nfcnmx=1000 + if (narg .gt. 0) nfcnmx=narg + isw(1)=0 + + NF = NFCN + CALL SIMPLEX + if (ISW(1) .lt. 1) then + NFCNMX = NFCNMX + NF - NFCN + GO TO 360 + endif + + return + + + entry fit_fit(narg) +! ------------------- + + call fit_set_inthdl + call fit_check_range + + nfcnmx=1000 + if (narg .gt. 0) nfcnmx=narg + isw(1)=0 + +360 NF = NFCN + APSI = EPSI + CALL MIGRAD + IF (ISW(2) .LE. 2 .AND. ISW(1) .NE. 1) THEN + NFCNMX = NFCNMX + NF - NFCN + NF = NFCN + CALL SIMPLEX + ENDIF + return + + + entry fit_sim(narg) +! ------------------- + + call fit_set_inthdl + call fit_check_range + + nfcnmx=1000 + if (narg .gt. 0) nfcnmx=narg + isw(1)=0 + + call simplex + return + + + entry fit_mig(narg) +! ------------------- + + call fit_set_inthdl + call fit_check_range + + nfcnmx=1000 + if (narg .gt. 0) nfcnmx=narg + isw(1)=0 + + NF = NFCN + APSI = EPSI + CALL MIGRAD + return + + + entry fit_err(earg) +! ------------------- + + if (earg .gt. 0) then + epsi=epsi*earg/up + up=earg + else + epsi=epsi/up + UP=1.0 + endif + IF (ISW(2).GE.1) CALL fit_print(1) + return + + + entry fit_pri(narg) +! ------------------- + + ISW(5) = narg + return + + + entry fit_epsi(earg) +! -------------------- + + if (earg .gt. 0) then + epsi=earg + else + epsi=0.1*up + endif + return + + + entry fit_vtest(earg) +! --------------------- + if (earg .gt. 0) then + vtest=earg + else + vtest=0.01 + endif + return + + end + + + subroutine fit_set_inthdl + + include 'fit.inc' + external fit_inthdl + + if (isyswr .ne. 0) + 1 write(isyswr,'(t40,a)') 'Press Ctrl-C to abort fit-algorithm' + + call sys_int_hdl(fit_inthdl) + end + + subroutine fit_inthdl + include 'fit.inc' + nfcnmx=0 + end + + + subroutine fit_reserr + + implicit none + + include 'fit.inc' + + integer i + + do i=1,nu + if (werr(i) .ne. 0) werr(i)=max(0.1,u(i)*0.1) + enddo + if (ififu .eq. 1) then + do i=3,nu,5 + if (werr(i+1) .ne. 0) werr(i+1)=werr(i+3)+werr(i+4) + enddo + endif + call fit_set(0,0.0,0.0,0.0,0.0) + end + + + + subroutine fit_chisq(chisq, istat) + + real chisq + integer istat + + include 'fit.inc' + + chisq=amin + istat=isw(2) + end + + + + subroutine fit_restore_wr + + include 'fit.inc' + + integer isave/0/ + + if (isave .ne. 0) then + isyswr=isave + isave=0 + endif + return + + entry fit_suspend_wr + if (isyswr .ne. 0) then + isave=isyswr + isyswr=0 + endif + end + + + subroutine fit_covar + + include 'fit.inc' + integer i,j,k + character line*130 + + if (isw(2) .lt. 3) then + print *,'covariance matrix undefined' + return + endif + do i=1,npar + do k=1,npar,16 + write(line, '(16g8.2)') (v(i,j),j=k,min(k+15,npar)) +! (100*v(i,j)/sqrt(abs(v(i,i)*v(j,j))) +! if (i .ge. k .and. i .le. k+15) then +! nam=' ' +! do l=1,nu +! if (lcorsp(l) .eq. i) then +! nam=psho(l) +! goto 9 +! endif +! enddo +!9 line((i-k)*8+1:(i-k+1)*8)=' '//nam +! endif + print *,line + enddo + if (i .gt. 26) print * + enddo + end + + + subroutine fit_true_err(ipar, fstep) + + integer ipar + real fstep + + include 'fit.inc' + + real sums0, sums, uc, start, step, step0, sl0, sl1 + real p0 + integer i,idir,j + real usave(maxext), esave(maxext), trum, trup + + external fit_restore_wr + + step0=abs(werr(ipar)) + if (step0 .eq. 0) then + print *,pnam(ipar),' is not free' + return + endif + call sys_err_hdl(fit_restore_wr) + call fit_suspend_wr + + call fit_min(0) + call fit_fix(ipar) + call fit_min(0) + do i=1,nu + usave(i)=u(i) + esave(i)=werr(i) + enddo +! uc=up*max(1.0,amin)/nfree + uc=up/nfree + sums0=amin/uc + start=u(ipar) + print *,pnam(ipar),' chi^2' + print *,start,amin + + do idir=-1,1,2 + step=step0*idir + sums=sums0 + do j=1,100 + sl0=sqrt(max(0.0,sums-sums0)) + do i=1,nu + werr(i)=esave(i) + enddo + p0=u(ipar) + call fit_set(ipar,start+step*j*fstep,0.0,0.0,-1.0) + call fit_min(0) + if (nfcnmx .eq. 0) goto 99 + sums=amin/uc + print *,u(ipar),amin,sums-sums0 + if (sums .gt. sums0+1) goto 50 + enddo +50 sl1=sqrt(max(0.0,sums-sums0)) + if (sl1 .le. sl0) then + print *,'error' + goto 99 + endif + step=p0-start+(u(ipar)-p0)*(1-sl0)/(sl1-sl0) + if (idir .lt. 0) then + trum=step + else + trup=step + endif + do i=1,nu + u(i)=usave(i) + werr(i)=esave(i) + enddo + call fit_set(0,0.0,0.0,0.0,0.0) + call fit_min(0) + enddo + +99 call fit_rel(ipar) + call fit_set(ipar, start, step0, 0.0, -1.0) + call fit_restore_wr + print *,'true error of ',pnam(ipar),':', trum, trup + end diff --git a/gen/fit_fix.f b/gen/fit_fix.f new file mode 100644 index 0000000..4b20f6c --- /dev/null +++ b/gen/fit_fix.f @@ -0,0 +1,36 @@ + subroutine FIT_FIX(k0) +C ---------------------- + + integer k0 + + include 'fit.inc' + + integer i + + i = abs(K0) + if (i .lt. 1 .or. i .gt. nu) then + write(isyswr,'(4x,a,i3)') 'Illegal parameter no.:',i + return + endif + + if (lcode(i) .le. 0) then + if (icsw(i) .eq. 0) then + write(isyswr, '(4X,2A)') pnam(i),' is already fixed' + else + write(isyswr, '(4X,3A)') + 1 pnam(i),' is correlated to ',pnam(icto(i)) + endif + return + endif + +10 lcode(i)=-lcode(i) + icsw(i)=0 + if (werr(i) .ne. 0) then + werrs(i)=werr(i) + werr(i)=0 + endif + if (isyswr .ne. 0) write (isyswr,502) pnam(i),u(i) +502 format (/4X,a,' fixed at ',f15.7) + + call extoin + end diff --git a/gen/fit_fun.f b/gen/fit_fun.f new file mode 100644 index 0000000..149c89e --- /dev/null +++ b/gen/fit_fun.f @@ -0,0 +1,470 @@ + SUBROUTINE fit_fun(funarg, nargs, parg, earg) +! -------------------------------------------- + + include 'fit.inc' + + integer funarg ! negative: ask, other values: see format 1100 at bottom + integer nargs ! functions 2,3,4,7: + ! nargs=0: ask for parameters + ! nargs>0: preset parameters and errors + ! functions 0,1: + ! nargs=0: auto parameters + ! nargs=1: preset position, auto width/intensity + ! function 5: narg unused + ! function 6: auto parameters + ! nargs=0: normal, nargs=1: multiply with with parg(1) + real parg(*) ! preset parameter + real earg(*) ! preset error + logical fixed, strange + + integer npfix,i,iexp,nsum,npuser,k,npeak + integer jfifu, nu_user, narg + real a,b,ukp,ukm,sumx,sumy,sumxx,sumxy,xr,yr,xl,yl,uk + real wk, YVALmax, wmult + + real voigt ! function + integer fit_userini + + jfifu=ififu + nu_user=0 + if (up .eq. 0.0) + 1 stop 'error in FIT_FUN: FIT_INIT must be called first' + 13 if (funarg .lt. 0) then + WRITE (ISYSWR,1100) usertit + READ (ISYSRD,1101,END=999,err=999) i + IF (i.LT.0 .OR. i.GT.8) GO TO 13 + ififu=i + narg=0 + else + ififu=funarg + narg=nargs + endif + + wmult=1.0 + if (ififu .eq. 6) then ! for strange peak use gaussian to determine start values + if (narg .eq. 1) wmult=parg(1) + narg=0 + ififu=0 + strange=.true. + else + strange=.false. + endif + + 10 NFCN=1 + ISW(1)=0 + ISW(2)=0 + ISW(3)=0 + SIGMA = 0. + NPFIX = 0 + NPAR = 0 + DO 11 I= 1, MAXEXT + if (ififu .ne. 6) then +! U(I) = 0.0 + WERRS(I) = 0. + endif + ICSW(I) = 0 + ICTO(I) = 0 + CFAC(I) = 0. + coff(I) = 0. + LCODE(I) = 0 + 11 LCORSP (I) = 0 + + IF (IFIFU.LE.1) THEN + +C . . . . . SINGLE PEAK PARAMETERS . . + + pnam(1)= 'Bg(Pos) ' + psho(1)= 'B' + pnam(2)= 'dBg/dx ' + psho(2)= 'D' + pnam(3)= 'Posi. 1' + psho(3)= 'P1' + pnam(4)= 'MaxInt 1' + psho(4)= 'M1' + pnam(5)= 'IntInt 1' + psho(5)= 'I1' + pnam(6)= 'Fwhm G 1' + psho(6)= 'G1' + pnam(7)= 'Fwhm L 1' + psho(7)= 'L1' + do i=1,7 + lcode(i) = 1 + enddo + if (ififu .eq. 0) then ! pure gaussian + lcode(7)=0 + u(7)=0 + werr(7)=0 + endif + ififu=1 + if (narg .eq. 1) then ! preselected position + u(3)=parg(1) + lcode(3)=0 ! fix pos for findauto + endif + nu=2 + call fit_findauto + nu=7 + if (narg .eq. 1) lcode(3)=1 ! release position + + elseif (ififu .eq. 6) then + +C . . . . . . STRANGE PEAK . . . . . + + PNAM(3)='Position' + psho(3)='P' + PNAM(4)='fw(Bg) ' + psho(4)='W' + NU=4 + WERR(1)=1 + LCODE(1)=1 + WERR(2)=1 + LCODE(2)=1 + WERR(3)=0 + LCODE(3)=0 + WERR(4)=0 + LCODE(4)=0 + if (u(4) .gt. 0) then + U(4)=u(6)*wmult*sqrt(max(1.0,log(2*u(4)/werr(1))/1.25)) + else + u(4)=u(6) + endif + call extoin + call fit_fit(0) + + ELSEIF (IFIFU.EQ.5) THEN + +C. . . . . CRITCAL EXPONENT PARAMETERS . . + + do i=1,7 + psho(i)=' ' + enddo + PNAM(1)= 'TC ' + PNAM(2)= 'BETA ' + PNAM(3)= 'CONST ' + PNAM(4)= 'BG ' + 201 WRITE (ISYSWR,1200) + READ(ISYSRD,1101,ERR=201,END=999) IEXP + 202 WRITE (ISYSWR,1201) + READ(ISYSRD,1107,ERR=202,END=999) U(1),WERR(1),A,B + IF (A) 212,210,212 + 210 IF (B) 212,211,212 + 211 LCODE(1) = 1 + GO TO 220 + 212 UKP = U(1)+ABS(WERR(1)) + UKM = U(1)-ABS(WERR(1)) + IF (A.GE.UKM) GOTO 213 + IF (B.LE.UKP) GOTO 213 + LCODE(1) = 4 + ALIM(1) = A + BLIM(1) = B + GOTO 220 + 213 WRITE (ISYSWR,1111) + GOTO 202 + 220 IF (WERR(1).EQ.0.) LCODE(1) = 0 + NU = 3 + U(6) = -1. + IF (IEXP.EQ.2) U(6) = 1. + IF (IEXP.EQ.4) U(6) = 1. + IF (IEXP.GE.2) PNAM(2)= 'GAMMA ' + IF (IEXP.GE.4) PNAM(2)= 'NY ' + IF (IEXP.GE.4) GOTO 230 + NU = 4 + 221 WRITE (ISYSWR,1202) + READ(ISYSRD,1107,ERR=221,END=999) U(4),WERR(4) + IF (WERR(4).NE.0.) LCODE(4) = 1 + 230 NSUM = 0 + SUMX = 0. + SUMY = 0. + SUMXX = 0. + SUMXY = 0. + DO 231 I = NXMIN,NXMAX + XR = U(6)*(XVAL(I)-U(1))/U(1) + IF (XR.LT.1E-5) GOTO 231 + YR = YVAL(I) - U(4) + IF (YR.LT.1E-10) GOTO 231 + XL = ALOG(XR) + YL = ALOG(YR) + SUMX = SUMX + XL + SUMY = SUMY + YL + SUMXX = SUMXX + XL*XL + SUMXY = SUMXY + XL*YL + NSUM = NSUM + 1 + 231 CONTINUE + IF (NSUM.GE.2) GOTO 232 + WRITE (ISYSWR,1203) + GOTO 10 + 232 U(2) = (SUMXY-SUMX*SUMY/NSUM)/(SUMXX-SUMX*SUMX/NSUM) + WERR(2) = ABS(0.1*U(2)) + LCODE(2) = 1 + U(3) = EXP(SUMY/NSUM-U(2)*SUMX/NSUM) + WERR(3) = ABS(0.1*U(3)) + LCODE(3) = 1 + u(5)=0. + IF (IEXP.GT.0) GOTO 259 + 250 NU = 7 + PNAM(4)= 'CRI.A ' + PNAM(5)= 'CRI.C ' + PNAM(6)= 'CRI.S ' + PNAM(7)= 'BG ' + U(7) = U(4) + WERR(7) = WERR(4) + LCODE(7) = LCODE(4) + U(6) = 3. + WERR(6) = 0. + LCODE(6) = 0 + LCODE(5) = 1 + LCODE(4) = 1 + NSUM = 0 + SUMX = 0. + SUMY = 0. + SUMXX = 0. + SUMXY = 0. + DO 255 I = NXMIN,NXMAX + XR = (XVAL(I)-U(1))/U(1) + IF (XR.GT.-1.E-4) GOTO 251 + YR = YVAL(I) - U(3)*((-XR)**U(2)) - U(7) + XR = -XR*U(6) + GOTO 252 + 251 IF (XR.LT.1.E-4) GOTO 255 + YR = YVAL(I) - U(7) + 252 IF (YR.LT.1E-10) GOTO 255 + XL = XR + YL = ALOG(YR) + SUMX = SUMX + XL + SUMY = SUMY + YL + SUMXX = SUMXX + XL*XL + SUMXY = SUMXY + XL*YL + NSUM = NSUM + 1 + 255 CONTINUE + IF (NSUM.GE.2) GOTO 256 + PNAM(2)= 'CR.SCAT.' + WRITE (ISYSWR,1203) PNAM(2) + GOTO 10 + 256 U(4) = (SUMXY-SUMX*SUMY/NSUM)/(SUMXX-SUMX*SUMX/NSUM) + WERR(4) = ABS(0.1*U(4)) + U(5) = EXP(SUMY/NSUM-U(4)*SUMX/NSUM) + WERR(5) = ABS(0.1*U(5)) + 259 CONTINUE + + ELSEIF (IFIFU .EQ. 8) THEN + +C . . . . . . PLOT ONLY + + nu=0 + RETURN + + ELSE ! standard input + if (ififu.eq.7) then + if (usernp .eq. 0 .or. userfun .eq. 0) then + print *,'No user function implemented' + goto 999 + endif + npuser=usernp + do k=1,npuser + pnam(k)=userpar(k) + psho(k)=usersho(k) + lcode(k)=1 + enddo + if (nu .eq. 0) nu=1 + nu_user=fit_userini(jfifu) + if (nu_user .gt. 0) npuser=nu_user + nu=0 ! nu is incremented for each check parameter below + else ! multi-voigt based functions + nu=0 + if (narg .eq. 0) then + print * + print *,' Hint: In general, it is easier to use Single', + 1 ' Gaussian' + print *,' for start and then add new peaks graphically or' + print *,' with command NEWPEAK' + endif + npeak=maxpeak + if (ififu .eq. 4) npeak=2 + npuser=2+npeak*5 + write(pnam, 291) 'Bg(Pos1)','dBg/dx ', + 1 ('Posi. ',i + 1 ,'MaxInt',i + 1 ,'IntInt',i + 1 ,'Fwhm G',i + 1 ,'Fwhm L',i, i=1,npeak) +291 format (a8/a8,999(/a6,i2)) + write(psho, 292) 'B','D', + 1 ('P',i,'M',i,'I',i,'G',i,'L',i, i=1,npeak) +292 format (a1/a1,45(/a1,i1),999(5(/a1,i2))) + do k=1,npuser + lcode(k)=1 + enddo + endif +C. . . . . . . . . . . . . . . . . . . +C. . . . . LOOP TO SET PARAMETERS . . + DO 590 K=1,npuser +521 if (nu_user .gt. 0) then + uk=u(k) + wk=0 + fixed=.true. + a=0 + b=0 + elseif (funarg .lt. 0 .or. narg .eq. 0) then + if (k .eq. 1) WRITE (ISYSWR,1102) + if (ififu .eq. 2 .and. k .gt. 2 .and. mod(k,5) .eq. 2 .or. + 1 ififu .eq. 4 .and. k .eq. 7) then ! do not ask for lorentzian HW + u(k)=0 + werr(k)=0 + lcode(k)=0 + nu=nu+1 + goto 590 + endif + if (ififu .le. 4 .and. mod(k,5) .eq. 0) then ! Int.Int. + lcode(k)=0 + nu=nu+1 + goto 590 + endif +522 WRITE (ISYSWR,1106) K,PNAM(K),': ' + READ (ISYSRD,'(4F20.0)',ERR=522,END=529) + 1 UK,WK,A,B + fixed=wk .eq. 0 + IF (UK.EQ.999.) goto 529 + else + if (k .gt. narg) goto 529 + uk=parg(k) + wk=earg(k) + fixed=wk .eq. 0.0 + a=0 + b=0 + endif +C. . . . . LIMIT CHECK . . . . . . . + IF (A .EQ. 0.0 .AND. B .EQ. 0.0) GOTO 540 + UKP = UK+ABS(WK) + UKM = UK-ABS(WK) + if (a .ge. ukm .or. b .le. ukp) then + WRITE (ISYSWR,1111) + if (funarg .lt. 0 .or. narg .eq. 0) goto 521 + a=ukm + b=ukp + endif + LCODE(K) = 4 + ALIM(K) = A + BLIM(K) = B +C. . . . . FWHM 1 EQUAL TO ZERO . . . . + 540 if (ififu .le. 4 .and. uk .eq. 0 .and. + 1 k .gt. 1 .and. mod(k,5) .eq. 1) then ! gaussian hw + if (k .eq. 5) then + if (ififu .eq. 2) then + WRITE (ISYSWR,1112) + if (funarg .lt. 0 .or. narg .eq. 0) goto 521 + uk=1 + endif + goto 570 + endif +C. . . . . FWHM CORRELATION . . . + 560 ICSW(K) = 1 + ICTO(K) = 5 + CFAC(K) = 1. + WERRS(K) = WK + UK = U(5) + WK = 0. + WRITE(ISYSWR,1110) K,PNAM(K) +C. . . . . END FWHM COR . . . . . + endif + 570 NU=NU+1 + U(K) = UK + WERR(K) = WK + if (fixed) then + lcode(k)=0 + werr(k)=0 + endif + 590 CONTINUE + goto 599 + +529 if (ififu .le. 4 .and. mod(nu,5) .ne. 2) then + nu=nu-mod(nu+2,5) + WRITE (ISYSWR, '(/X,A,/)') + 1 'Not all parameters are defined -> last peak removed' + endif + +599 continue + ENDIF + if (ififu .le. 4) then ! calculate int.intensities + ififu=1 + do k=4,nu,5 + YVALmax=voigt(0.0, u(k+2), u(k+3)) + u(k+1)=u(k)/YVALmax + if (lcode(k) .ne. 1) then ! fixed or limited Max.Int + werr(k)=0 + icsw(k+1)=-1 + icto(k+1)=k + else + werr(k+1)=werr(k)/YVALmax + lcode(k)=0 + lcode(k+1)=1 + icsw(k)=-1 + icto(k)=k+1 + endif + enddo + endif + + call extoin + call fit_check_range + + if (ififu .eq. 8) return + if (isyswr .ne. 0) WRITE (ISYSWR,2000) + 2000 FORMAT (/' First entry to FCN') + call fnctn(x, amin) + if (strange) then + strange=.false. + write(isyswr,'(/x,a/)') + 1 '--- STRANGE peak: fit one gaussian' + call fit_fit(0) + write(isyswr,'(/x,a/)') + 1 '--- STRANGE peak: calculate P and W from gaussian' + ififu=6 + goto 10 + endif + if (ififu .eq. 6) then + write(isyswr,'(/x,a/)') + 1 '--- STRANGE peak: fit background' + call fit_fit(0) + return + endif + + CALL FIT_PRINT (1) + WK=AMIN + NFCN=1 + call fnctn(x, wk) + IF (WK.EQ.AMIN) RETURN + WRITE (ISYSWR,2001) AMIN,WK + 2001 FORMAT (/' FCN is time-dependent: 1. Call F=',E16.7 + 1 /24X, '2. Call F=',E16.7) + 999 RETURN + + 1100 FORMAT( + 1/8X,'Single Gaussian = 0' + 1/8X,'Single Voigtian = 1 (Lorentzian folded with Gaussian)', + 1/8X,'Multi Gaussian = 2' + 1/8X,'Multi Voigtian = 3' + 1/8X,'Gaussian + Voigtian = 4' + 1/8X,'Crit.Exponent = 5' + 1/8X,'Strange = 6' + 1/8X,A, ' = 7 (User function)' + 1/8X,'Plot only = 8'// + 1/8X,'Select function [0] : ',$) + + 1101 FORMAT (I1) + 1102 FORMAT(/,' Parameter: Value,Error,(Lower-,Upper-Lim' + 1,'it) end = 999',/) + 1103 FORMAT (/,' Only ',I2,' variable parameters allowed',/) + 1106 FORMAT (I6,4X,A8,A,$) + 1107 FORMAT (4F10.0) + 1110 FORMAT ('+',I5,4X,A8,' = Fwhm G 1') + 1111 FORMAT (8X,'Input error: Parameter out of limits') + 1112 FORMAT (8X,'Input error: Fwhm G 1 = 0.') + 1200 FORMAT(/,' EXPONENT: BRAGG+CRIT.SCATTERING: = 0 ', + ,/, ' ORD.PARAMETER: BETA,TTC = 2 ', + ,/, ' GAMMA,TTC = 4 ', + ,/, ' NY ,T t +! m_x: transform t -> x + parameter (pn=2.0) ! step size of larger gaussian = fwhm/pn + parameter (gn=2.0) ! total width = gn*fwhm + parameter (imaxg=128) ! maximal fwhm (in steps) + integer i,j,k,m + + real ts ! t-step + real t ! transformed x + real ta, tb ! limits of t-space + + real gw ! total gaussian width (in t-space) + real wg ! total peak weight + real sum ! summing variable + integer kstp ! step for folding + integer mfold ! number of folding steps + real wd ! individual peak width + real t0 ! base for integration + real lasty ! last value for integr. + + real xa, xb ! x-range + real xs ! x-step at xbase + real q ! ratio between fwhm's of peaks for folding steps + real stp ! real step + real xd, sd ! delta peak parameters + + real x0, x1, x2, qq, td, xsi + + parameter (maxt=10000) ! maximal number of points + real y(0:maxt),yf(0:maxt) ! array before and after folding + + parameter (maxg=100) ! maximal number of points per gaussian (> gn*5) + real gs(0:maxg) ! precalculated gaussian + + save y,ta,tb,xa,xb,gw,kstp + + external sys_rfun_rriii, voigt, spline3, spline4 + real sys_rfun_rriii, voigt, spline3, spline4 + + if (mode .eq. 0) then + if (gw .eq. 0) then + fit_cfun=sys_rfun_rriii(confun,x,p,n,m_f,cinfo) + RETURN + endif + if (x .lt. xa .or. x .gt. xb) then + fit_cfun=sys_rfun_rriii(confun,x,p,n,m_f,cinfo) + ecnt=ecnt+1 + show=.true. + else + t=sys_rfun_rriii(confun,x,p,n,m_t,cinfo)/ts + t=(t-ta)/istp + i=nint(t-0.5) + if (i .le. 1) then + fit_cfun=spline3(t, y(0), y(1), y(2)) + elseif (i .ge. npy-1) then + fit_cfun=spline3(npy-t, y(npy), y(npy-1), y(npy-2)) + else + fit_cfun=spline4(t-i, y(i-1), y(i), y(i+1), y(i+2)) + endif + endif + else if (mode .gt. 0) then + show=.true. + call fit_init_delta(.false.) + if (p(1) .eq. 0.0) then + fit_cfun=sys_rfun_rriii(confun,x,p,n,m_f,cinfo) + RETURN + endif + call fit_get_xrange(xa,xb) + fit_cfun=sys_rfun_rriii(confun,x,p,n,m_i,cinfo) + call fit_init_delta(.true.) + ta=sys_rfun_rriii(confun,xa,p,n,m_t,cinfo) + tb=sys_rfun_rriii(confun,xb,p,n,m_t,cinfo) + xs=p(2) + if (xs .eq. 0) xs=p(1)/10 + if (xbase-max(p(1),xs) .lt. xa .or. + 1 xbase+max(p(1),xs) .gt. xb) then + qq=(tb-ta)/(xb-xa) + ts=abs(xs*qq) + gw=abs(p(1)*qq)/ts + else + ts=abs(sys_rfun_rriii(confun,xbase+xs,p,n,m_t,cinfo) + 1 -sys_rfun_rriii(confun,xbase-xs,p,n,m_t,cinfo)) + if (ts .eq. 0) ts=1.0 + gw=abs(sys_rfun_rriii(confun,xbase+p(1)/2,p,n,m_t,cinfo) + 1 -sys_rfun_rriii(confun,xbase-p(1)/2,p,n,m_t,cinfo))/ts + endif + ta=int((ta/ts-gn*gw)) + tb=int((tb/ts+gn*gw)+1) + npy=nint(tb-ta) + istp=max(int(gw/imaxg+1), (npy+maxt-1)/maxt) + npy=npy/istp + + t0=ta-0.5*istp + x0=sys_rfun_rriii(confun,t0*ts,p,n,m_x,cinfo) + lasty=sys_rfun_rriii(confun,x0,p,n,m_f,cinfo) + k=0 + do i=0,npy + x1=sys_rfun_rriii(confun,(t0+i*istp)*ts,p,n,m_x,cinfo) + ! simpson integral over interval (x0...x1) + xsi=(x1-x0)/istp + x2=x1-xsi/2 + sum=lasty + do j=1,istp + lasty=sys_rfun_rriii(confun,x0+j*xsi,p,n,m_f,cinfo) + sum=sum+4*sys_rfun_rriii(confun,x2+j*xsi,p,n,m_f,cinfo) + 1 +2*lasty + enddo + x0=x1 + y(i)=(sum-lasty)/6/istp + k=k+istp + enddo + call fit_get_delta(xd, sd) + do while (sd .ne. 0) + td=sys_rfun_rriii(confun,xd,p,n,m_t,cinfo)/ts + sd=sd/abs( + 1 sys_rfun_rriii(confun,(td+0.5*istp)*ts,p,n,m_x,cinfo) + 1 -sys_rfun_rriii(confun,(td-0.5*istp)*ts,p,n,m_x,cinfo) ) + if (td .ge. ta .and. td .le. tb) then + t=(td-ta)/istp + i=nint(t-0.4999) + if (i .ge. npy) i=npy-1 + y(i)=y(i)+sd*(i+1-t) + y(i+1)=y(i+1)+sd*(t-i) + endif + call fit_get_delta(xd, sd) + enddo + + if (gw .le. istp) RETURN + + mfold=max(1,nint(log(gw/pn/istp))) + sum=0 + q=max(1.1,(gw/pn/istp)**(1.0/mfold)) + qq=1/(q*q) + qq=sqrt((1-qq**mfold)/(1-qq)) ! sqrt of sum of squared widths divided by gw + wd=gw/istp/q**(mfold-1)/qq + + icnt=0 + stp=1.0 + do m=1,mfold + kstp=int(stp) + stp=stp*q + ng=min(maxg,int(gn*wd/kstp+0.9)) + icnt=icnt+(2*ng+1)*(npy+1)-(ng-1)*ng+1 + do i=0,ng + gs(i)=voigt(float(i), wd/kstp, 0.0) + enddo + do i=0,npy + wg=0 + sum=0 + k=i + do j=0,min(ng,i/kstp) + sum=sum+gs(j)*y(k) + wg=wg+gs(j) + k=k-kstp + enddo + k=i+kstp + do j=1,min(ng,(npy-i)/kstp) + sum=sum+gs(j)*y(k) + wg=wg+gs(j) + k=k+kstp + enddo + yf(i)=sum/wg + enddo + do i=ng*kstp,npy-ng*kstp + y(i)=yf(i) + enddo + wd=wd*q + enddo + else + fit_cfun=sys_rfun_rriii(confun,x,p,n,mode,cinfo) + call fit_fixit(2) + endif + end + + + subroutine fit_confun_print + + include 'fit_user.inc' + + if (show) then + print * + print '(i10,a,i9,a)' + 1 , npy*istp*2+1, ' fn. calls, fold. multiplications: ',icnt + if (ecnt .gt. 0) then + print *,ecnt,' outside range calls counted' + ecnt=0 + endif + show=.false. + endif + end + + + real function spline4(x, y1, y2, y3, y4) + +! spline interpolation. +! the result is valid for values x between 0 and 1 (x-coord of y2 and y3) + + real x, y1, y2, y3, y4 + real ss, sl, sr + + ss=y3-y2 ! median slope + sl=(y3-y1)/2 ! slope at point 2 + sr=(y4-y2)/2 ! slope at point 3 + spline4=y2+x*ss ! linear interpol. + 1 + (sl-ss)*x*(x-1)**2 ! correction for left slope + 1 - (sr-ss)*(1-x)*x**2 ! correction for right slope + end + + + real function spline3(x, y1, y2, y3) + +! spline interpolation. +! the result is valid for values x between 0 and 1 (x-coord of y1 and y2) +! or, as an extrapolation to the left of x1 + + real x, y1, y2, y3 + real sl, sr, s1 + + s1=y2-y1 + sr=(y3-y1)/2 ! interpolate slope at point 2 + sl=2*sr-s1 ! extrapolate slope at point 1 + spline3=y1+x*s1 ! linear interpol. + 1 + (sl-s1)*x*(x-1)**2 ! correction for left slope + 1 - (sr-s1)*(1-x)*x**2 ! correction for right slope + end diff --git a/gen/fit_user.inc b/gen/fit_user.inc new file mode 100644 index 0000000..828f647 --- /dev/null +++ b/gen/fit_user.inc @@ -0,0 +1,11 @@ + real xbase + integer confun ! function to convolute + logical show + integer istp ! integration over istp*2 points + integer npy ! number of points + integer icnt ! number of folding multiplications + integer ecnt ! error count + + common /fit_confun_com/confun, xbase, + 1 npy, istp, icnt, ecnt, show + diff --git a/gen/fit_win.f b/gen/fit_win.f new file mode 100644 index 0000000..6d0e13d --- /dev/null +++ b/gen/fit_win.f @@ -0,0 +1,280 @@ + SUBROUTINE fit_WIN(xb0, xe0) +C ----------------------------- + include 'fit.inc' + + real xb0, xe0 + real xb, xe, x1 + integer i,j + +C + 1000 FORMAT (/,4X,'FIT : X-START , X-END ',$) + 1001 FORMAT (2F10.0) + + if (xb0 .eq. 0.0 .and. xe0 .eq. 0.0) then + 100 WRITE(ISYSWR,1000) + READ(ISYSRD,1001,ERR=100,END=999) XB,XE + else + xb=xb0 + xe=xe0 + endif + nxmin=1 + nxmax=npkt + if (npkt .le. 0) return + + if (xb .ne. xe) then + + call fit_sort(1, npkt) + + if (xb .gt. xe) then ! exchange if not in order + x1=xb + xb=xe + xe=x1 + endif + do i=1,npkt + if (xval(i) .ge. xb) then + nxmin=i + do j=i,npkt + if (xval(j) .gt. xe) then + nxmax=max(i,j-1) + goto 11 + endif + enddo + nxmax=npkt + goto 11 + endif + enddo +11 nregion=1 + regx1(nregion)=xb + regx2(nregion)=xe + regy1(nregion)=0 + regy2(nregion)=0 + else + nregion=1 + regx1(nregion)=0 + regx2(nregion)=0 + regy1(nregion)=0 + regy2(nregion)=0 + endif + call extoin + call fit_check_range + call fnctn(x,amin) + + nset=1 + do i=nxmin,nxmax + nset=max(iset(i),nset) + enddo + + if (nxmax .lt. nxmin) then + print *,'no more datapoints present - enlarge fit window' + endif + + 999 RETURN + + END + + + + SUBROUTINE FIT_EXCLUDE(X1, X2, Y1, Y2) +! -------------------------------------- + + include 'fit.inc' + + real x1, x2, y1, y2 + + integer i + real xm1, xm2, ym1, ym2 + + xm1=min(x1,x2) + xm2=max(x1,x2) + ym1=min(y1,y2) + ym2=max(y1,y2) + if (xm1 .eq. xm2 .and. ym1 .eq. ym2) return + if (nregion .lt. maxregion) then + nregion=nregion+1 + regx1(nregion)=xm2 + regx2(nregion)=xm1 + regy1(nregion)=ym2 + regy2(nregion)=ym1 + endif + i=nxmin + do while (i .le. nxmax) + if ((xm1.le.xval(i) .and. xval(i).le.xm2 .or. xm1.eq.xm2) .and. + 1 (ym1.le.yval(i) .and. yval(i).le.ym2 .or. ym1.eq.ym2)) then + call fit_sort_exch(i, nxmax) + nxmax=nxmax-1 + else + i=i+1 + endif + enddo + if (nxmax .lt. nxmin) then + print *,'no more datapoints present - enlarge fit window' + else + call fit_sort(nxmin, nxmax) + endif + end + + + SUBROUTINE FIT_INCLUDE(X1, X2, Y1, Y2) +! -------------------------------------- + + include 'fit.inc' + + real x1, x2, y1, y2 + + integer i + real xm1, xm2, ym1, ym2 + external fit_sort_load, fit_sort_exch, fit_sort_comp + + xm1=min(x1,x2) + xm2=max(x1,x2) + ym1=min(y1,y2) + ym2=max(y1,y2) + if (nregion .lt. maxregion) then + nregion=nregion+1 + regx1(nregion)=xm1 + regx2(nregion)=xm2 + regy1(nregion)=ym1 + regy2(nregion)=ym2 + endif + i=1 + if (i .eq. nxmin) i=nxmax+1 + do while (i .le. npkt) + if ((xm1.le.xval(i) .and. xval(i).le.xm2 .or. xm1.eq.xm2) .and. + 1 (ym1.le.yval(i) .and. yval(i).le.ym2 .or. ym1.eq.ym2)) then + if (i .lt. nxmin) then + nxmin=nxmin-1 + call fit_sort_exch(i, nxmin) + else + nxmax=nxmax+1 + call fit_sort_exch(i, nxmax) + i=i+1 + endif + else + i=i+1 + endif + if (i .eq. nxmin) i=nxmax+1 + enddo + call fit_sort(nxmin, nxmax) + end + + + subroutine fit_restore_region(purge) +! +! code is not optimal (sort is called several times) +! + logical purge + + include 'fit.inc' + + integer i,j,m + + if (nregion .eq. 0) then + nxmin=1 + nxmax=npkt + else + nxmin=1 + nxmax=0 + m=nregion + if (m .ge. maxregion) then + print *,'excluded region too complex - simplified' + m=maxregion + endif + nregion=0 + do i=1,m + if (regx1(i) .gt. regx2(i) .or. regy1(i) .gt. regy2(i)) then + call fit_exclude(regx1(i), regx2(i), regy1(i), regy2(i)) + else + call fit_include(regx1(i), regx2(i), regy1(i), regy2(i)) + endif + enddo + endif + if (purge) then + if (nxmin .ne. 1) then + j=0 + do i=nxmin,nxmax + j=j+1 + xval(j)=xval(i) + yval(j)=yval(i) + sig (j)=sig (i) + rmon(j)=rmon(i) + iset(j)=iset(i) + enddo + npkt=j + nxmin=1 + nxmax=npkt + else + npkt=nxmax + endif + endif + end + + + subroutine fit_keep(keep) +! ------------------------- + + implicit none + include 'fit.inc' + character kp*1, keep*(*) + + character text*72 + integer i + + write(isyswr, *) + do i=1,nregion + if (regx1(i) .gt. regx2(i) .or. regy1(i) .gt. regy2(i)) then + text='excluded' + else + if (i .eq. 1) then + text='window' + else + text='included' + endif + endif + call fit_cvt_range(regx1(i), regx2(i), text(12:35), ' < x <') + call fit_cvt_range(regy1(i), regy2(i), text(39:72), ' < y <') + if (text .ne. 'window') write(isyswr, '(x,a)') text + enddo + if (nregion .ge. maxregion) + 1 print *,'excluded region too complex - simplified' + write(isyswr, *) + if (keep .eq. ' ') then + if (keepregion) then + kp='Y' + else + kp='N' + endif + write(isyswr,'(x,3a,$)') + 1 'Keep window/region on DAT command ([',kp,']) ? ' + READ (ISYSRD,'(a1)',ERR=999,end=999) kp + else + kp=keep + endif + if (kp .eq. 'N' .or. kp .eq. 'n' .or. kp .eq. '0') then + keepregion=.false. + elseif (kp .eq. 'Y' .or. kp .eq. 'y' .or. kp .eq. '1') then + keepregion=.true. + endif +999 end + + + + subroutine fit_cvt_range(r1, r2, text, sep) + + include 'fit.inc' + + character text*(*), sep*(*) + real r1,r2 + + integer i, l + + if (r1 .eq. r2) return + i=(len(text)-len(sep))/2 + text(i+1:i+len(sep))=sep + if (r1 .gt. r2) then + call cvt_real_str(text(1:i), l, r2, i, 0, 7, 3) + call cvt_real_str(text(i+len(sep)+1:), l, r1, 1, 0, 7, 3) + else + call cvt_real_str(text(1:i), l, r1, i, 0, 7, 3) + call cvt_real_str(text(i+len(sep)+1:), l, r2, 1, 0, 7, 3) + endif + end diff --git a/gen/fitexample.f b/gen/fitexample.f new file mode 100644 index 0000000..2f14707 --- /dev/null +++ b/gen/fitexample.f @@ -0,0 +1,69 @@ + program FIT ! change FIT to your own program name +! ----------- +! +! Simple user function example (voigtian peak). +! + implicit none + real FIT_USR_FUN + external FIT_USR_FUN ! change FIT_USR_FUN to your own function name + + character vers*32 + integer i,l +!--- +! Welcome message + + call fit_vers(vers) + call str_trim(vers, vers, l) + + print '(X)' + print '(X,2A)','Program FIT Version ',vers(1:l) + do i=1,l + vers(i:i)='-' + enddo + print '(X,2A/)','-----------------------------',vers(1:l) +!--- +! Function title and parameter names +! + call fit_userfun('EXAMPLE VOIGT', fit_usr_fun) ! function title, function + call fit_userpar('B:Bg(pos)') ! 1 background at peak pos. + call fit_userpar('D:dBg/dX') ! 2 background slope + call fit_userpar('I:Int.Int.') ! 3 integrated intensity + call fit_userpar('P:pos') ! 4 position + call fit_userpar('G:gaussFW') ! 5 gaussian fwhm + call fit_userpar('L:lorFW') ! 6 lorentzian fwhm + call fit_main + end + + + + real function fit_usr_fun(x,p,n,mode,cinfo) +! ------------------------------------------- + + implicit none + + real x ! x-value + integer n ! number of parameters + real p(n) ! parameters + integer mode ! mode + integer cinfo ! calculation information (see below) + + real voigt + external voigt + + if (mode .eq. 0) then + +! Define here your own function + + fit_usr_fun=p(1)+p(2)*(x-p(4))+p(3)*voigt(x-p(4),p(5),p(6)) + + elseif (mode .lt. 0) then + +! Use this part to do some initialisations. +! (e.g. read files, write out comments on your user function) +! This section is called by FIT_FUN (command FUN) + + print * + print *, 'Example: Single Voigtian' + + endif + end diff --git a/gen/fitlor.py b/gen/fitlor.py new file mode 100755 index 0000000..869710e --- /dev/null +++ b/gen/fitlor.py @@ -0,0 +1,118 @@ +#!/usr/bin/python +# above line tells us which program to handle this script +# +# M.Zolliker June 2081 +# +usage=''' +Usage: + +> fitlor -fit + + fit is called first, you should treat your peaks: + + fit> data 5182 get data file 5182 + fit> data [34] get peak number 34 from above datafile + fit> fun 0 as an example: select one gaussian + fit> fit you might play with parameters and reapeat + fit> k saving the data on the intermediate + k means: keep data of this peak, might also be used + in the plot window + fit> exit exit and run the conversion program + +when starting fit from fitlor, the commands 'open' and 'k' are used to +configure the outputfile for the needs of single crystal analysis + +> fitlor + + do the conversion of already existing input files + +if file names are omitted, default values are used +''' + +import sys +from math import sin, cos, radians +from subprocess import call +from collections import Mapping +from tempfile import NamedTemporaryFile + +# each entry is contained witinh curly brackets {} and +# contains the variable name and the format separated by ':' +# d n characters wide integer +# .d n characterws wide fixed point with m decimal digits + +output_format = '{n:6d}{h:4d}{k:4d}{l:4d}'\ + '{i1:10.2f}{sigi1:10.2f}'\ + '{th1:8.2f}{p1:8.2f}{chi:8.2f}{phi:8.2f}' + +# treating the arguments +if len(sys.argv) > 1 and sys.argv[1] == '-fit': + call_fit = True + sys.argv.pop(1) +else: + call_fit = False + +if len(sys.argv) > 1: + outfile = sys.argv[1] + sys.argv.pop(0) +else: + outfile = 'fitlor_out.txt' + print('output-file: %s' % outfile) + +if len(sys.argv) > 1: + datafile = sys.argv[1] + sys.argv.pop(1) +else: + datafile = 'fitlor_data.txt' + print('input-file: %s' % datafile) + +if call_fit: + with NamedTemporaryFile('w') as cmdfil: + cmdfil.write('k h,k,l,i1,p1,intexp,two_theta,chi,phi\n') + cmdfil.write('open %s\n' % datafile) + cmdfil.flush() + call(('fit', '-F', cmdfil.name)) + +tilt_geometry = False +lorentz_correction = True + +class Row(object): + def __init__(self, keys, values, fmt): + if keys is None: + raise ValueError('no keys') + for k,v in zip(keys, values): + v = float(v) + if v == int(v): + v = int(v) + setattr(self, k.lower(), v) + self.fmt = fmt + + def write(self, fil): + fil.write(self.fmt.format(**self.__dict__) + '\n') + +keys = None +rows = [] +try: + with open(datafile) as inp: + for line in inp: + values = line.split() + try: + row = Row(keys, values, output_format) + except ValueError: + keys = values + continue + rows.append(row) + row.n = len(rows) + row.th1=row.two_theta * 0.2 + if lorentz_correction: + lor_cor = sin(abs(radians(row.two_theta))) + if tilt_geometry: + lor_cor *= cos(radians(row.chi)) + row.intcor = row.i1 * lor_cor + row.sigcor = row.sigi1 * lor_cor +except IOError: + print(usage) + +with open(outfile, 'w') as out: + for row in rows: + row.write(out) + diff --git a/gen/fitv.f b/gen/fitv.f new file mode 100644 index 0000000..96cd620 --- /dev/null +++ b/gen/fitv.f @@ -0,0 +1,15 @@ + program fitv + + character str*79 + integer l + call sys_get_cmdpar(str, l) + if (str(1:1) .eq. '"' .and. l .gt. 2) then + str=str(2:l-1) + l=l-2 + endif + if (l .le. 1) then + str='FIT Version' + endif + call fit_vers(str(33:)) + print *,str + end diff --git a/gen/fvi.c b/gen/fvi.c new file mode 100644 index 0000000..152e9a3 --- /dev/null +++ b/gen/fvi.c @@ -0,0 +1,50 @@ +#include +#include + +typedef void (*Routine)(void); + +typedef struct Desc { + Routine r; + int t; +} Desc; + +static Desc list0={0,0}; +static Desc *list=&list0; +static int n=1; +static int m=0; + +static int idx(Routine r, int t) { + int i; + Desc *p; + + for (i=0; i0) { + list[i].t = t; + } + return i; + } + } + + if (n>=m) { + if (m==0) { + m=64; + } else { + m*=2; + } + p = calloc(m, sizeof(Desc)); + if (!p) return -1; + for (i=1; i ',pnam(k),' fixed' + + else + + if (werr(k) .eq. 0) then + if (werrs(k) .gt. 0) then + werr(k)=werrs(k) + else + if (ififu .eq. 1 .and. mod(k,5) .eq. 3) then + werr(k)=sqrt(werr(k+2)**2+werr(k+3)**2)/10 + endif + if (werr(k) .eq. 0) werr(k)=max(1e-5,abs(u(k))/10) + endif + endif + + npar=npar+1 + lcorsp(k)=npar + x(npar)=pintf(u(k),k) + uplus=u(k)+werr(k) + uminu=u(k)-werr(k) + dirin(npar)=(abs(pintf(uplus,k)-x(npar)) + 1 +abs(pintf(uminu,k)-x(npar)))/2 + endif + else + lcorsp(k)=0 + j=k + l=nu + do while (icsw(j) .ne. 0) ! go along correlation path + do i=1,ncor + if (icord(i) .eq. j) goto 8 ! already in ICORD + enddo + do i=l+1,nu + if (icord(i) .eq. j) goto 8 ! already in path list + enddo + icord(l)=j + l=l-1 + j=icto(j) + if (j .lt. k) goto 8 ! already tested + if (j .gt. nu) goto 8 ! illegal par. no + enddo +8 do j=l+1,nu + ncor=ncor+1 + icord(ncor)=icord(j) + enddo + endif +9 enddo + nfree=max(1,nxmax-nxmin+1-npar) + end + + + + real function pintf(pexti, i) +C ----------------------------- + include 'fit.inc' + + integer i + real pexti + + real alimi, blimi, yy + + goto (100,200,300,400) lcode(i) + +C no limits + 100 pintf = pexti + return + +C lower limit (not implemented) + 200 continue + +C upper limit (not implemented) + 300 continue + +C both limits + 400 alimi = alim(i) + blimi = blim(i) + + yy=2*(pexti-alimi)/(blimi-alimi)-1.0 + if (yy .lt. -1.0) then + yy=-1.0 + pexti=alimi + elseif (yy .gt. 1.0) then + yy=1.0 + pexti=blimi + endif + + pintf=asin(yy) + end diff --git a/gen/intprt.f b/gen/intprt.f new file mode 100644 index 0000000..083c627 --- /dev/null +++ b/gen/intprt.f @@ -0,0 +1,229 @@ + subroutine dat_intprt(text, putval, userarg) + +! +! Interprete TEXT containing name / value parameters. +! You must call DAT_DELIMITERS(SEP, ASS, QUOTE) before in order to define +! the separator symbol SEP +! the assignment symbol ASS and +! the text quote character QUOTE. +! +! DAT_INTPRT calls the subroutine PUTVAL(NAME, VALUE, USERARG) +! for each name/value pair. +! For numeric values NAME and VALUE contain name and value. +! For textual values, the argument NAME contains a concatenation +! of name '=' and the text between the quotes. In that case, VALUE +! is guaranteed to be 0.0. +! +! There may be up to 32 numeric values per name in TEXT, separated by +! blanks or commas (comma not allowed when SEP=','). +! If more then one value per name is given, PUTVAL is called several times +! +! Example: +! +! CALL DAT_DELIMITERS(';', ':=', '"') +! TEXT='first:=3.3;second:="name";third:=10,10.5,11' +! CALL DAT_INTPRT(TEXT, PUTVAL, 0) +! +! we are using ':=' as assignment symbol +! ';' as separator +! '"' as quote character +! +! DAT_INTPRT will call PUTVAL(NAME, VALUE, 0) 5 times with the following arguments: +! +! NAME VALUE +! ------------------ +! 'first' 3.3 +! 'second=name' 0.0 +! 'third' 10.0 +! 'third' 10.5 +! 'third' 11.0 +! + + character text*(*) ! text to interprete. must not be longer than 160-len(ASS) characters + external putval ! procedure to call for each name/value pair + external userarg ! user argument + +! arguments for dat_delimiters: + character sep_symbol*(*) ! separator between subsequent name/value pairs + ! must not be blank + character ass_symbol*(*) ! assignment symbol separator between name and values + ! must not be blank + character quote_char*1 ! quote character (may be blank) + + integer l,p,m,j,ln,i,k,q + + character line*160 + logical nodecpoint + + integer maxarr + parameter (maxarr=32) + real arr(maxarr) + + integer ls/0/, la/0/ + character sep*32, ass*32, quote*1 + save sep, ass, quote + + if (ls .eq. 0) + 1 stop 'DAT_INTPRT: DAT_DELIMITERS must be called first' + if (len(text)+max(la,ls) .gt. len(line)) + 1 stop 'DAT_INTPRT: text too long' + + call str_trim(line, text, l) + + line(l+1:l+1)='!' + l=index(line,'!')-1 + if (l .le. 0) RETURN + if (line(1:l) .eq. ' ') RETURN + p=0 +1 continue + line(l+1:l+la)=ass ! set stopper + + ! read blanks + if (p .lt. l) then + do while (line(p+1:p+1) .le. ' ') + p=p+1 + enddo + endif + + if (p .ge. l) RETURN + + j=p + p=p+index(line(p+1:), ass(1:la))-1 ! position of assignment char. +12 i=index(line(j+1:p+1), sep(1:ls)) + if (i .ne. 0) then + print *,'DAT_INTPRT: missing "',ass(1:la),'" : ' + 1 , line(1:j+i+ls-1) + p=j+i+ls + goto 1 + endif + if (j .eq. p) then + print *,'DAT_INTPRT: missing name: ', line + line(l+1:l+ls)=sep ! set stopper + p=j+index(line(j+1:), sep(1:ls))+ls + goto 1 + endif + m=p + do while (line(m:m) .le. ' ') + m=m-1 + enddo + if (p .ge. l) then + print *,'DAT_INTPRT: missing "',ass(1:la),'" : ', line(1:p) + RETURN + endif + p=p+la + + ! read blanks + line(l+1:l+1)=quote ! stopper + if (line(p+1:l+1) .eq. ' ') then + p=l + else + do while (line(p+1:p+1) .le. ' ') + p=p+1 + enddo + endif + + if (quote .gt. ' ' .and. line(p+1:p+1) .eq. quote) then ! --- quoted text + + p=p+1 + ln=index(line(p+1:), quote)-1 + if (ln .eq. 0) then + call putval(line(j+1:m)//'= ', 0.0, userarg) + else + call putval(line(j+1:m)//'='//line(p+1:p+ln), 0.0, userarg) + endif + p=p+ln + ln=index(line(p+1:),sep(1:ls))-1 + if (ln .lt. 0) ln=l-p + if (line(p+1:p+ln) .ne. quote) then + print *,'DAT_INTPRT: superflous characters: ',line(1:p+ln) + endif + p=p+ln+ls + + elseif (index('-.0123456789',line(p+1:p+1)) .ne. 0) then ! --- numeric + + i=0 + line(l+1:l+ls)=sep(1:ls) ! stopper + + k=p + do while (line(k+1:k+1) .eq. ' ') ! skip blanks + k=k+1 + enddo + q=p +11 continue + nodecpoint=.true. + do while (line(k+1:k+1) .ne. ' ' + 1 .and. line(k+1:k+1) .ne. ',' + 1 .and. line(k+1:k+ls) .ne. sep(1:ls)) + k=k+1 + enddo + do while (line(k+1:k+1) .eq. ' ') ! skip blanks + k=k+1 + enddo + if (line(k+1:k+1) .eq. ',' .and. + 1 line(k+1:k+ls) .ne. sep(1:ls)) then ! skip one comma + k=k+1 + do while (line(k+1:k+1) .eq. ' ') ! skip blanks + k=k+1 + enddo + endif + if (i .lt. maxarr) then + if (index(line(p+1:k), '.') .ne. 0) nodecpoint=.false. + read(line(p+1:k), *, err=103) arr(i+1) + endif + i=i+1 + if (line(k+1:k+ls) .ne. sep(1:ls)) then + p=k + goto 11 + endif + + p=k+ls + + if (nodecpoint) call meta_format(5003) ! set to integer format + if (i .eq. 1) then + call putval(line(j+1:m), arr(1), userarg) + else + ln=i + if (ln .gt. maxarr) goto 103 + do i=1,ln + call putval(line(j+1:m), arr(i), userarg) + enddo + endif + if (nodecpoint) call meta_format(0) ! reset format + + else ! --- literal + + ln=index(line(p+1:),sep(1:ls))-1 + if (ln .lt. 0) ln=l-p + i=p+ln + do while (line(i:i) .le. ' ') ! truncate trailing blanks + i=i-1 + enddo + if (i .le. p) then + call putval(line(j+1:m)//'= ', 0.0, userarg) + else + call putval(line(j+1:m)//'='//line(p+1:i), 0.0, userarg) + endif + p=p+ln+ls + + endif + goto 1 + +103 p=p+index(line(p+1:), sep(1:ls))-1 + call str_trim(line(q+1:p), line(q+1:p), ln) + call putval(line(j+1:m)//'='//line(q+1:q+ln), 0.0, userarg) + p=p+ls + goto 1 + + entry dat_delimiters(sep_symbol, ass_symbol, quote_char) + + quote=quote_char + call str_trim(sep, sep_symbol, ls) + call str_trim(ass, ass_symbol, la) + if (sep(1:ls) .le. ' ') + 1 stop 'DAT_DELIMITERS: separator must not be blank' + if (ass(1:la) .le. ' ') + 1 stop 'DAT_DELIMITERS: assignment symbol must not be blank' + if (quote .eq. sep(1:1) .or. quote .eq. ass(1:1)) then + stop 'DAT_DELIMITERS: QUOTE must be different from SEP and ASS' + endif + end diff --git a/gen/lib.fvi b/gen/lib.fvi new file mode 100644 index 0000000..23edce6 --- /dev/null +++ b/gen/lib.fvi @@ -0,0 +1,8 @@ +fvi +sys_call_c +sys_call_0 +sys_call_i +sys_call_ci +sys_call_iiieirrrr +sys_rfun_rriii +sys_rfun_r diff --git a/gen/lib.fvi2 b/gen/lib.fvi2 new file mode 100644 index 0000000..a2e54fb --- /dev/null +++ b/gen/lib.fvi2 @@ -0,0 +1,8 @@ +fvi2 +sys_call_c +sys_call_0 +sys_call_i +sys_call_ci +sys_call_iiieirrrr +sys_rfun_rriii +sys_rfun_r diff --git a/gen/main.c b/gen/main.c new file mode 100644 index 0000000..38b2473 --- /dev/null +++ b/gen/main.c @@ -0,0 +1,6 @@ +int MAIN__(int narg, char *argv[]); + +int MAIN_(int narg, char *argv[]) { + return MAIN__(narg, argv); +} + diff --git a/gen/make_custom.f b/gen/make_custom.f new file mode 100644 index 0000000..9859add --- /dev/null +++ b/gen/make_custom.f @@ -0,0 +1,51 @@ + program make_custom + +! make "customized" source files + + character line*1024, id*80 + integer l, pos, i, j, ll, iostat + + call sys_get_cmdpar(line, l) + l=l+1 + if (l .gt. len(line)) then + print *,'line too long' + goto 90 + endif + line(l:)=' ' + pos=0 + +10 i=index(line(pos+1:), ' ')-1 + if (i .lt. 0) goto 99 + if (i .eq. 0) then + pos=pos+1 + if (pos .gt. l) goto 99 + goto 10 + endif + call sys_open(1, line(pos+1:pos+i), 'r', iostat) + if (iostat .ne. 0) then + print *,'cannot open ',line(pos+1:pos+i) + goto 90 + endif + print *,'read ',line(pos+1:pos+i) + read(1,'(a)') id + if (id .eq. 'mzhelp') then + call make_help(1) + else if (id .eq. 'fvi') then + call make_fvi(1) + else if (id .eq. 'vers') then + call make_vers(1) + else + call str_trim(id, id, ll) + do j=1,ll + if (id(j:j) .lt. '0' .or. id(j:j) .gt. 'z') goto 19 + enddo + print *,line(pos+1:pos+i),' has an unknown id: ',id(1:ll) + goto 90 + ! probably a binary id: may be custom itself +19 print *,line(pos+1:pos+i),' has a strange id, skip it' + close(1) + endif + pos=pos+i+1 + goto 10 +90 stop 'error in MAKE_CUSTOM' +99 end diff --git a/gen/make_fvi.f b/gen/make_fvi.f new file mode 100644 index 0000000..b59c014 --- /dev/null +++ b/gen/make_fvi.f @@ -0,0 +1,274 @@ + subroutine make_fvi(lunin) +c +c create function variable interface (fvi) for FORTRAN +c input contains a list of subroutine/function names +c +c - first part: function type +c sys_ifun_ integer function +c sys_rfun_ real function +c sys_dfun_ double function +c sys_call_ for subroutine +c - subsequent letters: +c i integer argument +c r real argument +c d double argument +c c character(*) argument +c e external argument +c if the argument list is empty, 0 is used +c +c +c usage examples: +c +c subroutine test1(cc, rr, ii) +c character cc*(*) +c real rr +c integer ii +c ... +c end +c +c integer function test2() +c ... +c end +c +c program test +c ... +c external test1, test2 +c integer*8 cod1, cod2 +c integer sys_ifun_0 ! function +c character c8 +c real r +c integer i +c +c ... + +c call sys_funadr(test1, cod1) +c call sys_funadr(test2, cod2) +c ... +c call sys_call_cri(test1, c, r, i) +c i=sys_ifun0(test2) +c ... +c end +c + integer lunin + + character line*80, typ*8, system*16 + integer i,l,lc,lt, phase, iostat, lunout, typno + integer underscores + integer descriptor + + lunout=2 + if (lunout .eq. lunin) then + print *,'lun mismatch' + stop 'error in MAKE_FVI' + endif + call sys_check_system(system) + call sys_fortran_interface(underscores, descriptor) + call sys_open(lunout, 'sys_fvi.c', 'wo', iostat) + if (iostat .ne. 0) then + print *,'cannot write sys_fvi.c' + stop 'error in MAKE_FVI' + endif + if (system .eq. 'VMS') then + system='Alpha VMS' + elseif (system .eq. 'TRU64') then + system='Alpha Unix' + elseif (system .eq. 'GNU') then + system='GNU (g77/gcc)' + else + system = 'strange system' + endif + write(lunout,'(2a)') + 1 '/* FORTRAN function variable interface for ',system + write(lunout,'(a)') + 1 ' * this file is created by fvi and should not be modified */' + write(lunout,'(a)') + 1 '#include "fvi.c"' + typno=1964 +1 read(lunin,'(a)',end=99) line + if (line(1:1) .eq. '!') goto 1 + do i=1,len(line) + if (line(i:i) .lt. 'a') then + if (line(i:i) .le. ' ') then + l=i-1 + goto 10 + endif + if (line(i:i) .ge. 'A' .and. line(i:i) .le. 'Z') + 1 line(i:i)=char(ichar(line(i:i))+32) + endif + enddo + print *,line + stop 'too many arguments' +10 if (line(1:9) .eq. 'sys_ifun_') then + typ='int' + lt=3 + elseif (line(1:9) .eq. 'sys_rfun_') then + lt=5 + typ='float' + elseif (line(1:9) .eq. 'sys_dfun_') then + typ='double' + lt=6 + elseif (line(1:9) .eq. 'sys_call_') then + typ='void' + lt=4 + else + goto 19 + endif + call fvi_putstr(typ(1:lt+1)) + call fvi_putstr(line(1:l)) + do i=1,underscores + call fvi_putstr('_') + enddo + call fvi_putstr('(int *funno') + do phase=1,2 + lc=0 + if (line(10:l) .ne. '0') then + do i=10,l + if (i .ne. 10 .or. phase .eq. 1) then + call fvi_putstr(',') + endif + if (line(i:i) .eq. 'i') then + call fvi_putstr('int *a') + call fvi_putint(i-9) + elseif (line(i:i) .eq. 'r') then + call fvi_putstr('float *a') + call fvi_putint(i-9) + elseif (line(i:i) .eq. 'd') then + call fvi_putstr('double *a') + call fvi_putint(i-9) + elseif (line(i:i) .eq. 'c') then + if (descriptor .eq. 1) then + call fvi_putstr('void *a') ! descriptor + elseif (descriptor .eq. 0) then + call fvi_putstr('char *a') ! lengths are passed at end of argument list + lc=lc+1 + else + stop 'unknown descriptor code' + endif + call fvi_putint(i-9) + elseif (line(i:i) .eq. 'e') then + call fvi_putstr('void (*a') + call fvi_putint(i-9) + call fvi_putstr(')(void)') + else + call fvi_putstr('*** error ***') + print *,line(1:l),' unknown type: ',line(i:i) + endif + enddo + else if (phase .eq. 2) then + call fvi_putstr('void') + endif + do i=1,lc + call fvi_putstr(',int a') + call fvi_putint(i+l-9) + enddo + call fvi_putstr(')') + if (phase .eq. 1) then + call fvi_putstr(' {') + call fvi_putln(lunout) + call fvi_putstr(' typedef ') + call fvi_putstr(typ(1:lt)) + call fvi_putstr(' (*R)(') + endif + enddo + call fvi_putstr(';') + call fvi_putln(lunout) + call fvi_putstr(' int no=*funno;') + call fvi_putln(lunout) + call fvi_putstr(' if (list[no].t == ') + call fvi_putint(typno) + call fvi_putstr(') {') + call fvi_putln(lunout) + call fvi_putstr(' ') + if (typ .ne. 'void') then + call fvi_putstr('return ') + endif + call fvi_putstr('(*(R)list[no].r)(') + if (line(10:10) .ne. '0') then + call fvi_putstr('a1') + endif + do i=11,l+lc + call fvi_putstr(',') + call fvi_putstr('a') + call fvi_putint(i-9) + enddo + call fvi_putstr(');') + call fvi_putln(lunout) + call fvi_putstr(' } else {') + call fvi_putln(lunout) + call fvi_putstr(' assert(no == 0 && list[no].t == 0);') + if (typ .ne. 'void') then + call fvi_putln(lunout) + call fvi_putstr(' return 0;') + endif + call fvi_putln(lunout) + call fvi_putstr(' }') + call fvi_putln(lunout) + call fvi_putstr('}') + call fvi_putln(lunout) + call fvi_putstr('int sys_adr') + if (typ .ne. 'void') then + call fvi_putstr(line(5:5)) + endif + call fvi_putstr('_') + call fvi_putstr(line(10:l)) + do i=1,underscores + call fvi_putstr('_') + enddo + call fvi_putstr('(Routine r) {') + call fvi_putln(lunout) + call fvi_putstr(' return idx(r, ') + call fvi_putint(typno) + call fvi_putstr(');') + call fvi_putln(lunout) + call fvi_putstr('}') + call fvi_putln(lunout) + typno=typno+1 + goto 1 + +19 call fvi_putstr('*** error ***') + call fvi_putln(lunout) + print *,line(1:l),' < illegal prototype name' + goto 1 + +99 close(lunin) + close(lunout) + end + + + subroutine fvi_putstr(str) + + character str*(*) + integer n + integer lun + + character out*132/' '/,num*12 + integer l/0/,i,lunout/2/ + + if (l+len(str) .gt. len(out)-12) then ! let space for an integer number on the same line + write(lunout,'(a)') out(1:l) + l=0 + endif + out(l+1:l+len(str))=str + l=l+len(str) + return + + entry fvi_putint(n) + + write(num, '(i12)') n + do i=11,1,-1 + if (num(i:i) .eq. ' ') then + out(l+1:l+12-i)=num(i+1:12) + l=l+12-i + return + endif + enddo + stop 'FVI_PUTINT: error' + + entry fvi_putln(lun) + + if (lun .ne. lunout) stop 'MAKE_FVI: lun mismatch' + if (l .gt. 0) then + write(lunout,'(a)') out(1:l) + l=0 + endif + end diff --git a/gen/make_help.f b/gen/make_help.f new file mode 100644 index 0000000..6212c8b --- /dev/null +++ b/gen/make_help.f @@ -0,0 +1,161 @@ + subroutine out_html(lun, str) + +! lun = 0: put into buffer +! lun != 0: write buffer to lun + + integer lun + character str*(*) + integer l/0/ + save l + character*1024 line + save line + + integer ls + + if (lun .eq. 0) then + ls=len(str) + if (l .ge. len(line)) then + l=len(line)-1 + endif + if (l+ls .gt. len(line)) then + ls=1 + endif + line(l+1:l+ls)=str + l=l+ls + else + write(lun, '(a)') line(1:l) + l=0 + endif + end + + subroutine make_help(lunin) + + integer lunin + integer lunout + integer htmlout + character line*132, tab*1, upcase*64 + integer l, iostat, i, fmt, p + + tab=char(9) + lunout=2 + htmlout=3 + if (lunout .eq. lunin) then + print *,'lun mismatch' + stop 'error in MAKE_HELP' + endif + call sys_open(lunout, 'fit_help.f', 'wo', iostat) + if (iostat .ne. 0) then + print *,'cannot write fit_help.f' + stop 'error in MAKE_HELP' + endif + call sys_open(htmlout, 'fit_help.html', 'wo', iostat) + if (iostat .ne. 0) then + print *,'cannot write fit_help.html' + stop 'error in MAKE_HELP' + endif + + write(lunout,'(a,9(/,a))') + 1 '! DO NOT EDIT this subroutine.' + 1,'! It is automatically created with: make_custom fit.help' + 1,tab//'subroutine fit_help(topic)' + 1,tab//'character topic*(*), topup*64' + 1,tab//'integer l' + 1,tab//'topup(1:1)='' ''' + 1,tab//'call str_upcase(topup(2:), topic)' + 1,tab//'call str_trim(topup, topup, l)' + 1,tab//'if (topup .eq. '' '') then' + 1,tab//' print 1' + + write(htmlout, '(a)') '
FIT HELP'
+	fmt=1
+1	read(lunin, '(a)',err=99,end=99) line
+	if (line(1:1) .eq. '=') then
+	  if (fmt .ne. 1) write(lunout,'(a)') tab//'1)'
+	  do i=1,len(line)
+	    if (line(i:i) .eq. '=') line(i:i)=' '
+	  enddo
+	  call str_trim(line, line, l)
+	  call str_upcase(line(1:l), line(1:l))
+	  i=1
+          do while (i.lt.l)
+            if (line(i:l) .ne. ' ') then
+              do while (line(i:i) .eq. ' ')
+                i=i+1
+              enddo
+	      p=i
+              do while (line(i:i) .gt. ' ')
+                i=i+1
+              enddo
+	      call out_html(0, '')
+	    endif
+	  enddo
+	  call out_html(htmlout, ' ')
+	  call out_html(0, '
')
+	  call out_html(htmlout, ' ')
+	  write(lunout,'(a)') tab//'elseif (index('
+	  if (l .gt. 60) then
+	    write(lunout,'(3a/3a)')
+	1     tab//'1'' ',line(1:60),''''
+	1     ,tab//'1//''',line(61:l),''''
+	  else
+	    write(lunout,'(3a)') tab//'1'' ',line(1:l),''''
+	  endif
+	  write(lunout,'(a)') tab//'1 ,topup(1:l)) .ne. 0) then'
+	  write(lunout,'(a,i4/i4,a)')
+	1   tab//'print ',fmt,fmt,tab//'format ('
+	  fmt=fmt+1
+	else
+	  call str_trim(line, line(1:len(line)-1), l)
+	  p=0
+	  i=index(line(p+1:l+1), '"')
+	  do while (i .ne. 0)
+	    if (i .gt. 1) then
+	      call out_html(0, line(p+1:p+i-1))
+	    endif
+	    p=p+i
+	    i=index(line(p+1:l+1), '"')
+            if (i .eq. 0) then
+	      call out_html(htmlout, ' ')
+	      print *,'ERROR'
+	      write(htmlout, '(a)') 'ERROR'
+	      close(htmlout)
+	    else if (i .gt. 1) then
+	      call str_upcase(upcase, line(p+1:p+i-1))
+	      call out_html(0, '')
+	      call out_html(0,line(p+1:p+i-1))
+	      call out_html(0,'')
+	    endif
+	    p=p+i
+	    i=index(line(p+1:l+1), '"')
+	  enddo
+	  call out_html(0, line(p+1:l+1))
+	  call out_html(htmlout, ' ')
+	  p=0
+20	  i=index(line(p+1:), '''')
+	  if (i .ne. 0) then
+	    p=p+i
+	    line(p+1:l+1)=line(p:l)
+	    p=p+2
+	    l=l+1
+	    goto 20
+	  endif
+	  if (l .gt. 60) then
+	    write(lunout, '(3a/3a)')
+	1 tab//'1/'' ',line(1:60),''''
+	1,tab//'1,''',line(61:l),''''
+	  else
+	    write(lunout,'(3a)')
+	1 tab//'1/'' ',line(1:l),''''
+	  endif
+	endif
+	goto 1
+99	write(lunout,'(a/a/a)') tab//'1)',tab//'endif',tab//'end'
+	write(htmlout, '(a)') '
' + close(lunin) + close(lunout) + close(htmlout) + end diff --git a/gen/make_vers.f b/gen/make_vers.f new file mode 100644 index 0000000..b1af938 --- /dev/null +++ b/gen/make_vers.f @@ -0,0 +1,37 @@ + subroutine make_vers(lunin) + + integer lunin, lunout + character tab*1, vers*32, dat*8, tim*10 + integer l, iostat + + tab=char(9) + lunout=2 + if (lunout .eq. lunin) then + print *,'lun mismatch' + stop 'error in MAKE_VERS' + endif + call sys_open(lunout, 'fit_vers.f', 'wo', iostat) + if (iostat .ne. 0) then + print *,'cannot write fit_vers.f' + stop 'error in MAKE_VERS' + endif + + read(lunin,'(a)') vers + call str_trim(vers, vers, l) + call date_and_time(dat, tim) + vers(l+1:)=' ('//dat(1:4)//'-'//dat(5:6)//'-'//dat(7:8)//' ' + 1//tim(1:2)//':'//tim(3:4)//':'//tim(5:6)//')' + call str_trim(vers, vers,l) + write(lunout,'(a,6(/,a))') + 1 '! DO NOT EDIT this subroutine.' + 1,'! It is automatically created with: make_custom fit.vers' + 1,tab//'subroutine fit_vers(version)' + 1,tab//'character version*(*)' + 1,tab//'version='''//vers(1:l)//'''' + 1,tab//'end' + close(lunin) + close(lunout) + end + + + diff --git a/gen/metac.c b/gen/metac.c new file mode 100644 index 0000000..1bacbca --- /dev/null +++ b/gen/metac.c @@ -0,0 +1,334 @@ +#include +#include +#include +#include "myc_err.h" +#include "myc_mem.h" +#include "myc_str.h" +#include "myc_fortran.h" + +#define NAME_LEN 32 +#define STR_SIZE 2048 +#define STD_FORMAT 8230 + +typedef struct Itm_ { + struct Itm_ *next; + char *str; + int cnt, level, fmt, allsize; + float vmin, vmax, value; + char name[NAME_LEN], lowName[NAME_LEN]; +} Itm; + +static Itm *head, *lend; + +static int level, min_level=99999, max_level=-99999; +static int format=STD_FORMAT; /* width*1000+fixlen*100+digits*10+trunc) */ + +Itm *meta_find(char *name) { + Itm *p, *res; + char lowName[NAME_LEN]; + static int init=1; + + res=NULL; + p=NULL; + if (init) { + init=0; + head=NULL; + lend=NULL; + } + str_lowcase(lowName, name); + p=head; + while (p!=NULL) { + if (0==strcmp(p->lowName, lowName)) { + if (0==strcmp(p->name, name)) return p; + res=p; + } + p=p->next; + } + return res; +} + + +Itm *meta_find_create(char *name) { + Itm *p; + + p=meta_find(name); + if (p==NULL) { + NEW(p, Itm); + assert(p->str==NULL); + str_copy(p->name, name); + p->cnt=0; + str_lowcase(p->lowName, name); + if (lend==NULL) { + head=p; + } else { + lend->next=p; + } + lend=p; + } + p->level=level; + if (level>max_level) max_level=level; + if (levelmax_level) return max_level; + return *this; +} + +void F_FUN(meta_set_level)(int *this) { + level=*this; +} + +void F_FUN(meta_get_str)(F_CHAR(name), F_CHAR(value) F_CLEN(name) F_CLEN(value)) { + char nam[NAME_LEN]; + Itm *p; + static char buf[32]; + + STR_TO_C(nam, name); + p=meta_find(nam); + if (p==NULL) return; + if (p->str!=NULL) { + STR_TO_F(value, p->str); + } else { + sprintf(buf, "%f", p->value); + STR_TO_F(value, buf); + } +} + +void F_FUN(meta_get_real)(F_CHAR(name), float *value F_CLEN(name)) { + char nam[NAME_LEN]; + Itm *p; + + STR_TO_C(nam, name); + p=meta_find(nam); + if (p!=NULL) { + *value=p->value; + } +} + +void F_FUN(meta_real_range)(F_CHAR(name), float *vmin, float *vmax F_CLEN(name)) { + char nam[NAME_LEN]; + Itm *p; + + STR_TO_C(nam, name); + p=meta_find(nam); + if (p!=NULL) { + *vmin=p->vmin; + *vmax=p->vmax; + } +} + +void F_FUN(meta_put_str)(F_CHAR(name), F_CHAR(value), int *overwrite F_CLEN(name) F_CLEN(value)) { + char nam[NAME_LEN], val[STR_SIZE]; + Itm *p; + int l; + + STR_TO_C(nam, name); + STR_TO_C(val, value); + + p=meta_find_create(nam); + l=(strlen(val)/16+1)*16; + if (p->str==NULL) { + p->allsize=l; + p->str=MALLOC(l); + p->str[0]='\0'; + p->cnt=0; + } else if (l>p->allsize) { + free(p->str); + p->allsize=l; + p->str=MALLOC(l); + p->str[0]='\0'; + p->cnt=0; + } else if (*overwrite) { + p->cnt=0; + } + if (p->cnt > 0) { + if (0==strcmp(p->str, val)) return; + } + p->cnt++; + str_ncpy(p->str, val, p->allsize); +} + +void F_FUN(meta_put_real)(F_CHAR(name), float *value, int *overwrite F_CLEN(name)) { + Itm *p; + char nam[NAME_LEN]; + + STR_TO_C(nam, name); + p=meta_find_create(nam); + if (p->str!=NULL) { + FREE(p->str); + p->str=NULL; + p->cnt=0; + } else if (*overwrite>0) { + p->cnt=0; + } + if (p->cnt <= 0) { + p->vmin=*value; + p->vmax=*value; + } else { + if (*value < p->vmin) p->vmin=*value; + if (*value > p->vmax) p->vmax=*value; + } + p->value=*value; + p->cnt++; + p->fmt=format; +} + +void F_FUN(meta_purge)(int *from, int *to) { + Itm *p, *p0, *pn; + + p0=NULL; + p=head; + while (p!=NULL) { + if (*from <= p->level && p->level <= *to) { + pn=p->next; + if (p->str!=NULL) FREE(p->str); + FREE(p); + if (p0!=NULL) { + p0->next=pn; + } else { + head=pn; + } + p=pn; + } else { + p0=p; + p=p->next; + } + } + lend=p0; +} + +void F_FUN(cvt_real_str)(F_CHAR(fstr), int *l, float *f, int *w, int *d, int*g, int *t F_CLEN(fstr)); + +int meta_cvt_real(char *str, int fmt, float value) { + int fdig, gdig, wid, trc, l; + char buf[12]; + F_DCHAR(fstr,10); + + wid=fmt/1000; fmt=fmt % 1000; + fdig=fmt/100; fmt=fmt % 100; + gdig=fmt/10; + trc=fmt % 10; + F_FUN(cvt_real_str)(fstr, &l, &value, &wid, &fdig, &gdig, &trc F_ALEN(fstr)); + STR_TO_C(buf, fstr); + strcpy(str, buf); + return l; +} + +int meta_fmt_item(Itm *p, char *line, int lineLen, int list_mode) { + int l, fmt, trc; + + str_ncpy(line, p->name, lineLen); + if (p->str) { + str_ncat(line, "='", lineLen); + str_ncat(line, p->str, lineLen); + l=strlen(line); + if (l < lineLen-2) { + if (p->cnt > 1 && list_mode < 2 && line[l-1]!='?') { + line[l]='?'; l++; + } + line[l]='\''; l++; + line[l]='\0'; + } + } else { + if (p->fmt==0) { + fmt=format; + } else { + fmt=p->fmt; + } + if (fmt % 10 == 3) { + trc=3; + } else { + trc=1; + } + str_ncat(line,"=", lineLen); + l=strlen(line); + if (l < lineLen - 24) { + if (list_mode==0) { + l+=meta_cvt_real(line+l, 1060+trc, p->vmin); + } else if (list_mode==1) { + l+=meta_cvt_real(line+l, fmt, p->vmin); + } else { + l+=meta_cvt_real(line+l, fmt, p->value); + } + if (p->vmax != p->vmin && list_mode < 2) { + if (list_mode==0) { + line[l]=' '; l++; + l+=meta_cvt_real(line+l, 1060+trc, p->vmax); + } else { + line[l]='.'; l++; + line[l]='.'; l++; + l+=meta_cvt_real(line+l, fmt, p->vmax); + } + } + } + } + return l; +} + +void F_FUN(meta_show)(F_CHAR(name) F_CLEN(name)) { + char nam[NAME_LEN]; + Itm *p; + char line[256]; + + STR_TO_C(nam, name); + p=meta_find(nam); + if (p!=NULL) { + meta_fmt_item(p, line, sizeof line, 0); + printf(" %s\n", line); + } else { + printf(" %s not found\n", nam); + } +} + +void F_FUN(meta_list)(int *levl, int *listmode, int *str_select, void (*outrtn)(void *arg, F_CHAR(str) F_CLEN(str)) + , void *outarg, F_CHAR(except) F_CLEN(except)) { + Itm *p; + char line[256], lowName[NAME_LEN+2], exc[256]; + int l,lev,list_str, list_mode; + F_DCHAR(fline, 256); + + list_mode=*listmode; /* 0 compact (on file), 1: for info, 2: don't show min/max */ + STR_TO_C(exc, except); + str_append(exc, " "); + lev=*levl; + list_str=*str_select; + p=head; + if (levmax_level) return; + while (p!=NULL) { + if (p->level==lev && (list_str!=0) == (p->str!=NULL)) { /* check if level and type matches */ + str_copy(lowName, " "); + str_append(lowName, p->lowName); + str_append(lowName, " "); + if (NULL==strstr(exc, p->lowName)) { + l=meta_fmt_item(p, line, sizeof line, list_mode); + F_LEN(fline)=l; + STR_TO_F(fline, line); + outrtn(outarg, fline F_ALEN(fline)); + } + } + p=p->next; + } +} + +void F_FUN(meta_format)(int *fmt) { + if (*fmt==0) { + format=STD_FORMAT; + } else { + format=*fmt; + } +} + +void F_FUN(meta_set_format)(F_CHAR(name), int *fmt F_CLEN(name)) { + Itm *p; + char nam[NAME_LEN]; + STR_TO_C(nam, name); + p=meta_find(nam); + if (p!=NULL) { + p->fmt=*fmt; + } +} diff --git a/gen/metaf.f b/gen/metaf.f new file mode 100644 index 0000000..3f49c15 --- /dev/null +++ b/gen/metaf.f @@ -0,0 +1,180 @@ + subroutine meta_put(str, value) + character str*(*) + real value + + integer i + + if (value .eq. 0.0) then + i=index(str,'=') + if (i .gt. 0) then + if (i .eq. 1) return + if (i .eq. len(str)) then + call meta_put_str(str(1:i-1), ' ', 0) + else + call meta_put_str(str(1:i-1), str(i+1:), 0) + endif + return + endif + endif + call meta_put_real(str, value, 0) + end + + subroutine sym_put_str(name, str) + character name*(*), str*(*) + + call meta_put_str(name, str, 1) + end + + subroutine sym_put_real(name, value) + character name*(*) + real value + + call meta_put_real(name, value, 1) + end + + subroutine sym_get_str(name, l, str) + character name*(*), str*(*) + integer l + + str=' ' + call meta_get_str(name, str) + call str_trim(str, str, l) + end + + subroutine sym_get_real(name, value) + character name*(*) + real value + + call meta_get_real(name, value) + end + + subroutine fit_put_str(name, str) + character name*(*), str*(*) + + call meta_put_str(name, str, 1) + end + + subroutine fit_put_real(name, value) + character name*(*) + real value + + call meta_put_real(name, value, 1) + end + + subroutine fit_get_str(name, l, str) + character name*(*), str*(*) + integer l + + str=' ' + call meta_get_str(name, str) + call str_trim(str, str, l) + end + + subroutine fit_get_real(name, value) + character name*(*) + real value + + call meta_get_real(name, value) + end + + subroutine sym_list(lun, listmode, to_lev, except) + integer lun, listmode + integer to_lev + character*(*) except + + integer l + external sym_out_file + integer meta_lim_level + + if (listmode .gt. 0) call sym_out_lev(1) + do l=meta_lim_level(-99999),meta_lim_level(to_lev) + if (listmode .eq. 0) call sym_out_lev(l) + call meta_list(l, listmode, 0, sym_out_file, lun, except) + call meta_list(l, listmode, 1, sym_out_file, lun, except) + call sym_out_ln(lun) ! line break + enddo + end + + subroutine sym_out_file(lun, line) + integer lun, lvl + character line*(*) ! empty line means evt. line break + + character buf*256 + integer l/0/, lev/0/ + save buf, l, lev + integer ll + character ind*32/' '/ + + call str_trim(line, line, ll) + if (l+ll .gt. 80-lev) then + if (lev .eq. 0) then + write(lun, '(a)') buf(1:l) + else + write(lun, '(a,a)') ind(1:lev),buf(1:l) + endif + l=0 + elseif (l .gt. 0) then + buf(l+1:l+2)=';' + l=l+2 + endif + buf(l+1:)=line + l=l+ll + return + + entry sym_out_ln(lun) + if (l .gt. 0) then + if (lev .eq. 0) then + write(lun, '(a)') buf(1:l) + else + write(lun, '(a,a)') ind(1:lev),buf(1:l) + endif + endif + l=0 + return + + entry sym_out_lev(lvl) + lev=lvl + end + + subroutine sym_show(lev) + integer lev + + call meta_set_level(lev) + end + + subroutine sym_newline + entry sym_level + end + + subroutine sym_read(lun, wrapper) + integer lun + external wrapper + + character line*132 + external meta_put + integer j, iostat + + call wrapper(' ', 0.0, meta_put) ! reset + call dat_delimiters(';', '=', '''') +10 continue + read(lun, '(a)', iostat=iostat) line + if (iostat .ne. 0 .or. line .eq. ' ') return + j=0 + do while (line(j+1:j+1) .eq. ' ') + j=j+1 + enddo + call meta_set_level(j) + call dat_intprt(line, wrapper, meta_put) + goto 10 + end + + + subroutine sym_purge(lev) + integer lev + + call meta_purge(lev, 99999) + end + + subroutine obsolete + print *,'obsolete function called' + end diff --git a/gen/migrad.f b/gen/migrad.f new file mode 100644 index 0000000..7528d71 --- /dev/null +++ b/gen/migrad.f @@ -0,0 +1,338 @@ + SUBROUTINE MIGRAD +C -------------------- + include 'fit.inc' + +c Minimization subroutine based on a variable metric method. It is fast +c near a minimum or in any 'nearly quadratic' region but slower if the +c chi**2 function is badly behaved. It uses the first derivatives of the +c chi**2 function, which may either be supplied by the user (subroutine +c FNCTN, GG(*)) or estimated by MIGRAD (subroutine DERIVE). + + + REAL*8 VG(MAXPAR), VII(MAXPAR), D, VGI + real G(MAXPAR), G2(MAXPAR) + real GS(MAXPAR), R(MAXPAR),XXS(MAXPAR), FLNU(MAXPAR) + + integer iswtr, npfn, iflag, npard, i, ntry, negg2, id, kg, nf, ns + integer matgd, j, iter, npargd + real parn, rho2, rostop, trace, fs, xtf, fs1, fs2, xbegin, f, ri + real gdel, denom, slam, slamin, slamax, tlamin, tlamax, f2 + real aa, bb, cc, tlam, f3, gvg, delgam, gami + + DATA SLAMIN,SLAMAX,TLAMIN,TLAMAX/0.2, 3.0, 0.05, 6.0/ + + IF (NPAR .LE. 0) RETURN + + if (isw(2) .eq. 2) isw(2)=1 + + ISWTR = ISW(5) - ITAUR + NPFN = NFCN + PARN=NPAR + RHO2 = 10.*APSI +! ROSTOP = 1.0E-5 * APSI + ROSTOP = 1.0E-3 * APSI + TRACE=1. + IFLAG=4 + IF (ISW(3) .EQ. 1) IFLAG = 2 + FS = AMIN + IF (ITAUR .LT. 1 .and. isyswr.ne.0) + 1 WRITE (ISYSWR,470) ROSTOP, APSI, VTEST + GO TO 2 + 470 FORMAT (/' Start MIGRAD minimization. ' + 1/5X,'Convergence criteria: Estimated distance to minimum edm <' + 1/,E9.2/5X,'or edm <',E9.2 + 1,' and fractional change in variance matrix <',E9.2) + 1 if (isyswr .ne. 0) WRITE (ISYSWR,520) +C. . . . STEP SIZES DIRIN . . . + 2 NPARD = NPAR + DO 3 I= 1, NPAR + D = 0.02* ABS(DIRIN(I)) + IF (ISW(2) .GE. 1) D = 0.02* SQRT(ABS(V(I,I))*UP) + IF (D .LT. 1.0E-5 *ABS(X(I))) D = 1.0E-5 * X(I) ! was 1E-6 (M.Z. 1.9.95) + 3 DIRIN(I) = D +C. . . . . . STARTING GRADIENT + NTRY = 0 + 4 NEGG2 = 0 + DO 10 ID= 1, NPARD + I = ID + NPAR - NPARD + D = DIRIN(I) + XTF = X(I) + X(I) = XTF + D + CALL FNCTN(X,FS1) + NFCN = NFCN + 1 + X(I) = XTF - D + CALL FNCTN(X,FS2) + NFCN = NFCN + 1 + X(I) = XTF + GS(I) = (FS1-FS2)/(2.0 * D) + G2(I) = (FS1 + FS2 - 2.0*AMIN) / D**2 + IF (G2(I) .GT. 1.0E-30) GO TO 10 +C . . . SEARCH IF G2 .LE. 0. . . + if (isyswr .ne. 0) WRITE (ISYSWR,520) + NEGG2 = NEGG2 + 1 + NTRY = NTRY + 1 + IF (NTRY .GT. 4) GO TO 230 + D = 50.*ABS(DIRIN(I)) + XBEGIN = XTF + IF (GS(I) .LT. 0.) DIRIN(I) = -DIRIN(I) + KG = 0 + NF = 0 + NS = 0 + 5 X(I) = XTF + D + CALL FNCTN(X,F) + NFCN = NFCN + 1 + IF (F .LE. AMIN) GO TO 6 +C FAILURE + IF (KG .EQ. 1) GO TO 8 + KG = -1 + NF = NF + 1 + D = -0.4*D + IF (NF .LT. 10) GO TO 5 + D = 1000.*D + GO TO 7 +C SUCCESS + 6 XTF = X(I) + D = 3.0*D + AMIN = F + KG = 1 + NS = NS + 1 + IF (NS .LT. 10) GO TO 5 + IF (AMIN .LT. FS) GO TO 8 + D = 0.001*D + 7 XTF = XBEGIN + G2(I) = 1.0 + NEGG2 = NEGG2 - 1 + 8 X(I) = XTF + DIRIN(I) = 0.1*D + FS = AMIN + 10 CONTINUE + IF (NEGG2 .GE. 1) GO TO 4 + NTRY = 0 + MATGD = 1 +C . . . . . . DIAGONAL MATRIX + IF (ISW(2) .GT. 1) GO TO 15 + 11 NTRY = 1 + MATGD = 0 + DO 13 I= 1, NPAR + DO 12 J= 1, NPAR + 12 V(I,J) = 0. + 13 V(I,I) = 2.0/G2(I) +C. . . GET SIGMA AND SET UP LOOP + 15 SIGMA = 0. + DO 18 I= 1, NPAR + IF (V(I,I) .LE. 0.) GO TO 11 + RI = 0. + DO 17 J= 1, NPAR + XXS(I) = X(I) + 17 RI= RI+ V(I,J) * GS(J) + 18 SIGMA = SIGMA + GS(I) *RI *0.5 + IF (SIGMA .GE. 0.) GO TO 20 + if (isyswr .ne. 0) WRITE (ISYSWR,520) + IF (NTRY.EQ.0) GO TO 11 + ISW(2) = 0 + GO TO 230 + 20 ISW(2) = 1 + ITER = 0 + CALL INTOEX(X) + IF (ISWTR .GE. 1) CALL FIT_PRINT(0) +C . . . . . START MAIN LOOP + 24 CONTINUE + GDEL = 0. + DO 30 I=1,NPAR + RI = 0. + DO 25 J=1,NPAR + 25 RI = RI + V(I,J) *GS(J) + DIRIN(I) = -0.5*RI + GDEL = GDEL + DIRIN(I)*GS(I) +C.LINEAR SEARCH ALONG -VG . . . + 30 X(I) =XXS(I) + DIRIN(I) + CALL FNCTN(X, F) + NFCN=NFCN+1 +C. QUADR INTERP USING SLOPE GDEL + DENOM = 2.0*(F-AMIN-GDEL) + IF (DENOM .LE. 0.) GO TO 35 + SLAM = -GDEL/DENOM + IF (SLAM .GT. SLAMAX) GO TO 35 + IF (SLAM .LT. SLAMIN) SLAM=SLAMIN + GO TO 40 + 35 SLAM = SLAMAX + 40 IF (ABS(SLAM-1.0) .LT. 0.1) GO TO 70 + DO 45 I= 1, NPAR + 45 X(I) =XXS(I) + SLAM*DIRIN(I) + CALL FNCTN(X,F2) + NFCN = NFCN + 1 +C. QUADR INTERP USING 3 POINTS + AA = FS/SLAM + BB = F/(1.0-SLAM) + CC = F2/ (SLAM*(SLAM-1.0)) + DENOM = 2.0*(AA+BB+CC) + IF (DENOM .LE. 0.) GO TO 48 + TLAM = (AA*(SLAM+1.0) + BB*SLAM + CC)/DENOM + IF (TLAM .GT. TLAMAX) GO TO 48 + IF (TLAM .LT. TLAMIN) TLAM=TLAMIN + GO TO 50 + 48 TLAM = TLAMAX + 50 CONTINUE + DO 51 I= 1, NPAR + 51 X(I) = XXS(I)+TLAM*DIRIN(I) + CALL FNCTN(X,F3) + NFCN = NFCN + 1 + IF (F.GE.AMIN .AND. F2.GE.AMIN .AND. F3.GE.AMIN) GO TO 200 + IF (F .LT. F2 .AND. F .LT. F3) GO TO 61 + IF (F2 .LT. F3) GO TO 58 + 55 F = F3 + SLAM = TLAM + GO TO 65 + 58 F = F2 + GO TO 65 + 61 SLAM = 1.0 + 65 DO 67 I= 1, NPAR + DIRIN(I) = DIRIN(I)*SLAM + 67 X(I) = XXS(I) + DIRIN(I) + 70 AMIN = F + ISW(2) = 2 + IF (SIGMA+FS-AMIN .LT. ROSTOP) GO TO 170 + IF (SIGMA+RHO2+FS-AMIN .GT. APSI) GO TO 75 + IF (TRACE .LT. VTEST) GO TO 170 + 75 CONTINUE + IF (NFCN-NPFN .GE. NFCNMX) GO TO 190 + ITER = ITER + 1 + IF (ISWTR.GE. 3 .OR.(ISWTR.EQ. 2 .AND. MOD(ITER,10) .EQ.1)) + 1 CALL FIT_PRINT(0) +C. . . GET GRADIENT AND SIGMA . + IF (ISW(3) .NE. 1) GO TO 80 + CALL FNCTN(X,AMIN) + NFCN = NFCN + 1 + 80 CALL DERIVE(G,G2) + RHO2 = SIGMA + SIGMA = 0. + GVG = 0. + DELGAM = 0. + DO 100 I= 1, NPAR + RI = 0. + VGI = 0. + DO 90 J= 1, NPAR + VGI = VGI + V(I,J)*(G(J)-GS(J)) + 90 RI = RI + V(I,J) *G (J) + R(I) = RI * 0.5 + VG(I) = VGI*0.5 + GAMI = G(I) - GS(I) + GVG = GVG + GAMI*VG(I) + DELGAM = DELGAM + DIRIN(I)*GAMI + 100 SIGMA = SIGMA + G(I)*R(I) + IF (SIGMA .LT. 0.) GO TO 1 + IF (GVG .LE. 0.) GO TO 105 + IF (DELGAM .LE. 0.) GO TO 105 + GO TO 107 + 105 IF (SIGMA .LT. 0.1*ROSTOP) GO TO 170 + GO TO 1 + 107 CONTINUE +C. UPDATE COVARIANCE MATRIX + TRACE=0. + DO 120 I= 1, NPAR + VII(I) = V(I,I) + DO 120 J=1,NPAR + D = DIRIN(I)*DIRIN(J)/DELGAM - VG(I)*VG(J)/GVG + 120 V(I,J) = V(I,J) + 2.0*D + IF (DELGAM .LE. GVG) GO TO 135 + DO 125 I= 1, NPAR + 125 FLNU(I) = DIRIN(I)/DELGAM - VG(I)/GVG + DO 130 I= 1, NPAR + DO 130 J= 1, NPAR + 130 V(I,J) = V(I,J) + 2.0*GVG*FLNU(I)*FLNU(J) + 135 CONTINUE + DO 140 I= 1, NPAR + 140 TRACE = TRACE + ((V(I,I)-VII(I))/(V(I,I)+VII(I)))**2 + TRACE = SQRT(TRACE/PARN) + CALL UCOPY(X,XXS,NPAR) + CALL UCOPY(G,GS,NPAR) + FS = F + GO TO 24 +C . . . . . END MAIN LOOP + 170 if (isyswr .ne. 0) WRITE(ISYSWR,500) + 500 FORMAT (/' MIGRAD minimization has converged') +c do i=1,npar +c type '(X,8F10.5)',(v(i,j)/sqrt(v(i,i)*v(j,j)),j=1,npar) +c enddo + + ISW(2) = 3 + IF(ISWTR .GE. 0) CALL FIT_PRINT(1-ITAUR) + IF (ITAUR .GT. 0) GO TO 435 + IF (MATGD .GT. 0) GO TO 435 + NPARGD = NPAR*(NPAR+5)/2 + IF (NFCN-NPFN .GE. NPARGD) GO TO 435 + if (isyswr .ne. 0) + 1 WRITE (ISYSWR,'(X,A)') 'Covariance matrix inaccurate' + IF (ISW(2) .GE. 2) ISW(2) = 3 + GO TO 435 + 190 ISW(1) = 1 + if (nfcnmx .gt. 0) GO TO 230 + if (isyswr .ne. 0) write(isyswr, '(/a)') ' MIGRAD aborted' + goto 231 + 200 if (isyswr .ne.0) WRITE (ISYSWR,650) + 650 FORMAT (/' MIGRAD fails to find improvement') + CALL UCOPY(XXS,X,NPAR) + ISW(2) = 1 + IF (SIGMA .LT. ROSTOP) GO TO 170 + IF (MATGD .GT. 0) GO TO 2 + if (isw(2) .eq. 1) isw(2)=2 + 230 if (isyswr .ne. 0) WRITE (ISYSWR,510) + 510 FORMAT (/' MIGRAD terminated without convergence') + 231 CALL FNCTN(X,AMIN) + CALL FIT_PRINT(1-ITAUR) + 435 RETURN + 520 FORMAT (/' Covariance matrix is not positive-definite') + END + + SUBROUTINE DERIVE(GG,GG2) +C ---------------------------- + include 'fit.inc' + real GG(*),GG2(*) + + integer iflag, i, lc + real eps, xtf, fs1, fs2, dd + + IF (ISW(3) .EQ. 1) GO TO 100 + IFLAG = 4 + DO 46 I=1,NPAR + EPS = 0.1 * ABS(DIRIN(I)) + IF (ISW(2) .GE. 1) EPS = EPS + 0.005*SQRT(V(I,I)*UP) + IF (EPS .LT. 1.0E-8*ABS(X(I))) EPS = 1.0E-8*X(I) + XTF = X(I) + X(I) = XTF + EPS + CALL FNCTN(X,FS1) + NFCN=NFCN+1 + X(I) = XTF - EPS + CALL FNCTN(X,FS2) + NFCN=NFCN+1 +C. . . . . . . FIRST DERIVATIVE + GG(I)= (FS1-FS2)/(2.0*EPS) +C. . . ERROR ON FIRST DERIVATIVE + GG2(I)= (FS1+FS2-2.0*AMIN)/(2.0*EPS) + X(I) = XTF + 46 CONTINUE + CALL INTOEX(X) + GO TO 200 +C. DERIVATIVES CALC BY FCN + 100 DO 150 I= 1, NU + LC=LCORSP(I) + IF (LC .LT. 1) GO TO 150 + IF (LCODE(I) .GT. 1) GO TO 120 + GG(LC)=GG(I) + GO TO 150 + 120 DD = (BLIM(I)-ALIM(I))*0.5 *COS(X(LC)) + GG(LC)=GG(I)*DD + 150 CONTINUE + 200 RETURN + END + + SUBROUTINE UCOPY(FROM,TO,N) +C ----------------------------- + integer n, i + real FROM(N),TO(N) + IF(N.LT.1)RETURN + DO 100 I=1,N +100 TO(I)=FROM(I) + RETURN + END + diff --git a/gen/myc_err.c b/gen/myc_err.c new file mode 100644 index 0000000..c92112e --- /dev/null +++ b/gen/myc_err.c @@ -0,0 +1,136 @@ +#include +#include +#include + +#include "myc_fortran.h" +#include "myc_str.h" +#include "myc_err.h" + +#define SLEN 64 +#define MLEN 64 + +static char *txt[SLEN]; +static int sp=0; +static int stack_empty=1; + +int ErrCode; +char *ErrMessage=NULL; +void (*outrtn)(void *, char *)=NULL; +void *outarg; + +void ErrTxt(char *text, int systemError) +{ + if (systemError) { + sp=0; ErrCode=errno; ErrMessage=strerror(errno); + } + if (stack_empty && sp>0) { + sp=0; + stack_empty=0; + } + if (sp +#include + +/* 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 *,char *), void *arg); +void ErrSetOutFile(FILE *file); + +extern int ErrCode; +extern char *ErrMessage; + +#endif /* _ERR_HANDLING_H_ */ diff --git a/gen/myc_fortran.h b/gen/myc_fortran.h new file mode 100644 index 0000000..fb7e558 --- /dev/null +++ b/gen/myc_fortran.h @@ -0,0 +1,73 @@ +#ifndef _SYS_UTIL_H_ +#define _SYS_UTIL_H_ + +/* + + fortran interface stuff + + declare fortran character arguments as F_CHAR(arg) + and at at the end for each character argument add + int _len to the argument list + + Use macros STR_TO_C and STR_TO_F to convert from Fortran character strings + to C character arrays and vice versa. + +*/ + + +#if defined __VMS + +typedef struct { short size, dummy; char *text; } SysVmsChar; + +#define F_CHAR(VAR) SysVmsChar *VAR +#define F_DCHAR(VAR,LEN) static char VAR##_str[LEN]; SysVmsChar VAR##_desc={LEN,270,&VAR##_str[0]}; SysVmsChar *VAR=&VAR##_desc +#define F_CLEN(VAR) +#define F_ALEN(VAR) +#define F_LEN(VAR) VAR->size +#define STR_TO_C(DST,SRC) str_ntrim(DST, SRC->text, sizeof(DST), SRC->size) +#define STR_TO_F(DST,SRC) str_npad(DST->text, SRC, DST->size) + +#define F_DESCRIPTOR 1 +#define F_UNDERSCORE 0 + +#elif defined __alpha || defined __unix || defined __GNUC__ + +#define F_CHAR(VAR) char *VAR +#define F_DCHAR(VAR,LEN) char VAR[LEN]; int VAR##_len=LEN +#define F_CLEN(VAR) ,int VAR##_len +#define F_ALEN(VAR) ,VAR##_len +#define F_LEN(VAR) VAR##_len +#define STR_TO_C(DST,SRC) str_ntrim(DST, SRC, sizeof(DST), SRC##_len) +#define STR_TO_F(DST,SRC) str_npad(DST, SRC, DST##_len) + +#define F_DESCRIPTOR 0 + +#if defined __alpha +#define F_UNDERSCORE 1 +#else + +#ifndef F_UNDERSCORE +#define F_UNDERSCORE 2 + +#endif + +#endif + +#else + +#error "other machines are not supported" + +#endif + +#if F_UNDERSCORE == 0 +#define F_FUN(A) A + +#elif F_UNDERSCORE == 1 +#define F_FUN(A) A##_ + +#elif F_UNDERSCORE == 2 +#define F_FUN(A) A##__ + +#endif + +#endif /* _SYS_UTIL_H_ */ diff --git a/gen/myc_list.h b/gen/myc_list.h new file mode 100644 index 0000000..417dcd0 --- /dev/null +++ b/gen/myc_list.h @@ -0,0 +1,11 @@ +void Lst_Ins(void *head, void *item, int pos); +int Lst_Find(void *head, void *key); +void Lst_Pos(void *head, int pos); + +#define LstDecl(HEAD,TYP,CMP,KEY,KTYP) struct TYP##_HDR { \ + void (*ck)(); int (*cmp)(KTYP,KTYP);KTYP *kptr;int pos; \ + void *list;TYP *itm; TYP kitm;} HEAD \ + ={&Lst_Ins,CMP,&HEAD.kitm.KEY} +#define LstIns(HEAD,ITM,POS) Lst_Ins((LstHead*)&HEAD,(HEAD.itm=(ITM)),POS); +#define LstFind(HEAD,KEY) (HEAD.pos=Lst_Find((LstHead*)&HEAD,HEAD.kptr-&KEY,KEY)) +#define LstPos(HEAD,POS) Lst_Pos((LstHead*)&HEAD,POS) diff --git a/gen/myc_mem.h b/gen/myc_mem.h new file mode 100644 index 0000000..c9f91b5 --- /dev/null +++ b/gen/myc_mem.h @@ -0,0 +1,30 @@ +#ifndef _MEM_UTIL_H_ +#define _MEM_UTIL_H_ + +#include +#include + +#ifdef FORTIFY +#include "fortify.h" +#endif + +/* ------------------------------------------------------------ + these macros help for safer dynamic memory + you may change these macros if you want to log dynamic memory access + +*/ + +#define NEW(PTR,TYP) {TYP _0_={0}; ERR_SP(PTR=malloc(sizeof(*PTR))); *PTR=_0_; } +/* + allocates and initializes an object of type TYP and make PTR point to it + TYP must be defined with an appropriate typedef declaration, and + INIT(TYP) must follow the declaration to initialize a dummy initializer + object. +*/ + +#define NEW_STR(TO,FROM) {ERR_SP(TO=malloc(strlen(FROM)+1)); strcpy(TO,FROM); } + +#define MALLOC(SIZE) malloc(SIZE) +#define FREE(PTR) free(PTR) + +#endif /* _MEM_UTIL_H_ */ diff --git a/gen/myc_str.c b/gen/myc_str.c new file mode 100644 index 0000000..63c98e4 --- /dev/null +++ b/gen/myc_str.c @@ -0,0 +1,251 @@ +#include +#include +#include +#include +#include +#include +#include +#include "myc_err.h" +#include "myc_str.h" +#include "myc_mem.h" + +char *str_splitx(char *str, char sep, char *list[], int *n) { + int i; + char *s, *e; + + s=str; + for (i=0; i<*n; i++) { + list[i]=s; + e=strchr(s, sep); + if (e==NULL) { *n=i+1; return(NULL); } + s=e+1; + e--; + while (e>str && *e==' ') e--; /* trim sequence */ + e[1]='\0'; + } + return(s); +} + +char *str_split1(char *str, char sep) { + char *s, *e; + + e=strchr(str, sep); + if (e==NULL) { + s=NULL; + e=str+strlen(str); + } else { + s=e+1; + } + e--; + while (e>str && *e==' ') e--; /* trim sequence */ + e[1]='\0'; + return(s); +} + +int str_ntrim(char *dest, const char *src, int ldest, int lsrc) { + int i; + + if (lsrc>=ldest) lsrc=ldest-1; + if (dest!=src) strncpy(dest, src, lsrc); + dest[lsrc]='\0'; + i=strlen(dest)-1; + while (i>=0 && dest[i]==' ') i--; /* trim sequence */ + i++; + dest[i]='\0'; + return(i); +} + +int str_npad(char *dest, const char *src, int ldest) { + int i, lsrc; + + lsrc=strlen(src); + if (lsrc>=ldest) { + if (dest!=src) strncpy(dest, src, ldest); + lsrc=ldest; + } else { + if (dest!=src) strcpy(dest, src); + for (i=lsrc; i=dstlen) { + str_copy(dst, src); + } else { + strncpy(dst, src, i); + dst[i]='\0'; + } + return(s); +} + +char *str_read_until(FILE *fil, char *term, char *buf, char *end) { + char fmt[24]; + int i, l, siz; + char ch; + + siz=end-buf-1; + if (siz<1) return(NULL); + sprintf(fmt, "%s%d[^%s%s", "%", siz, term, "]%n%c"); + i=fscanf(fil, fmt, buf, &l, &ch); + if (i<0) { /* eof */ + buf[0]='\0'; + return(&buf[0]); + } else if (i==0) { /* fscanf returns 0 if first char is terminator */ + buf[0]=fgetc(fil); + return(&buf[0]); + } else if (i==1) { /* terminator not found -> read until eof */ + buf[l]='\0'; + return(&buf[l]); + } else { + buf[l]=ch; + if (l==siz && NULL==strchr(term, ch)) return(NULL); + return(&buf[l]); + } +} + +char *str_read_file(char *file) { + FILE *fil; + char *str, *s, *e, *p, *q; + int i, size; + struct stat statbuf; + + i=stat(file, &statbuf); + if (i<0) ERR_MSG("file not found"); + size=statbuf.st_size+4; + ERR_SP(str=MALLOC(size)); + e=&str[size-1]; + ERR_SP(fil=fopen(file, "r")); + s=str; + while (1) { + p=str_read_until(fil, "!", s, e); + if (p==NULL) break; + if (*p=='!') { + q=str_read_until(fil, "\n", p, e); + if (q==NULL) { p=NULL; break; } + s=p; *s='\n'; s++; + } else { + assert(*p=='\0'); + break; + } + } + ERR_SI(fclose(fil)); + assert(strlen(str)reslen) ERR_MSG("result buffer too short"); + strncpy(r, p, l); + r+=l; reslen-=l; + if (ln>reslen) ERR_MSG("result buffer too short"); + strncpy(r, new, reslen); + r+=ln; reslen-=ln; + p=s+lo; + s=strstr(p, old); + } + l=strlen(p); + if (l>reslen) ERR_MSG("result buffer too short"); + strncpy(r, p, l); + r+=l; + *r='\0'; + return(r-result); + OnError: + result[0]='\0'; + return(-1); +} + +void str_nupcase(char *dst, const char *src, int dstlen) { + dstlen--; /* space for trailing nul */ + while (*src!='\0' && dstlen>0) { + *dst=toupper((int)*src); + dst++; src++; + dstlen--; + } + *dst='\0'; +} + +void str_nlowcase(char *dst, const char *src, int dstlen) { + dstlen--; /* space for trailing nul */ + while (*src!='\0' && dstlen>0) { + *dst=tolower((int)*src); + dst++; src++; + dstlen--; + } + *dst='\0'; +} + +#ifndef __GNUC__ +int strcasecmp(const char *str1, const char *str2) { + int i; + char ch1, ch2; + ch1=tolower(*(str1++)); ch2=tolower(*(str2++)); + i=1; + while (ch1!='\0' && ch2!='\0' && ch1==ch2) { + ch1=tolower(*(str1++)); ch2=tolower(*(str2++)); i++; + } + if (ch1ch2) { + return(i); + } + return(0); +} +#endif + +int str_ncpy(char *dst, const char *src, int maxdest) { + strncpy(dst, src, maxdest); + if (dst[maxdest-1]!='\0') { + dst[maxdest-1]='\0'; + ERR_MSG("destination string too short"); + } + return(0); + OnError: return(-1); +} + +int str_ncat(char *dst, const char *src, int maxdest) { + strncat(dst, src, maxdest-strlen(dst)-1); + if (dst[maxdest-1]!='\0') { + dst[maxdest-1]='\0'; + ERR_MSG("destination string too short"); + } + return(0); + OnError: return(-1); +} diff --git a/gen/myc_str.h b/gen/myc_str.h new file mode 100644 index 0000000..95bdbfa --- /dev/null +++ b/gen/myc_str.h @@ -0,0 +1,122 @@ +#ifndef _MYC_STR_H_ +#define _MYC_STR_H_ + +#define MYC_NAN (-1.125/1024./1024./1024.) + +/* + use these macros if DST is a fixed length character array +*/ + +#define str_trim(DST,SRC,L) str_ntrim(DST,SRC,sizeof(DST),L) +#define str_pad(DST,SRC) str_npad(DST,SRC,sizeof(DST)) +#define str_split(DST,SRC,SEP) str_nsplit(DST,SRC,SEP,sizeof(DST)) +#define str_substitute(DST,SRC,OLD,NEW) str_nsubstitute(DST,SRC,OLD,NEW,sizeof(DST)) +#define str_upcase(DST,SRC) str_nupcase(DST,SRC,sizeof(DST)) +#define str_lowcase(DST,SRC) str_nlowcase(DST,SRC,sizeof(DST)) +#define str_copy(DST,SRC) str_ncpy(DST,SRC,sizeof(DST)) +#define str_append(DST,SRC) str_ncat(DST,SRC,sizeof(DST)) + + +char *str_split1(char *str, char separator); +/* + trims text before separator in *str and returns + a pointer to the first character after separator +*/ + +char *str_splitx(char *str, char sep, char *list[], int *n); +/* + split string into *n strings using separator sep. + spaces at the end of the elements are trimmed + attention: *str is modified ('\0' placed at the end of the elements) + + if *n separators are found, result points to string after *n-th separator + else result is NULL + *n contains number of elements stored in list +*/ + +int str_ntrim(char *dest, const char *src, int ldest, int lsrc); +/* + copy characters 0 to lsrc-1 from src to dest (max ldest chars). +*/ + +int str_npad(char *dest, const char *src, int ldest); +/* + copy src to dest and fill with spaces (fortran string format) +*/ + +char *str_nsplit(char *dst, const char *src, char sep, int dstlen); +/* + returns a pointer to the text after the separator sep in *src + and copies the text before the separator to *dst + when *src does not contain the separator sep + NULL is returned, and *dst is a copy of *src +*/ + +char *str_read_file(char *file); +/* + return one string containing the contents of file *file + comments separated by '!' are omitted. The caller must + free the result after use. +*/ + +void str_replace_char(char *str, char ch, char rep); +/* + replace all occurences of character ch by character rep in string *str +*/ + +int str_nsubstitute(char *result, char *str, char *old, char *new, int reslen); +/* + replace every instance of old in str by new. + the result must not overlap + if the result would be longer than reslen, the result is en empty string + and the return value is -1; + else the return value is the length of the result. + return one string containing the contents of file *file + the contents are treated in the following way: + - #0,#1,...#n is replaced by the corresponding argument *args[n] (n=0..nargs-1, nargs<10) + - at the end of each line spaces and comments separated by ! are trimmed +*/ + +void str_nupcase(char *dst, const char *src, int dstlen); +/* + convert *str to uppercase +*/ + +void str_nlowcase(char *dst, const char *src, int dstlen); +/* + convert *str to lowercase +*/ + +#ifdef __VMS_VER +#if __VMS_VER<70000000 + +int strcasecmp(const char *str1, const char *str2); +/* + compare *str1 with *str2 + the comparison is not case sensitive + if result=0: strings are equal + else + result>0 <==> *str1>*str2 + first different character is at position abs(result)-1 +*/ + +#else +#include +#endif /* __VMS_VER<70000000 */ +#else +#include +#endif /* __VMS_VER */ + +int str_ncpy(char *dst, const char *src, int maxdest); +/* + copy *src to *dest, maximal maxdest characters, + it is guaranteed, that dst contains '\0' +*/ + +int str_ncat(char *dst, const char *src, int maxdest); +/* + append *src to *dest, maximal maxdest characters, + it is guaranteed, that dst contains '\0' +*/ + +#endif /* _MYC_STR_H_ */ diff --git a/gen/myfit_head b/gen/myfit_head new file mode 100644 index 0000000..9a7dc90 --- /dev/null +++ b/gen/myfit_head @@ -0,0 +1,36 @@ +#!/bin/tcsh +if ($# < 1) then + echo " " + if (-e fitexample.f) then + echo "fitexample.f is already present" + else + set b=`dirname $0` + echo "fitexample.f created" + cp $b/../lib/fitexample.f . + endif + echo " " + echo "Create your own fit function:" + echo " " + echo "- rename fitexample.f to an other name (i.e. xxx.f)" + echo "- edit xxx.f changing the parameter list and the function" + echo " and type" + echo " " + echo " myfit -o xxx xxx.f" + echo " " + exit +endif +if ($# == 1) then + if (-r "$1.f") then + set argv=(-o $1 $1.f) + else + set f="${1}_" + set s=${f:s/.f_//:s/.for_//} + if ($s != $f && -r $1) then + set argv=(-o $s $1) + else + echo "Usage: myfit -o xxx xxx.f" + exit + endif + endif + echo myfit $argv +endif diff --git a/gen/napi_err.c b/gen/napi_err.c new file mode 100644 index 0000000..c04ffa4 --- /dev/null +++ b/gen/napi_err.c @@ -0,0 +1,47 @@ +#include +#include +#include "napi.h" +#include "myc_str.h" + +static int doReport; +static int init=1; +static char report[2048]; + +void NXswitchedReport(void *pData, char *string) +{ + if (doReport) { + printf("%s\n",string); + } else if (NULL==strstr(report, string)) { /* append only new messages */ + str_append(report, string); + str_append(report, "\n"); + } +} + +void nxswitchreport(int *doreport) +{ + if (init) { init=0; NXMSetError(NULL, NXswitchedReport); }; + doReport = *doreport; + if (!doReport) report[0]='\0'; +} + +void nxlistreport(void) { + if (report[0]!='\0') { + printf("--- Errors in NeXus:%s---\n", report); + } +} + +void nxswitchreport_(int *doreport) +{ + nxswitchreport(doreport); +} + +void nxlistreport_(void) { + nxlistreport(); +} + +/* +int nxbytesize(int *type) +{ + return DFKNTsize(*type); +} +*/ diff --git a/gen/quick_sort.f b/gen/quick_sort.f new file mode 100644 index 0000000..0808275 --- /dev/null +++ b/gen/quick_sort.f @@ -0,0 +1,112 @@ + subroutine quick_sort(n1, n2, ld, exch, comp, userarg) + +C Quicksort Algorithm M. Zolliker Dec. 89 +C +C N = number of elements +C LD, EXCH and COMP are subroutines +C +C SUBROUTINE LD(I,userarg): load element no. I into a buffer +C +C SUBROUTINE EXCH(I,J,userarg): exchange elements no. I and J +C +C SUBROUTINE COMP(I, TST,userarg): compare element no. I with buffer, result is TST +C +C < < +C TST = 0 if element I = buffer +C > > +C +C for example for comparing reals: +C +C subroutine comp(i, tst) +C common buffer +C if (element(i) .ne. buffer) then +C if (element(i) .gt. buffer) then +C tst=1 +C else +C tst=-1 +C endif +C else +C tst=0 +C endif +C end +C + implicit none + integer nstack + parameter (nstack=30) ! sequence stack dim. for 2**30 elements + integer n1, n2, i, j, k, l, m, tst + integer kst(nstack), lst(nstack), nst + integer userarg + + if (n1 .ge. n2) return + + nst=0 + k=n1 + l=n2 + +C sort sequence K...L + +1 i=k + j=l + m=(k+l)/2 + call ld(m,userarg) ! load mid. element + +C increment I until an element .GE. mid. element found + +10 if (i.gt.l) goto 91 + call comp(i, tst,userarg) + if (tst .ge. 0) goto 20 + i=i+1 + goto 10 +91 stop 'QUICK_SORT: mistake in subroutine COMP, EXCH or LD' + +C decrement J until an element .LT. mid. element found + +20 if (j.lt.k) goto 91 + call comp(j, tst,userarg) + if (tst .le. 0) goto 30 + j=j-1 + goto 20 + +30 if (i .ge. j) goto 40 + call exch(i, j,userarg) + i=i+1 + j=j-1 + if (i .le. j) goto 10 + +C now all elements between K and I are .LE. mid. element +C and all elements between J and L are .GE. mid. element + +40 i=i-1 + j=j+1 + if (i-k .gt. l-j) then ! K...I sequence is longer + + if (i .gt. k) then ! if sequence longer than 1 + nst=nst+1 ! then push K,J to stack + if (nst .gt. nstack) goto 92 + kst(nst)=k + lst(nst)=i + end if + k=j ! sort sequence J...L immediately + + else ! sequence J...L is longer + + if (l .gt. j) then ! if sequence longer than 1 + nst=nst+1 ! then push J,L to stack + if (nst .gt. nstack) goto 92 + kst(nst)=j + lst(nst)=l + end if + l=i ! sort sequence K...I immediately + + end if + + if (k .lt. l) goto 1 ! if sequence longer than one then sort + +90 if (nst .eq. 0) return ! no more sequences to sort + k=kst(nst) ! pop K,L from stack + l=lst(nst) + nst=nst-1 + goto 1 + +92 stop 'QUICK_SORT: stack overflow' + end diff --git a/gen/simplex.f b/gen/simplex.f new file mode 100644 index 0000000..cb3966e --- /dev/null +++ b/gen/simplex.f @@ -0,0 +1,233 @@ + SUBROUTINE SIMPLEX +C ------------------ + +c minimization subroutine using a simple method by nelder and mead *). +c it is reasonably fast when far from minimum, and may also be used to +c converge to the exact minimum, but is mostly slower than "migrad". +c +c *) - nelder, j.a., mead, r. (1965), comput. j. 7, 308 +c - james, f., roos, m. (1985), cern documentation d506 + + include 'fit.inc' + + integer jh,jl + real p(maxpar,maxpar+1),y(maxpar+1) + common/comsim/jh,jl,y,p + + integer iflag, i, kg, ns, nf, k, ignal, ncycl, j, npfn, nparp1 + integer jhold + real rho1, rho2, alpha, beta, gamma, rhomin, rhomax, wg + real ynpp1, absmin, aming, bestx, f, sig2, pb, ystar, ystst + real y1, y2, rho, yrho, ypbar + + REAL PSTAR(MAXPAR) ,PSTST(MAXPAR) ,PBAR(MAXPAR) ,PRHO(MAXPAR) + DATA ALPHA,BETA,GAMMA,RHOMIN,RHOMAX / 1.0, 0.5, 2.0, 4.0, 8.0/ + + IF (NPAR .LE. 0) RETURN + NPFN=NFCN + NPARP1=NPAR+1 + RHO1 = 1.0 + ALPHA + RHO2 = RHO1 + ALPHA*GAMMA + WG = 1.0/FLOAT(NPAR) + IFLAG=4 + if (isyswr .ne. 0) WRITE(ISYSWR,100) EPSI + 100 FORMAT(/' Start SIMPLEX minimization' + 1/4X,'Convergence criterion: estimated distance to minimum edm <' + 1,E10.2) + + DO 2 I= 1, NPAR + IF (ISW(2) .GE. 1) DIRIN(I) = SQRT(V(I,I)*UP) + IF (ABS(DIRIN(I)) .LT. 1.0E-5*ABS(X(I))) DIRIN(I)=1.0E-5*X(I) ! was 1e-8 M.Z. 6.02 + IF(ITAUR.LT. 1) V(I,I) = DIRIN(I)**2/UP + 2 CONTINUE + IF (ITAUR .LT. 1) ISW(2) = 1 +C** CHOOSE THE INITIAL SIMPLEX USING SINGLE-PARAMETER SEARCHES + 1 CONTINUE + YNPP1 = AMIN + JL = NPARP1 + Y(NPARP1) = AMIN + ABSMIN = AMIN + DO 10 I= 1, NPAR + AMING = AMIN + PBAR(I) = X(I) + BESTX = X(I) + KG = 0 + NS = 0 + NF = 0 + 4 X(I) = BESTX + DIRIN(I) + CALL FNCTN(X,F) + NFCN = NFCN + 1 + IF (F .LE. AMING) GO TO 6 +C FAILURE + IF (KG .EQ. 1) GO TO 8 + KG = -1 + NF = NF + 1 + DIRIN(I) = DIRIN(I) * (-0.4) + IF (NF .LT. 3) GO TO 4 + NS = 6 +C SUCCESS + 6 BESTX = X(I) + DIRIN(I) = DIRIN(I) * 3.0 + AMING = F + KG = 1 + NS = NS + 1 + IF (NS .LT. 6) GO TO 4 +C LOCAL MINIMUM FOUND IN ITH DIRECTION + 8 Y(I) = AMING + IF (AMING .LT. ABSMIN) JL = I + IF (AMING .LT. ABSMIN) ABSMIN = AMING + X(I) = BESTX + DO 9 K= 1, NPAR + 9 P(K,I) = X(K) + 10 CONTINUE + JH = NPARP1 + AMIN=Y(JL) + CALL RAZZIA(YNPP1,PBAR) + DO 20 I= 1, NPAR + 20 X(I) = P(I,JL) + CALL INTOEX(X) + IF (ISW(5) .GE. 1) CALL FIT_PRINT(0) + SIGMA = SIGMA * 10. + SIG2 = SIGMA + IGNAL = 0 + NCYCL=0 +C. . . . . START MAIN LOOP + 50 CONTINUE + IF (IGNAL .GE. 10) GO TO 1 + IF (SIG2 .LT. EPSI .AND. SIGMA.LT.EPSI) GO TO 76 + SIG2 = SIGMA + IF ((NFCN-NPFN) .GT. NFCNMX) GO TO 78 +C CALCULATE NEW POINT * BY REFLECTION + DO 60 I= 1, NPAR + PB = 0. + DO 59 J= 1, NPARP1 + 59 PB = PB + WG * P(I,J) + PBAR(I) = PB - WG * P(I,JH) + 60 PSTAR(I)=(1.+ALPHA)*PBAR(I)-ALPHA*P(I,JH) + CALL FNCTN(PSTAR,YSTAR) + NFCN=NFCN+1 + IF(YSTAR.GE.AMIN) GO TO 70 +C POINT * BETTER THAN JL, CALCULATE NEW POINT ** + DO 61 I=1,NPAR + 61 PSTST(I)=GAMMA*PSTAR(I)+(1.-GAMMA)*PBAR(I) + CALL FNCTN(PSTST,YSTST) + NFCN=NFCN+1 +C TRY A PARABOLA THROUGH PH, PSTAR, PSTST. MIN = PRHO + Y1 = (YSTAR-Y(JH)) * RHO2 + Y2 = (YSTST-Y(JH)) * RHO1 + RHO = 0.5 * (RHO2*Y1 -RHO1*Y2) / (Y1 -Y2) + IF (RHO .LT. RHOMIN) GO TO 66 + IF (RHO .GT. RHOMAX) RHO = RHOMAX + DO 64 I= 1, NPAR + 64 PRHO(I) = RHO*PSTAR(I) + (1. -RHO)*P(I,JH) + CALL FNCTN(PRHO,YRHO) + NFCN = NFCN + 1 + IF (YRHO .LT. Y(JL) .AND. YRHO .LT. YSTST) GO TO 65 + IF (YSTST .LT. Y(JL)) GO TO 67 + IF (YRHO .GT. Y(JL)) GO TO 66 +C ACCEPT MINIMUM POINT OF PARABOLA, PRHO + 65 CALL RAZZIA (YRHO,PRHO) + IGNAL = MAX0(IGNAL-2, 0) + GO TO 68 + 66 IF (YSTST .LT. Y(JL)) GO TO 67 + IGNAL = MAX0(IGNAL-1, 0) + CALL RAZZIA(YSTAR,PSTAR) + GO TO 68 + 67 IGNAL = MAX0(IGNAL-2, 0) + 675 CALL RAZZIA(YSTST,PSTST) + 68 NCYCL=NCYCL+1 + IF (ISW(5) .LT. 2) GO TO 50 + IF (ISW(5) .GE. 3 .OR. MOD(NCYCL, 10) .EQ. 0) CALL FIT_PRINT(0) + GO TO 50 +C POINT * IS NOT AS GOOD AS JL + 70 IF (YSTAR .GE. Y(JH)) GO TO 73 + JHOLD = JH + CALL RAZZIA(YSTAR,PSTAR) + IF (JHOLD .NE. JH) GO TO 50 +C CALCULATE NEW POINT ** + 73 DO 74 I=1,NPAR + 74 PSTST(I)=BETA*P(I,JH)+(1.-BETA)*PBAR(I) + CALL FNCTN (PSTST,YSTST) + NFCN=NFCN+1 + IF(YSTST.GT.Y(JH)) GO TO 1 +C POINT ** IS BETTER THAN JH + IF (YSTST .LT. AMIN) GO TO 675 + IGNAL = IGNAL + 1 + CALL RAZZIA(YSTST,PSTST) + GO TO 50 +C. . . . . . END MAIN LOOP + 76 if (isyswr .ne. 0) WRITE(ISYSWR,120) +120 format(/' SIMPLEX minimization has converged') + GO TO 80 + 78 if (nfcnmx .eq. 0) then + if (isyswr .ne. 0) write(isyswr,'(/a)') ' SIMPLEX aborted' + else + if (isyswr .ne. 0) WRITE(ISYSWR,130) +130 format(/' SIMPLEX terminates without convergence') + endif + ISW(1) = 1 + 80 DO 82 I=1,NPAR + PB = 0. + DO 81 J=1,NPARP1 + 81 PB = PB + WG * P(I,J) + 82 PBAR(I) = PB - WG * P(I,JH) + CALL FNCTN(PBAR,YPBAR) + NFCN=NFCN+1 + IF (YPBAR .LT. AMIN) CALL RAZZIA(YPBAR,PBAR) + IF (NFCNMX+NPFN-NFCN .LT. 3*NPAR) GO TO 90 + IF (SIGMA .GT. 2.0*EPSI) GO TO 1 + 90 CALL FNCTN(X,AMIN) + NFCN = NFCN + 1 + CALL FIT_PRINT(1-ITAUR) + RETURN + END + + SUBROUTINE RAZZIA(YNEW,PNEW) +C ------------------------------ + + include 'fit.inc' + + integer jh,jl + real p(maxpar,maxpar+1),y(maxpar+1) + common/comsim/jh,jl,y,p + + integer i, nparp1, j + real ynew, us, pbig, plit + real PNEW(MAXPAR) + + DO 10 I=1,NPAR +10 P(I,JH)=PNEW(I) + Y(JH)=YNEW + IF(YNEW.GE.AMIN) GO TO 18 + DO 15 I=1,NPAR +15 X(I)=PNEW(I) + CALL INTOEX(X) + AMIN=YNEW + JL=JH +18 CONTINUE + JH=1 + NPARP1=NPAR+1 +20 DO 25 J=2,NPARP1 + IF (Y(J) .GT. Y(JH)) JH = J +25 CONTINUE + SIGMA = Y(JH) - Y(JL) + IF (SIGMA .LE. 0.) GO TO 45 + US = 1.0/SIGMA + DO 35 I= 1, NPAR + PBIG = P(I,1) + PLIT = PBIG + DO 30 J= 2, NPARP1 + IF (P(I,J) .GT. PBIG) PBIG = P(I,J) + IF (P(I,J) .LT. PLIT) PLIT = P(I,J) + 30 CONTINUE + DIRIN(I) = PBIG - PLIT + IF (ITAUR .LT. 1 ) V(I,I) = 0.5*(V(I,I) +US*DIRIN(I)**2) + 35 CONTINUE + 40 RETURN + 45 WRITE (ISYSWR, 1000) NPAR + GO TO 40 +1000 FORMAT ( + 1 ' ***** FUNCTION VALUE DOES NOT SEEM TO DEPEND ON ANY OF THE ' + 1, I3,' VARIABLE PARAMETERS'/15X,'VERIFY THAT STEP SIZES ARE' + 1,' BIG ENOUGH AND CHECK FUN LOGIC.'/1X, 79('*')/1X,79('H')///) + END diff --git a/gen/str.f b/gen/str.f new file mode 100644 index 0000000..9fca647 --- /dev/null +++ b/gen/str.f @@ -0,0 +1,286 @@ +!! string handling +!! + subroutine STR_TRIM(RETSTR, STR, RETLEN) !! +!! +!! if RETSTR=STR then RETSTR is not touched +!! +!! Arguments: + character*(*) STR, RETSTR !! in,out + integer RETLEN !! out + integer i + + i=len(str) + if (str(1:1) .gt. ' ') then +10 if (str(i:i) .le. ' ') then + i=i-1 + goto 10 + endif + else +20 if (str(i:i) .le. ' ') then + if (i .gt. 1) then + i=i-1 + goto 20 + endif + endif + endif + retlen=min(len(retstr),i) + if (retstr .ne. str) then ! avoid copy to retstr if equal + retstr=str(1:i) + endif + end + +!! + subroutine STR_UPCASE(RETSTR, STR) !! +!! +!! Arguments: + character STR*(*), RETSTR*(*) !! in,out + integer i, ch + + retstr=str + do i=1,len(retstr) + ch=ichar(retstr(i:i)) + if (ch .ge. ichar('a') .and. ch .le. ichar('z')) then + retstr(i:i)=char(ch-(ichar('a')-ichar('A'))) + endif + enddo + end + +!! + subroutine STR_LOWCASE(RETSTR, STR) !! +!! +!! Arguments: + character STR*(*), RETSTR*(*) !! in,out + integer i, ch + + retstr=str + do i=1,len(retstr) + ch=ichar(retstr(i:i)) + if (ch .ge. ichar('A') .and. ch .le. ichar('Z')) then + retstr(i:i)=char(ch+(ichar('a')-ichar('A'))) + endif + enddo + end + +!! + subroutine STR_APPEND(str, length, add) !! +!! + implicit none + + character*(*) str, add !! + integer length !! + + if (len(add)+length .gt. len(str)) then + if (length .lt. len(str)) then + str(length+1:)=add + length=len(str) + endif + else + str(length+1:length+len(add))=add + length=length+len(add) + endif + end + +!! + integer function STR_CMP(str1, str2) !! +!! +!! if strings are equal: return 0 +!! else return position of first different character + + character str1*(*), str2*(*) !! + + integer i + + do i=0,min(len(str1),len(str2))-1 + if (str1(i+1:i+1) .ne. str2(i+1:i+1)) then + str_cmp=i+1 + return + endif + enddo + do i=len(str1),len(str2)-1 + if (str2(i+1:i+1) .ne. ' ') then + str_cmp=i+1 + return + endif + enddo + do i=len(str2),len(str1)-1 + if (str1(i+1:i+1) .ne. ' ') then + str_cmp=i+1 + return + endif + enddo + str_cmp=0 + return + end + +!! + subroutine STR_FIRST_NONBLANK(STR, POS) !! +!! +!! Arguments: + character*(*) STR !! in + integer POS !! out + integer i + + do i=1,len(str) + if (str(i:i) .gt. ' ') then + pos=i + return + endif + enddo + pos=0 + end + +!! + subroutine STR_SPLIT(STR, DELIM, START, ENDE) !! +!! +!! split string into sequences separated by DELIM +!! for the first sequence set ENDE=0 and START=0 (or START=n for other start position n+1) +!! result: end of list: ENDE=-1 +!! empty sequence: START=ENDE+1 +!! normal sequence: STR(START:ENDE) without delimiter +!! +!! if ENDE has not a legal value, nothing happens + + character STR*(*), DELIM*(*) !! (in) string, delimiter + integer START, ENDE !! (in/out) start/end position + + integer i + + if (ende .lt. 0 .or. ende .ge. len(str) .or. start .lt. 0) then + ende=-1 + RETURN + endif + if (ende .ne. 0) start=ende+len(delim) + if (start .ge. len(str)) then + if (start .gt. len(str)) then + ende=-1 + RETURN + endif + i=0 + else + i=index(str(start+1:), delim) + endif + if (i .eq. 0) then + ende=len(str) + else + ende=start+i-1 + endif + start=start+1 + end + +!! + subroutine STR_GET_ELEM(STR, POS, ELEM) !! +!! +!! reads next element ELEM from string STR(POS:). Elements are separated by +!! spaces combined with one control-char (assume tab) or one comma. +!! return ' ' when STR(POS:) contains only whitespace or when pos is to high +!! + character STR*(*) !! (in) input string + character ELEM*(*) !! (out) element read + integer POS !! (in/out) read position + + integer start + + +1 if (pos .gt. len(str)) then + elem=' ' + RETURN + endif + if (str(pos:pos) .eq. ' ') then + pos=pos+1 + goto 1 + endif + start=pos +2 if (str(pos:pos) .gt. ' ' .and. str(pos:pos) .ne. ',') then + pos=pos+1 + if (pos .le. len(str)) then + goto 2 + endif + pos=pos-1 + endif + if (str(pos:pos) .eq. ',' .or. str(pos:pos) .lt. ' ') then + if (start .eq. pos) then + elem=str(start:pos) + if (elem(1:1) .lt. ' ') elem(1:1)=' ' + else + elem=str(start:pos-1) + endif + pos=pos+1 + RETURN + endif + elem=str(start:pos-1) + if (str(pos:) .eq. ' ') then + RETURN + endif +3 if (str(pos:pos) .eq. ' ') then + pos=pos+1 + if (pos .gt. len(str)) stop 'STR_GET_ELEM: assertion failed' + goto 3 + endif + if (str(pos:pos) .eq. ',' .or. str(pos:pos) .lt. ' ') then + pos=pos+1 + endif + end + +!! + subroutine STR_GET_WORD(STR, POS, WORD) !! +!! +!! reads next WORD from string STR(POS:). Words are separated by +!! whitespace. +!! return ' ' when STR(POS:) contains only whitespace or when pos is to high +!! + character STR*(*) !! (in) input string + character WORD*(*) !! (out) element read + integer POS !! (in/out) read position + + integer start + integer i + +1 if (pos .gt. len(str)) then + word=' ' + RETURN + endif + if (str(pos:pos) .le. ' ') then + pos=pos+1 + goto 1 + endif + start=pos + do i=pos,len(str) + if (str(i:i) .le. ' ') then + pos=i + word=str(start:i-1) + RETURN + endif + enddo + word=str(start:) + pos=len(str)+1 + RETURN + end + +!! + integer function STR_FIND_ELEM(STR, ELEM) !! +!! +!! find column index of element ELEM (case insensitive) +!! only the first 64 chars of each element are checked +!! 0 is returned when not found +!! + character STR*(*), ELEM*(*) + character ups*64, upe*64 + integer pos, idx + + pos=1 + call str_upcase(upe, elem) + idx=0 + + call str_get_elem(str, pos, ups) + do while (ups .ne. ' ') + idx=idx+1 + call str_upcase(ups, ups) + if (ups .eq. upe) then + str_find_elem=idx + RETURN + endif + call str_get_elem(str, pos, ups) + enddo + str_find_elem=0 + RETURN + end diff --git a/gen/sys_util.h b/gen/sys_util.h new file mode 100644 index 0000000..e75d59c --- /dev/null +++ b/gen/sys_util.h @@ -0,0 +1,58 @@ +#ifndef _SYS_UTIL_H_ +#define _SYS_UTIL_H_ + +/* + + fortran interface stuff + + declare fortran character arguments as F_CHAR(arg) + and at at the end for each character argument add + int _len to the argument list + + Use macros STR_TO_C and STR_TO_F to convert from Fortran character strings + to C character arrays and vice versa. + +*/ + + +#if defined __VMS + +typedef struct { short size, dummy; char *text; } SysVmsChar; + +#define F_CHAR(VAR) SysVmsChar *VAR +#define F_DCHAR(VAR,LEN) static char VAR##_str[LEN]; SysVmsChar VAR##_desc={LEN,270,&VAR##_str[0]}; SysVmsChar *VAR=&VAR##_desc +#define F_CLEN(VAR) +#define F_ALEN(VAR) +#define F_LEN(VAR) VAR->size +#define STR_TO_C(DST,SRC) str_ntrim(DST, SRC->text, sizeof(DST), SRC->size) +#define STR_TO_F(DST,SRC) str_npad(DST->text, SRC, DST->size) +#define F_FUN(A) A + + +#elif defined __alpha || defined __unix || defined __GNUC__ + +#define F_CHAR(VAR) char *VAR +#define F_DCHAR(VAR,LEN) char VAR[LEN]; int VAR##_len=LEN +#define F_CLEN(VAR) ,int VAR##_len +#define F_ALEN(VAR) ,VAR##_len +#define F_LEN(VAR) VAR##_len +#define STR_TO_C(DST,SRC) str_ntrim(DST, SRC, sizeof(DST), SRC##_len) +#define STR_TO_F(DST,SRC) str_npad(DST, SRC, DST##_len) + +#ifdef __alpha +#define F_FUN(A) A##_ +#elif defined __GNUC__ +#define F_FUN(A) A##__ +#elif defined __INTEL_COMPILER +#define F_FUN(A) A##_ +#else +#define F_FUN(A) A##__ +#endif + +#else + +"other machines are not supported" + +#endif + +#endif /* _SYS_UTIL_H_ */ diff --git a/gen/zm_fit b/gen/zm_fit new file mode 100644 index 0000000..2b71f58 --- /dev/null +++ b/gen/zm_fit @@ -0,0 +1 @@ +this file is used by config diff --git a/libs/CVS/Entries b/libs/CVS/Entries new file mode 100644 index 0000000..3051003 --- /dev/null +++ b/libs/CVS/Entries @@ -0,0 +1 @@ +D/cygwin//// diff --git a/libs/CVS/Repository b/libs/CVS/Repository new file mode 100644 index 0000000..90d781f --- /dev/null +++ b/libs/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/libs diff --git a/libs/CVS/Root b/libs/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/libs/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/libs/cygwin/CVS/Entries b/libs/cygwin/CVS/Entries new file mode 100644 index 0000000..4cfb7a4 --- /dev/null +++ b/libs/cygwin/CVS/Entries @@ -0,0 +1,2 @@ +D/include//// +D/lib//// diff --git a/libs/cygwin/CVS/Repository b/libs/cygwin/CVS/Repository new file mode 100644 index 0000000..af6d51c --- /dev/null +++ b/libs/cygwin/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/libs/cygwin diff --git a/libs/cygwin/CVS/Root b/libs/cygwin/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/libs/cygwin/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/libs/cygwin/include/CVS/Entries b/libs/cygwin/include/CVS/Entries new file mode 100644 index 0000000..dbaac50 --- /dev/null +++ b/libs/cygwin/include/CVS/Entries @@ -0,0 +1,40 @@ +/H5ACpublic.h/1.1.1.1/Tue Nov 2 15:54:57 2004// +/H5Apublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Bpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Dpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Epublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDcore.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDfamily.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDgass.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDlog.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDmpi.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDmpio.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDmpiposix.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDmulti.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDsec2.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDsrb.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDstdio.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5FDstream.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Fpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Gpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5HGpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5HLpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Ipublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5MMpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Opublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Ppublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Rpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Spublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Tpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5Zpublic.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5api_adpt.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5pubconf.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/H5public.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/hdf5.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/napi.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/napi4.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/napi5.h/1.1.1.1/Tue Nov 2 15:54:58 2004// +/napif.inc/1.1.1.1/Tue Nov 2 15:54:58 2004// +/napif__.inc/1.1.1.1/Tue Nov 2 15:54:58 2004// +D diff --git a/libs/cygwin/include/CVS/Repository b/libs/cygwin/include/CVS/Repository new file mode 100644 index 0000000..f0120ea --- /dev/null +++ b/libs/cygwin/include/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/libs/cygwin/include diff --git a/libs/cygwin/include/CVS/Root b/libs/cygwin/include/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/libs/cygwin/include/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/libs/cygwin/include/H5ACpublic.h b/libs/cygwin/include/H5ACpublic.h new file mode 100755 index 0000000..9eb5156 --- /dev/null +++ b/libs/cygwin/include/H5ACpublic.h @@ -0,0 +1,40 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/*------------------------------------------------------------------------- + * + * Created: H5ACproto.h + * Jul 10 1997 + * Robb Matzke + * + * Purpose: Public include file for cache functions. + * + * Modifications: + * + *------------------------------------------------------------------------- + */ +#ifndef _H5ACpublic_H +#define _H5ACpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Apublic.h b/libs/cygwin/include/H5Apublic.h new file mode 100755 index 0000000..c7478d8 --- /dev/null +++ b/libs/cygwin/include/H5Apublic.h @@ -0,0 +1,53 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5A module. + */ +#ifndef _H5Apublic_H +#define _H5Apublic_H + +/* Public headers needed by this file */ +#include "H5Ipublic.h" + +#ifdef __cplusplus +extern "C" { +#endif + +typedef herr_t (*H5A_operator_t)(hid_t location_id/*in*/, + const char *attr_name/*in*/, void *operator_data/*in,out*/); + +/* Public function prototypes */ +H5_DLL hid_t H5Acreate(hid_t loc_id, const char *name, hid_t type_id, + hid_t space_id, hid_t plist_id); +H5_DLL hid_t H5Aopen_name(hid_t loc_id, const char *name); +H5_DLL hid_t H5Aopen_idx(hid_t loc_id, unsigned idx); +H5_DLL herr_t H5Awrite(hid_t attr_id, hid_t type_id, const void *buf); +H5_DLL herr_t H5Aread(hid_t attr_id, hid_t type_id, void *buf); +H5_DLL herr_t H5Aclose(hid_t attr_id); +H5_DLL hid_t H5Aget_space(hid_t attr_id); +H5_DLL hid_t H5Aget_type(hid_t attr_id); +H5_DLL ssize_t H5Aget_name(hid_t attr_id, size_t buf_size, char *buf); +H5_DLL hsize_t H5Aget_storage_size(hid_t attr_id); +H5_DLL int H5Aget_num_attrs(hid_t loc_id); +H5_DLL herr_t H5Arename(hid_t loc_id, const char *old_name, const char *new_name); +H5_DLL herr_t H5Aiterate(hid_t loc_id, unsigned *attr_num, H5A_operator_t op, + void *op_data); +H5_DLL herr_t H5Adelete(hid_t loc_id, const char *name); + +#ifdef __cplusplus +} +#endif + +#endif /* _H5Apublic_H */ diff --git a/libs/cygwin/include/H5Bpublic.h b/libs/cygwin/include/H5Bpublic.h new file mode 100755 index 0000000..26bac99 --- /dev/null +++ b/libs/cygwin/include/H5Bpublic.h @@ -0,0 +1,51 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/*------------------------------------------------------------------------- + * + * Created: H5Bproto.h + * Jul 10 1997 + * Robb Matzke + * + * Purpose: Public declarations for the H5B package. + * + * Modifications: + * + *------------------------------------------------------------------------- + */ +#ifndef _H5Bpublic_H +#define _H5Bpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +/* B-tree IDs for various internal things. */ +/* Not really a "public" symbol, but that should be OK -QAK */ +/* Note - if more of these are added, any 'K' values (for internal or leaf + * nodes) they use will need to be stored in the file somewhere. -QAK + */ +typedef enum H5B_subid_t { + H5B_SNODE_ID = 0, /*B-tree is for symbol table nodes */ + H5B_ISTORE_ID = 1, /*B-tree is for indexed object storage */ + H5B_NUM_BTREE_ID /* Number of B-tree key IDs (must be last) */ +} H5B_subid_t; + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Dpublic.h b/libs/cygwin/include/H5Dpublic.h new file mode 100755 index 0000000..5987b79 --- /dev/null +++ b/libs/cygwin/include/H5Dpublic.h @@ -0,0 +1,105 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5D module. + */ +#ifndef _H5Dpublic_H +#define _H5Dpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" +#include "H5Ipublic.h" + +/* Values for the H5D_LAYOUT property */ +typedef enum H5D_layout_t { + H5D_LAYOUT_ERROR = -1, + + H5D_COMPACT = 0, /*raw data is very small */ + H5D_CONTIGUOUS = 1, /*the default */ + H5D_CHUNKED = 2, /*slow and fancy */ + H5D_NLAYOUTS = 3 /*this one must be last! */ +} H5D_layout_t; + +/* Values for the space allocation time property */ +typedef enum H5D_alloc_time_t { + H5D_ALLOC_TIME_ERROR =-1, + H5D_ALLOC_TIME_DEFAULT =0, + H5D_ALLOC_TIME_EARLY =1, + H5D_ALLOC_TIME_LATE =2, + H5D_ALLOC_TIME_INCR =3 +} H5D_alloc_time_t; + +/* Values for the status of space allocation */ +typedef enum H5D_space_status_t { + H5D_SPACE_STATUS_ERROR =-1, + H5D_SPACE_STATUS_NOT_ALLOCATED =0, + H5D_SPACE_STATUS_PART_ALLOCATED =1, + H5D_SPACE_STATUS_ALLOCATED =2 +} H5D_space_status_t; + +/* Values for time of writing fill value property */ +typedef enum H5D_fill_time_t { + H5D_FILL_TIME_ERROR =-1, + H5D_FILL_TIME_ALLOC =0, + H5D_FILL_TIME_NEVER =1, + H5D_FILL_TIME_IFSET =2 +} H5D_fill_time_t; + +/* Values for fill value status */ +typedef enum H5D_fill_value_t { + H5D_FILL_VALUE_ERROR =-1, + H5D_FILL_VALUE_UNDEFINED =0, + H5D_FILL_VALUE_DEFAULT =1, + H5D_FILL_VALUE_USER_DEFINED =2 +} H5D_fill_value_t; + +#ifdef __cplusplus +extern "C" { +#endif + +/* Define the operator function pointer for H5Diterate() */ +typedef herr_t (*H5D_operator_t)(void *elem, hid_t type_id, hsize_t ndim, + hssize_t *point, void *operator_data); + +H5_DLL hid_t H5Dcreate (hid_t file_id, const char *name, hid_t type_id, + hid_t space_id, hid_t plist_id); +H5_DLL hid_t H5Dopen (hid_t file_id, const char *name); +H5_DLL herr_t H5Dclose (hid_t dset_id); +H5_DLL hid_t H5Dget_space (hid_t dset_id); +H5_DLL herr_t H5Dget_space_status(hid_t dset_id, + H5D_space_status_t *allocation); +H5_DLL hid_t H5Dget_type (hid_t dset_id); +H5_DLL hid_t H5Dget_create_plist (hid_t dset_id); +H5_DLL hsize_t H5Dget_storage_size(hid_t dset_id); +H5_DLL haddr_t H5Dget_offset(hid_t dset_id); +H5_DLL herr_t H5Dread (hid_t dset_id, hid_t mem_type_id, hid_t mem_space_id, + hid_t file_space_id, hid_t plist_id, void *buf/*out*/); +H5_DLL herr_t H5Dwrite (hid_t dset_id, hid_t mem_type_id, hid_t mem_space_id, + hid_t file_space_id, hid_t plist_id, const void *buf); +H5_DLL herr_t H5Dextend (hid_t dset_id, const hsize_t *size); +H5_DLL herr_t H5Diterate(void *buf, hid_t type_id, hid_t space_id, + H5D_operator_t op, void *operator_data); +H5_DLL herr_t H5Dvlen_reclaim(hid_t type_id, hid_t space_id, hid_t plist_id, void *buf); +H5_DLL herr_t H5Dvlen_get_buf_size(hid_t dataset_id, hid_t type_id, hid_t space_id, hsize_t *size); +H5_DLL herr_t H5Dfill(const void *fill, hid_t fill_type, void *buf, + hid_t buf_type, hid_t space); +H5_DLL herr_t H5Ddebug(hid_t dset_id, unsigned int flags); +H5_DLL herr_t H5Dset_extent (hid_t dset_id, const hsize_t *size); + + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Epublic.h b/libs/cygwin/include/H5Epublic.h new file mode 100755 index 0000000..3ac6fd0 --- /dev/null +++ b/libs/cygwin/include/H5Epublic.h @@ -0,0 +1,263 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5E module. + */ +#ifndef _H5Epublic_H +#define _H5Epublic_H + +#include /*FILE arg of H5Eprint() */ + +/* Public headers needed by this file */ +#include "H5public.h" +#include "H5Ipublic.h" + +/* + * One often needs to temporarily disable automatic error reporting when + * trying something that's likely or expected to fail. For instance, to + * determine if an object exists one can call H5Gget_objinfo() which will fail if + * the object doesn't exist. The code to try can be nested between calls to + * H5Eget_auto() and H5Eset_auto(), but it's easier just to use this macro + * like: + * H5E_BEGIN_TRY { + * ...stuff here that's likely to fail... + * } H5E_END_TRY; + * + * Warning: don't break, return, or longjmp() from the body of the loop or + * the error reporting won't be properly restored! + */ +#define H5E_BEGIN_TRY { \ + H5E_auto_t H5E_saved_efunc; \ + void *H5E_saved_edata; \ + H5Eget_auto (&H5E_saved_efunc, &H5E_saved_edata); \ + H5Eset_auto (NULL, NULL); + +#define H5E_END_TRY \ + H5Eset_auto (H5E_saved_efunc, H5E_saved_edata); \ +} + +/* + * Public API Convenience Macros for Error reporting - Documented + */ +/* Use the Standard C __FILE__ & __LINE__ macros instead of typing them in */ +#define H5Epush_sim(func,maj,min,str) H5Epush(__FILE__,func,__LINE__,maj,min,str) + +/* + * Public API Convenience Macros for Error reporting - Undocumented + */ +/* Use the Standard C __FILE__ & __LINE__ macros instead of typing them in */ +/* And return after pushing error onto stack */ +#define H5Epush_ret(func,maj,min,str,ret) { \ + H5Epush(__FILE__,func,__LINE__,maj,min,str); \ + return(ret); \ +} + +/* Use the Standard C __FILE__ & __LINE__ macros instead of typing them in */ +/* And goto a label after pushing error onto stack */ +#define H5Epush_goto(func,maj,min,str,label) { \ + H5Epush(__FILE__,func,__LINE__,maj,min,str); \ + goto label; \ +} + +/* + * Declare an enumerated type which holds all the valid major HDF error codes. + */ +typedef enum H5E_major_t { + H5E_NONE_MAJOR = 0, /*special zero, no error */ + H5E_ARGS, /*invalid arguments to routine */ + H5E_RESOURCE, /*resource unavailable */ + H5E_INTERNAL, /* Internal error (too specific to document + * in detail) + */ + H5E_FILE, /*file Accessability */ + H5E_IO, /*Low-level I/O */ + H5E_FUNC, /*function Entry/Exit */ + H5E_ATOM, /*object Atom */ + H5E_CACHE, /*object Cache */ + H5E_BTREE, /*B-Tree Node */ + H5E_SYM, /*symbol Table */ + H5E_HEAP, /*Heap */ + H5E_OHDR, /*object Header */ + H5E_DATATYPE, /*Datatype */ + H5E_DATASPACE, /*Dataspace */ + H5E_DATASET, /*Dataset */ + H5E_STORAGE, /*data storage */ + H5E_PLIST, /*Property lists */ + H5E_ATTR, /*Attribute */ + H5E_PLINE, /*Data filters */ + H5E_EFL, /*External file list */ + H5E_REFERENCE, /*References */ + H5E_VFL, /*Virtual File Layer */ + H5E_TBBT, /*Threaded, Balanced, Binary Trees */ + H5E_FPHDF5, /*Flexible Parallel HDF5 */ + H5E_TST, /*Ternary Search Trees */ + H5E_RS /*Reference Counted Strings */ +} H5E_major_t; + +/* Declare an enumerated type which holds all the valid minor HDF error codes */ +typedef enum H5E_minor_t { + H5E_NONE_MINOR = 0, /*special zero, no error */ + + /* Argument errors */ + H5E_UNINITIALIZED, /*information is unitialized */ + H5E_UNSUPPORTED, /*feature is unsupported */ + H5E_BADTYPE, /*incorrect type found */ + H5E_BADRANGE, /*argument out of range */ + H5E_BADVALUE, /*bad value for argument */ + + /* Resource errors */ + H5E_NOSPACE, /*no space available for allocation */ + H5E_CANTCOPY, /*unable to copy object */ + H5E_CANTFREE, /*unable to free object */ + H5E_ALREADYEXISTS, /*Object already exists */ + H5E_CANTLOCK, /*Unable to lock object */ + H5E_CANTUNLOCK, /*Unable to unlock object */ + + /* File accessability errors */ + H5E_FILEEXISTS, /*file already exists */ + H5E_FILEOPEN, /*file already open */ + H5E_CANTCREATE, /*Can't create file */ + H5E_CANTOPENFILE, /*Can't open file */ + H5E_CANTCLOSEFILE, /*Can't close file */ + H5E_NOTHDF5, /*not an HDF5 format file */ + H5E_BADFILE, /*bad file ID accessed */ + H5E_TRUNCATED, /*file has been truncated */ + H5E_MOUNT, /*file mount error */ + + /* Generic low-level file I/O errors */ + H5E_SEEKERROR, /*seek failed */ + H5E_READERROR, /*read failed */ + H5E_WRITEERROR, /*write failed */ + H5E_CLOSEERROR, /*close failed */ + H5E_OVERFLOW, /*address overflowed */ + H5E_FCNTL, /*file fcntl failed */ + + /* Function entry/exit interface errors */ + H5E_CANTINIT, /*Can't initialize object */ + H5E_ALREADYINIT, /*object already initialized */ + H5E_CANTRELEASE, /*Can't release object */ + + /* Object atom related errors */ + H5E_BADATOM, /*Can't find atom information */ + H5E_BADGROUP, /*Can't find group information */ + H5E_CANTREGISTER, /*Can't register new atom */ + H5E_CANTINC, /*Can't increment reference count */ + H5E_CANTDEC, /*Can't decrement reference count */ + H5E_NOIDS, /*Out of IDs for group */ + + /* Cache related errors */ + H5E_CANTFLUSH, /*Can't flush object from cache */ + H5E_CANTLOAD, /*Can't load object into cache */ + H5E_PROTECT, /*protected object error */ + H5E_NOTCACHED, /*object not currently cached */ + + /* B-tree related errors */ + H5E_NOTFOUND, /*object not found */ + H5E_EXISTS, /*object already exists */ + H5E_CANTENCODE, /*Can't encode value */ + H5E_CANTDECODE, /*Can't decode value */ + H5E_CANTSPLIT, /*Can't split node */ + H5E_CANTINSERT, /*Can't insert object */ + H5E_CANTLIST, /*Can't list node */ + + /* Object header related errors */ + H5E_LINKCOUNT, /*bad object header link count */ + H5E_VERSION, /*wrong version number */ + H5E_ALIGNMENT, /*alignment error */ + H5E_BADMESG, /*unrecognized message */ + H5E_CANTDELETE, /* Can't delete message */ + + /* Group related errors */ + H5E_CANTOPENOBJ, /*Can't open object */ + H5E_COMPLEN, /*name component is too long */ + H5E_CWG, /*problem with current working group */ + H5E_LINK, /*link count failure */ + H5E_SLINK, /*symbolic link error */ + + /* Datatype conversion errors */ + H5E_CANTCONVERT, /*Can't convert datatypes */ + H5E_BADSIZE, /*Bad size for object */ + + /* Dataspace errors */ + H5E_CANTCLIP, /*Can't clip hyperslab region */ + H5E_CANTCOUNT, /*Can't count elements */ + H5E_CANTSELECT, /*Can't select hyperslab */ + H5E_CANTNEXT, /*Can't move to next iterator location */ + H5E_BADSELECT, /*Invalid selection */ + H5E_CANTCOMPARE, /*Can't compare objects */ + + /* Property list errors */ + H5E_CANTGET, /*Can't get value */ + H5E_CANTSET, /*Can't set value */ + H5E_DUPCLASS, /*Duplicate class name in parent class */ + + /* Parallel errors */ + H5E_MPI, /*some MPI function failed */ + H5E_MPIERRSTR, /*MPI Error String */ + + /* FPHDF5 errors */ + H5E_CANTMAKETREE, /*can't make a TBBT tree */ + H5E_CANTRECV, /*can't receive messages from processes */ + H5E_CANTSENDMDATA, /*can't send metadata message */ + H5E_CANTCHANGE, /*can't register change on server */ + H5E_CANTALLOC, /*can't allocate from file */ + + /* I/O pipeline errors */ + H5E_NOFILTER, /*requested filter is not available */ + H5E_CALLBACK, /*callback failed */ + H5E_CANAPPLY, /*error from filter "can apply" callback */ + H5E_SETLOCAL, /*error from filter "set local" callback */ + H5E_NOENCODER /* Filter present, but encoding disabled */ +} H5E_minor_t; + +/* Information about an error */ +typedef struct H5E_error_t { + H5E_major_t maj_num; /*major error number */ + H5E_minor_t min_num; /*minor error number */ + const char *func_name; /*function in which error occurred */ + const char *file_name; /*file in which error occurred */ + unsigned line; /*line in file where error occurs */ + const char *desc; /*optional supplied description */ +} H5E_error_t; + +/* Error stack traversal direction */ +typedef enum H5E_direction_t { + H5E_WALK_UPWARD = 0, /*begin deep, end at API function */ + H5E_WALK_DOWNWARD = 1 /*begin at API function, end deep */ +} H5E_direction_t; + +#ifdef __cplusplus +extern "C" { +#endif + +/* Error stack traversal callback function */ +typedef herr_t (*H5E_walk_t)(int n, H5E_error_t *err_desc, void *client_data); +typedef herr_t (*H5E_auto_t)(void *client_data); + +H5_DLL herr_t H5Eset_auto (H5E_auto_t func, void *client_data); +H5_DLL herr_t H5Eget_auto (H5E_auto_t *func, void **client_data); +H5_DLL herr_t H5Eclear (void); +H5_DLL herr_t H5Eprint (FILE *stream); +H5_DLL herr_t H5Ewalk (H5E_direction_t direction, H5E_walk_t func, + void *client_data); +H5_DLL const char *H5Eget_major (H5E_major_t major_number); +H5_DLL const char *H5Eget_minor (H5E_minor_t minor_number); +H5_DLL herr_t H5Epush(const char *file, const char *func, + unsigned line, H5E_major_t maj, H5E_minor_t min, const char *str); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5FDcore.h b/libs/cygwin/include/H5FDcore.h new file mode 100755 index 0000000..0960425 --- /dev/null +++ b/libs/cygwin/include/H5FDcore.h @@ -0,0 +1,41 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, August 2, 1999 + * + * Purpose: The public header file for the sec2 driver. + */ +#ifndef H5FDcore_H +#define H5FDcore_H + +#include "H5Ipublic.h" + +#define H5FD_CORE (H5FD_core_init()) + +#ifdef __cplusplus +extern "C" { +#endif +H5_DLL hid_t H5FD_core_init(void); +H5_DLL void H5FD_core_term(void); +H5_DLL herr_t H5Pset_fapl_core(hid_t fapl_id, size_t increment, + hbool_t backing_store); +H5_DLL herr_t H5Pget_fapl_core(hid_t fapl_id, size_t *increment/*out*/, + hbool_t *backing_store/*out*/); +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libs/cygwin/include/H5FDfamily.h b/libs/cygwin/include/H5FDfamily.h new file mode 100755 index 0000000..c774bdb --- /dev/null +++ b/libs/cygwin/include/H5FDfamily.h @@ -0,0 +1,43 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, August 4, 1999 + * + * Purpose: The public header file for the family driver. + */ +#ifndef H5FDfamily_H +#define H5FDfamily_H + +#include "H5Ipublic.h" + +#define H5FD_FAMILY (H5FD_family_init()) + +#ifdef __cplusplus +extern "C" { +#endif + +H5_DLL hid_t H5FD_family_init(void); +H5_DLL void H5FD_family_term(void); +H5_DLL herr_t H5Pset_fapl_family(hid_t fapl_id, hsize_t memb_size, + hid_t memb_fapl_id); +H5_DLL herr_t H5Pget_fapl_family(hid_t fapl_id, hsize_t *memb_size/*out*/, + hid_t *memb_fapl_id/*out*/); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libs/cygwin/include/H5FDgass.h b/libs/cygwin/include/H5FDgass.h new file mode 100755 index 0000000..1d599a0 --- /dev/null +++ b/libs/cygwin/include/H5FDgass.h @@ -0,0 +1,69 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Saurabh Bagchi + * Tuesday, August 17, 1999 + * + * Purpose: The public header file for the gass driver. + */ +#ifndef H5FDgass_H +#define H5FDgass_H + +#include "H5FDpublic.h" +#include "H5Ipublic.h" + +#include + +#ifdef H5_HAVE_GASS +#define H5FD_GASS (H5FD_gass_init()) +#else +#define H5FD_GASS (-1) +#endif + +#ifdef H5_HAVE_GASS +/* Define the GASS info object. (Will be added to later as more GASS + functionality is sought to be exposed. */ +typedef struct GASS_Info { + unsigned long block_size; + unsigned long max_length; +} GASS_Info; + +#define GASS_INFO_NULL(v) memset((void *)&v, 0, sizeof(GASS_Info)); +/* + GASS_Info zzGassInfo = {0L,0L}; + #define GASS_INFO_NULL zzGassInfo +*/ +#endif + +/* Function prototypes */ +#ifdef H5_HAVE_GASS + +#ifdef __cplusplus +extern "C" { +#endif + +hid_t H5FD_gass_init(void); +void H5FD_gass_term(void); +herr_t H5Pset_fapl_gass(hid_t fapl_id, GASS_Info info); +herr_t H5Pget_fapl_gass(hid_t fapl_id, GASS_Info *info/*out*/); + +#ifdef __cplusplus +} +#endif + +#endif + +#endif /* H5FDgass_H */ + diff --git a/libs/cygwin/include/H5FDlog.h b/libs/cygwin/include/H5FDlog.h new file mode 100755 index 0000000..2380e2e --- /dev/null +++ b/libs/cygwin/include/H5FDlog.h @@ -0,0 +1,72 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Quincey Koziol + * Monday, April 17, 2000 + * + * Purpose: The public header file for the log driver. + */ +#ifndef H5FDlog_H +#define H5FDlog_H + +#include "H5Ipublic.h" + +#define H5FD_LOG (H5FD_log_init()) + +/* Flags for H5Pset_fapl_log() */ +/* Flags for tracking where reads/writes/seeks occur */ +#define H5FD_LOG_LOC_READ 0x0001 +#define H5FD_LOG_LOC_WRITE 0x0002 +#define H5FD_LOG_LOC_SEEK 0x0004 +#define H5FD_LOG_LOC_IO (H5FD_LOG_LOC_READ|H5FD_LOG_LOC_WRITE|H5FD_LOG_LOC_SEEK) +/* Flags for tracking number of times each byte is read/written */ +#define H5FD_LOG_FILE_READ 0x0008 +#define H5FD_LOG_FILE_WRITE 0x0010 +#define H5FD_LOG_FILE_IO (H5FD_LOG_FILE_READ|H5FD_LOG_FILE_WRITE) +/* Flag for tracking "flavor" (type) of information stored at each byte */ +#define H5FD_LOG_FLAVOR 0x0020 +/* Flags for tracking total number of reads/writes/seeks */ +#define H5FD_LOG_NUM_READ 0x0040 +#define H5FD_LOG_NUM_WRITE 0x0080 +#define H5FD_LOG_NUM_SEEK 0x0100 +#define H5FD_LOG_NUM_IO (H5FD_LOG_NUM_READ|H5FD_LOG_NUM_WRITE|H5FD_LOG_NUM_SEEK) +/* Flags for tracking time spent in open/read/write/seek/close */ +#define H5FD_LOG_TIME_OPEN 0x0200 /* Not implemented yet */ +#define H5FD_LOG_TIME_READ 0x0400 /* Not implemented yet */ +#define H5FD_LOG_TIME_WRITE 0x0800 /* Partially implemented (need to track total time) */ +#define H5FD_LOG_TIME_SEEK 0x1000 /* Partially implemented (need to track total time & track time for seeks during reading) */ +#define H5FD_LOG_TIME_CLOSE 0x2000 /* Fully implemented */ +#define H5FD_LOG_TIME_IO (H5FD_LOG_TIME_OPEN|H5FD_LOG_TIME_READ|H5FD_LOG_TIME_WRITE|H5FD_LOG_TIME_SEEK|H5FD_LOG_TIME_CLOSE) +/* Flag for tracking allocation of space in file */ +#define H5FD_LOG_ALLOC 0x4000 +#define H5FD_LOG_ALL (H5FD_LOG_ALLOC|H5FD_LOG_TIME_IO|H5FD_LOG_NUM_IO|H5FD_LOG_FLAVOR|H5FD_LOG_FILE_IO|H5FD_LOG_LOC_IO) + +#ifdef __cplusplus +extern "C" { +#endif + +H5_DLL hid_t H5FD_log_init(void); +H5_DLL void H5FD_log_term(void); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_fapl_log(hid_t fapl_id, const char *logfile, int verbosity); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_fapl_log(hid_t fapl_id, const char *logfile, unsigned flags, size_t buf_size); +#endif /* H5_WANT_H5_V1_4_COMPAT */ + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libs/cygwin/include/H5FDmpi.h b/libs/cygwin/include/H5FDmpi.h new file mode 100755 index 0000000..0dd9362 --- /dev/null +++ b/libs/cygwin/include/H5FDmpi.h @@ -0,0 +1,93 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Quincey Koziol + * Friday, January 30, 2004 + * + * Purpose: The public header file for common items for all MPI VFL drivers + */ +#ifndef H5FDmpi_H +#define H5FDmpi_H + +/* Type of I/O for data transfer properties */ +typedef enum H5FD_mpio_xfer_t { + H5FD_MPIO_INDEPENDENT = 0, /*zero is the default*/ + H5FD_MPIO_COLLECTIVE +} H5FD_mpio_xfer_t; + +#ifdef H5_HAVE_PARALLEL + +/* Sub-class the H5FD_class_t to add more specific functions for MPI-based VFDs */ +typedef struct H5FD_class_mpi_t { + H5FD_class_t super; /* Superclass information & methods */ + int (*get_rank)(const H5FD_t *file); /* Get the MPI rank of a process */ + int (*get_size)(const H5FD_t *file); /* Get the MPI size of a communicator */ + MPI_Comm (*get_comm)(const H5FD_t *file); /* Get the communicator for a file */ +} H5FD_class_mpi_t; +#endif /* H5_HAVE_PARALLEL */ + +/* Include all the MPI VFL headers */ +#include "H5FDmpio.h" /* MPI I/O file driver */ +#include "H5FDmpiposix.h" /* MPI/posix I/O file driver */ + +/* Macros */ + +/* Single macro to check for all file drivers that use MPI */ +#define IS_H5FD_MPI(file) \ + (IS_H5FD_MPIO(file) || IS_H5FD_MPIPOSIX(file)) + +#ifdef H5_HAVE_PARALLEL +/* ======== Temporary data transfer properties ======== */ +/* Definitions for memory MPI type property */ +#define H5FD_MPI_XFER_MEM_MPI_TYPE_NAME "H5FD_mpi_mem_mpi_type" +#define H5FD_MPI_XFER_MEM_MPI_TYPE_SIZE sizeof(MPI_Datatype) +/* Definitions for file MPI type property */ +#define H5FD_MPI_XFER_FILE_MPI_TYPE_NAME "H5FD_mpi_file_mpi_type" +#define H5FD_MPI_XFER_FILE_MPI_TYPE_SIZE sizeof(MPI_Datatype) + +/* + * The view is set to this value + */ +H5_DLLVAR char H5FD_mpi_native_g[]; + +/* Function prototypes */ +#ifdef __cplusplus +extern "C" { +#endif +/* General routines */ +H5_DLL haddr_t H5FD_mpi_MPIOff_to_haddr(MPI_Offset mpi_off); +H5_DLL herr_t H5FD_mpi_haddr_to_MPIOff(haddr_t addr, MPI_Offset *mpi_off/*out*/); +H5_DLL herr_t H5FD_mpi_comm_info_dup(MPI_Comm comm, MPI_Info info, + MPI_Comm *comm_new, MPI_Info *info_new); +H5_DLL herr_t H5FD_mpi_comm_info_free(MPI_Comm *comm, MPI_Info *info); +#ifdef NOT_YET +H5_DLL herr_t H5FD_mpio_wait_for_left_neighbor(H5FD_t *file); +H5_DLL herr_t H5FD_mpio_signal_right_neighbor(H5FD_t *file); +#endif /* NOT_YET */ +H5_DLL herr_t H5FD_mpi_setup_collective(hid_t dxpl_id, MPI_Datatype btype, + MPI_Datatype ftype); +H5_DLL herr_t H5FD_mpi_teardown_collective(hid_t dxpl_id); + +/* Driver specific methods */ +H5_DLL int H5FD_mpi_get_rank(const H5FD_t *file); +H5_DLL int H5FD_mpi_get_size(const H5FD_t *file); +H5_DLL MPI_Comm H5FD_mpi_get_comm(const H5FD_t *_file); +#ifdef __cplusplus +} +#endif + +#endif /* H5_HAVE_PARALLEL */ + +#endif /* H5FDmpi_H */ diff --git a/libs/cygwin/include/H5FDmpio.h b/libs/cygwin/include/H5FDmpio.h new file mode 100755 index 0000000..912cbd8 --- /dev/null +++ b/libs/cygwin/include/H5FDmpio.h @@ -0,0 +1,60 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, August 2, 1999 + * + * Purpose: The public header file for the mpio driver. + */ +#ifndef H5FDmpio_H +#define H5FDmpio_H + +#ifdef H5_HAVE_PARALLEL +# define H5FD_MPIO (H5FD_mpio_init()) +#else +# define H5FD_MPIO (-1) +#endif /* H5_HAVE_PARALLEL */ + +/* Macros */ + +#define IS_H5FD_MPIO(f) /* (H5F_t *f) */ \ + (H5FD_MPIO==H5F_get_driver_id(f)) + +#ifdef H5_HAVE_PARALLEL +/*Turn on H5FDmpio_debug if H5F_DEBUG is on */ +#ifdef H5F_DEBUG +#ifndef H5FDmpio_DEBUG +#define H5FDmpio_DEBUG +#endif +#endif + +/* Function prototypes */ +#ifdef __cplusplus +extern "C" { +#endif +H5_DLL hid_t H5FD_mpio_init(void); +H5_DLL void H5FD_mpio_term(void); +H5_DLL herr_t H5Pset_fapl_mpio(hid_t fapl_id, MPI_Comm comm, MPI_Info info); +H5_DLL herr_t H5Pget_fapl_mpio(hid_t fapl_id, MPI_Comm *comm/*out*/, + MPI_Info *info/*out*/); +H5_DLL herr_t H5Pset_dxpl_mpio(hid_t dxpl_id, H5FD_mpio_xfer_t xfer_mode); +H5_DLL herr_t H5Pget_dxpl_mpio(hid_t dxpl_id, H5FD_mpio_xfer_t *xfer_mode/*out*/); +#ifdef __cplusplus +} +#endif + +#endif /* H5_HAVE_PARALLEL */ + +#endif diff --git a/libs/cygwin/include/H5FDmpiposix.h b/libs/cygwin/include/H5FDmpiposix.h new file mode 100755 index 0000000..d29bcd7 --- /dev/null +++ b/libs/cygwin/include/H5FDmpiposix.h @@ -0,0 +1,61 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Quincey Koziol + * Thursday, July 11, 2002 + * + * Purpose: The public header file for the mpiposix driver. + */ + +#ifndef __H5FDmpiposix_H +#define __H5FDmpiposix_H + +#ifdef H5_HAVE_PARALLEL +# define H5FD_MPIPOSIX (H5FD_mpiposix_init()) +#else +# define H5FD_MPIPOSIX (-1) +#endif + +/* Macros */ + +#define IS_H5FD_MPIPOSIX(f) /* (H5F_t *f) */ \ + (H5FD_MPIPOSIX==H5F_get_driver_id(f)) + +#ifdef H5_HAVE_PARALLEL + +/* Function prototypes */ +#ifdef __cplusplus +extern "C" { +#endif + +H5_DLL hid_t H5FD_mpiposix_init(void); +H5_DLL void H5FD_mpiposix_term(void); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_fapl_mpiposix(hid_t fapl_id, MPI_Comm comm); +H5_DLL herr_t H5Pget_fapl_mpiposix(hid_t fapl_id, MPI_Comm *comm/*out*/); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_fapl_mpiposix(hid_t fapl_id, MPI_Comm comm, hbool_t use_gpfs); +H5_DLL herr_t H5Pget_fapl_mpiposix(hid_t fapl_id, MPI_Comm *comm/*out*/, hbool_t *use_gpfs/*out*/); +#endif /* H5_WANT_H5_V1_4_COMPAT */ + +#ifdef __cplusplus +} +#endif + +#endif /*H5_HAVE_PARALLEL*/ + +#endif /* __H5FDmpiposix_H */ + + diff --git a/libs/cygwin/include/H5FDmulti.h b/libs/cygwin/include/H5FDmulti.h new file mode 100755 index 0000000..59c1336 --- /dev/null +++ b/libs/cygwin/include/H5FDmulti.h @@ -0,0 +1,51 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, August 2, 1999 + * + * Purpose: The public header file for the "multi" driver. + */ +#ifndef H5FDmulti_H +#define H5FDmulti_H + +#include "H5Ipublic.h" +#include "H5Ppublic.h" /* Property lists */ +#include "H5Fpublic.h" + +#define H5FD_MULTI (H5FD_multi_init()) + +#ifdef __cplusplus +extern "C" { +#endif +H5_DLL hid_t H5FD_multi_init(void); +H5_DLL void H5FD_multi_term(void); +H5_DLL herr_t H5Pset_fapl_multi(hid_t fapl_id, const H5FD_mem_t *memb_map, + const hid_t *memb_fapl, const char * const *memb_name, + const haddr_t *memb_addr, hbool_t relax); +H5_DLL herr_t H5Pget_fapl_multi(hid_t fapl_id, H5FD_mem_t *memb_map/*out*/, + hid_t *memb_fapl/*out*/, char **memb_name/*out*/, + haddr_t *memb_addr/*out*/, hbool_t *relax/*out*/); +H5_DLL herr_t H5Pset_dxpl_multi(hid_t dxpl_id, const hid_t *memb_dxpl); +H5_DLL herr_t H5Pget_dxpl_multi(hid_t dxpl_id, hid_t *memb_dxpl/*out*/); + +H5_DLL herr_t H5Pset_fapl_split(hid_t fapl, const char *meta_ext, + hid_t meta_plist_id, const char *raw_ext, + hid_t raw_plist_id); +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libs/cygwin/include/H5FDpublic.h b/libs/cygwin/include/H5FDpublic.h new file mode 100755 index 0000000..ba762db --- /dev/null +++ b/libs/cygwin/include/H5FDpublic.h @@ -0,0 +1,259 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, July 26, 1999 + */ +#ifndef _H5FDpublic_H +#define _H5FDpublic_H + +#include "H5public.h" +#include "H5Fpublic.h" /*for H5F_close_degree_t */ + +#define H5_HAVE_VFL 1 /*define a convenient app feature test*/ +#define H5FD_VFD_DEFAULT 0 /* Default VFL driver value */ + +/* + * Types of allocation requests. The values larger than H5FD_MEM_DEFAULT + * should not change other than adding new types to the end. These numbers + * might appear in files. + */ +typedef enum H5FD_mem_t { + H5FD_MEM_NOLIST = -1, /*must be negative*/ + H5FD_MEM_DEFAULT = 0, /*must be zero*/ + H5FD_MEM_SUPER = 1, + H5FD_MEM_BTREE = 2, + H5FD_MEM_DRAW = 3, + H5FD_MEM_GHEAP = 4, + H5FD_MEM_LHEAP = 5, + H5FD_MEM_OHDR = 6, + + H5FD_MEM_NTYPES /*must be last*/ +} H5FD_mem_t; + +/* + * A free-list map which maps all types of allocation requests to a single + * free list. This is useful for drivers that don't really care about + * keeping different requests segregated in the underlying file and which + * want to make most efficient reuse of freed memory. The use of the + * H5FD_MEM_SUPER free list is arbitrary. + */ +#define H5FD_FLMAP_SINGLE { \ + H5FD_MEM_SUPER, /*default*/ \ + H5FD_MEM_SUPER, /*super*/ \ + H5FD_MEM_SUPER, /*btree*/ \ + H5FD_MEM_SUPER, /*draw*/ \ + H5FD_MEM_SUPER, /*gheap*/ \ + H5FD_MEM_SUPER, /*lheap*/ \ + H5FD_MEM_SUPER /*ohdr*/ \ +} + +/* + * A free-list map which segregates requests into `raw' or `meta' data + * pools. + */ +#define H5FD_FLMAP_DICHOTOMY { \ + H5FD_MEM_SUPER, /*default*/ \ + H5FD_MEM_SUPER, /*super*/ \ + H5FD_MEM_SUPER, /*btree*/ \ + H5FD_MEM_DRAW, /*draw*/ \ + H5FD_MEM_SUPER, /*gheap*/ \ + H5FD_MEM_SUPER, /*lheap*/ \ + H5FD_MEM_SUPER /*ohdr*/ \ +} + +/* + * The default free list map which causes each request type to use it's own + * free-list. + */ +#define H5FD_FLMAP_DEFAULT { \ + H5FD_MEM_DEFAULT, /*default*/ \ + H5FD_MEM_DEFAULT, /*super*/ \ + H5FD_MEM_DEFAULT, /*btree*/ \ + H5FD_MEM_DEFAULT, /*draw*/ \ + H5FD_MEM_DEFAULT, /*gheap*/ \ + H5FD_MEM_DEFAULT, /*lheap*/ \ + H5FD_MEM_DEFAULT /*ohdr*/ \ +} + + +/* Define VFL driver features that can be enabled on a per-driver basis */ +/* These are returned with the 'query' function pointer in H5FD_class_t */ + /* + * Defining the H5FD_FEAT_AGGREGATE_METADATA for a VFL driver means that + * the library will attempt to allocate a larger block for metadata and + * then sub-allocate each metadata request from that larger block. + */ +#define H5FD_FEAT_AGGREGATE_METADATA 0x00000001 + /* + * Defining the H5FD_FEAT_ACCUMULATE_METADATA for a VFL driver means that + * the library will attempt to cache metadata as it is written to the file + * and build up a larger block of metadata to eventually pass to the VFL + * 'write' routine. + * + * Distinguish between updating the metadata accumulator on writes and + * reads. This is particularly (perhaps only, even) important for MPI-I/O + * where we guarantee that writes are collective, but reads may not be. + * If we were to allow the metadata accumulator to be written during a + * read operation, the application would hang. + */ +#define H5FD_FEAT_ACCUMULATE_METADATA_WRITE 0x00000002 +#define H5FD_FEAT_ACCUMULATE_METADATA_READ 0x00000004 +#define H5FD_FEAT_ACCUMULATE_METADATA (H5FD_FEAT_ACCUMULATE_METADATA_WRITE|H5FD_FEAT_ACCUMULATE_METADATA_READ) + /* + * Defining the H5FD_FEAT_DATA_SIEVE for a VFL driver means that + * the library will attempt to cache raw data as it is read from/written to + * a file in a "data seive" buffer. See Rajeev Thakur's papers: + * http://www.mcs.anl.gov/~thakur/papers/romio-coll.ps.gz + * http://www.mcs.anl.gov/~thakur/papers/mpio-high-perf.ps.gz + */ +#define H5FD_FEAT_DATA_SIEVE 0x00000008 + /* + * Defining the H5FD_FEAT_AGGREGATE_SMALLDATA for a VFL driver means that + * the library will attempt to allocate a larger block for "small" raw data + * and then sub-allocate "small" raw data requests from that larger block. + */ +#define H5FD_FEAT_AGGREGATE_SMALLDATA 0x00000010 + + +/* Forward declaration */ +typedef struct H5FD_t H5FD_t; + +/* Class information for each file driver */ +typedef struct H5FD_class_t { + const char *name; + haddr_t maxaddr; + H5F_close_degree_t fc_degree; + hsize_t (*sb_size)(H5FD_t *file); + herr_t (*sb_encode)(H5FD_t *file, char *name/*out*/, + unsigned char *p/*out*/); + herr_t (*sb_decode)(H5FD_t *f, const char *name, const unsigned char *p); + size_t fapl_size; + void * (*fapl_get)(H5FD_t *file); + void * (*fapl_copy)(const void *fapl); + herr_t (*fapl_free)(void *fapl); + size_t dxpl_size; + void * (*dxpl_copy)(const void *dxpl); + herr_t (*dxpl_free)(void *dxpl); + H5FD_t *(*open)(const char *name, unsigned flags, hid_t fapl, + haddr_t maxaddr); + herr_t (*close)(H5FD_t *file); + int (*cmp)(const H5FD_t *f1, const H5FD_t *f2); + herr_t (*query)(const H5FD_t *f1, unsigned long *flags); + haddr_t (*alloc)(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, hsize_t size); + herr_t (*free)(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, + haddr_t addr, hsize_t size); + haddr_t (*get_eoa)(H5FD_t *file); + herr_t (*set_eoa)(H5FD_t *file, haddr_t addr); + haddr_t (*get_eof)(H5FD_t *file); + herr_t (*get_handle)(H5FD_t *file, hid_t fapl, void**file_handle); + herr_t (*read)(H5FD_t *file, H5FD_mem_t type, hid_t dxpl, + haddr_t addr, size_t size, void *buffer); + herr_t (*write)(H5FD_t *file, H5FD_mem_t type, hid_t dxpl, + haddr_t addr, size_t size, const void *buffer); + herr_t (*flush)(H5FD_t *file, hid_t dxpl_id, unsigned closing); + herr_t (*lock)(H5FD_t *file, unsigned char *oid, unsigned lock_type, hbool_t last); + herr_t (*unlock)(H5FD_t *file, unsigned char *oid, hbool_t last); + H5FD_mem_t fl_map[H5FD_MEM_NTYPES]; +} H5FD_class_t; + +/* A free list is a singly-linked list of address/size pairs. */ +typedef struct H5FD_free_t { + haddr_t addr; + hsize_t size; + struct H5FD_free_t *next; +} H5FD_free_t; + +/* + * The main datatype for each driver. Public fields common to all drivers + * are declared here and the driver appends private fields in memory. + */ +struct H5FD_t { + hid_t driver_id; /*driver ID for this file */ + const H5FD_class_t *cls; /*constant class info */ + unsigned long fileno[2]; /* File serial number */ + unsigned long feature_flags; /* VFL Driver feature Flags */ + hsize_t threshold; /* Threshold for alignment */ + hsize_t alignment; /* Allocation alignment */ + hsize_t reserved_alloc; /* Space reserved for later alloc calls */ + + /* Metadata aggregation fields */ + hsize_t def_meta_block_size; /* Metadata allocation + * block size (if + * aggregating metadata) */ + hsize_t cur_meta_block_size; /* Current size of metadata + * allocation region left */ + haddr_t eoma; /* End of metadata + * allocated region */ + + /* "Small data" aggregation fields */ + hsize_t def_sdata_block_size; /* "Small data" + * allocation block size + * (if aggregating "small + * data") */ + hsize_t cur_sdata_block_size; /* Current size of "small + * data" allocation + * region left */ + haddr_t eosda; /* End of "small data" + * allocated region */ + + /* Metadata accumulator fields */ + unsigned char *meta_accum; /* Buffer to hold the accumulated metadata */ + haddr_t accum_loc; /* File location (offset) of the + * accumulated metadata */ + size_t accum_size; /* Size of the accumulated + * metadata buffer used (in + * bytes) */ + size_t accum_buf_size; /* Size of the accumulated + * metadata buffer allocated (in + * bytes) */ + unsigned accum_dirty; /* Flag to indicate that the + * accumulated metadata is dirty */ + haddr_t maxaddr; /* For this file, overrides class */ + H5FD_free_t *fl[H5FD_MEM_NTYPES]; /* Freelist per allocation type */ + hsize_t maxsize; /* Largest object on FL, or zero */ +}; + +#ifdef __cplusplus +extern "C" { +#endif + +/* Function prototypes */ +H5_DLL hid_t H5FDregister(const H5FD_class_t *cls); +H5_DLL herr_t H5FDunregister(hid_t driver_id); +H5_DLL H5FD_t *H5FDopen(const char *name, unsigned flags, hid_t fapl_id, + haddr_t maxaddr); +H5_DLL herr_t H5FDclose(H5FD_t *file); +H5_DLL int H5FDcmp(const H5FD_t *f1, const H5FD_t *f2); +H5_DLL int H5FDquery(const H5FD_t *f, unsigned long *flags); +H5_DLL haddr_t H5FDalloc(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, hsize_t size); +H5_DLL herr_t H5FDfree(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, + haddr_t addr, hsize_t size); +H5_DLL haddr_t H5FDrealloc(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, + haddr_t addr, hsize_t old_size, hsize_t new_size); +H5_DLL haddr_t H5FDget_eoa(H5FD_t *file); +H5_DLL herr_t H5FDset_eoa(H5FD_t *file, haddr_t eof); +H5_DLL haddr_t H5FDget_eof(H5FD_t *file); +H5_DLL herr_t H5FDget_vfd_handle(H5FD_t *file, hid_t fapl, void**file_handle); +H5_DLL herr_t H5FDread(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, + haddr_t addr, size_t size, void *buf/*out*/); +H5_DLL herr_t H5FDwrite(H5FD_t *file, H5FD_mem_t type, hid_t dxpl_id, + haddr_t addr, size_t size, const void *buf); +H5_DLL herr_t H5FDflush(H5FD_t *file, hid_t dxpl_id, unsigned closing); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5FDsec2.h b/libs/cygwin/include/H5FDsec2.h new file mode 100755 index 0000000..7242084 --- /dev/null +++ b/libs/cygwin/include/H5FDsec2.h @@ -0,0 +1,40 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, August 2, 1999 + * + * Purpose: The public header file for the sec2 driver. + */ +#ifndef H5FDsec2_H +#define H5FDsec2_H + +#include "H5Ipublic.h" + +#define H5FD_SEC2 (H5FD_sec2_init()) + +#ifdef __cplusplus +extern "C" { +#endif + +H5_DLL hid_t H5FD_sec2_init(void); +H5_DLL void H5FD_sec2_term(void); +H5_DLL herr_t H5Pset_fapl_sec2(hid_t fapl_id); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libs/cygwin/include/H5FDsrb.h b/libs/cygwin/include/H5FDsrb.h new file mode 100755 index 0000000..053ca51 --- /dev/null +++ b/libs/cygwin/include/H5FDsrb.h @@ -0,0 +1,57 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Raymond Lu + * Wednesday, April 12, 2000 + * Purpose: The public header file for the SRB driver. + */ +#ifndef H5FDsrb_H +#define H5FDsrb_H + +#include "H5FDpublic.h" +#include "H5Ipublic.h" + +#ifdef H5_HAVE_SRB + +#define H5FD_SRB (H5FD_srb_init()) + +typedef struct SRB_Info { /* Define the SRB info object. */ + char *srbHost; /* SRB host address of server */ + char *srbPort; /* SRB host port number */ + char *srbAuth; /* SRB Authentication-password */ + int storSysType; /* Storage Type: 0=Unix, 1=UniTree, 2=HPSS, + * 3=FTP, 4=HTTP */ + int mode; /* File mode-Unix access mode */ + int size; /* File Size-Only valid for HPSS, -1 is default */ +} SRB_Info; + +#ifdef __cplusplus +extern "C" { +#endif + +H5_DLL hid_t H5FD_srb_init(void); +H5_DLL void H5FD_srb_term(void); +H5_DLL herr_t H5Pset_fapl_srb(hid_t fapl_id, SRB_Info info); +H5_DLL herr_t H5Pget_fapl_srb(hid_t fapl_id, SRB_Info *info); + +#ifdef __cplusplus +} +#endif + +#else +#define H5FD_SRB (-1) +#endif /* H5_HAVE_SRB */ + +#endif /* H5FDsrb_H */ diff --git a/libs/cygwin/include/H5FDstdio.h b/libs/cygwin/include/H5FDstdio.h new file mode 100755 index 0000000..5c18a4f --- /dev/null +++ b/libs/cygwin/include/H5FDstdio.h @@ -0,0 +1,40 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Monday, August 2, 1999 + * + * Purpose: The public header file for the sec2 driver. + */ +#ifndef H5FDstdio_H +#define H5FDstdio_H + +#include "H5Ipublic.h" + +#define H5FD_STDIO (H5FD_stdio_init()) + +#ifdef __cplusplus +extern "C" { +#endif + +H5_DLL hid_t H5FD_stdio_init(void); +H5_DLL void H5FD_stdio_term(void); +H5_DLL herr_t H5Pset_fapl_stdio(hid_t fapl_id); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/libs/cygwin/include/H5FDstream.h b/libs/cygwin/include/H5FDstream.h new file mode 100755 index 0000000..890eb5a --- /dev/null +++ b/libs/cygwin/include/H5FDstream.h @@ -0,0 +1,82 @@ +/* + * Copyright © 2000 The author. + * The author prefers this code not be used for military purposes. + * + * + * Author: Thomas Radke + * Tuesday, September 12, 2000 + * + * Purpose: The public header file for the Stream Virtual File Driver. + * + * Modifications: + * Thomas Radke, Thursday, October 26, 2000 + * Added support for Windows. + * + */ +#ifndef H5FDstream_H +#define H5FDstream_H + +#ifdef H5_HAVE_STREAM + +/* check what sockets type we have (Unix or Windows sockets) + Note that only MS compilers require to use Windows sockets + but gcc under Windows does not. */ +#if ! defined(H5_HAVE_WINSOCK_H) || defined(__GNUC__) +#define H5FD_STREAM_HAVE_UNIX_SOCKETS 1 +#endif + +/* define the data type for socket descriptors + and the constant indicating an invalid descriptor */ +#ifdef H5FD_STREAM_HAVE_UNIX_SOCKETS + +#define H5FD_STREAM_SOCKET_TYPE int +#define H5FD_STREAM_INVALID_SOCKET -1 + +#else +#include + +#define H5FD_STREAM_SOCKET_TYPE SOCKET +#define H5FD_STREAM_INVALID_SOCKET INVALID_SOCKET + +#endif + +#define H5FD_STREAM (H5FD_stream_init()) + +#ifdef __cplusplus +extern "C" { +#endif + +/* prototype for read broadcast callback routine */ +typedef int (*H5FD_stream_broadcast_t) (unsigned char **file, + haddr_t *len, + void *arg); + +/* driver-specific file access properties */ +typedef struct H5FD_stream_fapl_t +{ + size_t increment; /* how much to grow memory in reallocs */ + H5FD_STREAM_SOCKET_TYPE socket; /* externally provided socket descriptor*/ + hbool_t do_socket_io; /* do I/O on socket */ + int backlog; /* backlog argument for listen call */ + H5FD_stream_broadcast_t broadcast_fn; /* READ broadcast callback */ + void *broadcast_arg; /* READ broadcast callback user argument*/ + unsigned int maxhunt; /* how many more ports to try to bind to*/ + unsigned short int port; /* port a socket was bound/connected to */ +} H5FD_stream_fapl_t; + + +/* prototypes of exported functions */ +H5_DLL hid_t H5FD_stream_init (void); +H5_DLL void H5FD_stream_term(void); +H5_DLL herr_t H5Pset_fapl_stream (hid_t fapl_id, + H5FD_stream_fapl_t *fapl); +H5_DLL herr_t H5Pget_fapl_stream (hid_t fapl_id, + H5FD_stream_fapl_t *fapl /*out*/ ); + +#ifdef __cplusplus +} +#endif + +#endif /* H5_HAVE_STREAM */ + +#endif /* H5FDstream_H */ diff --git a/libs/cygwin/include/H5Fpublic.h b/libs/cygwin/include/H5Fpublic.h new file mode 100755 index 0000000..c83f12e --- /dev/null +++ b/libs/cygwin/include/H5Fpublic.h @@ -0,0 +1,122 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5F module. + */ +#ifndef _H5Fpublic_H +#define _H5Fpublic_H + +/* Public header files needed by this file */ +#include "H5public.h" +#include "H5Ipublic.h" + +/* + * These are the bits that can be passed to the `flags' argument of + * H5Fcreate() and H5Fopen(). Use the bit-wise OR operator (|) to combine + * them as needed. As a side effect, they call H5check_version() to make sure + * that the application is compiled with a version of the hdf5 header files + * which are compatible with the library to which the application is linked. + * We're assuming that these constants are used rather early in the hdf5 + * session. + * + * NOTE: When adding H5F_ACC_* macros, remember to redefine them in H5Fprivate.h + * + */ + +/* When this header is included from H5Fprivate.h, don't make calls to H5check() */ +#undef H5CHECK +#ifndef _H5Fprivate_H +#define H5CHECK H5check(), +#else /* _H5Fprivate_H */ +#define H5CHECK +#endif /* _H5Fprivate_H */ + +#define H5F_ACC_RDONLY (H5CHECK 0x0000u) /*absence of rdwr => rd-only */ +#define H5F_ACC_RDWR (H5CHECK 0x0001u) /*open for read and write */ +#define H5F_ACC_TRUNC (H5CHECK 0x0002u) /*overwrite existing files */ +#define H5F_ACC_EXCL (H5CHECK 0x0004u) /*fail if file already exists*/ +#define H5F_ACC_DEBUG (H5CHECK 0x0008u) /*print debug info */ +#define H5F_ACC_CREAT (H5CHECK 0x0010u) /*create non-existing files */ + +#define H5F_OBJ_FILE (0x0001u) +#define H5F_OBJ_DATASET (0x0002u) +#define H5F_OBJ_GROUP (0x0004u) +#define H5F_OBJ_DATATYPE (0x0008u) +#define H5F_OBJ_ATTR (0x0010u) +#define H5F_OBJ_ALL (H5F_OBJ_FILE|H5F_OBJ_DATASET|H5F_OBJ_GROUP|H5F_OBJ_DATATYPE|H5F_OBJ_ATTR) + +#ifdef H5_HAVE_PARALLEL +/* + * Use this constant string as the MPI_Info key to set H5Fmpio debug flags. + * To turn on H5Fmpio debug flags, set the MPI_Info value with this key to + * have the value of a string consisting of the characters that turn on the + * desired flags. + */ +#define H5F_MPIO_DEBUG_KEY "H5F_mpio_debug_key" +#endif /* H5_HAVE_PARALLEL */ + +/* The difference between a single file and a set of mounted files */ +typedef enum H5F_scope_t { + H5F_SCOPE_LOCAL = 0, /*specified file handle only */ + H5F_SCOPE_GLOBAL = 1, /*entire virtual file */ + H5F_SCOPE_DOWN = 2 /*for internal use only */ +} H5F_scope_t; + +/* Unlimited file size for H5Pset_external() */ +#define H5F_UNLIMITED ((hsize_t)(-1L)) + +/* How does file close behave? + * H5F_CLOSE_DEFAULT - Use the degree pre-defined by underlining VFL + * H5F_CLOSE_WEAK - file closes only after all opened objects are closed + * H5F_CLOSE_SEMI - if no opened objects, file is close; otherwise, file + close fails + * H5F_CLOSE_STRONG - if there are opened objects, close them first, then + close file + */ +typedef enum H5F_close_degree_t { + H5F_CLOSE_DEFAULT = 0, + H5F_CLOSE_WEAK = 1, + H5F_CLOSE_SEMI = 2, + H5F_CLOSE_STRONG = 3 +} H5F_close_degree_t; + +#ifdef __cplusplus +extern "C" { +#endif + +/* Functions in H5F.c */ +H5_DLL htri_t H5Fis_hdf5 (const char *filename); +H5_DLL hid_t H5Fcreate (const char *filename, unsigned flags, + hid_t create_plist, hid_t access_plist); +H5_DLL hid_t H5Fopen (const char *filename, unsigned flags, + hid_t access_plist); +H5_DLL hid_t H5Freopen(hid_t file_id); +H5_DLL herr_t H5Fflush(hid_t object_id, H5F_scope_t scope); +H5_DLL herr_t H5Fclose (hid_t file_id); +H5_DLL hid_t H5Fget_create_plist (hid_t file_id); +H5_DLL hid_t H5Fget_access_plist (hid_t file_id); +H5_DLL int H5Fget_obj_count(hid_t file_id, unsigned types); +H5_DLL int H5Fget_obj_ids(hid_t file_id, unsigned types, int max_objs, hid_t *obj_id_list); +H5_DLL herr_t H5Fget_vfd_handle(hid_t file_id, hid_t fapl, void** file_handle); +H5_DLL herr_t H5Fmount(hid_t loc, const char *name, hid_t child, hid_t plist); +H5_DLL herr_t H5Funmount(hid_t loc, const char *name); +H5_DLL hssize_t H5Fget_freespace(hid_t file_id); +H5_DLL herr_t H5Fget_filesize(hid_t file_id, hsize_t *size); +H5_DLL ssize_t H5Fget_name(hid_t obj_id, char *name, size_t size); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Gpublic.h b/libs/cygwin/include/H5Gpublic.h new file mode 100755 index 0000000..3d74704 --- /dev/null +++ b/libs/cygwin/include/H5Gpublic.h @@ -0,0 +1,138 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/*------------------------------------------------------------------------- + * + * Created: H5Gproto.h + * Jul 11 1997 + * Robb Matzke + * + * Purpose: Public declarations for the H5G package (symbol + * tables). + * + * Modifications: + * + *------------------------------------------------------------------------- + */ +#ifndef _H5Gpublic_H +#define _H5Gpublic_H + +/* Public headers needed by this file */ +#include + +#include "H5public.h" +#include "H5Ipublic.h" +#include "H5Opublic.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* Types of links */ +typedef enum H5G_link_t { + H5G_LINK_ERROR = -1, + H5G_LINK_HARD = 0, + H5G_LINK_SOFT = 1 +} H5G_link_t; + +/* + * An object has a certain type. The first few numbers are reserved for use + * internally by HDF5. Users may add their own types with higher values. The + * values are never stored in the file -- they only exist while an + * application is running. An object may satisfy the `isa' function for more + * than one type. + */ +#ifdef H5_WANT_H5_V1_4_COMPAT +#define H5G_UNKNOWN -1 /* Unknown object type */ +#define H5G_LINK 0 /* Object is a symbolic link */ +#define H5G_GROUP 1 /* Object is a group */ +#define H5G_DATASET 2 /* Object is a dataset */ +#define H5G_TYPE 3 /* Object is a named data type */ +#define H5G_RESERVED_4 4 /* Reserved for future use */ +#define H5G_RESERVED_5 5 /* Reserved for future use */ +#define H5G_RESERVED_6 6 /* Reserved for future use */ +#define H5G_RESERVED_7 7 /* Reserved for future use */ +#else /*H5_WANT_H5_V1_4_COMPAT*/ +typedef enum H5G_obj_t { + H5G_UNKNOWN = -1, /* Unknown object type */ + H5G_LINK, /* Object is a symbolic link */ + H5G_GROUP, /* Object is a group */ + H5G_DATASET, /* Object is a dataset */ + H5G_TYPE, /* Object is a named data type */ + H5G_RESERVED_4, /* Reserved for future use */ + H5G_RESERVED_5, /* Reserved for future use */ + H5G_RESERVED_6, /* Reserved for future use */ + H5G_RESERVED_7 /* Reserved for future use */ +} H5G_obj_t; +#endif /*H5_WANT_H5_V1_4_COMPAT*/ + +#define H5G_NTYPES 256 /* Max possible number of types */ +#define H5G_NLIBTYPES 8 /* Number of internal types */ +#define H5G_NUSERTYPES (H5G_NTYPES-H5G_NLIBTYPES) +#define H5G_USERTYPE(X) (8+(X)) /* User defined types */ + +/* Information about an object */ +typedef struct H5G_stat_t { + unsigned long fileno[2]; /*file number */ + unsigned long objno[2]; /*object number */ + unsigned nlink; /*number of hard links to object*/ +#ifdef H5_WANT_H5_V1_4_COMPAT + int type; /*basic object type */ +#else /*H5_WANT_H5_V1_4_COMPAT*/ + H5G_obj_t type; /*basic object type */ +#endif /*H5_WANT_H5_V1_4_COMPAT*/ + time_t mtime; /*modification time */ + size_t linklen; /*symbolic link value length */ + H5O_stat_t ohdr; /* Object header information */ +} H5G_stat_t; + +#define H5G_SAME_LOC 0 +#define H5Glink(cur_loc_id, type, cur_name, new_name) \ + H5Glink2(cur_loc_id, cur_name, type, H5G_SAME_LOC, new_name) +#define H5Gmove(src_loc_id, src_name, dst_name) \ + H5Gmove2(src_loc_id, src_name, H5G_SAME_LOC, dst_name) + +typedef herr_t (*H5G_iterate_t)(hid_t group, const char *name, + void *op_data); + +H5_DLL hid_t H5Gcreate(hid_t loc_id, const char *name, size_t size_hint); +H5_DLL hid_t H5Gopen(hid_t loc_id, const char *name); +H5_DLL herr_t H5Gclose(hid_t group_id); +H5_DLL herr_t H5Giterate(hid_t loc_id, const char *name, int *idx, + H5G_iterate_t op, void *op_data); +H5_DLL herr_t H5Gget_num_objs(hid_t loc_id, hsize_t *num_objs); +H5_DLL ssize_t H5Gget_objname_by_idx(hid_t loc_id, hsize_t idx, char* name, size_t size); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL int H5Gget_objtype_by_idx(hid_t loc_id, hsize_t idx); +#else /*H5_WANT_H5_V1_4_COMPAT*/ +H5_DLL H5G_obj_t H5Gget_objtype_by_idx(hid_t loc_id, hsize_t idx); +#endif /*H5_WANT_H5_V1_4_COMPAT*/ +H5_DLL herr_t H5Gmove2(hid_t src_loc, const char *src, hid_t dst_loc, + const char *dst); +H5_DLL herr_t H5Glink2(hid_t src_loc, const char *cur_name, H5G_link_t type, + hid_t dst_loc, const char *new_name); +H5_DLL herr_t H5Gunlink(hid_t loc_id, const char *name); +H5_DLL herr_t H5Gget_objinfo(hid_t loc_id, const char *name, + hbool_t follow_link, H5G_stat_t *statbuf/*out*/); +H5_DLL herr_t H5Gget_linkval(hid_t loc_id, const char *name, size_t size, + char *buf/*out*/); +H5_DLL herr_t H5Gset_comment(hid_t loc_id, const char *name, + const char *comment); +H5_DLL int H5Gget_comment(hid_t loc_id, const char *name, size_t bufsize, + char *buf); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5HGpublic.h b/libs/cygwin/include/H5HGpublic.h new file mode 100755 index 0000000..44885ef --- /dev/null +++ b/libs/cygwin/include/H5HGpublic.h @@ -0,0 +1,32 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * Programmer: Robb Matzke + * Friday, March 27, 1998 + */ +#ifndef _H5HGpublic_H +#define _H5HGpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5HLpublic.h b/libs/cygwin/include/H5HLpublic.h new file mode 100755 index 0000000..5bf2971 --- /dev/null +++ b/libs/cygwin/include/H5HLpublic.h @@ -0,0 +1,40 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/*------------------------------------------------------------------------- + * + * Created: H5HLpublic.h + * Jul 16 1997 + * Robb Matzke + * + * Purpose: Public declarations for the H5HL (local heap) package. + * + * Modifications: + * + *------------------------------------------------------------------------- + */ +#ifndef _H5HLpublic_H +#define _H5HLpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Ipublic.h b/libs/cygwin/include/H5Ipublic.h new file mode 100755 index 0000000..6069fd1 --- /dev/null +++ b/libs/cygwin/include/H5Ipublic.h @@ -0,0 +1,74 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains function prototypes for each exported function in + * the H5I module. + */ +#ifndef _H5Ipublic_H +#define _H5Ipublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +/* + * Group values allowed. Start with `1' instead of `0' because it makes the + * tracing output look better when hid_t values are large numbers. Change the + * GROUP_BITS in H5I.c if the MAXID gets larger than 32 (an assertion will + * fail otherwise). + * + * When adding groups here, add a section to the 'misc19' test in test/tmisc.c + * to verify that the H5I{inc|dec|get}_ref() routines work correctly with in. + * + */ +typedef enum { + H5I_BADID = (-1), /*invalid Group */ + H5I_FILE = 1, /*group ID for File objects */ + H5I_FILE_CLOSING, /*files pending close due to open objhdrs */ + H5I_GROUP, /*group ID for Group objects */ + H5I_DATATYPE, /*group ID for Datatype objects */ + H5I_DATASPACE, /*group ID for Dataspace objects */ + H5I_DATASET, /*group ID for Dataset objects */ + H5I_ATTR, /*group ID for Attribute objects */ + H5I_TEMPBUF, /*group ID for Temporary buffer objects */ + H5I_REFERENCE, /*group ID for Reference objects */ + H5I_VFL, /*group ID for virtual file layer */ + H5I_GENPROP_CLS, /*group ID for generic property list classes */ + H5I_GENPROP_LST, /*group ID for generic property lists */ + + H5I_NGROUPS /*number of valid groups, MUST BE LAST! */ +} H5I_type_t; + +/* Type of atoms to return to users */ +typedef int hid_t; + +/* An invalid object ID. This is also negative for error return. */ +#define H5I_INVALID_HID (-1) + +#ifdef __cplusplus +extern "C" { +#endif + +/* Public API functions */ +H5_DLL H5I_type_t H5Iget_type(hid_t id); +H5_DLL hid_t H5Iget_file_id(hid_t id); +H5_DLL ssize_t H5Iget_name(hid_t id, char *name/*out*/, size_t size); +H5_DLL int H5Iinc_ref(hid_t id); +H5_DLL int H5Idec_ref(hid_t id); +H5_DLL int H5Iget_ref(hid_t id); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5MMpublic.h b/libs/cygwin/include/H5MMpublic.h new file mode 100755 index 0000000..1da1e36 --- /dev/null +++ b/libs/cygwin/include/H5MMpublic.h @@ -0,0 +1,45 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/*------------------------------------------------------------------------- + * + * Created: H5MMproto.h + * Jul 10 1997 + * Robb Matzke + * + * Purpose: Public declarations for the H5MM (memory management) + * package. + * + * Modifications: + * + *------------------------------------------------------------------------- + */ +#ifndef _H5MMpublic_H +#define _H5MMpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +/* These typedefs are currently used for VL datatype allocation/freeing */ +typedef void *(* H5MM_allocate_t)(size_t size,void *info); +typedef void (* H5MM_free_t)(void *mem, void *free_info); + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Opublic.h b/libs/cygwin/include/H5Opublic.h new file mode 100755 index 0000000..e71ff9c --- /dev/null +++ b/libs/cygwin/include/H5Opublic.h @@ -0,0 +1,48 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/*------------------------------------------------------------------------- + * + * Created: H5Opublic.h + * Aug 5 1997 + * Robb Matzke + * + * Purpose: Public declarations for the H5O (object header) + * package. + * + * Modifications: + * + *------------------------------------------------------------------------- + */ +#ifndef _H5Opublic_H +#define _H5Opublic_H + +/* Public headers needed by this file */ +#include "H5public.h" + +typedef struct H5O_stat_t { + hsize_t size; /* Total size of object header in file */ + hsize_t free; /* Free space within object header */ + unsigned nmesgs; /* Number of object header messages */ + unsigned nchunks; /* Number of object header chunks */ +} H5O_stat_t; + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Ppublic.h b/libs/cygwin/include/H5Ppublic.h new file mode 100755 index 0000000..eedcda6 --- /dev/null +++ b/libs/cygwin/include/H5Ppublic.h @@ -0,0 +1,308 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains function prototypes for each exported function in the + * H5P module. + */ +#ifndef _H5Ppublic_H +#define _H5Ppublic_H + +/* Default Template for creation, access, etc. templates */ +#define H5P_DEFAULT 0 + +/* Public headers needed by this file */ +#include "H5public.h" +#include "H5Ipublic.h" +#include "H5Dpublic.h" +#include "H5Fpublic.h" +#include "H5FDpublic.h" +#include "H5MMpublic.h" +#include "H5Zpublic.h" + +/* Metroworks doesn't define off_t. */ +#ifdef __MWERKS__ +typedef long off_t; +/* Metroworks does not define EINTR in */ +# define EINTR 4 +#endif +/*__MWERKS__*/ + +#ifdef H5_WANT_H5_V1_4_COMPAT +/* Backward compatibility typedef... */ +typedef hid_t H5P_class_t; /* Alias H5P_class_t to hid_t */ + +/* H5P_DATASET_XFER was the name from the beginning through 1.2. It was + * changed to H5P_DATA_XFER on v1.3.0. Then it was changed back to + * H5P_DATASET_XFER right before the release of v1.4.0-beta2. + * Define an alias here to help applications that had ported to v1.3. + * Should be removed in later version. + */ +#define H5P_DATA_XFER H5P_DATASET_XFER +#endif /* H5_WANT_H5_V1_4_COMPAT */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* Define property list class callback function pointer types */ +typedef herr_t (*H5P_cls_create_func_t)(hid_t prop_id, void *create_data); +typedef herr_t (*H5P_cls_copy_func_t)(hid_t new_prop_id, hid_t old_prop_id, + void *copy_data); +typedef herr_t (*H5P_cls_close_func_t)(hid_t prop_id, void *close_data); + +/* Define property list callback function pointer types */ +typedef herr_t (*H5P_prp_cb1_t)(const char *name, size_t size, void *value); +typedef herr_t (*H5P_prp_cb2_t)(hid_t prop_id, const char *name, size_t size, void *value); +typedef H5P_prp_cb1_t H5P_prp_create_func_t; +typedef H5P_prp_cb2_t H5P_prp_set_func_t; +typedef H5P_prp_cb2_t H5P_prp_get_func_t; +typedef H5P_prp_cb2_t H5P_prp_delete_func_t; +typedef H5P_prp_cb1_t H5P_prp_copy_func_t; +typedef int (*H5P_prp_compare_func_t)(const void *value1, const void *value2, size_t size); +typedef H5P_prp_cb1_t H5P_prp_close_func_t; + +/* Define property list iteration function type */ +typedef herr_t (*H5P_iterate_t)(hid_t id, const char *name, void *iter_data); + +/* + * The library created property list classes + * + * NOTE: When adding H5P_* macros, remember to redefine them in H5Pprivate.h + * + */ + +/* When this header is included from H5Pprivate.h, don't make calls to H5open() */ +#undef H5OPEN +#ifndef _H5Pprivate_H +#define H5OPEN H5open(), +#else /* _H5Pprivate_H */ +#define H5OPEN +#endif /* _H5Pprivate_H */ + +#define H5P_NO_CLASS (H5OPEN H5P_CLS_NO_CLASS_g) +#define H5P_FILE_CREATE (H5OPEN H5P_CLS_FILE_CREATE_g) +#define H5P_FILE_ACCESS (H5OPEN H5P_CLS_FILE_ACCESS_g) +#define H5P_DATASET_CREATE (H5OPEN H5P_CLS_DATASET_CREATE_g) +#define H5P_DATASET_XFER (H5OPEN H5P_CLS_DATASET_XFER_g) +#define H5P_MOUNT (H5OPEN H5P_CLS_MOUNT_g) +H5_DLLVAR hid_t H5P_CLS_NO_CLASS_g; +H5_DLLVAR hid_t H5P_CLS_FILE_CREATE_g; +H5_DLLVAR hid_t H5P_CLS_FILE_ACCESS_g; +H5_DLLVAR hid_t H5P_CLS_DATASET_CREATE_g; +H5_DLLVAR hid_t H5P_CLS_DATASET_XFER_g; +H5_DLLVAR hid_t H5P_CLS_MOUNT_g; + +/* + * The library created default property lists + * + * NOTE: When adding H5P_* macros, remember to redefine them in H5Pprivate.h + * + */ +#define H5P_NO_CLASS_DEFAULT (H5OPEN H5P_LST_NO_CLASS_g) +#define H5P_FILE_CREATE_DEFAULT (H5OPEN H5P_LST_FILE_CREATE_g) +#define H5P_FILE_ACCESS_DEFAULT (H5OPEN H5P_LST_FILE_ACCESS_g) +#define H5P_DATASET_CREATE_DEFAULT (H5OPEN H5P_LST_DATASET_CREATE_g) +#define H5P_DATASET_XFER_DEFAULT (H5OPEN H5P_LST_DATASET_XFER_g) +#define H5P_MOUNT_DEFAULT (H5OPEN H5P_LST_MOUNT_g) +H5_DLLVAR hid_t H5P_LST_NO_CLASS_g; +H5_DLLVAR hid_t H5P_LST_FILE_CREATE_g; +H5_DLLVAR hid_t H5P_LST_FILE_ACCESS_g; +H5_DLLVAR hid_t H5P_LST_DATASET_CREATE_g; +H5_DLLVAR hid_t H5P_LST_DATASET_XFER_g; +H5_DLLVAR hid_t H5P_LST_MOUNT_g; + +/* Public functions */ +H5_DLL hid_t H5Pcreate_class(hid_t parent, const char *name, + H5P_cls_create_func_t cls_create, void *create_data, + H5P_cls_copy_func_t cls_copy, void *copy_data, + H5P_cls_close_func_t cls_close, void *close_data); +H5_DLL char *H5Pget_class_name(hid_t pclass_id); +H5_DLL hid_t H5Pcreate(hid_t cls_id); +H5_DLL herr_t H5Pregister(hid_t cls_id, const char *name, size_t size, + void *def_value, H5P_prp_create_func_t prp_create, + H5P_prp_set_func_t prp_set, H5P_prp_get_func_t prp_get, + H5P_prp_delete_func_t prp_del, + H5P_prp_copy_func_t prp_copy, + H5P_prp_close_func_t prp_close); +H5_DLL herr_t H5Pinsert(hid_t plist_id, const char *name, size_t size, + void *value, H5P_prp_set_func_t prp_set, H5P_prp_get_func_t prp_get, + H5P_prp_delete_func_t prp_delete, + H5P_prp_copy_func_t prp_copy, + H5P_prp_close_func_t prp_close); +H5_DLL herr_t H5Pset(hid_t plist_id, const char *name, void *value); +H5_DLL htri_t H5Pexist(hid_t plist_id, const char *name); +H5_DLL herr_t H5Pget_size(hid_t id, const char *name, size_t *size); +H5_DLL herr_t H5Pget_nprops(hid_t id, size_t *nprops); +H5_DLL hid_t H5Pget_class(hid_t plist_id); +H5_DLL hid_t H5Pget_class_parent(hid_t pclass_id); +H5_DLL herr_t H5Pget(hid_t plist_id, const char *name, void * value); +H5_DLL htri_t H5Pequal(hid_t id1, hid_t id2); +H5_DLL htri_t H5Pisa_class(hid_t plist_id, hid_t pclass_id); +H5_DLL int H5Piterate(hid_t id, int *idx, H5P_iterate_t iter_func, + void *iter_data); +H5_DLL herr_t H5Pcopy_prop(hid_t dst_id, hid_t src_id, const char *name); +H5_DLL herr_t H5Premove(hid_t plist_id, const char *name); +H5_DLL herr_t H5Punregister(hid_t pclass_id, const char *name); +H5_DLL herr_t H5Pclose_class(hid_t plist_id); +H5_DLL herr_t H5Pclose(hid_t plist_id); +H5_DLL hid_t H5Pcopy(hid_t plist_id); + +H5_DLL herr_t H5Pget_version(hid_t plist_id, int *boot/*out*/, + int *freelist/*out*/, int *stab/*out*/, + int *shhdr/*out*/); +H5_DLL herr_t H5Pset_userblock(hid_t plist_id, hsize_t size); +H5_DLL herr_t H5Pget_userblock(hid_t plist_id, hsize_t *size); +H5_DLL herr_t H5Pset_alignment(hid_t fapl_id, hsize_t threshold, + hsize_t alignment); +H5_DLL herr_t H5Pget_alignment(hid_t fapl_id, hsize_t *threshold/*out*/, + hsize_t *alignment/*out*/); +H5_DLL herr_t H5Pset_sizes(hid_t plist_id, size_t sizeof_addr, + size_t sizeof_size); +H5_DLL herr_t H5Pget_sizes(hid_t plist_id, size_t *sizeof_addr/*out*/, + size_t *sizeof_size/*out*/); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_sym_k(hid_t plist_id, int ik, int lk); +H5_DLL herr_t H5Pget_sym_k(hid_t plist_id, int *ik/*out*/, int *lk/*out*/); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_sym_k(hid_t plist_id, int ik, unsigned lk); +H5_DLL herr_t H5Pget_sym_k(hid_t plist_id, int *ik/*out*/, unsigned *lk/*out*/); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_istore_k(hid_t plist_id, int ik); +H5_DLL herr_t H5Pget_istore_k(hid_t plist_id, int *ik/*out*/); +H5_DLL herr_t H5Pset_layout(hid_t plist_id, H5D_layout_t layout); +H5_DLL H5D_layout_t H5Pget_layout(hid_t plist_id); +H5_DLL herr_t H5Pset_chunk(hid_t plist_id, int ndims, const hsize_t dim[]); +H5_DLL int H5Pget_chunk(hid_t plist_id, int max_ndims, hsize_t dim[]/*out*/); +H5_DLL herr_t H5Pset_external(hid_t plist_id, const char *name, off_t offset, + hsize_t size); +H5_DLL int H5Pget_external_count(hid_t plist_id); +H5_DLL herr_t H5Pget_external(hid_t plist_id, int idx, size_t name_size, + char *name/*out*/, off_t *offset/*out*/, + hsize_t *size/*out*/); +H5_DLL herr_t H5Pset_driver(hid_t plist_id, hid_t driver_id, + const void *driver_info); +H5_DLL hid_t H5Pget_driver(hid_t plist_id); +H5_DLL void *H5Pget_driver_info(hid_t plist_id); +H5_DLL herr_t H5Pset_family_offset(hid_t fapl_id, hsize_t offset); +H5_DLL herr_t H5Pget_family_offset(hid_t fapl_id, hsize_t *offset); +H5_DLL herr_t H5Pset_multi_type(hid_t fapl_id, H5FD_mem_t type); +H5_DLL herr_t H5Pget_multi_type(hid_t fapl_id, H5FD_mem_t *type); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_buffer(hid_t plist_id, hsize_t size, void *tconv, + void *bkg); +H5_DLL hsize_t H5Pget_buffer(hid_t plist_id, void **tconv/*out*/, + void **bkg/*out*/); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_buffer(hid_t plist_id, size_t size, void *tconv, + void *bkg); +H5_DLL size_t H5Pget_buffer(hid_t plist_id, void **tconv/*out*/, + void **bkg/*out*/); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_preserve(hid_t plist_id, hbool_t status); +H5_DLL int H5Pget_preserve(hid_t plist_id); +H5_DLL herr_t H5Pmodify_filter(hid_t plist_id, H5Z_filter_t filter, + unsigned int flags, size_t cd_nelmts, + const unsigned int cd_values[/*cd_nelmts*/]); +H5_DLL herr_t H5Pset_filter(hid_t plist_id, H5Z_filter_t filter, + unsigned int flags, size_t cd_nelmts, + const unsigned int c_values[]); +H5_DLL int H5Pget_nfilters(hid_t plist_id); +H5_DLL H5Z_filter_t H5Pget_filter(hid_t plist_id, int filter, + unsigned int *flags/*out*/, + size_t *cd_nelmts/*out*/, + unsigned cd_values[]/*out*/, + size_t namelen, char name[]); +H5_DLL H5Z_filter_t H5Pget_filter_by_id(hid_t plist_id, H5Z_filter_t id, + unsigned int *flags/*out*/, + size_t *cd_nelmts/*out*/, + unsigned cd_values[]/*out*/, + size_t namelen, char name[]); +H5_DLL htri_t H5Pall_filters_avail(hid_t plist_id); +H5_DLL herr_t H5Pset_deflate(hid_t plist_id, unsigned aggression); +H5_DLL herr_t H5Pset_szip(hid_t plist_id, unsigned options_mask, unsigned pixels_per_block); +H5_DLL herr_t H5Pset_shuffle(hid_t plist_id); +H5_DLL herr_t H5Pset_fletcher32(hid_t plist_id); +H5_DLL herr_t H5Pset_edc_check(hid_t plist_id, H5Z_EDC_t check); +H5_DLL H5Z_EDC_t H5Pget_edc_check(hid_t plist_id); +H5_DLL herr_t H5Pset_filter_callback(hid_t plist_id, H5Z_filter_func_t func, + void* op_data); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_cache(hid_t plist_id, int mdc_nelmts, int rdcc_nelmts, + size_t rdcc_nbytes, double rdcc_w0); +H5_DLL herr_t H5Pget_cache(hid_t plist_id, int *mdc_nelmts/*out*/, + int *rdcc_nelmts/*out*/, + size_t *rdcc_nbytes/*out*/, double *rdcc_w0); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_cache(hid_t plist_id, int mdc_nelmts, size_t rdcc_nelmts, + size_t rdcc_nbytes, double rdcc_w0); +H5_DLL herr_t H5Pget_cache(hid_t plist_id, int *mdc_nelmts/*out*/, + size_t *rdcc_nelmts/*out*/, + size_t *rdcc_nbytes/*out*/, double *rdcc_w0); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_hyper_cache(hid_t plist_id, unsigned cache, + unsigned limit); +H5_DLL herr_t H5Pget_hyper_cache(hid_t plist_id, unsigned *cache, + unsigned *limit); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_btree_ratios(hid_t plist_id, double left, double middle, + double right); +H5_DLL herr_t H5Pget_btree_ratios(hid_t plist_id, double *left/*out*/, + double *middle/*out*/, + double *right/*out*/); +H5_DLL herr_t H5Pset_fill_value(hid_t plist_id, hid_t type_id, + const void *value); +H5_DLL herr_t H5Pget_fill_value(hid_t plist_id, hid_t type_id, + void *value/*out*/); +H5_DLL herr_t H5Pfill_value_defined(hid_t plist, H5D_fill_value_t *status); +H5_DLL herr_t H5Pset_alloc_time(hid_t plist_id, H5D_alloc_time_t + alloc_time); +H5_DLL herr_t H5Pget_alloc_time(hid_t plist_id, H5D_alloc_time_t + *alloc_time/*out*/); +H5_DLL herr_t H5Pset_fill_time(hid_t plist_id, H5D_fill_time_t fill_time); +H5_DLL herr_t H5Pget_fill_time(hid_t plist_id, H5D_fill_time_t + *fill_time/*out*/); +H5_DLL herr_t H5Pset_gc_references(hid_t fapl_id, unsigned gc_ref); +H5_DLL herr_t H5Pget_gc_references(hid_t fapl_id, unsigned *gc_ref/*out*/); +H5_DLL herr_t H5Pset_fclose_degree(hid_t fapl_id, H5F_close_degree_t degree); +H5_DLL herr_t H5Pget_fclose_degree(hid_t fapl_id, H5F_close_degree_t *degree); +H5_DLL herr_t H5Pset_vlen_mem_manager(hid_t plist_id, + H5MM_allocate_t alloc_func, + void *alloc_info, H5MM_free_t free_func, + void *free_info); +H5_DLL herr_t H5Pget_vlen_mem_manager(hid_t plist_id, + H5MM_allocate_t *alloc_func, + void **alloc_info, + H5MM_free_t *free_func, + void **free_info); +H5_DLL herr_t H5Pset_meta_block_size(hid_t fapl_id, hsize_t size); +H5_DLL herr_t H5Pget_meta_block_size(hid_t fapl_id, hsize_t *size/*out*/); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Pset_sieve_buf_size(hid_t fapl_id, hsize_t size); +H5_DLL herr_t H5Pget_sieve_buf_size(hid_t fapl_id, hsize_t *size/*out*/); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_sieve_buf_size(hid_t fapl_id, size_t size); +H5_DLL herr_t H5Pget_sieve_buf_size(hid_t fapl_id, size_t *size/*out*/); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Pset_hyper_vector_size(hid_t fapl_id, size_t size); +H5_DLL herr_t H5Pget_hyper_vector_size(hid_t fapl_id, size_t *size/*out*/); +H5_DLL herr_t H5Pset_small_data_block_size(hid_t fapl_id, hsize_t size); +H5_DLL herr_t H5Pget_small_data_block_size(hid_t fapl_id, hsize_t *size/*out*/); +H5_DLL herr_t H5Premove_filter(hid_t plist_id, H5Z_filter_t filter); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Rpublic.h b/libs/cygwin/include/H5Rpublic.h new file mode 100755 index 0000000..9cdd56e --- /dev/null +++ b/libs/cygwin/include/H5Rpublic.h @@ -0,0 +1,85 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5S module. + */ +#ifndef _H5Rpublic_H +#define _H5Rpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" +#include "H5Gpublic.h" +#include "H5Ipublic.h" + +/* + * Reference types allowed. + */ +typedef enum { + H5R_BADTYPE = (-1), /*invalid Reference Type */ + H5R_OBJECT, /*Object reference */ + H5R_DATASET_REGION, /*Dataset Region Reference */ + H5R_INTERNAL, /*Internal Reference */ + H5R_MAXTYPE /*highest type (Invalid as true type) */ +} H5R_type_t; + +#ifdef LATER +/* Generic reference structure for user's code */ +typedef struct { + unsigned long oid[2]; /* OID of object referenced */ + unsigned long region[2]; /* heap ID of region in object */ + unsigned long file[2]; /* heap ID of external filename */ +} href_t; +#endif /* LATER */ + +/* Note! Be careful with the sizes of the references because they should really + * depend on the run-time values in the file. Unfortunately, the arrays need + * to be defined at compile-time, so we have to go with the worst case sizes for + * them. -QAK + */ +#define H5R_OBJ_REF_BUF_SIZE sizeof(haddr_t) +typedef haddr_t hobj_ref_t; /* Buffer to store OID of object referenced */ + /* Needs to be large enough to store largest haddr_t in a worst case machine (ie. 8 bytes currently) */ + +#define H5R_DSET_REG_REF_BUF_SIZE (sizeof(haddr_t)+4) +/* 4 is used instead of sizeof(int) to permit portability between + the Crays and other machines (the heap ID is always encoded as an int32 anyway) +*/ +/* Dataset Region reference structure for user's code */ +typedef unsigned char hdset_reg_ref_t[H5R_DSET_REG_REF_BUF_SIZE];/* Buffer to store heap ID and index */ +/* Needs to be large enough to store largest haddr_t in a worst case machine (ie. 8 bytes currently) plus an int */ + +/* Publicly visible datastructures */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* Functions in H5R.c */ +H5_DLL herr_t H5Rcreate(void *ref, hid_t loc_id, const char *name, + H5R_type_t ref_type, hid_t space_id); +H5_DLL hid_t H5Rdereference(hid_t dataset, H5R_type_t ref_type, void *ref); +H5_DLL hid_t H5Rget_region(hid_t dataset, H5R_type_t ref_type, void *ref); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL int H5Rget_object_type(hid_t dataset, void *_ref); +H5_DLL int H5Rget_obj_type(hid_t id, H5R_type_t ref_type, void *_ref); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL H5G_obj_t H5Rget_obj_type(hid_t id, H5R_type_t ref_type, void *_ref); +#endif /* H5_WANT_H5_V1_4_COMPAT */ + +#ifdef __cplusplus +} +#endif + +#endif /* _H5Rpublic_H */ diff --git a/libs/cygwin/include/H5Spublic.h b/libs/cygwin/include/H5Spublic.h new file mode 100755 index 0000000..8272dfa --- /dev/null +++ b/libs/cygwin/include/H5Spublic.h @@ -0,0 +1,149 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5S module. + */ +#ifndef _H5Spublic_H +#define _H5Spublic_H + +/* Public headers needed by this file */ +#include "H5public.h" +#include "H5Ipublic.h" + +/* Define atomic datatypes */ +#define H5S_ALL 0 +#define H5S_UNLIMITED ((hsize_t)(hssize_t)(-1)) + +/* Define user-level maximum number of dimensions */ +#define H5S_MAX_RANK 32 + +/* Different types of dataspaces */ +typedef enum H5S_class_t { + H5S_NO_CLASS = -1, /*error */ + H5S_SCALAR = 0, /*scalar variable */ + H5S_SIMPLE = 1, /*simple data space */ + H5S_COMPLEX = 2 /*complex data space */ +} H5S_class_t; + +/* Different ways of combining selections */ +typedef enum H5S_seloper_t { + H5S_SELECT_NOOP = -1, /* error */ + H5S_SELECT_SET = 0, /* Select "set" operation */ + H5S_SELECT_OR, /* Binary "or" operation for hyperslabs + * (add new selection to existing selection) + * Original region: AAAAAAAAAA + * New region: BBBBBBBBBB + * A or B: CCCCCCCCCCCCCCCC + */ + H5S_SELECT_AND, /* Binary "and" operation for hyperslabs + * (only leave overlapped regions in selection) + * Original region: AAAAAAAAAA + * New region: BBBBBBBBBB + * A and B: CCCC + */ + H5S_SELECT_XOR, /* Binary "xor" operation for hyperslabs + * (only leave non-overlapped regions in selection) + * Original region: AAAAAAAAAA + * New region: BBBBBBBBBB + * A xor B: CCCCCC CCCCCC + */ + H5S_SELECT_NOTB, /* Binary "not" operation for hyperslabs + * (only leave non-overlapped regions in original selection) + * Original region: AAAAAAAAAA + * New region: BBBBBBBBBB + * A not B: CCCCCC + */ + H5S_SELECT_NOTA, /* Binary "not" operation for hyperslabs + * (only leave non-overlapped regions in new selection) + * Original region: AAAAAAAAAA + * New region: BBBBBBBBBB + * B not A: CCCCCC + */ + H5S_SELECT_APPEND, /* Append elements to end of point selection */ + H5S_SELECT_PREPEND, /* Prepend elements to beginning of point selection */ + H5S_SELECT_INVALID /* Invalid upper bound on selection operations */ +} H5S_seloper_t; + +/* Enumerated type for the type of selection */ +typedef enum { + H5S_SEL_ERROR = -1, /* Error */ + H5S_SEL_NONE = 0, /* Nothing selected */ + H5S_SEL_POINTS = 1, /* Sequence of points selected */ + H5S_SEL_HYPERSLABS = 2, /* "New-style" hyperslab selection defined */ + H5S_SEL_ALL = 3, /* Entire extent selected */ + H5S_SEL_N = 4 /*THIS MUST BE LAST */ +}H5S_sel_type; + +#ifdef __cplusplus +extern "C" { +#endif + +/* Functions in H5S.c */ +H5_DLL hid_t H5Screate(H5S_class_t type); +H5_DLL hid_t H5Screate_simple(int rank, const hsize_t dims[], + const hsize_t maxdims[]); +H5_DLL herr_t H5Sset_extent_simple(hid_t space_id, int rank, + const hsize_t dims[], + const hsize_t max[]); +H5_DLL hid_t H5Scopy(hid_t space_id); +H5_DLL herr_t H5Sclose(hid_t space_id); +H5_DLL hssize_t H5Sget_simple_extent_npoints(hid_t space_id); +H5_DLL int H5Sget_simple_extent_ndims(hid_t space_id); +H5_DLL int H5Sget_simple_extent_dims(hid_t space_id, hsize_t dims[], + hsize_t maxdims[]); +H5_DLL htri_t H5Sis_simple(hid_t space_id); +H5_DLL herr_t H5Sset_space(hid_t space_id, int rank, const hsize_t *dims); +H5_DLL hssize_t H5Sget_select_npoints(hid_t spaceid); +H5_DLL herr_t H5Sselect_hyperslab(hid_t space_id, H5S_seloper_t op, + const hssize_t start[], + const hsize_t _stride[], + const hsize_t count[], + const hsize_t _block[]); +#ifdef NEW_HYPERSLAB_API +H5_DLL hid_t H5Scombine_hyperslab(hid_t space_id, H5S_seloper_t op, + const hssize_t start[], + const hsize_t _stride[], + const hsize_t count[], + const hsize_t _block[]); +H5_DLL herr_t H5Sselect_select(hid_t space1_id, H5S_seloper_t op, + hid_t space2_id); +H5_DLL hid_t H5Scombine_select(hid_t space1_id, H5S_seloper_t op, + hid_t space2_id); +#endif /* NEW_HYPERSLAB_API */ +H5_DLL herr_t H5Sselect_elements(hid_t space_id, H5S_seloper_t op, + size_t num_elemn, + const hssize_t **coord); +H5_DLL H5S_class_t H5Sget_simple_extent_type(hid_t space_id); +H5_DLL herr_t H5Sset_extent_none(hid_t space_id); +H5_DLL herr_t H5Sextent_copy(hid_t dst_id,hid_t src_id); +H5_DLL herr_t H5Sselect_all(hid_t spaceid); +H5_DLL herr_t H5Sselect_none(hid_t spaceid); +H5_DLL herr_t H5Soffset_simple(hid_t space_id, const hssize_t *offset); +H5_DLL htri_t H5Sselect_valid(hid_t spaceid); +H5_DLL hssize_t H5Sget_select_hyper_nblocks(hid_t spaceid); +H5_DLL hssize_t H5Sget_select_elem_npoints(hid_t spaceid); +H5_DLL herr_t H5Sget_select_hyper_blocklist(hid_t spaceid, hsize_t startblock, hsize_t numblocks, hsize_t *buf); +H5_DLL herr_t H5Sget_select_elem_pointlist(hid_t spaceid, hsize_t startpoint, hsize_t numpoints, hsize_t *buf); +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Sget_select_bounds(hid_t spaceid, hsize_t *start, hsize_t *end); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Sget_select_bounds(hid_t spaceid, hssize_t *start, hssize_t *end); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL H5S_sel_type H5Sget_select_type(hid_t spaceid); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Tpublic.h b/libs/cygwin/include/H5Tpublic.h new file mode 100755 index 0000000..8097546 --- /dev/null +++ b/libs/cygwin/include/H5Tpublic.h @@ -0,0 +1,566 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This file contains public declarations for the H5T module. + */ +#ifndef _H5Tpublic_H +#define _H5Tpublic_H + +/* Public headers needed by this file */ +#include "H5public.h" +#include "H5Ipublic.h" + +#define HOFFSET(S,M) (offsetof(S,M)) + +/* These are the various classes of data types */ +/* If this goes over 16 types (0-15), the file format will need to change) */ +typedef enum H5T_class_t { + H5T_NO_CLASS = -1, /*error */ + H5T_INTEGER = 0, /*integer types */ + H5T_FLOAT = 1, /*floating-point types */ + H5T_TIME = 2, /*date and time types */ + H5T_STRING = 3, /*character string types */ + H5T_BITFIELD = 4, /*bit field types */ + H5T_OPAQUE = 5, /*opaque types */ + H5T_COMPOUND = 6, /*compound types */ + H5T_REFERENCE = 7, /*reference types */ + H5T_ENUM = 8, /*enumeration types */ + H5T_VLEN = 9, /*Variable-Length types */ + H5T_ARRAY = 10, /*Array types */ + + H5T_NCLASSES /*this must be last */ +} H5T_class_t; + +/* Byte orders */ +typedef enum H5T_order_t { + H5T_ORDER_ERROR = -1, /*error */ + H5T_ORDER_LE = 0, /*little endian */ + H5T_ORDER_BE = 1, /*bit endian */ + H5T_ORDER_VAX = 2, /*VAX mixed endian */ + H5T_ORDER_NONE = 3 /*no particular order (strings, bits,..) */ + /*H5T_ORDER_NONE must be last */ +} H5T_order_t; + +/* Types of integer sign schemes */ +typedef enum H5T_sign_t { + H5T_SGN_ERROR = -1, /*error */ + H5T_SGN_NONE = 0, /*this is an unsigned type */ + H5T_SGN_2 = 1, /*two's complement */ + + H5T_NSGN = 2 /*this must be last! */ +} H5T_sign_t; + +/* Floating-point normalization schemes */ +typedef enum H5T_norm_t { + H5T_NORM_ERROR = -1, /*error */ + H5T_NORM_IMPLIED = 0, /*msb of mantissa isn't stored, always 1 */ + H5T_NORM_MSBSET = 1, /*msb of mantissa is always 1 */ + H5T_NORM_NONE = 2 /*not normalized */ + /*H5T_NORM_NONE must be last */ +} H5T_norm_t; + +/* + * Character set to use for text strings. Do not change these values since + * they appear in HDF5 files! + */ +typedef enum H5T_cset_t { + H5T_CSET_ERROR = -1, /*error */ + H5T_CSET_ASCII = 0, /*US ASCII */ + H5T_CSET_RESERVED_1 = 1, /*reserved for later use */ + H5T_CSET_RESERVED_2 = 2, /*reserved for later use */ + H5T_CSET_RESERVED_3 = 3, /*reserved for later use */ + H5T_CSET_RESERVED_4 = 4, /*reserved for later use */ + H5T_CSET_RESERVED_5 = 5, /*reserved for later use */ + H5T_CSET_RESERVED_6 = 6, /*reserved for later use */ + H5T_CSET_RESERVED_7 = 7, /*reserved for later use */ + H5T_CSET_RESERVED_8 = 8, /*reserved for later use */ + H5T_CSET_RESERVED_9 = 9, /*reserved for later use */ + H5T_CSET_RESERVED_10 = 10, /*reserved for later use */ + H5T_CSET_RESERVED_11 = 11, /*reserved for later use */ + H5T_CSET_RESERVED_12 = 12, /*reserved for later use */ + H5T_CSET_RESERVED_13 = 13, /*reserved for later use */ + H5T_CSET_RESERVED_14 = 14, /*reserved for later use */ + H5T_CSET_RESERVED_15 = 15 /*reserved for later use */ +} H5T_cset_t; +#define H5T_NCSET 1 /*Number of character sets actually defined */ + +/* + * Type of padding to use in character strings. Do not change these values + * since they appear in HDF5 files! + */ +typedef enum H5T_str_t { + H5T_STR_ERROR = -1, /*error */ + H5T_STR_NULLTERM = 0, /*null terminate like in C */ + H5T_STR_NULLPAD = 1, /*pad with nulls */ + H5T_STR_SPACEPAD = 2, /*pad with spaces like in Fortran */ + H5T_STR_RESERVED_3 = 3, /*reserved for later use */ + H5T_STR_RESERVED_4 = 4, /*reserved for later use */ + H5T_STR_RESERVED_5 = 5, /*reserved for later use */ + H5T_STR_RESERVED_6 = 6, /*reserved for later use */ + H5T_STR_RESERVED_7 = 7, /*reserved for later use */ + H5T_STR_RESERVED_8 = 8, /*reserved for later use */ + H5T_STR_RESERVED_9 = 9, /*reserved for later use */ + H5T_STR_RESERVED_10 = 10, /*reserved for later use */ + H5T_STR_RESERVED_11 = 11, /*reserved for later use */ + H5T_STR_RESERVED_12 = 12, /*reserved for later use */ + H5T_STR_RESERVED_13 = 13, /*reserved for later use */ + H5T_STR_RESERVED_14 = 14, /*reserved for later use */ + H5T_STR_RESERVED_15 = 15 /*reserved for later use */ +} H5T_str_t; +#define H5T_NSTR 3 /*num H5T_str_t types actually defined */ + +/* Type of padding to use in other atomic types */ +typedef enum H5T_pad_t { + H5T_PAD_ERROR = -1, /*error */ + H5T_PAD_ZERO = 0, /*always set to zero */ + H5T_PAD_ONE = 1, /*always set to one */ + H5T_PAD_BACKGROUND = 2, /*set to background value */ + + H5T_NPAD = 3 /*THIS MUST BE LAST */ +} H5T_pad_t; + +/* Commands sent to conversion functions */ +typedef enum H5T_cmd_t { + H5T_CONV_INIT = 0, /*query and/or initialize private data */ + H5T_CONV_CONV = 1, /*convert data from source to dest data type */ + H5T_CONV_FREE = 2 /*function is being removed from path */ +} H5T_cmd_t; + +/* How is the `bkg' buffer used by the conversion function? */ +typedef enum H5T_bkg_t { + H5T_BKG_NO = 0, /*background buffer is not needed, send NULL */ + H5T_BKG_TEMP = 1, /*bkg buffer used as temp storage only */ + H5T_BKG_YES = 2 /*init bkg buf with data before conversion */ +} H5T_bkg_t; + +/* Type conversion client data */ +typedef struct H5T_cdata_t { + H5T_cmd_t command;/*what should the conversion function do? */ + H5T_bkg_t need_bkg;/*is the background buffer needed? */ + hbool_t recalc; /*recalculate private data */ + void *priv; /*private data */ +} H5T_cdata_t; + +/* Conversion function persistence */ +typedef enum H5T_pers_t { + H5T_PERS_DONTCARE = -1, /*wild card */ + H5T_PERS_HARD = 0, /*hard conversion function */ + H5T_PERS_SOFT = 1 /*soft conversion function */ +} H5T_pers_t; + +/* The order to retrieve atomic native datatype */ +typedef enum H5T_direction_t { + H5T_DIR_DEFAULT = 0, /*default direction is inscendent */ + H5T_DIR_ASCEND = 1, /*in inscendent order */ + H5T_DIR_DESCEND = 2 /*in descendent order */ +} H5T_direction_t; + +/* Variable Length Datatype struct in memory */ +/* (This is only used for VL sequences, not VL strings, which are stored in char *'s) */ +typedef struct { + size_t len; /* Length of VL data (in base type units) */ + void *p; /* Pointer to VL data */ +} hvl_t; + +/* Variable Length String information */ +#define H5T_VARIABLE ((size_t)(-1)) /* Indicate that a string is variable length (null-terminated in C, instead of fixed length) */ + +#ifdef __cplusplus +extern "C" { +#endif + +/* All data type conversion functions are... */ +typedef herr_t (*H5T_conv_t) (hid_t src_id, hid_t dst_id, H5T_cdata_t *cdata, + size_t nelmts, size_t buf_stride, size_t bkg_stride, void *buf, + void *bkg, hid_t dset_xfer_plist); + +/* + * If an error occurs during a data type conversion then the function + * registered with H5Tset_overflow() is called. It's arguments are the + * source and destination data types, a buffer which has the source value, + * and a buffer to receive an optional result for the overflow conversion. + * If the overflow handler chooses a value for the result it should return + * non-negative; otherwise the hdf5 library will choose an appropriate + * result. + */ +typedef herr_t (*H5T_overflow_t)(hid_t src_id, hid_t dst_id, + void *src_buf, void *dst_buf); + + +/* When this header is included from H5Tprivate.h, don't make calls to H5open() */ +#undef H5OPEN +#ifndef _H5Tprivate_H +#define H5OPEN H5open(), +#else /* _H5Tprivate_H */ +#define H5OPEN +#endif /* _H5Tprivate_H */ + +/* + * The IEEE floating point types in various byte orders. + */ +#define H5T_IEEE_F32BE (H5OPEN H5T_IEEE_F32BE_g) +#define H5T_IEEE_F32LE (H5OPEN H5T_IEEE_F32LE_g) +#define H5T_IEEE_F64BE (H5OPEN H5T_IEEE_F64BE_g) +#define H5T_IEEE_F64LE (H5OPEN H5T_IEEE_F64LE_g) +H5_DLLVAR hid_t H5T_IEEE_F32BE_g; +H5_DLLVAR hid_t H5T_IEEE_F32LE_g; +H5_DLLVAR hid_t H5T_IEEE_F64BE_g; +H5_DLLVAR hid_t H5T_IEEE_F64LE_g; + +/* + * These are "standard" types. For instance, signed (2's complement) and + * unsigned integers of various sizes and byte orders. + */ +#define H5T_STD_I8BE (H5OPEN H5T_STD_I8BE_g) +#define H5T_STD_I8LE (H5OPEN H5T_STD_I8LE_g) +#define H5T_STD_I16BE (H5OPEN H5T_STD_I16BE_g) +#define H5T_STD_I16LE (H5OPEN H5T_STD_I16LE_g) +#define H5T_STD_I32BE (H5OPEN H5T_STD_I32BE_g) +#define H5T_STD_I32LE (H5OPEN H5T_STD_I32LE_g) +#define H5T_STD_I64BE (H5OPEN H5T_STD_I64BE_g) +#define H5T_STD_I64LE (H5OPEN H5T_STD_I64LE_g) +#define H5T_STD_U8BE (H5OPEN H5T_STD_U8BE_g) +#define H5T_STD_U8LE (H5OPEN H5T_STD_U8LE_g) +#define H5T_STD_U16BE (H5OPEN H5T_STD_U16BE_g) +#define H5T_STD_U16LE (H5OPEN H5T_STD_U16LE_g) +#define H5T_STD_U32BE (H5OPEN H5T_STD_U32BE_g) +#define H5T_STD_U32LE (H5OPEN H5T_STD_U32LE_g) +#define H5T_STD_U64BE (H5OPEN H5T_STD_U64BE_g) +#define H5T_STD_U64LE (H5OPEN H5T_STD_U64LE_g) +#define H5T_STD_B8BE (H5OPEN H5T_STD_B8BE_g) +#define H5T_STD_B8LE (H5OPEN H5T_STD_B8LE_g) +#define H5T_STD_B16BE (H5OPEN H5T_STD_B16BE_g) +#define H5T_STD_B16LE (H5OPEN H5T_STD_B16LE_g) +#define H5T_STD_B32BE (H5OPEN H5T_STD_B32BE_g) +#define H5T_STD_B32LE (H5OPEN H5T_STD_B32LE_g) +#define H5T_STD_B64BE (H5OPEN H5T_STD_B64BE_g) +#define H5T_STD_B64LE (H5OPEN H5T_STD_B64LE_g) +#define H5T_STD_REF_OBJ (H5OPEN H5T_STD_REF_OBJ_g) +#define H5T_STD_REF_DSETREG (H5OPEN H5T_STD_REF_DSETREG_g) +H5_DLLVAR hid_t H5T_STD_I8BE_g; +H5_DLLVAR hid_t H5T_STD_I8LE_g; +H5_DLLVAR hid_t H5T_STD_I16BE_g; +H5_DLLVAR hid_t H5T_STD_I16LE_g; +H5_DLLVAR hid_t H5T_STD_I32BE_g; +H5_DLLVAR hid_t H5T_STD_I32LE_g; +H5_DLLVAR hid_t H5T_STD_I64BE_g; +H5_DLLVAR hid_t H5T_STD_I64LE_g; +H5_DLLVAR hid_t H5T_STD_U8BE_g; +H5_DLLVAR hid_t H5T_STD_U8LE_g; +H5_DLLVAR hid_t H5T_STD_U16BE_g; +H5_DLLVAR hid_t H5T_STD_U16LE_g; +H5_DLLVAR hid_t H5T_STD_U32BE_g; +H5_DLLVAR hid_t H5T_STD_U32LE_g; +H5_DLLVAR hid_t H5T_STD_U64BE_g; +H5_DLLVAR hid_t H5T_STD_U64LE_g; +H5_DLLVAR hid_t H5T_STD_B8BE_g; +H5_DLLVAR hid_t H5T_STD_B8LE_g; +H5_DLLVAR hid_t H5T_STD_B16BE_g; +H5_DLLVAR hid_t H5T_STD_B16LE_g; +H5_DLLVAR hid_t H5T_STD_B32BE_g; +H5_DLLVAR hid_t H5T_STD_B32LE_g; +H5_DLLVAR hid_t H5T_STD_B64BE_g; +H5_DLLVAR hid_t H5T_STD_B64LE_g; +H5_DLLVAR hid_t H5T_STD_REF_OBJ_g; +H5_DLLVAR hid_t H5T_STD_REF_DSETREG_g; + +/* + * Types which are particular to Unix. + */ +#define H5T_UNIX_D32BE (H5OPEN H5T_UNIX_D32BE_g) +#define H5T_UNIX_D32LE (H5OPEN H5T_UNIX_D32LE_g) +#define H5T_UNIX_D64BE (H5OPEN H5T_UNIX_D64BE_g) +#define H5T_UNIX_D64LE (H5OPEN H5T_UNIX_D64LE_g) +H5_DLLVAR hid_t H5T_UNIX_D32BE_g; +H5_DLLVAR hid_t H5T_UNIX_D32LE_g; +H5_DLLVAR hid_t H5T_UNIX_D64BE_g; +H5_DLLVAR hid_t H5T_UNIX_D64LE_g; + +/* + * Types particular to the C language. String types use `bytes' instead + * of `bits' as their size. + */ +#define H5T_C_S1 (H5OPEN H5T_C_S1_g) +H5_DLLVAR hid_t H5T_C_S1_g; + +/* + * Types particular to Fortran. + */ +#define H5T_FORTRAN_S1 (H5OPEN H5T_FORTRAN_S1_g) +H5_DLLVAR hid_t H5T_FORTRAN_S1_g; + +/* + * These types are for Intel CPU's. They are little endian with IEEE + * floating point. + */ +#define H5T_INTEL_I8 H5T_STD_I8LE +#define H5T_INTEL_I16 H5T_STD_I16LE +#define H5T_INTEL_I32 H5T_STD_I32LE +#define H5T_INTEL_I64 H5T_STD_I64LE +#define H5T_INTEL_U8 H5T_STD_U8LE +#define H5T_INTEL_U16 H5T_STD_U16LE +#define H5T_INTEL_U32 H5T_STD_U32LE +#define H5T_INTEL_U64 H5T_STD_U64LE +#define H5T_INTEL_B8 H5T_STD_B8LE +#define H5T_INTEL_B16 H5T_STD_B16LE +#define H5T_INTEL_B32 H5T_STD_B32LE +#define H5T_INTEL_B64 H5T_STD_B64LE +#define H5T_INTEL_F32 H5T_IEEE_F32LE +#define H5T_INTEL_F64 H5T_IEEE_F64LE + +/* + * These types are for DEC Alpha CPU's. They are little endian with IEEE + * floating point. + */ +#define H5T_ALPHA_I8 H5T_STD_I8LE +#define H5T_ALPHA_I16 H5T_STD_I16LE +#define H5T_ALPHA_I32 H5T_STD_I32LE +#define H5T_ALPHA_I64 H5T_STD_I64LE +#define H5T_ALPHA_U8 H5T_STD_U8LE +#define H5T_ALPHA_U16 H5T_STD_U16LE +#define H5T_ALPHA_U32 H5T_STD_U32LE +#define H5T_ALPHA_U64 H5T_STD_U64LE +#define H5T_ALPHA_B8 H5T_STD_B8LE +#define H5T_ALPHA_B16 H5T_STD_B16LE +#define H5T_ALPHA_B32 H5T_STD_B32LE +#define H5T_ALPHA_B64 H5T_STD_B64LE +#define H5T_ALPHA_F32 H5T_IEEE_F32LE +#define H5T_ALPHA_F64 H5T_IEEE_F64LE + +/* + * These types are for MIPS cpu's commonly used in SGI systems. They are big + * endian with IEEE floating point. + */ +#define H5T_MIPS_I8 H5T_STD_I8BE +#define H5T_MIPS_I16 H5T_STD_I16BE +#define H5T_MIPS_I32 H5T_STD_I32BE +#define H5T_MIPS_I64 H5T_STD_I64BE +#define H5T_MIPS_U8 H5T_STD_U8BE +#define H5T_MIPS_U16 H5T_STD_U16BE +#define H5T_MIPS_U32 H5T_STD_U32BE +#define H5T_MIPS_U64 H5T_STD_U64BE +#define H5T_MIPS_B8 H5T_STD_B8BE +#define H5T_MIPS_B16 H5T_STD_B16BE +#define H5T_MIPS_B32 H5T_STD_B32BE +#define H5T_MIPS_B64 H5T_STD_B64BE +#define H5T_MIPS_F32 H5T_IEEE_F32BE +#define H5T_MIPS_F64 H5T_IEEE_F64BE + +/* + * The predefined native types. These are the types detected by H5detect and + * they violate the naming scheme a little. Instead of a class name, + * precision and byte order as the last component, they have a C-like type + * name. If the type begins with `U' then it is the unsigned version of the + * integer type; other integer types are signed. The type LLONG corresponds + * to C's `long_long' and LDOUBLE is `long double' (these types might be the + * same as `LONG' and `DOUBLE' respectively. + */ +#define H5T_NATIVE_CHAR (CHAR_MIN?H5T_NATIVE_SCHAR:H5T_NATIVE_UCHAR) +#define H5T_NATIVE_SCHAR (H5OPEN H5T_NATIVE_SCHAR_g) +#define H5T_NATIVE_UCHAR (H5OPEN H5T_NATIVE_UCHAR_g) +#define H5T_NATIVE_SHORT (H5OPEN H5T_NATIVE_SHORT_g) +#define H5T_NATIVE_USHORT (H5OPEN H5T_NATIVE_USHORT_g) +#define H5T_NATIVE_INT (H5OPEN H5T_NATIVE_INT_g) +#define H5T_NATIVE_UINT (H5OPEN H5T_NATIVE_UINT_g) +#define H5T_NATIVE_LONG (H5OPEN H5T_NATIVE_LONG_g) +#define H5T_NATIVE_ULONG (H5OPEN H5T_NATIVE_ULONG_g) +#define H5T_NATIVE_LLONG (H5OPEN H5T_NATIVE_LLONG_g) +#define H5T_NATIVE_ULLONG (H5OPEN H5T_NATIVE_ULLONG_g) +#define H5T_NATIVE_FLOAT (H5OPEN H5T_NATIVE_FLOAT_g) +#define H5T_NATIVE_DOUBLE (H5OPEN H5T_NATIVE_DOUBLE_g) +#define H5T_NATIVE_LDOUBLE (H5OPEN H5T_NATIVE_LDOUBLE_g) +#define H5T_NATIVE_B8 (H5OPEN H5T_NATIVE_B8_g) +#define H5T_NATIVE_B16 (H5OPEN H5T_NATIVE_B16_g) +#define H5T_NATIVE_B32 (H5OPEN H5T_NATIVE_B32_g) +#define H5T_NATIVE_B64 (H5OPEN H5T_NATIVE_B64_g) +#define H5T_NATIVE_OPAQUE (H5OPEN H5T_NATIVE_OPAQUE_g) +#define H5T_NATIVE_HADDR (H5OPEN H5T_NATIVE_HADDR_g) +#define H5T_NATIVE_HSIZE (H5OPEN H5T_NATIVE_HSIZE_g) +#define H5T_NATIVE_HSSIZE (H5OPEN H5T_NATIVE_HSSIZE_g) +#define H5T_NATIVE_HERR (H5OPEN H5T_NATIVE_HERR_g) +#define H5T_NATIVE_HBOOL (H5OPEN H5T_NATIVE_HBOOL_g) +H5_DLLVAR hid_t H5T_NATIVE_SCHAR_g; +H5_DLLVAR hid_t H5T_NATIVE_UCHAR_g; +H5_DLLVAR hid_t H5T_NATIVE_SHORT_g; +H5_DLLVAR hid_t H5T_NATIVE_USHORT_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_g; +H5_DLLVAR hid_t H5T_NATIVE_LONG_g; +H5_DLLVAR hid_t H5T_NATIVE_ULONG_g; +H5_DLLVAR hid_t H5T_NATIVE_LLONG_g; +H5_DLLVAR hid_t H5T_NATIVE_ULLONG_g; +H5_DLLVAR hid_t H5T_NATIVE_FLOAT_g; +H5_DLLVAR hid_t H5T_NATIVE_DOUBLE_g; +H5_DLLVAR hid_t H5T_NATIVE_LDOUBLE_g; +H5_DLLVAR hid_t H5T_NATIVE_B8_g; +H5_DLLVAR hid_t H5T_NATIVE_B16_g; +H5_DLLVAR hid_t H5T_NATIVE_B32_g; +H5_DLLVAR hid_t H5T_NATIVE_B64_g; +H5_DLLVAR hid_t H5T_NATIVE_OPAQUE_g; +H5_DLLVAR hid_t H5T_NATIVE_HADDR_g; +H5_DLLVAR hid_t H5T_NATIVE_HSIZE_g; +H5_DLLVAR hid_t H5T_NATIVE_HSSIZE_g; +H5_DLLVAR hid_t H5T_NATIVE_HERR_g; +H5_DLLVAR hid_t H5T_NATIVE_HBOOL_g; + +/* C9x integer types */ +#define H5T_NATIVE_INT8 (H5OPEN H5T_NATIVE_INT8_g) +#define H5T_NATIVE_UINT8 (H5OPEN H5T_NATIVE_UINT8_g) +#define H5T_NATIVE_INT_LEAST8 (H5OPEN H5T_NATIVE_INT_LEAST8_g) +#define H5T_NATIVE_UINT_LEAST8 (H5OPEN H5T_NATIVE_UINT_LEAST8_g) +#define H5T_NATIVE_INT_FAST8 (H5OPEN H5T_NATIVE_INT_FAST8_g) +#define H5T_NATIVE_UINT_FAST8 (H5OPEN H5T_NATIVE_UINT_FAST8_g) +H5_DLLVAR hid_t H5T_NATIVE_INT8_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT8_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_LEAST8_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_LEAST8_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_FAST8_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_FAST8_g; + +#define H5T_NATIVE_INT16 (H5OPEN H5T_NATIVE_INT16_g) +#define H5T_NATIVE_UINT16 (H5OPEN H5T_NATIVE_UINT16_g) +#define H5T_NATIVE_INT_LEAST16 (H5OPEN H5T_NATIVE_INT_LEAST16_g) +#define H5T_NATIVE_UINT_LEAST16 (H5OPEN H5T_NATIVE_UINT_LEAST16_g) +#define H5T_NATIVE_INT_FAST16 (H5OPEN H5T_NATIVE_INT_FAST16_g) +#define H5T_NATIVE_UINT_FAST16 (H5OPEN H5T_NATIVE_UINT_FAST16_g) +H5_DLLVAR hid_t H5T_NATIVE_INT16_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT16_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_LEAST16_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_LEAST16_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_FAST16_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_FAST16_g; + +#define H5T_NATIVE_INT32 (H5OPEN H5T_NATIVE_INT32_g) +#define H5T_NATIVE_UINT32 (H5OPEN H5T_NATIVE_UINT32_g) +#define H5T_NATIVE_INT_LEAST32 (H5OPEN H5T_NATIVE_INT_LEAST32_g) +#define H5T_NATIVE_UINT_LEAST32 (H5OPEN H5T_NATIVE_UINT_LEAST32_g) +#define H5T_NATIVE_INT_FAST32 (H5OPEN H5T_NATIVE_INT_FAST32_g) +#define H5T_NATIVE_UINT_FAST32 (H5OPEN H5T_NATIVE_UINT_FAST32_g) +H5_DLLVAR hid_t H5T_NATIVE_INT32_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT32_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_LEAST32_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_LEAST32_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_FAST32_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_FAST32_g; + +#define H5T_NATIVE_INT64 (H5OPEN H5T_NATIVE_INT64_g) +#define H5T_NATIVE_UINT64 (H5OPEN H5T_NATIVE_UINT64_g) +#define H5T_NATIVE_INT_LEAST64 (H5OPEN H5T_NATIVE_INT_LEAST64_g) +#define H5T_NATIVE_UINT_LEAST64 (H5OPEN H5T_NATIVE_UINT_LEAST64_g) +#define H5T_NATIVE_INT_FAST64 (H5OPEN H5T_NATIVE_INT_FAST64_g) +#define H5T_NATIVE_UINT_FAST64 (H5OPEN H5T_NATIVE_UINT_FAST64_g) +H5_DLLVAR hid_t H5T_NATIVE_INT64_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT64_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_LEAST64_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_LEAST64_g; +H5_DLLVAR hid_t H5T_NATIVE_INT_FAST64_g; +H5_DLLVAR hid_t H5T_NATIVE_UINT_FAST64_g; + +/* Operations defined on all data types */ +H5_DLL hid_t H5Topen(hid_t loc_id, const char *name); +H5_DLL hid_t H5Tcreate(H5T_class_t type, size_t size); +H5_DLL hid_t H5Tcopy(hid_t type_id); +H5_DLL herr_t H5Tclose(hid_t type_id); +H5_DLL htri_t H5Tequal(hid_t type1_id, hid_t type2_id); +H5_DLL herr_t H5Tlock(hid_t type_id); +H5_DLL herr_t H5Tcommit(hid_t loc_id, const char *name, hid_t type_id); +H5_DLL htri_t H5Tcommitted(hid_t type_id); + +/* Operations defined on compound data types */ +H5_DLL herr_t H5Tinsert(hid_t parent_id, const char *name, size_t offset, + hid_t member_id); +H5_DLL herr_t H5Tpack(hid_t type_id); + +/* Operations defined on enumeration data types */ +H5_DLL hid_t H5Tenum_create(hid_t base_id); +H5_DLL herr_t H5Tenum_insert(hid_t type, const char *name, void *value); +H5_DLL herr_t H5Tenum_nameof(hid_t type, void *value, char *name/*out*/, + size_t size); +H5_DLL herr_t H5Tenum_valueof(hid_t type, const char *name, + void *value/*out*/); + +/* Operations defined on variable-length data types */ +H5_DLL hid_t H5Tvlen_create(hid_t base_id); + +/* Operations defined on array data types */ +H5_DLL hid_t H5Tarray_create(hid_t base_id, int ndims, + const hsize_t dim[/* ndims */], const int perm[/* ndims */]); +H5_DLL int H5Tget_array_ndims(hid_t type_id); +H5_DLL int H5Tget_array_dims(hid_t type_id, hsize_t dims[], int perm[]); + +/* Operations defined on opaque data types */ +H5_DLL herr_t H5Tset_tag(hid_t type, const char *tag); +H5_DLL char *H5Tget_tag(hid_t type); + +/* Querying property values */ +H5_DLL hid_t H5Tget_super(hid_t type); +H5_DLL H5T_class_t H5Tget_class(hid_t type_id); +H5_DLL htri_t H5Tdetect_class(hid_t type_id, H5T_class_t cls); +H5_DLL size_t H5Tget_size(hid_t type_id); +H5_DLL H5T_order_t H5Tget_order(hid_t type_id); +H5_DLL size_t H5Tget_precision(hid_t type_id); +H5_DLL int H5Tget_offset(hid_t type_id); +H5_DLL herr_t H5Tget_pad(hid_t type_id, H5T_pad_t *lsb/*out*/, + H5T_pad_t *msb/*out*/); +H5_DLL H5T_sign_t H5Tget_sign(hid_t type_id); +H5_DLL herr_t H5Tget_fields(hid_t type_id, size_t *spos/*out*/, + size_t *epos/*out*/, size_t *esize/*out*/, + size_t *mpos/*out*/, size_t *msize/*out*/); +H5_DLL size_t H5Tget_ebias(hid_t type_id); +H5_DLL H5T_norm_t H5Tget_norm(hid_t type_id); +H5_DLL H5T_pad_t H5Tget_inpad(hid_t type_id); +H5_DLL H5T_str_t H5Tget_strpad(hid_t type_id); +H5_DLL int H5Tget_nmembers(hid_t type_id); +H5_DLL char *H5Tget_member_name(hid_t type_id, int membno); +H5_DLL int H5Tget_member_index(hid_t type_id, const char *name); +H5_DLL size_t H5Tget_member_offset(hid_t type_id, int membno); +H5_DLL H5T_class_t H5Tget_member_class(hid_t type_id, int membno); +H5_DLL hid_t H5Tget_member_type(hid_t type_id, int membno); +H5_DLL herr_t H5Tget_member_value(hid_t type_id, int membno, + void *value/*out*/); +H5_DLL H5T_cset_t H5Tget_cset(hid_t type_id); +H5_DLL htri_t H5Tis_variable_str(hid_t type_id); +H5_DLL hid_t H5Tget_native_type(hid_t type_id, H5T_direction_t direction); + +/* Setting property values */ +H5_DLL herr_t H5Tset_size(hid_t type_id, size_t size); +H5_DLL herr_t H5Tset_order(hid_t type_id, H5T_order_t order); +H5_DLL herr_t H5Tset_precision(hid_t type_id, size_t prec); +H5_DLL herr_t H5Tset_offset(hid_t type_id, size_t offset); +H5_DLL herr_t H5Tset_pad(hid_t type_id, H5T_pad_t lsb, H5T_pad_t msb); +H5_DLL herr_t H5Tset_sign(hid_t type_id, H5T_sign_t sign); +H5_DLL herr_t H5Tset_fields(hid_t type_id, size_t spos, size_t epos, + size_t esize, size_t mpos, size_t msize); +H5_DLL herr_t H5Tset_ebias(hid_t type_id, size_t ebias); +H5_DLL herr_t H5Tset_norm(hid_t type_id, H5T_norm_t norm); +H5_DLL herr_t H5Tset_inpad(hid_t type_id, H5T_pad_t pad); +H5_DLL herr_t H5Tset_cset(hid_t type_id, H5T_cset_t cset); +H5_DLL herr_t H5Tset_strpad(hid_t type_id, H5T_str_t strpad); + +/* Type conversion database */ +H5_DLL herr_t H5Tregister(H5T_pers_t pers, const char *name, hid_t src_id, + hid_t dst_id, H5T_conv_t func); +H5_DLL herr_t H5Tunregister(H5T_pers_t pers, const char *name, hid_t src_id, + hid_t dst_id, H5T_conv_t func); +H5_DLL H5T_conv_t H5Tfind(hid_t src_id, hid_t dst_id, H5T_cdata_t **pcdata); +H5_DLL herr_t H5Tconvert(hid_t src_id, hid_t dst_id, size_t nelmts, + void *buf, void *background, hid_t plist_id); +H5_DLL H5T_overflow_t H5Tget_overflow(void); +H5_DLL herr_t H5Tset_overflow(H5T_overflow_t func); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/H5Zpublic.h b/libs/cygwin/include/H5Zpublic.h new file mode 100755 index 0000000..e4db1b0 --- /dev/null +++ b/libs/cygwin/include/H5Zpublic.h @@ -0,0 +1,185 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* Programmer: Robb Matzke + * Thursday, April 16, 1998 + */ + +#ifndef _H5Zpublic_H +#define _H5Zpublic_H + +/* + * Filter identifiers. Values 0 through 255 are for filters defined by the + * HDF5 library. Values 256 through 511 are available for testing new + * filters. Subsequent values should be obtained from the HDF5 development + * team at hdf5dev@ncsa.uiuc.edu. These values will never change because they + * appear in the HDF5 files. + */ +typedef int H5Z_filter_t; +#define H5Z_FILTER_ERROR (-1) /*no filter */ +#define H5Z_FILTER_NONE 0 /*reserved indefinitely */ +#define H5Z_FILTER_ALL 0 /*symbol to remove all filters in H5Premove_filter */ +#define H5Z_FILTER_DEFLATE 1 /*deflation like gzip */ +#define H5Z_FILTER_SHUFFLE 2 /*shuffle the data */ +#define H5Z_FILTER_FLETCHER32 3 /*fletcher32 checksum of EDC */ +#define H5Z_FILTER_SZIP 4 /*szip compression */ +#define H5Z_FILTER_RESERVED 256 /*filter ids below this value are reserved */ +#define H5Z_FILTER_MAX 65535 /*maximum filter id */ +#define H5Z_MAX_NFILTERS 32 /* Maximum number of filters allowed in a pipeline (should probably be allowed to be an unlimited amount) */ + +/* Flags for filter definition */ +#define H5Z_FLAG_DEFMASK 0x00ff /*definition flag mask */ +#define H5Z_FLAG_MANDATORY 0x0000 /*filter is mandatory */ +#define H5Z_FLAG_OPTIONAL 0x0001 /*filter is optional */ + +/* Additional flags for filter invocation */ +#define H5Z_FLAG_INVMASK 0xff00 /*invocation flag mask */ +#define H5Z_FLAG_REVERSE 0x0100 /*reverse direction; read */ +#define H5Z_FLAG_SKIP_EDC 0x0200 /*skip EDC filters for read */ + +/* Special parameters for szip compression */ +/* [These are aliases for the similar definitions in szlib.h, which we can't + * include directly due to the duplication of various symbols with the zlib.h + * header file] */ +#define H5_SZIP_ALLOW_K13_OPTION_MASK 1 +#define H5_SZIP_CHIP_OPTION_MASK 2 +#define H5_SZIP_EC_OPTION_MASK 4 +#define H5_SZIP_NN_OPTION_MASK 32 +#define H5_SZIP_MAX_PIXELS_PER_BLOCK 32 + +/* Values to decide if EDC is enabled for reading data */ +typedef enum H5Z_EDC_t { + H5Z_ERROR_EDC = -1, /* error value */ + H5Z_DISABLE_EDC = 0, + H5Z_ENABLE_EDC = 1, + H5Z_NO_EDC = 2 /* must be the last */ +} H5Z_EDC_t; + +/* Bit flags for H5Zget_filter_info */ +#define H5Z_FILTER_CONFIG_ENCODE_ENABLED (0x0001) +#define H5Z_FILTER_CONFIG_DECODE_ENABLED (0x0002) + +/* Return values for filter callback function */ +typedef enum H5Z_cb_return_t { + H5Z_CB_ERROR = -1, + H5Z_CB_FAIL = 0, /* I/O should fail if filter fails. */ + H5Z_CB_CONT = 1, /* I/O continues if filter fails. */ + H5Z_CB_NO = 2 +} H5Z_cb_return_t; + +/* Filter callback function definition */ +typedef H5Z_cb_return_t (*H5Z_filter_func_t)(H5Z_filter_t filter, void* buf, + size_t buf_size, void* op_data); + +/* Structure for filter callback property */ +typedef struct H5Z_cb_t { + H5Z_filter_func_t func; + void* op_data; +} H5Z_cb_t; + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Before a dataset gets created, the "can_apply" callbacks for any filters used + * in the dataset creation property list are called + * with the dataset's dataset creation property list, the dataset's datatype and + * a dataspace describing a chunk (for chunked dataset storage). + * + * The "can_apply" callback must determine if the combination of the dataset + * creation property list setting, the datatype and the dataspace represent a + * valid combination to apply this filter to. For example, some cases of + * invalid combinations may involve the filter not operating correctly on + * certain datatypes (or certain datatype sizes), or certain sizes of the chunk + * dataspace. + * + * The "can_apply" callback can be the NULL pointer, in which case, the library + * will assume that it can apply to any combination of dataset creation + * property list values, datatypes and dataspaces. + * + * The "can_apply" callback returns positive a valid combination, zero for an + * invalid combination and negative for an error. + */ +typedef herr_t (*H5Z_can_apply_func_t)(hid_t dcpl_id, hid_t type_id, hid_t space_id); + +/* + * After the "can_apply" callbacks are checked for new datasets, the "set_local" + * callbacks for any filters used in the dataset creation property list are + * called. These callbacks receive the dataset's private copy of the dataset + * creation property list passed in to H5Dcreate (i.e. not the actual property + * list passed in to H5Dcreate) and the datatype ID passed in to H5Dcreate + * (which is not copied and should not be modified) and a dataspace describing + * the chunk (for chunked dataset storage) (which should also not be modified). + * + * The "set_local" callback must set any parameters that are specific to this + * dataset, based on the combination of the dataset creation property list + * values, the datatype and the dataspace. For example, some filters perform + * different actions based on different datatypes (or datatype sizes) or + * different number of dimensions or dataspace sizes. + * + * The "set_local" callback can be the NULL pointer, in which case, the library + * will assume that there are no dataset-specific settings for this filter. + * + * The "set_local" callback must return non-negative on success and negative + * for an error. + */ +typedef herr_t (*H5Z_set_local_func_t)(hid_t dcpl_id, hid_t type_id, hid_t space_id); + +/* + * A filter gets definition flags and invocation flags (defined above), the + * client data array and size defined when the filter was added to the + * pipeline, the size in bytes of the data on which to operate, and pointers + * to a buffer and its allocated size. + * + * The filter should store the result in the supplied buffer if possible, + * otherwise it can allocate a new buffer, freeing the original. The + * allocated size of the new buffer should be returned through the BUF_SIZE + * pointer and the new buffer through the BUF pointer. + * + * The return value from the filter is the number of bytes in the output + * buffer. If an error occurs then the function should return zero and leave + * all pointer arguments unchanged. + */ +typedef size_t (*H5Z_func_t)(unsigned int flags, size_t cd_nelmts, + const unsigned int cd_values[], size_t nbytes, + size_t *buf_size, void **buf); + +/* + * The filter table maps filter identification numbers to structs that + * contain a pointers to the filter function and timing statistics. + */ +typedef struct H5Z_class_t { + H5Z_filter_t id; /* Filter ID number */ + const char *name; /* Comment for debugging */ + H5Z_can_apply_func_t can_apply; /* The "can apply" callback for a filter */ + H5Z_set_local_func_t set_local; /* The "set local" callback for a filter */ + H5Z_func_t filter; /* The actual filter function */ +} H5Z_class_t; + +#ifdef H5_WANT_H5_V1_4_COMPAT +H5_DLL herr_t H5Zregister(H5Z_filter_t id, const char *comment, + H5Z_func_t filter); +#else /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Zregister(const H5Z_class_t *cls); +#endif /* H5_WANT_H5_V1_4_COMPAT */ +H5_DLL herr_t H5Zunregister(H5Z_filter_t id); +H5_DLL htri_t H5Zfilter_avail(H5Z_filter_t id); +H5_DLL herr_t H5Zget_filter_info(H5Z_filter_t filter, unsigned int *filter_config_flags); + +#ifdef __cplusplus +} +#endif +#endif + diff --git a/libs/cygwin/include/H5api_adpt.h b/libs/cygwin/include/H5api_adpt.h new file mode 100755 index 0000000..d2af250 --- /dev/null +++ b/libs/cygwin/include/H5api_adpt.h @@ -0,0 +1,66 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * H5api_adpt.h + * Used for the HDF5 dll project + * Created by Patrick Lu on 1/12/99 + */ +#ifndef H5API_ADPT_H +#define H5API_ADPT_H + +#if defined(WIN32) + +#if defined(_HDF5DLL_) +#pragma warning(disable: 4273) /* Disable the dll linkage warnings */ +#define H5_DLL __declspec(dllexport) +#define H5_DLLVAR __declspec(dllexport) +#elif defined(_HDF5USEDLL_) +#define H5_DLL __declspec(dllimport) +#define H5_DLLVAR __declspec(dllimport) +#else +#define H5_DLL +#define H5_DLLVAR extern +#endif /* _HDF5DLL_ */ + +#if defined(_HDF5TESTDLL_) +#pragma warning(disable: 4273) /* Disable the dll linkage warnings */ +#define H5TEST_DLL __declspec(dllexport) +#define H5TEST_DLLVAR __declspec(dllexport) +#elif defined(_HDF5TESTUSEDLL_) +#define H5TEST_DLL __declspec(dllimport) +#define H5TEST_DLLVAR __declspec(dllimport) +#else +#define H5TEST_DLL +#define H5TEST_DLLVAR extern +#endif /* _HDF5TESTDLL_ */ + +/* Added to export or to import C++ APIs - BMR (02-15-2002) */ +#if defined(HDF5_CPPDLL_EXPORTS) /* this name is generated at creation */ +#define H5_DLLCPP __declspec(dllexport) +#elif defined(HDF5CPP_USEDLL) +#define H5_DLLCPP __declspec(dllimport) +#else +#define H5_DLLCPP +#endif /* HDF5_CPPDLL_EXPORTS */ + +#else /*WIN32*/ +#define H5_DLL +#define H5_DLLVAR extern +#define H5_DLLCPP +#define H5TEST_DLL +#define H5TEST_DLLVAR extern +#endif + +#endif /* H5API_ADPT_H */ diff --git a/libs/cygwin/include/H5pubconf.h b/libs/cygwin/include/H5pubconf.h new file mode 100755 index 0000000..647efaa --- /dev/null +++ b/libs/cygwin/include/H5pubconf.h @@ -0,0 +1,537 @@ +/* src/H5config.h. Generated by configure. */ +/* src/H5config.h.in. Generated from configure.in by autoheader. */ + +/* Define if your system can handle converting denormalized floating-point + values. */ +#define H5_CONVERT_DENORMAL_FLOAT 1 + +/* Define if `dev_t' is a scalar */ +#define H5_DEV_T_IS_SCALAR 1 + +/* Define if gettimeofday() populates the tz pointer passed in */ +#define H5_GETTIMEOFDAY_GIVES_TZ 1 + +/* Define if the __attribute__(()) extension is present */ +#define H5_HAVE_ATTRIBUTE 1 + +/* Define to 1 if you have the `BSDgettimeofday' function. */ +/* #undef H5_HAVE_BSDGETTIMEOFDAY */ + +/* Define to 1 if you have the `difftime' function. */ +#define H5_HAVE_DIFFTIME 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_DLFCN_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_DMALLOC_H */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_FEATURES_H 1 + +/* Define if support for deflate filter is enabled */ +#define H5_HAVE_FILTER_DEFLATE 1 + +/* Define if support for Fletcher32 checksum is enabled */ +#define H5_HAVE_FILTER_FLETCHER32 1 + +/* Define if support for shuffle filter is enabled */ +#define H5_HAVE_FILTER_SHUFFLE 1 + +/* Define if support for szip filter is enabled */ +/* #undef H5_HAVE_FILTER_SZIP */ + +/* Define to 1 if you have the `fork' function. */ +#define H5_HAVE_FORK 1 + +/* Define to 1 if you have the `frexpf' function. */ +#define H5_HAVE_FREXPF 1 + +/* Define to 1 if you have the `frexpl' function. */ +/* #undef H5_HAVE_FREXPL */ + +/* Define to 1 if you have the `fseek64' function. */ +/* #undef H5_HAVE_FSEEK64 */ + +/* Define if the function stack tracing code is to be compiled in */ +/* #undef H5_HAVE_FUNCSTACK */ + +/* Define if the compiler understand the __FUNCTION__ keyword */ +#define H5_HAVE_FUNCTION 1 + +/* Define if the Globus GASS is defined */ +/* #undef H5_HAVE_GASS */ + +/* Define to 1 if you have the `GetConsoleScreenBufferInfo' function. */ +/* #undef H5_HAVE_GETCONSOLESCREENBUFFERINFO */ + +/* Define to 1 if you have the `gethostname' function. */ +#define H5_HAVE_GETHOSTNAME 1 + +/* Define to 1 if you have the `getpwuid' function. */ +#define H5_HAVE_GETPWUID 1 + +/* Define to 1 if you have the `getrusage' function. */ +#define H5_HAVE_GETRUSAGE 1 + +/* Define to 1 if you have the `gettextinfo' function. */ +/* #undef H5_HAVE_GETTEXTINFO */ + +/* Define to 1 if you have the `gettimeofday' function. */ +#define H5_HAVE_GETTIMEOFDAY 1 + +/* Define to 1 if you have the `get_fpc_csr' function. */ +/* #undef H5_HAVE_GET_FPC_CSR */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_GLOBUS_COMMON_H */ + +/* Define if we have GPFS support */ +/* #undef H5_HAVE_GPFS */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_GPFS_H */ + +/* Define if library will contain instrumentation to detect correct + optimization operation */ +/* #undef H5_HAVE_INSTRUMENTED_LIBRARY */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_INTTYPES_H 1 + +/* Define to 1 if you have the `ioctl' function. */ +#define H5_HAVE_IOCTL 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_IO_H 1 + +/* Define if it's safe to use `long long' for hsize_t and hssize_t */ +#define H5_HAVE_LARGE_HSIZET 1 + +/* Define to 1 if you have the `crypto' library (-lcrypto). */ +/* #undef H5_HAVE_LIBCRYPTO */ + +/* Define to 1 if you have the `dmalloc' library (-ldmalloc). */ +/* #undef H5_HAVE_LIBDMALLOC */ + +/* Define to 1 if you have the `elf' library (-lelf). */ +/* #undef H5_HAVE_LIBELF */ + +/* Define to 1 if you have the `globus_common' library (-lglobus_common). */ +/* #undef H5_HAVE_LIBGLOBUS_COMMON */ + +/* Define to 1 if you have the `globus_gaa' library (-lglobus_gaa). */ +/* #undef H5_HAVE_LIBGLOBUS_GAA */ + +/* Define to 1 if you have the `globus_gass_cache' library + (-lglobus_gass_cache). */ +/* #undef H5_HAVE_LIBGLOBUS_GASS_CACHE */ + +/* Define to 1 if you have the `globus_gass_file' library + (-lglobus_gass_file). */ +/* #undef H5_HAVE_LIBGLOBUS_GASS_FILE */ + +/* Define to 1 if you have the `globus_gass_transfer' library + (-lglobus_gass_transfer). */ +/* #undef H5_HAVE_LIBGLOBUS_GASS_TRANSFER */ + +/* Define to 1 if you have the `globus_gass_transfer_assist' library + (-lglobus_gass_transfer_assist). */ +/* #undef H5_HAVE_LIBGLOBUS_GASS_TRANSFER_ASSIST */ + +/* Define to 1 if you have the `globus_gss' library (-lglobus_gss). */ +/* #undef H5_HAVE_LIBGLOBUS_GSS */ + +/* Define to 1 if you have the `globus_gss_assist' library + (-lglobus_gss_assist). */ +/* #undef H5_HAVE_LIBGLOBUS_GSS_ASSIST */ + +/* Define to 1 if you have the `globus_io' library (-lglobus_io). */ +/* #undef H5_HAVE_LIBGLOBUS_IO */ + +/* Define to 1 if you have the `lmpe' library (-llmpe). */ +/* #undef H5_HAVE_LIBLMPE */ + +/* Define to 1 if you have the `m' library (-lm). */ +#define H5_HAVE_LIBM 1 + +/* Define to 1 if you have the `mpe' library (-lmpe). */ +/* #undef H5_HAVE_LIBMPE */ + +/* Define to 1 if you have the `mpi' library (-lmpi). */ +/* #undef H5_HAVE_LIBMPI */ + +/* Define to 1 if you have the `mpio' library (-lmpio). */ +/* #undef H5_HAVE_LIBMPIO */ + +/* Define to 1 if you have the `nsl' library (-lnsl). */ +/* #undef H5_HAVE_LIBNSL */ + +/* Define to 1 if you have the `pdb' library (-lpdb). */ +/* #undef H5_HAVE_LIBPDB */ + +/* Define to 1 if you have the `pthread' library (-lpthread). */ +/* #undef H5_HAVE_LIBPTHREAD */ + +/* Define to 1 if you have the `silo' library (-lsilo). */ +/* #undef H5_HAVE_LIBSILO */ + +/* Define to 1 if you have the `socket' library (-lsocket). */ +/* #undef H5_HAVE_LIBSOCKET */ + +/* Define to 1 if you have the `SrbClient' library (-lSrbClient). */ +/* #undef H5_HAVE_LIBSRBCLIENT */ + +/* Define to 1 if you have the `ssl' library (-lssl). */ +/* #undef H5_HAVE_LIBSSL */ + +/* Define to 1 if you have the `sz' library (-lsz). */ +/* #undef H5_HAVE_LIBSZ */ + +/* Define to 1 if you have the `z' library (-lz). */ +#define H5_HAVE_LIBZ 1 + +/* Define to 1 if you have the `longjmp' function. */ +#define H5_HAVE_LONGJMP 1 + +/* Define to 1 if you have the `lseek64' function. */ +/* #undef H5_HAVE_LSEEK64 */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_MEMORY_H 1 + +/* Define if we have MPE support */ +/* #undef H5_HAVE_MPE */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_MPE_H */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_NETINET_TCP_H 1 + +/* Define if we have parallel support */ +/* #undef H5_HAVE_PARALLEL */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_PDB_H */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_PTHREAD_H */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SETJMP_H 1 + +/* Define to 1 if you have the `setsysinfo' function. */ +/* #undef H5_HAVE_SETSYSINFO */ + +/* Define to 1 if you have the `sigaction' function. */ +#define H5_HAVE_SIGACTION 1 + +/* Define to 1 if you have the `signal' function. */ +#define H5_HAVE_SIGNAL 1 + +/* Define to 1 if you have the `snprintf' function. */ +#define H5_HAVE_SNPRINTF 1 + +/* Define if `socklen_t' is defined */ +#define H5_HAVE_SOCKLEN_T 1 + +/* Define if the SRB is defined */ +/* #undef H5_HAVE_SRB */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_SRBCLIENT_H */ + +/* Define if `struct stat' has the `st_blocks' field */ +#define H5_HAVE_STAT_ST_BLOCKS 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_STDDEF_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_STDINT_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_STDLIB_H 1 + +/* Define to 1 if you have the `strdup' function. */ +#define H5_HAVE_STRDUP 1 + +/* Define if the stream virtual file driver should be compiled */ +#define H5_HAVE_STREAM 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_STRINGS_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_STRING_H 1 + +/* Define if `struct text_info' is defined */ +/* #undef H5_HAVE_STRUCT_TEXT_INFO */ + +/* Define if `struct timezone' is defined */ +#define H5_HAVE_STRUCT_TIMEZONE 1 + +/* Define to 1 if `tm_zone' is member of `struct tm'. */ +/* #undef H5_HAVE_STRUCT_TM_TM_ZONE */ + +/* Define if `struct videoconfig' is defined */ +/* #undef H5_HAVE_STRUCT_VIDEOCONFIG */ + +/* Define to 1 if you have the `system' function. */ +#define H5_HAVE_SYSTEM 1 + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_SYS_FILIO_H */ + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_SYS_FPU_H */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_IOCTL_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_SYS_PROC_H */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_RESOURCE_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_SOCKET_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_STAT_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_SYS_SYSINFO_H */ + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_TIMEB_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_TIME_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_SYS_TYPES_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef H5_HAVE_SZLIB_H */ + +/* Define if we have thread safe support */ +/* #undef H5_HAVE_THREADSAFE */ + +/* Define if `timezone' is a global variable */ +/* #undef H5_HAVE_TIMEZONE */ + +/* Define if the ioctl TIOCGETD is defined */ +/* #undef H5_HAVE_TIOCGETD */ + +/* Define if the ioctl TIOGWINSZ is defined */ +/* #undef H5_HAVE_TIOCGWINSZ */ + +/* Define if `tm_gmtoff' is a member of `struct tm' */ +/* #undef H5_HAVE_TM_GMTOFF */ + +/* Define to 1 if your `struct tm' has `tm_zone'. Deprecated, use + `HAVE_STRUCT_TM_TM_ZONE' instead. */ +/* #undef H5_HAVE_TM_ZONE */ + +/* Define to 1 if you don't have `tm_zone' but do have the external array + `tzname'. */ +#define H5_HAVE_TZNAME 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_UNISTD_H 1 + +/* Define to 1 if you have the `vsnprintf' function. */ +#define H5_HAVE_VSNPRINTF 1 + +/* Define to 1 if you have the `waitpid' function. */ +#define H5_HAVE_WAITPID 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_WINSOCK_H 1 + +/* Define to 1 if you have the header file. */ +#define H5_HAVE_ZLIB_H 1 + +/* Define to 1 if you have the `_getvideoconfig' function. */ +/* #undef H5_HAVE__GETVIDEOCONFIG */ + +/* Define to 1 if you have the `_scrsize' function. */ +/* #undef H5_HAVE__SCRSIZE */ + +/* Define if `__tm_gmtoff' is a member of `struct tm' */ +/* #undef H5_HAVE___TM_GMTOFF */ + +/* Define if your system's `MPI_File_set_size' function works for files over + 2GB. */ +/* #undef H5_MPI_FILE_SET_SIZE_BIG */ + +/* Define if shared writing must be disabled (CodeWarrior only) */ +/* #undef H5_NO_SHARED_WRITING */ + +/* Define to the address where bug reports for this package should be sent. */ +#define H5_PACKAGE_BUGREPORT "hdfhelp@ncsa.uiuc.edu" + +/* Define to the full name of this package. */ +#define H5_PACKAGE_NAME "HDF5" + +/* Define to the full name and version of this package. */ +#define H5_PACKAGE_STRING "HDF5 1.6.3-patch" + +/* Define to the one symbol short name of this package. */ +#define H5_PACKAGE_TARNAME "hdf5" + +/* Define to the version of this package. */ +#define H5_PACKAGE_VERSION "1.6.3-patch" + +/* Width for printf() for type `long long' or `__int64', use `ll' */ +#define H5_PRINTF_LL_WIDTH "ll" + +/* The size of a `char', as computed by sizeof. */ +#define H5_SIZEOF_CHAR 1 + +/* The size of a `double', as computed by sizeof. */ +#define H5_SIZEOF_DOUBLE 8 + +/* The size of a `float', as computed by sizeof. */ +#define H5_SIZEOF_FLOAT 4 + +/* The size of a `int', as computed by sizeof. */ +#define H5_SIZEOF_INT 4 + +/* The size of a `int16_t', as computed by sizeof. */ +#define H5_SIZEOF_INT16_T 2 + +/* The size of a `int32_t', as computed by sizeof. */ +#define H5_SIZEOF_INT32_T 4 + +/* The size of a `int64_t', as computed by sizeof. */ +#define H5_SIZEOF_INT64_T 8 + +/* The size of a `int8_t', as computed by sizeof. */ +#define H5_SIZEOF_INT8_T 1 + +/* The size of a `int_fast16_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_FAST16_T 4 + +/* The size of a `int_fast32_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_FAST32_T 4 + +/* The size of a `int_fast64_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_FAST64_T 8 + +/* The size of a `int_fast8_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_FAST8_T 1 + +/* The size of a `int_least16_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_LEAST16_T 2 + +/* The size of a `int_least32_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_LEAST32_T 4 + +/* The size of a `int_least64_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_LEAST64_T 8 + +/* The size of a `int_least8_t', as computed by sizeof. */ +#define H5_SIZEOF_INT_LEAST8_T 1 + +/* The size of a `long', as computed by sizeof. */ +#define H5_SIZEOF_LONG 4 + +/* The size of a `long double', as computed by sizeof. */ +#define H5_SIZEOF_LONG_DOUBLE 12 + +/* The size of a `long long', as computed by sizeof. */ +#define H5_SIZEOF_LONG_LONG 8 + +/* The size of a `off_t', as computed by sizeof. */ +#define H5_SIZEOF_OFF_T 8 + +/* The size of a `short', as computed by sizeof. */ +#define H5_SIZEOF_SHORT 2 + +/* The size of a `size_t', as computed by sizeof. */ +#define H5_SIZEOF_SIZE_T 4 + +/* The size of a `ssize_t', as computed by sizeof. */ +#define H5_SIZEOF_SSIZE_T 4 + +/* The size of a `uint16_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT16_T 2 + +/* The size of a `uint32_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT32_T 4 + +/* The size of a `uint64_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT64_T 8 + +/* The size of a `uint8_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT8_T 1 + +/* The size of a `uint_fast16_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_FAST16_T 4 + +/* The size of a `uint_fast32_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_FAST32_T 4 + +/* The size of a `uint_fast64_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_FAST64_T 8 + +/* The size of a `uint_fast8_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_FAST8_T 1 + +/* The size of a `uint_least16_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_LEAST16_T 2 + +/* The size of a `uint_least32_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_LEAST32_T 4 + +/* The size of a `uint_least64_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_LEAST64_T 8 + +/* The size of a `uint_least8_t', as computed by sizeof. */ +#define H5_SIZEOF_UINT_LEAST8_T 1 + +/* The size of a `__int64', as computed by sizeof. */ +#define H5_SIZEOF___INT64 0 + +/* Define to 1 if you have the ANSI C header files. */ +#define H5_STDC_HEADERS 1 + +/* Define if your system supports pthread_attr_setscope(&attribute, + PTHREAD_SCOPE_SYSTEM) call. */ +/* #undef H5_SYSTEM_SCOPE_THREADS */ + +/* Define if szip encoder is present */ +/* #undef H5_SZIP_CAN_ENCODE */ + +/* Define to 1 if you can safely include both and . */ +#define H5_TIME_WITH_SYS_TIME 1 + +/* Define to 1 if your declares `struct tm'. */ +/* #undef H5_TM_IN_SYS_TIME */ + +/* Define if the HDF5 v1.4 compatibility functions are to be compiled in */ +/* #undef H5_WANT_H5_V1_4_COMPAT */ + +/* Define to 1 if your processor stores words with the most significant byte + first (like Motorola and SPARC, unlike Intel and VAX). */ +/* #undef H5_WORDS_BIGENDIAN */ + +/* Define to empty if `const' does not conform to ANSI C. */ +/* #undef H5_const */ + +/* Define as `__inline' if that's what the C compiler calls it, or to nothing + if it is not supported. */ +/* #undef H5_inline */ + +/* Define to `long' if does not define. */ +/* #undef H5_off_t */ + +/* Define to `unsigned long' if does not define. */ +/* #undef H5_size_t */ + +/* Define to `long' if does not define. */ +/* #undef H5_ssize_t */ diff --git a/libs/cygwin/include/H5public.h b/libs/cygwin/include/H5public.h new file mode 100755 index 0000000..6853f4b --- /dev/null +++ b/libs/cygwin/include/H5public.h @@ -0,0 +1,216 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* $Id: H5public.h,v 1.1.1.1 2004/11/02 15:54:58 cvs Exp $ */ + + +/* + * This file contains public declarations for the HDF5 module. + */ +#ifndef _H5public_H +#define _H5public_H + +/* Include files for public use... */ +/* + * Since H5pubconf.h is a generated header file, it is messy to try + * to put a #ifndef _H5pubconf_H ... #endif guard in it. + * HDF5 has set an internal rule that it is being included here. + * Source files should NOT include H5pubconf.h directly but include + * it via H5public.h. The #ifndef _H5public_H guard above would + * prevent repeated include. + */ +#include "H5pubconf.h" /*from configure */ + +#ifdef H5_HAVE_FEATURES_H +#include /*for setting POSIX, BSD, etc. compatibility */ +#endif +#ifdef H5_HAVE_SYS_TYPES_H +#include +#endif +#ifdef H5_STDC_HEADERS +# include /*for H5T_NATIVE_CHAR defn in H5Tpublic.h */ +#endif +#ifndef __cplusplus +#ifdef H5_HAVE_STDINT_H +# include /*for C9x types */ +#endif +#endif +#ifdef H5_HAVE_INTTYPES_H +# include /* For uint64_t on some platforms */ +#endif +#ifdef H5_HAVE_STDDEF_H +# include +#endif +#ifdef H5_HAVE_PARALLEL +# include +#ifndef MPI_FILE_NULL /*MPIO may be defined in mpi.h already */ +# include +#endif +#endif + +#ifdef H5_HAVE_GASS /*for Globus GASS I/O */ +#include "globus_common.h" +#include "globus_gass_file.h" +#endif + +#ifdef H5_HAVE_SRB /*for SRB I/O */ +#include +#endif + +#include "H5api_adpt.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* Version numbers */ +#define H5_VERS_MAJOR 1 /* For major interface/format changes */ +#define H5_VERS_MINOR 6 /* For minor interface/format changes */ +#define H5_VERS_RELEASE 3 /* For tweaks, bug-fixes, or development */ +#define H5_VERS_SUBRELEASE "patch" /* For pre-releases like snap0 */ + /* Empty string for real releases. */ +#define H5_VERS_INFO "HDF5 library version: 1.6.3-patch" /* Full version string */ + +#define H5check() H5check_version(H5_VERS_MAJOR,H5_VERS_MINOR, \ + H5_VERS_RELEASE) + +/* + * Status return values. Failed integer functions in HDF5 result almost + * always in a negative value (unsigned failing functions sometimes return + * zero for failure) while successfull return is non-negative (often zero). + * The negative failure value is most commonly -1, but don't bet on it. The + * proper way to detect failure is something like: + * + * if ((dset = H5Dopen (file, name))<0) { + * fprintf (stderr, "unable to open the requested dataset\n"); + * } + */ +typedef int herr_t; + + +/* + * Boolean type. Successful return values are zero (false) or positive + * (true). The typical true value is 1 but don't bet on it. Boolean + * functions cannot fail. Functions that return `htri_t' however return zero + * (false), positive (true), or negative (failure). The proper way to test + * for truth from a htri_t function is: + * + * if ((retval = H5Tcommitted(type))>0) { + * printf("data type is committed\n"); + * } else if (!retval) { + * printf("data type is not committed\n"); + * } else { + * printf("error determining whether data type is committed\n"); + * } + */ +typedef unsigned int hbool_t; +typedef int htri_t; + +/* Define the ssize_t type if it not is defined */ +#if H5_SIZEOF_SSIZE_T==0 +/* Undefine this size, we will re-define it in one of the sections below */ +#undef H5_SIZEOF_SSIZE_T +#if H5_SIZEOF_SIZE_T==H5_SIZEOF_INT +typedef int ssize_t; +# define H5_SIZEOF_SSIZE_T H5_SIZEOF_INT +#elif H5_SIZEOF_SIZE_T==H5_SIZEOF_LONG +typedef long ssize_t; +# define H5_SIZEOF_SSIZE_T H5_SIZEOF_LONG +#elif H5_SIZEOF_SIZE_T==H5_SIZEOF_LONG_LONG +typedef long long ssize_t; +# define H5_SIZEOF_SSIZE_T H5_SIZEOF_LONG_LONG +#elif H5_SIZEOF_SIZE_T==H5_SIZEOF___INT64 +typedef __int64 ssize_t; +# define H5_SIZEOF_SSIZE_T H5_SIZEOF___INT64 +#else /* Can't find matching type for ssize_t */ +# error "nothing appropriate for ssize_t" +#endif +#endif + +/* + * The sizes of file objects have their own types defined here. If large + * sizes are enabled then use a 64-bit data type, otherwise use the size of + * memory objects. + */ +#ifdef H5_HAVE_LARGE_HSIZET +# if H5_SIZEOF_LONG_LONG>=8 +typedef unsigned long long hsize_t; +typedef signed long long hssize_t; +# define H5_SIZEOF_HSIZE_T H5_SIZEOF_LONG_LONG +# elif H5_SIZEOF___INT64>=8 +typedef unsigned __int64 hsize_t; +typedef signed __int64 hssize_t; +# define H5_SIZEOF_HSIZE_T H5_SIZEOF___INT64 +# endif +#else /* H5_HAVE_LARGE_HSIZET */ +typedef size_t hsize_t; +typedef ssize_t hssize_t; +# define H5_SIZEOF_HSIZE_T H5_SIZEOF_SIZE_T +#endif /* H5_HAVE_LARGE_HSIZET */ + +/* + * File addresses have there own types. + */ +#if H5_SIZEOF_INT64_T>=8 + typedef uint64_t haddr_t; +# define HADDR_UNDEF ((haddr_t)(int64_t)(-1)) +# ifdef H5_HAVE_PARALLEL +# define HADDR_AS_MPI_TYPE MPI_LONG_LONG_INT +# endif /* H5_HAVE_PARALLEL */ +#elif H5_SIZEOF_INT>=8 + typedef unsigned haddr_t; +# define HADDR_UNDEF ((haddr_t)(-1)) +# ifdef H5_HAVE_PARALLEL +# define HADDR_AS_MPI_TYPE MPI_UNSIGNED +# endif /* H5_HAVE_PARALLEL */ +#elif H5_SIZEOF_LONG>=8 + typedef unsigned long haddr_t; +# define HADDR_UNDEF ((haddr_t)(long)(-1)) +# ifdef H5_HAVE_PARALLEL +# define HADDR_AS_MPI_TYPE MPI_UNSIGNED_LONG +# endif /* H5_HAVE_PARALLEL */ +#elif H5_SIZEOF_LONG_LONG>=8 + typedef unsigned long long haddr_t; +# define HADDR_UNDEF ((haddr_t)(long long)(-1)) +# ifdef H5_HAVE_PARALLEL +# define HADDR_AS_MPI_TYPE MPI_LONG_LONG_INT +# endif /* H5_HAVE_PARALLEL */ +#elif H5_SIZEOF___INT64>=8 + typedef unsigned __int64 haddr_t; +# define HADDR_UNDEF ((haddr_t)(__int64)(-1)) +# ifdef H5_HAVE_PARALLEL +# define HADDR_AS_MPI_TYPE MPI_LONG_LONG_INT +# endif /* H5_HAVE_PARALLEL */ +#else +# error "nothing appropriate for haddr_t" +#endif +#define HADDR_MAX (HADDR_UNDEF-1) + +/* Functions in H5.c */ +H5_DLL herr_t H5open(void); +H5_DLL herr_t H5close(void); +H5_DLL herr_t H5dont_atexit(void); +H5_DLL herr_t H5garbage_collect(void); +H5_DLL herr_t H5set_free_list_limits (int reg_global_lim, int reg_list_lim, + int arr_global_lim, int arr_list_lim, int blk_global_lim, + int blk_list_lim); +H5_DLL herr_t H5get_libversion(unsigned *majnum, unsigned *minnum, + unsigned *relnum); +H5_DLL herr_t H5check_version(unsigned majnum, unsigned minnum, + unsigned relnum); + +#ifdef __cplusplus +} +#endif +#endif diff --git a/libs/cygwin/include/hdf5.h b/libs/cygwin/include/hdf5.h new file mode 100755 index 0000000..76883aa --- /dev/null +++ b/libs/cygwin/include/hdf5.h @@ -0,0 +1,55 @@ +/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + * Copyright by the Board of Trustees of the University of Illinois. * + * All rights reserved. * + * * + * This file is part of HDF5. The full HDF5 copyright notice, including * + * terms governing use, modification, and redistribution, is contained in * + * the files COPYING and Copyright.html. COPYING can be found at the root * + * of the source code distribution tree; Copyright.html can be found at the * + * root level of an installed copy of the electronic HDF5 document set and * + * is linked from the top-level documents page. It can also be found at * + * http://hdf.ncsa.uiuc.edu/HDF5/doc/Copyright.html. If you do not have * + * access to either file, you may request a copy from hdfhelp@ncsa.uiuc.edu. * + * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ + +/* + * This is the main public HDF5 include file. Put further information in + * a particular header file and include that here, don't fill this file with + * lots of gunk... + */ +#ifndef _HDF5_H +#define _HDF5_H + +#include "H5public.h" +#include "H5Apublic.h" /* Attributes */ +#include "H5ACpublic.h" /* Metadata cache */ +#include "H5Bpublic.h" /* B-trees */ +#include "H5Dpublic.h" /* Datasets */ +#include "H5Epublic.h" /* Errors */ +#include "H5Fpublic.h" /* Files */ +#include "H5FDpublic.h" /* File drivers */ +#include "H5Gpublic.h" /* Groups */ +#include "H5HGpublic.h" /* Global heaps */ +#include "H5HLpublic.h" /* Local heaps */ +#include "H5Ipublic.h" /* ID management */ +#include "H5MMpublic.h" /* Memory management */ +#include "H5Opublic.h" /* Object headers */ +#include "H5Ppublic.h" /* Property lists */ +#include "H5Rpublic.h" /* References */ +#include "H5Spublic.h" /* Dataspaces */ +#include "H5Tpublic.h" /* Datatypes */ +#include "H5Zpublic.h" /* Data filters */ + +/* Predefined file drivers */ +#include "H5FDcore.h" /* Files stored entirely in memory */ +#include "H5FDfamily.h" /* File families */ +#include "H5FDgass.h" /* Remote files using GASS I/O */ +#include "H5FDlog.h" /* sec2 driver with I/O logging (for debugging) */ +#include "H5FDmpi.h" /* MPI-based file drivers */ +#include "H5FDmulti.h" /* Usage-partitioned file family */ +#include "H5FDsec2.h" /* POSIX unbuffered file I/O */ +#include "H5FDsrb.h" /* Remote access using SRB */ +#include "H5FDstdio.h" /* Standard C buffered I/O */ +#include "H5FDstream.h" /* In-memory files streamed via sockets */ + +#endif diff --git a/libs/cygwin/include/napi.h b/libs/cygwin/include/napi.h new file mode 100755 index 0000000..29b38c3 --- /dev/null +++ b/libs/cygwin/include/napi.h @@ -0,0 +1,315 @@ +/*--------------------------------------------------------------------------- + NeXus - Neutron & X-ray Common Data Format + + Application Program Interface Header File + + Copyright (C) 2000-2003 Mark Koennecke, Uwe Filges + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + For further information, see + + ----------------------------------------------------------------------------*/ + +#ifndef NEXUSAPI +#define NEXUSAPI + +/* NeXus HDF45 */ +#define NEXUS_VERSION "2.0.0." /* major.minor.patch */ + +#define CONSTCHAR char + +#if defined(_WIN32) && defined(_DLL) +# ifdef NX45DLL_EXPORTS +# define NX_EXTERNAL __declspec(dllexport) +# else +# define NX_EXTERNAL __declspec(dllimport) +# endif +#else +# define NX_EXTERNAL +#endif + +typedef void* NXhandle; /* really a pointer to a NexusFile structure */ +typedef int NXstatus; +typedef char NXname[128]; + +typedef enum {NXACC_READ=1, NXACC_RDWR=2, NXACC_CREATE=3, NXACC_CREATE4=4, NXACC_CREATE5=5} NXaccess; + +typedef struct { + char *iname; + int type; + }info_type, *pinfo; + +#define NX_OK 1 +#define NX_ERROR 0 +#define NX_EOD -1 + +#define NX_UNLIMITED -1 + +#define NX_MAXRANK 32 +#define NX_MAXNAMELEN 64 + + + + + +/*------------------------------------------------------------------------- + HDF Datatype values for datatype parameters + in the Nexus API + + NX_FLOAT32 32 bit float + NX_FLOAT64 64 nit float == double + NX_INT8 8 bit integer == byte + NX_UINT8 8 bit unsigned integer + NX_INT16 16 bit integer + NX_UINT16 16 bit unsigned integer + NX_INT32 32 bit integer + NX_UINT32 32 bit unsigned integer + NX_CHAR 8 bit character + +--------------------------------------------------------------------------*/ + + +/* Map NeXus to HDF types */ +#define NX_FLOAT32 5 +#define NX_FLOAT64 6 +#define NX_INT8 20 +#define NX_UINT8 21 +#define NX_INT16 22 +#define NX_UINT16 23 +#define NX_INT32 24 +#define NX_UINT32 25 +#define NX_CHAR 4 + +/* Map NeXus compression methods to HDF compression methods */ +#define NX_COMP_NONE 100 +#define NX_COMP_LZW 200 +#define NX_COMP_RLE 300 +#define NX_COMP_HUF 400 + + +#ifdef HDF4 +#include +#endif + +#ifdef HDF5 +#include +#endif + +typedef struct { +#ifdef HDF4 + int32 iTag; /* HDF4 variable */ + int32 iRef; /* HDF4 variable */ +#endif + +#ifdef HDF5 + char iTag5[1024]; /* HDF5 variable */ + char iRef5[1024]; /* HDF5 variable */ + char iRefd[1024]; /* HDF5 variable */ +#endif + } NXlink; + + + +#define NXMAXSTACK 50 + +#define CONCAT(__a,__b) __a##__b /* token concatenation */ + +#if defined(__unix) || defined(__unix__) || defined (__VMS) + +# ifdef __VMS +# define MANGLE(__arg) __arg +# else +# define MANGLE(__arg) CONCAT(__arg,_) +# endif + +# define CALLING_STYLE /* blank */ + +# define NXopen MANGLE(nxiopen) +# define NXclose MANGLE(nxiclose) +# define NXmakegroup MANGLE(nximakegroup) +# define NXopengroup MANGLE(nxiopengroup) +# define NXclosegroup MANGLE(nxiclosegroup) +# define NXmakedata MANGLE(nximakedata) +# define NXcompmakedata MANGLE(nxicompmakedata) +# define NXcompress MANGLE(nxicompress) +# define NXopendata MANGLE(nxiopendata) +# define NXclosedata MANGLE(nxiclosedata) +# define NXputdata MANGLE(nxiputdata) +# define NXputslab MANGLE(nxiputslab) +# define NXputattr MANGLE(nxiputattr) +# define NXgetdataID MANGLE(nxigetdataid) +# define NXmakelink MANGLE(nximakelink) +# define NXmalloc MANGLE(nximalloc) +# define NXfree MANGLE(nxifree) +# define NXflush MANGLE(nxiflush) + +# define NXgetinfo MANGLE(nxigetinfo) +# define NXgetnextentry MANGLE(nxigetnextentry) +# define NXgetdata MANGLE(nxigetdata) + +# define NXgetslab MANGLE(nxigetslab) +# define NXgetnextattr MANGLE(nxigetnextattr) +# define NXgetattr MANGLE(nxigetattr) +# define NXgetattrinfo MANGLE(nxigetattrinfo) +# define NXgetgroupID MANGLE(nxigetgroupid) +# define NXgetgroupinfo MANGLE(nxigetgroupinfo) +# define NXsameID MANGLE(nxisameid) +# define NXinitgroupdir MANGLE(nxiinitgroupdir) +# define NXinitattrdir MANGLE(nxiinitattrdir) +# define NXsetcache MANGLE(nxisetcache) +/* FORTRAN helpers - for NeXus internal use only */ +# define NXfopen MANGLE(nxifopen) +# define NXfclose MANGLE(nxifclose) +# define NXfflush MANGLE(nxifflush) +# define NXfmakedata MANGLE(nxifmakedata) +# define NXfcompmakedata MANGLE(nxifcompmakedata) +# define NXfcompress MANGLE(nxifcompress) +# define NXfputattr MANGLE(nxifputattr) + +#elif defined(_WIN32) +/* + * START OF WINDOWS SPECIFIC CONFIGURATION + * + * Added by Freddie Akeroyd 9/8/2002 + * + * Various PC calling conventions - you need only uncomment one of the following definitions of MANGLE() + * anlong with the appropriate CALLING_STYLE + * The choice arises because under Windows the default way FORTRAN calls FORTRAN is different + * from the dafault way C calls C, and so when you need to have FORTRAN calling C you must + * force them to use the same convention. Notice the use of "default way" above ... by choice + * of compiler options (or compiler vendor) you may actually have FORTRAN calling in the C way + * etc., so you might need to experiment with the options below until you get no "unresolved symbols" + * + * Choice 1: Should allow both FORTRAN and C NeXus interfaces to work in a "default" setup + * Choice 2: For when choice 1: gives problems and you only require the C interface + * Choice 3: An alternative to 1: which may allow both FORTRAN and C in a non-default setup + */ +# define MANGLE(__arg) __arg /* Choice 1 */ +# define CALLING_STYLE __stdcall /* Choice 1 */ +/* # define MANGLE(__arg) __arg /* Choice 2 */ +/* # define CALLING_STYLE /* Choice 2 */ +/* # define MANGLE(__arg) CONCAT(__arg,_) /* Choice 3 */ +/* # define CALLING_STYLE __stdcall /* Choice 3 */ +/* + * END OF WINDOWS SPECIFIC CONFIGURATION + */ +# define NXopen MANGLE(NXIOPEN) +# define NXclose MANGLE(NXICLOSE) +# define NXflush MANGLE(NXIFLUSH) +# define NXmakegroup MANGLE(NXIMAKEGROUP) +# define NXopengroup MANGLE(NXIOPENGROUP) +# define NXclosegroup MANGLE(NXICLOSEGROUP) +# define NXmakedata MANGLE(NXIMAKEDATA) +# define NXcompress MANGLE(NXICOMPRESS) +# define NXopendata MANGLE(NXIOPENDATA) +# define NXclosedata MANGLE(NXICLOSEDATA) +# define NXgetdata MANGLE(NXIGETDATA) +# define NXgetslab MANGLE(NXIGETSLAB) +# define NXgetattr MANGLE(NXIGETATTR) +# define NXgetdim MANGLE(NXIGETDIM) +# define NXputdata MANGLE(NXIPUTDATA) +# define NXputslab MANGLE(NXIPUTSLAB) +# define NXputattr MANGLE(NXIPUTATTR) +# define NXputdim MANGLE(NXIPUTDIM) +# define NXgetinfo MANGLE(NXIGETINFO) +# define NXgetgroupinfo MANGLE(NXIGETGROUPINFO) +# define NXsameID MANGLE(NXISAMEID) +# define NXinitgroupdir MANGLE(NXIINITGROUPDIR) +# define NXgetnextentry MANGLE(NXIGETNEXTENTRY) +# define NXgetattrinfo MANGLE(NXIGETATTRINFO) +# define NXinitattrdir MANGLE(NXIINITATTRDIR) +# define NXgetnextattr MANGLE(NXIGETNEXTATTR) +# define NXgetgroupID MANGLE(NXIGETGROUPID) +# define NXgetdataID MANGLE(NXIGETDATAID) +# define NXmakelink MANGLE(NXIMAKELINK) +# define NXmalloc MANGLE(NXIMALLOC) +# define NXfree MANGLE(NXIFREE) +/* FORTRAN helpers - for NeXus internal use only */ +# define NXfopen MANGLE(NXIFOPEN) +# define NXfclose MANGLE(NXIFCLOSE) +# define NXfflush MANGLE(NXIFFLUSH) +# define NXfmakedata MANGLE(NXIFMAKEDATA) +# define NXfcompmakedata MANGLE(NXIFCOMPMAKEDATA) +# define NXfcompress MANGLE(NXIFCOMPRESS) +# define NXfputattr MANGLE(NXIFPUTATTR) +#else +# error Cannot compile - unknown operating system +#endif + + +/* + * Standard interface + */ + +#ifdef __cplusplus +extern "C" { +#endif /* __cplusplus */ +NX_EXTERNAL NXstatus CALLING_STYLE NXopen(CONSTCHAR * filename, NXaccess access_method, NXhandle* pHandle); +NX_EXTERNAL NXstatus CALLING_STYLE NXclose(NXhandle* pHandle); +NX_EXTERNAL NXstatus CALLING_STYLE NXflush(NXhandle* pHandle); + +NX_EXTERNAL NXstatus CALLING_STYLE NXmakegroup (NXhandle handle, CONSTCHAR *name, char* NXclass); +NX_EXTERNAL NXstatus CALLING_STYLE NXopengroup (NXhandle handle, CONSTCHAR *name, char* NXclass); +NX_EXTERNAL NXstatus CALLING_STYLE NXclosegroup(NXhandle handle); + +NX_EXTERNAL NXstatus CALLING_STYLE NXmakedata (NXhandle handle, CONSTCHAR* label, int datatype, int rank, int dim[]); +NX_EXTERNAL NXstatus CALLING_STYLE NXcompmakedata (NXhandle handle, CONSTCHAR* label, int datatype, int rank, int dim[], int comp_typ, int bufsize[]); +NX_EXTERNAL NXstatus CALLING_STYLE NXcompress (NXhandle handle, int compr_type); +NX_EXTERNAL NXstatus CALLING_STYLE NXopendata (NXhandle handle, CONSTCHAR* label); +NX_EXTERNAL NXstatus CALLING_STYLE NXclosedata(NXhandle handle); +NX_EXTERNAL NXstatus CALLING_STYLE NXputdata(NXhandle handle, void* data); + +NX_EXTERNAL NXstatus CALLING_STYLE NXputattr(NXhandle handle, CONSTCHAR* name, void* data, int iDataLen, int iType); +NX_EXTERNAL NXstatus CALLING_STYLE NXputslab(NXhandle handle, void* data, int start[], int size[]); + +NX_EXTERNAL NXstatus CALLING_STYLE NXgetdataID(NXhandle handle, NXlink* pLink); +NX_EXTERNAL NXstatus CALLING_STYLE NXmakelink(NXhandle handle, NXlink* pLink); + +NX_EXTERNAL NXstatus CALLING_STYLE NXgetdata(NXhandle handle, void* data); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetinfo(NXhandle handle, int* rank, int dimension[], int* datatype); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetnextentry(NXhandle handle, NXname name, NXname nxclass, int* datatype); + +NX_EXTERNAL NXstatus CALLING_STYLE NXgetslab(NXhandle handle, void* data, int start[], int size[]); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetnextattr(NXhandle handle, NXname pName, int *iLength, int *iType); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetattr(NXhandle handle, char* name, void* data, int* iDataLen, int* iType); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetattrinfo(NXhandle handle, int* no_items); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetgroupID(NXhandle handle, NXlink* pLink); +NX_EXTERNAL NXstatus CALLING_STYLE NXgetgroupinfo(NXhandle handle, int* no_items, NXname name, NXname nxclass); +NX_EXTERNAL NXstatus CALLING_STYLE NXsameID(NXhandle handle, NXlink* pFirstID, NXlink* pSecondID); + +NX_EXTERNAL NXstatus CALLING_STYLE NXinitgroupdir(NXhandle handle); +NX_EXTERNAL NXstatus CALLING_STYLE NXinitattrdir(NXhandle handle); + +NX_EXTERNAL NXstatus CALLING_STYLE NXmalloc(void** data, int rank, int dimensions[], int datatype); +NX_EXTERNAL NXstatus CALLING_STYLE NXfree(void** data); + + +/*----------------------------------------------------------------------- + A non Nexus standard function to set an error handler +*/ +NX_EXTERNAL void CALLING_STYLE NXMSetError(void *pData, void (*ErrFunc)(void *pD, char *text)); + +/* + another special function for setting the default cache size for HDF-5 +*/ +NX_EXTERNAL NXstatus CALLING_STYLE NXsetcache(long newVal); + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif /*NEXUSAPI*/ + diff --git a/libs/cygwin/include/napi4.h b/libs/cygwin/include/napi4.h new file mode 100755 index 0000000..d564317 --- /dev/null +++ b/libs/cygwin/include/napi4.h @@ -0,0 +1,68 @@ +/*--------------------------------------------------------------------------- + NeXus - Neutron & X-ray Common Data Format + + Application Program Interface (HDF4) Header File + + Copyright (C) 1997-2002 Mark Koennecke, Przemek Klosowski + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + For further information, see + +----------------------------------------------------------------------------*/ +#define NXSIGNATURE 959697 + +#include "napi4.c" + +/* + * HDF4 interface + */ + + NXstatus CALLING_STYLE NX4open(CONSTCHAR *filename, NXaccess access_method, NXhandle* pHandle); + NXstatus CALLING_STYLE NX4close(NXhandle* pHandle); + NXstatus CALLING_STYLE NX4flush(NXhandle* pHandle); + + NXstatus CALLING_STYLE NX4makegroup (NXhandle handle, CONSTCHAR* Vgroup, char* NXclass); + NXstatus CALLING_STYLE NX4opengroup (NXhandle handle, CONSTCHAR* Vgroup, char* NXclass); + NXstatus CALLING_STYLE NX4closegroup(NXhandle handle); + + NXstatus CALLING_STYLE NX4makedata (NXhandle handle, CONSTCHAR* label, int datatype, int rank, int dim[]); + NXstatus CALLING_STYLE NX4compmakedata (NXhandle handle, CONSTCHAR* label, int datatype, int rank, int dim[], int comp_typ, int bufsize[]); + NXstatus CALLING_STYLE NX4compress (NXhandle handle, int compr_type); + NXstatus CALLING_STYLE NX4opendata (NXhandle handle, CONSTCHAR* label); + + NXstatus CALLING_STYLE NX4closedata(NXhandle handle); + + NXstatus CALLING_STYLE NX4getdata(NXhandle handle, void* data); + NXstatus CALLING_STYLE NX4getslab(NXhandle handle, void* data, int start[], int size[]); + NXstatus CALLING_STYLE NX4getattr(NXhandle handle, char* name, void* data, int* iDataLen, int* iType); + + NXstatus CALLING_STYLE NX4putdata(NXhandle handle, void* data); + NXstatus CALLING_STYLE NX4putslab(NXhandle handle, void* data, int start[], int size[]); + NXstatus CALLING_STYLE NX4putattr(NXhandle handle, CONSTCHAR* name, void* data, int iDataLen, int iType); + + NXstatus CALLING_STYLE NX4getinfo(NXhandle handle, int* rank, int dimension[], int* datatype); + NXstatus CALLING_STYLE NX4getgroupinfo(NXhandle handle, int* no_items, NXname name, NXname nxclass); + NXstatus CALLING_STYLE NX4initgroupdir(NXhandle handle); + NXstatus CALLING_STYLE NX4getnextentry(NXhandle handle, NXname name, NXname nxclass, int* datatype); + NXstatus CALLING_STYLE NX4getattrinfo(NXhandle handle, int* no_items); + NXstatus CALLING_STYLE NX4initattrdir(NXhandle handle); + NXstatus CALLING_STYLE NX4getnextattr(NXhandle handle, NXname pName, int *iLength, int *iType); + + NXstatus CALLING_STYLE NX4getgroupID(NXhandle handle, NXlink* pLink); + NXstatus CALLING_STYLE NX4getdataID(NXhandle handle, NXlink* pLink); + NXstatus CALLING_STYLE NX4makelink(NXhandle handle, NXlink* pLink); + NXstatus CALLING_STYLE NX4sameID(NXhandle handle, NXlink* pFirstID, NXlink* pSecondID); + diff --git a/libs/cygwin/include/napi5.h b/libs/cygwin/include/napi5.h new file mode 100755 index 0000000..61375e9 --- /dev/null +++ b/libs/cygwin/include/napi5.h @@ -0,0 +1,72 @@ +/*--------------------------------------------------------------------------- + NeXus - Neutron & X-ray Common Data Format + + Application Program Interface (HDF5) Header File + + Copyright (C) 1997-2002 Mark Koennecke, Przemek Klosowski + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + For further information, see + +----------------------------------------------------------------------------*/ +#define NX5SIGNATURE 959695 + +#include +#include "napi5.c" + +/* HDF5 interface */ + + NXstatus CALLING_STYLE NX5open(CONSTCHAR *filename, NXaccess access_method, NXhandle* pHandle); + NXstatus CALLING_STYLE NX5close(NXhandle* pHandle); + NXstatus CALLING_STYLE NX5flush(NXhandle* pHandle); + + NXstatus CALLING_STYLE NX5makegroup (NXhandle handle, CONSTCHAR *name, char* NXclass); + NXstatus CALLING_STYLE NX5opengroup (NXhandle handle, CONSTCHAR *name, char* NXclass); + NXstatus CALLING_STYLE NX5closegroup(NXhandle handle); + + NXstatus CALLING_STYLE NX5makedata (NXhandle handle, CONSTCHAR* label, int datatype, int rank, int dim[]); + NXstatus CALLING_STYLE NX5compmakedata (NXhandle handle, CONSTCHAR* label, int datatype, int rank, int dim[], int comp_typ, int bufsize[]); + NXstatus CALLING_STYLE NX5compress (NXhandle handle, int compr_type); + NXstatus CALLING_STYLE NX5opendata (NXhandle handle, CONSTCHAR* label); + NXstatus CALLING_STYLE NX5closedata(NXhandle handle); + NXstatus CALLING_STYLE NX5putdata(NXhandle handle, void* data); + + NXstatus CALLING_STYLE NX5putattr(NXhandle handle, CONSTCHAR* name, void* data, int iDataLen, int iType); + NXstatus CALLING_STYLE NX5putslab(NXhandle handle, void* data, int start[], int size[]); + + NXstatus CALLING_STYLE NX5getdataID(NXhandle handle, NXlink* pLink); + NXstatus CALLING_STYLE NX5makelink(NXhandle handle, NXlink* pLink); + + NXstatus CALLING_STYLE NX5getdata(NXhandle handle, void* data); + NXstatus CALLING_STYLE NX5getinfo(NXhandle handle, int* rank, int dimension[], int* datatype); + NXstatus CALLING_STYLE NX5getnextentry(NXhandle handle, NXname name, NXname nxclass, int* datatype); + + NXstatus CALLING_STYLE NX5getslab(NXhandle handle, void* data, int start[], int size[]); + NXstatus CALLING_STYLE NX5getnextattr(NXhandle handle, NXname pName, int *iLength, int *iType); + NXstatus CALLING_STYLE NX5getattr(NXhandle handle, char* name, void* data, int* iDataLen, int* iType); + NXstatus CALLING_STYLE NX5getattrinfo(NXhandle handle, int* no_items); + NXstatus CALLING_STYLE NX5getgroupID(NXhandle handle, NXlink* pLink); + NXstatus CALLING_STYLE NX5getgroupinfo(NXhandle handle, int* no_items, NXname name, NXname nxclass); + NXstatus CALLING_STYLE NX5sameID(NXhandle handle, NXlink* pFirstID, NXlink* pSecondID); + + NXstatus CALLING_STYLE NX5initgroupdir(NXhandle handle); + NXstatus CALLING_STYLE NX5initattrdir(NXhandle handle); + + +herr_t nxgroup_info(hid_t loc_id, const char *name, void *op_data); +herr_t attr_info(hid_t loc_id, const char *name, void *opdata); +herr_t group_info(hid_t loc_id, const char *name, void *opdata); + diff --git a/libs/cygwin/include/napif.inc b/libs/cygwin/include/napif.inc new file mode 100755 index 0000000..185c947 --- /dev/null +++ b/libs/cygwin/include/napif.inc @@ -0,0 +1,90 @@ +C------------------------------------------------------------------------------ +C NeXus - Neutron & X-ray Common Data Format +C +C Application Program Interface (Fortran 77) Header File +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 +C +C $Id: napif.inc,v 1.1.1.1 2004/11/02 15:54:58 cvs Exp $ +C------------------------------------------------------------------------------ + +C *** Version of NeXus interface - should be consistent with napi.h! + CHARACTER*5 NEXUS_VERSION + PARAMETER(NEXUS_VERSION='2.0.0') +C *** NXaccess enum - access modes for NXopen + INTEGER NXACC_READ,NXACC_RDWR,NXACC_CREATE, + + NXACC_CREATE4,NXACC_CREATE5 + PARAMETER(NXACC_READ=1,NXACC_RDWR=2,NXACC_CREATE=3, + + NXACC_CREATE4=4,NXACC_CREATE5=5) +C *** NXHANDLESIZE should be the size of an INTEGER*4 array that is (at least) +C *** large enough to hold an NXhandle structure + INTEGER NXHANDLESIZE + PARAMETER(NXHANDLESIZE=600) +C *** NXLINKSIZE is (at least) the size of an INTEGER*4 array that can hold +C *** an NXlink structure: we'll assume 64bit alignment of structure members for safety + INTEGER NXLINKSIZE + PARAMETER(NXLINKSIZE=1028) +C *** Possible NXstatus values - these are returned by all NX routines + INTEGER NX_OK,NX_ERROR,NX_EOD + PARAMETER(NX_OK=1,NX_ERROR=0,NX_EOD=-1) +C *** Maximum values defined in HDF standard + INTEGER NX_MAXRANK,NX_MAXNAMELEN + PARAMETER(NX_MAXRANK=32,NX_MAXNAMELEN=64) +C *** HDF datatypes used by Nexus - see hntdefs.h in HDF distribution + INTEGER DFNT_FLOAT32,DFNT_FLOAT64,DFNT_INT8,DFNT_UINT8,DFNT_INT16, + + DFNT_UINT16,DFNT_INT32,DFNT_UINT32,DFNT_UCHAR8,DFNT_CHAR8 + PARAMETER(DFNT_FLOAT32=5,DFNT_FLOAT64=6,DFNT_INT8=20, + + DFNT_UINT8=21,DFNT_INT16=22,DFNT_UINT16=23, + + DFNT_INT32=24,DFNT_UINT32=25,DFNT_UCHAR8=3, + + DFNT_CHAR8=4) +C *** NeXus names for HDF parameters + INTEGER NX_FLOAT32,NX_FLOAT64,NX_INT8,NX_UINT8,NX_INT16, + + NX_UINT16,NX_INT32,NX_UINT32,NX_CHAR + PARAMETER(NX_FLOAT32=5,NX_FLOAT64=6,NX_INT8=20, + + NX_UINT8=21,NX_INT16=22,NX_UINT16=23, + + NX_INT32=24,NX_UINT32=25,NX_CHAR=4) +C**** NeXus compression schemes + INTEGER NX_COMP_NONE, NX_COMP_LZW, NX_COMP_HUF, NX_COMP_RLE + PARAMETER(NX_COMP_NONE=100,NX_COMP_LZW=200,NX_COMP_RLE=300, + + NX_COMP_HUF=400) +C**** NeXus Unlimited Dimension + INTEGER NX_UNLIMITED + PARAMETER (NX_UNLIMITED=-1) + INTEGER NXOPEN, NXCLOSE, NXMAKEGROUP, NXOPENGROUP, NXCLOSEGROUP, + + NXMAKEDATA, NXOPENDATA, NXCLOSEDATA, NXGETDATA, + + NXGETCHARDATA, NXGETSLAB, NXGETATTR, NXGETCHARATTR, + + NXGETDIM, NXPUTDATA, NXPUTCHARDATA, NXPUTSLAB, + + NXPUTATTR, NXPUTCHARATTR, NXPUTDIM, NXGETINFO, + + NXGETNEXTENTRY, NXGETNEXTATTR, NXGETGROUPID, NXMAKELINK, + + NXGETGROUPINFO, NXINITGROUPDIR, NXGETATTRINFO, + + NXINITATTRDIR, NXFLUSH, NXCOMPMAKEDATA + LOGICAL NXSAMEID + EXTERNAL NXOPEN, NXCLOSE, NXMAKEGROUP, NXOPENGROUP, NXCLOSEGROUP, + + NXMAKEDATA, NXOPENDATA, NXCLOSEDATA, NXGETDATA, + + NXGETCHARDATA, NXGETSLAB, NXGETATTR, NXGETCHARATTR, + + NXGETDIM, NXPUTDATA, NXPUTCHARDATA, NXPUTSLAB, + + NXPUTATTR, NXPUTCHARATTR, NXPUTDIM, NXGETINFO, + + NXGETNEXTENTRY, NXGETNEXTATTR, NXGETGROUPID, NXMAKELINK, + + NXGETGROUPINFO, NXINITGROUPDIR, NXGETATTRINFO, + + NXINITATTRDIR, NXFLUSH, NXCOMPMAKEDATA, NXSAMEID + + + + + diff --git a/libs/cygwin/include/napif__.inc b/libs/cygwin/include/napif__.inc new file mode 100755 index 0000000..070920c --- /dev/null +++ b/libs/cygwin/include/napif__.inc @@ -0,0 +1,89 @@ +C------------------------------------------------------------------------------ +C NeXus - Neutron & X-ray Common Data Format +C +C Application Program Interface (Fortran 77) Header File +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 +C +C $Id: napif__.inc,v 1.1.1.1 2004/11/02 15:54:58 cvs Exp $ +C------------------------------------------------------------------------------ + +C *** Version of NeXus interface - should be consistent with napi.h! + CHARACTER*5 NEXUS_VERSION + PARAMETER(NEXUS_VERSION='2.0.0') +C *** NXaccess enum - access modes for NXopen + INTEGER NXACC_READ,NXACC_RDWR,NXACC_CREATE, NXACC_CREATE5 + PARAMETER(NXACC_READ=1,NXACC_RDWR=2,NXACC_CREATE=3, + + NXACC_CREATE4=4,NXACC_CREATE5=5) +C *** NXHANDLESIZE should be the size of an INTEGER*4 array that is (at least) +C *** large enough to hold an NXhandle structure + INTEGER NXHANDLESIZE + PARAMETER(NXHANDLESIZE=600) +C *** NXLINKSIZE is (at least) the size of an INTEGER*4 array that can hold +C *** an NXlink structure: we'll assume 64bit alignment of structure members for safety + INTEGER NXLINKSIZE + PARAMETER(NXLINKSIZE=1028) +C *** Possible NXstatus values - these are returned by all NX routines + INTEGER NX_OK,NX_ERROR,NX_EOD + PARAMETER(NX_OK=1,NX_ERROR=0,NX_EOD=-1) +C *** Maximum values defined in HDF standard + INTEGER NX_MAXRANK,NX_MAXNAMELEN + PARAMETER(NX_MAXRANK=32,NX_MAXNAMELEN=64) +C *** HDF datatypes used by Nexus - see hntdefs.h in HDF distribution + INTEGER DFNT_FLOAT32,DFNT_FLOAT64,DFNT_INT8,DFNT_UINT8,DFNT_INT16, + + DFNT_UINT16,DFNT_INT32,DFNT_UINT32,DFNT_UCHAR8,DFNT_CHAR8 + PARAMETER(DFNT_FLOAT32=5,DFNT_FLOAT64=6,DFNT_INT8=20, + + DFNT_UINT8=21,DFNT_INT16=22,DFNT_UINT16=23, + + DFNT_INT32=24,DFNT_UINT32=25,DFNT_UCHAR8=3, + + DFNT_CHAR8=4) +C *** NeXus names for HDF parameters + INTEGER NX_FLOAT32,NX_FLOAT64,NX_INT8,NX_UINT8,NX_INT16, + + NX_UINT16,NX_INT32,NX_UINT32,NX_CHAR + PARAMETER(NX_FLOAT32=5,NX_FLOAT64=6,NX_INT8=20, + + NX_UINT8=21,NX_INT16=22,NX_UINT16=23, + + NX_INT32=24,NX_UINT32=25,NX_CHAR=4) +C**** NeXus compression schemes + INTEGER NX_COMP_NONE, NX_COMP_LZW, NX_COMP_HUF, NX_COMP_RLE + PARAMETER(NX_COMP_NONE=100,NX_COMP_LZW=200,NX_COMP_RLE=300, + + NX_COMP_HUF=400) +C**** NeXus Unlimited Dimension + INTEGER NX_UNLIMITED + PARAMETER (NX_UNLIMITED=-1) + INTEGER NXOPEN, NXCLOSE, NXMAKEGROUP, NXOPENGROUP, NXCLOSEGROUP, + + NXMAKEDATA, NXOPENDATA, NXCLOSEDATA, NXGETDATA, + + NXGETCHARDATA, NXGETSLAB, NXGETATTR, NXGETCHARATTR, + + NXGETDIM, NXPUTDATA, NXPUTCHARDATA, NXPUTSLAB, + + NXPUTATTR, NXPUTCHARATTR, NXPUTDIM, NXGETINFO, + + NXGETNEXTENTRY, NXGETNEXTATTR, NXGETGROUPID, NXMAKELINK, + + NXGETGROUPINFO, NXINITGROUPDIR, NXGETATTRINFO, + + NXINITATTRDIR, NXFLUSH, NXCOMPMAKEDATA + LOGICAL NXSAMEID + EXTERNAL NXOPEN, NXCLOSE, NXMAKEGROUP, NXOPENGROUP, NXCLOSEGROUP, + + NXMAKEDATA, NXOPENDATA, NXCLOSEDATA, NXGETDATA, + + NXGETCHARDATA, NXGETSLAB, NXGETATTR, NXGETCHARATTR, + + NXGETDIM, NXPUTDATA, NXPUTCHARDATA, NXPUTSLAB, + + NXPUTATTR, NXPUTCHARATTR, NXPUTDIM, NXGETINFO, + + NXGETNEXTENTRY, NXGETNEXTATTR, NXGETGROUPID, NXMAKELINK, + + NXGETGROUPINFO, NXINITGROUPDIR, NXGETATTRINFO, + + NXINITATTRDIR, NXFLUSH, NXCOMPMAKEDATA, NXSAMEID + + + + + diff --git a/libs/cygwin/lib/CVS/Entries b/libs/cygwin/lib/CVS/Entries new file mode 100644 index 0000000..c6ef3a5 --- /dev/null +++ b/libs/cygwin/lib/CVS/Entries @@ -0,0 +1,8 @@ +/libNeXus.a/1.1/Fri Nov 5 08:46:11 2004// +/libdf.a/1.1/Fri Nov 5 08:46:11 2004// +/libhdf5.a/1.1/Fri Nov 5 08:46:11 2004// +/libhdf5.la/1.2/Fri Nov 12 10:31:30 2004// +/libhdf5.settings/1.3/Fri Nov 12 10:31:00 2004// +/libmfhdf.a/1.1/Fri Nov 5 08:46:11 2004// +/libudport.a/1.1/Fri Nov 5 08:46:11 2004// +D diff --git a/libs/cygwin/lib/CVS/Repository b/libs/cygwin/lib/CVS/Repository new file mode 100644 index 0000000..150e292 --- /dev/null +++ b/libs/cygwin/lib/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/libs/cygwin/lib diff --git a/libs/cygwin/lib/CVS/Root b/libs/cygwin/lib/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/libs/cygwin/lib/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/libs/cygwin/lib/libNeXus.a b/libs/cygwin/lib/libNeXus.a new file mode 100755 index 0000000..15b6948 Binary files /dev/null and b/libs/cygwin/lib/libNeXus.a differ diff --git a/libs/cygwin/lib/libdf.a b/libs/cygwin/lib/libdf.a new file mode 100755 index 0000000..ff82f9f Binary files /dev/null and b/libs/cygwin/lib/libdf.a differ diff --git a/libs/cygwin/lib/libhdf5.a b/libs/cygwin/lib/libhdf5.a new file mode 100755 index 0000000..9410e7a Binary files /dev/null and b/libs/cygwin/lib/libhdf5.a differ diff --git a/libs/cygwin/lib/libhdf5.la b/libs/cygwin/lib/libhdf5.la new file mode 100755 index 0000000..a431326 --- /dev/null +++ b/libs/cygwin/lib/libhdf5.la @@ -0,0 +1,32 @@ +# libhdf5.la - a libtool library file +# Generated by ltmain.sh - GNU libtool 1.4.2 (1.922.2.53 2001/09/11 03:18:52) +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# The name that we can dlopen(3). +dlname='' + +# Names of this library. +library_names='' + +# The name of the static archive. +old_library='libhdf5.a' + +# Libraries that this one depends upon. +dependency_libs=' -lz' + +# Version information for libhdf5. +current=0 +age=0 +revision=0 + +# Is this an already installed library? +installed=yes + +# Files to dlopen/dlpreopen +dlopen='' +dlpreopen='' + +# Directory that this library needs to be installed in: +libdir='/cygdrive/c/work/hdf5-1.6.3-patch/hdf5/lib' diff --git a/libs/cygwin/lib/libhdf5.settings b/libs/cygwin/lib/libhdf5.settings new file mode 100755 index 0000000..30e950f --- /dev/null +++ b/libs/cygwin/lib/libhdf5.settings @@ -0,0 +1,52 @@ +SUMMARY OF THE HDF5 CONFIGURATION +================================= + +HDF5 Version: 1.6.3-patch +Configured on: Mon Oct 11 08:49:04 WEST 2004 +Configured by: theidel@pc4192 +Configure mode: production +Host system: i686-pc-cygwin +Byte sex: little-endian +Libraries: static, shared +Parallel support: no +Installation point: /cygdrive/c/work/hdf5-1.6.3-patch/hdf5 +Compiler: /usr/bin/gcc +Compiler switches: -O2 -UH5_DEBUG_API -DNDEBUG +Extra libraries: -lz -lm +Archiver: ar +Ranlib: ranlib +Debugged Packages: +API Tracing: no +File addresses: large +Configure Summary +Compiling Options: + Compilation Mode: Production + C Compiler: gcc + CFLAGS: -O2 + CPPFLAGS: -UH5_DEBUG_API -DNDEBUG + LDFLAGS: + Debug Mode: None + Shared Libraries: Yes + Static Libraries: Yes + Statically Linked Executables: No + Tracing: No + Optimization Instrumentation: No +Languages: + C++: No + Fortran: No +Features: + dmalloc: No + Function Stack Tracing: Disabled + GASS: No + GPFS: No + HDF5 v1.4 Compatibility: No + hsize_t: Large + I/O filters (external): deflate + I/O filters (internal): shuffle,fletcher32 + Linux Large File Support (LFS): Disabled + MPE: No + Pablo: No + Parallel HDF5: No + SRB: No + Stream VFD: Enabled + Threadsafety: Disabled diff --git a/libs/cygwin/lib/libmfhdf.a b/libs/cygwin/lib/libmfhdf.a new file mode 100755 index 0000000..513faa2 Binary files /dev/null and b/libs/cygwin/lib/libmfhdf.a differ diff --git a/libs/cygwin/lib/libudport.a b/libs/cygwin/lib/libudport.a new file mode 100755 index 0000000..a2d54c9 Binary files /dev/null and b/libs/cygwin/lib/libudport.a differ diff --git a/make_gen b/make_gen new file mode 100755 index 0000000..d288016 --- /dev/null +++ b/make_gen @@ -0,0 +1,212 @@ +#--------------------------------------------------------------------------- +# Makefile for FIT and some related programs +# +# Markus Zolliker, Sept 2002 +#-------------------------------------------------------------------------- +-include make_deb +#NXFLAG is Y when NeXus should be used +NXF_Y = dat_nexus.o +NXF_ = dat_nexus_dum.o +F_OBJ = fit_main.o fit_win.o \ + cvt.o fit_merge.o fit_abskor.o fit_auto.o fit_mon.o \ + fit_bars.o fit_multiply.o inex.o \ + fit_command.o fit_out.o \ + dat_utils.o fit_connect.o fit_peak.o migrad.o \ + dat_fit3.o fit_cor.o fit_dat.o fit_print.o \ + dat_lnsp.o fit_exit.o fit_rel.o quick_sort.o \ + dat_init.o dat_open.o fit_export.o fit_scale.o simplex.o \ + dat_tasmad.o fit_file.o fit_set.o dat_ccl.o dat_5c2.o \ + dat_2t.o dat_rita.o dat_table.o dat_frm.o \ + dat_oldtas.o dat_sics.o dat_fullp.o fit_fit.o fit_style.o \ + fit_fix.o fit_subtract.o \ + fit_fun.o fifun.o fit_init.o fit_title.o \ + fit_list.o fit_user.o fit_range.o fit_array.o str.o \ + metaf.o intprt.o dat_ida.o dat_fda.o dat_d1a.o \ + gra.o fit_plot.o fit_bgedit.o cho.o \ + dat_xy.o dat_xys.o dat_xysm.o dat_inx.o dat_spec.o \ + sys_getenv.o sys_home.o sys_cmdpar.o sys_date.o sys_remote_host.o \ + sys_wait.o sys_lun.o sys_file.o sys_open.o sys_parse.o \ + $(NXF_$(NXFLAG)) $(NAPIF) +NXC_Y = napi_err.o dat_c.o +C_OBJ = sys_fun.o sys_unix.o \ + metac.o myc_str.o myc_err.o myc_tmp.o \ + sys_env.o sys_rdline.o sys_try.o \ + dat_tascom_dir.o main.o \ + $(NXC_$(NXFLAG)) +LIB_OBJ = $(C_OBJ) $(F_OBJ) sys_fvi.o fit_help.o fit_vers.o + +NXINC_Y=-I$(NXINC) -I$(NXHDF) +NXPATH_Y=:$(NXINC):$(NXHDF) +NXLIB_Y=$(NXLIB) +LL = $(PGLIB) $(RDLIB) $(NXLIB_$(NXFLAG)) +LIB_a= $(LL) +LIB_so= +LIBFIT = libfit.$(LIB_TYPE) +LF = $(LIB_$(LIB_TYPE)) libfit.a + +ARFLAGS = cr + +.SUFFIXES: .o .c .f + +F_OPT_D = $(F_DEB) +F_OPT_ = $(F_OPT) +FFLAGS = $(F_FLAGS) $(F_STRICT) $(F_OPT_$(DEB)) +FFLAGSR = $(F_FLAGS) $(F_RELAXED) $(F_OPT_$(DEB)) +CFLAGS = $(C_FLAGS) $(C_STRICT) -Isrc/gen +CFLAGSR = $(C_FLAGS) $(C_RELAXED) -Isrc/gen + +VPATH = src/gen/$(SPECPATH):src/unix/:src/pgm/:./$(NXPATH_$(NXFLAG)) + +SUPBIN = cho_ terinq_ sumvar deteff clamp abskor3 csc addit subit \ + trics_ccl addchan addei polcal csvsumvar autofit fitlor + +MAINBIN = fit $(ADD_ALL) + +ALL = $(MAINBIN) $(LIBFIT) $(SUPBIN) + +default: fit libfit.a $(LIBFIT) + +all: $(ALL) + +fit: fit.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) $(LDFLAGS) + +myfit: src/makefile_$(FIT_VERSION) src/make_gen src/gen/myfit_head + cp -f src/gen/myfit_head ./myfit + @echo '$(FC) $(FFLAGS) $$* $(INSTDIR)/lib/libfit.a $(LL) $(INSTDIR)/lib/libfit.a' >> myfit + chmod +x myfit + +libfit.a: $(LIB_OBJ) make_fdep $(CDEP) + rm -f $@ + $(AR) $(ARFLAGS) $@ $(LIB_OBJ) + ranlib $@ + +libfit.so: $(LIB_OBJ) + rm -f libfit.so + $(FC) $(FFLAGS) -shared -o libfit.so $(LIB_OBJ) $(LL) + +dat_nexus.o: dat_nexus.f + $(FC) $(FFLAGSR) $(NXINC_$(NXFLAG)) -c $F +dat_c.o: dat_c.c + $(CC) $(CFLAGSR) $(NXINC_$(NXFLAG)) -c $C +napi_err.o: napi_err.c + $(CC) $(CFLAGSR) $(NXINC_$(NXFLAG)) -c $C + +sumvar: sumvar.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +csvsumvar: csvsumvar.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +csc: csc.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +deteff: deteff.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +clamp: clamp.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +abskor3: abskor3.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +addit: addit.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +addchan: addchan.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +subit: subit.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +autofit: autofit.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +fitvers: fitv.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +brows.o: brows.f + $(FC) $(FFLAGSR) $(LDFLAGS) $(NXINC_$(NXFLAG)) -c $F + +brows: brows.o $(LIBFIT) + $(FC) $(FFLAGSR) $(LDFLAGS) -o $@ $Q $(LF) + +cho_: chooser.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +terinq_: terinq.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +tricslog: tricslog.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +trics_ccl: trics_ccl.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +addei: addei.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +polcal: polcal.o $(LIBFIT) + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q $(LF) + +make_custom: make_custom.f make_fvi.f make_help.f make_vers.f str.o \ + sys_open.o sys_cmdpar.o sys_unix.o sys_getenv.o sys_env.o \ + myc_str.o myc_err.o myc_tmp.o + $(FC) $(FFLAGS) $(LDFLAGS) -o $@ $Q + +fit_vers.f: make_custom fit.vers $(F_OBJ:.o=.f) $(C_OBJ:.o=.c) + ./make_custom src/gen/fit.vers + +sys_fvi.c fit_help.f: make_custom lib.fvi fit.help + ./$Q + +fitlor: src/gen/fitlor.py + cp src/gen/fitlor.py fitlor + +INSTBIN=$(INSTDIR)/bin +INSTLIB=$(INSTDIR)/lib + +$(MAINBIN:%=$(INSTBIN)/%): $(MAINBIN) + cp -f $(@:$(INSTBIN)/%=%) $@ + +$(SUPBIN:%=$(INSTBIN)/%): $(SUPBIN) + cp -f $(@:$(INSTBIN)/%=%) $@ + +$(INSTLIB)/libfit.a: libfit.a + cp -f libfit.a $(INSTLIB)/libfit.a + +$(INSTLIB)/fitexample.f: src/gen/fitexample.f + cp -f src/gen/fitexample.f $(INSTLIB)/fitexample.f + +inst: $(MAINBIN:%=$(INSTBIN)/%) $(INSTLIB)/libfit.a $(INSTLIB)/fitexample.f + +install: inst $(SUPBIN:%=$(INSTBIN)/%) + +PRJS= $(F_OBJ:.o=.f) + +# "make check" will check everything that has been changed. +check: fit.f $(PRJS) + ftnchek -declare -source=dec-tab -notruncation -wrap=0 \ + -arguments=no-arrayness -nopure -nousage -quiet $Q + +clean: + rm -f *.o *.d *.df *.f *.c $(ALL) terinq make_custom \ + make_fdep make_cdep libfit.so so_locations + +purge_c: + rm -f $(C_OBJ) + +make_fdep: $(F_OBJ:.o=.f) +# search for include statements. the rest of the line is text processing + @echo "determine Fortran include file dependencies" + @echo $Q + @grep "include.*'.*'" $Q | sed \ + "s+:.*include.'\(.*\)'.*+: \1+g;s+.*/\(.*\)\.f:+\1.o: \1.f+g" \ + | sort -u > make_fdep + +make_cdep: $(C_OBJ:.o=.c) + @echo "collect C include file dependencies" + @- cat *.d | grep -v "/usr" > make_cdep + +-include make_fdep +-include $(CDEP) $(C_OBJ:.o=.d) diff --git a/makefile b/makefile new file mode 100644 index 0000000..0b67195 --- /dev/null +++ b/makefile @@ -0,0 +1,58 @@ +# This file is included by the makefile. +# It forwards the execution to a version specific makefile. +# FIT_VERSION must be defined +# M. Zolliker 08.2003 + +VERS_UNDEFINED= +VERS_UNDEFINED$(FIT_VERSION)=version_undefined + +MD=cd $(FIT_VERSION); \ + make -f $(SRC)makefile_$(FIT_VERSION) SRC=$(SRC) + +# overwrite MD when FIT_VERSION undefined +MD$(FIT_VERSION)=@ true + +PRE=$(VERS_UNDEFINED) obj/$(FIT_VERSION) + +SRC=src/ + +.SUFFIXES: .none + +default: $(PRE) + $(MD) + +%.o: $(PRE) + $(MD) $@ + +%: $(PRE) + $(MD) $@ + +.DEFAULT: $(PRE) + $(MD) $@ + +tree: $(PRE) + +obj/$(FIT_VERSION): + @ ./maketree . $(FIT_VERSION) + +makefile: + @ echo makefile + +version_undefined: + @ echo "" + @ echo "Usage:" + @ echo "" + @ echo "Creating objects and targets in separate subdirectories" + @ echo "" + @ echo " setenv FIT_VERSION version_xxx (assume we are using tcsh)" + @ echo " make [target]" + @ echo "" + @ echo " where version_xxx is one of" + @ echo "" + @ ls -1 makefile_* | cut -b 10-99 | pr -t -o 4 + @ echo "" + @ echo " Remarks:" + @ echo " All objects for alpha version will be created in subdirectory obj/alpha/," + @ echo " Tip: define FIT_VERSION at login" + @ echo "" + diff --git a/makefile_alpha b/makefile_alpha new file mode 100644 index 0000000..a7f03fb --- /dev/null +++ b/makefile_alpha @@ -0,0 +1,65 @@ +# Tru64 Unix with lnslib + +DEB$(NODEB)=D + +SINQ=/afs/psi.ch/project/sinq/tru64 + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=$(SINQ)/stow/fit + +# 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. -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 +LNL=$(SINQ)/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)NeXusf77.a $(LNL)hdf5.a $(LNL)mfhdf.a $(LNL)df.a $(LNL)jpeg.a $(LNL)z.a +#NXLIB=/data/zolliker/lib/libNeXus45.a $(LNL)hdf5.a $(LNL)mfhdf.a $(LNL)df.a $(LNL)jpeg.a $(LNL)z.a + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +NXINC=$(SINQ)/include + +# add to 'all' list +ADD_ALL=fitvers + +-include make_deb +include make_gen + diff --git a/makefile_alpha_f b/makefile_alpha_f new file mode 100644 index 0000000..a0c6ec1 --- /dev/null +++ b/makefile_alpha_f @@ -0,0 +1,3 @@ +NODEB=N +include makefile_alpha + diff --git a/makefile_cygwin b/makefile_cygwin new file mode 100755 index 0000000..1431a81 --- /dev/null +++ b/makefile_cygwin @@ -0,0 +1,51 @@ +# Linux with AFS at PSI + +# only debugger version works +DEB=D + +# 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. -static +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 + +SINQ=../libs/cygwin +SL=../libs/cygwin/lib/lib +# linker flags for pgplot +PGLIB= -Wl,--subsystem,console -lpgplot -lGrWin -mwindows +# +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=$(SL)NeXus.a $(SL)hdf5.a $(SL)mfhdf.a $(SL)df.a -ljpeg -lz -lrpclib + + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +NXINC=$(SINQ)/include + +-include make_deb +include src/make_gen diff --git a/makefile_linux b/makefile_linux new file mode 100644 index 0000000..4a4d1c4 --- /dev/null +++ b/makefile_linux @@ -0,0 +1,57 @@ +# Linux + +# only debugger version works +DEB=D + +# 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. -Wall +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 + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=~ + +# linker flags for pgplot +PGLIB=$(INSTDIR)/libpgplot.a -L/usr/X11R6/lib -lX11 + +# link NeXus file input routines ? +# remove '#' in the next line if you like NeXus support +#NXFLAG=Y + +NXLIBS=$(INSTDIR)/lib/lib + +# linker flags for NeXus +NXLIB=$(NXLIBS)NeXus77.a $(NXLIBS)hdf5.a $(NXLIBS)mfhdf.a $(NSLIBS)df.a \ + $(NXLIBS)jpeg.a $(NXLIBS)z.a + +# directory for the HDF include files (needed for NeXus) +NXHDF=$(INSTDIR)/include + +# directory for the NeXus include files +NXINC=$(INSTDIR)/include + +ADD_ALL = myfit + +-include make_deb +include src/make_gen diff --git a/makefile_macintel b/makefile_macintel new file mode 100644 index 0000000..c644576 --- /dev/null +++ b/makefile_macintel @@ -0,0 +1,58 @@ +# Mac OS X with Fink + +# only debuggger version works +DEB=D + +# 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 -DF_UNDERSCORE=1 +C_STRICT=-Wall +C_RELAXED= + +# fortran compiler to be used, flags for different options +FC=gfortran +F_FLAGS=-fimplicit-none -ffixed-line-length-none -fbounds-check -I. +F_STRICT= +F_RELAXED=-Wno-globals +F_OPT=-O +F_DEB=-g + +#ld flags +#LDFLAGS=/usr/lib/gcc/i686-apple-darwin8/4.0.1/libgcc_static.a + +# 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 + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=/sinqsw + +# linker flags for pgplot +PGLIB=-L/sw/lib/pgplot -lpgplot -L/usr/X11R6/lib -lX11 -lpng \ + -laquaterm -Wl,-framework -Wl,Foundation -Wl,-framework -Wl,AppKit + +# link NeXus file input routines ? (comment out if not needed) +#NXFLAG=Y + +# linker flags for NeXus +NXLIB=-L/sinqsw/lib -lNeXus -lNeXus77 -L/sw/lib -lhdf5 -lmfhdf -ldf -ljpeg -lz + +# directory for the HDF include files +NXHDF=/sw/include + +# directory for the NeXus include files +NXINC=$(INSTDIR)/include + +ADD_ALL = myfit + +-include make_deb +include src/make_gen + diff --git a/makefile_macosx b/makefile_macosx new file mode 100644 index 0000000..467a6ef --- /dev/null +++ b/makefile_macosx @@ -0,0 +1,69 @@ +# Mac OS X with Fink + +# only debuggger version works +DEB=D + +# 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 + +#ld flags +#LDFLAGS=/Developer/SDKs/MacOSX10.3.0.sdk/usr/lib/gcc/darwin/3.3/libgcc.a +#LDFLAGS=/sw/lib/gcc/powerpc-apple-darwin8.8.0/3.4.3/libgcc.a -L/sw/lib -lg95 -lg2c +#LDFLAGS=/usr/lib/gcc/darwin/3.1/libgcc.a +#LDFLAGS=/usr/lib/gcc/darwin/3.3/libgcc.a /usr/lib/libSystemStubs.a +#LDFLAGS=/usr/lib/gcc/i686-apple-darwin8/4.0.0/libgcc.a +#LDFLAGS=/usr/lib/gcc/powerpc-apple-darwin8/4.0.0/libgcc.a +#LDFLAGS=/usr/lib/gcc/powerpc-apple-darwin8/4.0.1/ppc64/libgcc.a + +# 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 + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=/sinqsw + +# linker flags for pgplot +PGLIB=-L/usr/X11R6/lib -lX11 -Wl,-framework -Wl,Foundation -L/sw/lib \ + -lpng -lz -laquaterm -L/sw/lib/pgplot -lpgplot -lg95 + +# -L/sw/lib/pgplot -lpgplot -L/usr/X11R6/lib -lX11 -lpng \ +# -Wl,-framework -Wl,Foundation -Wl,-framework -Wl,AppKit -lg95 + + + +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=-L/sinqsw/lib -lNeXus -lNeXus77 -L/sw/lib -lhdf5 -lmfhdf -ldf -ljpeg -lz + +# directory for the HDF include files +NXHDF=/sw/include + +# directory for the NeXus include files +NXINC=$(INSTDIR)/include + +ADD_ALL = myfit + +-include make_deb +include src/make_gen + diff --git a/makefile_rhel7 b/makefile_rhel7 new file mode 100644 index 0000000..4c0a31f --- /dev/null +++ b/makefile_rhel7 @@ -0,0 +1,68 @@ +# RedHat Linunx (rhel7) with AFS at PSI + +# only debugger version works +DEB=D + +# 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 -DF_UNDERSCORE=1 +#C_FLAGS=-g -D__unix -MMD +C_STRICT=-Wall +C_RELAXED= + +# fortran compiler to be used, flags for different options +FC=gfortran +#FC=g77 +F_FLAGS=-fimplicit-none -ffixed-line-length-none -fbounds-check -I. +#F_FLAGS=-Wimplicit -fbounds-check -I. -Wall +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=-L$(PWD) -lreadline + +SINQ=/afs/psi.ch/project/sinq/$(linuxsys) +SL=$(sinq)/sl6-64/lib/lib + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=$(SINQ)/stow/fit + +# linker flags for pgplot +PGLIB=$(PWD)/src/pgplot_rhel7/libpgplot.a -L/usr/X11R6/lib -lX11 + +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=$(SL)NeXus77.a $(SL)NeXus.a $(SL)hdf5.a $(SL)mxml.a -lz $(SL)sz.a -lpthread + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +NXINC=$(sinq)/sl6-64/include +#NXINC=$(PWD)/../gen + +# a hack: it seems that napif.f is not properly included in libNeXus77.a +NAPIF=napif.o + +ADD_ALL = myfit + +-include make_deb +include src/make_gen + +# location: unix/napif.f +napif.o: napif.f + $(FC) -c $Q + diff --git a/makefile_sl-linux b/makefile_sl-linux new file mode 100644 index 0000000..1dbd420 --- /dev/null +++ b/makefile_sl-linux @@ -0,0 +1,57 @@ +# Linux with AFS at PSI + +# only debugger version works +DEB=D + +# 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. -Wall +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 + +SINQ=/afs/psi.ch/project/sinq/sl-linux +SL=$(SINQ)/lib/lib + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=$(SINQ)/stow/fit + +# linker flags for pgplot +PGLIB=$(SL)pgplot.a -L/usr/X11R6/lib -lX11 + +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=$(SL)NeXus77.a $(SL)NeXus.a $(SL)hdf5.a $(SL)mfhdf.a $(SL)mxml.a $(SL)df.a $(SL)jpeg.a -lz $(SL)sz.a + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +#NXINC=$(SINQ)/include +NXINC=$(PWD)/../gen + +ADD_ALL = myfit + +-include make_deb +include src/make_gen diff --git a/makefile_sl5 b/makefile_sl5 new file mode 100644 index 0000000..5a0a3a1 --- /dev/null +++ b/makefile_sl5 @@ -0,0 +1,60 @@ +# Linux with AFS at PSI + +# only debugger version works +DEB=D + +# 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_FLAGS=-g -D__unix -MMD -DF_UNDERSCORE=1 +C_STRICT=-Wall +C_RELAXED= + +# fortran compiler to be used, flags for different options +FC=g77 +F_FLAGS=-Wimplicit -fbounds-check -I. -Wall +#F_FLAGS=-w +F_STRICT= +F_RELAXED=-Wno-globals +#F_RELAXED=$(F_FLAGS) +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 + +SINQ=/afs/psi.ch/project/sinq/sl5 +SL=$(SINQ)/lib/lib + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=$(SINQ)/stow/fit + +# linker flags for pgplot +PGLIB=$(SL)pgplot.a -L/usr/X11R6/lib -lX11 + +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=$(SL)NeXus77.a $(SL)NeXus.a $(SL)hdf5.a $(SL)mfhdf.a $(SL)mxml.a $(SL)df.a $(SL)jpeg.a -lz $(SL)sz.a + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +#NXINC=$(SINQ)/include +NXINC=$(PWD)/../gen + +ADD_ALL = myfit + +-include make_deb +include src/make_gen diff --git a/makefile_sl6 b/makefile_sl6 new file mode 100644 index 0000000..18c66b6 --- /dev/null +++ b/makefile_sl6 @@ -0,0 +1,60 @@ +# Linux with AFS at PSI + +# only debugger version works +DEB=D + +# 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 -DF_UNDERSCORE=1 +#C_FLAGS=-g -D__unix -MMD +C_STRICT=-Wall +C_RELAXED= + +# fortran compiler to be used, flags for different options +FC=gfortran +#FC=g77 +F_FLAGS=-fimplicit-none -ffixed-line-length-none -fbounds-check -I. +#F_FLAGS=-Wimplicit -fbounds-check -I. -Wall +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 + +SINQ=/afs/psi.ch/project/sinq/sl6 +SL=$(SINQ)/lib/lib + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=$(SINQ)/stow/fit + +# linker flags for pgplot +PGLIB=$(PWD)/src/pgplot_sl6/libpgplot.a -L/usr/X11R6/lib -lX11 + +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=$(SL)NeXus77.a $(SL)NeXus.a $(SL)hdf5.a $(SL)mfhdf.a $(SL)mxml.a $(SL)df.a $(SL)jpeg.a -lz $(SL)sz.a -lpthread + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +#NXINC=$(SINQ)/include +NXINC=$(PWD)/../gen + +ADD_ALL = myfit + +-include make_deb +include src/make_gen diff --git a/makefile_sl6-64 b/makefile_sl6-64 new file mode 100644 index 0000000..26c26a7 --- /dev/null +++ b/makefile_sl6-64 @@ -0,0 +1,68 @@ +# Linux with AFS at PSI + +# only debugger version works +DEB=D + +# 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 -DF_UNDERSCORE=1 +#C_FLAGS=-g -D__unix -MMD +C_STRICT=-Wall +C_RELAXED= + +# fortran compiler to be used, flags for different options +FC=gfortran +#FC=g77 +F_FLAGS=-fimplicit-none -ffixed-line-length-none -fbounds-check -I. +#F_FLAGS=-Wimplicit -fbounds-check -I. -Wall +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 + +SINQ=/afs/psi.ch/project/sinq/sl6-64 +SL=$(SINQ)/lib/lib + +# directories for installing the binaries are $(INSTDIR)/bin and $(INSTDIR)/lib +INSTDIR=$(SINQ)/stow/fit + +# linker flags for pgplot +PGLIB=$(PWD)/src/pgplot_sl6-64/libpgplot.a -L/usr/X11R6/lib -lX11 + +# link NeXus file input routines ? (comment out if not needed) +NXFLAG=Y + +# linker flags for NeXus +NXLIB=$(SL)NeXus77.a $(SL)NeXus.a $(SL)hdf5.a $(SL)mxml.a -lz $(SL)sz.a -lpthread + +# directory for the HDF include files +NXHDF=$(SINQ)/include + +# directory for the NeXus include files +#NXINC=$(SINQ)/include +NXINC=$(PWD)/../gen + +# a hack: it seems that napif.f is not properly included in libNeXus77.a +NAPIF=napif.o + +ADD_ALL = myfit + +-include make_deb +include src/make_gen + +# location: unix/napif.f +napif.o: napif.f + $(FC) -c $Q + diff --git a/maketree b/maketree new file mode 100755 index 0000000..fdda78a --- /dev/null +++ b/maketree @@ -0,0 +1,32 @@ +#!/bin/tcsh +# create the version specific object tree +# +# M.Zolliker 08.2003 +# +if ("$2" == "") then + + echo missing arg 2 (fit version) + +else + + set FIT_ROOT=$PWD + +# determine object directory + set o="$FIT_ROOT/$2/$1" + +# determine makefile + set m="$FIT_ROOT/$1/makefile_$2" + + if (-e $m) then + if (! -e $o) then + echo create directory $o + mkdir -p $o + else + echo $o exists + endif + rm -f $o/src + echo ln -s $FIT_ROOT/$1 $o/src + ln -s $FIT_ROOT/$1 $o/src + endif +endif + diff --git a/napif.o b/napif.o new file mode 100644 index 0000000..f36ae83 Binary files /dev/null and b/napif.o differ diff --git a/pgm/CVS/Entries b/pgm/CVS/Entries new file mode 100644 index 0000000..f8ca63f --- /dev/null +++ b/pgm/CVS/Entries @@ -0,0 +1,16 @@ +/addchan.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/bose.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/csc.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/deteff.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/deteff2.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/subit.f/1.1.1.1/Tue Nov 2 15:54:57 2004// +/ufit.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// +/abskor3.f/1.2/Thu Dec 22 16:07:28 2005// +/brows.f/1.2/Tue Aug 8 10:35:11 2006// +/addit.f/1.3/Tue May 15 11:02:38 2012// +/clamp.f/1.3/Tue Mar 8 09:25:31 2011// +/tricslog.f/1.3/Fri Nov 13 14:06:20 2015// +/sumvar.f/1.3/Fri Nov 3 07:22:08 2017// +/trics_ccl.f/1.7/Fri Sep 8 07:59:46 2017// +D diff --git a/pgm/CVS/Repository b/pgm/CVS/Repository new file mode 100644 index 0000000..834c9ec --- /dev/null +++ b/pgm/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/pgm diff --git a/pgm/CVS/Root b/pgm/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/pgm/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/pgm/abskor3.f b/pgm/abskor3.f new file mode 100644 index 0000000..885e332 --- /dev/null +++ b/pgm/abskor3.f @@ -0,0 +1,175 @@ + program abskor3 + +* absorption correction for full or double-walled cylinders +* replaces old ABSKOR and ABSKOR2 +* uses FIT subroutines written by M. Zolliker +* 30.11.01 +* +* > myfit abskor3.f +* > mv a.out abskor3 + + implicit none + + integer l + character*256 file, outfile, line + character*32 spec, value + character*5 flag + real mur, rira, rarc + logical found + + external extract_option, cvt_ratio + logical extract_option + real cvt_ratio + + call sys_get_cmdpar(line, l) + + if (line .eq. ' ') then + call fit_init_silent + call sys_getenv('dat_defspec',spec) + if (spec.eq.' ') spec='DMC' + call str_trim(spec,spec,l) + + 100 write(*,*) + write(*,'(x,a)')'DMC = 1 / HRPT = 2' + write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): ' + read(*,'(a)')flag + + call str_upcase(flag, flag) + + if (flag.eq.'1') flag='DMC' + if (flag.eq.'2') flag='HRPT' + if (flag.ne.' ') then + if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100 + spec=flag + endif + + call sys_setenv('dat_defspec',spec) + file=' ' + outfile=' ' + else + mur=0 + rira=0 + rarc=0 + if (extract_option('m', line, value)) then + read(value, *, err=999,end=999) mur + endif + if (extract_option('r', line, value)) then + rira=cvt_ratio(value, -1.0) + if (rarc .lt. 0) goto 999 + endif + if (extract_option('c', line, value)) then + rarc=cvt_ratio(value, -1.0) + if (rarc .lt. 0) goto 999 + endif + found=extract_option(' ', line, file) + found=extract_option('o', line, outfile) + if (line .ne. ' ') goto 999 + call fit_init_silent + endif + + call fit_dat_merge(file,0.025) + write(*,*) + call fit_abskor2(mur,rira,rarc) + write(*,*) + +C call fit_auto_mon +C write(*,*) +C call fit_mon(0) + + if (outfile .eq. ' ') then + 101 write(*,'(x,a,$)')'Name of output file: ' + read(*,'(a)') outfile + if (outfile.eq.' ') goto 101 + endif + + call fit_export(0.0,'lnsp',outfile) + + write(*,*) + write(*,'(x,2a)')'new file: ',outfile + write(*,*) + + goto 9999 + +999 write (*,*) ' ' + write (*,*) 'Usage:' + write (*,*) ' ' + write (*,'(x,2a)') ' abskor3 -m [ -r / ]' + *,' [ -c / ] [ -o ] ' + write (*,*) ' ' + write (*,*) 'where mu*R' + write (*,*) ' inner sample radius' + write (*,*) ' outer sample radius' + write (*,*) ' radial collimator fwhm' + write (*,*) ' input file(s) or number of run(s)' + write (*,*) ' output file' + +9999 end + + + logical function extract_option(optchar, line, value) + +! extract an option from commandline +! options are single chars preceded by + + character optchar*1, line*(*), value*(*) + + integer i, state, j + + state=0 ! beginning or between options + do i=1,len(line) + if (state .eq. 0) then + if (line(i:i) .le. ' ') then + continue + elseif (line(i:i) .eq. '-') then + state=2 ! option started + elseif (optchar .eq. ' ') then ! argument + state=5 ! argument started + j=i + endif + elseif (state .eq. 2) then + if (line(i:i) .eq. optchar) then + line(i-1:i)=' ' + state=3 ! option matches + else + state=1 ! option does not match + endif + elseif (state .eq. 1) then + if (line(i:i) .gt. ' ') then + state=4 ! unmatching option value + elseif (line(i:i) .eq. '-') then + state=2 ! option has started + endif + elseif (state .eq. 4) then + if (line(i:i) .le. ' ') then + state=0 ! between options + endif + elseif (state .eq. 3) then + if (line(i:i) .gt. ' ') then + j=i + state=6 + endif + elseif (state .ge. 6) then + if (state .eq. 6) then + if (line(i:i) .eq. '-' .and. len(value) .eq. 1) then + value=' ' + extract_option=.true. + return + endif + if (line(i:i) .le. ' ') then + value=line(j:i) + line(j:i)=' ' + extract_option=.true. + return + endif + endif + endif + enddo + if (state .lt. 5) then + value=' ' + extract_option=.false. + return + endif + value=line(j:) + line(j:)=' ' + extract_option=.true. + end diff --git a/pgm/addchan.f b/pgm/addchan.f new file mode 100644 index 0000000..4064c6a --- /dev/null +++ b/pgm/addchan.f @@ -0,0 +1,52 @@ + program addchan + +! compile with: +! > myfit -o addchan addchan.f + + implicit none + + integer j,i,n,listflag + character*256 list + real twoth + + integer nmax + parameter (nmax=16000) + real xx(nmax) + + call fit_init + + call dat_ask_filelist(list,' ') + listflag=0 + + do j=1,999999 + + call fit_dat_next_opt(list,listflag,1,0.0) + if (listflag.eq.0) goto 101 + + call fit_get_real('A4', twoth) + call fit_get_array('X', xx, nmax, n) + print *,'a4 ',twoth,n + do i=1,n + if (xx(i) .le. 500.) then + xx(i)=xx(i)-twoth+1000. + endif + enddo + call fit_put_array('X', xx, n) + if (n+1600 .ge. nmax) then + call fit_merge(0.05) + endif + enddo + + 101 write(*,*) + + call fit_merge(0.05) + call fit_get_array('X', xx, nmax, n) + do i=1,n + xx(i)=xx(i)-1000. + enddo + call fit_put_array('X', xx, n) + + call fit_export(0,'lnsp',' ') + + + end diff --git a/pgm/addei.f b/pgm/addei.f new file mode 100644 index 0000000..731913c --- /dev/null +++ b/pgm/addei.f @@ -0,0 +1,94 @@ + program addei + + implicit none + + integer i, n, listflag, l, iostat, numor, j, la, lo + character*1024 list + character*256 filename + character*256 outname + character line*256, axis*8 + real fx,kfix,val,en(999),ei + + call fit_init + + list=' ' + call sys_get_cmdpar(list, l) + if (list .eq. ' ') then + call dat_ask_filelist(list,' ') + endif + listflag=0 + +c treat no more than 9999 files + do i=1,9999 + + call fit_dat_options('x=en') + call fit_dat_silent + call fit_dat_next(list,listflag) +c exit loop when finished + if (listflag.eq.0) goto 999 + call fit_get_real('Numor', val) + numor = val + call fit_get_real('FX', fx) + call fit_get_real('KFIX', kfix) + ei=kfix*kfix*2.072 + call fit_get_array('x', en, 999, n) + call fit_get_str('File', l, filename) + do j=l,1,-1 + if (filename(j:j) .eq. '/') then + outname=filename(j+1:l) + lo=l-j + goto 200 + endif + enddo + outname=filename + lo=l +200 continue + call fit_get_str('XAxis', la, axis) + if (axis .ne. 'EN') then + print *,outname(1:lo),'(column EN not found)' + goto 900 + endif + call sys_open(1, filename(1:l), 'r', iostat) + if (iostat .ne. 0) then + print *,'can not open ',filename(1:l) + goto 999 + endif + + if (outname(lo:lo) .eq. 'c') then + outname(lo:lo) = 't' + else + outname(lo:lo) = 'c' + endif + call sys_open(2, outname(1:lo), 'w', iostat) + if (iostat .ne. 0) then + print *,'can not create ',outname(1:lo) + goto 999 + endif + print *,outname(1:lo),' created' + read(1, '(a)', iostat=iostat) line + call str_trim(line, line, l) + do while (iostat .eq. 0 .and. line(1:4) .ne. 'DATA') + write(2,'(a)') line(1:l) + read(1, '(a)', iostat=iostat) line + enddo + read(1, '(a)', iostat=iostat) line + call str_trim(line, line, l) + write(2, '(2a)') line(1:l),' EI' + call str_trim(line, line, l) + do j=1,n + read(1, '(a)', iostat=iostat) line + if (iostat .ne. 0) goto 900 + if (fx .eq. 1) then + write(2,'(a,f10.4)') line(1:l),ei + else + write(2,'(a,f10.4)') line(1:l),ei-en(j) + endif + enddo + close(1) + close(2) +900 continue + enddo + + 999 continue + + end diff --git a/pgm/addit.f b/pgm/addit.f new file mode 100644 index 0000000..1c08c16 --- /dev/null +++ b/pgm/addit.f @@ -0,0 +1,67 @@ + program addit + +* replaces "powderplus" +* (23.4.99) rekonstruiert am 7.7.99, geaendert am 15.7.99,28.9.99,7.3.00 +* +* > myfit addit.f +* > mv a.out addit + + implicit none + + integer l + character*36 spec + character*256 file + character*8192 line + character*5 flag + + call fit_init + + call sys_get_cmdpar(line, l) + call str_lowcase(line, line) + if (line(1:l) .ne. ' ') then + call fit_dat_options(line) + endif + call sys_getenv('dat_defspec',spec) + if (spec.eq.' ') spec='DMC' + call str_trim(spec,spec,l) ! Laenge bestimmen (l) + + 100 write(*,*) + write(*,'(x,a)')'DMC = 1 / HRPT = 2' + write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): ' + read(*,'(a)')flag ! ^ schreibt spec von + ! Zeichen 1 bis l + + call str_upcase(flag, flag) ! schreibt Inhalt von flag gross + + if (flag.eq.'1') flag='DMC' + if (flag.eq.'2') flag='HRPT' + if (flag.ne.' ') then + if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100 + spec=flag + endif + + call sys_setenv('dat_defspec',spec) + +C call fit_dat(' ') +C call fit_merge(0.02) + if (spec .eq. 'DMC') then + call fit_dat_merge(' ',0.025) ! ersetzt fit_dat und fit_merge + else + call fit_dat_merge(' ',0.025) ! ersetzt fit_dat und fit_merge + endif + call fit_auto_mon + write(*,*) + call fit_mon(0) + + 101 write(*,'(x,a,$)')'Name of output file: ' + read(*,'(a)')file + if (file.eq.' ') goto 101 + + call fit_export(0,'lnsp',file) + + call str_trim(file, file, l) + write(*,*) + write(*,'(x,2a)')'new file: ',file(1:l) + write(*,*) + + end diff --git a/pgm/autofit.f b/pgm/autofit.f new file mode 100644 index 0000000..35b4d5f --- /dev/null +++ b/pgm/autofit.f @@ -0,0 +1,152 @@ + program autofit +c --------------- + + implicit none + + real par(200), err(200) + integer j, i, n, listflag, pos, iostat, ipar + character*8192 list + character*8192 line + integer l, lline + character*128 vars + character*128 outfile + character num*32 + character var*32,upvar*32 + real value + integer lun, k + real ymon + + integer get_par_no + integer iret, fit_dat_opt + + call sys_get_cmdpar(line, lline) + pos = 1 + call str_get_word(line(1:lline), pos, vars) + call str_get_word(line(1:lline), pos, outfile) + call str_get_word(line(1:lline), pos, list) + if (outfile .eq. ' ') then + print *,' ' + print *,'Usage:' + print *,' ' + print *,'1) start the ordinary fit program with the first file' + print *,'2) select fit function, and setup fixed pars and correlations' + print *,'3) do a first fit' + print *,'4) use command "exit" to leave and save settings in last.fit3' + print *,'5) start autofit. Example:' + print *,' ' + print *,' autofit mf,i1 out.dat 1964-2018' + print *,' ' + print *,' fit datafiles with numbers 1964...2018' + print *,' plot using mf as x and fir parameter i1 as y' + print *,' ' + print *,'6) plot results:' + print *,' ' + print *,' fit -p out.dat' + print *,' ' + print *,'7) if in doubt, check fit graphically:' + print *,' ' + print *,' gv pgplot.ps' + print *,' ' + print *,'Tips:' + print *,'- use "temp" for temperature' + print *,'- use "intexp" for experimental integrated intensity' + print *,'- more than one fit parameter might be specified,' + print *,' resulting in more than 3 columns' + print *,'- in step (2), use commands "win" and "keep y" in fit,' + print *,' if you want to make the fit only in a window' + print *,' ' + goto 999 + endif + + call fit_init + call sys_setenv('CHOOSER_PAN','9') ! 9 plots per page + call sys_setenv('CHOOSER_POPT','A') ! all on one file + +c read parameter file from last fit + + call fit_load('last.fit3') + call sym_get_real('Monitor', ymon) + if (list .eq. ' ') then + call dat_ask_filelist(list,' ') + call str_trim(list, list, l) + call str_append(line, lline, ' ') + call str_append(line, lline, line(1:l)) + endif + listflag=0 + call sys_get_lun(lun) + call sys_open(lun, outfile, 'w', iostat) + if (iostat .ne. 0) then + print *,'cannot open ',outfile + goto 999 + endif + write(lun,'(2a)') '# created with the following command:' + write(lun,'(2a)') '# autofit ', line(1:lline) +c write header + line = ' ' + lline = 0 + i=1 + do while (.true.) + call str_get_elem(vars, i, var) + if (var .eq. ' ') exit + call str_trim(var, var, l) + if (lline .ne. 0) call str_append(line, lline, ' ') + do k=l,9 + call str_append(line, lline, ' ') + enddo + call str_append(line, lline, var(1:l)) + call str_upcase(upvar(1:l), var(1:l)) + ipar = get_par_no(upvar(1:l)) + if (ipar .gt. 0 .or. upvar(1:l) .eq. 'INTEXP') then + call str_append(line, lline, ' err') + endif + enddo + write(lun,'(a)') line(1:lline) + +c treat no more than 9999 files + do j=1,9999 + + call fit_dat_next(list,listflag) + call fit_mon(ymon) +c exit loop when finished + if (listflag.eq.0) goto 101 + + call fit_fit(0) + +c plot it to file + call fit_plot('y') + + call fit_get_array('p', par, 100, n) + call fit_get_array('e', err, 100, n) + line = ' ' + lline = 0 + i = 1 + do while (.true.) + call str_get_elem(vars, i, var) + if (var .eq. ' ') exit + if (lline .ne. 0) call str_append(line, lline, ' ') + call str_upcase(upvar, var) + if (upvar .eq. 'INTEXP') then + ipar = n + else + ipar = get_par_no(upvar) + endif + if (ipar .eq. 0) then +c it is a variable like 'temp' or 'mf' + call sym_get_real(var, value) + call cvt_real_str(num, l, value, 10, 0, 7, 1) + call str_append(line, lline, num(1:l)) + else +c it is a parameter, we write also the error + call cvt_real_str(num, l, par(ipar), 10, 0, 7, 1) + call str_append(line, lline, num(1:l)) + call str_append(line, lline, ' ') + call cvt_real_str(num, l, err(ipar), 10, 0, 7, 1) + call str_append(line, lline, num(1:l)) + endif + enddo + write(lun,'(a)') line(1:lline) + enddo + close(lun) + 101 write(*,*) + +999 end diff --git a/pgm/bose.f b/pgm/bose.f new file mode 100644 index 0000000..1c74a5d --- /dev/null +++ b/pgm/bose.f @@ -0,0 +1,180 @@ + program BOSE +! ------------ +! +! Simple user function example (straight line). +! + implicit none + external BOSE_FUN + + character str*32 + integer i,l + +!--- +! Welcome message + + call fit_vers(str) + call str_trim(str, str, l) + + type '(X,2A)','Program FIT(BOSE) Version ',str(1:l) + do i=1,l + str(i:i)='-' + enddo + type '(X,2A/)','-----------------------------',str(1:l) + +!--- +! Function title and parameter names +! + call fit_confun('lorenz/bose', bose_fun) ! function title, function + call fit_userpar('BG:Bgr(0)') + call fit_userpar('DB:dBgr/dX') + call fit_userpar('EF:EF') + call fit_userpar('T:Temp') + do i=1,9 + write(str, '(2(a,i1))') 'P',i,':Pos',i + call fit_userpar(str) + write(str, '(2(a,i1))') 'I',i,':Int',i + call fit_userpar(str) + write(str, '(2(a,i1))') 'W',i,':Wid',i + call fit_userpar(str) + enddo + call fit_main + end + + + + real function bose_fun(x,p,n,mode,cinfo) +! ------------------------------------------- + + implicit none + + real x ! x-value + integer n ! number of parameters + real p(n) ! parameters + integer mode ! mode + integer cinfo ! calculation information (see below) + + integer i,i0,j,k + parameter (i0=7) + real x0,w0,y0,db,bg,kf,l0 + real voigt, bose_fact + real xnew(9),ynew(9),wnew(9) + + if (mode .eq. 0) then + + bose_fun=0 + do i=i0,n-2,3 + if (p(i+2) .ne. 0) then ! ignore delta functions (treated later) + bose_fun=bose_fun+p(i+1)*voigt(x-p(i), 0.0, p(i+2)) + if (p(i+2) .lt. 0) then ! make a mirror peak for negative width + x0=x+p(i) + if (i .gt. i0 .and. p(i0+2) .eq. 0.0) x0=x0-2*p(i0) ! shift zero + bose_fun=bose_fun+p(i+1)*voigt(x0, 0.0, -p(i+2)) + endif + endif + enddo + bose_fun=bose_fun*bose_fact(x/p(6))+p(3)+p(4)*x + + elseif (mode .eq. 1) then + +! x-independent part + + do i=i0,n-2,3 + if (p(i+2) .eq. 0) then ! treat delta functions + call fit_delta(p(i),p(i+1)) + endif + enddo + call fit_limit_xrange(-p(5),1e6) + + elseif (mode .eq. 2) then ! transform x -> t + + x0=x+2*p(5) + if (x0 .ge. 0) then + bose_fun=sqrt(x0) + else + bose_fun=0 + endif + + elseif (mode .eq. 3) then ! transform t -> x + + bose_fun=x*x-2*p(5) + + else + if (nint(x) .eq. -1 .and. n .ge. 7) then ! convert from multi-voigt + print * + if (n .eq. 7) then + print *,'Convert from voigt' + else + print *,'Convert from multi-voigt' + endif + db=p(2) + bg=p(1)-p(3)*db ! different bg definition + j=3 + x0=p(3) + y0=p(5) + w0=max(abs(p(6)), abs(p(7))) + l0=p(7) + do i=8,n,5 + if (abs(p(i)) .lt. abs(x0)) then + j=i + x0=p(i) + y0=p(i+2) + w0=max(abs(p(i+3)), abs(p(i+4))) + endif + enddo + k=0 + do i=3,n,5 + if (p(i) .gt. 0 .and. i .ne. j) then + k=k+1 + xnew(k)=p(i) + ynew(k)=p(i+2) + wnew(k)=-max(abs(p(i+3)), abs(p(i+4))) + endif + enddo + p(1)=w0 + p(2)=w0*0.05 + p(3)=bg + p(4)=db + kf=1.55 + call fit_get_real('KFIX', kf) + p(5)=2.0723*kf*kf + p(6)=10 ! default Temp + call fit_get_real('Temp', p(6)) + p(7)=x0 + p(8)=y0 + p(9)=l0 + i=10 + do j=1,k + p(i)=xnew(k) + p(i+1)=ynew(k)/bose_fact(p(i)/p(6)) + p(i+2)=wnew(k) + i=i+3 + enddo + x=i-1 + else + print * + print *,'Up to 9 Lorenzians multiplied with bose_factor' + 1 ,', folded with gaussian' + + endif + print *,'Negative Wid makes a mirror peak at -Pos' + print * + endif + end + + + real function bose_fact(wot) + +! argument: omega[meV] over T[K] + real wot + real K_meV, x + parameter (K_meV=11.6048) + + x=wot*K_meV + if (abs(x) .lt. 1e-5) then + bose_fact=1.0 + else if (x .lt. -30) then + bose_fact=0 + else + bose_fact=x/(1-exp(-x)) + endif + end diff --git a/pgm/brows.f b/pgm/brows.f new file mode 100644 index 0000000..63bbbd8 --- /dev/null +++ b/pgm/brows.f @@ -0,0 +1,216 @@ + program brows + + integer pin, pout, n,l + integer nmax + parameter (nmax=9999) + character filelist*256, name*256 + real xval(nmax), yval(nmax), sig(nmax), rmon(nmax) + external list_none + external cvtyp + character*4 cvtyp + + call sys_get_cmdpar(filelist, l) + + name=cvtyp(0) ! init types + if (filelist .eq. ' ') then + call dat_ask_filelist(filelist, ' ') + endif + call dat_silent + pin=0 + pout=0 + call dat_open_next(filelist, pin, name, pout + & , list_none, nmax, n, xval, yval, sig, rmon) + call dat_get_filename(filelist, l) + call list_file(filelist(1:l)) + end + + + subroutine list_none(name, value) + + character name*(*) + real value + + end + + + subroutine list_file(filename) + + implicit none + + character filename*(*) + + include 'napif.inc' + + integer fileid(NXhandlesize) + integer status, type, level, l, m, length, j, i + integer rank, dim(32) + integer*4 idata(64) + real*4 val + character cdata*80, name*257, class*257 + + external cvtyp, cvt_str + character*4 cvtyp + character tab*80/' '/ + integer cvt_str + +100 format(1x,10a) + + level=0 + call NXswitchReport(0) + status=NXopen(filename, NXacc_read, fileid) + if (status .ne. NX_ok) then + print *,filename,' is probably not a HDF file' + goto 999 + endif +1 status=NXgetnextattr(fileid, name, length, type) + if (status .eq. NX_error) goto 999 + if (status .eq. NX_ok) then + call str_trim(name,name,l) + length=256 + status=NXgetattr(fileid, name(1:l), idata, length, type) + if (status .ne. NX_ok) goto 999 + if (type .eq. nx_char .or. + 1 type .eq. nx_uint8 .or. type .eq. nx_int8) then + length=cvt_str(cdata, idata) + elseif (type .eq. NX_INT32) then + length=12 + write(cdata(1:12), '(i12)') idata(1) + else + length=4 + cdata=cvtyp(type) + endif + write(*,100) tab(1:level*2+1) + 1 ,'| ',name(1:l),':',cdata(1:length) + goto 1 + endif +2 status=NXgetnextentry(fileid, name, class, type) + if (status .eq. NX_error) goto 999 + if (status .eq. NX_ok) then + call str_trim(name, name, l) + call str_trim(class, class, m) + if (class .ne. 'SDS') then + write(*,100) tab(1:level*2+1) + 1 ,'Group: ',name(1:l),', class:',class(1:m) + if (class(1:3) .ne. 'CDF') then + status=NXopengroup(fileid, name(1:l), class(1:m)) + if (status .ne. NX_ok) goto 999 + level=level+1 + endif + goto 2 + endif + status=NXopendata(fileid, name(1:l)) + if (status .ne. NX_ok) goto 999 + status=NXgetinfo(fileid, rank, dim, type) + if (status .ne. NX_ok .or. rank .gt. 16) goto 999 + if (type .eq. nx_char .or. + & type .eq. nx_uint8 .or. type .eq. nx_int8) then + length=dim(1) + status=NXgetslab(fileid, idata, 1, length) + if (status .ne. NX_ok) goto 999 + length=cvt_str(cdata, idata) + else + do i=1,rank + if (dim(i) .gt. 1 ) then + write(cdata,'(a,16i5)') ' array [',(dim(j),j=1,rank) + length=8+5*rank+6 + cdata(length-5:length)='] '//cvtyp(type) + goto 29 + endif + enddo + if (type .eq. NX_INT32) then + status=NXgetslab(fileid, idata, 1, 1) + if (status .ne. NX_ok) goto 999 + length=12 + write(cdata(1:12), '(i12)') idata(1) + elseif (type .eq. NX_FLOAT32) then + status=NXgetslab(fileid, val, 1, 1) + if (status .ne. NX_ok) goto 999 + length=16 + write(cdata(1:16), '(g16.5)') val + else + length=4 + cdata=cvtyp(type) + endif + endif +29 write(*,100) tab(1:level*2+1) + 1 ,name(1:l),':',cdata(1:length) + +3 status=NXgetnextattr(fileid, name, length, type) + if (status .eq. NX_error) goto 999 + if (status .eq. NX_ok) then + call str_trim(name,name,l) + + length=256 + status=NXgetattr(fileid, name(1:l), idata, length, type) + if (status .ne. NX_ok) goto 999 + if (type .eq. nx_char .or. + 1 type .eq. nx_uint8 .or. type .eq. nx_int8) then + length=cvt_str(cdata, idata) + elseif (type .eq. NX_INT32) then + length=12 + write(cdata(1:12), '(i12)') idata(1) + else + length=4 + cdata=cvtyp(type) + endif + write(*,100) tab(1:level*2+1) + 1 ,'| ',name(1:l),':',cdata(1:length) + goto 3 + endif + status=NXclosedata(fileid) + if (status .ne. NX_ok) goto 999 + goto 2 + endif + if (level .gt. 0) then + level=level-1 + status=NXclosegroup(fileid) + if (status .ne. NX_ok) goto 999 + goto 2 + endif +9 status=NXclose(fileid) + if (status .ne. NX_ok) goto 999 + print *,"o.k." +999 call nxlistreport + end + + character*4 function cvtyp(type) + + integer type + integer i + + character*4 t(25)/3*' ','char','f32','f64',13*' ', + & 'i8','u8','i16','u16','i32','u32'/ + + if (type .le. 0 .or. type .gt. 25) then + do i=1,25 + if (t(i) .eq. ' ') write(t(i),'(i2)') i + enddo + if (type .gt. 9999 .or. type .lt. 0) then + cvtyp='????' + else + write(cvtyp, '(i4)') type + endif + else + cvtyp=t(type) + endif + end + + + integer function cvt_str(cdata, idata) + + character cdata*(*) + character str*257 + byte idata(*) + + integer l + + call replace_string(str, idata) + call str_trim(str, str, l) + if (l+2 .gt. len(cdata)) then + cdata='"'//str(1:len(cdata)-5)//'..."' + cvt_str=len(cdata) + else + cdata='"'//str(1:l)//'"' + cvt_str=l+2 + endif + end diff --git a/pgm/chooser.f b/pgm/chooser.f new file mode 100644 index 0000000..3201d4b --- /dev/null +++ b/pgm/chooser.f @@ -0,0 +1,3 @@ + program chooser + call cho_choose('?') + end diff --git a/pgm/clamp.f b/pgm/clamp.f new file mode 100644 index 0000000..0318333 --- /dev/null +++ b/pgm/clamp.f @@ -0,0 +1,152 @@ + program mclamp + +* mclamp = multi convert to lamp format +* ^^^^^^ ^ ^ ^^^^ +* preparation program for 3d plots in LAMP +* converts all the data formats recognized by FIT into LAMP format +* +* > myfit clamp.f +* > mv a.out clamp +* 6.2.01 LK / 26.8.02 MZ +* +* To be done: +* - if the input files do not have the same x-range, the output may be wrong +* - instead of 'number of files to merge' a tolerance in temperature +* should be given, and clamp should merge automatically +* + implicit none + + real int1(4000),tth(4000),step,y(1000),tem(1000) + integer i,j,f,l,n,np,flag,int2(4000) + integer merg, numor1, numor2 + real rnum, ymon + character*20 sample + character*1024 list + character*4 yflag + + call fit_init + + do i=1,4000 + int1(i)=0. + enddo + + print *,'number of files to merge:' + read(*,'(i20)') merg + if (merg .le. 0) merg=1 + print *,'step for merge [0.025]' + read(*,'(f20.0)') step + if (step .eq. 0) step=0.025 + + open(1,file='LAMPascii',status='unknown') + + call dat_ask_filelist(list,' ') + + flag=0 + np=0 + n=0 + + ymon=0 + + do f=1,1000*merg + + call fit_dat_silent + call fit_dat_next_opt(list,flag,0,step) ! DAT + call fit_get_real('Numor', rnum) + numor1=nint(rnum) + if (flag .eq. 0) goto 100 + do j=2,merg + call fit_dat_silent + call fit_dat_next_opt(list,flag,3,step) ! LINK & MERGE + if (flag.eq.0) goto 50 + enddo + call fit_get_real('Numor', rnum) + 50 numor2=nint(rnum) + print *,'read numors',numor1,' to',numor2 + call fit_merge(step) + if (ymon .eq. 0) then + call fit_auto_mon + call fit_get_real('Monitor', ymon) + else + call fit_mon(ymon) + endif + + call fit_get_real('temp',tem(f)) + call fit_get_str('sample',l,sample) + + call fit_get_array('X',tth,4000,np) + call fit_get_array('Y',int1,4000,np) + + do i=1,4000 + int2(i)=nint(int1(i)) + enddo + + write(1,'(6i12)')(int2(j),j=1,np) + + n=n+1 + + enddo + 100 continue + + close(1) + + yflag='1' + 105 print '(x,a)', 'x-axis: 2Theta' + print '(x,2a)', 'y-axis: File number [1] or Temperature [2]' + & ,' (default: 1): ' + read(*,'(a)') yflag + print * + if (yflag.eq.' ') yflag='1' + if ((yflag.ne.'1').and.(yflag.ne.'2')) goto 105 + + open(3,file='LAMP',status='unknown') + + write(3,'(x,a)')'LAMP_FORMAT' + write(3,'(x,a)')'HEADER FILE written by the LAMP APPLICATION' + write(3,*) + write(3,*) + write(3,'(x,a)')'DATA_FILE: LAMPascii' + write(3,'(x,a)')'SOURCE: clamp' + write(3,'(x,a)')'HISTORY: DMC/HRPT' + write(3,*) + write(3,'(x,a,i9)')'X_SIZE:',np + write(3,'(x,a,i9)')'Y_SIZE:',n + write(3,'(x,a,i9)')'Z_SIZE:',1 + write(3,'(x,a)')'FORMAT: Ascii' + write(3,'(x,a)')'TYPE: (3 )Long Integer' + write(3,*) + write(3,'(x,a,i4,a,i3,a)')'MIN,MAX VALUES: w 1: Long dim =',np, + & ' * ',n,' min=0 max=9999' + write(3,*) + write(3,'(x,2a)')'TITLES: ',sample + write(3,'(x,a)')' X: 2Theta' + if (yflag.eq.'1') write(3,'(x,a)')' Y: File Number' + if (yflag.eq.'2') write(3,'(x,a)')' Y: Temperature' + write(3,'(x,a)')' Z: Counts' + write(3,*) + write(3,'(x,a)')'PARAMETERS:' + write(3,'(x,a)')'----------' + write(3,'(x,2a)')'Sample Name= ',sample + write(3,'(x,a)')'Temperature= ' + write(3,*) + write(3,'(x,a)')'X_COORDINATES:' + write(3,'(x,a)')'-------------' + + write(3,'(6f13.4)')(tth(j),j=1,np) + + write(3,*) + write(3,'(x,a)')'Y_COORDINATES:' + write(3,'(x,a)')'-------------' + + do i=1,n + y(i)=i + enddo + + if (yflag.eq.'1') then + write(3,'(6f13.4)')(y(j),j=1,n) + else + write(3,'(6f13.4)')(tem(j),j=1,n) + endif + + close(3) + + end diff --git a/pgm/csc.f b/pgm/csc.f new file mode 100644 index 0000000..8fe19e2 --- /dev/null +++ b/pgm/csc.f @@ -0,0 +1,210 @@ + program csc + +* convert single crystal data +* ^ ^ ^ +* +* converts any data format read by FIT to inputfile for +* TVtueb (E2, HMI Berlin) +* +* > myfit -o csc csc.f +* +* Nov.03 L.Keller +* Dec.03 M.Zolliker (merged DMC + HRPT Version, 1 pass) + + implicit none + +! max. number of files, max. number of points + integer mf,mp + parameter (mf=2000,mp=1600) + + real int1(mp),tth(mp) + real tem(mf),omega(mf),mon(mf),tth0(mf) + real lambda,dtth,lasttth,lastint + real reverse,omegasign + integer i,j,f,l,n,np,flag,nfiles,linstr + integer intall(mp,mf), int2(mp) + character*32 sample,owner,date,title,instr + character*1024 list + + call fit_init + + call dat_ask_filelist(list,' ') + + flag=0 + + call fit_dat_next(list,flag) + + call fit_get_real('lambda',lambda) + call fit_get_str('owner',l,owner) + call fit_get_str('sample',l,sample) + call fit_get_str('title',l,title) + call fit_get_str('date',l,date) + + call fit_get_str('instrument',linstr,instr) + if (instr .eq. 'DMC') then + omegasign=-1 ! Vorzeichenwechsel von A3 + dtth=0.2 + reverse=-1 ! for historical reasons, revert output + np=400 + elseif (instr .eq. 'HRPT') then + omegasign=1 + dtth=0.1 + reverse=-1 + np=1600 + else + write(*,*) 'unknown instrument: ',instr + stop + endif + + write(*,*) + write(*,*)'processing ...' + write(*,*) + + do f=1,mf + + call fit_get_real('a3',omega(f)) + call fit_get_real('temp',tem(f)) + call fit_get_real('smon',mon(f)) + + call fit_get_array('X',tth,mp,n) + call fit_get_array('Y',int1,mp,n) + + j=0 + lasttth=tth(1) + lastint=int1(1) + do i=1,n + do while ((tth(i)-lasttth)/dtth .gt. 1.5) ! step is higher than 1.5 times step + j=j+1 + intall(j,f)=nint((lastint+int1(i))*0.5) + lasttth=lasttth+dtth + enddo + j=j+1 + lastint=int1(i) + intall(j,f)=nint(lastint) + lasttth=tth(i) + enddo +! check if step and number of points is correct + if (nint((tth(n)-tth(1))/dtth) .ne. np-1 .or. j .ne. np) then + print *,'step ',dtth,' np ',j + print *,'theta-range', tth(1), tth(n) + print *,'mismatch' + stop + endif + tth0(f)=tth(1) + +! print '(''+'',i5)',f + print '(a1,i5,a1,$)','+',f,13 + + call fit_dat_silent + call fit_dat_next(list,flag) + + if (flag.eq.0) then + nfiles=f + goto 100 + endif + + enddo + write(*,*)'too many files - fatal error' + stop + 100 continue + write(*,*) + nfiles=f + + open(1,file='csc.asc',status='unknown') + print *,'create csc.asc' + + write(1,'(a14)')'SYS$SYSDEVICE:' + write(1,*) + write(1,'(a6,a64)')'NUMOR ',list + write(1,*) + write(1,'(3a)')'EXPTYPE ',instr(1:linstr),',SINQ' + write(1,*) + write(1,'(a3,x,a32)')'USN',owner + write(1,*) + write(1,'(a3,x,F6.4)')'WAV',lambda + write(1,*) + write(1,'(a,i6,a)') 'WIND W1= 1,',np, + & ' W2= 0, 0 W3= 0, W4= 0, 0' + write(1,*) + write(1,'(a9)')'PASS TTHS' + write(1,*) + write(1,'(a9)')'PRO T_SAM' + write(1,*) + write(1,'(a8,i12)')'MM1 MON=',nint(mon(1)) + write(1,*) + write(1,'(a,e12.5,a,e12.5,a,e12.5)') + & 'RELA TTHS=',1.0*np,',',1.0*np,',',reverse*dtth + write(1,*) + write(1,'(a3,x,a32)')'SAM',sample + write(1,*) + write(1,'(a5,x,a32)')'TITLE',title + write(1,*) + write(1,'(a10,i6,x,a4)')'SETV STEP=',nfiles,'OMGS' + write(1,*) + write(1,'(a12,e12.5)')'READ T_MEAN=',tem(1) + write(1,*) + write(1,'(a4,x,a32)')'DATE',date + write(1,*) + write(1,'(a3,x,a32)')'COM',title + write(1,*) + write(1,*) + + + do f=1,nfiles + + if (reverse .lt. 0) then + j=np + do i=1,np + int2(j)=intall(i,f) + tth(j)=tth0(f)+dtth*(i-1) + j=j-1 + enddo + else + do i=1,np + int2(i)=intall(i,f) + tth(i)=tth0(f)+dtth*(i-1) + enddo + endif + + write(1,'(a9)')'SETVALUES' + write(1,'(a4,F12.4)')'OMGS',omegasign*omega(f) + write(1,*) + write(1,*) + write(1,'(a14)')'PROTOCOLVALUES' + write(1,'(a5,F12.4)')'T_SAM',tem(f) + write(1,*) + write(1,*) + write(1,'(a13)')'MASTER1VALUES' + write(1,'(a3)')'MM1' + write(1,'(a3,i12)')'MON',nint(mon(f)) + write(1,'(a3)')'SL1' + write(1,'(a4,F12.4)')'TTHS',tth0(f) + write(1,'(a4)')'LDET' + write(1,'(a2)')'W1' + + do i=1,np,10 + write(1,'(x,i4,a1,F7.2,10I12)')i,'/',tth(i), + & (int2(j),j=i,min(np,i+9)) + enddo + + write(1,'(a18,a27,a15)')'PEAK','BACKGROUND','INTEGRAL' + write(1,'(F12.4,4i12)')0.0,0,0,0,1 + write(1,'(a16)')'TIM1 1' + write(1,*) + write(1,*) + write(1,'(a14)')'PROTOCOLVALUES' + write(1,'(a5,F12.4)')'T_SAM',tem(f) + write(1,*) + write(1,*) + + enddo + 200 continue + + write(1,'(a14)')'DATE 01-JAN-01' + write(1,*) + write(1,'(a13)')'TIME 01:01:01' + write(1,*) + + close(1) + + end diff --git a/pgm/csvsumvar.f b/pgm/csvsumvar.f new file mode 100644 index 0000000..d242a80 --- /dev/null +++ b/pgm/csvsumvar.f @@ -0,0 +1,319 @@ +! Output variables for list of files in comma separated variable format +! +! interactive usage: csvsumvar +! allows specification of output variables, list of files, and output file +! +! non-interactive usage: csvsumvar [list of files] {output filename} +! relies upon environment variables `dat_defspec` and `sumvar` to +! determine which variables are included in output (same as plain sumvar) +! The output filename is optional, if omitted output is sent to STDOUT. +! +! Cobbled together from the guts of sumvar.f by Gregory Tucker -- 2017-11-02 + + program csvsumvar +! -------------- + implicit none + + integer nmax + parameter (nmax=10000) + + character filelist*2048, files*2048, spec*16, sumvars*256 + character var*64, filename*128 + integer l, k, km, i, n, pin, pout, lun, iostat + integer first,last + real xval(nmax), yval(nmax), sig(nmax), rmon(nmax) + + external list_values, list_vars, list_nix + + integer mcols + parameter (mcols=32) + integer ncol, nframes + real cnts, fmt(mcols), vmin(mcols), vmax(mcols) + character line*1024, names(mcols)*32, time*6 + character formatted(mcols)*128 + common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax + & ,line, names, formatted, time + +! call fit_init + call sys_get_cmdpar(files,l) ! l is set by sys_get_cmdpar to the length of returned character variable, but isn't used + call dat_def_options('entry=') + + ! check if files contains the output filename too + filename=' ' + call findfirstlastnonblank(files,first,last) + if (last-first .gt. 0) then + files=files(first:last) ! remove any preceeding or trailing spaces + i=index(files(first:last)," ") ! look for any internal spaces + if (i .gt. 0) then + filename=files(first+i:last) ! after space is filename + files=files(first:first+i-1) ! before space is files specification + endif + endif + + + if (files .eq. ' ') then + call dat_ask_filelist(filelist, ' ') + if (filelist .eq. ' ') goto 91 + call dat_silent + pin=0 + pout=0 + call dat_open_next(filelist, pin, line, pout + & , list_nix, nmax, n, xval, yval, sig, rmon) + endif + call sys_getenv('dat_defspec', spec) + call sys_getenv('sumvar', sumvars) + if (sumvars .eq. ' ') call sys_getenv('sumvars', sumvars) + if (sumvars .eq. ' ') then + call sys_getenv('sumvar_'//spec, sumvars) + endif + if (sumvars .eq. ' ') then + sumvars= + & 'Numor:5,Date:16,Title:25,Temp:10.3,dTemp:8.3,sMon:10.' + endif + if (files .eq. ' ') then + print * + print *,' Variables listed by default:' + call str_trim(sumvars, sumvars, l) + print '(x,a)',sumvars(1:l) + print * +30 print *,' Enter a new variable list, for default' + & ,', or ? for help:' + read(*, '(a)', err=91, end=91) line + if (line .eq. '?') then + print * + &,'--------------------------------------------------------------' + print * + &,' You may configure the default with the environment variables' + &,' sumvar or sumvar_',spec + print * + &,' Example (to be typed on the Unix prompt):' + print * + print '(x,3a)' + &,'> setenv sumvars "',sumvars(1:l),'"' + print * + print * + &,' For each column, write the variable name and the column' + &,' width, separated by a colon. For numeric values, give' + &,' also the number of digits after decimal point, separated' + &,' with a point. The columns have to be separated by a comma.' + &,' The column title is right justified, if a point is present.' + print * + print * + &,' List of variables in the first file:' + call dat_silent + pin=0 + pout=0 + call dat_open_next(filelist, pin, files, pout + & , list_vars, nmax, n, xval, yval, sig, rmon) + call list_vars('*', 0.0) + print * + &,'--------------------------------------------------------------' + goto 30 + endif + if (line .ne. ' ') sumvars=line + print * + print *,'Output file name (default: terminal):' + read(*, '(a)', err=91, end=91) filename + else + filelist=files + endif + if (filename .eq. ' ') then + lun=6 + else + lun=1 + call sys_open(lun, filename, 'w', iostat) + if (iostat .ne. 0) then + print *,'can not open',filename + stop + endif + call findfirstlastnonblank(sumvars,first,last) + print *,"saving output ",sumvars(first:last) + call findfirstlastnonblank(files,first,last) + print *,"from files ",files(first:last)," to ",filename + endif + + call str_trim(sumvars, sumvars, last) ! last is the length of sumvars without trailing space(s) + sumvars(min(len(sumvars),last+1):)=',' + + ncol=0 + k=0 + line=' ' +35 km=index(sumvars(k+1:),',') + if (km .gt. 0) then + if (km .gt. 1 .and. ncol .lt. mcols) then + ncol=ncol+1 + var=sumvars(k+1:k+km-1) + i=index(var, ':') + if (i .eq. 0) then + call str_trim(names(ncol), var, n) + fmt(ncol)=16.3 + else + call str_trim(names(ncol), var(1:i-1), n) + fmt(ncol)=0 + read(var(i+1:),*,err=36) fmt(ncol) +36 if (fmt(ncol) .eq. 0) fmt(ncol)=16.3 + endif + call findfirstlastnonblank(names(ncol),first,last) + if (last-first .gt. 0) then + formatted(ncol)='"'//names(ncol)(first:last)//'",' ! stash for output + endif + call str_upcase(names(ncol), names(ncol)) + endif + k=k+km + goto 35 + endif + +38 if (ncol .le. 1) goto 91 + call putonline(formatted,ncol,line) + call findfirstlastnonblank(line,first,last) + if (last-first .gt. 1) then + write(lun, '(a)') line(first:last-1) ! cut off the trailing comma + endif + + pin=0 + pout=0 +40 line=' ' + call fillspaces(formatted,ncol) ! reset the formatted column strings (only up to the number of columns) + call dat_def_options('entry=*') + call dat_silent + call dat_open_next(filelist, pin, files, pout + & , list_values, nmax, n, xval, yval, sig, rmon) ! this calls subroutine list_values for the pin_th entry of filelist + call putonline(formatted,ncol,line) + call findfirstlastnonblank(line,first,last) + if (last-first .gt. 1) then + write(lun, '(a)') line(first:last-1) ! cut off the trailing comma + endif + + if (pin .le. len(filelist)) goto 40 +91 end + + + subroutine list_nix(name, value) + character name*(*) + real value + end + + subroutine list_vars(name, value) + character name*(*) + real value + + integer l/0/,j + character line*80 + save line, l + + if (name .eq. 'ShowLevel') return + j=index(name, '=')-1 + if (j .le. 0) call str_trim(name, name, j) + if (l+j .ge. 80 .or. name .eq. '*') then + print *,line(1:l) + l=0 + endif + if (l .gt. 0) then + line(l+1:l+1)=',' + l=l+1 + endif + line(l+1:)=name(1:j) + l=min(80,l+j) + end + + + subroutine list_values(name, value) + character name*(*) + real value + + integer i,l,j,first,last + character unam*32, form*8, field*128 + real f + + integer mcols + parameter (mcols=32) + integer ncol, nframes + real cnts, fmt(mcols), vmin(mcols), vmax(mcols) + character line*1024, names(mcols)*32, time*6 + character formatted(mcols)*128 + common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax + & ,line, names, formatted, time + + if (name .eq. 'ranges') then + nframes=nint(value) + elseif (name .eq. 'Counts') then + cnts=value + elseif (len(name) .gt. 5) then + if (name(1:5) .eq. 'Date=') then + time=name(17:) + endif + endif + j=index(name, '=') + if (j .gt. 1) then ! string + call str_upcase(unam, name(1:j-1)) + else + call str_upcase(unam, name) + endif + do i=1,ncol + if (unam .eq. names(i)) then + f=fmt(i)+1 + l=int(f+0.001) + if (l .ge. len(field)) l=len(field) + field(1:)=' ' + if (j .gt. 0) then ! string + field(1:l)=' '//name(j+1:) + else + if (f-l .lt. 0.04) then + write(form, '(a,I2,a)') '(i',l,')' + write(field(1:l), form) nint(value) + else + write(form, '(a,f5.1,a)') '(f',f,')' + write(field(1:l), form) value + endif + endif + if (field(1:1) .ne. '-') field(1:1)=' ' + call findfirstlastnonblank(field,first,last) + formatted(i)='"'//field(first:last)//'",' + endif + enddo + end + + subroutine findfirstlastnonblank(field,intf,intl) + character field*(*) + integer intf,intl + intl=LEN(field) + intf=1 + if (intl .gt. 0) then + do while (field(intf:intf) .eq. ' ') + intf=intf+1 + if (intf .ge. intl) exit + enddo + do while (field(intl:intl) .eq. ' ') + intl=intl-1 + if (intl .le. intf) exit + enddo + endif + end + + subroutine fillspaces(vecchars,lv) + integer lv + character vecchars(lv)*(*) + integer i + do i=1,lv + vecchars(i)=' ' + enddo + end + + subroutine putonline(vecchars,lv,outline) + integer lv + character vecchars(lv)*(*), outline*(*) + integer lo,i,first,last,k,thisl + lo=len(outline) + k=0 + do i=1,lv + call findfirstlastnonblank(vecchars(i),first,last) + if (last-first .gt. 0) then + if (k .lt. lo) then + thisl=last-first+1 + outline(k+1:k+thisl)=vecchars(i)(first:last) + k=k+thisl + endif + endif + if (k .ge. lo) exit ! shortcut if we've run past the end of the outline + enddo + end diff --git a/pgm/datafilepath b/pgm/datafilepath new file mode 100755 index 0000000..bdafbd0 --- /dev/null +++ b/pgm/datafilepath @@ -0,0 +1,97 @@ +#!/usr/bin/env python3 +import os +import sys +import time + +USAGE = """ +Usage: + + datafilepath [] [] + +set current proposal for an instrument for fit +""" + +instrument = os.environ.get('dat_defspec', None) +proposal = os.environ.get('dat_proposal', None) +printit = True + +filename = '/tmp/.senv_%s.%s' % (os.environ['USER'], os.getppid()) +lines = [] +envdict = {} +try: + with open(filename, 'r') as f: + for line in f: + if not line.startswith('setenv '): + if line.strip() != '#': + lines.append(line) + continue + head, name, value = line.split() + if value[0] == "'" and value[-1] == "'": + value = value[1:-1] + envdict[name] = value +except FileNotFoundError: + lines = ['test $$ = %s && rm -f %s' % (os.getppid(), filename)] + +proposal = os.environ.get('dat_proposal', envdict.get('dat_proposal', None)) +if len(sys.argv) > 1: + proposal = sys.argv[1] +elif proposal is None: + if printit: + print(USAGE) + printit = False + proposal = input('proposal: ') +envdict['dat_proposal'] = proposal + +instrument = os.environ.get('dat_defspec', envdict.get('dat_defspec', None)) +if len(sys.argv) > 2: + instrument = sys.argv[2] +elif instrument is None: + if printit: + print(USAGE) + printit = False + instrument = input('instrument: ') +envdict['dat_defspec'] = instrument + +if len(sys.argv) > 3: + envdict['dat_defyear'] = sys.argv[3] + +key = 'dat_spec_%s' % instrument +datspec = envdict.get(key, os.environ.get(key, None)) +if datspec is None: + if printit: + print(USAGE) + printit = False + datspec = input('file path (containing ****** for numor): ') + +elements = [] +for spc in datspec.split(','): + res = [] + for elm in spc.split('/'): + if elm.startswith(instrument + '%%%%n'): + res[-1] = proposal + res.append(elm) + elements.append('/'.join(res)) +datspec = ','.join(elements) +envdict[key] = datspec + +with open(filename, 'w') as f: + for key, value in envdict.items(): + f.write("setenv %s '%s'\n#%s\n" % (key, value, os.environ.get(key, ''))) + f.write('\n'.join(lines)) + f.write('\n') + +year = envdict.get('dat_defyear', time.strftime('%Y' , time.localtime())) +datspec = datspec.replace('%%%%', year) + +if len(sys.argv) < 2: + if printit: + print(USAGE) + printit = False + +print('data file path:\n') +last = '' +for element in datspec.split(','): + if '/' not in element: + element = last.rsplit('.', 1)[0] + element + print(element) + last = element diff --git a/pgm/deteff.f b/pgm/deteff.f new file mode 100644 index 0000000..c61e692 --- /dev/null +++ b/pgm/deteff.f @@ -0,0 +1,190 @@ + program deteff + +* 1. linearer Fit (A+xB) einer Detektoreichmessung * +* 2. Normierung der Daten mit der verfeinerten Funktion * +* 3. Speicherung im Format fuer deteff.dat * +* 27.4.99 keller, Aenderung 15.7.99,28.9.99 * +* Aenderung 3.11.99: schneidet Punkte die 0 sind weg (HRPT!) * +* 7.3.00, 24.5.02, 9.8.02 * +* * +* > myfit deteff.f * +* > cp a.out deteff * + + implicit none + + external FIT_LIN_FUN + + real par(16),err(16),int(2000),tth(2000),par1,ti,step,tf,lim + integer n,i,nret,l,count + character*36 spec + character*5 flag,flag2 + character*78 title + + call fit_init + +! Function title and parameter names + call fit_userfun('STRAIGHT LINE', fit_lin_fun) ! function title, function + call fit_userpar('Bg(0)') ! first parameter: background at zero + call fit_userpar('dBg/dX') ! second parameter: slope + + call fit_dat_options('cal=0') ! turns off calibration of raw data + + do i=1,2000 + int(i)=0. + enddo + + + call sys_getenv('dat_defspec',spec) + if (spec.eq.' ') spec='DMC' + call str_trim(spec,spec,l) ! Laenge bestimmen (l) + + 100 write(*,*) + write(*,'(x,a)')'DMC = 1 / HRPT = 2' + write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): ' + read(*,'(a)')flag ! ^ schreibt spec von + ! Zeichen 1 bis l + + call str_upcase(flag,flag) ! schreibt Inhalt von flag gross + if (flag.eq.'1') flag='DMC' + if (flag.eq.'2') flag='HRPT' + if (flag.ne.' ') then + if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100 + spec=flag + endif + + call sys_setenv('dat_defspec',spec) + + +C WRITE (*,'(X,A,$)') 'Calibration data files (e.g.: DMC/1999/ +C A4-34) : ' +C READ (*,'(A)') FILES + +C CALL FIT_DAT(FILES) + +C call fit_dat(' ') +C call fit_merge(0.02) + call fit_dat_merge(' ',0.02) ! ersetzt fit_dat und fit_merge + call fit_get_array('X',tth,2000,nret) + call fit_get_array('Y',int,2000,nret) + + write(*,*) + write(*,'(x,a,$)')'Title of detector efficiency file: ' + read(*,'(a)')title + + if (title.eq.' ') then + if (nret.eq.400) title='DMC detector efficiency file' + if (nret.eq.1600) title='HRPT detector efficiency file' + endif + + if (nret.ne.400) then + if (nret.ne.1600) then + write(*,*) + write(*,*) + write(*,*) + write(*,*) + write(*,*)' **************** WARNING ***************' + write(*,*) + write(*,*)' The number of data points does not match ' + write(*,*)' the number of detectors of DMC or HRPT' + write(*,*) + write(*,*) + write(*,'(a,$)')' continue? (y/N): ' + read(*,'(a)')flag2 + call str_upcase(flag2,flag2) + if (flag2.ne.'Y') then + write(*,'(a)')' program aborted' + goto 102 + endif + endif + endif + + write(*,*) + write(*,'(x,a,$)')'slope=0 ? (Y/n): ' + read(*,'(a)') flag2 + call str_upcase(flag2,flag2) + + TI=TTH(1) + TF=TTH(NRET) + STEP=(TTH(NRET)-TTH(1))/(NRET-1.) + + PAR1=0 + DO I=1,NRET + PAR1=PAR1+INT(I) + ENDDO + PAR(1)=PAR1/NRET ! starting value for Bg(0) + PAR(2)=0. ! starting value for slope + ERR(1)=1. + ERR(2)=1. + + lim=par(1)/4. ! points below lim are excluded! + + call fit_exclude(0.,0.,0.,lim) + + CALL FIT_FUN(7,2,PAR,ERR) + if (flag2 .ne. 'N') call fit_fix(2) + CALL FIT_FIT(0) + CALL FIT_FIT(0) + CALL FIT_FIT(0) + CALL FIT_GET_ARRAY('P',PAR,2,N) ! reads fit parameters + CALL FIT_GET_ARRAY('E',ERR,2,N) ! reads parameter errors + + OPEN (1,FILE='deteff.dat',STATUS='UNKNOWN') + + WRITE (1,'(2A)')'#',TITLE + if (nret.gt.999) write(1,'(I4)')nret + if (nret.lt.1000) write(1,'(I3)')nret + + count=0 ! count: # of excluded points + + DO 101 I=1,NRET + + if (int(i).lt.lim) then + write(1,'(F8.6)')0.0 + count=count+1 + else + WRITE(1,'(F8.6)')INT(I)/(PAR(1)+((I-1)*STEP+TI)*PAR(2)) + endif + + 101 CONTINUE + + CLOSE(1) + + call str_trim(spec,spec,l) + WRITE(*,*) + WRITE(*,*) + WRITE(*,*) + WRITE(*,*) + WRITE(*,*)' New detector efficiency file: deteff.dat' + WRITE(*,'(3a)')' Copy this file into the directory /data/ + Alnslib/data/',spec(1:l),'//' + WRITE(*,*) + WRITE(*,*)' Normalization function: P(1)+2th*P(2)' + WRITE(*,'(A,F12.5,A,F10.5,A,F10.5,A,F9.5,A)')' P(1)=' + A,PAR(1),'(',ERR(1),'), P(2)=',PAR(2),'(',ERR(2),')' + WRITE(*,*) + if (count.gt.0) write (*,*)' Number of excluded points: ',count + WRITE(*,*) + + 102 END + + + real function fit_lin_fun(x,p,n,mode,cinfo) +! ------------------------------------------- + + implicit none + + real x ! x-value + integer n ! number of parameters + real p(n) ! parameters + integer mode ! mode + integer cinfo ! calculation information (see below) + + if (mode .eq. 0) then + +! Define here your own function + + fit_lin_fun=p(1)+x*p(2) + + endif + end + diff --git a/pgm/deteff2.f b/pgm/deteff2.f new file mode 100644 index 0000000..25e8d26 --- /dev/null +++ b/pgm/deteff2.f @@ -0,0 +1,203 @@ + program deteff + +* 1. linearer Fit (A+xB) einer Detektoreichmessung * +* 2. Normierung der Daten mit der verfeinerten Funktion * +* 3. Speicherung im Format fuer deteff.dat * +* 27.4.99 keller, Aenderung 15.7.99,28.9.99 * +* Aenderung 3.11.99: schneidet Punkte die 0 sind weg (HRPT!) * +* 7.3.00,24.5.02,9.8.02 * +* 16.01.03 zolliker (Fragt, ob untergrund flach sein soll) * +* * +* > myfit -o deteff deteff.f * + + implicit none + + external FIT_LIN_FUN + + real par(16),err(16),int(2000),tth(2000),par1,ti,step,tf,lim + integer n,i,nret,l,count + character*36 spec + character*5 flag,flag2 + character*78 title + real flat + + call fit_init + +! Function title and parameter names + call fit_userfun('STRAIGHT LINE', fit_lin_fun) ! function title, function + call fit_userpar('Bg(0)') ! first parameter: background at zero + call fit_userpar('dBg/dX') ! second parameter: slope + + call fit_dat_options('cal=0') ! turns off calibration of raw data + + do i=1,2000 + int(i)=0. + enddo + + + call sys_getenv('dat_defspec',spec) + if (spec.eq.' ') spec='DMC' + call str_trim(spec,spec,l) ! Laenge bestimmen (l) + + 100 write(*,*) + write(*,'(x,a)')'DMC = 1 / HRPT = 2' + write(*,'(x,3a,$)')'Instrument (default: ',spec(1:l),'): ' + read(*,'(a)')flag ! ^ schreibt spec von + ! Zeichen 1 bis l + + call str_upcase(flag,flag) ! schreibt Inhalt von flag gross + if (flag.eq.'1') flag='DMC' + if (flag.eq.'2') flag='HRPT' + if (flag.ne.' ') then + if (flag.ne.'DMC' .and. flag.ne.'HRPT') goto 100 + spec=flag + endif + + write(*,*) + write(*,'(x,a,$)') 'Flat Background [y]' + read(*,'(a)') flat + call str_upcase(flat, flat) + + call sys_setenv('dat_defspec',spec) + + +C WRITE (*,'(X,A,$)') 'Calibration data files (e.g.: DMC/1999/ +C A4-34) : ' +C READ (*,'(A)') FILES + +C CALL FIT_DAT(FILES) + +C call fit_dat(' ') +C call fit_merge(0.02) + call fit_dat_merge(' ',0.02) ! ersetzt fit_dat und fit_merge + call fit_get_array('X',tth,2000,nret) + call fit_get_array('Y',int,2000,nret) + + write(*,*) + write(*,'(x,a,$)')'Title of detector efficiency file: ' + read(*,'(a)')title + + if (title.eq.' ') then + if (nret.eq.400) title='DMC detector efficiency file' + if (nret.eq.1600) title='HRPT detector efficiency file' + endif + + if (nret.ne.400) then + if (nret.ne.1600) then + write(*,*) + write(*,*) + write(*,*) + write(*,*) + write(*,*)' **************** WARNING ***************' + write(*,*) + write(*,*)' The number of data points does not match ' + write(*,*)' the number of detectors of DMC or HRPT' + write(*,*) + write(*,*) + write(*,'(a,$)')' continue? (y/n): ' + read(*,'(a)')flag2 + call str_upcase(flag2,flag2) + if (flag2.ne.'Y') then + write(*,'(a)')' program aborted' + goto 102 + endif + endif + endif + + TI=TTH(1) + TF=TTH(NRET) + STEP=(TTH(NRET)-TTH(1))/(NRET-1.) + + PAR1=0 + DO I=1,NRET + PAR1=PAR1+INT(I) + ENDDO + PAR(1)=PAR1/NRET ! starting value for Bg(0) + PAR(2)=0. ! starting value for slope + ERR(1)=1. + ERR(2)=1. + + lim=par(1)/4. ! points below lim are excluded! + + call fit_exclude(0.,0.,0.,lim) + + CALL FIT_FUN(7,2,PAR,ERR) + + if (flat .eq. 'Y') call fit_fix(2) ! fix slope + + CALL FIT_FIT(0) + CALL FIT_FIT(0) + CALL FIT_FIT(0) + CALL FIT_GET_ARRAY('P',PAR,2,N) ! reads fit parameters + CALL FIT_GET_ARRAY('E',ERR,2,N) ! reads parameter errors + + OPEN (1,FILE='deteff.dat',STATUS='UNKNOWN') + + WRITE (1,'(2A)')'#',TITLE + if (nret.gt.999) write(1,'(I4)')nret + if (nret.lt.1000) write(1,'(I3)')nret + + count=0 ! count: # of excluded points + + DO 101 I=1,NRET + + if (int(i).lt.lim) then + write(1,'(F8.6)')0.0 + count=count+1 + else + WRITE(1,'(F8.6)')INT(I)/(PAR(1)+((I-1)*STEP+TI)*PAR(2)) + endif + + 101 CONTINUE + + CLOSE(1) + + call str_trim(spec,spec,l) + WRITE(*,*) + WRITE(*,*) + WRITE(*,*) + WRITE(*,*) + WRITE(*,*)' New detector efficiency file: deteff.dat' + WRITE(*,'(3a)')' Copy this file into the directory /data/ + Alnslib/data/',spec(1:l),'//' + WRITE(*,*) + WRITE(*,*)' Normalization function: P(1)+2th*P(2)' + WRITE(*,'(A,F12.5,A,F10.5,A,F10.5,A,F9.5,A)')' P(1)=' + A,PAR(1),'(',ERR(1),'), P(2)=',PAR(2),'(',ERR(2),')' + WRITE(*,*) + if (count.gt.0) write (*,*)' Number of excluded points: ',count + WRITE(*,*) + + 102 END + + + real function fit_lin_fun(x,p,n,mode,cinfo) +! ------------------------------------------- + + implicit none + + real x ! x-value + integer n ! number of parameters + real p(n) ! parameters + integer mode ! mode + integer cinfo ! calculation information (see below) + + if (mode .eq. 0) then + +! Define here your own function + + fit_lin_fun=p(1)+x*p(2) + + elseif (mode .lt. 0) then + +! Use this part to do some initialisations. +! (e.g. read files, write out comments on your user function) +! This section is called by FIT_FUN (command FUN) + + type * + type *, 'to define your own user function leave FIT and type MYFIT' + type *, 'Example: STRAIGHT LINE' + + endif + end + diff --git a/pgm/getdatafilepath b/pgm/getdatafilepath new file mode 100755 index 0000000..0d00441 --- /dev/null +++ b/pgm/getdatafilepath @@ -0,0 +1,50 @@ +#!/usr/bin/env python3 +import os +import sys +import time +from glob import glob + +USAGE = """ +Usage: + + getdatafilepath + +get datafile path +""" + +if len(sys.argv) != 4: + print(USAGE) + sys.exit() + +instrument = sys.argv[1] +year = sys.argv[2] +number = int(sys.argv[3]) +key = 'dat_spec_%s' % instrument +last = '' +for datspec in os.environ[key].replace('%%%%', year).split(','): + if '/' not in datspec: + datspec = last.rsplit('.', 1)[0]+datspec + last = datspec + for i in range(10,0,-1): + pat = '*' * i + if datspec.find(pat) >= 0: + break + else: + pat = None + + if pat: + fmt = '%%.%dd' % len(pat) + datspec = datspec.replace(pat, fmt % number) + if year < '2020': + datspec = datspec.replace('###', '%.3d' % (number // 1000)) + if os.path.isfile(datspec): + print(datspec) + break + else: + datspec = datspec.replace('###', '*') + files = glob(datspec) + if len(files) == 1: + print(files[0]) + break +else: + print('%s:%s:%d' % (instrument, year, number)) diff --git a/pgm/polcal.f b/pgm/polcal.f new file mode 100644 index 0000000..edceef3 --- /dev/null +++ b/pgm/polcal.f @@ -0,0 +1,444 @@ + program polcal + +c this program work, because the dat_tasmad_read routine is +c coding the polarisation information into the x-value ip.b +c where i is 1..9 for xx, yx, yz, zy, yy, zy, xz, yz, zz +c p is 1..4 for ++, +-, -+, -- +c b is 0 for signal and 1 for background + + implicit none + character files*1024 + character bfiles*1024 + character line*2048 + character word*1024 + + integer l, pos + integer i + real xx(36), yy(36), ss(36) + real cnts(9,4,2), sigma(9,4,2) + integer n + character mukind*20 + character single*1024 + logical merge,bgr + integer listflag + real numor, mon, lastnumor + integer status + integer iostat + integer summary,sumx,sumy + common summary,sumx,sumy + + call sys_get_cmdpar(line, l) + if (line .eq. ' ') then + print * + print *,'polcal calculates polarisation matrices from files ', + 1 'measured with the' + print *,'polmat command on TASP/MuPAD' + print * + print *,'Usage:' + print *, + 1 'polcal [-m] [-b ]' + print * + print *,'Options:' + print * + print *,' -m' + print *,' merge files' + print *,' without this option, for every file a polarisation' + print *,' matrix is calculated' + print * + print *,' -b' + print *,' treat numors given before -b as signal,' + print *,' numors after -b as background.' + print *,' the files are merged even without the -m option.' + print *,' without this option, polcal sorts out automatically' + print *,' signal and background files' + print * + print *,' -f' + print *,' make summary files fort.11 etc. with the' + print *,' matrix elements' + print * + print *,' -f1213' + print *,' make a summary of Pxy vs Pxz (output file fort.1)' + print * + goto 9 + endif + +c Argument processing + pos=1 + files=' ' + merge=.false. + summary=0 + bgr=.false. + call str_get_word(line, pos, word) +1 do while (word .ne. ' ') + if (word .eq. '-b') then + call str_get_word(line, pos, bfiles) + bgr=.true. + merge=.true. + elseif (word .eq. '-m') then + merge=.true. + elseif (word(1:2) .eq. '-f') then + if (word(3:) .eq. ' ') then + summary=1 + else + summary=2 + sumx=0 + sumy=0 + read(word(3:4), *, iostat=iostat) sumx + read(word(5:6), *, iostat=iostat) sumy + endif + else + if (files .eq. ' ') then + files = word + else + call str_trim(files, files, l) + if (l .lt. len(files) - 1) then + l=l+1 + files(l:l)=',' + files(l+1:) = word + endif + endif + endif + call str_get_word(line, pos, word) + enddo + + call sys_setenv('dat_defspec','TASP') + call fit_init_silent + call clr_me(cnts) + call clr_me(sigma) + + if (merge) then + if (bgr) then + call fit_dat_silent + call fit_dat(files) + call fit_merge(0.2) ! merge signal and bgr + call fit_get_real('Monitor', mon) + call fit_get_array('X', xx, 36, n) + call fit_get_array('Y', yy, 36, n) + call fit_get_array('S', ss, 36, n) + call fill_me(cnts, xx, yy, n, 1) ! 1 = force to signal + call fill_me(sigma, xx, ss, n, 1) + call calc_pol(cnts, sigma, status) + if (status .eq. 0) then + print *,'NO DATA' + goto 9 + else + call info_line(files, 'S', 1) + endif + call fit_dat_silent + call fit_dat(bfiles) + call fit_merge(0.2) ! merge signal and bgr + call fit_mon(mon) + call fit_get_array('X', xx, 36, n) + call fit_get_array('Y', yy, 36, n) + call fit_get_array('S', ss, 36, n) + call fill_me(cnts, xx, yy, n, 2) ! 2 = force to bgr + call fill_me(sigma, xx, ss, n, 2) + call calc_pol(cnts, sigma, status) + if (status .eq. 0) then + print *,'NO DATA' + else + call info_line(bfiles, 'B', 2) + endif + else + call fit_dat_silent + call fit_dat(files) + call fit_merge(0.01) ! do not merge signal and bgr + call fit_get_array('X', xx, 36, n) + call fit_get_array('Y', yy, 36, n) + call fit_get_array('S', ss, 36, n) + call fill_me(cnts, xx, yy, n, 0) + call fill_me(sigma, xx, ss, n, 0) + call calc_pol(cnts, sigma, status) + if (status .eq. 0) then + print *,'NO DATA' + else + call info_line(files, 'S', 1) + if (status .eq. 2) call info_line(files, 'B', 1) + endif + endif + else + listflag=0 + lastnumor = -1 + do i=1,99999 + call fit_dat_silent + call fit_dat_next(files, listflag) + if (listflag .eq. 0) goto 9 + mukind=' ' + call fit_get_str('mukind', l, mukind) + if (mukind .ne. 'background') then + call clr_me(cnts) + call clr_me(sigma) + if (mukind .eq. ' ') goto 19 + endif + call fit_get_array('X', xx, 36, n) + call fit_get_array('Y', yy, 36, n) + call fit_get_array('S', ss, 36, n) + call fill_me(cnts, xx, yy, n, 0) + call fill_me(sigma, xx, ss, n, 0) + call calc_pol(cnts, sigma, status) + if (status .eq. 0) goto 19 + call fit_get_real('Numor', numor) + if (mukind .eq. 'background') then + if (lastnumor .eq. -1) then + print *,'WARNING: background only' + call cvtnumor(single, numor) + call info_line(single, ' ', 1) + else + call cvtnumor(single, lastnumor) + call cvtnumor(single, numor) + call info_line(single, 'B', 2) + endif + else + call cvtnumor(single, numor) + call info_line(single, ' ', 1) + lastnumor=numor + endif +19 continue + enddo + endif +9 end + + + subroutine cvtnumor(result, numor) + character result*(*) + real numor + integer l + + write(result,'(f10.0)') numor + call str_first_nonblank(result, l) + result = result(l:9) + end + + + subroutine info_line(file, type, prthold) + + character file*(*), type*(*) + integer prthold + + character line1*132/' '/, line2*132/' '/ + real vmin(5), vmax(5), mean(5), diff(5) + integer i,l + character line*132, label*4 + logical secondline + + if (prthold .eq. 2) then + if (line1(1:3) .eq. ' ') line1(1:3)='sig' + call str_trim(line1, line1, l) + print '(x,a)',line1(1:l) + call str_trim(line2, line2, l) + if (l .gt. 1) print '(x,a)',line2(1:l) + endif + + do i=1,5 + vmin(i)=0 + vmax(i)=0 + enddo + if (type .eq. 'B') then + call meta_real_range('QH', vmin(1), vmax(1)) + call meta_real_range('QH_B', vmin(1), vmax(1)) + call meta_real_range('QK', vmin(2), vmax(2)) + call meta_real_range('QK_B', vmin(2), vmax(2)) + call meta_real_range('QL', vmin(3), vmax(3)) + call meta_real_range('QL_B', vmin(3), vmax(3)) + call meta_real_range('EN', vmin(4), vmax(4)) + call meta_real_range('EN_B', vmin(4), vmax(4)) + call meta_real_range('TEMP', vmin(5), vmax(5)) + call meta_real_range('TEMP_B', vmin(5), vmax(5)) + label='bgr' + else + call meta_real_range('QH', vmin(1), vmax(1)) + call meta_real_range('QH_S', vmin(1), vmax(1)) + call meta_real_range('QK', vmin(2), vmax(2)) + call meta_real_range('QK_S', vmin(2), vmax(2)) + call meta_real_range('QL', vmin(3), vmax(3)) + call meta_real_range('QL_S', vmin(3), vmax(3)) + call meta_real_range('EN', vmin(4), vmax(4)) + call meta_real_range('EN_S', vmin(4), vmax(4)) + call meta_real_range('TEMP', vmin(5), vmax(5)) + call meta_real_range('TEMP_S', vmin(5), vmax(5)) + if (type .eq. 'S') then + label='sig' + else + label=' ' + endif + endif + + do i=1,5 + mean(i) = 0.5 * (vmin(i) + vmax(i)) + diff(i) = 0.5 * (vmax(i) - vmin(i)) + enddo +! temperature tolerance 10 % + secondline = (diff(5) .gt. mean(5) * 0.1) +! q tolerance 0.003 + do i=1,3 + if (diff(i) .gt. 0.003) secondline = .true. + enddo +! en tolerance 0.01 + if (diff(4) .gt. 0.01) secondline = .true. + + call str_trim(file, file, l) + write(line1, '(2a,3f8.3,'' en:'',f8.2,'' T:'',f8.3,2a)') + 1 label, 'q:', mean, ' file(s): ',file(1:l) + + line2=' ' + if (secondline) then + line=' ' + do i=1,5 + if (i .eq. 4) then + write(line(i*8-7:i*8), '(f8.2)') diff(i) + else + write(line(i*8-7:i*8), '(f8.3)') diff(i) + endif + enddo + write(line2,'(7a)') ' +/-',line(1:24),' +/-',line(25:32) + 1 ,' +/-',line(33:40),' <-- mixed values!!!' + endif + + if (prthold .gt. 0) then + call str_trim(line1, line1, l) + print '(x,a)',line1(1:l) + call str_trim(line2, line2, l) + if (l .gt. 1) print '(x,a)',line2(1:l) + endif + end + + + subroutine calc_pol(cnts, sigma, status) + implicit none + real cnts(9,4,2), sigma(9,4,2) + integer status + + integer i,i1,i2,k,ip,im + real sum2, d2, sum, pij, dpij2, c1, c2, sq1, sq2 + character line*80 + + real pm(3,4), sm(3,4) + logical done,bgr,matoutput + integer l + integer summary,sumx,sumy + common summary,sumx,sumy + real numor + + status=0 + matoutput = .false. +c k=1: normal polarity, k=2: NEG. polarity + do k=1,2 + done = .false. + bgr = .false. + ip=k*2-1 + im=k*2 + do i1=1,3 + sum2 = 0 + d2 = 0 + line=' ' + do i2=1,3 + i = (i1-1)*3 + i2 + if (cnts(i,ip,2) .gt. 0 .or. cnts(i,im,2) .gt. 0) status=2 + c1 = cnts(i, ip, 1) - cnts(i, ip, 2) + c2 = cnts(i, im, 1) - cnts(i, im, 2) + sq1 = sigma(i, ip, 1)**2 + sigma(i, ip, 2)**2 + sq2 = sigma(i, im, 1)**2 + sigma(i, im, 2)**2 + sum = c1 + c2 + if (sum .eq. 0 .or. + 1 cnts(i, ip, 1) .eq. 0 .and. cnts(i, im, 1) .eq. 0) then + pij=0 + dpij2 = 1 + else + done = .true. + pij = (c1 - c2) / sum + dpij2 = ((1-pij)/sum) ** 2 * sq1 + dpij2 = dpij2 + ((1+pij)/sum) ** 2 * sq2 + endif + pm(i1, i2) = pij + sm(i1, i2) = sqrt(dpij2) + sum2 = sum2 + pij*pij + d2 = d2 + dpij2 * pij * pij + enddo + pm(i1,4) = sqrt(sum2) + if (sum2 .eq. 0) then + sm(i1,4)=1 + else + sm(i1,4) = sqrt(d2/sum2) + endif + enddo + if (done) then + matoutput = .true. + if (status .eq. 0) status=1 + print *, + 1'------------------------------------------------------' + call fit_get_str('Title', l, line) + if (k .eq. 2) then + print *,'NEG. polarity ',line(1:l) + else + print *,'normal polarity ',line(1:l) + endif + print *,' pix sigma piy sigma piz sigma' + 1, ' |Pi| sigma' + do i1=1,3 + line=' ' + if (summary .eq. 1) call fit_get_real('numor', numor) + do i2=1,4 + if (pm(i1, i2) .ne. 0 .or. sm(i1, i2) .ne. 1.0) then + write(line(i2*20-19:i2*20), '(2f7.3)') pm(i1, i2), sm(i1, i2) + endif + if (summary .eq. 1) then + write(i1*10+i2,*) numor, pm(i1,i2), sm(i1,i2) + endif + enddo + print *,line(1:78) + if (summary .eq. 2) then + write(1,*) pm(sumx/10, mod(sumx,10)) + 1 , pm(sumy/10, mod(sumy,10)),sm(sumy/10,mod(sumy,10)) + endif + enddo + endif + enddo + if (.not. matoutput) then + print *,'WARNING: zero count matrix can not be calculated' + endif + end + + subroutine clr_me(values) + real values(9,4,2) + integer i,j,k + do k=1,2 + do j=1,4 + do i=1,9 + values(i,j,k)=0 + enddo + enddo + enddo + end + + subroutine fill_me(values, xx, yy, n, mode) + + implicit none + integer n + integer mode + real values(9,4,2), xx(n), yy(n) + + integer i,j,k,m,dbl + + dbl=0 + do m=1,n + i = nint(xx(m)) + if (mode .ne. 0) then + k = mode + else if (abs(xx(m)-i) .lt. 0.05) then + k = 1 + else + k = 2 + endif + j=mod(i,10) + i=i/10 + if (i .gt. 0 .and. i .le. 9 .and. j .gt. 0 .and. j .le. 4) then + if (values(i,j,k) .ne. 0) then + dbl=1 + endif + values(i,j,k) = yy(m) + endif + enddo + if (dbl .ne. 0) then + print *,'WARNING: duplicate points skipped' + endif + end diff --git a/pgm/subit.f b/pgm/subit.f new file mode 100644 index 0000000..289e3f5 --- /dev/null +++ b/pgm/subit.f @@ -0,0 +1,64 @@ + program subit + +* ~= old changei +* range and steps of file2 are interpolated according to file1; +* file2 is scaled with factor mon1/mon2 +* 23.4.99 keller, modified 7.3.00 +* +* > myfit subit.f +* > cp a.out subit + + implicit none + + real const + character*78 file1,file2,file3,title + character*16 cc + + write(*,*) + write(*,'(x,a)')'____________________________________' + write(*,*) + write(*,'(x,a)')' File1 - (Mon1/Mon2)*File2 + const.' + write(*,'(x,a)')'____________________________________' + write(*,*) + + 100 write(*,'(x,a,$)')'File1 / file to add: ' + read(*,'(a)')file1 + if (file1.eq.' ') goto 100 + + 101 write(*,'(x,a,$)')'File2 / file to subtract: ' + read(*,'(a)')file2 + if (file2.eq.' ') goto 101 + + write(*,'(x,a,$)')'Value of additive constant (default: 0): ' + read(*,'(a)')cc + if (cc.eq.' ') cc='0.' + read(cc,*)const + + write(*,'(x,a,$)')'Name of output file: ' + read(*,'(a)')file3 + if (file3.eq.' ') file3='diff.dat' + + write(*,'(x,a,$)')'Title of output file: ' + read(*,'(a)')title + if (title.eq.' ') title='difference pattern' + + write(*,*) + write(*,*) + + call fit_init + call fit_dat(file1) + call fit_subtract(file2) + +C write(*,*) +C call fit_mon(0) + + call fit_add(const, 0) + call fit_title(title) + + call fit_export(0,'dmc',file3) + + write(*,*) + write(*,'(x,2a)')'new file: ',file3 + write(*,*) + + end diff --git a/pgm/sumvar.f b/pgm/sumvar.f new file mode 100644 index 0000000..7522c0c --- /dev/null +++ b/pgm/sumvar.f @@ -0,0 +1,271 @@ + program sumvar +! -------------- + + implicit none + + integer nmax + parameter (nmax=10000) + + character filelist*2048, files*2048, spec*16, sumvars*256 + character var*64, filename*128 + integer ls, l, k, km, i, n, pin, pout, lun, iostat + real xval(nmax), yval(nmax), sig(nmax), rmon(nmax) + + external list_values, list_vars, list_nix + + integer mcols + parameter (mcols=32) + integer ncol, nframes + real cnts, fmt(mcols), vmin(mcols), vmax(mcols) + character line*1024, line2*1024, names(mcols)*32, time*6 + common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax + & ,line, line2, names, time + +! call fit_init + call sys_get_cmdpar(files,l) + call dat_def_options('entry=') + + if (files .eq. ' ') then + call dat_ask_filelist(filelist, ' ') + if (filelist .eq. ' ') goto 91 + call dat_silent + pin=0 + pout=0 + call dat_open_next(filelist, pin, line, pout + & , list_nix, nmax, n, xval, yval, sig, rmon) + endif + call sys_getenv('dat_defspec', spec) + call sys_getenv('sumvar', sumvars) + if (sumvars .eq. ' ') call sys_getenv('sumvars', sumvars) + if (sumvars .eq. ' ') then + call sys_getenv('sumvar_'//spec, sumvars) + endif + if (sumvars .eq. ' ') then + sumvars= + & 'Numor:5,Date:16,Title:25,Temp:10.3,dTemp:8.3,sMon:10.' + endif + if (files .eq. ' ') then + print * + print *,' Variables listed by default:' + call str_trim(sumvars, sumvars, l) + print '(x,a)',sumvars(1:l) + print * +30 print *,' Enter a new variable list, for default' + & ,', or ? for help:' + read(*, '(a)', err=91, end=91) line + if (line .eq. '?') then + print * + &,'--------------------------------------------------------------' + print * + &,' You may configure the default with the environment variables' + &,' sumvar or sumvar_',spec + print * + &,' Example (to be typed on the Unix prompt):' + print * + print '(x,3a)' + &,'> setenv sumvars "',sumvars(1:l),'"' + print * + print * + &,' For each column, write the variable name and the column' + &,' width, separated by a colon. For numeric values, give' + &,' also the number of digits after decimal point, separated' + &,' with a point. The columns have to be separated by a comma.' + &,' The column title is right justified, if a point is present.' + print * + print * + &,' List of variables in the first file:' + call dat_silent + pin=0 + pout=0 + call dat_open_next(filelist, pin, files, pout + & , list_vars, nmax, n, xval, yval, sig, rmon) + call list_vars('*', 0.0) + print * + &,'--------------------------------------------------------------' + goto 30 + endif + if (line .ne. ' ') sumvars=line + print * + print *,'Output file name (default: terminal):' + read(*, '(a)', err=91, end=91) filename + if (filename .eq. ' ') then + lun=6 + else + lun=1 + call sys_open(lun, filename, 'w', iostat) + if (iostat .ne. 0) then + print *,'can not open',filename + stop + endif + endif + else + filelist=files + lun=6 + endif + + call str_trim(sumvars, sumvars, ls) + sumvars(min(len(sumvars),ls+1):)=',' + + ncol=0 + k=0 + l=0 + line=' ' +35 km=index(sumvars(k+1:),',') + if (km .gt. 0) then + if (km .gt. 1 .and. ncol .lt. mcols) then + ncol=ncol+1 + var=sumvars(k+1:k+km-1) + i=index(var, ':') + if (i .eq. 0) then + call str_trim(names(ncol), var, n) + fmt(ncol)=16.3 + else + call str_trim(names(ncol), var(1:i-1), n) + fmt(ncol)=0 + read(var(i+1:),*,err=36) fmt(ncol) +36 if (fmt(ncol) .eq. 0) fmt(ncol)=16.3 + endif + i=int(fmt(ncol)+0.001) + if (index(var, '.') .eq. 0) then ! left just + line(l+1:l+i)=names(ncol) + else + line(l+max(0,i-n)+1:l+i)=names(ncol) + endif + call str_upcase(names(ncol), names(ncol)) + l=l+i+1 + endif + k=k+km + goto 35 + endif + +38 if (l .le. 1) goto 91 + l=l-1 + print * + write(lun, '(x,a)') line(1:l) + do i=1,l + line(i:i)='-' + enddo + write(lun, '(x,a)') line(1:l) + + pin=0 + pout=0 +40 line=' ' + line2=' ' + call dat_def_options('entry=*') + call dat_silent + call dat_open_next(filelist, pin, files, pout + & , list_values, nmax, n, xval, yval, sig, rmon) + call str_trim(line, line, l) + if (line(1:l) .ne. ' ') then + write(lun, '(a)') line(1:l) + if (line2(1:l) .ne. ' ') + & write(lun, '(a)') line2(1:l) + endif + if (pin .le. len(filelist)) goto 40 +91 end + + + subroutine list_nix(name, value) + character name*(*) + real value + end + + subroutine list_vars(name, value) + + character name*(*) + real value + + integer l/0/,j + character line*80 + save line, l + + if (name .eq. 'ShowLevel') return + j=index(name, '=')-1 + if (j .le. 0) call str_trim(name, name, j) + if (l+j .ge. 80 .or. name .eq. '*') then + print *,line(1:l) + l=0 + endif + if (l .gt. 0) then + line(l+1:l+1)=',' + l=l+1 + endif + line(l+1:)=name(1:j) + l=min(80,l+j) + end + + + subroutine list_values(name, value) + + character name*(*) + real value + + integer k,i,l,j + character unam*32, form*8, field*128 + real f + + integer mcols + parameter (mcols=32) + integer ncol, nframes + real cnts, fmt(mcols), vmin(mcols), vmax(mcols) + character line*1024, line2*1024, names(mcols)*32, time*6 + common /sum_com/ncol, nframes, cnts, fmt, vmin, vmax + & ,line, line2, names, time + + if (name .eq. 'ranges') then + nframes=nint(value) + elseif (name .eq. 'Counts') then + cnts=value + elseif (len(name) .gt. 5) then + if (name(1:5) .eq. 'Date=') then + time=name(17:) + endif + endif + j=index(name, '=') + if (j .gt. 1) then ! string + call str_upcase(unam, name(1:j-1)) + else + call str_upcase(unam, name) + endif + k=0 + do i=1,ncol + f=fmt(i)+1 + l=int(f+0.001) + if (l .ge. len(field)) l=len(field) + if (unam .eq. names(i)) then + if (j .gt. 0) then ! string + field(1:l)=' '//name(j+1:) + else + if (f-l .lt. 0.04) then + write(form, '(a,I2,a)') '(i',l,')' + write(field(1:l), form) nint(value) + else + write(form, '(a,f5.1,a)') '(f',f,')' + write(field(1:l), form) value + endif + endif + if (field(1:1) .ne. '-') field(1:1)=' ' + if (line(k+1:k+l) .eq. ' ') then + line(k+1:k+l)=field(1:l) + vmin(i)=value + vmax(i)=value + elseif (j .eq. 0) then ! numeric + if (line(k+1:k+l) .ne. field(1:l)) then + if (value .gt. vmax(i)) then + line2(k+1:k+l)=field(1:l) + elseif (value .lt. vmin(i)) then + if (line2(k+1:k+l) .eq. ' ') + & line2(k+1:k+l)=line(k+1:k+l) + line(k+1:k+l)=field(1:l) + endif + endif + elseif (line(k+1:k+l) .ne. field(1:l)) then ! string + line2(k+1:k+l)=field(1:l) + endif +! goto 39 + endif + k=k+l + if (k .gt. len(line)) goto 39 + enddo +39 continue + end diff --git a/pgm/trics_ccl.f b/pgm/trics_ccl.f new file mode 100644 index 0000000..2ab6993 --- /dev/null +++ b/pgm/trics_ccl.f @@ -0,0 +1,368 @@ + program TriCS_CCL +c ----------------- +c +c fits data from ccl-files and write *.col file for upals +c and rafin.dat file for position refining +c + +c replaces "none" +c 8.5.99/21.6.99/15.7.99 Juerg Schefer +c 29.11.99: Lorentz-Korrektur SJ33 +c 10.4.2000: flat background SJ33 +c 31.10.2000: transfered to UNIX ZO33 +c 22.11.2000: problem with printing is fixed +c 02.02.01: h,k,l may be real ZM33 +c 17.06.2010: Lorentz correction for tilt Geometry, SJ33 +c +c link ccl,fit4_shr/opt ! attention: check for last fit_n +c + + implicit none + + integer np_max + parameter (np_max=1000) + real output(20),th2,omega_cal,omega_fit,chi,phi,yint,yy1, + * dint,delta,yoverall,h,k,l,s,temperature,range + real omega_err + real output2(20), xx(np_max),lor_cor,fwhm,radian,degrees + real bgr, wmult + logical plot,iexp,flat_backgr + integer lorentz,comens ! SJ33, June 2010 + integer next_flag + integer iall,iincom,icom,icenter + character*1 answer,hard + character*128 input_files + character*128 output_file1 + character*128 output_file2 + character*128 output_file3 ! SJ33, May 2012 + character*128 output_file4 ! SJ33, May 2012 + character*16 out + character*2 off,weak + character*30 hkl + character*12 hkl_int + character*18 hkl_float + character*24 datime + integer ldt + + integer ntyp,i,j,numor,ii,iout,np + radian=3.14159265/180.00 + degrees=1./radian + + write(*,1000) + 1000 format (/,' FIT CCL Files: Version 2.08, update Jun. 21, 2010', + * //,' Data processing of files *.ccl from TriCS single' + * ,' detector mode') + + call sys_setenv('DAT_DEFSPEC', 'TRICS') + call dat_ask_filelist(input_files, ' ') + output_file1=input_files + i=index(output_file1, '.') + if (i .eq. 0) i=index(output_file1, '[') + if (i .eq. 0) i=index(output_file1, ',') + if (i .eq. 0) i=index(output_file1, ' ') + do j=i-1,1,-1 + if (output_file1(j:j) .eq. '/') then + goto 1002 + endif + enddo + j=0 +1002 if (i .gt. j+1) then + output_file2=output_file1(j+1:i-1)//'_rafin.dat' + output_file1=output_file1(j+1:i-1)//'.col' + output_file3=output_file1(j+1:i-1)//'.comm' + output_file4=output_file1(j+1:i-1)//'.incomm' + else + output_file2='rafin.dat' + output_file1='upals.col' + endif +c + write(*,1004) +1004 format (/,' function type to be used (0=gauss[def],6=strange)', + * ' typ = ',$) + read (5,'(i1)') ntyp + if (ntyp .eq. 6) then + write(*,'(/,'' width factor [1.0] = '',$)') + read(5,'(f20.0)') wmult + if (wmult .eq. 0.0) wmult=1.0 + else + wmult=1.0 + ntyp=0 + endif + + write(*,1013) + 1013 format (/,' Monitor to be standardized , monitor=',$) + read (5,'(f20.0)') yoverall + if (yoverall.le.1.1) yoverall = 100000. + + write(*,1015) +1015 format (/, + * ' plots (answer=n [no=def], y [yes,terminal], h [hard] ',$) + read (5,'(a1)') answer + plot = (answer.eq.'y' .or. answer .eq.'h') + if (plot) then + hard='y' + if (answer.eq.'y') hard='n' + endif + + write(*,1019) +1019 format (' Flat Background (y/n, default=y) : ',$) + read (5,'(a1)')answer + flat_backgr = (answer.ne.'n' .and. answer .ne.'N') + + if (ntyp .eq. 0) then + write(*,1017) +1017 format + * (//,' output intensities: 0=experimental (def), 1=gaussian ',$) + read (5,'(i1)') Iout + iexp= (iout.eq.0) + else + iexp= .true. + endif + if (iexp) then + out='experimental ' + else + out='gaussian ' + end if + + write(*,1018) +1018 format (' Lorentz-Correction to be applied (0 = 4-circle-geometry(default), 1 = tilt-geometry, 2 = not applied) ?: ',$) + read (5,'(I1)') lorentz ! SJ33, June 2010, tilt option added (3 options now, def=0) + if (lorentz.ne.1 .and. lorentz.ne.2) lorentz=0 ! SJ33, June 2010 + write(*,1011) input_files,ntyp,wmult, + * output_file1,output_file2,out,yoverall,flat_backgr,lorentz + 1011 format (/,' ',78('-'),/,' input from file(s) :',A30,/, + * ' function type ',i3,' width factor ',f6.3,//, + * ' output: for UPALS :',A50,/, + * ' for RAFIN :',A50,/, + * 1X,A16,' intensities used'/, + * ' monitor: ',f12.1,/, + * ' Flat Background (yes/no): ',L33,/, + * ' Lorentz-Correction (options: 0 = 4-circle-mode,', + * ' 1 = tilt-mode, 2 = none)',/, + * ' applied option No. ',i1,/, + * ' No. 0 Icor=Iobs*sin(2theta)',/, + * ' No. 1 Icor=Iobs*sin(Gama)*cos(nu)',/, + * ' ',78('-'),/,' hit return to start ',$) +c + read (5,'(i1)') ii +C if (ii.eq.1) goto 504 + +c + if (ntyp.ne.0 .and. ntyp.ne.6) ntyp = 0 +c +c this ends the input for the program, the rest goes automatic +c ------------------------------------------------------------ + if (plot) then + call sys_setenv('CHOOSER_PAN','9') ! 9 plots per page + end if +c +c loop over all data following: + iall =0 + iincom =0 + icom =0 + icenter =0 + open (unit=1,file=output_file1,status='unknown') + open (unit=2,file=output_file2,status='unknown') + open (unit=3,file=output_file3,status='unknown') + open (unit=4,file=output_file4,status='unknown') +c write headers for fullprof +c write (3,1027)9.99,0,1,1,0.00,0.00,0.00 +c write (4,1028)9.99,0,1,1,0.00,0.00,0.00 +c1027 format (' title',/,22H(I6,3I10,2F10.2,4F8.2), /,F7.4,i5,i6,/,i1,3f5.2) +c1028 format (' title',/,24H(I6,3F10.4,2F10.2,4F8.2),/,F7.4,I5,i6,/,i1,3f5.2) + next_flag=0 ! start flag + i=0 + call fit_init +c +c ------------------------------------------------------ start loop -- +1500 continue + + call fit_dat_next(input_files, next_flag) + if (next_flag .eq.0) goto 2222 ! last scan of last file read + i=i+1 + + call fit_mon(yoverall) + +C set limits if peak to narrow: + call fit_get_array('P', output, 20, ii) + call fit_get_array('X', xx, np_max, np) + + +c get information out of title: + call fit_get_real('two_theta',th2) + call fit_get_real('omega',omega_cal) + call fit_get_real('chi',chi) + call fit_get_real('phi',phi) + call fit_get_real('h',h) + call fit_get_real('k',k) + call fit_get_real('l',l) + call fit_get_real('temp',temperature) ! SJ33, Aug.30,1999 + call fit_get_str('date', ldt, datime) + +cjs type *,' ***** temp=',temperature + numor=i + if (l.eq.88) then + write(*,1007) + 1007 format (' data numor not found, exit') + goto 3000 + endif +c + if (ntyp .eq. 6) then + call fit_fun(6,1,wmult,0.0) ! select strange + else + call fit_fun(ntyp,0,0.0,0.0) ! select other (guassian) + endif + if (flat_backgr) call fit_set(2,0.,0.,0.,0.) ! flat background +c range = scan with: + range=xx(np)-xx(1) +cjs type *,'******',output(5),output(6) + if (ntyp .ne. 6) then + if (output(6) .lt. 5.0*range/np) then +c set position to center: + call fit_set(3, (xx(np)+xx(1))/2.0, range/np, + & xx(1)+range/6,xx(np)-range/6) +c set fwhm + fwhm = max(0.2,range/5) +c arbitrary limits: minimal 3 steps, maximal 1 /3 range + call fit_set(6,fwhm,fwhm/10.,3*range/np, range/3) + else + fwhm=max(output(6),5*range/np) + call fit_set(6,fwhm,range/np + 1 ,3*range/np,range/3) + endif + endif + call fit_fit(0) +c + if (plot) call fit_plot(hard) ! hardcopy / terminal +c + call fit_get_array('P', output, 20, ii) + call fit_get_array('E', output2, 20, ii) +cjs type *,' output ',output +cjs type *,' output2',output2 +c +c +c get results now: + if (ntyp.eq.0) then +c function 1 (gauss: use only background, intensity=sum) + omega_fit = output (3) + omega_err = output2(3) + off = ' ' + if (iexp) then + yint = output(8) + dint = output2(8) + else +c modified 14.7.99 sj33 + yint = output(5) + dint = output2(5) + endif + bgr=output(1) + fwhm=output(6) + else +c function 6 (strange) + yint = output(7) + dint = output2(7) + omega_fit = output(3) + omega_err = output2(3) + bgr=output(1) + fwhm=output(4) + end if +c +c make notes for easy data inspections: + delta = abs (omega_cal - omega_fit) + if (delta.ge.0.3) off =' *' + if (delta.ge.0.5) off ='**' + weak = ' ' +c +c write on output files now: + lor_cor = 1.00000 +c L = 1 / SIN (2-Theta), page 156, Schwarzenbach, EPFL: +c L applies to the calculated value of the intensities +c Ical*L = Iobs +c (measured intensity is always bigger than corrected one) + if (lorentz.eq.0) lor_cor = sin (abs(th2)*radian) +c +c June 2010: SJ33 +c tilt angle nu is read-in as chi from file *.col +c correction formula: not used (3.59) on page 154, Schwarzenbach/Chapuis Cristallographie, Presses EPFL ! SJ33, June 2010 +c used: Arndt and Wills, L=sin(gamma)*cos(nu), where gamma projection 2-theta, nu tilt + yy1=lor_cor + if (lorentz.eq.1) lor_cor = + * sin(abs(th2)*radian)*cos(abs(chi)*radian) +c * sqrt( (sin(abs(th2)*radian))**2 -(sin(abs(chi)*radian))**2 ) ! SJ33, June 2010 +c write (6,*)' chi=',chi,th2,radian,sin(chi*radian),sin(th2*radian) +c write (6,*)' Lorentz=',yy1,lor_cor +c +c + if (abs(nint(h)-h) .gt. abs(h)*1e-4 .or. + & abs(nint(k)-k) .gt. abs(k)*1e-4 .or. + & abs(nint(l)-l) .gt. abs(l)*1e-4) then + write(hkl, '(3(x,f9.4))') h, k, l + write(hkl_float,'(3f6.2)') h, k, l + iincom=iincom+1 + iall=iall+1 + comens=1 ! SJ33-May 2012 + else + write(hkl, '(3(x,i9))') nint(h), nint(k), nint(l) + write(hkl_int,'(3i4)') nint(h), nint(k), nint(l) + iall=iall+1 + icom=icom+1 ! SJ33-May 2012 + comens=0 + endif +c + write (1, 1005) numor,hkl,lor_cor*yint,lor_cor*dint, + & Th2/2.,omega_fit,chi,phi,temperature,yoverall/1000.,off,weak + & ,bgr,fwhm,lor_cor,omega_err,datime(1:ldt) +c + if (comens.eq.0) then + write (3, 1025) numor,hkl_int, lor_cor*yint,lor_cor*dint, + * Th2/2,omega_fit,chi,phi ! SJ33-May 2012 + else + write (4, 1026) numor,hkl_float,lor_cor*yint,lor_cor*dint, + * Th2/2,omega_fit,chi,phi + endif ! SJ33-May 2012 +1025 format (I6,A12,2F10.2,4f8.2) ! SJ33, nuc +1026 format (I4,A18,2F10.2,4F8.2) ! SJ33 mag +1005 format (I6,a,1x,f9.2,1x,f9.3,f7.2,1x,f8.3,1x,f7.2,1x,f7.2,1x, + & F8.3,1x,F6.0,1x,2A2,1x,f6.1,1x,f5.3,1x,f6.4,1x,f6.3,1x,a) + + if (dint.ge.1) then + s = yint/dint + if (s.le.3) weak='w ' ! weak + if (s.le.1) weak='vw' ! very weak + if (s.ge.15 .and. yint.ge.100) then ! write strong hkl to rafin.dat + write (2,1009) hkl,Th2,omega_fit,chi,phi,.2,temperature + icenter=icenter+1 + end if +c + 1009 format (a,f8.2,f8.3,2f8.2,1x,f5.3,f9.3) + end if +C + goto 1500 +c -------------------------------------------------------- end loop -- +C + 2222 write(*,1006) + 1006 format (' Bye bye, normal end of program.') +C +C ------------------------------------------- +C error exits here, does not pass label 2222: + 3000 continue + close (1) + close (2) + close (3) ! SJ33-May 2012 + close (4) ! SJ33-May 2012 +c +c writing the end message for the user + write (6,2040) + write (6,2042) input_files(1:60) + write (6,2041) iall,output_file1(1:30),icenter,output_file2(1:30), + * icom,output_file3(1:30),iincom,output_file4 +2040 format(///,' trics_ccl prepared the following files for YOU:',//) +2042 format(' TriCS-input-file used:',A60,//) +2041 format(i6,' reflections ',a30,' for JANA2006',/ + * ,i6,' positions ',a30,' for rafin (to improve your UB using the dataset)',/ + * ,I6,' reflections ',a30,' for Fullprof - commensurate data',/ + * ,I6,' reflections ',a30,' for Fullprof - incommensurate data',//) +c + call fit_exit +c + end diff --git a/pgm/tricslog.f b/pgm/tricslog.f new file mode 100644 index 0000000..1d7bfa1 --- /dev/null +++ b/pgm/tricslog.f @@ -0,0 +1,260 @@ + program trilog_pgm +! ------------------ + + implicit none + + integer nmax + parameter (nmax=10000) + + character filelist*2048, files*2048 + character trilog*1024, trihead*1024, sumvars*1024 + character var*64 + integer ls, l, k, km, i, n, pin, pout, j, lhead, ltot + real xval(nmax), yval(nmax), sig(nmax), rmon(nmax) + + external list_values, list_vars + + integer mcols + parameter (mcols=32) + integer ncol, nframes + real cnts, fmt(mcols) + character line*1024, names(mcols)*32, opt*80, time*6 + common /sum_com/ncol, nframes, cnts, fmt, line, names, time + +! call fit_init + call sys_setenv('dat_defspec', 'TRICS') + call sys_get_cmdpar(files,l) + + call sys_getenv('trilog', trilog) + call sys_getenv('trihead', trihead) + if (trilog .eq. ' ') then + trilog= + & 'dTime:5,stt:7.2,om:7.3,chi:7.2,phi:7.2' + & //',dg1:7.2,dg2:7.2,dg3:7.2,Sum1:8.,Sum2:8.,Sum3:8.' + & //',Temp:8.2,sMon:11.,time:7.,bMon:11.' + endif + if (trihead .eq. ' ') then + trihead='Numor:5,Date:16,Title:60,Sample:20,Owner:20' + endif + if (files .eq. ' ') then + call dat_ask_filelist(filelist, ' ') + if (filelist .eq. ' ') goto 91 + print * + print *,'Variables listed by default ' + & ,'(configure default with setenv trilog / setenv trihead):' + print * + call str_trim(trihead, trihead, l) + print '(x,a)',trihead(1:l) +30 print * + & ,'enter new header variable list, empty line for default' + & ,', ? for a list of variables:' + read(*, '(a)', err=91) line + if (line .eq. '?') then + call dat_silent + print * + pin=0 + pout=0 + call dat_set_options( + & '1,512,bank=detector1,entry=frame0000,frame=0') + call dat_open_next(filelist, pin, files, pout + & , list_vars, nmax, n, xval, yval, sig, rmon) + call list_vars('*', 0.0) + print * + goto 30 + endif + if (line .ne. ' ') trihead=line + call str_trim(trilog, trilog, l) + print '(x,a)',trilog(1:l) +31 print * + & ,'enter new frame variable list, empty line for default' + & ,', ? for a list of variables:' + read(*, '(a)', err=91) line + if (line .eq. '?') then + call dat_silent + print * + pin=0 + pout=0 + call dat_set_options( + & '1,512,bank=detector1,entry=frame0000,frame=0') + call dat_open_next(filelist, pin, files, pout + & , list_vars, nmax, n, xval, yval, sig, rmon) + call list_vars('*', 0.0) + print * + goto 31 + endif + if (line .ne. ' ') trilog=line + else + filelist=files + endif + + call str_trim(sumvars, trihead, ls) + sumvars(min(len(sumvars),ls+1):)=',' + + ncol=0 + k=0 + l=0 + line=' ' + lhead=0 +35 km=index(sumvars(k+1:),',') + if (km .gt. 0) then + if (km .gt. 1 .and. ncol .lt. mcols) then + ncol=ncol+1 + var=sumvars(k+1:k+km-1) + i=index(var, ':') + if (i .eq. 0) then + call str_trim(names(ncol), var, n) + fmt(ncol)=16.3 + else + call str_trim(names(ncol), var(1:i-1), n) + fmt(ncol)=0 + read(var(i+1:),*,err=36) fmt(ncol) +36 if (fmt(ncol) .eq. 0) fmt(ncol)=16.3 + endif + i=int(fmt(ncol)+0.001) + if (index(var, '.') .eq. 0) then ! left just + line(l+1:l+i)=names(ncol) + else + line(l+max(0,i-n)+1:l+i)=names(ncol) + endif + call str_upcase(names(ncol), names(ncol)) + l=l+i+1 + endif + k=k+km + goto 35 + elseif (lhead .eq. 0) then + call str_trim(sumvars, trilog, ls) + sumvars(min(len(sumvars),ls+1):)=',' + k=0 + lhead=l + goto 35 + endif + +38 if (l .le. 1) goto 91 + ltot=l-1 + trihead=line(1:lhead) + trilog=line(lhead+1:ltot) + pin=0 + pout=0 + nframes=0 +40 line=' ' + call dat_silent + call dat_set_options( + & '1,512,bank=detector1,entry=frame0000,frame=0') + call dat_open_next(filelist, pin, files, pout, list_values + & , nmax, n, xval, yval, sig, rmon) + if (n .le. 0) goto 39 + print * + print '(x,a)',trihead(1:lhead) + print '(x,a)',line(1:lhead) + print * + print '(x,a)',trilog(1:ltot-lhead) + + do i=0,nframes-1 + line=' ' +! call list_values('Frame', 1.0*i) + do j=1,3 + cnts=0 + write(opt, '(a,i1,a,i4.4,a,i4)') + & '1,512,bank=detector',j,',entry=frame',i,',frame=',i + call dat_set_options(opt) + call dat_read_again(list_values + & , nmax, n, xval, yval, sig, rmon) + call list_values('Sum'//char(48+j), cnts) + enddo + call list_values('dTime='//time, 0.0) + call str_trim(line, line(lhead+1:ltot), l) + if (line(1:l) .ne. ' ') then + print '(x,a)',line(1:l) + endif + enddo + +39 if (pin .le. len(filelist)) goto 40 +91 end + + + subroutine list_vars(name, value) + + character name*(*) + real value + + integer l/0/,j + character line*80 + save line, l + + if (name .eq. 'ShowLevel') return + j=index(name, '=')-1 + if (j .le. 0) call str_trim(name, name, j) + if (l+j .ge. 80 .or. name .eq. '*') then + print *,line(1:l) + l=0 + endif + if (l .gt. 0) then + line(l+1:l+1)=',' + l=l+1 + endif + line(l+1:)=name(1:j) + l=min(80,l+j) + end + + + subroutine list_values(name, value) + + character name*(*) + real value + + integer k,i,l,j,k0 + character unam*32, form*8 + real f + + integer mcols + parameter (mcols=32) + integer ncol, nframes + real cnts, fmt(mcols) + character line*1024, names(mcols)*32, time*6 + common /sum_com/ncol, nframes, cnts, fmt, line, names, time + + if (name .eq. 'ranges') then + nframes=nint(value) + elseif (name .eq. 'Counts') then + cnts=value + elseif (len(name) .gt. 5) then + if (name(1:5) .eq. 'Date=') then + time=name(17:) + endif + endif + j=index(name, '=') + if (j .gt. 1) then ! string + call str_upcase(unam, name(1:j-1)) + else + call str_upcase(unam, name) + endif + k=0 + do i=1,ncol + l=int(fmt(i)+0.001) + k0=k+l+1 + if (unam .eq. names(i)) then + if (j .gt. 0) then ! string + line(k+1:k+l)=name(j+1:) + else + f=fmt(i) + if (value .lt. 0.0 .and. k .gt. 0) then ! allow minus sign left overlow field + k=k-1 + l=l+1 + f=f+1 + endif + if (f-l .lt. 0.04) then + write(form, '(a,i3,a)') '(i',l,')' + write(line(k+1:k+l), form) nint(value) + else + write(form, '(a,f5.1,a)') '(f',f,')' + write(line(k+1:k+l), form) value + endif + endif +! goto 39 + endif + k=k0 + if (k .gt. len(line)) goto 39 + line(k:k)=' ' + enddo +39 continue + end diff --git a/pgm/ufit.f b/pgm/ufit.f new file mode 100644 index 0000000..6f0c219 --- /dev/null +++ b/pgm/ufit.f @@ -0,0 +1,92 @@ + program ufit ! change FIT to your own program name +! ------------ +! +! Simple user function example (straight line). +! + implicit none + external FIT_ufun ! change FIT_ufun to your own function name + +!--- +! Welcome message + + print '(5(/X,A))' + 1,'Program UFIT' + 1,'------------' + 1,'User function: sum of lorentzian folded with meas. resolution' + +!--- +! Function title and parameter names +! + call fit_userfun('Quasielastic', fit_ufun) ! function title, function + call fit_userpar('B:Bg(0)') ! first parameter: background at zero + call fit_userpar('D:dBg/dX') ! second parameter: slope + call fit_userpar('S:bg.scale') ! background slope + call fit_userpar('G:fwhm gaussian') + call fit_userpar('P:Pos') ! position + call fit_userpar('I1:IntInt 1') ! 1st lorentzian intensity + call fit_userpar('L1:fwhm L 1') ! 1st lorentzian width + call fit_userpar('I2:IntInt 2') ! 2nd lorentzian intensity + call fit_userpar('L2:fwhm L 2') ! 2nd lorentzian width + call fit_userpar('I3:IntInt 3') ! 3rd lorentzian intensity + call fit_userpar('L3:fwhm L 3') ! 3rd lorentzian width + call fit_main + end + + + real function fit_ufun(x,p,n,mode,cinfo) +! ------------------------------------------- + + implicit none + + real x ! x-value + integer n ! number of parameters + real p(n) ! parameters + integer mode ! mode + integer cinfo ! calculation information (see below) + + integer npnt + parameter (npnt=10000) + real xx(npnt), yy(npnt) + real gg,xp,b,q + integer idx/1/, nb/0/ + + real voigt + + if (mode .eq. 0) then + +! Define here your own function + + xp=x-p(5) + gg=p(4) + fit_ufun=p(1)+xp*p(2) + 1 +p(6)*voigt(xp, gg, p(7)) + 1 +p(8)*voigt(xp, gg, p(9)) + 1 +p(10)*voigt(xp, gg, p(11)) + if (idx .le. 0 .or. idx .ge. nb) stop 'FIT_UFUN: illegal IDX' +10 if (x .gt. xx(idx+1)) then + if (idx .lt. nb-1) then + idx=idx+1 + goto 10 + endif + else +20 if (x .lt. xx(idx)) then + if (idx .gt. 1) then + idx=idx-1 + goto 20 + endif + endif + endif + q=(x-xx(idx))/(xx(idx+1)-xx(idx)) + b=yy(idx)*(1-q)+q*yy(idx+1) + fit_ufun=fit_ufun+p(3)*b + + elseif (mode .lt. 0) then + + call fit_sort(0,0) ! sort data + call fit_get_array('X', xx, npnt, nb) + if (nb .ge. npnt) print *,'background points limit reached:',npnt + idx=1 + call fit_get_array('Y', yy, npnt, nb) + + endif + end diff --git a/pgm/zm_fit b/pgm/zm_fit new file mode 100644 index 0000000..2b71f58 --- /dev/null +++ b/pgm/zm_fit @@ -0,0 +1 @@ +this file is used by config diff --git a/pgplot_rhel7/drivers.list b/pgplot_rhel7/drivers.list new file mode 100644 index 0000000..28c20c4 --- /dev/null +++ b/pgplot_rhel7/drivers.list @@ -0,0 +1,114 @@ +! PGPLOT drivers. +!------------------------------------------------------------------------------ +! To configure PGPLOT, ensure that drivers you do not want are +! commented out (place ! in column 1). N.B. Many device-drivers are +! available on selected operating systems only. +!------------------------------------------------------------------------------ +! File Code Description Restrictions +! BCDRIV 0 /BCANON Canon Laser printer (bitmap version), landscape +! CADRIV 0 /CANON Canon Laser printer, LBP-8/A2, landscape +! CCDRIV 0 /CCP DEC LJ250 Color Companion printer +! CGDRIV 1 /CGM CGM metafile, indexed colour selection C +! CGDRIV 2 /CGMD CGM metafile, direct colour selection C +! CWDRIV 0 /CW6320 Gould/Bryans Colourwriter 6320 pen plotter Std F77 +! EPDRIV 0 /EPSON Epson FX100 dot matrix printer +! EXDRIV 1 /EXCL Talaris/EXCL printers, landscape +! EXDRIV 2 /EXCL Talaris/EXCL printers, portrait +! GCDRIV 0 /GENICOM Genicom 4410 dot-matrix printer, landscape +! Caution: use of GIDRIV may require a license from Unisys: + GIDRIV 1 /GIF GIF-format file, landscape + GIDRIV 2 /VGIF GIF-format file, portrait +! GLDRIV 1 /HPGL Hewlett-Packard HP-GL plotters, landscape Std F77 +! GLDRIV 2 /VHPGL Hewlett-Packard HP-GL plotters, portrait Std F77 +! GODRIV 0 /GOC GOC Sigma T5670 terminal VMS +! GVDRIV 0 /GVENICOM Genicom 4410 dot-matrix printer, portrait +! HGDRIV 0 /HPGL2 Hewlett-Packard graphics language +! HIDRIV 0 /HIDMP Houston Instruments HIDMP pen plotter +! HJDRIV 0 /HJ Hewlett-Packard Desk/Laserjet printer +! HPDRIV 0 /HP7221 Hewlett-Packard HP7221 pen plotter Std F77 +! LADRIV 0 /LA50 Dec LA50 and other sixel printers +! LJDRIV 0 /LJ Hewlett-Packard LaserJet printers VMS +! LSDRIV 1 /LIPS2 Canon LaserShot printer (landscape) +! LSDRIV 2 /VLIPS2 Canon LaserShot printer (portrait) +! LNDRIV 0 /LN03 Dec LN03-PLUS Laser printer (landscape) VMS +! LVDRIV 0 /LVN03 Dec LN03-PLUS Laser printer (portrait) VMS +! LXDRIV 0 /LATEX LaTeX picture environment +! MFDRIV 0 /FILE PGPLOT graphics metafile +! NEDRIV 0 /NEXT Computers running NeXTstep operating system + NUDRIV 0 /NULL Null device (no output) Std F77 +! PGDRIV 0 /PGMF PGPLOT metafile (new format, experimental) Std F77 +! PNDRIV 1 /PNG Portable Network Graphics file C +! PNDRIV 2 /TPNG Portable Network Graphics file - transparent background C +! PPDRIV 1 /PPM Portable Pixel Map file, landscape +! PPDRIV 2 /VPPM Portable PIxel Map file, portrait + PSDRIV 1 /PS PostScript printers, monochrome, landscape Std F77 + PSDRIV 2 /VPS Postscript printers, monochrome, portrait Std F77 + PSDRIV 3 /CPS PostScript printers, color, landscape Std F77 + PSDRIV 4 /VCPS PostScript printers, color, portrait Std F77 +! PXDRIV 0 /PRINTRONI Printronix P300 or P600 dot-matrix printer +! QMDRIV 1 /QMS QUIC devices (QMS and Talaris), landscape Std F77 +! QMDRIV 2 /VQMS QUIC devices (QMS and Talaris), portrait Std F77 +! TFDRIV 0 /TFILE Tektronix-format disk file VMS +! TODRIV 0 /TOSHIBA Toshiba "3-in-one" printer, model P351 +! TTDRIV 1 /TEK4010 Tektronix 4006/4010 storage-tube terminal Std F77 +! TTDRIV 2 /GF GraphOn terminal Std F77 +! TTDRIV 3 /RETRO RetroGraphics terminal Std F77 +! TTDRIV 4 /GTERM GTERM Tektronix terminal emulator Std F77 + TTDRIV 5 /XTERM XTERM Tektronix terminal emulator Std F77 +! TTDRIV 6 /ZSTEM ZSTEM terminal emulator Std F77 +! TTDRIV 7 /V603 Visual 603 terminal Std F77 +! TTDRIV 8 /KRM3 Kermit 3 on IBM-PC Std F77 +! TTDRIV 9 /TK4100 Tektronix 4100-series terminals Std F77 +! TTDRIV 10 /VMAC Macintosh VersaTerm-PRO Tektronix-4105 emulator Std F77 +! TXDRIV 0 /TX TeX PK Font Output files +! VADRIV 0 /VCANON Canon Laser printer, LBP-8/A2, portrait +! VBDRIV 0 /VBCANON Canon Laser printer (bitmap version), portrait +! VTDRIV 0 /VT125 Dec Regis terminals (VT125 etc.) Std F77 +! WDDRIV 1 /WD X Window dump file, landscape +! WDDRIV 2 /VWD X Window dump file, portrait +! WSDRIV 0 /WS VAX workstations running VWS software VMS +! X2DRIV 0 /XDISP PGDISP or FIGDISP server for X workstations C + XWDRIV 1 /XWINDOW Workstations running X Window System C + XWDRIV 2 /XSERVE Persistent window on X Window System C +! ZEDRIV 0 /ZETA Zeta 8 Digital Plotter +! +! The following drivers can only be used in PGPLOT installations on MS-DOS +! systems with appropriate hardware and software. Do not select these +! on UNIX or VMS systems. +! +! LHDRIV 0 /LH IBM PCs and clones, Lahey F77 32-bit Fortran v5.0 +! MSDRIV 0 /MSOFT IBM PCs and clones running Microsoft Fortran 5.0 +! SSDRIV 0 /SS IBM PCs and clones, MS-DOS, Salford Software FTN +! +! The following driver can only be used in PGPLOT installations on Acorn +! Archimedes systems with appropriate hardware and software. +! +! ACDRIV 0 /ARC Acorn Archimedes computer +! +! Selection of the XMOTIF driver causes a stub driver to be placed in +! the main PGPLOT library. The real driver is placed in libXmPgplot.a. +! Applications that need the Motif driver should link with libXmPgplot.a +! before the PGPLOT library. This treatment means that only Motif +! applications have to be linked with Motif libraries. +! +! XMDRIV 0 /XMOTIF Motif applications containing XmPgplot widgets. C +! +! Selection of the XATHENA driver causes a stub driver to be placed in +! the main PGPLOT library. The real driver is placed in libXawPgplot.a. +! Applications that need the Athena driver should link with libXawPgplot.a +! before the PGPLOT library. This treatment means that only Athena +! applications have to be linked with Xaw libraries. +! +! XADRIV 0 /XATHENA Motif applications containing XaPgplot widgets. C +! +! Selection of the TK driver causes a stub driver to be placed in +! the main PGPLOT library. The real driver is placed in libtkpgplot.a. +! Applications that need the Tk driver should link with libtkpgplot.a +! before the PGPLOT library. This treatment means that only Tcl/Tk +! applications have to be linked with the Tcl and Tk libraries. +! +! TKDRIV 0 /XTK X-window Tcl/Tk programs with pgplot widgets. C +! +! The following driver is included solely for use by the aips++ team. +! +! RVDRIV 0 /XRV X-window Rivet/Tk programs with pgplot widgets. C diff --git a/pgplot_rhel7/gidriv.o b/pgplot_rhel7/gidriv.o new file mode 100644 index 0000000..2173278 Binary files /dev/null and b/pgplot_rhel7/gidriv.o differ diff --git a/pgplot_rhel7/grarea.o b/pgplot_rhel7/grarea.o new file mode 100644 index 0000000..044a361 Binary files /dev/null and b/pgplot_rhel7/grarea.o differ diff --git a/pgplot_rhel7/grbpic.o b/pgplot_rhel7/grbpic.o new file mode 100644 index 0000000..e3d36d6 Binary files /dev/null and b/pgplot_rhel7/grbpic.o differ diff --git a/pgplot_rhel7/grchsz.o b/pgplot_rhel7/grchsz.o new file mode 100644 index 0000000..77e7974 Binary files /dev/null and b/pgplot_rhel7/grchsz.o differ diff --git a/pgplot_rhel7/grclip.o b/pgplot_rhel7/grclip.o new file mode 100644 index 0000000..5819aef Binary files /dev/null and b/pgplot_rhel7/grclip.o differ diff --git a/pgplot_rhel7/grclos.o b/pgplot_rhel7/grclos.o new file mode 100644 index 0000000..c9f9674 Binary files /dev/null and b/pgplot_rhel7/grclos.o differ diff --git a/pgplot_rhel7/grclpl.o b/pgplot_rhel7/grclpl.o new file mode 100644 index 0000000..4ffe93a Binary files /dev/null and b/pgplot_rhel7/grclpl.o differ diff --git a/pgplot_rhel7/grctoi.o b/pgplot_rhel7/grctoi.o new file mode 100644 index 0000000..1166463 Binary files /dev/null and b/pgplot_rhel7/grctoi.o differ diff --git a/pgplot_rhel7/grcurs.o b/pgplot_rhel7/grcurs.o new file mode 100644 index 0000000..5b42440 Binary files /dev/null and b/pgplot_rhel7/grcurs.o differ diff --git a/pgplot_rhel7/grdate.o b/pgplot_rhel7/grdate.o new file mode 100644 index 0000000..c2e05e3 Binary files /dev/null and b/pgplot_rhel7/grdate.o differ diff --git a/pgplot_rhel7/grdot0.o b/pgplot_rhel7/grdot0.o new file mode 100644 index 0000000..f05a9a8 Binary files /dev/null and b/pgplot_rhel7/grdot0.o differ diff --git a/pgplot_rhel7/grdot1.o b/pgplot_rhel7/grdot1.o new file mode 100644 index 0000000..dacebbe Binary files /dev/null and b/pgplot_rhel7/grdot1.o differ diff --git a/pgplot_rhel7/grdtyp.o b/pgplot_rhel7/grdtyp.o new file mode 100644 index 0000000..7802fa8 Binary files /dev/null and b/pgplot_rhel7/grdtyp.o differ diff --git a/pgplot_rhel7/grepic.o b/pgplot_rhel7/grepic.o new file mode 100644 index 0000000..ddcb787 Binary files /dev/null and b/pgplot_rhel7/grepic.o differ diff --git a/pgplot_rhel7/gresc.o b/pgplot_rhel7/gresc.o new file mode 100644 index 0000000..a0dc283 Binary files /dev/null and b/pgplot_rhel7/gresc.o differ diff --git a/pgplot_rhel7/gretxt.o b/pgplot_rhel7/gretxt.o new file mode 100644 index 0000000..f8ae125 Binary files /dev/null and b/pgplot_rhel7/gretxt.o differ diff --git a/pgplot_rhel7/grexec.f b/pgplot_rhel7/grexec.f new file mode 100644 index 0000000..9dc8fb1 --- /dev/null +++ b/pgplot_rhel7/grexec.f @@ -0,0 +1,43 @@ +C*GREXEC -- PGPLOT device handler dispatch routine +C+ + SUBROUTINE GREXEC(IDEV,IFUNC,RBUF,NBUF,CHR,LCHR) + INTEGER IDEV, IFUNC, NBUF, LCHR + REAL RBUF(*) + CHARACTER*(*) CHR +C--- + INTEGER NDEV + PARAMETER (NDEV=10) + CHARACTER*10 MSG +C--- + GOTO(1,2,3,4,5,6,7,8,9,10) IDEV + IF (IDEV.EQ.0) THEN + RBUF(1) = NDEV + NBUF = 1 + ELSE + WRITE (MSG,'(I10)') IDEV + CALL GRWARN('Unknown device code in GREXEC: '//MSG) + END IF + RETURN +C--- +1 CALL GIDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1) + RETURN +2 CALL GIDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2) + RETURN +3 CALL NUDRIV(IFUNC,RBUF,NBUF,CHR,LCHR) + RETURN +4 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1) + RETURN +5 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2) + RETURN +6 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,3) + RETURN +7 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,4) + RETURN +8 CALL TTDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,5) + RETURN +9 CALL XWDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1) + RETURN +10 CALL XWDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2) + RETURN +C + END diff --git a/pgplot_rhel7/grexec.o b/pgplot_rhel7/grexec.o new file mode 100644 index 0000000..cc290ee Binary files /dev/null and b/pgplot_rhel7/grexec.o differ diff --git a/pgplot_rhel7/grfa.o b/pgplot_rhel7/grfa.o new file mode 100644 index 0000000..6fdc742 Binary files /dev/null and b/pgplot_rhel7/grfa.o differ diff --git a/pgplot_rhel7/grfao.o b/pgplot_rhel7/grfao.o new file mode 100644 index 0000000..7a9b66e Binary files /dev/null and b/pgplot_rhel7/grfao.o differ diff --git a/pgplot_rhel7/grfileio.o b/pgplot_rhel7/grfileio.o new file mode 100644 index 0000000..bb7f2ac Binary files /dev/null and b/pgplot_rhel7/grfileio.o differ diff --git a/pgplot_rhel7/grflun.o b/pgplot_rhel7/grflun.o new file mode 100644 index 0000000..3647de5 Binary files /dev/null and b/pgplot_rhel7/grflun.o differ diff --git a/pgplot_rhel7/grfont.dat b/pgplot_rhel7/grfont.dat new file mode 100644 index 0000000..acde914 Binary files /dev/null and b/pgplot_rhel7/grfont.dat differ diff --git a/pgplot_rhel7/grgcom.o b/pgplot_rhel7/grgcom.o new file mode 100644 index 0000000..9126507 Binary files /dev/null and b/pgplot_rhel7/grgcom.o differ diff --git a/pgplot_rhel7/grgenv.o b/pgplot_rhel7/grgenv.o new file mode 100644 index 0000000..a079f35 Binary files /dev/null and b/pgplot_rhel7/grgenv.o differ diff --git a/pgplot_rhel7/grgetc.o b/pgplot_rhel7/grgetc.o new file mode 100644 index 0000000..1f14947 Binary files /dev/null and b/pgplot_rhel7/grgetc.o differ diff --git a/pgplot_rhel7/grgfil.o b/pgplot_rhel7/grgfil.o new file mode 100644 index 0000000..a9b201e Binary files /dev/null and b/pgplot_rhel7/grgfil.o differ diff --git a/pgplot_rhel7/grglun.o b/pgplot_rhel7/grglun.o new file mode 100644 index 0000000..d4aac4a Binary files /dev/null and b/pgplot_rhel7/grglun.o differ diff --git a/pgplot_rhel7/grgmem.o b/pgplot_rhel7/grgmem.o new file mode 100644 index 0000000..37b016f Binary files /dev/null and b/pgplot_rhel7/grgmem.o differ diff --git a/pgplot_rhel7/grgmsg.o b/pgplot_rhel7/grgmsg.o new file mode 100644 index 0000000..fb15525 Binary files /dev/null and b/pgplot_rhel7/grgmsg.o differ diff --git a/pgplot_rhel7/grgray.o b/pgplot_rhel7/grgray.o new file mode 100644 index 0000000..7588dbb Binary files /dev/null and b/pgplot_rhel7/grgray.o differ diff --git a/pgplot_rhel7/grimg0.o b/pgplot_rhel7/grimg0.o new file mode 100644 index 0000000..02820d9 Binary files /dev/null and b/pgplot_rhel7/grimg0.o differ diff --git a/pgplot_rhel7/grimg1.o b/pgplot_rhel7/grimg1.o new file mode 100644 index 0000000..14111ec Binary files /dev/null and b/pgplot_rhel7/grimg1.o differ diff --git a/pgplot_rhel7/grimg2.o b/pgplot_rhel7/grimg2.o new file mode 100644 index 0000000..7c85b3a Binary files /dev/null and b/pgplot_rhel7/grimg2.o differ diff --git a/pgplot_rhel7/grimg3.o b/pgplot_rhel7/grimg3.o new file mode 100644 index 0000000..ab552f7 Binary files /dev/null and b/pgplot_rhel7/grimg3.o differ diff --git a/pgplot_rhel7/grinit.o b/pgplot_rhel7/grinit.o new file mode 100644 index 0000000..e0f3732 Binary files /dev/null and b/pgplot_rhel7/grinit.o differ diff --git a/pgplot_rhel7/gritoc.o b/pgplot_rhel7/gritoc.o new file mode 100644 index 0000000..86282d0 Binary files /dev/null and b/pgplot_rhel7/gritoc.o differ diff --git a/pgplot_rhel7/grlen.o b/pgplot_rhel7/grlen.o new file mode 100644 index 0000000..8229648 Binary files /dev/null and b/pgplot_rhel7/grlen.o differ diff --git a/pgplot_rhel7/grlgtr.o b/pgplot_rhel7/grlgtr.o new file mode 100644 index 0000000..a6f2826 Binary files /dev/null and b/pgplot_rhel7/grlgtr.o differ diff --git a/pgplot_rhel7/grlin0.o b/pgplot_rhel7/grlin0.o new file mode 100644 index 0000000..2d2f635 Binary files /dev/null and b/pgplot_rhel7/grlin0.o differ diff --git a/pgplot_rhel7/grlin1.o b/pgplot_rhel7/grlin1.o new file mode 100644 index 0000000..b50d2d2 Binary files /dev/null and b/pgplot_rhel7/grlin1.o differ diff --git a/pgplot_rhel7/grlin2.o b/pgplot_rhel7/grlin2.o new file mode 100644 index 0000000..b122727 Binary files /dev/null and b/pgplot_rhel7/grlin2.o differ diff --git a/pgplot_rhel7/grlin3.o b/pgplot_rhel7/grlin3.o new file mode 100644 index 0000000..754b834 Binary files /dev/null and b/pgplot_rhel7/grlin3.o differ diff --git a/pgplot_rhel7/grlina.o b/pgplot_rhel7/grlina.o new file mode 100644 index 0000000..395de64 Binary files /dev/null and b/pgplot_rhel7/grlina.o differ diff --git a/pgplot_rhel7/grmcur.o b/pgplot_rhel7/grmcur.o new file mode 100644 index 0000000..d418f9e Binary files /dev/null and b/pgplot_rhel7/grmcur.o differ diff --git a/pgplot_rhel7/grmker.o b/pgplot_rhel7/grmker.o new file mode 100644 index 0000000..3f50b35 Binary files /dev/null and b/pgplot_rhel7/grmker.o differ diff --git a/pgplot_rhel7/grmova.o b/pgplot_rhel7/grmova.o new file mode 100644 index 0000000..a0be44e Binary files /dev/null and b/pgplot_rhel7/grmova.o differ diff --git a/pgplot_rhel7/grmsg.o b/pgplot_rhel7/grmsg.o new file mode 100644 index 0000000..afd2a6d Binary files /dev/null and b/pgplot_rhel7/grmsg.o differ diff --git a/pgplot_rhel7/gropen.o b/pgplot_rhel7/gropen.o new file mode 100644 index 0000000..f30d4e5 Binary files /dev/null and b/pgplot_rhel7/gropen.o differ diff --git a/pgplot_rhel7/groptx.o b/pgplot_rhel7/groptx.o new file mode 100644 index 0000000..96efab9 Binary files /dev/null and b/pgplot_rhel7/groptx.o differ diff --git a/pgplot_rhel7/grpage.o b/pgplot_rhel7/grpage.o new file mode 100644 index 0000000..421031a Binary files /dev/null and b/pgplot_rhel7/grpage.o differ diff --git a/pgplot_rhel7/grpars.o b/pgplot_rhel7/grpars.o new file mode 100644 index 0000000..75b5cbb Binary files /dev/null and b/pgplot_rhel7/grpars.o differ diff --git a/pgplot_rhel7/grpckg1.inc b/pgplot_rhel7/grpckg1.inc new file mode 100644 index 0000000..b6a2118 --- /dev/null +++ b/pgplot_rhel7/grpckg1.inc @@ -0,0 +1,98 @@ +C----------------------------------------------------------------------- +C Include file for GRPCKG +C Modifications: +C 29-Jan-1985 - add HP2648 (KS/TJP). +C 16-Sep-1985 - remove tabs (TJP). +C 30-Dec-1985 - add PS, VPS (TJP). +C 27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, +C HP7221, GRINL (TJP). +C 6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). +C 11-Jun-1987 - remove remaining built-in devices (TJP). +C 5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. +C 16-Aug-1987 - remove obsolete variables. +C 9-Sep-1989 - add SAVE statement. +C 26-Nov-1990 - remove GRCTYP. +C 5-Jan-1993 - add GRADJU. +C 1-Sep-1994 - add GRGCAP. +C 21-Dec-1995 - increase GRIMAX to 8. +C 30-Apr-1997 - remove GRC{XY}SP +C----------------------------------------------------------------------- +C +C Parameters: +C GRIMAX : maximum number of concurrent devices +C GRFNMX : maximum length of file names +C GRCXSZ : default width of chars (pixels) +C GRCYSZ : default height of chars (pixels) +C + INTEGER GRIMAX, GRFNMX + REAL GRCXSZ, GRCYSZ + PARAMETER (GRIMAX = 8) + PARAMETER (GRFNMX = 90) + PARAMETER (GRCXSZ = 7.0, GRCYSZ = 9.0) +C +C Common blocks: +C GRCIDE : identifier of current plot +C GRGTYP : device type of current plot +C The following are qualified by a plot id: +C GRSTAT : 0 => workstation closed +C 1 => workstation open +C 2 => picture open +C GRPLTD : +C GRDASH : software dashing in effect? +C GRUNIT : unit associated with id +C GRFNLN : length of filename +C GRTYPE : device type +C GRXMXA : x size of plotting surface +C GRYMXA : y size of plotting surface +C GRXMIN : blc of plotting window +C GRYMIN : ditto +C GRXMAX : trc of plotting window +C GRYMAX : ditto +C GRSTYL : line style (integer code) +C GRWIDT : line width (integer code) +C GRCCOL : current color index (integer code) +C GRMNCI : minimum color index on this device +C GRMXCI : maximum color index on this device +C GRCMRK : marker number +C GRXPRE : previous (current) pen position (x) +C GRYPRE : ditto (y) +C GRXORG : transformation variables (GRTRAN) +C GRYORG : ditto +C GRXSCL : ditto +C GRYSCL : ditto +C GRCSCL : character scaling factor +C GRCFAC : +C GRCFNT : character font +C GRFILE : file name (character) +C GRGCAP : device capabilities (character) +C GRPXPI : pixels per inch in x +C GRPYPI : pixels per inch in y +C GRADJU : TRUE if GRSETS (PGPAP) has been called +C + INTEGER GRCIDE, GRGTYP + LOGICAL GRPLTD(GRIMAX), GRDASH(GRIMAX), GRADJU(GRIMAX) + INTEGER GRSTAT(GRIMAX) + INTEGER GRUNIT(GRIMAX), GRFNLN(GRIMAX), GRTYPE(GRIMAX), + 1 GRXMXA(GRIMAX), GRYMXA(GRIMAX), + 2 GRSTYL(GRIMAX), GRWIDT(GRIMAX), GRCCOL(GRIMAX), + 3 GRCMRK(GRIMAX), GRIPAT(GRIMAX), GRCFNT(GRIMAX), + 4 GRMNCI(GRIMAX), GRMXCI(GRIMAX) + REAL GRXMIN(GRIMAX), GRYMIN(GRIMAX), + 1 GRXMAX(GRIMAX), GRYMAX(GRIMAX) + REAL GRXPRE(GRIMAX), GRYPRE(GRIMAX), GRXORG(GRIMAX), + 1 GRYORG(GRIMAX), GRXSCL(GRIMAX), GRYSCL(GRIMAX), + 2 GRCSCL(GRIMAX), GRCFAC(GRIMAX), GRPOFF(GRIMAX), + 3 GRPATN(GRIMAX,8),GRPXPI(GRIMAX),GRPYPI(GRIMAX) + COMMON /GRCM00/ GRCIDE, GRGTYP, GRSTAT, GRPLTD, GRUNIT, + 1 GRFNLN, GRTYPE, GRXMXA, GRYMXA, GRXMIN, GRYMIN, + 2 GRXMAX, GRYMAX, GRWIDT, GRCCOL, GRSTYL, + 3 GRXPRE, GRYPRE, GRXORG, GRYORG, GRXSCL, GRYSCL, + 4 GRCSCL, GRCFAC, GRDASH, GRPATN, GRPOFF, + 5 GRIPAT, GRCFNT, GRCMRK, GRPXPI, GRPYPI, GRADJU, + 6 GRMNCI, GRMXCI +C + CHARACTER*(GRFNMX) GRFILE(GRIMAX) + CHARACTER*11 GRGCAP(GRIMAX) + COMMON /GRCM01/ GRFILE, GRGCAP + SAVE /GRCM00/, /GRCM01/ +C----------------------------------------------------------------------- diff --git a/pgplot_rhel7/grpixl.o b/pgplot_rhel7/grpixl.o new file mode 100644 index 0000000..6287fd1 Binary files /dev/null and b/pgplot_rhel7/grpixl.o differ diff --git a/pgplot_rhel7/grpocl.o b/pgplot_rhel7/grpocl.o new file mode 100644 index 0000000..a93bffc Binary files /dev/null and b/pgplot_rhel7/grpocl.o differ diff --git a/pgplot_rhel7/grprom.o b/pgplot_rhel7/grprom.o new file mode 100644 index 0000000..e276653 Binary files /dev/null and b/pgplot_rhel7/grprom.o differ diff --git a/pgplot_rhel7/grpxpo.o b/pgplot_rhel7/grpxpo.o new file mode 100644 index 0000000..31825ac Binary files /dev/null and b/pgplot_rhel7/grpxpo.o differ diff --git a/pgplot_rhel7/grpxps.o b/pgplot_rhel7/grpxps.o new file mode 100644 index 0000000..bb883fe Binary files /dev/null and b/pgplot_rhel7/grpxps.o differ diff --git a/pgplot_rhel7/grpxpx.o b/pgplot_rhel7/grpxpx.o new file mode 100644 index 0000000..9759fc5 Binary files /dev/null and b/pgplot_rhel7/grpxpx.o differ diff --git a/pgplot_rhel7/grpxre.o b/pgplot_rhel7/grpxre.o new file mode 100644 index 0000000..1f35b7d Binary files /dev/null and b/pgplot_rhel7/grpxre.o differ diff --git a/pgplot_rhel7/grqcap.o b/pgplot_rhel7/grqcap.o new file mode 100644 index 0000000..eb4e5d9 Binary files /dev/null and b/pgplot_rhel7/grqcap.o differ diff --git a/pgplot_rhel7/grqci.o b/pgplot_rhel7/grqci.o new file mode 100644 index 0000000..1b0176c Binary files /dev/null and b/pgplot_rhel7/grqci.o differ diff --git a/pgplot_rhel7/grqcol.o b/pgplot_rhel7/grqcol.o new file mode 100644 index 0000000..90cb838 Binary files /dev/null and b/pgplot_rhel7/grqcol.o differ diff --git a/pgplot_rhel7/grqcr.o b/pgplot_rhel7/grqcr.o new file mode 100644 index 0000000..a61b28a Binary files /dev/null and b/pgplot_rhel7/grqcr.o differ diff --git a/pgplot_rhel7/grqdev.o b/pgplot_rhel7/grqdev.o new file mode 100644 index 0000000..9964c2c Binary files /dev/null and b/pgplot_rhel7/grqdev.o differ diff --git a/pgplot_rhel7/grqdt.o b/pgplot_rhel7/grqdt.o new file mode 100644 index 0000000..2409d91 Binary files /dev/null and b/pgplot_rhel7/grqdt.o differ diff --git a/pgplot_rhel7/grqfnt.o b/pgplot_rhel7/grqfnt.o new file mode 100644 index 0000000..9373687 Binary files /dev/null and b/pgplot_rhel7/grqfnt.o differ diff --git a/pgplot_rhel7/grqls.o b/pgplot_rhel7/grqls.o new file mode 100644 index 0000000..51f4daf Binary files /dev/null and b/pgplot_rhel7/grqls.o differ diff --git a/pgplot_rhel7/grqlw.o b/pgplot_rhel7/grqlw.o new file mode 100644 index 0000000..dc00a88 Binary files /dev/null and b/pgplot_rhel7/grqlw.o differ diff --git a/pgplot_rhel7/grqpos.o b/pgplot_rhel7/grqpos.o new file mode 100644 index 0000000..d5d22c2 Binary files /dev/null and b/pgplot_rhel7/grqpos.o differ diff --git a/pgplot_rhel7/grqtxt.o b/pgplot_rhel7/grqtxt.o new file mode 100644 index 0000000..30e72eb Binary files /dev/null and b/pgplot_rhel7/grqtxt.o differ diff --git a/pgplot_rhel7/grqtyp.o b/pgplot_rhel7/grqtyp.o new file mode 100644 index 0000000..8b3a860 Binary files /dev/null and b/pgplot_rhel7/grqtyp.o differ diff --git a/pgplot_rhel7/grquit.o b/pgplot_rhel7/grquit.o new file mode 100644 index 0000000..a1d3f89 Binary files /dev/null and b/pgplot_rhel7/grquit.o differ diff --git a/pgplot_rhel7/grrec0.o b/pgplot_rhel7/grrec0.o new file mode 100644 index 0000000..d267816 Binary files /dev/null and b/pgplot_rhel7/grrec0.o differ diff --git a/pgplot_rhel7/grrect.o b/pgplot_rhel7/grrect.o new file mode 100644 index 0000000..a4987a3 Binary files /dev/null and b/pgplot_rhel7/grrect.o differ diff --git a/pgplot_rhel7/grsci.o b/pgplot_rhel7/grsci.o new file mode 100644 index 0000000..c57999f Binary files /dev/null and b/pgplot_rhel7/grsci.o differ diff --git a/pgplot_rhel7/grscr.o b/pgplot_rhel7/grscr.o new file mode 100644 index 0000000..19faeb8 Binary files /dev/null and b/pgplot_rhel7/grscr.o differ diff --git a/pgplot_rhel7/grscrl.o b/pgplot_rhel7/grscrl.o new file mode 100644 index 0000000..82892a7 Binary files /dev/null and b/pgplot_rhel7/grscrl.o differ diff --git a/pgplot_rhel7/grsetc.o b/pgplot_rhel7/grsetc.o new file mode 100644 index 0000000..a47a54c Binary files /dev/null and b/pgplot_rhel7/grsetc.o differ diff --git a/pgplot_rhel7/grsets.o b/pgplot_rhel7/grsets.o new file mode 100644 index 0000000..2ab5681 Binary files /dev/null and b/pgplot_rhel7/grsets.o differ diff --git a/pgplot_rhel7/grsfnt.o b/pgplot_rhel7/grsfnt.o new file mode 100644 index 0000000..deb30b6 Binary files /dev/null and b/pgplot_rhel7/grsfnt.o differ diff --git a/pgplot_rhel7/grsize.o b/pgplot_rhel7/grsize.o new file mode 100644 index 0000000..6ac606d Binary files /dev/null and b/pgplot_rhel7/grsize.o differ diff --git a/pgplot_rhel7/grskpb.o b/pgplot_rhel7/grskpb.o new file mode 100644 index 0000000..cb0433a Binary files /dev/null and b/pgplot_rhel7/grskpb.o differ diff --git a/pgplot_rhel7/grslct.o b/pgplot_rhel7/grslct.o new file mode 100644 index 0000000..67bf4a2 Binary files /dev/null and b/pgplot_rhel7/grslct.o differ diff --git a/pgplot_rhel7/grsls.o b/pgplot_rhel7/grsls.o new file mode 100644 index 0000000..fa412d9 Binary files /dev/null and b/pgplot_rhel7/grsls.o differ diff --git a/pgplot_rhel7/grslw.o b/pgplot_rhel7/grslw.o new file mode 100644 index 0000000..a04cac2 Binary files /dev/null and b/pgplot_rhel7/grslw.o differ diff --git a/pgplot_rhel7/grsy00.o b/pgplot_rhel7/grsy00.o new file mode 100644 index 0000000..bfeeaf1 Binary files /dev/null and b/pgplot_rhel7/grsy00.o differ diff --git a/pgplot_rhel7/grsyds.o b/pgplot_rhel7/grsyds.o new file mode 100644 index 0000000..1bfa521 Binary files /dev/null and b/pgplot_rhel7/grsyds.o differ diff --git a/pgplot_rhel7/grsymk.o b/pgplot_rhel7/grsymk.o new file mode 100644 index 0000000..882a7e7 Binary files /dev/null and b/pgplot_rhel7/grsymk.o differ diff --git a/pgplot_rhel7/grsyxd.o b/pgplot_rhel7/grsyxd.o new file mode 100644 index 0000000..b790691 Binary files /dev/null and b/pgplot_rhel7/grsyxd.o differ diff --git a/pgplot_rhel7/grterm.o b/pgplot_rhel7/grterm.o new file mode 100644 index 0000000..6d1c7da Binary files /dev/null and b/pgplot_rhel7/grterm.o differ diff --git a/pgplot_rhel7/grtermio.o b/pgplot_rhel7/grtermio.o new file mode 100644 index 0000000..d365358 Binary files /dev/null and b/pgplot_rhel7/grtermio.o differ diff --git a/pgplot_rhel7/grtext.o b/pgplot_rhel7/grtext.o new file mode 100644 index 0000000..90c8898 Binary files /dev/null and b/pgplot_rhel7/grtext.o differ diff --git a/pgplot_rhel7/grtoup.o b/pgplot_rhel7/grtoup.o new file mode 100644 index 0000000..70c31e0 Binary files /dev/null and b/pgplot_rhel7/grtoup.o differ diff --git a/pgplot_rhel7/grtrim.o b/pgplot_rhel7/grtrim.o new file mode 100644 index 0000000..90bef23 Binary files /dev/null and b/pgplot_rhel7/grtrim.o differ diff --git a/pgplot_rhel7/grtrml.o b/pgplot_rhel7/grtrml.o new file mode 100644 index 0000000..f831822 Binary files /dev/null and b/pgplot_rhel7/grtrml.o differ diff --git a/pgplot_rhel7/grtrn0.o b/pgplot_rhel7/grtrn0.o new file mode 100644 index 0000000..9b3c567 Binary files /dev/null and b/pgplot_rhel7/grtrn0.o differ diff --git a/pgplot_rhel7/grtter.o b/pgplot_rhel7/grtter.o new file mode 100644 index 0000000..4c990ff Binary files /dev/null and b/pgplot_rhel7/grtter.o differ diff --git a/pgplot_rhel7/grtxy0.o b/pgplot_rhel7/grtxy0.o new file mode 100644 index 0000000..e409f99 Binary files /dev/null and b/pgplot_rhel7/grtxy0.o differ diff --git a/pgplot_rhel7/gruser.o b/pgplot_rhel7/gruser.o new file mode 100644 index 0000000..d502f37 Binary files /dev/null and b/pgplot_rhel7/gruser.o differ diff --git a/pgplot_rhel7/grvct0.o b/pgplot_rhel7/grvct0.o new file mode 100644 index 0000000..1915b4b Binary files /dev/null and b/pgplot_rhel7/grvct0.o differ diff --git a/pgplot_rhel7/grwarn.o b/pgplot_rhel7/grwarn.o new file mode 100644 index 0000000..df7046c Binary files /dev/null and b/pgplot_rhel7/grwarn.o differ diff --git a/pgplot_rhel7/grxhls.o b/pgplot_rhel7/grxhls.o new file mode 100644 index 0000000..439185f Binary files /dev/null and b/pgplot_rhel7/grxhls.o differ diff --git a/pgplot_rhel7/grxrgb.o b/pgplot_rhel7/grxrgb.o new file mode 100644 index 0000000..be26148 Binary files /dev/null and b/pgplot_rhel7/grxrgb.o differ diff --git a/pgplot_rhel7/libpgplot.a b/pgplot_rhel7/libpgplot.a new file mode 100644 index 0000000..67c6e2b Binary files /dev/null and b/pgplot_rhel7/libpgplot.a differ diff --git a/pgplot_rhel7/libpgplot.so b/pgplot_rhel7/libpgplot.so new file mode 100755 index 0000000..fe54f55 Binary files /dev/null and b/pgplot_rhel7/libpgplot.so differ diff --git a/pgplot_rhel7/makefile b/pgplot_rhel7/makefile new file mode 100644 index 0000000..c765335 --- /dev/null +++ b/pgplot_rhel7/makefile @@ -0,0 +1,932 @@ +# Makefile for PGPLOT. +# /afs/psi.ch/project/sinq/common/src/pgplot5.2.2/makemake /afs/psi.ch/project/sinq/common/src/pgplot5.2.2 linux gfortran_gcc +# This file is automatically generated. Do not edit. +# +# This generates the PGPLOT binary files (libraries and demos) in the +# current default directory (which need not be the source directory). +#----------------------------------------------------------------------- +SHELL=/bin/sh +# PGPLOT subdirectories +SRC=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2 +SRCDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/src +OBSDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/obssrc +DEMDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/examples +FNTDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/fonts +DRVDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/drivers +SYSDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/sys_linux +PGDDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/pgdispd +GENDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/sys +XMDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/drivers/xmotif +XADIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/drivers/xathena +TKDIR=/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/drivers/xtk +# +# Fortran compiler and compilation flags +# +FCOMPL=gfortran +FFLAGC=-g -ffixed-form -ffixed-line-length-none -u -Wall -fPIC -O +FFLAGD=-fno-backslash +# +# C compiler and compilation flags +# +XINCL=-I/usr/X11R6/include +MOTIF_INCL=-I/usr/X11R6/include +ATHENA_INCL=-I/usr/X11R6/include +TK_INCL=-I/usr/include -I/usr/X11R6/include +RV_INCL= +CCOMPL=gcc +CFLAGC=-Wall -fPIC -DPG_PPU -O -I. +CFLAGD=-Wall -O +MCOMPL= +MFLAGC= +# +# Pgbind flags. +# +PGBIND_FLAGS=bsd +# +# Loader library-flags +# +LIBS=-L/usr/X11R6/lib -lX11 +MOTIF_LIBS=-lXm -lXt -L/usr/X11R6/lib -lX11 +ATHENA_LIBS=-lXaw -lXt -lXmu -lXext -L/usr/X11R6/lib -lX11 +TK_LIBS=-L/usr/lib -ltk -ltcl -L/usr/X11R6/lib -lX11 -ldl +# +# Loader command for PGPLOT library +# +PGPLOT_LIB=-L`pwd` -lpgplot +CPGPLOT_LIB=-L`pwd` -lcpgplot -lpgplot +# +# Shared library creation. +# +SHARED_LIB=libpgplot.so +SHARED_LD=gcc -shared -o libpgplot.so +# +# The libraries that the shared PGPLOT library depends upon. +# This is for systems that allow one to specify what libraries +# undefined symbols of a shared library reside in. Such systems +# (eg. Solaris 2.x) use this information at run time so that users of +# the library don't have to list a slew of other implementation-specific +# libraries when they link their executables. +# +SHARED_LIB_LIBS= +# +# Ranlib command if required +# +RANLIB=ranlib +# +# Routine lists. +# +PG_ROUTINES= pgarro.o pgask.o pgaxis.o pgaxlg.o pgband.o pgbbuf.o pgbeg.o pgbin.o pgbox.o pgbox1.o pgcirc.o pgcl.o pgclos.o pgcn01.o pgcnsc.o pgconb.o pgconf.o pgconl.o pgcons.o pgcont.o pgconx.o pgcp.o pgctab.o pgcurs.o pgdraw.o pgebuf.o pgend.o pgenv.o pgeras.o pgerr1.o pgerrb.o pgerrx.o pgerry.o pgetxt.o pgfunt.o pgfunx.o pgfuny.o pggray.o pghi2d.o pghis1.o pghist.o pghtch.o pgiden.o pgimag.o pginit.o pglab.o pglcur.o pgldev.o pglen.o pgline.o pgmove.o pgmtxt.o pgncur.o pgnoto.o pgnpl.o pgnumb.o pgolin.o pgopen.o pgpage.o pgpanl.o pgpap.o pgpixl.o pgpnts.o pgpoly.o pgpt.o pgpt1.o pgptxt.o pgqah.o pgqcf.o pgqch.o pgqci.o pgqcir.o pgqclp.o pgqcol.o pgqcr.o pgqcs.o pgqdt.o pgqfs.o pgqhs.o pgqid.o pgqinf.o pgqitf.o pgqls.o pgqlw.o pgqndt.o pgqpos.o pgqtbg.o pgqtxt.o pgqvp.o pgqvsz.o pgqwin.o pgrect.o pgrnd.o pgrnge.o pgsah.o pgsave.o pgscf.o pgsch.o pgsci.o pgscir.o pgsclp.o pgscr.o pgscrl.o pgscrn.o pgsfs.o pgshls.o pgshs.o pgsitf.o pgslct.o pgsls.o pgslw.o pgstbg.o pgsubp.o pgsvp.o pgswin.o pgtbox.o pgtext.o pgtick.o pgtikl.o pgupdt.o pgvect.o pgvsiz.o pgvstd.o pgvw.o pgwedg.o pgwnad.o +PG_NON_STANDARD= pgadvance.o pgbegin.o pgcurse.o pglabel.o pgmtext.o pgncurse.o pgpaper.o pgpoint.o pgptext.o pgvport.o pgvsize.o pgvstand.o pgwindow.o +GR_ROUTINES= grarea.o grbpic.o grchsz.o grclip.o grclos.o grclpl.o grctoi.o grcurs.o grdot0.o grdot1.o grdtyp.o gresc.o grepic.o gretxt.o grfa.o grfao.o grgfil.o grgray.o grimg0.o grimg1.o grimg2.o grimg3.o grinit.o gritoc.o grlen.o grlin0.o grlin1.o grlin2.o grlin3.o grlina.o grmcur.o grmker.o grmova.o grmsg.o gropen.o grpage.o grpars.o grpixl.o grpocl.o grprom.o grpxpo.o grpxps.o grpxpx.o grpxre.o grqcap.o grqci.o grqcol.o grqcr.o grqdev.o grqdt.o grqfnt.o grqls.o grqlw.o grqpos.o grqtxt.o grqtyp.o grquit.o grrec0.o grrect.o grsci.o grscr.o grscrl.o grsetc.o grsets.o grsfnt.o grsize.o grskpb.o grslct.o grsls.o grslw.o grsyds.o grsymk.o grsyxd.o grterm.o grtext.o grtoup.o grtrim.o grtrn0.o grtxy0.o grvct0.o grwarn.o grxhls.o grxrgb.o +SYSTEM_ROUTINES= grdate.o grfileio.o grflun.o grgcom.o grgenv.o grgetc.o grglun.o grgmem.o grgmsg.o grlgtr.o groptx.o grsy00.o grtermio.o grtrml.o grtter.o gruser.o +OBSOLETE_ROUTINES= grchar.o grchr0.o grdat2.o grgtc0.o grinqfont.o grinqli.o grinqpen.o grlinr.o grmark.o grmovr.o grsetfont.o grsetli.o grsetpen.o grtran.o grvect.o pgsetc.o pgsize.o +DRIVERS=gidriv.o nudriv.o psdriv.o ttdriv.o xwdriv.o +PGDISP_ROUTINES= cleanup.o pgdisp.o figcurs.o getdata.o getvisuals.o handlexevent.o proccom.o resdb.o exposelgwin.o getcolors.o initlgluts.o initlgwin.o initlock.o initwmattr.o mainloop.o resizelgwin.o returnbuf.o waitevent.o updatelgtitle.o +DEMOS= pgdemo1 pgdemo2 pgdemo3 pgdemo4 pgdemo5 pgdemo6 pgdemo7 pgdemo8 pgdemo9 pgdemo10 pgdemo11 pgdemo12 pgdemo13 pgdemo14 pgdemo15 pgdemo16 pgdemo17 +# +#----------------------------------------------------------------------- +# Target "all" makes everything (except the library of obsolete routines) +#----------------------------------------------------------------------- +all: lib grfont.dat prog pgplot.doc pgxwin_server + @echo ' ';echo '*** Finished compilation of PGPLOT ***';echo ' ' + @echo 'Note that if you plan to install PGPLOT in a different' + @echo 'directory than the current one, the following files will be' + @echo 'needed.' + @echo ' ' + @echo ' libpgplot.a' + @echo ' libpgplot.so' + @echo ' grfont.dat' + @echo ' rgb.txt' + @echo ' pgxwin_server' + @echo ' ' + @echo 'Also note that subsequent usage of PGPLOT programs requires that' + @echo 'the full path of the chosen installation directory be named in' + @echo 'an environment variable named PGPLOT_DIR.' + @echo ' ' + +#----------------------------------------------------------------------- +# Rules for compiling the .o files +#----------------------------------------------------------------------- +pgarro.o: $(SRCDIR)/pgarro.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgarro.f +pgask.o: $(SRCDIR)/pgask.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgask.f +pgaxis.o: $(SRCDIR)/pgaxis.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgaxis.f +pgaxlg.o: $(SRCDIR)/pgaxlg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgaxlg.f +pgband.o: $(SRCDIR)/pgband.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgband.f +pgbbuf.o: $(SRCDIR)/pgbbuf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbbuf.f +pgbeg.o: $(SRCDIR)/pgbeg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbeg.f +pgbin.o: $(SRCDIR)/pgbin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbin.f +pgbox.o: $(SRCDIR)/pgbox.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbox.f +pgbox1.o: $(SRCDIR)/pgbox1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbox1.f +pgcirc.o: $(SRCDIR)/pgcirc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcirc.f +pgcl.o: $(SRCDIR)/pgcl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcl.f +pgclos.o: $(SRCDIR)/pgclos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgclos.f +pgcn01.o: $(SRCDIR)/pgcn01.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcn01.f +pgcnsc.o: $(SRCDIR)/pgcnsc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcnsc.f +pgconb.o: $(SRCDIR)/pgconb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconb.f +pgconf.o: $(SRCDIR)/pgconf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconf.f +pgconl.o: $(SRCDIR)/pgconl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconl.f +pgcons.o: $(SRCDIR)/pgcons.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcons.f +pgcont.o: $(SRCDIR)/pgcont.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcont.f +pgconx.o: $(SRCDIR)/pgconx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconx.f +pgcp.o: $(SRCDIR)/pgcp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcp.f +pgctab.o: $(SRCDIR)/pgctab.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgctab.f +pgcurs.o: $(SRCDIR)/pgcurs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcurs.f +pgdraw.o: $(SRCDIR)/pgdraw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgdraw.f +pgebuf.o: $(SRCDIR)/pgebuf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgebuf.f +pgend.o: $(SRCDIR)/pgend.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgend.f +pgenv.o: $(SRCDIR)/pgenv.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgenv.f +pgeras.o: $(SRCDIR)/pgeras.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgeras.f +pgerr1.o: $(SRCDIR)/pgerr1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerr1.f +pgerrb.o: $(SRCDIR)/pgerrb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerrb.f +pgerrx.o: $(SRCDIR)/pgerrx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerrx.f +pgerry.o: $(SRCDIR)/pgerry.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerry.f +pgetxt.o: $(SRCDIR)/pgetxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgetxt.f +pgfunt.o: $(SRCDIR)/pgfunt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgfunt.f +pgfunx.o: $(SRCDIR)/pgfunx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgfunx.f +pgfuny.o: $(SRCDIR)/pgfuny.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgfuny.f +pggray.o: $(SRCDIR)/pggray.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pggray.f +pghi2d.o: $(SRCDIR)/pghi2d.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghi2d.f +pghis1.o: $(SRCDIR)/pghis1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghis1.f +pghist.o: $(SRCDIR)/pghist.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghist.f +pghtch.o: $(SRCDIR)/pghtch.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghtch.f +pgiden.o: $(SRCDIR)/pgiden.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgiden.f +pgimag.o: $(SRCDIR)/pgimag.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgimag.f +pginit.o: $(SRCDIR)/pginit.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pginit.f +pglab.o: $(SRCDIR)/pglab.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglab.f +pglcur.o: $(SRCDIR)/pglcur.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglcur.f +pgldev.o: $(SRCDIR)/pgldev.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgldev.f +pglen.o: $(SRCDIR)/pglen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglen.f +pgline.o: $(SRCDIR)/pgline.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgline.f +pgmove.o: $(SRCDIR)/pgmove.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgmove.f +pgmtxt.o: $(SRCDIR)/pgmtxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgmtxt.f +pgncur.o: $(SRCDIR)/pgncur.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgncur.f +pgnoto.o: $(SRCDIR)/pgnoto.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgnoto.f +pgnpl.o: $(SRCDIR)/pgnpl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgnpl.f +pgnumb.o: $(SRCDIR)/pgnumb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgnumb.f +pgolin.o: $(SRCDIR)/pgolin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgolin.f +pgopen.o: $(SRCDIR)/pgopen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgopen.f +pgpage.o: $(SRCDIR)/pgpage.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpage.f +pgpanl.o: $(SRCDIR)/pgpanl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpanl.f +pgpap.o: $(SRCDIR)/pgpap.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpap.f +pgpixl.o: $(SRCDIR)/pgpixl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpixl.f +pgpnts.o: $(SRCDIR)/pgpnts.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpnts.f +pgpoly.o: $(SRCDIR)/pgpoly.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpoly.f +pgpt.o: $(SRCDIR)/pgpt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpt.f +pgpt1.o: $(SRCDIR)/pgpt1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpt1.f +pgptxt.o: $(SRCDIR)/pgptxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgptxt.f +pgqah.o: $(SRCDIR)/pgqah.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqah.f +pgqcf.o: $(SRCDIR)/pgqcf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcf.f +pgqch.o: $(SRCDIR)/pgqch.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqch.f +pgqci.o: $(SRCDIR)/pgqci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqci.f +pgqcir.o: $(SRCDIR)/pgqcir.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcir.f +pgqclp.o: $(SRCDIR)/pgqclp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqclp.f +pgqcol.o: $(SRCDIR)/pgqcol.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcol.f +pgqcr.o: $(SRCDIR)/pgqcr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcr.f +pgqcs.o: $(SRCDIR)/pgqcs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcs.f +pgqdt.o: $(SRCDIR)/pgqdt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqdt.f +pgqfs.o: $(SRCDIR)/pgqfs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqfs.f +pgqhs.o: $(SRCDIR)/pgqhs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqhs.f +pgqid.o: $(SRCDIR)/pgqid.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqid.f +pgqinf.o: $(SRCDIR)/pgqinf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqinf.f +pgqitf.o: $(SRCDIR)/pgqitf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqitf.f +pgqls.o: $(SRCDIR)/pgqls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqls.f +pgqlw.o: $(SRCDIR)/pgqlw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqlw.f +pgqndt.o: $(SRCDIR)/pgqndt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqndt.f +pgqpos.o: $(SRCDIR)/pgqpos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqpos.f +pgqtbg.o: $(SRCDIR)/pgqtbg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqtbg.f +pgqtxt.o: $(SRCDIR)/pgqtxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqtxt.f +pgqvp.o: $(SRCDIR)/pgqvp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqvp.f +pgqvsz.o: $(SRCDIR)/pgqvsz.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqvsz.f +pgqwin.o: $(SRCDIR)/pgqwin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqwin.f +pgrect.o: $(SRCDIR)/pgrect.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgrect.f +pgrnd.o: $(SRCDIR)/pgrnd.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgrnd.f +pgrnge.o: $(SRCDIR)/pgrnge.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgrnge.f +pgsah.o: $(SRCDIR)/pgsah.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsah.f +pgsave.o: $(SRCDIR)/pgsave.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsave.f +pgscf.o: $(SRCDIR)/pgscf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscf.f +pgsch.o: $(SRCDIR)/pgsch.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsch.f +pgsci.o: $(SRCDIR)/pgsci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsci.f +pgscir.o: $(SRCDIR)/pgscir.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscir.f +pgsclp.o: $(SRCDIR)/pgsclp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsclp.f +pgscr.o: $(SRCDIR)/pgscr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscr.f +pgscrl.o: $(SRCDIR)/pgscrl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscrl.f +pgscrn.o: $(SRCDIR)/pgscrn.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscrn.f +pgsfs.o: $(SRCDIR)/pgsfs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsfs.f +pgshls.o: $(SRCDIR)/pgshls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgshls.f +pgshs.o: $(SRCDIR)/pgshs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgshs.f +pgsitf.o: $(SRCDIR)/pgsitf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsitf.f +pgslct.o: $(SRCDIR)/pgslct.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgslct.f +pgsls.o: $(SRCDIR)/pgsls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsls.f +pgslw.o: $(SRCDIR)/pgslw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgslw.f +pgstbg.o: $(SRCDIR)/pgstbg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgstbg.f +pgsubp.o: $(SRCDIR)/pgsubp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsubp.f +pgsvp.o: $(SRCDIR)/pgsvp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsvp.f +pgswin.o: $(SRCDIR)/pgswin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgswin.f +pgtbox.o: $(SRCDIR)/pgtbox.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtbox.f +pgtext.o: $(SRCDIR)/pgtext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtext.f +pgtick.o: $(SRCDIR)/pgtick.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtick.f +pgtikl.o: $(SRCDIR)/pgtikl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtikl.f +pgupdt.o: $(SRCDIR)/pgupdt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgupdt.f +pgvect.o: $(SRCDIR)/pgvect.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvect.f +pgvsiz.o: $(SRCDIR)/pgvsiz.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvsiz.f +pgvstd.o: $(SRCDIR)/pgvstd.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvstd.f +pgvw.o: $(SRCDIR)/pgvw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvw.f +pgwedg.o: $(SRCDIR)/pgwedg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgwedg.f +pgwnad.o: $(SRCDIR)/pgwnad.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgwnad.f +pgadvance.o: $(SRCDIR)/pgadvance.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgadvance.f +pgbegin.o: $(SRCDIR)/pgbegin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbegin.f +pgcurse.o: $(SRCDIR)/pgcurse.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcurse.f +pglabel.o: $(SRCDIR)/pglabel.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglabel.f +pgmtext.o: $(SRCDIR)/pgmtext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgmtext.f +pgncurse.o: $(SRCDIR)/pgncurse.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgncurse.f +pgpaper.o: $(SRCDIR)/pgpaper.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpaper.f +pgpoint.o: $(SRCDIR)/pgpoint.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpoint.f +pgptext.o: $(SRCDIR)/pgptext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgptext.f +pgvport.o: $(SRCDIR)/pgvport.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvport.f +pgvsize.o: $(SRCDIR)/pgvsize.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvsize.f +pgvstand.o: $(SRCDIR)/pgvstand.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvstand.f +pgwindow.o: $(SRCDIR)/pgwindow.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgwindow.f +grarea.o: $(SRCDIR)/grarea.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grarea.f +grbpic.o: $(SRCDIR)/grbpic.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grbpic.f +grchsz.o: $(SRCDIR)/grchsz.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grchsz.f +grclip.o: $(SRCDIR)/grclip.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grclip.f +grclos.o: $(SRCDIR)/grclos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grclos.f +grclpl.o: $(SRCDIR)/grclpl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grclpl.f +grctoi.o: $(SRCDIR)/grctoi.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grctoi.f +grcurs.o: $(SRCDIR)/grcurs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grcurs.f +grdot0.o: $(SRCDIR)/grdot0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grdot0.f +grdot1.o: $(SRCDIR)/grdot1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grdot1.f +grdtyp.o: $(SRCDIR)/grdtyp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grdtyp.f +gresc.o: $(SRCDIR)/gresc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gresc.f +grepic.o: $(SRCDIR)/grepic.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grepic.f +gretxt.o: $(SRCDIR)/gretxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gretxt.f +grfa.o: $(SRCDIR)/grfa.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grfa.f +grfao.o: $(SRCDIR)/grfao.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grfao.f +grgfil.o: $(SRCDIR)/grgfil.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grgfil.f +grgray.o: $(SRCDIR)/grgray.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grgray.f +grimg0.o: $(SRCDIR)/grimg0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg0.f +grimg1.o: $(SRCDIR)/grimg1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg1.f +grimg2.o: $(SRCDIR)/grimg2.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg2.f +grimg3.o: $(SRCDIR)/grimg3.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg3.f +grinit.o: $(SRCDIR)/grinit.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grinit.f +gritoc.o: $(SRCDIR)/gritoc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gritoc.f +grlen.o: $(SRCDIR)/grlen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlen.f +grlin0.o: $(SRCDIR)/grlin0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin0.f +grlin1.o: $(SRCDIR)/grlin1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin1.f +grlin2.o: $(SRCDIR)/grlin2.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin2.f +grlin3.o: $(SRCDIR)/grlin3.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin3.f +grlina.o: $(SRCDIR)/grlina.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlina.f +grmcur.o: $(SRCDIR)/grmcur.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmcur.f +grmker.o: $(SRCDIR)/grmker.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmker.f +grmova.o: $(SRCDIR)/grmova.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmova.f +grmsg.o: $(SRCDIR)/grmsg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmsg.f +gropen.o: $(SRCDIR)/gropen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gropen.f +grpage.o: $(SRCDIR)/grpage.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpage.f +grpars.o: $(SRCDIR)/grpars.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpars.f +grpixl.o: $(SRCDIR)/grpixl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpixl.f +grpocl.o: $(SRCDIR)/grpocl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpocl.f +grprom.o: $(SRCDIR)/grprom.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grprom.f +grpxpo.o: $(SRCDIR)/grpxpo.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxpo.f +grpxps.o: $(SRCDIR)/grpxps.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxps.f +grpxpx.o: $(SRCDIR)/grpxpx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxpx.f +grpxre.o: $(SRCDIR)/grpxre.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxre.f +grqcap.o: $(SRCDIR)/grqcap.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqcap.f +grqci.o: $(SRCDIR)/grqci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqci.f +grqcol.o: $(SRCDIR)/grqcol.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqcol.f +grqcr.o: $(SRCDIR)/grqcr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqcr.f +grqdev.o: $(SRCDIR)/grqdev.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqdev.f +grqdt.o: $(SRCDIR)/grqdt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqdt.f +grqfnt.o: $(SRCDIR)/grqfnt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqfnt.f +grqls.o: $(SRCDIR)/grqls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqls.f +grqlw.o: $(SRCDIR)/grqlw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqlw.f +grqpos.o: $(SRCDIR)/grqpos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqpos.f +grqtxt.o: $(SRCDIR)/grqtxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqtxt.f +grqtyp.o: $(SRCDIR)/grqtyp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqtyp.f +grquit.o: $(SRCDIR)/grquit.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grquit.f +grrec0.o: $(SRCDIR)/grrec0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grrec0.f +grrect.o: $(SRCDIR)/grrect.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grrect.f +grsci.o: $(SRCDIR)/grsci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsci.f +grscr.o: $(SRCDIR)/grscr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grscr.f +grscrl.o: $(SRCDIR)/grscrl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grscrl.f +grsetc.o: $(SRCDIR)/grsetc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsetc.f +grsets.o: $(SRCDIR)/grsets.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsets.f +grsfnt.o: $(SRCDIR)/grsfnt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsfnt.f +grsize.o: $(SRCDIR)/grsize.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsize.f +grskpb.o: $(SRCDIR)/grskpb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grskpb.f +grslct.o: $(SRCDIR)/grslct.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grslct.f +grsls.o: $(SRCDIR)/grsls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsls.f +grslw.o: $(SRCDIR)/grslw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grslw.f +grsyds.o: $(SRCDIR)/grsyds.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsyds.f +grsymk.o: $(SRCDIR)/grsymk.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsymk.f +grsyxd.o: $(SRCDIR)/grsyxd.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsyxd.f +grterm.o: $(SRCDIR)/grterm.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grterm.f +grtext.o: $(SRCDIR)/grtext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtext.f +grtoup.o: $(SRCDIR)/grtoup.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtoup.f +grtrim.o: $(SRCDIR)/grtrim.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtrim.f +grtrn0.o: $(SRCDIR)/grtrn0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtrn0.f +grtxy0.o: $(SRCDIR)/grtxy0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtxy0.f +grvct0.o: $(SRCDIR)/grvct0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grvct0.f +grwarn.o: $(SRCDIR)/grwarn.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grwarn.f +grxhls.o: $(SRCDIR)/grxhls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grxhls.f +grxrgb.o: $(SRCDIR)/grxrgb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grxrgb.f +grdate.o: $(GENDIR)/grdate.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grdate.c +grfileio.o: $(GENDIR)/grfileio.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grfileio.c +grflun.o: $(GENDIR)/grflun.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grflun.f +grgcom.o: $(GENDIR)/grgcom.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grgcom.f +grgenv.o: $(GENDIR)/grgenv.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grgenv.f +grgetc.o: $(GENDIR)/grgetc.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grgetc.c +grglun.o: $(GENDIR)/grglun.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grglun.f +grgmem.o: $(GENDIR)/grgmem.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grgmem.c +grgmsg.o: $(GENDIR)/grgmsg.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grgmsg.f +grlgtr.o: $(GENDIR)/grlgtr.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grlgtr.f +groptx.o: $(GENDIR)/groptx.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/groptx.f +grsy00.o: $(GENDIR)/grsy00.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grsy00.f +grtermio.o: $(GENDIR)/grtermio.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grtermio.c +grtrml.o: $(GENDIR)/grtrml.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grtrml.f +grtter.o: $(GENDIR)/grtter.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grtter.f +gruser.o: $(GENDIR)/gruser.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/gruser.c +grchar.o: $(OBSDIR)/grchar.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grchar.f +grchr0.o: $(OBSDIR)/grchr0.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grchr0.f +grdat2.o: $(OBSDIR)/grdat2.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grdat2.f +grgtc0.o: $(OBSDIR)/grgtc0.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grgtc0.f +grinqfont.o: $(OBSDIR)/grinqfont.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grinqfont.f +grinqli.o: $(OBSDIR)/grinqli.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grinqli.f +grinqpen.o: $(OBSDIR)/grinqpen.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grinqpen.f +grlinr.o: $(OBSDIR)/grlinr.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grlinr.f +grmark.o: $(OBSDIR)/grmark.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grmark.f +grmovr.o: $(OBSDIR)/grmovr.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grmovr.f +grsetfont.o: $(OBSDIR)/grsetfont.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grsetfont.f +grsetli.o: $(OBSDIR)/grsetli.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grsetli.f +grsetpen.o: $(OBSDIR)/grsetpen.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grsetpen.f +grtran.o: $(OBSDIR)/grtran.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grtran.f +grvect.o: $(OBSDIR)/grvect.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grvect.f +pgsetc.o: $(OBSDIR)/pgsetc.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/pgsetc.f +pgsize.o: $(OBSDIR)/pgsize.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/pgsize.f +cleanup.o: $(PGDDIR)/cleanup.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/cleanup.c +pgdisp.o: $(PGDDIR)/pgdisp.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/pgdisp.c +figcurs.o: $(PGDDIR)/figcurs.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/figcurs.c +getdata.o: $(PGDDIR)/getdata.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/getdata.c +getvisuals.o: $(PGDDIR)/getvisuals.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/getvisuals.c +handlexevent.o: $(PGDDIR)/handlexevent.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/handlexevent.c +proccom.o: $(PGDDIR)/proccom.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/proccom.c +resdb.o: $(PGDDIR)/resdb.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/resdb.c +exposelgwin.o: $(PGDDIR)/exposelgwin.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/exposelgwin.c +getcolors.o: $(PGDDIR)/getcolors.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/getcolors.c +initlgluts.o: $(PGDDIR)/initlgluts.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initlgluts.c +initlgwin.o: $(PGDDIR)/initlgwin.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initlgwin.c +initlock.o: $(PGDDIR)/initlock.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initlock.c +initwmattr.o: $(PGDDIR)/initwmattr.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initwmattr.c +mainloop.o: $(PGDDIR)/mainloop.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/mainloop.c +resizelgwin.o: $(PGDDIR)/resizelgwin.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/resizelgwin.c +returnbuf.o: $(PGDDIR)/returnbuf.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/returnbuf.c +waitevent.o: $(PGDDIR)/waitevent.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/waitevent.c +updatelgtitle.o: $(PGDDIR)/updatelgtitle.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/updatelgtitle.c +gidriv.o: $(DRVDIR)/gidriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/gidriv.f +nudriv.o: $(DRVDIR)/nudriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/nudriv.f +psdriv.o: $(DRVDIR)/psdriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/psdriv.f +ttdriv.o: $(DRVDIR)/ttdriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/ttdriv.f +xwdriv.o: $(DRVDIR)/xwdriv.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) $(DRVDIR)/xwdriv.c + +#----------------------------------------------------------------------- +# The device-driver dispatch routine is generated automatically by +# reading the "drivers.list" file. +#----------------------------------------------------------------------- + +DISPATCH_ROUTINE=grexec.o + +grexec.o: grexec.f + $(FCOMPL) -c $(FFLAGC) grexec.f + +#----------------------------------------------------------------------- +# Target "lib" is used to built the PGPLOT subroutine library. +# libpgplot.a is the primary PGPLOT object library. +# "shared" is an optional target for operating systems that allow shared +# libraries. +#----------------------------------------------------------------------- + +lib : libpgplot.a $(SHARED_LIB) + +libpgplot.a : $(PG_ROUTINES) $(PG_NON_STANDARD) $(GR_ROUTINES) \ + $(DISPATCH_ROUTINE) $(DRIVERS) $(SYSTEM_ROUTINES) + ar ru libpgplot.a \ + `ls $(PG_ROUTINES) \ + $(PG_NON_STANDARD) $(GR_ROUTINES) $(DISPATCH_ROUTINE) \ + $(DRIVERS) $(SYSTEM_ROUTINES) | sort | uniq` + $(RANLIB) libpgplot.a + +$(SHARED_LIB): $(PG_ROUTINES) $(PG_NON_STANDARD) \ + $(GR_ROUTINES) $(DISPATCH_ROUTINE) $(DRIVERS) $(SYSTEM_ROUTINES) + $(SHARED_LD) `ls $(PG_ROUTINES) \ + $(PG_NON_STANDARD) $(GR_ROUTINES) $(DISPATCH_ROUTINE) \ + $(DRIVERS) $(SYSTEM_ROUTINES) | sort | uniq` $(SHARED_LIB_LIBS) + +#----------------------------------------------------------------------- +# libpgobs.a contains obsolete routines used by some programs +#----------------------------------------------------------------------- +libpgobs.a : $(OBSOLETE_ROUTINES) + ar ru libpgobs.a $(OBSOLETE_ROUTINES) + $(RANLIB) libpgobs.a + +#----------------------------------------------------------------------- +# Target "prog" is used to make the demo programs. They can also be made +# individually. +#----------------------------------------------------------------------- +prog: $(DEMOS) + +pgdemo1: $(DEMDIR)/pgdemo1.f + $(FCOMPL) $(FFLAGD) -o pgdemo1 $(DEMDIR)/pgdemo1.f $(PGPLOT_LIB) $(LIBS) +pgdemo2: $(DEMDIR)/pgdemo2.f + $(FCOMPL) $(FFLAGD) -o pgdemo2 $(DEMDIR)/pgdemo2.f $(PGPLOT_LIB) $(LIBS) +pgdemo3: $(DEMDIR)/pgdemo3.f + $(FCOMPL) $(FFLAGD) -o pgdemo3 $(DEMDIR)/pgdemo3.f $(PGPLOT_LIB) $(LIBS) +pgdemo4: $(DEMDIR)/pgdemo4.f + $(FCOMPL) $(FFLAGD) -o pgdemo4 $(DEMDIR)/pgdemo4.f $(PGPLOT_LIB) $(LIBS) +pgdemo5: $(DEMDIR)/pgdemo5.f + $(FCOMPL) $(FFLAGD) -o pgdemo5 $(DEMDIR)/pgdemo5.f $(PGPLOT_LIB) $(LIBS) +pgdemo6: $(DEMDIR)/pgdemo6.f + $(FCOMPL) $(FFLAGD) -o pgdemo6 $(DEMDIR)/pgdemo6.f $(PGPLOT_LIB) $(LIBS) +pgdemo7: $(DEMDIR)/pgdemo7.f + $(FCOMPL) $(FFLAGD) -o pgdemo7 $(DEMDIR)/pgdemo7.f $(PGPLOT_LIB) $(LIBS) +pgdemo8: $(DEMDIR)/pgdemo8.f + $(FCOMPL) $(FFLAGD) -o pgdemo8 $(DEMDIR)/pgdemo8.f $(PGPLOT_LIB) $(LIBS) +pgdemo9: $(DEMDIR)/pgdemo9.f + $(FCOMPL) $(FFLAGD) -o pgdemo9 $(DEMDIR)/pgdemo9.f $(PGPLOT_LIB) $(LIBS) +pgdemo10: $(DEMDIR)/pgdemo10.f + $(FCOMPL) $(FFLAGD) -o pgdemo10 $(DEMDIR)/pgdemo10.f $(PGPLOT_LIB) $(LIBS) +pgdemo11: $(DEMDIR)/pgdemo11.f + $(FCOMPL) $(FFLAGD) -o pgdemo11 $(DEMDIR)/pgdemo11.f $(PGPLOT_LIB) $(LIBS) +pgdemo12: $(DEMDIR)/pgdemo12.f + $(FCOMPL) $(FFLAGD) -o pgdemo12 $(DEMDIR)/pgdemo12.f $(PGPLOT_LIB) $(LIBS) +pgdemo13: $(DEMDIR)/pgdemo13.f + $(FCOMPL) $(FFLAGD) -o pgdemo13 $(DEMDIR)/pgdemo13.f $(PGPLOT_LIB) $(LIBS) +pgdemo14: $(DEMDIR)/pgdemo14.f + $(FCOMPL) $(FFLAGD) -o pgdemo14 $(DEMDIR)/pgdemo14.f $(PGPLOT_LIB) $(LIBS) +pgdemo15: $(DEMDIR)/pgdemo15.f + $(FCOMPL) $(FFLAGD) -o pgdemo15 $(DEMDIR)/pgdemo15.f $(PGPLOT_LIB) $(LIBS) +pgdemo16: $(DEMDIR)/pgdemo16.f + $(FCOMPL) $(FFLAGD) -o pgdemo16 $(DEMDIR)/pgdemo16.f $(PGPLOT_LIB) $(LIBS) +pgdemo17: $(DEMDIR)/pgdemo17.f + $(FCOMPL) $(FFLAGD) -o pgdemo17 $(DEMDIR)/pgdemo17.f $(PGPLOT_LIB) $(LIBS) + +#----------------------------------------------------------------------- +# Target "grfont.dat" is the binary font file. +# This is created from grfont.txt with the "pgpack" program. +# (a) compile the `pgpack' program; then +# (b) run `pgpack' to convert the ASCII version of the font file +# (grfont.txt) into the binary version (grfont.dat). When executed, +# `pgpack' should report: +# Characters defined: 996 +# Array cells used: 26732 +#----------------------------------------------------------------------- + +grfont.dat: $(FNTDIR)/grfont.txt $(FNTDIR)/pgpack.f + $(FCOMPL) $(FFLAGC) -o pgpack $(FNTDIR)/pgpack.f + rm -f grfont.dat + ./pgpack <$(FNTDIR)/grfont.txt + rm -f pgpack + +#----------------------------------------------------------------------- +# Documentation files +#----------------------------------------------------------------------- + +PG_SOURCE= $(SRCDIR)/pgarro.f $(SRCDIR)/pgask.f $(SRCDIR)/pgaxis.f $(SRCDIR)/pgaxlg.f $(SRCDIR)/pgband.f $(SRCDIR)/pgbbuf.f $(SRCDIR)/pgbeg.f $(SRCDIR)/pgbin.f $(SRCDIR)/pgbox.f $(SRCDIR)/pgbox1.f $(SRCDIR)/pgcirc.f $(SRCDIR)/pgcl.f $(SRCDIR)/pgclos.f $(SRCDIR)/pgcn01.f $(SRCDIR)/pgcnsc.f $(SRCDIR)/pgconb.f $(SRCDIR)/pgconf.f $(SRCDIR)/pgconl.f $(SRCDIR)/pgcons.f $(SRCDIR)/pgcont.f $(SRCDIR)/pgconx.f $(SRCDIR)/pgcp.f $(SRCDIR)/pgctab.f $(SRCDIR)/pgcurs.f $(SRCDIR)/pgdraw.f $(SRCDIR)/pgebuf.f $(SRCDIR)/pgend.f $(SRCDIR)/pgenv.f $(SRCDIR)/pgeras.f $(SRCDIR)/pgerr1.f $(SRCDIR)/pgerrb.f $(SRCDIR)/pgerrx.f $(SRCDIR)/pgerry.f $(SRCDIR)/pgetxt.f $(SRCDIR)/pgfunt.f $(SRCDIR)/pgfunx.f $(SRCDIR)/pgfuny.f $(SRCDIR)/pggray.f $(SRCDIR)/pghi2d.f $(SRCDIR)/pghis1.f $(SRCDIR)/pghist.f $(SRCDIR)/pghtch.f $(SRCDIR)/pgiden.f $(SRCDIR)/pgimag.f $(SRCDIR)/pginit.f $(SRCDIR)/pglab.f $(SRCDIR)/pglcur.f $(SRCDIR)/pgldev.f $(SRCDIR)/pglen.f $(SRCDIR)/pgline.f $(SRCDIR)/pgmove.f $(SRCDIR)/pgmtxt.f $(SRCDIR)/pgncur.f $(SRCDIR)/pgnoto.f $(SRCDIR)/pgnpl.f $(SRCDIR)/pgnumb.f $(SRCDIR)/pgolin.f $(SRCDIR)/pgopen.f $(SRCDIR)/pgpage.f $(SRCDIR)/pgpanl.f $(SRCDIR)/pgpap.f $(SRCDIR)/pgpixl.f $(SRCDIR)/pgpnts.f $(SRCDIR)/pgpoly.f $(SRCDIR)/pgpt.f $(SRCDIR)/pgpt1.f $(SRCDIR)/pgptxt.f $(SRCDIR)/pgqah.f $(SRCDIR)/pgqcf.f $(SRCDIR)/pgqch.f $(SRCDIR)/pgqci.f $(SRCDIR)/pgqcir.f $(SRCDIR)/pgqclp.f $(SRCDIR)/pgqcol.f $(SRCDIR)/pgqcr.f $(SRCDIR)/pgqcs.f $(SRCDIR)/pgqdt.f $(SRCDIR)/pgqfs.f $(SRCDIR)/pgqhs.f $(SRCDIR)/pgqid.f $(SRCDIR)/pgqinf.f $(SRCDIR)/pgqitf.f $(SRCDIR)/pgqls.f $(SRCDIR)/pgqlw.f $(SRCDIR)/pgqndt.f $(SRCDIR)/pgqpos.f $(SRCDIR)/pgqtbg.f $(SRCDIR)/pgqtxt.f $(SRCDIR)/pgqvp.f $(SRCDIR)/pgqvsz.f $(SRCDIR)/pgqwin.f $(SRCDIR)/pgrect.f $(SRCDIR)/pgrnd.f $(SRCDIR)/pgrnge.f $(SRCDIR)/pgsah.f $(SRCDIR)/pgsave.f $(SRCDIR)/pgscf.f $(SRCDIR)/pgsch.f $(SRCDIR)/pgsci.f $(SRCDIR)/pgscir.f $(SRCDIR)/pgsclp.f $(SRCDIR)/pgscr.f $(SRCDIR)/pgscrl.f $(SRCDIR)/pgscrn.f $(SRCDIR)/pgsfs.f $(SRCDIR)/pgshls.f $(SRCDIR)/pgshs.f $(SRCDIR)/pgsitf.f $(SRCDIR)/pgslct.f $(SRCDIR)/pgsls.f $(SRCDIR)/pgslw.f $(SRCDIR)/pgstbg.f $(SRCDIR)/pgsubp.f $(SRCDIR)/pgsvp.f $(SRCDIR)/pgswin.f $(SRCDIR)/pgtbox.f $(SRCDIR)/pgtext.f $(SRCDIR)/pgtick.f $(SRCDIR)/pgtikl.f $(SRCDIR)/pgupdt.f $(SRCDIR)/pgvect.f $(SRCDIR)/pgvsiz.f $(SRCDIR)/pgvstd.f $(SRCDIR)/pgvw.f $(SRCDIR)/pgwedg.f $(SRCDIR)/pgwnad.f $(SRCDIR)/pgadvance.f $(SRCDIR)/pgbegin.f $(SRCDIR)/pgcurse.f $(SRCDIR)/pglabel.f $(SRCDIR)/pgmtext.f $(SRCDIR)/pgncurse.f $(SRCDIR)/pgpaper.f $(SRCDIR)/pgpoint.f $(SRCDIR)/pgptext.f $(SRCDIR)/pgvport.f $(SRCDIR)/pgvsize.f $(SRCDIR)/pgvstand.f $(SRCDIR)/pgwindow.f +pgplot.doc: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot5.2.2/makedoc $(PG_SOURCE) > pgplot.doc +pgplot.html: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot5.2.2/makehtml $(PG_SOURCE) > pgplot.html +pgplot.hlp: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot5.2.2/makehelp $(PG_SOURCE) > pgplot.hlp +pgplot-routines.tex: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot5.2.2/maketex $(PG_SOURCE) > pgplot-routines.tex + +#----------------------------------------------------------------------- +# Target "pgxwin_server" is the server program for the XW driver +#----------------------------------------------------------------------- +pgxwin_server: $(DRVDIR)/pgxwin_server.c + $(CCOMPL) $(CFLAGC) $(XINCL) -o pgxwin_server $(DRVDIR)/pgxwin_server.c $(LIBS) + +#----------------------------------------------------------------------- +# Target "pgdisp" is the pgdisp server program for /XDISP driver +#----------------------------------------------------------------------- +pgdisp: $(PGDISP_ROUTINES) + $(CCOMPL) $(CFLAGC) -o pgdisp $(PGDISP_ROUTINES) $(LIBS) + +#----------------------------------------------------------------------- +# Target "libxmpgplot.a" contains the Motif widget driver. +#----------------------------------------------------------------------- + +libXmPgplot.a: XmPgplot.o + ar ru libXmPgplot.a XmPgplot.o + $(RANLIB) libXmPgplot.a + +XmPgplot.h: $(XMDIR)/XmPgplot.h + cp $(XMDIR)/XmPgplot.h XmPgplot.h + +XmPgplot.o: $(DRVDIR)/pgxwin.h XmPgplot.h $(XMDIR)/XmPgplotP.h $(XMDIR)/XmPgplot.c + $(CCOMPL) -c $(CFLAGC) -I$(DRVDIR) -I$(XMDIR) $(MOTIF_INCL) $(XMDIR)/XmPgplot.c + +#----------------------------------------------------------------------- +# Target "libxapgplot.a" contains the Motif widget driver. +#----------------------------------------------------------------------- + +libXaPgplot.a: XaPgplot.o + ar ru libXaPgplot.a XaPgplot.o + $(RANLIB) libXaPgplot.a + +XaPgplot.h: $(XADIR)/XaPgplot.h + cp $(XADIR)/XaPgplot.h XaPgplot.h + +XaPgplot.o: $(DRVDIR)/pgxwin.h XaPgplot.h $(XADIR)/XaPgplotP.h $(XADIR)/XaPgplot.c + $(CCOMPL) -c $(CFLAGC) -I$(DRVDIR) -I$(XADIR) $(MOTIF_INCL) $(XADIR)/XaPgplot.c + +#----------------------------------------------------------------------- +# Target "libtkpgplot.a" contains the Tk widget driver. +#----------------------------------------------------------------------- + +libtkpgplot.a: tkpgplot.o + ar ru libtkpgplot.a tkpgplot.o + $(RANLIB) libtkpgplot.a + +tkpgplot.h: $(TKDIR)/tkpgplot.h + cp $(TKDIR)/tkpgplot.h tkpgplot.h + +tkpgplot.o: $(DRVDIR)/pgxwin.h tkpgplot.h $(TKDIR)/tkpgplot.c + $(CCOMPL) -c $(CFLAGC) -I$(DRVDIR) -I$(TKDIR) $(TK_INCL) $(TKDIR)/tkpgplot.c + +#----------------------------------------------------------------------- +# Target "librvpgplot.a" contains the Rivet-Tk widget driver. +#----------------------------------------------------------------------- + +librvpgplot.a: rvpgplot.o + ar ru librvpgplot.a rvpgplot.o + $(RANLIB) librvpgplot.a + +rvpgplot.h: $(TKDIR)/rvpgplot.h + cp $(TKDIR)/rvpgplot.h rvpgplot.h + +rvpgplot.o: $(DRVDIR)/pgxwin.h rvpgplot.h $(TKDIR)/tkpgplot.c + $(CCOMPL) -o $@ -c -DUSE_RIVET $(CFLAGC) -I$(DRVDIR) -I$(TKDIR) $(RV_INCL) $(TKDIR)/tkpgplot.c + +#----------------------------------------------------------------------- +# Target "install" is required for Figaro. +#----------------------------------------------------------------------- +install: + +#----------------------------------------------------------------------- +# Target "clean" is used to remove all the intermediate files. +#----------------------------------------------------------------------- +clean : + -@rm -f $(PG_ROUTINES) $(PG_NON_STANDARD) $(GR_ROUTINES)\ + $(DISPATCH_ROUTINE) $(DRIVERS) $(SYSTEM_ROUTINES)\ + $(OBSOLETE_ROUTINES) $(PGDISP_ROUTINES) pgmdemo.o\ + XmPgplot.o pgbind tkpgplot.o pgtkdemo.o rvpgplot.o\ + pgbind.o pgdemo*.o pgawdemo.o + +#----------------------------------------------------------------------- +# Include file dependencies +#----------------------------------------------------------------------- +# The following routines reference pgplot.inc + +pgask.o pgband.o pgbbuf.o pgbox.o pgcirc.o pgcl.o pgclos.o pgconl.o pgcont.o pgcp.o pgebuf.o pgend.o pggray.o pghi2d.o pgiden.o pgimag.o pginit.o pglen.o pgmtxt.o pgncur.o pgnoto.o pgopen.o pgpage.o pgpanl.o pgpap.o pgpoly.o pgptxt.o pgqah.o pgqch.o pgqcir.o pgqclp.o pgqcs.o pgqfs.o pgqhs.o pgqid.o pgqinf.o pgqitf.o pgqtbg.o pgqtxt.o pgqvp.o pgqvsz.o pgqwin.o pgrect.o pgsah.o pgsch.o pgscir.o pgsclp.o pgscrl.o pgsfs.o pgshs.o pgsitf.o pgslct.o pgstbg.o pgsubp.o pgsvp.o pgswin.o pgtikl.o pgvsiz.o pgvstd.o pgvw.o pgwnad.o : $(SRCDIR)/pgplot.inc + +# The following routines reference grpckg1.inc + +grarea.o grbpic.o grchr0.o grchsz.o grclos.o grclpl.o grcurs.o grdot0.o grdot1.o grdtyp.o grepic.o gresc.o gretxt.o grfa.o grgray.o grimg0.o grimg1.o grimg2.o grimg3.o grinit.o grldev.o grlen.o grlin0.o grlin1.o grlin2.o grlin3.o grlina.o grlinr.o grmker.o grmova.o grmovr.o gropen.o grpage.o grpixl.o grpxpo.o grpxps.o grpxpx.o grqcap.o grqci.o grqcol.o grqcr.o grqdev.o grqdt.o grqfnt.o grqls.o grqlw.o grqpos.o grqtxt.o grqtyp.o grrec0.o grrect.o grsci.o grscr.o grscrl.o grsetc.o grsetli.o grsets.o grsfnt.o grsize.o grslct.o grsls.o grslw.o grterm.o grtext.o grtrn0.o grtxy0.o grvct0.o : $(SRCDIR)/grpckg1.inc + + +# Miscellaneous include files required by drivers + +griv00.o : $(DRVDIR)/gadef.h $(DRVDIR)/gmdef.h $(DRVDIR)/gphdef.h +grivas.o : $(DRVDIR)/gadef.h +grtv00.o : $(DRVDIR)/imdef.h +pgxwin.o : $(DRVDIR)/pgxwin.h +pndriv.o : ./png.h ./pngconf.h ./zlib.h ./zconf.h + +x2driv.o figdisp_comm.o: $(DRVDIR)/commands.h + + +cpg: libcpgplot.a cpgplot.h cpgdemo + @echo ' ' + @echo '*** Finished compilation of the C PGPLOT wrapper library ***' + @echo ' ' + @echo 'Note that if you plan to install the library in a different' + @echo 'directory than the current one, both libcpgplot.a and cpgplot.h' + @echo 'will be needed.' + @echo ' ' + +pgbind: $(SRC)/cpg/pgbind.c + $(CCOMPL) $(CFLAGC) $(SRC)/cpg/pgbind.c -o pgbind + +libcpgplot.a cpgplot.h: $(PG_SOURCE) pgbind + ./pgbind $(PGBIND_FLAGS) -h -w $(PG_SOURCE) + $(CCOMPL) -c $(CFLAGC) cpg*.c + rm -f cpg*.c + ar ru libcpgplot.a cpg*.o + $(RANLIB) libcpgplot.a + rm -f cpg*.o + +cpgdemo: cpgplot.h $(SRC)/cpg/cpgdemo.c libcpgplot.a + $(CCOMPL) $(CFLAGD) -c -I. $(SRC)/cpg/cpgdemo.c + $(FCOMPL) -o cpgdemo cpgdemo.o $(CPGPLOT_LIB) $(LIBS) + rm -f cpgdemo.o + +pgmdemo: pgmdemo.o libXmPgplot.a + $(FCOMPL) -o pgmdemo pgmdemo.o -L`pwd` -lXmPgplot $(CPGPLOT_LIB) $(MOTIF_LIBS) + +pgmdemo.o: $(XMDIR)/pgmdemo.c XmPgplot.h libcpgplot.a cpgplot.h + $(CCOMPL) $(CFLAGD) -c -I`pwd` $(MOTIF_INCL) $(XMDIR)/pgmdemo.c + +pgawdemo: pgawdemo.o libXaPgplot.a + $(FCOMPL) -o pgawdemo pgawdemo.o -L`pwd` -lXaPgplot $(CPGPLOT_LIB) $(ATHENA_LIBS) + +pgawdemo.o: $(XADIR)/pgawdemo.c XaPgplot.h libcpgplot.a cpgplot.h + $(CCOMPL) $(CFLAGD) -c -I`pwd` $(ATHENA_INCL) $(XADIR)/pgawdemo.c + +pgtkdemo: pgtkdemo.o libtkpgplot.a + $(FCOMPL) -o pgtkdemo pgtkdemo.o -L`pwd` -ltkpgplot $(CPGPLOT_LIB) $(TK_LIBS) + +pgtkdemo.tcl: $(TKDIR)/pgtkdemo.tcl + cp $(TKDIR)/pgtkdemo.tcl pgtkdemo.tcl + chmod a+x pgtkdemo.tcl + +pgtkdemo.o: $(TKDIR)/pgtkdemo.c tkpgplot.h libcpgplot.a cpgplot.h + $(CCOMPL) $(CFLAGD) -c -I`pwd` $(TK_INCL) $(TKDIR)/pgtkdemo.c diff --git a/pgplot_rhel7/nudriv.o b/pgplot_rhel7/nudriv.o new file mode 100644 index 0000000..f2dc271 Binary files /dev/null and b/pgplot_rhel7/nudriv.o differ diff --git a/pgplot_rhel7/pgadvance.o b/pgplot_rhel7/pgadvance.o new file mode 100644 index 0000000..ede6a3e Binary files /dev/null and b/pgplot_rhel7/pgadvance.o differ diff --git a/pgplot_rhel7/pgarro.o b/pgplot_rhel7/pgarro.o new file mode 100644 index 0000000..a23153d Binary files /dev/null and b/pgplot_rhel7/pgarro.o differ diff --git a/pgplot_rhel7/pgask.o b/pgplot_rhel7/pgask.o new file mode 100644 index 0000000..a459b10 Binary files /dev/null and b/pgplot_rhel7/pgask.o differ diff --git a/pgplot_rhel7/pgaxis.o b/pgplot_rhel7/pgaxis.o new file mode 100644 index 0000000..8d6a557 Binary files /dev/null and b/pgplot_rhel7/pgaxis.o differ diff --git a/pgplot_rhel7/pgaxlg.o b/pgplot_rhel7/pgaxlg.o new file mode 100644 index 0000000..2a0a354 Binary files /dev/null and b/pgplot_rhel7/pgaxlg.o differ diff --git a/pgplot_rhel7/pgband.o b/pgplot_rhel7/pgband.o new file mode 100644 index 0000000..48aa57b Binary files /dev/null and b/pgplot_rhel7/pgband.o differ diff --git a/pgplot_rhel7/pgbbuf.o b/pgplot_rhel7/pgbbuf.o new file mode 100644 index 0000000..b67ef11 Binary files /dev/null and b/pgplot_rhel7/pgbbuf.o differ diff --git a/pgplot_rhel7/pgbeg.o b/pgplot_rhel7/pgbeg.o new file mode 100644 index 0000000..f3da990 Binary files /dev/null and b/pgplot_rhel7/pgbeg.o differ diff --git a/pgplot_rhel7/pgbegin.o b/pgplot_rhel7/pgbegin.o new file mode 100644 index 0000000..202740c Binary files /dev/null and b/pgplot_rhel7/pgbegin.o differ diff --git a/pgplot_rhel7/pgbin.o b/pgplot_rhel7/pgbin.o new file mode 100644 index 0000000..9373f45 Binary files /dev/null and b/pgplot_rhel7/pgbin.o differ diff --git a/pgplot_rhel7/pgbox.o b/pgplot_rhel7/pgbox.o new file mode 100644 index 0000000..a03bee2 Binary files /dev/null and b/pgplot_rhel7/pgbox.o differ diff --git a/pgplot_rhel7/pgbox1.o b/pgplot_rhel7/pgbox1.o new file mode 100644 index 0000000..deeff81 Binary files /dev/null and b/pgplot_rhel7/pgbox1.o differ diff --git a/pgplot_rhel7/pgcirc.o b/pgplot_rhel7/pgcirc.o new file mode 100644 index 0000000..c9b04ea Binary files /dev/null and b/pgplot_rhel7/pgcirc.o differ diff --git a/pgplot_rhel7/pgcl.o b/pgplot_rhel7/pgcl.o new file mode 100644 index 0000000..53eb29d Binary files /dev/null and b/pgplot_rhel7/pgcl.o differ diff --git a/pgplot_rhel7/pgclos.o b/pgplot_rhel7/pgclos.o new file mode 100644 index 0000000..2eddef9 Binary files /dev/null and b/pgplot_rhel7/pgclos.o differ diff --git a/pgplot_rhel7/pgcn01.o b/pgplot_rhel7/pgcn01.o new file mode 100644 index 0000000..8c379e3 Binary files /dev/null and b/pgplot_rhel7/pgcn01.o differ diff --git a/pgplot_rhel7/pgcnsc.o b/pgplot_rhel7/pgcnsc.o new file mode 100644 index 0000000..17d41b9 Binary files /dev/null and b/pgplot_rhel7/pgcnsc.o differ diff --git a/pgplot_rhel7/pgconb.o b/pgplot_rhel7/pgconb.o new file mode 100644 index 0000000..961b903 Binary files /dev/null and b/pgplot_rhel7/pgconb.o differ diff --git a/pgplot_rhel7/pgconf.o b/pgplot_rhel7/pgconf.o new file mode 100644 index 0000000..dbb3d9a Binary files /dev/null and b/pgplot_rhel7/pgconf.o differ diff --git a/pgplot_rhel7/pgconl.o b/pgplot_rhel7/pgconl.o new file mode 100644 index 0000000..0efa67f Binary files /dev/null and b/pgplot_rhel7/pgconl.o differ diff --git a/pgplot_rhel7/pgcons.o b/pgplot_rhel7/pgcons.o new file mode 100644 index 0000000..580e6fb Binary files /dev/null and b/pgplot_rhel7/pgcons.o differ diff --git a/pgplot_rhel7/pgcont.o b/pgplot_rhel7/pgcont.o new file mode 100644 index 0000000..6d642aa Binary files /dev/null and b/pgplot_rhel7/pgcont.o differ diff --git a/pgplot_rhel7/pgconx.o b/pgplot_rhel7/pgconx.o new file mode 100644 index 0000000..3deba38 Binary files /dev/null and b/pgplot_rhel7/pgconx.o differ diff --git a/pgplot_rhel7/pgcp.o b/pgplot_rhel7/pgcp.o new file mode 100644 index 0000000..19f64e6 Binary files /dev/null and b/pgplot_rhel7/pgcp.o differ diff --git a/pgplot_rhel7/pgctab.o b/pgplot_rhel7/pgctab.o new file mode 100644 index 0000000..3859329 Binary files /dev/null and b/pgplot_rhel7/pgctab.o differ diff --git a/pgplot_rhel7/pgcurs.o b/pgplot_rhel7/pgcurs.o new file mode 100644 index 0000000..05ecd27 Binary files /dev/null and b/pgplot_rhel7/pgcurs.o differ diff --git a/pgplot_rhel7/pgcurse.o b/pgplot_rhel7/pgcurse.o new file mode 100644 index 0000000..7463f14 Binary files /dev/null and b/pgplot_rhel7/pgcurse.o differ diff --git a/pgplot_rhel7/pgdemo1 b/pgplot_rhel7/pgdemo1 new file mode 100755 index 0000000..852bc79 Binary files /dev/null and b/pgplot_rhel7/pgdemo1 differ diff --git a/pgplot_rhel7/pgdemo10 b/pgplot_rhel7/pgdemo10 new file mode 100755 index 0000000..608d3f8 Binary files /dev/null and b/pgplot_rhel7/pgdemo10 differ diff --git a/pgplot_rhel7/pgdemo11 b/pgplot_rhel7/pgdemo11 new file mode 100755 index 0000000..977e874 Binary files /dev/null and b/pgplot_rhel7/pgdemo11 differ diff --git a/pgplot_rhel7/pgdemo12 b/pgplot_rhel7/pgdemo12 new file mode 100755 index 0000000..a302c22 Binary files /dev/null and b/pgplot_rhel7/pgdemo12 differ diff --git a/pgplot_rhel7/pgdemo13 b/pgplot_rhel7/pgdemo13 new file mode 100755 index 0000000..691952c Binary files /dev/null and b/pgplot_rhel7/pgdemo13 differ diff --git a/pgplot_rhel7/pgdemo14 b/pgplot_rhel7/pgdemo14 new file mode 100755 index 0000000..651f0c5 Binary files /dev/null and b/pgplot_rhel7/pgdemo14 differ diff --git a/pgplot_rhel7/pgdemo15 b/pgplot_rhel7/pgdemo15 new file mode 100755 index 0000000..6b71e18 Binary files /dev/null and b/pgplot_rhel7/pgdemo15 differ diff --git a/pgplot_rhel7/pgdemo16 b/pgplot_rhel7/pgdemo16 new file mode 100755 index 0000000..3958daf Binary files /dev/null and b/pgplot_rhel7/pgdemo16 differ diff --git a/pgplot_rhel7/pgdemo17 b/pgplot_rhel7/pgdemo17 new file mode 100755 index 0000000..f14690a Binary files /dev/null and b/pgplot_rhel7/pgdemo17 differ diff --git a/pgplot_rhel7/pgdemo2 b/pgplot_rhel7/pgdemo2 new file mode 100755 index 0000000..aea8750 Binary files /dev/null and b/pgplot_rhel7/pgdemo2 differ diff --git a/pgplot_rhel7/pgdemo3 b/pgplot_rhel7/pgdemo3 new file mode 100755 index 0000000..b9be27a Binary files /dev/null and b/pgplot_rhel7/pgdemo3 differ diff --git a/pgplot_rhel7/pgdemo4 b/pgplot_rhel7/pgdemo4 new file mode 100755 index 0000000..e5dc6f7 Binary files /dev/null and b/pgplot_rhel7/pgdemo4 differ diff --git a/pgplot_rhel7/pgdemo5 b/pgplot_rhel7/pgdemo5 new file mode 100755 index 0000000..af3d61d Binary files /dev/null and b/pgplot_rhel7/pgdemo5 differ diff --git a/pgplot_rhel7/pgdemo6 b/pgplot_rhel7/pgdemo6 new file mode 100755 index 0000000..4b707d2 Binary files /dev/null and b/pgplot_rhel7/pgdemo6 differ diff --git a/pgplot_rhel7/pgdemo7 b/pgplot_rhel7/pgdemo7 new file mode 100755 index 0000000..520ba9c Binary files /dev/null and b/pgplot_rhel7/pgdemo7 differ diff --git a/pgplot_rhel7/pgdemo8 b/pgplot_rhel7/pgdemo8 new file mode 100755 index 0000000..e7197ab Binary files /dev/null and b/pgplot_rhel7/pgdemo8 differ diff --git a/pgplot_rhel7/pgdemo9 b/pgplot_rhel7/pgdemo9 new file mode 100755 index 0000000..a21c3c7 Binary files /dev/null and b/pgplot_rhel7/pgdemo9 differ diff --git a/pgplot_rhel7/pgdraw.o b/pgplot_rhel7/pgdraw.o new file mode 100644 index 0000000..42ddf36 Binary files /dev/null and b/pgplot_rhel7/pgdraw.o differ diff --git a/pgplot_rhel7/pgebuf.o b/pgplot_rhel7/pgebuf.o new file mode 100644 index 0000000..73d5406 Binary files /dev/null and b/pgplot_rhel7/pgebuf.o differ diff --git a/pgplot_rhel7/pgend.o b/pgplot_rhel7/pgend.o new file mode 100644 index 0000000..7e2c272 Binary files /dev/null and b/pgplot_rhel7/pgend.o differ diff --git a/pgplot_rhel7/pgenv.o b/pgplot_rhel7/pgenv.o new file mode 100644 index 0000000..9e4d3cd Binary files /dev/null and b/pgplot_rhel7/pgenv.o differ diff --git a/pgplot_rhel7/pgeras.o b/pgplot_rhel7/pgeras.o new file mode 100644 index 0000000..ab88c95 Binary files /dev/null and b/pgplot_rhel7/pgeras.o differ diff --git a/pgplot_rhel7/pgerr1.o b/pgplot_rhel7/pgerr1.o new file mode 100644 index 0000000..5cc836a Binary files /dev/null and b/pgplot_rhel7/pgerr1.o differ diff --git a/pgplot_rhel7/pgerrb.o b/pgplot_rhel7/pgerrb.o new file mode 100644 index 0000000..65fc9b6 Binary files /dev/null and b/pgplot_rhel7/pgerrb.o differ diff --git a/pgplot_rhel7/pgerrx.o b/pgplot_rhel7/pgerrx.o new file mode 100644 index 0000000..2efd0e0 Binary files /dev/null and b/pgplot_rhel7/pgerrx.o differ diff --git a/pgplot_rhel7/pgerry.o b/pgplot_rhel7/pgerry.o new file mode 100644 index 0000000..35570c7 Binary files /dev/null and b/pgplot_rhel7/pgerry.o differ diff --git a/pgplot_rhel7/pgetxt.o b/pgplot_rhel7/pgetxt.o new file mode 100644 index 0000000..49e8e0d Binary files /dev/null and b/pgplot_rhel7/pgetxt.o differ diff --git a/pgplot_rhel7/pgfunt.o b/pgplot_rhel7/pgfunt.o new file mode 100644 index 0000000..5566481 Binary files /dev/null and b/pgplot_rhel7/pgfunt.o differ diff --git a/pgplot_rhel7/pgfunx.o b/pgplot_rhel7/pgfunx.o new file mode 100644 index 0000000..5925114 Binary files /dev/null and b/pgplot_rhel7/pgfunx.o differ diff --git a/pgplot_rhel7/pgfuny.o b/pgplot_rhel7/pgfuny.o new file mode 100644 index 0000000..fee010f Binary files /dev/null and b/pgplot_rhel7/pgfuny.o differ diff --git a/pgplot_rhel7/pggray.o b/pgplot_rhel7/pggray.o new file mode 100644 index 0000000..569dbf5 Binary files /dev/null and b/pgplot_rhel7/pggray.o differ diff --git a/pgplot_rhel7/pghi2d.o b/pgplot_rhel7/pghi2d.o new file mode 100644 index 0000000..6ff7300 Binary files /dev/null and b/pgplot_rhel7/pghi2d.o differ diff --git a/pgplot_rhel7/pghis1.o b/pgplot_rhel7/pghis1.o new file mode 100644 index 0000000..f7f5925 Binary files /dev/null and b/pgplot_rhel7/pghis1.o differ diff --git a/pgplot_rhel7/pghist.o b/pgplot_rhel7/pghist.o new file mode 100644 index 0000000..a00f1db Binary files /dev/null and b/pgplot_rhel7/pghist.o differ diff --git a/pgplot_rhel7/pghtch.o b/pgplot_rhel7/pghtch.o new file mode 100644 index 0000000..3715692 Binary files /dev/null and b/pgplot_rhel7/pghtch.o differ diff --git a/pgplot_rhel7/pgiden.o b/pgplot_rhel7/pgiden.o new file mode 100644 index 0000000..9415432 Binary files /dev/null and b/pgplot_rhel7/pgiden.o differ diff --git a/pgplot_rhel7/pgimag.o b/pgplot_rhel7/pgimag.o new file mode 100644 index 0000000..ead22ea Binary files /dev/null and b/pgplot_rhel7/pgimag.o differ diff --git a/pgplot_rhel7/pginit.o b/pgplot_rhel7/pginit.o new file mode 100644 index 0000000..0e99af4 Binary files /dev/null and b/pgplot_rhel7/pginit.o differ diff --git a/pgplot_rhel7/pglab.o b/pgplot_rhel7/pglab.o new file mode 100644 index 0000000..4376b9b Binary files /dev/null and b/pgplot_rhel7/pglab.o differ diff --git a/pgplot_rhel7/pglabel.o b/pgplot_rhel7/pglabel.o new file mode 100644 index 0000000..b4d40e1 Binary files /dev/null and b/pgplot_rhel7/pglabel.o differ diff --git a/pgplot_rhel7/pglcur.o b/pgplot_rhel7/pglcur.o new file mode 100644 index 0000000..f5809ed Binary files /dev/null and b/pgplot_rhel7/pglcur.o differ diff --git a/pgplot_rhel7/pgldev.o b/pgplot_rhel7/pgldev.o new file mode 100644 index 0000000..55f6e52 Binary files /dev/null and b/pgplot_rhel7/pgldev.o differ diff --git a/pgplot_rhel7/pglen.o b/pgplot_rhel7/pglen.o new file mode 100644 index 0000000..9a7d0ff Binary files /dev/null and b/pgplot_rhel7/pglen.o differ diff --git a/pgplot_rhel7/pgline.o b/pgplot_rhel7/pgline.o new file mode 100644 index 0000000..b8c606b Binary files /dev/null and b/pgplot_rhel7/pgline.o differ diff --git a/pgplot_rhel7/pgmove.o b/pgplot_rhel7/pgmove.o new file mode 100644 index 0000000..b1688e0 Binary files /dev/null and b/pgplot_rhel7/pgmove.o differ diff --git a/pgplot_rhel7/pgmtext.o b/pgplot_rhel7/pgmtext.o new file mode 100644 index 0000000..0db1f79 Binary files /dev/null and b/pgplot_rhel7/pgmtext.o differ diff --git a/pgplot_rhel7/pgmtxt.o b/pgplot_rhel7/pgmtxt.o new file mode 100644 index 0000000..a39822d Binary files /dev/null and b/pgplot_rhel7/pgmtxt.o differ diff --git a/pgplot_rhel7/pgncur.o b/pgplot_rhel7/pgncur.o new file mode 100644 index 0000000..970d702 Binary files /dev/null and b/pgplot_rhel7/pgncur.o differ diff --git a/pgplot_rhel7/pgncurse.o b/pgplot_rhel7/pgncurse.o new file mode 100644 index 0000000..54aac2e Binary files /dev/null and b/pgplot_rhel7/pgncurse.o differ diff --git a/pgplot_rhel7/pgnoto.o b/pgplot_rhel7/pgnoto.o new file mode 100644 index 0000000..e1885de Binary files /dev/null and b/pgplot_rhel7/pgnoto.o differ diff --git a/pgplot_rhel7/pgnpl.o b/pgplot_rhel7/pgnpl.o new file mode 100644 index 0000000..85b75e5 Binary files /dev/null and b/pgplot_rhel7/pgnpl.o differ diff --git a/pgplot_rhel7/pgnumb.o b/pgplot_rhel7/pgnumb.o new file mode 100644 index 0000000..d6e187f Binary files /dev/null and b/pgplot_rhel7/pgnumb.o differ diff --git a/pgplot_rhel7/pgolin.o b/pgplot_rhel7/pgolin.o new file mode 100644 index 0000000..7f90bc5 Binary files /dev/null and b/pgplot_rhel7/pgolin.o differ diff --git a/pgplot_rhel7/pgopen.o b/pgplot_rhel7/pgopen.o new file mode 100644 index 0000000..e950e48 Binary files /dev/null and b/pgplot_rhel7/pgopen.o differ diff --git a/pgplot_rhel7/pgpage.o b/pgplot_rhel7/pgpage.o new file mode 100644 index 0000000..7898fcb Binary files /dev/null and b/pgplot_rhel7/pgpage.o differ diff --git a/pgplot_rhel7/pgpanl.o b/pgplot_rhel7/pgpanl.o new file mode 100644 index 0000000..e8b86b9 Binary files /dev/null and b/pgplot_rhel7/pgpanl.o differ diff --git a/pgplot_rhel7/pgpap.o b/pgplot_rhel7/pgpap.o new file mode 100644 index 0000000..0689d52 Binary files /dev/null and b/pgplot_rhel7/pgpap.o differ diff --git a/pgplot_rhel7/pgpaper.o b/pgplot_rhel7/pgpaper.o new file mode 100644 index 0000000..c9ef612 Binary files /dev/null and b/pgplot_rhel7/pgpaper.o differ diff --git a/pgplot_rhel7/pgpixl.o b/pgplot_rhel7/pgpixl.o new file mode 100644 index 0000000..65a36e7 Binary files /dev/null and b/pgplot_rhel7/pgpixl.o differ diff --git a/pgplot_rhel7/pgplot.doc b/pgplot_rhel7/pgplot.doc new file mode 100644 index 0000000..cc7b5de --- /dev/null +++ b/pgplot_rhel7/pgplot.doc @@ -0,0 +1,3846 @@ +PGPLOT GRAPHICS SUBROUTINE LIBRARY Version 5.1 + +PGPLOT is a Fortran subroutine package for drawing graphs on a variety +of display devices. For more details, see the manual ``PGPLOT Graphics +Subroutine Library'' available from T. J. Pearson +(tjp@astro.caltech.edu). + +INDEX OF ROUTINES + +PGARRO -- draw an arrow +PGASK -- control new page prompting +PGAXIS -- draw an axis +PGBAND -- read cursor position, with anchor +PGBBUF -- begin batch of output (buffer) +PGBEG -- open a graphics device +PGBIN -- histogram of binned data +PGBOX -- draw labeled frame around viewport +PGCIRC -- draw a circle, using fill-area attributes +PGCLOS -- close the selected graphics device +PGCONB -- contour map of a 2D data array, with blanking +PGCONF -- fill between two contours +PGCONL -- label contour map of a 2D data array +PGCONS -- contour map of a 2D data array (fast algorithm) +PGCONT -- contour map of a 2D data array (contour-following) +PGCONX -- contour map of a 2D data array (non rectangular) +PGCTAB -- install the color table to be used by PGIMAG +PGCURS -- read cursor position +PGDRAW -- draw a line from the current pen position to a point +PGEBUF -- end batch of output (buffer) +PGEND -- close all open graphics devices +PGENV -- set window and viewport and draw labeled frame +PGERAS -- erase all graphics from current page +PGERR1 -- horizontal or vertical error bar +PGERRB -- horizontal or vertical error bar +PGERRX -- horizontal error bar +PGERRY -- vertical error bar +PGETXT -- erase text from graphics display +PGFUNT -- function defined by X = F(T), Y = G(T) +PGFUNX -- function defined by Y = F(X) +PGFUNY -- function defined by X = F(Y) +PGGRAY -- gray-scale map of a 2D data array +PGHI2D -- cross-sections through a 2D data array +PGHIST -- histogram of unbinned data +PGIDEN -- write username, date, and time at bottom of plot +PGIMAG -- color image from a 2D data array +PGLAB -- write labels for x-axis, y-axis, and top of plot +PGLCUR -- draw a line using the cursor +PGLDEV -- list available device types on standard output +PGLEN -- find length of a string in a variety of units +PGLINE -- draw a polyline (curve defined by line-segments) +PGMOVE -- move pen (change current pen position) +PGMTXT -- write text at position relative to viewport +PGNCUR -- mark a set of points using the cursor +PGNUMB -- convert a number into a plottable character string +PGOLIN -- mark a set of points using the cursor +PGOPEN -- open a graphics device +PGPAGE -- advance to new page +PGPANL -- switch to a different panel on the view surface +PGPAP -- change the size of the view surface +PGPIXL -- draw pixels +PGPNTS -- draw several graph markers, not all the same +PGPOLY -- draw a polygon, using fill-area attributes +PGPT -- draw several graph markers +PGPT1 -- draw one graph marker +PGPTXT -- write text at arbitrary position and angle +PGQAH -- inquire arrow-head style +PGQCF -- inquire character font +PGQCH -- inquire character height +PGQCI -- inquire color index +PGQCIR -- inquire color index range +PGQCLP -- inquire clipping status +PGQCOL -- inquire color capability +PGQCR -- inquire color representation +PGQCS -- inquire character height in a variety of units +PGQDT -- inquire name of nth available device type +PGQFS -- inquire fill-area style +PGQHS -- inquire hatching style +PGQID -- inquire current device identifier +PGQINF -- inquire PGPLOT general information +PGQITF -- inquire image transfer function +PGQLS -- inquire line style +PGQLW -- inquire line width +PGQNDT -- inquire number of available device types +PGQPOS -- inquire current pen position +PGQTBG -- inquire text background color index +PGQTXT -- find bounding box of text string +PGQVP -- inquire viewport size and position +PGQVSZ -- inquire size of view surface +PGQWIN -- inquire window boundary coordinates +PGRECT -- draw a rectangle, using fill-area attributes +PGRND -- find the smallest `round' number greater than x +PGRNGE -- choose axis limits +PGSAH -- set arrow-head style +PGSAVE -- save PGPLOT attributes +PGUNSA -- restore PGPLOT attributes +PGSCF -- set character font +PGSCH -- set character height +PGSCI -- set color index +PGSCIR -- set color index range +PGSCLP -- enable or disable clipping at edge of viewport +PGSCR -- set color representation +PGSCRL -- scroll window +PGSCRN -- set color representation by name +PGSFS -- set fill-area style +PGSHLS -- set color representation using HLS system +PGSHS -- set hatching style +PGSITF -- set image transfer function +PGSLCT -- select an open graphics device +PGSLS -- set line style +PGSLW -- set line width +PGSTBG -- set text background color index +PGSUBP -- subdivide view surface into panels +PGSVP -- set viewport (normalized device coordinates) +PGSWIN -- set window +PGTBOX -- draw frame and write (DD) HH MM SS.S labelling +PGTEXT -- write text (horizontal, left-justified) +PGTICK -- draw a single tick mark on an axis +PGUPDT -- update display +PGVECT -- vector map of a 2D data array, with blanking +PGVSIZ -- set viewport (inches) +PGVSTD -- set standard (default) viewport +PGWEDG -- annotate an image plot with a wedge +PGWNAD -- set window and adjust viewport to same aspect ratio +PGADVANCE -- non-standard alias for PGPAGE +PGBEGIN -- non-standard alias for PGBEG +PGCURSE -- non-standard alias for PGCURS +PGLABEL -- non-standard alias for PGLAB +PGMTEXT -- non-standard alias for PGMTXT +PGNCURSE -- non-standard alias for PGNCUR +PGPAPER -- non-standard alias for PGPAP +PGPOINT -- non-standard alias for PGPT +PGPTEXT -- non-standard alias for PGPTXT +PGVPORT -- non-standard alias for PGSVP +PGVSIZE -- non-standard alias for PGVSIZ +PGVSTAND -- non-standard alias for PGVSTD +PGWINDOW -- non-standard alias for PGSWIN + + +------------------------------------------------------------------------ +Module: PGARRO -- draw an arrow +------------------------------------------------------------------------ + + SUBROUTINE PGARRO (X1, Y1, X2, Y2) + REAL X1, Y1, X2, Y2 + +Draw an arrow from the point with world-coordinates (X1,Y1) to +(X2,Y2). The size of the arrowhead at (X2,Y2) is determined by +the current character size set by routine PGSCH. The default size +is 1/40th of the smaller of the width or height of the view surface. +The appearance of the arrowhead (shape and solid or open) is +controlled by routine PGSAH. + +Arguments: + X1, Y1 (input) : world coordinates of the tail of the arrow. + X2, Y2 (input) : world coordinates of the head of the arrow. + + +------------------------------------------------------------------------ +Module: PGASK -- control new page prompting +------------------------------------------------------------------------ + + SUBROUTINE PGASK (FLAG) + LOGICAL FLAG + +Change the ``prompt state'' of PGPLOT. If the prompt state is +ON, PGPAGE will type ``Type RETURN for next page:'' and will wait +for the user to type a carriage-return before starting a new page. +The initial prompt state (after the device has been opened) is ON +for interactive devices. Prompt state is always OFF for +non-interactive devices. + +Arguments: + FLAG (input) : if .TRUE., and if the device is an interactive + device, the prompt state will be set to ON. If + .FALSE., the prompt state will be set to OFF. + + +------------------------------------------------------------------------ +Module: PGAXIS -- draw an axis +------------------------------------------------------------------------ + + SUBROUTINE PGAXIS (OPT, X1, Y1, X2, Y2, V1, V2, STEP, NSUB, + : DMAJL, DMAJR, FMIN, DISP, ORIENT) + CHARACTER*(*) OPT + REAL X1, Y1, X2, Y2, V1, V2, STEP, DMAJL, DMAJR, FMIN, DISP + REAL ORIENT + INTEGER NSUB + +Draw a labelled graph axis from world-coordinate position (X1,Y1) to +(X2,Y2). + +Normally, this routine draws a standard LINEAR axis with equal +subdivisions. The quantity described by the axis runs from V1 to V2; +this may be, but need not be, the same as X or Y. + +If the 'L' option is specified, the routine draws a LOGARITHMIC axis. +In this case, the quantity described by the axis runs from 10**V1 to +10**V2. A logarithmic axis always has major, labeled, tick marks +spaced by one or more decades. If the major tick marks are spaced +by one decade (as specified by the STEP argument), then minor +tick marks are placed at 2, 3, .., 9 times each power of 10; +otherwise minor tick marks are spaced by one decade. If the axis +spans less than two decades, numeric labels are placed at 1, 2, and +5 times each power of ten. + +If the axis spans less than one decade, or if it spans many decades, +it is preferable to use a linear axis labeled with the logarithm of +the quantity of interest. + +Arguments: + OPT (input) : a string containing single-letter codes for + various options. The options currently + recognized are: + L : draw a logarithmic axis + N : write numeric labels + 1 : force decimal labelling, instead of automatic + choice (see PGNUMB). + 2 : force exponential labelling, instead of + automatic. + X1, Y1 (input) : world coordinates of one endpoint of the axis. + X2, Y2 (input) : world coordinates of the other endpoint of the axis. + V1 (input) : axis value at first endpoint. + V2 (input) : axis value at second endpoint. + STEP (input) : major tick marks are drawn at axis value 0.0 plus + or minus integer multiples of STEP. If STEP=0.0, + a value is chosen automatically. + NSUB (input) : minor tick marks are drawn to divide the major + divisions into NSUB equal subdivisions (ignored if + STEP=0.0). If NSUB <= 1, no minor tick marks are + drawn. NSUB is ignored for a logarithmic axis. + DMAJL (input) : length of major tick marks drawn to left of axis + (as seen looking from first endpoint to second), in + units of the character height. + DMAJR (input) : length of major tick marks drawn to right of axis, + in units of the character height. + FMIN (input) : length of minor tick marks, as fraction of major. + DISP (input) : displacement of baseline of tick labels to + right of axis, in units of the character height. + ORIENT (input) : orientation of label text, in degrees; angle between + baseline of text and direction of axis (0-360°). + + +------------------------------------------------------------------------ +Module: PGBAND -- read cursor position, with anchor +------------------------------------------------------------------------ + + INTEGER FUNCTION PGBAND (MODE, POSN, XREF, YREF, X, Y, CH) + INTEGER MODE, POSN + REAL XREF, YREF, X, Y + CHARACTER*(*) CH + +Read the cursor position and a character typed by the user. +The position is returned in world coordinates. PGBAND positions +the cursor at the position specified (if POSN=1), allows the user to +move the cursor using the mouse or arrow keys or whatever is available +on the device. When he has positioned the cursor, the user types a +single character on the keyboard; PGBAND then returns this +character and the new cursor position (in world coordinates). + +Some interactive devices offer a selection of cursor types, +implemented as thin lines that move with the cursor, but without +erasing underlying graphics. Of these types, some extend between +a stationary anchor-point at XREF,YREF, and the position of the +cursor, while others simply follow the cursor without changing shape +or size. The cursor type is specified with one of the following MODE +values. Cursor types that are not supported by a given device, are +treated as MODE=0. + +-- If MODE=0, the anchor point is ignored and the routine behaves +like PGCURS. +-- If MODE=1, a straight line is drawn joining the anchor point +and the cursor position. +-- If MODE=2, a hollow rectangle is extended as the cursor is moved, +with one vertex at the anchor point and the opposite vertex at the +current cursor position; the edges of the rectangle are horizontal +and vertical. +-- If MODE=3, two horizontal lines are extended across the width of +the display, one drawn through the anchor point and the other +through the moving cursor position. This could be used to select +a Y-axis range when one end of the range is known. +-- If MODE=4, two vertical lines are extended over the height of +the display, one drawn through the anchor point and the other +through the moving cursor position. This could be used to select an +X-axis range when one end of the range is known. +-- If MODE=5, a horizontal line is extended through the cursor +position over the width of the display. This could be used to select +an X-axis value such as the start of an X-axis range. The anchor point +is ignored. +-- If MODE=6, a vertical line is extended through the cursor +position over the height of the display. This could be used to select +a Y-axis value such as the start of a Y-axis range. The anchor point +is ignored. +-- If MODE=7, a cross-hair, centered on the cursor, is extended over +the width and height of the display. The anchor point is ignored. + +Returns: + PGBAND : 1 if the call was successful; 0 if the device + has no cursor or some other error occurs. +Arguments: + MODE (input) : display mode (0, 1, ..7: see above). + POSN (input) : if POSN=1, PGBAND attempts to place the cursor + at point (X,Y); if POSN=0, it leaves the cursor + at its current position. (On some devices this + request may be ignored.) + XREF (input) : the world x-coordinate of the anchor point. + YREF (input) : the world y-coordinate of the anchor point. + X (in/out) : the world x-coordinate of the cursor. + Y (in/out) : the world y-coordinate of the cursor. + CH (output) : the character typed by the user; if the device has + no cursor or if some other error occurs, the value + CHAR(0) [ASCII NUL character] is returned. + +Note: The cursor coordinates (X,Y) may be changed by PGBAND even if +the device has no cursor or if the user does not move the cursor. +Under these circumstances, the position returned in (X,Y) is that of +the pixel nearest to the requested position. + + +------------------------------------------------------------------------ +Module: PGBBUF -- begin batch of output (buffer) +------------------------------------------------------------------------ + + SUBROUTINE PGBBUF + +Begin saving graphical output commands in an internal buffer; the +commands are held until a matching PGEBUF call (or until the buffer +is emptied by PGUPDT). This can greatly improve the efficiency of +PGPLOT. PGBBUF increments an internal counter, while PGEBUF +decrements this counter and flushes the buffer to the output +device when the counter drops to zero. PGBBUF and PGEBUF calls +should always be paired. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGBEG -- open a graphics device +------------------------------------------------------------------------ + + INTEGER FUNCTION PGBEG (UNIT, FILE, NXSUB, NYSUB) + INTEGER UNIT + CHARACTER*(*) FILE + INTEGER NXSUB, NYSUB + +Note: new programs should use PGOPEN rather than PGBEG. PGOPEN +is retained for compatibility with existing programs. Unlike PGOPEN, +PGBEG closes any graphics devices that are already open, so it +cannot be used to open devices to be used in parallel. + +PGBEG opens a graphical device or file and prepares it for +subsequent plotting. A device must be opened with PGBEG or PGOPEN +before any other calls to PGPLOT subroutines for the device. + +If any device is already open for PGPLOT output, it is closed before +the new device is opened. + +Returns: + PGBEG : a status return value. A value of 1 indicates + successful completion, any other value indicates + an error. In the event of error a message is + written on the standard error unit. + To test the return value, call + PGBEG as a function, eg IER=PGBEG(...); note + that PGBEG must be declared INTEGER in the + calling program. Some Fortran compilers allow + you to use CALL PGBEG(...) and discard the + return value, but this is not standard Fortran. +Arguments: + UNIT (input) : this argument is ignored by PGBEG (use zero). + FILE (input) : the "device specification" for the plot device. + (For explanation, see description of PGOPEN.) + NXSUB (input) : the number of subdivisions of the view surface in + X (>0 or <0). + NYSUB (input) : the number of subdivisions of the view surface in + Y (>0). + PGPLOT puts NXSUB x NYSUB graphs on each plot + page or screen; when the view surface is sub- + divided in this way, PGPAGE moves to the next + panel, not the next physical page. If + NXSUB > 0, PGPLOT uses the panels in row + order; if <0, PGPLOT uses them in column order. + + +------------------------------------------------------------------------ +Module: PGBIN -- histogram of binned data +------------------------------------------------------------------------ + + SUBROUTINE PGBIN (NBIN, X, DATA, CENTER) + INTEGER NBIN + REAL X(*), DATA(*) + LOGICAL CENTER + +Plot a histogram of NBIN values with X(1..NBIN) values along +the ordinate, and DATA(1...NBIN) along the abscissa. Bin width is +spacing between X values. + +Arguments: + NBIN (input) : number of values. + X (input) : abscissae of bins. + DATA (input) : data values of bins. + CENTER (input) : if .TRUE., the X values denote the center of the + bin; if .FALSE., the X values denote the lower + edge (in X) of the bin. + + +------------------------------------------------------------------------ +Module: PGBOX -- draw labeled frame around viewport +------------------------------------------------------------------------ + + SUBROUTINE PGBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB) + CHARACTER*(*) XOPT, YOPT + REAL XTICK, YTICK + INTEGER NXSUB, NYSUB + +Annotate the viewport with frame, axes, numeric labels, etc. +PGBOX is called by on the user's behalf by PGENV, but may also be +called explicitly. + +Arguments: + XOPT (input) : string of options for X (horizontal) axis of + plot. Options are single letters, and may be in + any order (see below). + XTICK (input) : world coordinate interval between major tick marks + on X axis. If XTICK=0.0, the interval is chosen by + PGBOX, so that there will be at least 3 major tick + marks along the axis. + NXSUB (input) : the number of subintervals to divide the major + coordinate interval into. If XTICK=0.0 or NXSUB=0, + the number is chosen by PGBOX. + YOPT (input) : string of options for Y (vertical) axis of plot. + Coding is the same as for XOPT. + YTICK (input) : like XTICK for the Y axis. + NYSUB (input) : like NXSUB for the Y axis. + +Options (for parameters XOPT and YOPT): + A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical + line X=0). + B : draw bottom (X) or left (Y) edge of frame. + C : draw top (X) or right (Y) edge of frame. + G : draw Grid of vertical (X) or horizontal (Y) lines. + I : Invert the tick marks; ie draw them outside the viewport + instead of inside. + L : label axis Logarithmically (see below). + N : write Numeric labels in the conventional location below the + viewport (X) or to the left of the viewport (Y). + P : extend ("Project") major tick marks outside the box (ignored if + option I is specified). + M : write numeric labels in the unconventional location above the + viewport (X) or to the right of the viewport (Y). + T : draw major Tick marks at the major coordinate interval. + S : draw minor tick marks (Subticks). + V : orient numeric labels Vertically. This is only applicable to Y. + The default is to write Y-labels parallel to the axis. + 1 : force decimal labelling, instead of automatic choice (see PGNUMB). + 2 : force exponential labelling, instead of automatic. + +To get a complete frame, specify BC in both XOPT and YOPT. +Tick marks, if requested, are drawn on the axes or frame +or both, depending which are requested. If none of ABC is specified, +tick marks will not be drawn. When PGENV calls PGBOX, it sets both +XOPT and YOPT according to the value of its parameter AXIS: +-1: 'BC', 0: 'BCNST', 1: 'ABCNST', 2: 'ABCGNST'. + +For a logarithmic axis, the major tick interval is always 1.0. The +numeric label is 10**(x) where x is the world coordinate at the +tick mark. If subticks are requested, 8 subticks are drawn between +each major tick at equal logarithmic intervals. + +To label an axis with time (days, hours, minutes, seconds) or +angle (degrees, arcmin, arcsec), use routine PGTBOX. + + +------------------------------------------------------------------------ +Module: PGCIRC -- draw a circle, using fill-area attributes +------------------------------------------------------------------------ + + SUBROUTINE PGCIRC (XCENT, YCENT, RADIUS) + REAL XCENT, YCENT, RADIUS + +Draw a circle. The action of this routine depends +on the setting of the Fill-Area Style attribute. If Fill-Area Style +is SOLID (the default), the interior of the circle is solid-filled +using the current Color Index. If Fill-Area Style is HOLLOW, the +outline of the circle is drawn using the current line attributes +(color index, line-style, and line-width). + +Arguments: + XCENT (input) : world x-coordinate of the center of the circle. + YCENT (input) : world y-coordinate of the center of the circle. + RADIUS (input) : radius of circle (world coordinates). + + +------------------------------------------------------------------------ +Module: PGCLOS -- close the selected graphics device +------------------------------------------------------------------------ + + SUBROUTINE PGCLOS + +Close the currently selected graphics device. After the device has +been closed, either another open device must be selected with PGSLCT +or another device must be opened with PGOPEN before any further +plotting can be done. If the call to PGCLOS is omitted, some or all +of the plot may be lost. + +[This routine was added to PGPLOT in Version 5.1.0. Older programs +use PGEND instead.] + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGCONB -- contour map of a 2D data array, with blanking +------------------------------------------------------------------------ + + SUBROUTINE PGCONB (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR, + 1 BLANK) + INTEGER IDIM, JDIM, I1, I2, J1, J2, NC + REAL A(IDIM,JDIM), C(*), TR(6), BLANK + +Draw a contour map of an array. This routine is the same as PGCONS, +except that array elements that have the "magic value" defined by +argument BLANK are ignored, making gaps in the contour map. The +routine may be useful for data measured on most but not all of the +points of a grid. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1,I2 (input) : range of first index to be contoured (inclusive). + J1,J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of contour levels (in the same units as the + data in array A); dimension at least NC. + NC (input) : number of contour levels (less than or equal to + dimension of C). The absolute value of this + argument is used (for compatibility with PGCONT, + where the sign of NC is significant). + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + BLANK (input) : elements of array A that are exactly equal to + this value are ignored (blanked). + + +------------------------------------------------------------------------ +Module: PGCONF -- fill between two contours +------------------------------------------------------------------------ + + SUBROUTINE PGCONF (A, IDIM, JDIM, I1, I2, J1, J2, C1, C2, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + REAL A(IDIM,JDIM), C1, C2, TR(6) + +Shade the region between two contour levels of a function defined on +the nodes of a rectangular grid. The routine uses the current fill +attributes, hatching style (if appropriate), and color index. + +If you want to both shade between contours and draw the contour +lines, call this routine first (once for each pair of levels) and +then CALL PGCONT (or PGCONS) to draw the contour lines on top of the +shading. + +Note 1: This routine is not very efficient: it generates a polygon +fill command for each cell of the mesh that intersects the desired +area, rather than consolidating adjacent cells into a single polygon. + +Note 2: If both contours intersect all four edges of a particular +mesh cell, the program behaves badly and may consider some parts +of the cell to lie in more than one contour range. + +Note 3: If a contour crosses all four edges of a cell, this +routine may not generate the same contours as PGCONT or PGCONS +(these two routines may not agree either). Such cases are always +ambiguous and the routines use different approaches to resolving +the ambiguity. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1,I2 (input) : range of first index to be contoured (inclusive). + J1,J2 (input) : range of second index to be contoured (inclusive). + C1, C2 (input) : contour levels; note that C1 must be less than C2. + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + + +------------------------------------------------------------------------ +Module: PGCONL -- label contour map of a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGCONL (A, IDIM, JDIM, I1, I2, J1, J2, C, TR, + 1 LABEL, INTVAL, MININT) + INTEGER IDIM, JDIM, I1, J1, I2, J2, INTVAL, MININT + REAL A(IDIM,JDIM), C, TR(6) + CHARACTER*(*) LABEL + +Label a contour map drawn with routine PGCONT. Routine PGCONT should +be called first to draw the contour lines, then this routine should be +called to add the labels. Labels are written at intervals along the +contour lines, centered on the contour lines with lettering aligned +in the up-hill direction. Labels are opaque, so a part of the under- +lying contour line is obscured by the label. Labels use the current +attributes (character height, line width, color index, character +font). + +The first 9 arguments are the same as those supplied to PGCONT, and +should normally be identical to those used with PGCONT. Note that +only one contour level can be specified; tolabel more contours, call +PGCONL for each level. + +The Label is supplied as a character string in argument LABEL. + +The spacing of labels along the contour is specified by parameters +INTVAL and MININT. The routine follows the contour through the +array, counting the number of cells that the contour crosses. The +first label will be written in the MININT'th cell, and additional +labels will be written every INTVAL cells thereafter. A contour +that crosses less than MININT cells will not be labelled. Some +experimentation may be needed to get satisfactory results; a good +place to start is INTVAL=20, MININT=10. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1, I2 (input) : range of first index to be contoured (inclusive). + J1, J2 (input) : range of second index to be contoured (inclusive). + C (input) : the level of the contour to be labelled (one of the + values given to PGCONT). + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. + The world coordinates of the array point A(I,J) + are given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation or + shear. + LABEL (input) : character strings to be used to label the specified + contour. Leading and trailing blank spaces are + ignored. + INTVAL (input) : spacing along the contour between labels, in + grid cells. + MININT (input) : contours that cross less than MININT cells + will not be labelled. + + +------------------------------------------------------------------------ +Module: PGCONS -- contour map of a 2D data array (fast algorithm) +------------------------------------------------------------------------ + + SUBROUTINE PGCONS (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2, NC + REAL A(IDIM,JDIM), C(*), TR(6) + +Draw a contour map of an array. The map is truncated if +necessary at the boundaries of the viewport. Each contour line is +drawn with the current line attributes (color index, style, and +width). This routine, unlike PGCONT, does not draw each contour as a +continuous line, but draws the straight line segments composing each +contour in a random order. It is thus not suitable for use on pen +plotters, and it usually gives unsatisfactory results with dashed or +dotted lines. It is, however, faster than PGCONT, especially if +several contour levels are drawn with one call of PGCONS. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1,I2 (input) : range of first index to be contoured (inclusive). + J1,J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of contour levels (in the same units as the + data in array A); dimension at least NC. + NC (input) : number of contour levels (less than or equal to + dimension of C). The absolute value of this + argument is used (for compatibility with PGCONT, + where the sign of NC is significant). + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + + +------------------------------------------------------------------------ +Module: PGCONT -- contour map of a 2D data array (contour-following) +------------------------------------------------------------------------ + + SUBROUTINE PGCONT (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR) + INTEGER IDIM, JDIM, I1, J1, I2, J2, NC + REAL A(IDIM,JDIM), C(*), TR(6) + +Draw a contour map of an array. The map is truncated if +necessary at the boundaries of the viewport. Each contour line +is drawn with the current line attributes (color index, style, and +width); except that if argument NC is positive (see below), the line +style is set by PGCONT to 1 (solid) for positive contours or 2 +(dashed) for negative contours. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1, I2 (input) : range of first index to be contoured (inclusive). + J1, J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of NC contour levels; dimension at least NC. + NC (input) : +/- number of contour levels (less than or equal + to dimension of C). If NC is positive, it is the + number of contour levels, and the line-style is + chosen automatically as described above. If NC is + negative, it is minus the number of contour + levels, and the current setting of line-style is + used for all the contours. + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. + The world coordinates of the array point A(I,J) + are given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation or + shear. + + +------------------------------------------------------------------------ +Module: PGCONX -- contour map of a 2D data array (non rectangular) +------------------------------------------------------------------------ + + SUBROUTINE PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, PLOT) + INTEGER IDIM, JDIM, I1, J1, I2, J2, NC + REAL A(IDIM,JDIM), C(*) + EXTERNAL PLOT + +Draw a contour map of an array using a user-supplied plotting +routine. This routine should be used instead of PGCONT when the +data are defined on a non-rectangular grid. PGCONT permits only +a linear transformation between the (I,J) grid of the array +and the world coordinate system (x,y), but PGCONX permits any +transformation to be used, the transformation being defined by a +user-supplied subroutine. The nature of the contouring algorithm, +however, dictates that the transformation should maintain the +rectangular topology of the grid, although grid-points may be +allowed to coalesce. As an example of a deformed rectangular +grid, consider data given on the polar grid theta=0.1n(pi/2), +for n=0,1,...,10, and r=0.25m, for m=0,1,..,4. This grid +contains 55 points, of which 11 are coincident at the origin. +The input array for PGCONX should be dimensioned (11,5), and +data values should be provided for all 55 elements. PGCONX can +also be used for special applications in which the height of the +contour affects its appearance, e.g., stereoscopic views. + +The map is truncated if necessary at the boundaries of the viewport. +Each contour line is drawn with the current line attributes (color +index, style, and width); except that if argument NC is positive +(see below), the line style is set by PGCONX to 1 (solid) for +positive contours or 2 (dashed) for negative contours. Attributes +for the contour lines can also be set in the user-supplied +subroutine, if desired. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1, I2 (input) : range of first index to be contoured (inclusive). + J1, J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of NC contour levels; dimension at least NC. + NC (input) : +/- number of contour levels (less than or equal + to dimension of C). If NC is positive, it is the + number of contour levels, and the line-style is + chosen automatically as described above. If NC is + negative, it is minus the number of contour + levels, and the current setting of line-style is + used for all the contours. + PLOT (input) : the address (name) of a subroutine supplied by + the user, which will be called by PGCONX to do + the actual plotting. This must be declared + EXTERNAL in the program unit calling PGCONX. + +The subroutine PLOT will be called with four arguments: + CALL PLOT(VISBLE,X,Y,Z) +where X,Y (input) are real variables corresponding to +I,J indices of the array A. If VISBLE (input, integer) is 1, +PLOT should draw a visible line from the current pen +position to the world coordinate point corresponding to (X,Y); +if it is 0, it should move the pen to (X,Y). Z is the value +of the current contour level, and may be used by PLOT if desired. +Example: + SUBROUTINE PLOT (VISBLE,X,Y,Z) + REAL X, Y, Z, XWORLD, YWORLD + INTEGER VISBLE + XWORLD = X*COS(Y) ! this is the user-defined + YWORLD = X*SIN(Y) ! transformation + IF (VISBLE.EQ.0) THEN + CALL PGMOVE (XWORLD, YWORLD) + ELSE + CALL PGDRAW (XWORLD, YWORLD) + END IF + END + + +------------------------------------------------------------------------ +Module: PGCTAB -- install the color table to be used by PGIMAG +------------------------------------------------------------------------ + + SUBROUTINE PGCTAB(L, R, G, B, NC, CONTRA, BRIGHT) + INTEGER NC + REAL L(NC), R(NC), G(NC), B(NC), CONTRA, BRIGHT + +Use the given color table to change the color representations of +all color indexes marked for use by PGIMAG. To change which +color indexes are thus marked, call PGSCIR before calling PGCTAB +or PGIMAG. On devices that can change the color representations +of previously plotted graphics, PGCTAB will also change the colors +of existing graphics that were plotted with the marked color +indexes. This feature can then be combined with PGBAND to +interactively manipulate the displayed colors of data previously +plotted with PGIMAG. + +Limitations: + 1. Some devices do not propagate color representation changes + to previously drawn graphics. + 2. Some devices ignore requests to change color representations. + 3. The appearance of specific color representations on grey-scale + devices is device-dependent. + +Notes: + To reverse the sense of a color table, change the chosen contrast + and brightness to -CONTRA and 1-BRIGHT. + + In the following, the term 'color table' refers to the input + L,R,G,B arrays, whereas 'color ramp' refers to the resulting + ramp of colors that would be seen with PGWEDG. + +Arguments: + L (input) : An array of NC normalized ramp-intensity levels + corresponding to the RGB primary color intensities + in R(),G(),B(). Colors on the ramp are linearly + interpolated from neighbouring levels. + Levels must be sorted in increasing order. + 0.0 places a color at the beginning of the ramp. + 1.0 places a color at the end of the ramp. + Colors outside these limits are legal, but will + not be visible if CONTRA=1.0 and BRIGHT=0.5. + R (input) : An array of NC normalized red intensities. + G (input) : An array of NC normalized green intensities. + B (input) : An array of NC normalized blue intensities. + NC (input) : The number of color table entries. + CONTRA (input) : The contrast of the color ramp (normally 1.0). + Negative values reverse the direction of the ramp. + BRIGHT (input) : The brightness of the color ramp. This is normally + 0.5, but can sensibly hold any value between 0.0 + and 1.0. Values at or beyond the latter two + extremes, saturate the color ramp with the colors + of the respective end of the color table. + + +------------------------------------------------------------------------ +Module: PGCURS -- read cursor position +------------------------------------------------------------------------ + + INTEGER FUNCTION PGCURS (X, Y, CH) + REAL X, Y + CHARACTER*(*) CH + +Read the cursor position and a character typed by the user. +The position is returned in world coordinates. PGCURS positions +the cursor at the position specified, allows the user to move the +cursor using the joystick or arrow keys or whatever is available on +the device. When he has positioned the cursor, the user types a +single character on the keyboard; PGCURS then returns this +character and the new cursor position (in world coordinates). + +Returns: + PGCURS : 1 if the call was successful; 0 if the device + has no cursor or some other error occurs. +Arguments: + X (in/out) : the world x-coordinate of the cursor. + Y (in/out) : the world y-coordinate of the cursor. + CH (output) : the character typed by the user; if the device has + no cursor or if some other error occurs, the value + CHAR(0) [ASCII NUL character] is returned. + +Note: The cursor coordinates (X,Y) may be changed by PGCURS even if +the device has no cursor or if the user does not move the cursor. +Under these circumstances, the position returned in (X,Y) is that of +the pixel nearest to the requested position. + + +------------------------------------------------------------------------ +Module: PGDRAW -- draw a line from the current pen position to a point +------------------------------------------------------------------------ + + SUBROUTINE PGDRAW (X, Y) + REAL X, Y + +Draw a line from the current pen position to the point +with world-coordinates (X,Y). The line is clipped at the edge of the +current window. The new pen position is (X,Y) in world coordinates. + +Arguments: + X (input) : world x-coordinate of the end point of the line. + Y (input) : world y-coordinate of the end point of the line. + + +------------------------------------------------------------------------ +Module: PGEBUF -- end batch of output (buffer) +------------------------------------------------------------------------ + + SUBROUTINE PGEBUF + +A call to PGEBUF marks the end of a batch of graphical output begun +with the last call of PGBBUF. PGBBUF and PGEBUF calls should always +be paired. Each call to PGBBUF increments a counter, while each call +to PGEBUF decrements the counter. When the counter reaches 0, the +batch of output is written on the output device. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGEND -- close all open graphics devices +------------------------------------------------------------------------ + + SUBROUTINE PGEND + +Close and release any open graphics devices. All devices must be +closed by calling either PGCLOS (for each device) or PGEND before +the program terminates. If a device is not closed properly, some +or all of the graphical output may be lost. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGENV -- set window and viewport and draw labeled frame +------------------------------------------------------------------------ + + SUBROUTINE PGENV (XMIN, XMAX, YMIN, YMAX, JUST, AXIS) + REAL XMIN, XMAX, YMIN, YMAX + INTEGER JUST, AXIS + +Set PGPLOT "Plotter Environment". PGENV establishes the scaling +for subsequent calls to PGPT, PGLINE, etc. The plotter is +advanced to a new page or panel, clearing the screen if necessary. +If the "prompt state" is ON (see PGASK), confirmation +is requested from the user before clearing the screen. +If requested, a box, axes, labels, etc. are drawn according to +the setting of argument AXIS. + +Arguments: + XMIN (input) : the world x-coordinate at the bottom left corner + of the viewport. + XMAX (input) : the world x-coordinate at the top right corner + of the viewport (note XMAX may be less than XMIN). + YMIN (input) : the world y-coordinate at the bottom left corner + of the viewport. + YMAX (input) : the world y-coordinate at the top right corner + of the viewport (note YMAX may be less than YMIN). + JUST (input) : if JUST=1, the scales of the x and y axes (in + world coordinates per inch) will be equal, + otherwise they will be scaled independently. + AXIS (input) : controls the plotting of axes, tick marks, etc: + AXIS = -2 : draw no box, axes or labels; + AXIS = -1 : draw box only; + AXIS = 0 : draw box and label it with coordinates; + AXIS = 1 : same as AXIS=0, but also draw the + coordinate axes (X=0, Y=0); + AXIS = 2 : same as AXIS=1, but also draw grid lines + at major increments of the coordinates; + AXIS = 10 : draw box and label X-axis logarithmically; + AXIS = 20 : draw box and label Y-axis logarithmically; + AXIS = 30 : draw box and label both axes logarithmically. + +For other axis options, use routine PGBOX. PGENV can be persuaded to +call PGBOX with additional axis options by defining an environment +parameter PGPLOT_ENVOPT containing the required option codes. +Examples: + PGPLOT_ENVOPT=P ! draw Projecting tick marks + PGPLOT_ENVOPT=I ! Invert the tick marks + PGPLOT_ENVOPT=IV ! Invert tick marks and label y Vertically + + +------------------------------------------------------------------------ +Module: PGERAS -- erase all graphics from current page +------------------------------------------------------------------------ + + SUBROUTINE PGERAS + +Erase all graphics from the current page (or current panel, if +the view surface has been divided into panels with PGSUBP). + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGERR1 -- horizontal or vertical error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERR1 (DIR, X, Y, E, T) + INTEGER DIR + REAL X, Y, E + REAL T + +Plot a single error bar in the direction specified by DIR. +This routine draws an error bar only; to mark the data point at +the start of the error bar, an additional call to PGPT is required. +To plot many error bars, use PGERRB. + +Arguments: + DIR (input) : direction to plot the error bar relative to + the data point. + One-sided error bar: + DIR is 1 for +X (X to X+E); + 2 for +Y (Y to Y+E); + 3 for -X (X to X-E); + 4 for -Y (Y to Y-E). + Two-sided error bar: + DIR is 5 for +/-X (X-E to X+E); + 6 for +/-Y (Y-E to Y+E). + X (input) : world x-coordinate of the data. + Y (input) : world y-coordinate of the data. + E (input) : value of error bar distance to be added to the + data position in world coordinates. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + + +------------------------------------------------------------------------ +Module: PGERRB -- horizontal or vertical error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERRB (DIR, N, X, Y, E, T) + INTEGER DIR, N + REAL X(*), Y(*), E(*) + REAL T + +Plot error bars in the direction specified by DIR. +This routine draws an error bar only; to mark the data point at +the start of the error bar, an additional call to PGPT is required. + +Arguments: + DIR (input) : direction to plot the error bar relative to + the data point. + One-sided error bar: + DIR is 1 for +X (X to X+E); + 2 for +Y (Y to Y+E); + 3 for -X (X to X-E); + 4 for -Y (Y to Y-E). + Two-sided error bar: + DIR is 5 for +/-X (X-E to X+E); + 6 for +/-Y (Y-E to Y+E). + N (input) : number of error bars to plot. + X (input) : world x-coordinates of the data. + Y (input) : world y-coordinates of the data. + E (input) : value of error bar distance to be added to the + data position in world coordinates. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + +Note: the dimension of arrays X, Y, and E must be greater +than or equal to N. If N is 1, X, Y, and E may be scalar +variables, or expressions. + + +------------------------------------------------------------------------ +Module: PGERRX -- horizontal error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERRX (N, X1, X2, Y, T) + INTEGER N + REAL X1(*), X2(*), Y(*) + REAL T + +Plot horizontal error bars. +This routine draws an error bar only; to mark the data point in +the middle of the error bar, an additional call to PGPT or +PGERRY is required. + +Arguments: + N (input) : number of error bars to plot. + X1 (input) : world x-coordinates of lower end of the + error bars. + X2 (input) : world x-coordinates of upper end of the + error bars. + Y (input) : world y-coordinates of the data. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + +Note: the dimension of arrays X1, X2, and Y must be greater +than or equal to N. If N is 1, X1, X2, and Y may be scalar +variables, or expressions, eg: + CALL PGERRX(1,X-SIGMA,X+SIGMA,Y) + + +------------------------------------------------------------------------ +Module: PGERRY -- vertical error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERRY (N, X, Y1, Y2, T) + INTEGER N + REAL X(*), Y1(*), Y2(*) + REAL T + +Plot vertical error bars. +This routine draws an error bar only; to mark the data point in +the middle of the error bar, an additional call to PGPT or +PGERRX is required. + +Arguments: + N (input) : number of error bars to plot. + X (input) : world x-coordinates of the data. + Y1 (input) : world y-coordinates of top end of the + error bars. + Y2 (input) : world y-coordinates of bottom end of the + error bars. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + +Note: the dimension of arrays X, Y1, and Y2 must be greater +than or equal to N. If N is 1, X, Y1, and Y2 may be scalar +variables or expressions, eg: + CALL PGERRY(1,X,Y+SIGMA,Y-SIGMA) + + +------------------------------------------------------------------------ +Module: PGETXT -- erase text from graphics display +------------------------------------------------------------------------ + + SUBROUTINE PGETXT + +Some graphics terminals display text (the normal interactive dialog) +on the same screen as graphics. This routine erases the text from the +view surface without affecting the graphics. It does nothing on +devices which do not display text on the graphics screen, and on +devices which do not have this capability. + +Arguments: + None + + +------------------------------------------------------------------------ +Module: PGFUNT -- function defined by X = F(T), Y = G(T) +------------------------------------------------------------------------ + + SUBROUTINE PGFUNT (FX, FY, N, TMIN, TMAX, PGFLAG) + REAL FX, FY + EXTERNAL FX, FY + INTEGER N + REAL TMIN, TMAX + INTEGER PGFLAG + +Draw a curve defined by parametric equations X = FX(T), Y = FY(T). + +Arguments: + FX (external real function): supplied by the user, evaluates + X-coordinate. + FY (external real function): supplied by the user, evaluates + Y-coordinate. + N (input) : the number of points required to define the + curve. The functions FX and FY will each be + called N+1 times. + TMIN (input) : the minimum value for the parameter T. + TMAX (input) : the maximum value for the parameter T. + PGFLAG (input) : if PGFLAG = 1, the curve is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGFUNT to + start a new plot with automatic scaling. + +Note: The functions FX and FY must be declared EXTERNAL in the +Fortran program unit that calls PGFUNT. + + +------------------------------------------------------------------------ +Module: PGFUNX -- function defined by Y = F(X) +------------------------------------------------------------------------ + + SUBROUTINE PGFUNX (FY, N, XMIN, XMAX, PGFLAG) + REAL FY + EXTERNAL FY + INTEGER N + REAL XMIN, XMAX + INTEGER PGFLAG + +Draw a curve defined by the equation Y = FY(X), where FY is a +user-supplied subroutine. + +Arguments: + FY (external real function): supplied by the user, evaluates + Y value at a given X-coordinate. + N (input) : the number of points required to define the + curve. The function FY will be called N+1 times. + If PGFLAG=0 and N is greater than 1000, 1000 + will be used instead. If N is less than 1, + nothing will be drawn. + XMIN (input) : the minimum value of X. + XMAX (input) : the maximum value of X. + PGFLAG (input) : if PGFLAG = 1, the curve is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGFUNX to + start a new plot with X limits (XMIN, XMAX) + and automatic scaling in Y. + +Note: The function FY must be declared EXTERNAL in the Fortran +program unit that calls PGFUNX. It has one argument, the +x-coordinate at which the y value is required, e.g. + REAL FUNCTION FY(X) + REAL X + FY = ..... + END + + +------------------------------------------------------------------------ +Module: PGFUNY -- function defined by X = F(Y) +------------------------------------------------------------------------ + + SUBROUTINE PGFUNY (FX, N, YMIN, YMAX, PGFLAG) + REAL FX + EXTERNAL FX + INTEGER N + REAL YMIN, YMAX + INTEGER PGFLAG + +Draw a curve defined by the equation X = FX(Y), where FY is a +user-supplied subroutine. + +Arguments: + FX (external real function): supplied by the user, evaluates + X value at a given Y-coordinate. + N (input) : the number of points required to define the + curve. The function FX will be called N+1 times. + If PGFLAG=0 and N is greater than 1000, 1000 + will be used instead. If N is less than 1, + nothing will be drawn. + YMIN (input) : the minimum value of Y. + YMAX (input) : the maximum value of Y. + PGFLAG (input) : if PGFLAG = 1, the curve is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGFUNY to + start a new plot with Y limits (YMIN, YMAX) + and automatic scaling in X. + +Note: The function FX must be declared EXTERNAL in the Fortran +program unit that calls PGFUNY. It has one argument, the +y-coordinate at which the x value is required, e.g. + REAL FUNCTION FX(Y) + REAL Y + FX = ..... + END + + +------------------------------------------------------------------------ +Module: PGGRAY -- gray-scale map of a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGGRAY (A, IDIM, JDIM, I1, I2, J1, J2, + 1 FG, BG, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + REAL A(IDIM,JDIM), FG, BG, TR(6) + +Draw gray-scale map of an array in current window. The subsection +of the array A defined by indices (I1:I2, J1:J2) is mapped onto +the view surface world-coordinate system by the transformation +matrix TR. The resulting quadrilateral region is clipped at the edge +of the window and shaded with the shade at each point determined +by the corresponding array value. The shade is a number in the +range 0 to 1 obtained by linear interpolation between the background +level (BG) and the foreground level (FG), i.e., + + shade = [A(i,j) - BG] / [FG - BG] + +The background level BG can be either less than or greater than the +foreground level FG. Points in the array that are outside the range +BG to FG are assigned shade 0 or 1 as appropriate. + +PGGRAY uses two different algorithms, depending how many color +indices are available in the color index range specified for images. +(This range is set with routine PGSCIR, and the current or default +range can be queried by calling routine PGQCIR). + +If 16 or more color indices are available, PGGRAY first assigns +color representations to these color indices to give a linear ramp +between the background color (color index 0) and the foreground color +(color index 1), and then calls PGIMAG to draw the image using these +color indices. In this mode, the shaded region is "opaque": every +pixel is assigned a color. + +If less than 16 color indices are available, PGGRAY uses only +color index 1, and uses a "dithering" algorithm to fill in pixels, +with the shade (computed as above) determining the faction of pixels +that are filled. In this mode the shaded region is "transparent" and +allows previously-drawn graphics to show through. + +The transformation matrix TR is used to calculate the world +coordinates of the center of the "cell" that represents each +array element. The world coordinates of the center of the cell +corresponding to array element A(I,J) are given by: + + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + +Usually TR(3) and TR(5) are zero -- unless the coordinate +transformation involves a rotation or shear. The corners of the +quadrilateral region that is shaded by PGGRAY are given by +applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5). + +Arguments: + A (input) : the array to be plotted. + IDIM (input) : the first dimension of array A. + JDIM (input) : the second dimension of array A. + I1, I2 (input) : the inclusive range of the first index + (I) to be plotted. + J1, J2 (input) : the inclusive range of the second + index (J) to be plotted. + FG (input) : the array value which is to appear with the + foreground color (corresponding to color index 1). + BG (input) : the array value which is to appear with the + background color (corresponding to color index 0). + TR (input) : transformation matrix between array grid and + world coordinates. + + +------------------------------------------------------------------------ +Module: PGHI2D -- cross-sections through a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGHI2D (DATA, NXV, NYV, IX1, IX2, IY1, IY2, X, IOFF, + 1 BIAS, CENTER, YLIMS) + INTEGER NXV, NYV, IX1, IX2, IY1, IY2 + REAL DATA(NXV,NYV) + REAL X(IX2-IX1+1), YLIMS(IX2-IX1+1) + INTEGER IOFF + REAL BIAS + LOGICAL CENTER + +Plot a series of cross-sections through a 2D data array. +Each cross-section is plotted as a hidden line histogram. The plot +can be slanted to give a pseudo-3D effect - if this is done, the +call to PGENV may have to be changed to allow for the increased X +range that will be needed. + +Arguments: + DATA (input) : the data array to be plotted. + NXV (input) : the first dimension of DATA. + NYV (input) : the second dimension of DATA. + IX1 (input) + IX2 (input) + IY1 (input) + IY2 (input) : PGHI2D plots a subset of the input array DATA. + This subset is delimited in the first (x) + dimension by IX1 and IX2 and the 2nd (y) by IY1 + and IY2, inclusively. Note: IY2 < IY1 is + permitted, resulting in a plot with the + cross-sections plotted in reverse Y order. + However, IX2 must be => IX1. + X (input) : the abscissae of the bins to be plotted. That is, + X(1) should be the X value for DATA(IX1,IY1), and + X should have (IX2-IX1+1) elements. The program + has to assume that the X value for DATA(x,y) is + the same for all y. + IOFF (input) : an offset in array elements applied to successive + cross-sections to produce a slanted effect. A + plot with IOFF > 0 slants to the right, one with + IOFF < 0 slants left. + BIAS (input) : a bias value applied to each successive cross- + section in order to raise it above the previous + cross-section. This is in the same units as the + data. + CENTER (input) : if .true., the X values denote the center of the + bins; if .false. the X values denote the lower + edges (in X) of the bins. + YLIMS (input) : workspace. Should be an array of at least + (IX2-IX1+1) elements. + + +------------------------------------------------------------------------ +Module: PGHIST -- histogram of unbinned data +------------------------------------------------------------------------ + + SUBROUTINE PGHIST(N, DATA, DATMIN, DATMAX, NBIN, PGFLAG) + INTEGER N + REAL DATA(*) + REAL DATMIN, DATMAX + INTEGER NBIN, PGFLAG + +Draw a histogram of N values of a variable in array +DATA(1...N) in the range DATMIN to DATMAX using NBIN bins. Note +that array elements which fall exactly on the boundary between +two bins will be counted in the higher bin rather than the +lower one; and array elements whose value is less than DATMIN or +greater than or equal to DATMAX will not be counted at all. + +Arguments: + N (input) : the number of data values. + DATA (input) : the data values. Note: the dimension of array + DATA must be greater than or equal to N. The + first N elements of the array are used. + DATMIN (input) : the minimum data value for the histogram. + DATMAX (input) : the maximum data value for the histogram. + NBIN (input) : the number of bins to use: the range DATMIN to + DATMAX is divided into NBIN equal bins and + the number of DATA values in each bin is + determined by PGHIST. NBIN may not exceed 200. + PGFLAG (input) : if PGFLAG = 1, the histogram is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGHIST to start + a new plot (the x-limits of the window will be + DATMIN and DATMAX; the y-limits will be chosen + automatically. + IF PGFLAG = 2,3 the histogram will be in the same + window and viewport but with a filled area style. + If pgflag=4,5 as for pgflag = 0,1, but simple + line drawn as for PGBIN + + + +------------------------------------------------------------------------ +Module: PGIDEN -- write username, date, and time at bottom of plot +------------------------------------------------------------------------ + + SUBROUTINE PGIDEN + +Write username, date, and time at bottom of plot. + +Arguments: none. + + +------------------------------------------------------------------------ +Module: PGIMAG -- color image from a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGIMAG (A, IDIM, JDIM, I1, I2, J1, J2, + 1 A1, A2, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + REAL A(IDIM,JDIM), A1, A2, TR(6) + +Draw a color image of an array in current window. The subsection +of the array A defined by indices (I1:I2, J1:J2) is mapped onto +the view surface world-coordinate system by the transformation +matrix TR. The resulting quadrilateral region is clipped at the edge +of the window. Each element of the array is represented in the image +by a small quadrilateral, which is filled with a color specified by +the corresponding array value. + +The subroutine uses color indices in the range C1 to C2, which can +be specified by calling PGSCIR before PGIMAG. The default values +for C1 and C2 are device-dependent; these values can be determined by +calling PGQCIR. Note that color representations should be assigned to +color indices C1 to C2 by calling PGSCR before calling PGIMAG. On some +devices (but not all), the color representation can be changed after +the call to PGIMAG by calling PGSCR again. + +Array values in the range A1 to A2 are mapped on to the range of +color indices C1 to C2, with array values <= A1 being given color +index C1 and values >= A2 being given color index C2. The mapping +function for intermediate array values can be specified by +calling routine PGSITF before PGIMAG; the default is linear. + +On devices which have no available color indices (C1 > C2), +PGIMAG will return without doing anything. On devices with only +one color index (C1=C2), all array values map to the same color +which is rather uninteresting. An image is always "opaque", +i.e., it obscures all graphical elements previously drawn in +the region. + +The transformation matrix TR is used to calculate the world +coordinates of the center of the "cell" that represents each +array element. The world coordinates of the center of the cell +corresponding to array element A(I,J) are given by: + + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + +Usually TR(3) and TR(5) are zero -- unless the coordinate +transformation involves a rotation or shear. The corners of the +quadrilateral region that is shaded by PGIMAG are given by +applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5). + +Arguments: + A (input) : the array to be plotted. + IDIM (input) : the first dimension of array A. + JDIM (input) : the second dimension of array A. + I1, I2 (input) : the inclusive range of the first index + (I) to be plotted. + J1, J2 (input) : the inclusive range of the second + index (J) to be plotted. + A1 (input) : the array value which is to appear with shade C1. + A2 (input) : the array value which is to appear with shade C2. + TR (input) : transformation matrix between array grid and + world coordinates. + + +------------------------------------------------------------------------ +Module: PGLAB -- write labels for x-axis, y-axis, and top of plot +------------------------------------------------------------------------ + + SUBROUTINE PGLAB (XLBL, YLBL, TOPLBL) + CHARACTER*(*) XLBL, YLBL, TOPLBL + +Write labels outside the viewport. This routine is a simple +interface to PGMTXT, which should be used if PGLAB is inadequate. + +Arguments: + XLBL (input) : a label for the x-axis (centered below the + viewport). + YLBL (input) : a label for the y-axis (centered to the left + of the viewport, drawn vertically). + TOPLBL (input) : a label for the entire plot (centered above the + viewport). + + +------------------------------------------------------------------------ +Module: PGLCUR -- draw a line using the cursor +------------------------------------------------------------------------ + + SUBROUTINE PGLCUR (MAXPT, NPT, X, Y) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + +Interactive routine for user to enter a polyline by use of +the cursor. Routine allows user to Add and Delete vertices; +vertices are joined by straight-line segments. + +Arguments: + MAXPT (input) : maximum number of points that may be accepted. + NPT (in/out) : number of points entered; should be zero on + first call. + X (in/out) : array of x-coordinates (dimension at least MAXPT). + Y (in/out) : array of y-coordinates (dimension at least MAXPT). + +Notes: + +(1) On return from the program, cursor points are returned in +the order they were entered. Routine may be (re-)called with points +already defined in X,Y (# in NPT), and they will be plotted +first, before editing. + +(2) User commands: the user types single-character commands +after positioning the cursor: the following are accepted: + A (Add) - add point at current cursor location. + D (Delete) - delete last-entered point. + X (eXit) - leave subroutine. + + +------------------------------------------------------------------------ +Module: PGLDEV -- list available device types on standard output +------------------------------------------------------------------------ + + SUBROUTINE PGLDEV + +Writes (to standard output) a list of all device types available in +the current PGPLOT installation. + +Arguments: none. + + +------------------------------------------------------------------------ +Module: PGLEN -- find length of a string in a variety of units +------------------------------------------------------------------------ + + SUBROUTINE PGLEN (UNITS, STRING, XL, YL) + REAL XL, YL + INTEGER UNITS + CHARACTER*(*) STRING + +Work out length of a string in x and y directions + +Input + UNITS : 0 => answer in normalized device coordinates + 1 => answer in inches + 2 => answer in mm + 3 => answer in absolute device coordinates (dots) + 4 => answer in world coordinates + 5 => answer as a fraction of the current viewport size + + STRING : String of interest +Output + XL : Length of string in x direction + YL : Length of string in y direction + + + +------------------------------------------------------------------------ +Module: PGLINE -- draw a polyline (curve defined by line-segments) +------------------------------------------------------------------------ + + SUBROUTINE PGLINE (N, XPTS, YPTS) + INTEGER N + REAL XPTS(*), YPTS(*) + +Primitive routine to draw a Polyline. A polyline is one or more +connected straight-line segments. The polyline is drawn using +the current setting of attributes color-index, line-style, and +line-width. The polyline is clipped at the edge of the window. + +Arguments: + N (input) : number of points defining the line; the line + consists of (N-1) straight-line segments. + N should be greater than 1 (if it is 1 or less, + nothing will be drawn). + XPTS (input) : world x-coordinates of the points. + YPTS (input) : world y-coordinates of the points. + +The dimension of arrays X and Y must be greater than or equal to N. +The "pen position" is changed to (X(N),Y(N)) in world coordinates +(if N > 1). + + +------------------------------------------------------------------------ +Module: PGMOVE -- move pen (change current pen position) +------------------------------------------------------------------------ + + SUBROUTINE PGMOVE (X, Y) + REAL X, Y + +Primitive routine to move the "pen" to the point with world +coordinates (X,Y). No line is drawn. + +Arguments: + X (input) : world x-coordinate of the new pen position. + Y (input) : world y-coordinate of the new pen position. + + +------------------------------------------------------------------------ +Module: PGMTXT -- write text at position relative to viewport +------------------------------------------------------------------------ + + SUBROUTINE PGMTXT (SIDE, DISP, COORD, FJUST, TEXT) + CHARACTER*(*) SIDE, TEXT + REAL DISP, COORD, FJUST + +Write text at a position specified relative to the viewport (outside +or inside). This routine is useful for annotating graphs. It is used +by routine PGLAB. The text is written using the current values of +attributes color-index, line-width, character-height, and +character-font. + +Arguments: + SIDE (input) : must include one of the characters 'B', 'L', 'T', + or 'R' signifying the Bottom, Left, Top, or Right + margin of the viewport. If it includes 'LV' or + 'RV', the string is written perpendicular to the + frame rather than parallel to it. + DISP (input) : the displacement of the character string from the + specified edge of the viewport, measured outwards + from the viewport in units of the character + height. Use a negative value to write inside the + viewport, a positive value to write outside. + COORD (input) : the location of the character string along the + specified edge of the viewport, as a fraction of + the length of the edge. + FJUST (input) : controls justification of the string parallel to + the specified edge of the viewport. If + FJUST = 0.0, the left-hand end of the string will + be placed at COORD; if JUST = 0.5, the center of + the string will be placed at COORD; if JUST = 1.0, + the right-hand end of the string will be placed at + at COORD. Other values between 0 and 1 give inter- + mediate placing, but they are not very useful. + TEXT (input) : the text string to be plotted. Trailing spaces are + ignored when justifying the string, but leading + spaces are significant. + + + +------------------------------------------------------------------------ +Module: PGNCUR -- mark a set of points using the cursor +------------------------------------------------------------------------ + + SUBROUTINE PGNCUR (MAXPT, NPT, X, Y, SYMBOL) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + INTEGER SYMBOL + +Interactive routine for user to enter data points by use of +the cursor. Routine allows user to Add and Delete points. The +points are returned in order of increasing x-coordinate, not in the +order they were entered. + +Arguments: + MAXPT (input) : maximum number of points that may be accepted. + NPT (in/out) : number of points entered; should be zero on + first call. + X (in/out) : array of x-coordinates. + Y (in/out) : array of y-coordinates. + SYMBOL (input) : code number of symbol to use for marking + entered points (see PGPT). + +Note (1): The dimension of arrays X and Y must be greater than or +equal to MAXPT. + +Note (2): On return from the program, cursor points are returned in +increasing order of X. Routine may be (re-)called with points +already defined in X,Y (number in NPT), and they will be plotted +first, before editing. + +Note (3): User commands: the user types single-character commands +after positioning the cursor: the following are accepted: +A (Add) - add point at current cursor location. +D (Delete) - delete nearest point to cursor. +X (eXit) - leave subroutine. + + +------------------------------------------------------------------------ +Module: PGNUMB -- convert a number into a plottable character string +------------------------------------------------------------------------ + + SUBROUTINE PGNUMB (MM, PP, FORM, STRING, NC) + INTEGER MM, PP, FORM + CHARACTER*(*) STRING + INTEGER NC + +This routine converts a number into a decimal character +representation. To avoid problems of floating-point roundoff, the +number must be provided as an integer (MM) multiplied by a power of 10 +(10**PP). The output string retains only significant digits of MM, +and will be in either integer format (123), decimal format (0.0123), +or exponential format (1.23x10**5). Standard escape sequences \u, \d +raise the exponent and \x is used for the multiplication sign. +This routine is used by PGBOX to create numeric labels for a plot. + +Formatting rules: + (a) Decimal notation (FORM=1): + - Trailing zeros to the right of the decimal sign are + omitted + - The decimal sign is omitted if there are no digits + to the right of it + - When the decimal sign is placed before the first digit + of the number, a zero is placed before the decimal sign + - The decimal sign is a period (.) + - No spaces are placed between digits (ie digits are not + grouped in threes as they should be) + - A leading minus (-) is added if the number is negative + (b) Exponential notation (FORM=2): + - The exponent is adjusted to put just one (non-zero) + digit before the decimal sign + - The mantissa is formatted as in (a), unless its value is + 1 in which case it and the multiplication sign are omitted + - If the power of 10 is not zero and the mantissa is not + zero, an exponent of the form \x10\u[-]nnn is appended, + where \x is a multiplication sign (cross), \u is an escape + sequence to raise the exponent, and as many digits nnn + are used as needed + (c) Automatic choice (FORM=0): + Decimal notation is used if the absolute value of the + number is less than 10000 or greater than or equal to + 0.01. Otherwise exponential notation is used. + +Arguments: + MM (input) + PP (input) : the value to be formatted is MM*10**PP. + FORM (input) : controls how the number is formatted: + FORM = 0 -- use either decimal or exponential + FORM = 1 -- use decimal notation + FORM = 2 -- use exponential notation + STRING (output) : the formatted character string, left justified. + If the length of STRING is insufficient, a single + asterisk is returned, and NC=1. + NC (output) : the number of characters used in STRING: + the string to be printed is STRING(1:NC). + + +------------------------------------------------------------------------ +Module: PGOLIN -- mark a set of points using the cursor +------------------------------------------------------------------------ + + SUBROUTINE PGOLIN (MAXPT, NPT, X, Y, SYMBOL) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + INTEGER SYMBOL + +Interactive routine for user to enter data points by use of +the cursor. Routine allows user to Add and Delete points. The +points are returned in the order that they were entered (unlike +PGNCUR). + +Arguments: + MAXPT (input) : maximum number of points that may be accepted. + NPT (in/out) : number of points entered; should be zero on + first call. + X (in/out) : array of x-coordinates. + Y (in/out) : array of y-coordinates. + SYMBOL (input) : code number of symbol to use for marking + entered points (see PGPT). + +Note (1): The dimension of arrays X and Y must be greater than or +equal to MAXPT. + +Note (2): On return from the program, cursor points are returned in +the order they were entered. Routine may be (re-)called with points +already defined in X,Y (number in NPT), and they will be plotted +first, before editing. + +Note (3): User commands: the user types single-character commands +after positioning the cursor: the following are accepted: +A (Add) - add point at current cursor location. +D (Delete) - delete the last point entered. +X (eXit) - leave subroutine. + + +------------------------------------------------------------------------ +Module: PGOPEN -- open a graphics device +------------------------------------------------------------------------ + + INTEGER FUNCTION PGOPEN (DEVICE) + CHARACTER*(*) DEVICE + +Open a graphics device for PGPLOT output. If the device is +opened successfully, it becomes the selected device to which +graphics output is directed until another device is selected +with PGSLCT or the device is closed with PGCLOS. + +The value returned by PGOPEN should be tested to ensure that +the device was opened successfully, e.g., + + ISTAT = PGOPEN('plot.ps/PS') + IF (ISTAT .LE. 0 ) STOP + +Note that PGOPEN must be declared INTEGER in the calling program. + +The DEVICE argument is a character constant or variable; its value +should be one of the following: + +(1) A complete device specification of the form 'device/type' or + 'file/type', where 'type' is one of the allowed PGPLOT device + types (installation-dependent) and 'device' or 'file' is the + name of a graphics device or disk file appropriate for this type. + The 'device' or 'file' may contain '/' characters; the final + '/' delimits the 'type'. If necessary to avoid ambiguity, + the 'device' part of the string may be enclosed in double + quotation marks. +(2) A device specification of the form '/type', where 'type' is one + of the allowed PGPLOT device types. PGPLOT supplies a default + file or device name appropriate for this device type. +(3) A device specification with '/type' omitted; in this case + the type is taken from the environment variable PGPLOT_TYPE, + if defined (e.g., setenv PGPLOT_TYPE PS). Because of possible + confusion with '/' in file-names, omitting the device type + in this way is not recommended. +(4) A blank string (' '); in this case, PGOPEN will use the value + of environment variable PGPLOT_DEV as the device specification, + or '/NULL' if the environment variable is undefined. +(5) A single question mark, with optional trailing spaces ('?'); in + this case, PGPLOT will prompt the user to supply the device + specification, with a prompt string of the form + 'Graphics device/type (? to see list, default XXX):' + where 'XXX' is the default (value of environment variable + PGPLOT_DEV). +(6) A non-blank string in which the first character is a question + mark (e.g., '?Device: '); in this case, PGPLOT will prompt the + user to supply the device specification, using the supplied + string as the prompt (without the leading question mark but + including any trailing spaces). + +In cases (5) and (6), the device specification is read from the +standard input. The user should respond to the prompt with a device +specification of the form (1), (2), or (3). If the user types a +question-mark in response to the prompt, a list of available device +types is displayed and the prompt is re-issued. If the user supplies +an invalid device specification, the prompt is re-issued. If the user +responds with an end-of-file character, e.g., ctrl-D in UNIX, program +execution is aborted; this avoids the possibility of an infinite +prompting loop. A programmer should avoid use of PGPLOT-prompting +if this behavior is not desirable. + +The device type is case-insensitive (e.g., '/ps' and '/PS' are +equivalent). The device or file name may be case-sensitive in some +operating systems. + +Examples of valid DEVICE arguments: + +(1) 'plot.ps/ps', 'dir/plot.ps/ps', '"dir/plot.ps"/ps', + 'user:[tjp.plots]plot.ps/PS' +(2) '/ps' (PGPLOT interprets this as 'pgplot.ps/ps') +(3) 'plot.ps' (if PGPLOT_TYPE is defined as 'ps', PGPLOT + interprets this as 'plot.ps/ps') +(4) ' ' (if PGPLOT_DEV is defined) +(5) '? ' +(6) '?Device specification for PGPLOT: ' + +[This routine was added to PGPLOT in Version 5.1.0. Older programs +use PGBEG instead.] + +Returns: + PGOPEN : returns either a positive value, the + identifier of the graphics device for use with + PGSLCT, or a 0 or negative value indicating an + error. In the event of error a message is + written on the standard error unit. +Arguments: + DEVICE (input) : the 'device specification' for the plot device + (see above). + + +------------------------------------------------------------------------ +Module: PGPAGE -- advance to new page +------------------------------------------------------------------------ + + SUBROUTINE PGPAGE + +Advance plotter to a new page or panel, clearing the screen if +necessary. If the "prompt state" is ON (see PGASK), confirmation is +requested from the user before clearing the screen. If the view +surface has been subdivided into panels with PGBEG or PGSUBP, then +PGPAGE advances to the next panel, and if the current panel is the +last on the page, PGPAGE clears the screen or starts a new sheet of +paper. PGPAGE does not change the PGPLOT window or the viewport +(in normalized device coordinates); but note that if the size of the +view-surface is changed externally (e.g., by a workstation window +manager) the size of the viewport is changed in proportion. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGPANL -- switch to a different panel on the view surface +------------------------------------------------------------------------ + + SUBROUTINE PGPANL(IX, IY) + INTEGER IX, IY + +Start plotting in a different panel. If the view surface has been +divided into panels by PGBEG or PGSUBP, this routine can be used to +move to a different panel. Note that PGPLOT does not remember what +viewport and window were in use in each panel; these should be reset +if necessary after calling PGPANL. Nor does PGPLOT clear the panel: +call PGERAS after calling PGPANL to do this. + +Arguments: + IX (input) : the horizontal index of the panel (in the range + 1 <= IX <= number of panels in horizontal + direction). + IY (input) : the vertical index of the panel (in the range + 1 <= IY <= number of panels in horizontal + direction). + + +------------------------------------------------------------------------ +Module: PGPAP -- change the size of the view surface +------------------------------------------------------------------------ + + SUBROUTINE PGPAP (WIDTH, ASPECT) + REAL WIDTH, ASPECT + +This routine changes the size of the view surface ("paper size") to a +specified width and aspect ratio (height/width), in so far as this is +possible on the specific device. It is always possible to obtain a +view surface smaller than the default size; on some devices (e.g., +printers that print on roll or fan-feed paper) it is possible to +obtain a view surface larger than the default. + +This routine should be called either immediately after PGBEG or +immediately before PGPAGE. The new size applies to all subsequent +images until the next call to PGPAP. + +Arguments: + WIDTH (input) : the requested width of the view surface in inches; + if WIDTH=0.0, PGPAP will obtain the largest view + surface available consistent with argument ASPECT. + (1 inch = 25.4 mm.) + ASPECT (input) : the aspect ratio (height/width) of the view + surface; e.g., ASPECT=1.0 gives a square view + surface, ASPECT=0.618 gives a horizontal + rectangle, ASPECT=1.618 gives a vertical rectangle. + + +------------------------------------------------------------------------ +Module: PGPIXL -- draw pixels +------------------------------------------------------------------------ + + SUBROUTINE PGPIXL (IA, IDIM, JDIM, I1, I2, J1, J2, + 1 X1, X2, Y1, Y2) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + INTEGER IA(IDIM,JDIM) + REAL X1, X2, Y1, Y2 + +Draw lots of solid-filled (tiny) rectangles aligned with the +coordinate axes. Best performance is achieved when output is +directed to a pixel-oriented device and the rectangles coincide +with the pixels on the device. In other cases, pixel output is +emulated. + +The subsection of the array IA defined by indices (I1:I2, J1:J2) +is mapped onto world-coordinate rectangle defined by X1, X2, Y1 +and Y2. This rectangle is divided into (I2 - I1 + 1) * (J2 - J1 + 1) +small rectangles. Each of these small rectangles is solid-filled +with the color index specified by the corresponding element of +IA. + +On most devices, the output region is "opaque", i.e., it obscures +all graphical elements previously drawn in the region. But on +devices that do not have erase capability, the background shade +is "transparent" and allows previously-drawn graphics to show +through. + +Arguments: + IA (input) : the array to be plotted. + IDIM (input) : the first dimension of array A. + JDIM (input) : the second dimension of array A. + I1, I2 (input) : the inclusive range of the first index + (I) to be plotted. + J1, J2 (input) : the inclusive range of the second + index (J) to be plotted. + X1, Y1 (input) : world coordinates of one corner of the output + region + X2, Y2 (input) : world coordinates of the opposite corner of the + output region + + +------------------------------------------------------------------------ +Module: PGPNTS -- draw several graph markers, not all the same +------------------------------------------------------------------------ + + SUBROUTINE PGPNTS (N, X, Y, SYMBOL, NS) + INTEGER N, NS + REAL X(*), Y(*) + INTEGER SYMBOL(*) + +Draw Graph Markers. Unlike PGPT, this routine can draw a different +symbol at each point. The markers are drawn using the current values +of attributes color-index, line-width, and character-height +(character-font applies if the symbol number is >31). If the point +to be marked lies outside the window, no marker is drawn. The "pen +position" is changed to (XPTS(N),YPTS(N)) in world coordinates +(if N > 0). + +Arguments: + N (input) : number of points to mark. + X (input) : world x-coordinate of the points. + Y (input) : world y-coordinate of the points. + SYMBOL (input) : code number of the symbol to be plotted at each + point (see PGPT). + NS (input) : number of values in the SYMBOL array. If NS <= N, + then the first NS points are drawn using the value + of SYMBOL(I) at (X(I), Y(I)) and SYMBOL(1) for all + the values of (X(I), Y(I)) where I > NS. + +Note: the dimension of arrays X and Y must be greater than or equal +to N and the dimension of the array SYMBOL must be greater than or +equal to NS. If N is 1, X and Y may be scalars (constants or +variables). If NS is 1, then SYMBOL may be a scalar. If N is +less than 1, nothing is drawn. + + +------------------------------------------------------------------------ +Module: PGPOLY -- draw a polygon, using fill-area attributes +------------------------------------------------------------------------ + + SUBROUTINE PGPOLY (N, XPTS, YPTS) + INTEGER N + REAL XPTS(*), YPTS(*) + +Fill-area primitive routine: shade the interior of a closed +polygon in the current window. The action of this routine depends +on the setting of the Fill-Area Style attribute (see PGSFS). +The polygon is clipped at the edge of the +window. The pen position is changed to (XPTS(1),YPTS(1)) in world +coordinates (if N > 1). If the polygon is not convex, a point is +assumed to lie inside the polygon if a straight line drawn to +infinity intersects and odd number of the polygon's edges. + +Arguments: + N (input) : number of points defining the polygon; the + line consists of N straight-line segments, + joining points 1 to 2, 2 to 3,... N-1 to N, N to 1. + N should be greater than 2 (if it is 2 or less, + nothing will be drawn). + XPTS (input) : world x-coordinates of the vertices. + YPTS (input) : world y-coordinates of the vertices. + Note: the dimension of arrays XPTS and YPTS must be + greater than or equal to N. + + +------------------------------------------------------------------------ +Module: PGPT -- draw several graph markers +------------------------------------------------------------------------ + + SUBROUTINE PGPT (N, XPTS, YPTS, SYMBOL) + INTEGER N + REAL XPTS(*), YPTS(*) + INTEGER SYMBOL + +Primitive routine to draw Graph Markers (polymarker). The markers +are drawn using the current values of attributes color-index, +line-width, and character-height (character-font applies if the symbol +number is >31). If the point to be marked lies outside the window, +no marker is drawn. The "pen position" is changed to +(XPTS(N),YPTS(N)) in world coordinates (if N > 0). + +Arguments: + N (input) : number of points to mark. + XPTS (input) : world x-coordinates of the points. + YPTS (input) : world y-coordinates of the points. + SYMBOL (input) : code number of the symbol to be drawn at each + point: + -1, -2 : a single dot (diameter = current + line width). + -3..-31 : a regular polygon with ABS(SYMBOL) + edges (style set by current fill style). + 0..31 : standard marker symbols. + 32..127 : ASCII characters (in current font). + e.g. to use letter F as a marker, let + SYMBOL = ICHAR('F'). + > 127 : a Hershey symbol number. + +Note: the dimension of arrays X and Y must be greater than or equal +to N. If N is 1, X and Y may be scalars (constants or variables). If +N is less than 1, nothing is drawn. + + +------------------------------------------------------------------------ +Module: PGPT1 -- draw one graph marker +------------------------------------------------------------------------ + + SUBROUTINE PGPT1 (XPT, YPT, SYMBOL) + REAL XPT, YPT + INTEGER SYMBOL + +Primitive routine to draw a single Graph Marker at a specified point. +The marker is drawn using the current values of attributes +color-index, line-width, and character-height (character-font applies +if the symbol number is >31). If the point to be marked lies outside +the window, no marker is drawn. The "pen position" is changed to +(XPT,YPT) in world coordinates. + +To draw several markers with coordinates specified by X and Y +arrays, use routine PGPT. + +Arguments: + XPT (input) : world x-coordinate of the point. + YPT (input) : world y-coordinate of the point. + SYMBOL (input) : code number of the symbol to be drawn: + -1, -2 : a single dot (diameter = current + line width). + -3..-31 : a regular polygon with ABS(SYMBOL) + edges (style set by current fill style). + 0..31 : standard marker symbols. + 32..127 : ASCII characters (in current font). + e.g. to use letter F as a marker, let + SYMBOL = ICHAR('F'). + > 127 : a Hershey symbol number. + + +------------------------------------------------------------------------ +Module: PGPTXT -- write text at arbitrary position and angle +------------------------------------------------------------------------ + + SUBROUTINE PGPTXT (X, Y, ANGLE, FJUST, TEXT) + REAL X, Y, ANGLE, FJUST + CHARACTER*(*) TEXT + +Primitive routine for drawing text. The text may be drawn at any +angle with the horizontal, and may be centered or left- or right- +justified at a specified position. Routine PGTEXT provides a +simple interface to PGPTXT for horizontal strings. Text is drawn +using the current values of attributes color-index, line-width, +character-height, and character-font. Text is NOT subject to +clipping at the edge of the window. + +Arguments: + X (input) : world x-coordinate. + Y (input) : world y-coordinate. The string is drawn with the + baseline of all the characters passing through + point (X,Y); the positioning of the string along + this line is controlled by argument FJUST. + ANGLE (input) : angle, in degrees, that the baseline is to make + with the horizontal, increasing counter-clockwise + (0.0 is horizontal). + FJUST (input) : controls horizontal justification of the string. + If FJUST = 0.0, the string will be left-justified + at the point (X,Y); if FJUST = 0.5, it will be + centered, and if FJUST = 1.0, it will be right + justified. [Other values of FJUST give other + justifications.] + TEXT (input) : the character string to be plotted. + + +------------------------------------------------------------------------ +Module: PGQAH -- inquire arrow-head style +------------------------------------------------------------------------ + + SUBROUTINE PGQAH (FS, ANGLE, BARB) + INTEGER FS + REAL ANGLE, BARB + +Query the style to be used for arrowheads drawn with routine PGARRO. + +Argument: + FS (output) : FS = 1 => filled; FS = 2 => outline. + ANGLE (output) : the acute angle of the arrow point, in degrees. + BARB (output) : the fraction of the triangular arrow-head that + is cut away from the back. + + +------------------------------------------------------------------------ +Module: PGQCF -- inquire character font +------------------------------------------------------------------------ + + SUBROUTINE PGQCF (FONT) + INTEGER FONT + +Query the current Character Font (set by routine PGSCF). + +Argument: + FONT (output) : the current font number (in range 1-4). + + +------------------------------------------------------------------------ +Module: PGQCH -- inquire character height +------------------------------------------------------------------------ + + SUBROUTINE PGQCH (SIZE) + REAL SIZE + +Query the Character Size attribute (set by routine PGSCH). + +Argument: + SIZE (output) : current character size (dimensionless multiple of + the default size). + + +------------------------------------------------------------------------ +Module: PGQCI -- inquire color index +------------------------------------------------------------------------ + + SUBROUTINE PGQCI (CI) + INTEGER CI + +Query the Color Index attribute (set by routine PGSCI). + +Argument: + CI (output) : the current color index (in range 0-max). This is + the color index actually in use, and may differ + from the color index last requested by PGSCI if + that index is not available on the output device. + + +------------------------------------------------------------------------ +Module: PGQCIR -- inquire color index range +------------------------------------------------------------------------ + + SUBROUTINE PGQCIR(ICILO, ICIHI) + INTEGER ICILO, ICIHI + +Query the color index range to be used for producing images with +PGGRAY or PGIMAG, as set by routine PGSCIR or by device default. + +Arguments: + ICILO (output) : the lowest color index to use for images + ICIHI (output) : the highest color index to use for images + + +------------------------------------------------------------------------ +Module: PGQCLP -- inquire clipping status +------------------------------------------------------------------------ + + SUBROUTINE PGQCLP(STATE) + INTEGER STATE + +Query the current clipping status (set by routine PGSCLP). + +Argument: + STATE (output) : receives the clipping status (0 => disabled, + 1 => enabled). + + +------------------------------------------------------------------------ +Module: PGQCOL -- inquire color capability +------------------------------------------------------------------------ + + SUBROUTINE PGQCOL (CI1, CI2) + INTEGER CI1, CI2 + +Query the range of color indices available on the current device. + +Argument: + CI1 (output) : the minimum available color index. This will be + either 0 if the device can write in the + background color, or 1 if not. + CI2 (output) : the maximum available color index. This will be + 1 if the device has no color capability, or a + larger number (e.g., 3, 7, 15, 255). + + +------------------------------------------------------------------------ +Module: PGQCR -- inquire color representation +------------------------------------------------------------------------ + + SUBROUTINE PGQCR (CI, CR, CG, CB) + INTEGER CI + REAL CR, CG, CB + +Query the RGB colors associated with a color index. + +Arguments: + CI (input) : color index + CR (output) : red, green and blue intensities + CG (output) in the range 0.0 to 1.0 + CB (output) + + +------------------------------------------------------------------------ +Module: PGQCS -- inquire character height in a variety of units +------------------------------------------------------------------------ + + SUBROUTINE PGQCS(UNITS, XCH, YCH) + INTEGER UNITS + REAL XCH, YCH + +Return the current PGPLOT character height in a variety of units. +This routine provides facilities that are not available via PGQCH. +Use PGQCS if the character height is required in units other than +those used in PGSCH. + +The PGPLOT "character height" is a dimension that scales with the +size of the view surface and with the scale-factor specified with +routine PGSCH. The default value is 1/40th of the height or width +of the view surface (whichever is less); this value is then +multiplied by the scale-factor supplied with PGSCH. Note that it +is a nominal height only; the actual character size depends on the +font and is usually somewhat smaller. + +Arguments: + UNITS (input) : Used to specify the units of the output value: + UNITS = 0 : normalized device coordinates + UNITS = 1 : inches + UNITS = 2 : millimeters + UNITS = 3 : pixels + UNITS = 4 : world coordinates + Other values give an error message, and are + treated as 0. + XCH (output) : The character height for text written with a + vertical baseline. + YCH (output) : The character height for text written with + a horizontal baseline (the usual case). + +The character height is returned in both XCH and YCH. + +If UNITS=1 or UNITS=2, XCH and YCH both receive the same value. + +If UNITS=3, XCH receives the height in horizontal pixel units, and YCH +receives the height in vertical pixel units; on devices for which the +pixels are not square, XCH and YCH will be different. + +If UNITS=4, XCH receives the height in horizontal world coordinates +(as used for the x-axis), and YCH receives the height in vertical +world coordinates (as used for the y-axis). Unless special care has +been taken to achive equal world-coordinate scales on both axes, the +values of XCH and YCH will be different. + +If UNITS=0, XCH receives the character height as a fraction of the +horizontal dimension of the view surface, and YCH receives the +character height as a fraction of the vertical dimension of the view +surface. + + +------------------------------------------------------------------------ +Module: PGQDT -- inquire name of nth available device type +------------------------------------------------------------------------ + + SUBROUTINE PGQDT(N, TYPE, TLEN, DESCR, DLEN, INTER) + INTEGER N + CHARACTER*(*) TYPE, DESCR + INTEGER TLEN, DLEN, INTER + +Return the name of the Nth available device type as a character +string. The number of available types can be determined by calling +PGQNDT. If the value of N supplied is outside the range from 1 to +the number of available types, the routine returns DLEN=TLEN=0. + +Arguments: + N (input) : the number of the device type (1..maximum). + TYPE (output) : receives the character device-type code of the + Nth device type. The argument supplied should be + large enough for at least 8 characters. The first + character in the string is a '/' character. + TLEN (output) : receives the number of characters in TYPE, + excluding trailing blanks. + DESCR (output) : receives a description of the device type. The + argument supplied should be large enough for at + least 64 characters. + DLEN (output) : receives the number of characters in DESCR, + excluding trailing blanks. + INTER (output) : receives 1 if the device type is an interactive + one, 0 otherwise. + + +------------------------------------------------------------------------ +Module: PGQFS -- inquire fill-area style +------------------------------------------------------------------------ + + SUBROUTINE PGQFS (FS) + INTEGER FS + +Query the current Fill-Area Style attribute (set by routine +PGSFS). + +Argument: + FS (output) : the current fill-area style: + FS = 1 => solid (default) + FS = 2 => outline + FS = 3 => hatched + FS = 4 => cross-hatched + + +------------------------------------------------------------------------ +Module: PGQHS -- inquire hatching style +------------------------------------------------------------------------ + + SUBROUTINE PGQHS (ANGLE, SEPN, PHASE) + REAL ANGLE, SEPN, PHASE + +Query the style to be used hatching (fill area with fill-style 3). + +Arguments: + ANGLE (output) : the angle the hatch lines make with the + horizontal, in degrees, increasing + counterclockwise (this is an angle on the + view surface, not in world-coordinate space). + SEPN (output) : the spacing of the hatch lines. The unit spacing + is 1 percent of the smaller of the height or + width of the view surface. + PHASE (output) : a real number between 0 and 1; the hatch lines + are displaced by this fraction of SEPN from a + fixed reference. Adjacent regions hatched with the + same PHASE have contiguous hatch lines. + + +------------------------------------------------------------------------ +Module: PGQID -- inquire current device identifier +------------------------------------------------------------------------ + + SUBROUTINE PGQID (ID) + INTEGER ID + +This subroutine returns the identifier of the currently +selected device, or 0 if no device is selected. The identifier is +assigned when PGOPEN is called to open the device, and may be used +as an argument to PGSLCT. Each open device has a different +identifier. + +[This routine was added to PGPLOT in Version 5.1.0.] + +Argument: + ID (output) : the identifier of the current device, or 0 if + no device is currently selected. + + +------------------------------------------------------------------------ +Module: PGQINF -- inquire PGPLOT general information +------------------------------------------------------------------------ + + SUBROUTINE PGQINF (ITEM, VALUE, LENGTH) + CHARACTER*(*) ITEM, VALUE + INTEGER LENGTH + +This routine can be used to obtain miscellaneous information about +the PGPLOT environment. Input is a character string defining the +information required, and output is a character string containing the +requested information. + +The following item codes are accepted (note that the strings must +match exactly, except for case, but only the first 8 characters are +significant). For items marked *, PGPLOT must be in the OPEN state +for the inquiry to succeed. If the inquiry is unsuccessful, either +because the item code is not recognized or because the information +is not available, a question mark ('?') is returned. + + 'VERSION' - version of PGPLOT software in use. + 'STATE' - status of PGPLOT ('OPEN' if a graphics device + is open for output, 'CLOSED' otherwise). + 'USER' - the username associated with the calling program. + 'NOW' - current date and time (e.g., '17-FEB-1986 10:04'). + 'DEVICE' * - current PGPLOT device or file. + 'FILE' * - current PGPLOT device or file. + 'TYPE' * - device-type of the current PGPLOT device. + 'DEV/TYPE' * - current PGPLOT device and type, in a form which + is acceptable as an argument for PGBEG. + 'HARDCOPY' * - is the current device a hardcopy device? ('YES' or + 'NO'). + 'TERMINAL' * - is the current device the user's interactive + terminal? ('YES' or 'NO'). + 'CURSOR' * - does the current device have a graphics cursor? + ('YES' or 'NO'). + 'SCROLL' * - does current device have rectangle-scroll + capability ('YES' or 'NO'); see PGSCRL. + +Arguments: + ITEM (input) : character string defining the information to + be returned; see above for a list of possible + values. + VALUE (output) : returns a character-string containing the + requested information, truncated to the length + of the supplied string or padded on the right with + spaces if necessary. + LENGTH (output): the number of characters returned in VALUE + (excluding trailing blanks). + + +------------------------------------------------------------------------ +Module: PGQITF -- inquire image transfer function +------------------------------------------------------------------------ + + SUBROUTINE PGQITF (ITF) + INTEGER ITF + +Return the Image Transfer Function as set by default or by a previous +call to PGSITF. The Image Transfer Function is used by routines +PGIMAG, PGGRAY, and PGWEDG. + +Argument: + ITF (output) : type of transfer function (see PGSITF) + + +------------------------------------------------------------------------ +Module: PGQLS -- inquire line style +------------------------------------------------------------------------ + + SUBROUTINE PGQLS (LS) + INTEGER LS + +Query the current Line Style attribute (set by routine PGSLS). + +Argument: + LS (output) : the current line-style attribute (in range 1-5). + + +------------------------------------------------------------------------ +Module: PGQLW -- inquire line width +------------------------------------------------------------------------ + + SUBROUTINE PGQLW (LW) + INTEGER LW + +Query the current Line-Width attribute (set by routine PGSLW). + +Argument: + LW (output) : the line-width (in range 1-201). + + +------------------------------------------------------------------------ +Module: PGQNDT -- inquire number of available device types +------------------------------------------------------------------------ + + SUBROUTINE PGQNDT(N) + INTEGER N + +Return the number of available device types. This routine is +usually used in conjunction with PGQDT to get a list of the +available device types. + +Arguments: + N (output) : the number of available device types. + + +------------------------------------------------------------------------ +Module: PGQPOS -- inquire current pen position +------------------------------------------------------------------------ + + SUBROUTINE PGQPOS (X, Y) + REAL X, Y + +Query the current "pen" position in world C coordinates (X,Y). + +Arguments: + X (output) : world x-coordinate of the pen position. + Y (output) : world y-coordinate of the pen position. + + +------------------------------------------------------------------------ +Module: PGQTBG -- inquire text background color index +------------------------------------------------------------------------ + + SUBROUTINE PGQTBG (TBCI) + INTEGER TBCI + +Query the current Text Background Color Index (set by routine +PGSTBG). + +Argument: + TBCI (output) : receives the current text background color index. + + +------------------------------------------------------------------------ +Module: PGQTXT -- find bounding box of text string +------------------------------------------------------------------------ + + SUBROUTINE PGQTXT (X, Y, ANGLE, FJUST, TEXT, XBOX, YBOX) + REAL X, Y, ANGLE, FJUST + CHARACTER*(*) TEXT + REAL XBOX(4), YBOX(4) + +This routine returns a bounding box for a text string. Instead +of drawing the string as routine PGPTXT does, it returns in XBOX +and YBOX the coordinates of the corners of a rectangle parallel +to the string baseline that just encloses the string. The four +corners are in the order: lower left, upper left, upper right, +lower right (where left and right refer to the first and last +characters in the string). + +If the string is blank or contains no drawable characters, all +four elements of XBOX and YBOX are assigned the starting point +of the string, (X,Y). + +Arguments: + X, Y, ANGLE, FJUST, TEXT (input) : these arguments are the same as + the corrresponding arguments in PGPTXT. + XBOX, YBOX (output) : arrays of dimension 4; on output, they + contain the world coordinates of the bounding + box in (XBOX(1), YBOX(1)), ..., (XBOX(4), YBOX(4)). + + +------------------------------------------------------------------------ +Module: PGQVP -- inquire viewport size and position +------------------------------------------------------------------------ + + SUBROUTINE PGQVP (UNITS, X1, X2, Y1, Y2) + INTEGER UNITS + REAL X1, X2, Y1, Y2 + +Inquiry routine to determine the current viewport setting. +The values returned may be normalized device coordinates, inches, mm, +or pixels, depending on the value of the input parameter CFLAG. + +Arguments: + UNITS (input) : used to specify the units of the output parameters: + UNITS = 0 : normalized device coordinates + UNITS = 1 : inches + UNITS = 2 : millimeters + UNITS = 3 : pixels + Other values give an error message, and are + treated as 0. + X1 (output) : the x-coordinate of the bottom left corner of the + viewport. + X2 (output) : the x-coordinate of the top right corner of the + viewport. + Y1 (output) : the y-coordinate of the bottom left corner of the + viewport. + Y2 (output) : the y-coordinate of the top right corner of the + viewport. + + +------------------------------------------------------------------------ +Module: PGQVSZ -- inquire size of view surface +------------------------------------------------------------------------ + + SUBROUTINE PGQVSZ (UNITS, X1, X2, Y1, Y2) + INTEGER UNITS + REAL X1, X2, Y1, Y2 + +This routine returns the dimensions of the view surface (the maximum +plottable area) of the currently selected graphics device, in +a variety of units. The size of the view surface is device-dependent +and is established when the graphics device is opened. On some +devices, it can be changed by calling PGPAP before starting a new +page with PGPAGE. On some devices, the size can be changed (e.g., +by a workstation window manager) outside PGPLOT, and PGPLOT detects +the change when PGPAGE is used. Call this routine after PGPAGE to +find the current size. + +Note 1: the width and the height of the view surface in normalized +device coordinates are both always equal to 1.0. + +Note 2: when the device is divided into panels (see PGSUBP), the +view surface is a single panel. + +Arguments: + UNITS (input) : 0,1,2,3 for output in normalized device coords, + inches, mm, or device units (pixels) + X1 (output) : always returns 0.0 + X2 (output) : width of view surface + Y1 (output) : always returns 0.0 + Y2 (output) : height of view surface + + +------------------------------------------------------------------------ +Module: PGQWIN -- inquire window boundary coordinates +------------------------------------------------------------------------ + + SUBROUTINE PGQWIN (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +Inquiry routine to determine the current window setting. +The values returned are world coordinates. + +Arguments: + X1 (output) : the x-coordinate of the bottom left corner + of the window. + X2 (output) : the x-coordinate of the top right corner + of the window. + Y1 (output) : the y-coordinate of the bottom left corner + of the window. + Y2 (output) : the y-coordinate of the top right corner + of the window. + + +------------------------------------------------------------------------ +Module: PGRECT -- draw a rectangle, using fill-area attributes +------------------------------------------------------------------------ + + SUBROUTINE PGRECT (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +This routine can be used instead of PGPOLY for the special case of +drawing a rectangle aligned with the coordinate axes; only two +vertices need be specified instead of four. On most devices, it is +faster to use PGRECT than PGPOLY for drawing rectangles. The +rectangle has vertices at (X1,Y1), (X1,Y2), (X2,Y2), and (X2,Y1). + +Arguments: + X1, X2 (input) : the horizontal range of the rectangle. + Y1, Y2 (input) : the vertical range of the rectangle. + + +------------------------------------------------------------------------ +Module: PGRND -- find the smallest `round' number greater than x +------------------------------------------------------------------------ + + REAL FUNCTION PGRND (X, NSUB) + REAL X + INTEGER NSUB + +Routine to find the smallest "round" number larger than x, a +"round" number being 1, 2 or 5 times a power of 10. If X is negative, +PGRND(X) = -PGRND(ABS(X)). eg PGRND(8.7) = 10.0, +PGRND(-0.4) = -0.5. If X is zero, the value returned is zero. +This routine is used by PGBOX for choosing tick intervals. + +Returns: + PGRND : the "round" number. +Arguments: + X (input) : the number to be rounded. + NSUB (output) : a suitable number of subdivisions for + subdividing the "nice" number: 2 or 5. + + +------------------------------------------------------------------------ +Module: PGRNGE -- choose axis limits +------------------------------------------------------------------------ + + SUBROUTINE PGRNGE (X1, X2, XLO, XHI) + REAL X1, X2, XLO, XHI + +Choose plotting limits XLO and XHI which encompass the data +range X1 to X2. + +Arguments: + X1, X2 (input) : the data range (X1= X2). + + +------------------------------------------------------------------------ +Module: PGSAH -- set arrow-head style +------------------------------------------------------------------------ + + SUBROUTINE PGSAH (FS, ANGLE, BARB) + INTEGER FS + REAL ANGLE, BARB + +Set the style to be used for arrowheads drawn with routine PGARRO. + +Argument: + FS (input) : FS = 1 => filled; FS = 2 => outline. + Other values are treated as 2. Default 1. + ANGLE (input) : the acute angle of the arrow point, in degrees; + angles in the range 20.0 to 90.0 give reasonable + results. Default 45.0. + BARB (input) : the fraction of the triangular arrow-head that + is cut away from the back. 0.0 gives a triangular + wedge arrow-head; 1.0 gives an open >. Values 0.3 + to 0.7 give reasonable results. Default 0.3. + + +------------------------------------------------------------------------ +Module: PGSAVE -- save PGPLOT attributes +------------------------------------------------------------------------ + + SUBROUTINE PGSAVE + +This routine saves the current PGPLOT attributes in a private storage +area. They can be restored by calling PGUNSA (unsave). Attributes +saved are: character font, character height, color index, fill-area +style, line style, line width, pen position, arrow-head style, +hatching style, and clipping state. Color representation is not saved. + +Calls to PGSAVE and PGUNSA should always be paired. Up to 20 copies +of the attributes may be saved. PGUNSA always retrieves the last-saved +values (last-in first-out stack). + +Note that when multiple devices are in use, PGUNSA retrieves the +values saved by the last PGSAVE call, even if they were for a +different device. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGUNSA -- restore PGPLOT attributes +------------------------------------------------------------------------ + + ENTRY PGUNSA + +This routine restores the PGPLOT attributes saved in the last call to +PGSAVE. Usage: CALL PGUNSA (no arguments). See PGSAVE. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGSCF -- set character font +------------------------------------------------------------------------ + + SUBROUTINE PGSCF (FONT) + INTEGER FONT + +Set the Character Font for subsequent text plotting. Four different +fonts are available: + 1: (default) a simple single-stroke font ("normal" font) + 2: roman font + 3: italic font + 4: script font +This call determines which font is in effect at the beginning of +each text string. The font can be changed (temporarily) within a text +string by using the escape sequences \fn, \fr, \fi, and \fs for fonts +1, 2, 3, and 4, respectively. + +Argument: + FONT (input) : the font number to be used for subsequent text + plotting (in range 1-4). + + +------------------------------------------------------------------------ +Module: PGSCH -- set character height +------------------------------------------------------------------------ + + SUBROUTINE PGSCH (SIZE) + REAL SIZE + +Set the character size attribute. The size affects all text and graph +markers drawn later in the program. The default character size is +1.0, corresponding to a character height about 1/40 the height of +the view surface. Changing the character size also scales the length +of tick marks drawn by PGBOX and terminals drawn by PGERRX and PGERRY. + +Argument: + SIZE (input) : new character size (dimensionless multiple of + the default size). + + +------------------------------------------------------------------------ +Module: PGSCI -- set color index +------------------------------------------------------------------------ + + SUBROUTINE PGSCI (CI) + INTEGER CI + +Set the Color Index for subsequent plotting, if the output device +permits this. The default color index is 1, usually white on a black +background for video displays or black on a white background for +printer plots. The color index is an integer in the range 0 to a +device-dependent maximum. Color index 0 corresponds to the background +color; lines may be "erased" by overwriting them with color index 0 +(if the device permits this). + +If the requested color index is not available on the selected device, +color index 1 will be substituted. + +The assignment of colors to color indices can be changed with +subroutine PGSCR (set color representation). Color indices 0-15 +have predefined color representations (see the PGPLOT manual), but +these may be changed with PGSCR. Color indices above 15 have no +predefined representations: if these indices are used, PGSCR must +be called to define the representation. + +Argument: + CI (input) : the color index to be used for subsequent plotting + on the current device (in range 0-max). If the + index exceeds the device-dependent maximum, the + default color index (1) is used. + + +------------------------------------------------------------------------ +Module: PGSCIR -- set color index range +------------------------------------------------------------------------ + + SUBROUTINE PGSCIR(ICILO, ICIHI) + INTEGER ICILO, ICIHI + +Set the color index range to be used for producing images with +PGGRAY or PGIMAG. If the range is not all within the range supported +by the device, a smaller range will be used. The number of +different colors available for images is ICIHI-ICILO+1. + +Arguments: + ICILO (input) : the lowest color index to use for images + ICIHI (input) : the highest color index to use for images + + +------------------------------------------------------------------------ +Module: PGSCLP -- enable or disable clipping at edge of viewport +------------------------------------------------------------------------ + + SUBROUTINE PGSCLP(STATE) + INTEGER STATE + +Normally all PGPLOT primitives except text are ``clipped'' at the +edge of the viewport: parts of the primitives that lie outside +the viewport are not drawn. If clipping is disabled by calling this +routine, primitives are visible wherever they lie on the view +surface. The default (clipping enabled) is appropriate for almost +all applications. + +Argument: + STATE (input) : 0 to disable clipping, or 1 to enable clipping. + +25-Feb-1997 [TJP] - new routine. + + +------------------------------------------------------------------------ +Module: PGSCR -- set color representation +------------------------------------------------------------------------ + + SUBROUTINE PGSCR (CI, CR, CG, CB) + INTEGER CI + REAL CR, CG, CB + +Set color representation: i.e., define the color to be +associated with a color index. Ignored for devices which do not +support variable color or intensity. Color indices 0-15 +have predefined color representations (see the PGPLOT manual), but +these may be changed with PGSCR. Color indices 16-maximum have no +predefined representations: if these indices are used, PGSCR must +be called to define the representation. On monochrome output +devices (e.g. VT125 terminals with monochrome monitors), the +monochrome intensity is computed from the specified Red, Green, Blue +intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television +systems, NTSC encoding. Note that most devices do not have an +infinite range of colors or monochrome intensities available; +the nearest available color is used. Examples: for black, +set CR=CG=CB=0.0; for white, set CR=CG=CB=1.0; for medium gray, +set CR=CG=CB=0.5; for medium yellow, set CR=CG=0.5, CB=0.0. + +Argument: + CI (input) : the color index to be defined, in the range 0-max. + If the color index greater than the device + maximum is specified, the call is ignored. Color + index 0 applies to the background color. + CR (input) : red, green, and blue intensities, + CG (input) in range 0.0 to 1.0. + CB (input) + + +------------------------------------------------------------------------ +Module: PGSCRL -- scroll window +------------------------------------------------------------------------ + + SUBROUTINE PGSCRL (DX, DY) + REAL DX, DY + +This routine moves the window in world-coordinate space while +leaving the viewport unchanged. On devices that have the +capability, the pixels within the viewport are scrolled +horizontally, vertically or both in such a way that graphics +previously drawn in the window are shifted so that their world +coordinates are unchanged. + +If the old window coordinate range was (X1, X2, Y1, Y2), the new +coordinate range will be approximately (X1+DX, X2+DX, Y1+DY, Y2+DY). +The size and scale of the window are unchanged. + +Thee window can only be shifted by a whole number of pixels +(device coordinates). If DX and DY do not correspond to integral +numbers of pixels, the shift will be slightly different from that +requested. The new window-coordinate range, and hence the exact +amount of the shift, can be determined by calling PGQWIN after this +routine. + +Pixels that are moved out of the viewport by this operation are +lost completely; they cannot be recovered by scrolling back. +Pixels that are ``scrolled into'' the viewport are filled with +the background color (color index 0). + +If the absolute value of DX is bigger than the width of the window, +or the aboslute value of DY is bigger than the height of the window, +the effect will be the same as zeroing all the pixels in the +viewport. + +Not all devices have the capability to support this routine. +It is only available on some interactive devices that have discrete +pixels. To determine whether the current device has scroll capability, +call PGQINF. + +Arguments: + DX (input) : distance (in world coordinates) to shift the + window horizontally (positive shifts window to the + right and scrolls to the left). + DY (input) : distance (in world coordinates) to shift the + window vertically (positive shifts window up and + scrolls down). + + +------------------------------------------------------------------------ +Module: PGSCRN -- set color representation by name +------------------------------------------------------------------------ + + SUBROUTINE PGSCRN(CI, NAME, IER) + INTEGER CI + CHARACTER*(*) NAME + INTEGER IER + +Set color representation: i.e., define the color to be +associated with a color index. Ignored for devices which do not +support variable color or intensity. This is an alternative to +routine PGSCR. The color representation is defined by name instead +of (R,G,B) components. + +Color names are defined in an external file which is read the first +time that PGSCRN is called. The name of the external file is +found as follows: +1. if environment variable (logical name) PGPLOT_RGB is defined, + its value is used as the file name; +2. otherwise, if environment variable PGPLOT_DIR is defined, a + file "rgb.txt" in the directory named by this environment + variable is used; +3. otherwise, file "rgb.txt" in the current directory is used. +If all of these fail to find a file, an error is reported and +the routine does nothing. + +Each line of the file +defines one color, with four blank- or tab-separated fields per +line. The first three fields are the R, G, B components, which +are integers in the range 0 (zero intensity) to 255 (maximum +intensity). The fourth field is the color name. The color name +may include embedded blanks. Example: + +255 0 0 red +255 105 180 hot pink +255 255 255 white + 0 0 0 black + +Arguments: + CI (input) : the color index to be defined, in the range 0-max. + If the color index greater than the device + maximum is specified, the call is ignored. Color + index 0 applies to the background color. + NAME (input) : the name of the color to be associated with + this color index. This name must be in the + external file. The names are not case-sensitive. + If the color is not listed in the file, the + color representation is not changed. + IER (output) : returns 0 if the routine was successful, 1 + if an error occurred (either the external file + could not be read, or the requested color was + not defined in the file). + + +------------------------------------------------------------------------ +Module: PGSFS -- set fill-area style +------------------------------------------------------------------------ + + SUBROUTINE PGSFS (FS) + INTEGER FS + +Set the Fill-Area Style attribute for subsequent area-fill by +PGPOLY, PGRECT, or PGCIRC. Four different styles are available: +solid (fill polygon with solid color of the current color-index), +outline (draw outline of polygon only, using current line attributes), +hatched (shade interior of polygon with parallel lines, using +current line attributes), or cross-hatched. The orientation and +spacing of hatch lines can be specified with routine PGSHS (set +hatch style). + +Argument: + FS (input) : the fill-area style to be used for subsequent + plotting: + FS = 1 => solid (default) + FS = 2 => outline + FS = 3 => hatched + FS = 4 => cross-hatched + Other values give an error message and are + treated as 2. + + +------------------------------------------------------------------------ +Module: PGSHLS -- set color representation using HLS system +------------------------------------------------------------------------ + + SUBROUTINE PGSHLS (CI, CH, CL, CS) + INTEGER CI + REAL CH, CL, CS + +Set color representation: i.e., define the color to be +associated with a color index. This routine is equivalent to +PGSCR, but the color is defined in the Hue-Lightness-Saturation +model instead of the Red-Green-Blue model. Hue is represented +by an angle in degrees, with red at 120, green at 240, +and blue at 0 (or 360). Lightness ranges from 0.0 to 1.0, with black +at lightness 0.0 and white at lightness 1.0. Saturation ranges from +0.0 (gray) to 1.0 (pure color). Hue is irrelevant when saturation +is 0.0. + +Examples: H L S R G B + black any 0.0 0.0 0.0 0.0 0.0 + white any 1.0 0.0 1.0 1.0 1.0 + medium gray any 0.5 0.0 0.5 0.5 0.5 + red 120 0.5 1.0 1.0 0.0 0.0 + yellow 180 0.5 1.0 1.0 1.0 0.0 + pink 120 0.7 0.8 0.94 0.46 0.46 + +Reference: SIGGRAPH Status Report of the Graphic Standards Planning +Committee, Computer Graphics, Vol.13, No.3, Association for +Computing Machinery, New York, NY, 1979. See also: J. D. Foley et al, +``Computer Graphics: Principles and Practice'', second edition, +Addison-Wesley, 1990, section 13.3.5. + +Argument: + CI (input) : the color index to be defined, in the range 0-max. + If the color index greater than the device + maximum is specified, the call is ignored. Color + index 0 applies to the background color. + CH (input) : hue, in range 0.0 to 360.0. + CL (input) : lightness, in range 0.0 to 1.0. + CS (input) : saturation, in range 0.0 to 1.0. + + +------------------------------------------------------------------------ +Module: PGSHS -- set hatching style +------------------------------------------------------------------------ + + SUBROUTINE PGSHS (ANGLE, SEPN, PHASE) + REAL ANGLE, SEPN, PHASE + +Set the style to be used for hatching (fill area with fill-style 3). +The default style is ANGLE=45.0, SEPN=1.0, PHASE=0.0. + +Arguments: + ANGLE (input) : the angle the hatch lines make with the + horizontal, in degrees, increasing + counterclockwise (this is an angle on the + view surface, not in world-coordinate space). + SEPN (input) : the spacing of the hatch lines. The unit spacing + is 1 percent of the smaller of the height or + width of the view surface. This should not be + zero. + PHASE (input) : a real number between 0 and 1; the hatch lines + are displaced by this fraction of SEPN from a + fixed reference. Adjacent regions hatched with the + same PHASE have contiguous hatch lines. To hatch + a region with alternating lines of two colors, + fill the area twice, with PHASE=0.0 for one color + and PHASE=0.5 for the other color. + + +------------------------------------------------------------------------ +Module: PGSITF -- set image transfer function +------------------------------------------------------------------------ + + SUBROUTINE PGSITF (ITF) + INTEGER ITF + +Set the Image Transfer Function for subsequent images drawn by +PGIMAG, PGGRAY, or PGWEDG. The Image Transfer Function is used +to map array values into the available range of color indices +specified with routine PGSCIR or (for PGGRAY on some devices) +into dot density. + +Argument: + ITF (input) : type of transfer function: + ITF = 0 : linear + ITF = 1 : logarithmic + ITF = 2 : square-root + + +------------------------------------------------------------------------ +Module: PGSLCT -- select an open graphics device +------------------------------------------------------------------------ + + SUBROUTINE PGSLCT(ID) + INTEGER ID + +Select one of the open graphics devices and direct subsequent +plotting to it. The argument is the device identifier returned by +PGOPEN when the device was opened. If the supplied argument is not a +valid identifier of an open graphics device, a warning message is +issued and the current selection is unchanged. + +[This routine was added to PGPLOT in Version 5.1.0.] + +Arguments: + +ID (input, integer): identifier of the device to be selected. + + +------------------------------------------------------------------------ +Module: PGSLS -- set line style +------------------------------------------------------------------------ + + SUBROUTINE PGSLS (LS) + INTEGER LS + +Set the line style attribute for subsequent plotting. This +attribute affects line primitives only; it does not affect graph +markers, text, or area fill. +Five different line styles are available, with the following codes: +1 (full line), 2 (dashed), 3 (dot-dash-dot-dash), 4 (dotted), +5 (dash-dot-dot-dot). The default is 1 (normal full line). + +Argument: + LS (input) : the line-style code for subsequent plotting + (in range 1-5). + + +------------------------------------------------------------------------ +Module: PGSLW -- set line width +------------------------------------------------------------------------ + + SUBROUTINE PGSLW (LW) + INTEGER LW + +Set the line-width attribute. This attribute affects lines, graph +markers, and text. The line width is specified in units of 1/200 +(0.005) inch (about 0.13 mm) and must be an integer in the range +1-201. On some devices, thick lines are generated by tracing each +line with multiple strokes offset in the direction perpendicular to +the line. + +Argument: + LW (input) : width of line, in units of 0.005 inch (0.13 mm) + in range 1-201. + + +------------------------------------------------------------------------ +Module: PGSTBG -- set text background color index +------------------------------------------------------------------------ + + SUBROUTINE PGSTBG (TBCI) + INTEGER TBCI + +Set the Text Background Color Index for subsequent text. By default +text does not obscure underlying graphics. If the text background +color index is positive, however, text is opaque: the bounding box +of the text is filled with the color specified by PGSTBG before +drawing the text characters in the current color index set by PGSCI. +Use color index 0 to erase underlying graphics before drawing text. + +Argument: + TBCI (input) : the color index to be used for the background + for subsequent text plotting: + TBCI < 0 => transparent (default) + TBCI >= 0 => text will be drawn on an opaque + background with color index TBCI. + + +------------------------------------------------------------------------ +Module: PGSUBP -- subdivide view surface into panels +------------------------------------------------------------------------ + + SUBROUTINE PGSUBP (NXSUB, NYSUB) + INTEGER NXSUB, NYSUB + +PGPLOT divides the physical surface of the plotting device (screen, +window, or sheet of paper) into NXSUB x NYSUB `panels'. When the +view surface is sub-divided in this way, PGPAGE moves to the next +panel, not the next physical page. The initial subdivision of the +view surface is set in the call to PGBEG. When PGSUBP is called, +it forces the next call to PGPAGE to start a new physical page, +subdivided in the manner indicated. No plotting should be done +between a call of PGSUBP and a call of PGPAGE (or PGENV, which calls +PGPAGE). + +If NXSUB > 0, PGPLOT uses the panels in row order; if <0, +PGPLOT uses them in column order, e.g., + + NXSUB=3, NYSUB=2 NXSUB=-3, NYSUB=2 + ++-----+-----+-----+ +-----+-----+-----+ +| 1 | 2 | 3 | | 1 | 3 | 5 | ++-----+-----+-----+ +-----+-----+-----+ +| 4 | 5 | 6 | | 2 | 4 | 6 | ++-----+-----+-----+ +-----+-----+-----+ + +PGPLOT advances from one panels to the next when PGPAGE is called, +clearing the screen or starting a new page when the last panel has +been used. It is also possible to jump from one panel to another +in random order by calling PGPANL. + +Arguments: + NXSUB (input) : the number of subdivisions of the view surface in + X (>0 or <0). + NYSUB (input) : the number of subdivisions of the view surface in + Y (>0). + + +------------------------------------------------------------------------ +Module: PGSVP -- set viewport (normalized device coordinates) +------------------------------------------------------------------------ + + SUBROUTINE PGSVP (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +Change the size and position of the viewport, specifying +the viewport in normalized device coordinates. Normalized +device coordinates run from 0 to 1 in each dimension. The +viewport is the rectangle on the view surface "through" +which one views the graph. All the PG routines which plot lines +etc. plot them within the viewport, and lines are truncated at +the edge of the viewport (except for axes, labels etc drawn with +PGBOX or PGLAB). The region of world space (the coordinate +space of the graph) which is visible through the viewport is +specified by a call to PGSWIN. It is legal to request a +viewport larger than the view surface; only the part which +appears on the view surface will be plotted. + +Arguments: + XLEFT (input) : x-coordinate of left hand edge of viewport, in NDC. + XRIGHT (input) : x-coordinate of right hand edge of viewport, + in NDC. + YBOT (input) : y-coordinate of bottom edge of viewport, in NDC. + YTOP (input) : y-coordinate of top edge of viewport, in NDC. + + +------------------------------------------------------------------------ +Module: PGSWIN -- set window +------------------------------------------------------------------------ + + SUBROUTINE PGSWIN (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +Change the window in world coordinate space that is to be mapped on +to the viewport. Usually PGSWIN is called automatically by PGENV, +but it may be called directly by the user. + +Arguments: + X1 (input) : the x-coordinate of the bottom left corner + of the viewport. + X2 (input) : the x-coordinate of the top right corner + of the viewport (note X2 may be less than X1). + Y1 (input) : the y-coordinate of the bottom left corner + of the viewport. + Y2 (input) : the y-coordinate of the top right corner + of the viewport (note Y2 may be less than Y1). + + +------------------------------------------------------------------------ +Module: PGTBOX -- draw frame and write (DD) HH MM SS.S labelling +------------------------------------------------------------------------ + + SUBROUTINE PGTBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB) + + REAL XTICK, YTICK + INTEGER NXSUB, NYSUB + CHARACTER XOPT*(*), YOPT*(*) + +Draw a box and optionally label one or both axes with (DD) HH MM SS +style numeric labels (useful for time or RA - DEC plots). If this +style of labelling is desired, then PGSWIN should have been called +previously with the extrema in SECONDS of time. + +In the seconds field, you can have at most 3 places after the decimal +point, so that 1 ms is the smallest time interval you can time label. + +Large numbers are coped with by fields of 6 characters long. Thus +you could have times with days or hours as big as 999999. However, +in practice, you might have trouble with labels overwriting themselves +with such large numbers unless you a) use a small time INTERVAL, +b) use a small character size or c) choose your own sparse ticks in +the call to PGTBOX. + +PGTBOX will attempt, when choosing its own ticks, not to overwrite +the labels, but this algorithm is not very bright and may fail. + +Note that small intervals but large absolute times such as +TMIN = 200000.0 s and TMAX=200000.1 s will cause the algorithm +to fail. This is inherent in PGPLOT's use of single precision +and cannot be avoided. In such cases, you should use relative +times if possible. + +PGTBOX's labelling philosophy is that the left-most or bottom tick of +the axis contains a full label. Thereafter, only changing fields are +labelled. Negative fields are given a '-' label, positive fields +have none. Axes that have the DD (or HH if the day field is not +used) field on each major tick carry the sign on each field. If the +axis crosses zero, the zero tick will carry a full label and sign. + +This labelling style can cause a little confusion with some special +cases, but as long as you know its philosophy, the truth can be divined. +Consider an axis with TMIN=20s, TMAX=-20s. The labels will look like + + +----------+----------+----------+----------+ + 0h0m20s 10s -0h0m0s 10s 20s + +Knowing that the left field always has a full label and that +positive fields are unsigned, informs that time is decreasing +from left to right, not vice versa. This can become very +unclear if you have used the 'F' option, but that is your problem ! + +Exceptions to this labelling philosophy are when the finest time +increment being displayed is hours (with option 'Y') or days. +Then all fields carry a label. For example, + + +----------+----------+----------+----------+ + -10h -8h -6h -4h -2h + + +PGTBOX can be used in place of PGBOX; it calls PGBOX and only invokes +time labelling if requested. Other options are passed intact to PGBOX. + +Inputs: + XOPT : X-options for PGTBOX. Same as for PGBOX plus + + 'Z' for (DD) HH MM SS.S time labelling + 'Y' means don't include the day field so that labels + are HH MM SS.S rather than DD HH MM SS.S The hours + will accumulate beyond 24 if necessary in this case. + 'X' label the HH field as modulo 24. Thus, a label + such as 25h 10m would come out as 1h 10m + 'H' means superscript numbers with d, h, m, & s symbols + 'D' means superscript numbers with o, ', & '' symbols + 'F' causes the first label (left- or bottom-most) to + be omitted. Useful for sub-panels that abut each other. + Care is needed because first label carries sign as well. + 'O' means omit leading zeros in numbers < 10 + E.g. 3h 3m 1.2s rather than 03h 03m 01.2s Useful + to help save space on X-axes. The day field does not + use this facility. + + YOPT : Y-options for PGTBOX. See above. + XTICK : X-axis major tick increment. 0.0 for default. + YTICK : Y-axis major tick increment. 0.0 for default. + If the 'Z' option is used then XTICK and/or YTICK must + be in seconds. + NXSUB : Number of intervals for minor ticks on X-axis. 0 for default + NYSUB : Number of intervals for minor ticks on Y-axis. 0 for default + + The regular XOPT and YOPT axis options for PGBOX are + + A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical + line X=0). + B : draw bottom (X) or left (Y) edge of frame. + C : draw top (X) or right (Y) edge of frame. + G : draw Grid of vertical (X) or horizontal (Y) lines. + I : Invert the tick marks; ie draw them outside the viewport + instead of inside. + L : label axis Logarithmically (see below). + N : write Numeric labels in the conventional location below the + viewport (X) or to the left of the viewport (Y). + P : extend ("Project") major tick marks outside the box (ignored if + option I is specified). + M : write numeric labels in the unconventional location above the + viewport (X) or to the right of the viewport (Y). + T : draw major Tick marks at the major coordinate interval. + S : draw minor tick marks (Subticks). + V : orient numeric labels Vertically. This is only applicable to Y. + The default is to write Y-labels parallel to the axis. + 1 : force decimal labelling, instead of automatic choice (see PGNUMB). + 2 : force exponential labelling, instead of automatic. + + The default is to write Y-labels parallel to the axis + + + ****************** EXCEPTIONS ******************* + + Note that + 1) PGBOX option 'L' (log labels) is ignored with option 'Z' + 2) The 'O' option will be ignored for the 'V' option as it + makes it impossible to align the labels nicely + 3) Option 'Y' is forced with option 'D' + + *************************************************************** + + + + +------------------------------------------------------------------------ +Module: PGTEXT -- write text (horizontal, left-justified) +------------------------------------------------------------------------ + + SUBROUTINE PGTEXT (X, Y, TEXT) + REAL X, Y + CHARACTER*(*) TEXT + +Write text. The bottom left corner of the first character is placed +at the specified position, and the text is written horizontally. +This is a simplified interface to the primitive routine PGPTXT. +For non-horizontal text, use PGPTXT. + +Arguments: + X (input) : world x-coordinate of start of string. + Y (input) : world y-coordinate of start of string. + TEXT (input) : the character string to be plotted. + + +------------------------------------------------------------------------ +Module: PGTICK -- draw a single tick mark on an axis +------------------------------------------------------------------------ + + SUBROUTINE PGTICK (X1, Y1, X2, Y2, V, TIKL, TIKR, DISP, + : ORIENT, STR) + REAL X1, Y1, X2, Y2, V, TIKL, TIKR, DISP, ORIENT + CHARACTER*(*) STR + +Draw and label single tick mark on a graph axis. The tick mark is +a short line perpendicular to the direction of the axis (which is not +drawn by this routine). The optional text label is drawn with its +baseline parallel to the axis and reading in the same direction as +the axis (from point 1 to point 2). Current line and text attributes +are used. + +Arguments: + X1, Y1 (input) : world coordinates of one endpoint of the axis. + X2, Y2 (input) : world coordinates of the other endpoint of the axis. + V (input) : draw the tick mark at fraction V (0<=V<=1) along + the line from (X1,Y1) to (X2,Y2). + TIKL (input) : length of tick mark drawn to left of axis + (as seen looking from first endpoint to second), in + units of the character height. + TIKR (input) : length of major tick marks drawn to right of axis, + in units of the character height. + DISP (input) : displacement of label text to + right of axis, in units of the character height. + ORIENT (input) : orientation of label text, in degrees; angle between + baseline of text and direction of axis (0-360°). + STR (input) : text of label (may be blank). + + +------------------------------------------------------------------------ +Module: PGUPDT -- update display +------------------------------------------------------------------------ + + SUBROUTINE PGUPDT + +Update the graphics display: flush any pending commands to the +output device. This routine empties the buffer created by PGBBUF, +but it does not alter the PGBBUF/PGEBUF counter. The routine should +be called when it is essential that the display be completely up to +date (before interaction with the user, for example) but it is not +known if output is being buffered. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGVECT -- vector map of a 2D data array, with blanking +------------------------------------------------------------------------ + + SUBROUTINE PGVECT (A, B, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR, + 1 BLANK) + INTEGER IDIM, JDIM, I1, I2, J1, J2, NC + REAL A(IDIM,JDIM), B(IDIM, JDIM), TR(6), BLANK, C + +Draw a vector map of two arrays. This routine is similar to +PGCONB in that array elements that have the "magic value" defined by +the argument BLANK are ignored, making gaps in the vector map. The +routine may be useful for data measured on most but not all of the +points of a grid. Vectors are displayed as arrows; the style of the +arrowhead can be set with routine PGSAH, and the the size of the +arrowhead is determined by the current character size, set by PGSCH. + +Arguments: + A (input) : horizontal component data array. + B (input) : vertical component data array. + IDIM (input) : first dimension of A and B. + JDIM (input) : second dimension of A and B. + I1,I2 (input) : range of first index to be mapped (inclusive). + J1,J2 (input) : range of second index to be mapped (inclusive). + C (input) : scale factor for vector lengths, if 0.0, C will be + set so that the longest vector is equal to the + smaller of TR(2)+TR(3) and TR(5)+TR(6). + NC (input) : vector positioning code. + <0 vector head positioned on coordinates + >0 vector base positioned on coordinates + =0 vector centered on the coordinates + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + BLANK (input) : elements of arrays A or B that are exactly equal to + this value are ignored (blanked). + + +------------------------------------------------------------------------ +Module: PGVSIZ -- set viewport (inches) +------------------------------------------------------------------------ + + SUBROUTINE PGVSIZ (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +Change the size and position of the viewport, specifying +the viewport in physical device coordinates (inches). The +viewport is the rectangle on the view surface "through" +which one views the graph. All the PG routines which plot lines +etc. plot them within the viewport, and lines are truncated at +the edge of the viewport (except for axes, labels etc drawn with +PGBOX or PGLAB). The region of world space (the coordinate +space of the graph) which is visible through the viewport is +specified by a call to PGSWIN. It is legal to request a +viewport larger than the view surface; only the part which +appears on the view surface will be plotted. + +Arguments: + XLEFT (input) : x-coordinate of left hand edge of viewport, in + inches from left edge of view surface. + XRIGHT (input) : x-coordinate of right hand edge of viewport, in + inches from left edge of view surface. + YBOT (input) : y-coordinate of bottom edge of viewport, in + inches from bottom of view surface. + YTOP (input) : y-coordinate of top edge of viewport, in inches + from bottom of view surface. + + +------------------------------------------------------------------------ +Module: PGVSTD -- set standard (default) viewport +------------------------------------------------------------------------ + + SUBROUTINE PGVSTD + +Define the viewport to be the standard viewport. The standard +viewport is the full area of the view surface (or panel), +less a margin of 4 character heights all round for labelling. +It thus depends on the current character size, set by PGSCH. + +Arguments: none. + + +------------------------------------------------------------------------ +Module: PGWEDG -- annotate an image plot with a wedge +------------------------------------------------------------------------ + + SUBROUTINE PGWEDG(SIDE, DISP, WIDTH, FG, BG, LABEL) + CHARACTER *(*) SIDE,LABEL + REAL DISP, WIDTH, FG, BG + +Plot an annotated grey-scale or color wedge parallel to a given axis +of the the current viewport. This routine is designed to provide a +brightness/color scale for an image drawn with PGIMAG or PGGRAY. +The wedge will be drawn with the transfer function set by PGSITF +and using the color index range set by PGSCIR. + +Arguments: + SIDE (input) : The first character must be one of the characters + 'B', 'L', 'T', or 'R' signifying the Bottom, Left, + Top, or Right edge of the viewport. + The second character should be 'I' to use PGIMAG + to draw the wedge, or 'G' to use PGGRAY. + DISP (input) : the displacement of the wedge from the specified + edge of the viewport, measured outwards from the + viewport in units of the character height. Use a + negative value to write inside the viewport, a + positive value to write outside. + WIDTH (input) : The total width of the wedge including annotation, + in units of the character height. + FG (input) : The value which is to appear with shade + 1 ("foreground"). Use the values of FG and BG + that were supplied to PGGRAY or PGIMAG. + BG (input) : the value which is to appear with shade + 0 ("background"). + LABEL (input) : Optional units label. If no label is required + use ' '. + + +------------------------------------------------------------------------ +Module: PGWNAD -- set window and adjust viewport to same aspect ratio +------------------------------------------------------------------------ + + SUBROUTINE PGWNAD (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +Change the window in world coordinate space that is to be mapped on +to the viewport, and simultaneously adjust the viewport so that the +world-coordinate scales are equal in x and y. The new viewport is +the largest one that can fit within the previously set viewport +while retaining the required aspect ratio. + +Arguments: + X1 (input) : the x-coordinate of the bottom left corner + of the viewport. + X2 (input) : the x-coordinate of the top right corner + of the viewport (note X2 may be less than X1). + Y1 (input) : the y-coordinate of the bottom left corner + of the viewport. + Y2 (input) : the y-coordinate of the top right corner of the + viewport (note Y2 may be less than Y1). + + +------------------------------------------------------------------------ +Module: PGADVANCE -- non-standard alias for PGPAGE +------------------------------------------------------------------------ + + SUBROUTINE PGADVANCE + +See description of PGPAGE. + + +------------------------------------------------------------------------ +Module: PGBEGIN -- non-standard alias for PGBEG +------------------------------------------------------------------------ + + INTEGER FUNCTION PGBEGIN (UNIT, FILE, NXSUB, NYSUB) + INTEGER UNIT + CHARACTER*(*) FILE + INTEGER NXSUB, NYSUB + +See description of PGBEG. + + +------------------------------------------------------------------------ +Module: PGCURSE -- non-standard alias for PGCURS +------------------------------------------------------------------------ + + INTEGER FUNCTION PGCURSE (X, Y, CH) + REAL X, Y + CHARACTER*1 CH + +See description of PGCURS. + + +------------------------------------------------------------------------ +Module: PGLABEL -- non-standard alias for PGLAB +------------------------------------------------------------------------ + + SUBROUTINE PGLABEL (XLBL, YLBL, TOPLBL) + CHARACTER*(*) XLBL, YLBL, TOPLBL + +See description of PGLAB. + + +------------------------------------------------------------------------ +Module: PGMTEXT -- non-standard alias for PGMTXT +------------------------------------------------------------------------ + + SUBROUTINE PGMTEXT (SIDE, DISP, COORD, FJUST, TEXT) + CHARACTER*(*) SIDE, TEXT + REAL DISP, COORD, FJUST + +See description of PGMTXT. + + +------------------------------------------------------------------------ +Module: PGNCURSE -- non-standard alias for PGNCUR +------------------------------------------------------------------------ + + SUBROUTINE PGNCURSE (MAXPT, NPT, X, Y, SYMBOL) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + INTEGER SYMBOL + +See description of PGNCUR. + + +------------------------------------------------------------------------ +Module: PGPAPER -- non-standard alias for PGPAP +------------------------------------------------------------------------ + + SUBROUTINE PGPAPER (WIDTH, ASPECT) + REAL WIDTH, ASPECT + +See description of PGPAP. + + +------------------------------------------------------------------------ +Module: PGPOINT -- non-standard alias for PGPT +------------------------------------------------------------------------ + + SUBROUTINE PGPOINT (N, XPTS, YPTS, SYMBOL) + INTEGER N + REAL XPTS(*), YPTS(*) + INTEGER SYMBOL + +See description of PGPT. + + +------------------------------------------------------------------------ +Module: PGPTEXT -- non-standard alias for PGPTXT +------------------------------------------------------------------------ + + SUBROUTINE PGPTEXT (X, Y, ANGLE, FJUST, TEXT) + REAL X, Y, ANGLE, FJUST + CHARACTER*(*) TEXT + +See description of PGPTXT. + + +------------------------------------------------------------------------ +Module: PGVPORT -- non-standard alias for PGSVP +------------------------------------------------------------------------ + + SUBROUTINE PGVPORT (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +See description of PGSVP. + + +------------------------------------------------------------------------ +Module: PGVSIZE -- non-standard alias for PGVSIZ +------------------------------------------------------------------------ + + SUBROUTINE PGVSIZE (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +See description of PGVSIZ. + + +------------------------------------------------------------------------ +Module: PGVSTAND -- non-standard alias for PGVSTD +------------------------------------------------------------------------ + + SUBROUTINE PGVSTAND + +See description of PGVSTD. + + +------------------------------------------------------------------------ +Module: PGWINDOW -- non-standard alias for PGSWIN +------------------------------------------------------------------------ + + SUBROUTINE PGWINDOW (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +See description of PGSWIN. diff --git a/pgplot_rhel7/pgplot.inc b/pgplot_rhel7/pgplot.inc new file mode 100644 index 0000000..e15f308 --- /dev/null +++ b/pgplot_rhel7/pgplot.inc @@ -0,0 +1,135 @@ +C----------------------------------------------------------------------- +C PGPLOT: common block definition. +C----------------------------------------------------------------------- +C Maximum number of concurrent devices (should match GRIMAX). +C----------------------------------------------------------------------- + INTEGER PGMAXD + PARAMETER (PGMAXD=8) +C----------------------------------------------------------------------- +C Indentifier of currently selected device. +C----------------------------------------------------------------------- + INTEGER PGID +C----------------------------------------------------------------------- +C Device status (indexed by device identifier). +C----------------------------------------------------------------------- +C PGDEVS =0 if device is not open; 1 if device is open. +C PGADVS Set to 0 by PGBEGIN, set to 1 by PGPAGE; used to suppress +C the prompt for the first page. +C PROMPT If .TRUE., ask user before clearing page; set by PGASK +C and (indirectly) by PGBEGIN, used in PGENV. +C PGBLEV Buffering level: incremented by PGBBUF, decremented by +C PGEBUF. +C PGPFIX TRUE if PGPAP has been called, FALSE otherwise. +C + INTEGER PGDEVS(PGMAXD), PGADVS(PGMAXD), PGBLEV(PGMAXD) + LOGICAL PGPRMP(PGMAXD), PGPFIX(PGMAXD) +C----------------------------------------------------------------------- +C Panel parameters (indexed by device identification). +C----------------------------------------------------------------------- +C NX Number of panels in x direction +C NY Number of panels in y direction +C NXC Ordinal number of current X panel +C NYC Ordinal number of current Y panel +C XSZ X dimension of panel (device units) +C YSZ Y dimension of panel (device units) +C PGROWS TRUE if panels are used in row order, FALSE for column +C order. +C + INTEGER PGNX (PGMAXD), PGNY (PGMAXD) + INTEGER PGNXC (PGMAXD), PGNYC (PGMAXD) + REAL PGXSZ (PGMAXD), PGYSZ (PGMAXD) + LOGICAL PGROWS(PGMAXD) +C----------------------------------------------------------------------- +C Attributes (indexed by device identification). +C----------------------------------------------------------------------- +C PGCLP clipping enabled/disabed +C PGFAS fill-area style +C PGCHSZ character height +C PGAHS arrow-head fill style +C PGAHA arrow-head angle +C PGAHV arrow-head vent +C PGTBCI text background color index +C PGMNCI lower range of color indices available to PGGRAY/PGIMAG +C PGMXCI upper range of color indices available to PGGRAY/PGIMAG +C PGITF type of transfer function used by PGGRAY/PGIMAG +C PGHSA hatching line angle +C PGHSS hatching line separation +C PGHSP hatching line phase +C + INTEGER PGCLP (PGMAXD) + INTEGER PGFAS (PGMAXD) + REAL PGCHSZ(PGMAXD) + INTEGER PGAHS (PGMAXD) + REAL PGAHA (PGMAXD) + REAL PGAHV (PGMAXD) + INTEGER PGTBCI(PGMAXD) + INTEGER PGMNCI(PGMAXD) + INTEGER PGMXCI(PGMAXD) + INTEGER PGITF (PGMAXD) + REAL PGHSA (PGMAXD) + REAL PGHSS (PGMAXD) + REAL PGHSP (PGMAXD) +C----------------------------------------------------------------------- +C Viewport parameters (indexed by device identification); all are device +C coordinates: +C----------------------------------------------------------------------- +C PGXOFF X coordinate of blc of viewport. +C PGYOFF Y coordinate of blc of viewport. +C PGXVP X coordinate of blc of viewport, relative to blc of subpage. +C PGYVP Y coordinate of blc of viewport, relative to blc of subpage. +C PGXLEN Width of viewport. +C PGYLEN Height of viewport. +C + REAL PGXOFF(PGMAXD), PGYOFF(PGMAXD) + REAL PGXVP (PGMAXD), PGYVP (PGMAXD) + REAL PGXLEN(PGMAXD), PGYLEN(PGMAXD) +C----------------------------------------------------------------------- +C Scaling parameters (indexed by device identification): +C----------------------------------------------------------------------- +C PGXORG device coordinate value corresponding to world X=0 +C PGYORG device coordinate value corresponding to world Y=0 +C PGXSCL scale in x (device units per world coordinate unit) +C PGYSCL scale in y (device units per world coordinate unit) +C PGXPIN device x scale in device units/inch +C PGYPIN device y scale in device units/inch +C PGXSP Character X spacing (device units) +C PGYSP Character Y spacing (device units) +C + REAL PGXORG(PGMAXD), PGYORG(PGMAXD) + REAL PGXSCL(PGMAXD), PGYSCL(PGMAXD) + REAL PGXPIN(PGMAXD), PGYPIN(PGMAXD) + REAL PGXSP (PGMAXD), PGYSP (PGMAXD) +C----------------------------------------------------------------------- +C Window parameters (indexed by device identification); all are world +C coordinate values: +C----------------------------------------------------------------------- +C PGXBLC world X at bottom left corner of window +C PGXTRC world X at top right corner of window +C PGYBLC world Y at bottom left corner of window +C PGYTRC world Y at top right corner of window +C + REAL PGXBLC(PGMAXD), PGXTRC(PGMAXD) + REAL PGYBLC(PGMAXD), PGYTRC(PGMAXD) +C----------------------------------------------------------------------- +C The following parameters are used in the contouring routines to pass +C information to the action routine. They do not need to be indexed. +C----------------------------------------------------------------------- +C TRANS Transformation matrix for contour plots; copied +C from argument list by PGCONT and used by PGCP. +C + INTEGER PGCINT, PGCMIN + REAL TRANS(6) + CHARACTER*32 PGCLAB +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + COMMON /PGPLT1/ PGID,PGDEVS,PGADVS,PGNX, PGNY, PGNXC, PGNYC , + 1 PGXPIN,PGYPIN,PGXSP, PGYSP, PGXSZ, PGYSZ, + 2 PGXOFF,PGYOFF,PGXVP, PGYVP, PGXLEN,PGYLEN,PGXORG,PGYORG, + 3 PGXSCL,PGYSCL,PGXBLC,PGXTRC,PGYBLC,PGYTRC,TRANS, + 4 PGPRMP,PGCLP, PGFAS, PGCHSZ,PGBLEV,PGROWS, + 5 PGAHS, PGAHA, PGAHV, PGTBCI,PGMNCI,PGMXCI,PGCINT,PGCMIN, + 6 PGPFIX,PGITF, PGHSA, PGHSS, PGHSP + COMMON /PGPLT2/ PGCLAB + SAVE /PGPLT1/ + SAVE /PGPLT2/ +C----------------------------------------------------------------------- diff --git a/pgplot_rhel7/pgpnts.o b/pgplot_rhel7/pgpnts.o new file mode 100644 index 0000000..f98e127 Binary files /dev/null and b/pgplot_rhel7/pgpnts.o differ diff --git a/pgplot_rhel7/pgpoint.o b/pgplot_rhel7/pgpoint.o new file mode 100644 index 0000000..eb621d1 Binary files /dev/null and b/pgplot_rhel7/pgpoint.o differ diff --git a/pgplot_rhel7/pgpoly.o b/pgplot_rhel7/pgpoly.o new file mode 100644 index 0000000..0f830f0 Binary files /dev/null and b/pgplot_rhel7/pgpoly.o differ diff --git a/pgplot_rhel7/pgpt.o b/pgplot_rhel7/pgpt.o new file mode 100644 index 0000000..699b0d3 Binary files /dev/null and b/pgplot_rhel7/pgpt.o differ diff --git a/pgplot_rhel7/pgpt1.o b/pgplot_rhel7/pgpt1.o new file mode 100644 index 0000000..f883b30 Binary files /dev/null and b/pgplot_rhel7/pgpt1.o differ diff --git a/pgplot_rhel7/pgptext.o b/pgplot_rhel7/pgptext.o new file mode 100644 index 0000000..6f6f823 Binary files /dev/null and b/pgplot_rhel7/pgptext.o differ diff --git a/pgplot_rhel7/pgptxt.o b/pgplot_rhel7/pgptxt.o new file mode 100644 index 0000000..e62f4cd Binary files /dev/null and b/pgplot_rhel7/pgptxt.o differ diff --git a/pgplot_rhel7/pgqah.o b/pgplot_rhel7/pgqah.o new file mode 100644 index 0000000..144cbbd Binary files /dev/null and b/pgplot_rhel7/pgqah.o differ diff --git a/pgplot_rhel7/pgqcf.o b/pgplot_rhel7/pgqcf.o new file mode 100644 index 0000000..9d0e687 Binary files /dev/null and b/pgplot_rhel7/pgqcf.o differ diff --git a/pgplot_rhel7/pgqch.o b/pgplot_rhel7/pgqch.o new file mode 100644 index 0000000..5b344af Binary files /dev/null and b/pgplot_rhel7/pgqch.o differ diff --git a/pgplot_rhel7/pgqci.o b/pgplot_rhel7/pgqci.o new file mode 100644 index 0000000..da2f73f Binary files /dev/null and b/pgplot_rhel7/pgqci.o differ diff --git a/pgplot_rhel7/pgqcir.o b/pgplot_rhel7/pgqcir.o new file mode 100644 index 0000000..8229cd9 Binary files /dev/null and b/pgplot_rhel7/pgqcir.o differ diff --git a/pgplot_rhel7/pgqclp.o b/pgplot_rhel7/pgqclp.o new file mode 100644 index 0000000..8f5e174 Binary files /dev/null and b/pgplot_rhel7/pgqclp.o differ diff --git a/pgplot_rhel7/pgqcol.o b/pgplot_rhel7/pgqcol.o new file mode 100644 index 0000000..92e52a8 Binary files /dev/null and b/pgplot_rhel7/pgqcol.o differ diff --git a/pgplot_rhel7/pgqcr.o b/pgplot_rhel7/pgqcr.o new file mode 100644 index 0000000..52d5e6d Binary files /dev/null and b/pgplot_rhel7/pgqcr.o differ diff --git a/pgplot_rhel7/pgqcs.o b/pgplot_rhel7/pgqcs.o new file mode 100644 index 0000000..85db391 Binary files /dev/null and b/pgplot_rhel7/pgqcs.o differ diff --git a/pgplot_rhel7/pgqdt.o b/pgplot_rhel7/pgqdt.o new file mode 100644 index 0000000..4dc74c2 Binary files /dev/null and b/pgplot_rhel7/pgqdt.o differ diff --git a/pgplot_rhel7/pgqfs.o b/pgplot_rhel7/pgqfs.o new file mode 100644 index 0000000..b3e38be Binary files /dev/null and b/pgplot_rhel7/pgqfs.o differ diff --git a/pgplot_rhel7/pgqhs.o b/pgplot_rhel7/pgqhs.o new file mode 100644 index 0000000..bbf3a98 Binary files /dev/null and b/pgplot_rhel7/pgqhs.o differ diff --git a/pgplot_rhel7/pgqid.o b/pgplot_rhel7/pgqid.o new file mode 100644 index 0000000..397e77b Binary files /dev/null and b/pgplot_rhel7/pgqid.o differ diff --git a/pgplot_rhel7/pgqinf.o b/pgplot_rhel7/pgqinf.o new file mode 100644 index 0000000..dba1d71 Binary files /dev/null and b/pgplot_rhel7/pgqinf.o differ diff --git a/pgplot_rhel7/pgqitf.o b/pgplot_rhel7/pgqitf.o new file mode 100644 index 0000000..9448f68 Binary files /dev/null and b/pgplot_rhel7/pgqitf.o differ diff --git a/pgplot_rhel7/pgqls.o b/pgplot_rhel7/pgqls.o new file mode 100644 index 0000000..93c4bc9 Binary files /dev/null and b/pgplot_rhel7/pgqls.o differ diff --git a/pgplot_rhel7/pgqlw.o b/pgplot_rhel7/pgqlw.o new file mode 100644 index 0000000..f2b0cf2 Binary files /dev/null and b/pgplot_rhel7/pgqlw.o differ diff --git a/pgplot_rhel7/pgqndt.o b/pgplot_rhel7/pgqndt.o new file mode 100644 index 0000000..1ab2e19 Binary files /dev/null and b/pgplot_rhel7/pgqndt.o differ diff --git a/pgplot_rhel7/pgqpos.o b/pgplot_rhel7/pgqpos.o new file mode 100644 index 0000000..7e3594f Binary files /dev/null and b/pgplot_rhel7/pgqpos.o differ diff --git a/pgplot_rhel7/pgqtbg.o b/pgplot_rhel7/pgqtbg.o new file mode 100644 index 0000000..502de0c Binary files /dev/null and b/pgplot_rhel7/pgqtbg.o differ diff --git a/pgplot_rhel7/pgqtxt.o b/pgplot_rhel7/pgqtxt.o new file mode 100644 index 0000000..d4928d9 Binary files /dev/null and b/pgplot_rhel7/pgqtxt.o differ diff --git a/pgplot_rhel7/pgqvp.o b/pgplot_rhel7/pgqvp.o new file mode 100644 index 0000000..542773b Binary files /dev/null and b/pgplot_rhel7/pgqvp.o differ diff --git a/pgplot_rhel7/pgqvsz.o b/pgplot_rhel7/pgqvsz.o new file mode 100644 index 0000000..0784f2e Binary files /dev/null and b/pgplot_rhel7/pgqvsz.o differ diff --git a/pgplot_rhel7/pgqwin.o b/pgplot_rhel7/pgqwin.o new file mode 100644 index 0000000..03d0388 Binary files /dev/null and b/pgplot_rhel7/pgqwin.o differ diff --git a/pgplot_rhel7/pgrect.o b/pgplot_rhel7/pgrect.o new file mode 100644 index 0000000..3d50093 Binary files /dev/null and b/pgplot_rhel7/pgrect.o differ diff --git a/pgplot_rhel7/pgrnd.o b/pgplot_rhel7/pgrnd.o new file mode 100644 index 0000000..6873f82 Binary files /dev/null and b/pgplot_rhel7/pgrnd.o differ diff --git a/pgplot_rhel7/pgrnge.o b/pgplot_rhel7/pgrnge.o new file mode 100644 index 0000000..f172379 Binary files /dev/null and b/pgplot_rhel7/pgrnge.o differ diff --git a/pgplot_rhel7/pgsah.o b/pgplot_rhel7/pgsah.o new file mode 100644 index 0000000..bf9505f Binary files /dev/null and b/pgplot_rhel7/pgsah.o differ diff --git a/pgplot_rhel7/pgsave.o b/pgplot_rhel7/pgsave.o new file mode 100644 index 0000000..8d06a64 Binary files /dev/null and b/pgplot_rhel7/pgsave.o differ diff --git a/pgplot_rhel7/pgscf.o b/pgplot_rhel7/pgscf.o new file mode 100644 index 0000000..a8ac1d0 Binary files /dev/null and b/pgplot_rhel7/pgscf.o differ diff --git a/pgplot_rhel7/pgsch.o b/pgplot_rhel7/pgsch.o new file mode 100644 index 0000000..9d233c6 Binary files /dev/null and b/pgplot_rhel7/pgsch.o differ diff --git a/pgplot_rhel7/pgsci.o b/pgplot_rhel7/pgsci.o new file mode 100644 index 0000000..da0ea80 Binary files /dev/null and b/pgplot_rhel7/pgsci.o differ diff --git a/pgplot_rhel7/pgscir.o b/pgplot_rhel7/pgscir.o new file mode 100644 index 0000000..abeedd6 Binary files /dev/null and b/pgplot_rhel7/pgscir.o differ diff --git a/pgplot_rhel7/pgsclp.o b/pgplot_rhel7/pgsclp.o new file mode 100644 index 0000000..0d9c922 Binary files /dev/null and b/pgplot_rhel7/pgsclp.o differ diff --git a/pgplot_rhel7/pgscr.o b/pgplot_rhel7/pgscr.o new file mode 100644 index 0000000..51cfa7a Binary files /dev/null and b/pgplot_rhel7/pgscr.o differ diff --git a/pgplot_rhel7/pgscrl.o b/pgplot_rhel7/pgscrl.o new file mode 100644 index 0000000..eb7d126 Binary files /dev/null and b/pgplot_rhel7/pgscrl.o differ diff --git a/pgplot_rhel7/pgscrn.o b/pgplot_rhel7/pgscrn.o new file mode 100644 index 0000000..6fea0dd Binary files /dev/null and b/pgplot_rhel7/pgscrn.o differ diff --git a/pgplot_rhel7/pgsfs.o b/pgplot_rhel7/pgsfs.o new file mode 100644 index 0000000..f1e6572 Binary files /dev/null and b/pgplot_rhel7/pgsfs.o differ diff --git a/pgplot_rhel7/pgshls.o b/pgplot_rhel7/pgshls.o new file mode 100644 index 0000000..4e6bdb5 Binary files /dev/null and b/pgplot_rhel7/pgshls.o differ diff --git a/pgplot_rhel7/pgshs.o b/pgplot_rhel7/pgshs.o new file mode 100644 index 0000000..4037b6e Binary files /dev/null and b/pgplot_rhel7/pgshs.o differ diff --git a/pgplot_rhel7/pgsitf.o b/pgplot_rhel7/pgsitf.o new file mode 100644 index 0000000..49f270d Binary files /dev/null and b/pgplot_rhel7/pgsitf.o differ diff --git a/pgplot_rhel7/pgslct.o b/pgplot_rhel7/pgslct.o new file mode 100644 index 0000000..2a76dcd Binary files /dev/null and b/pgplot_rhel7/pgslct.o differ diff --git a/pgplot_rhel7/pgsls.o b/pgplot_rhel7/pgsls.o new file mode 100644 index 0000000..d98d335 Binary files /dev/null and b/pgplot_rhel7/pgsls.o differ diff --git a/pgplot_rhel7/pgslw.o b/pgplot_rhel7/pgslw.o new file mode 100644 index 0000000..57ac154 Binary files /dev/null and b/pgplot_rhel7/pgslw.o differ diff --git a/pgplot_rhel7/pgstbg.o b/pgplot_rhel7/pgstbg.o new file mode 100644 index 0000000..a469cba Binary files /dev/null and b/pgplot_rhel7/pgstbg.o differ diff --git a/pgplot_rhel7/pgsubp.o b/pgplot_rhel7/pgsubp.o new file mode 100644 index 0000000..24d68a3 Binary files /dev/null and b/pgplot_rhel7/pgsubp.o differ diff --git a/pgplot_rhel7/pgsvp.o b/pgplot_rhel7/pgsvp.o new file mode 100644 index 0000000..8ee0f07 Binary files /dev/null and b/pgplot_rhel7/pgsvp.o differ diff --git a/pgplot_rhel7/pgswin.o b/pgplot_rhel7/pgswin.o new file mode 100644 index 0000000..c7fe1f2 Binary files /dev/null and b/pgplot_rhel7/pgswin.o differ diff --git a/pgplot_rhel7/pgtbox.o b/pgplot_rhel7/pgtbox.o new file mode 100644 index 0000000..52c833c Binary files /dev/null and b/pgplot_rhel7/pgtbox.o differ diff --git a/pgplot_rhel7/pgtext.o b/pgplot_rhel7/pgtext.o new file mode 100644 index 0000000..fd6e8a9 Binary files /dev/null and b/pgplot_rhel7/pgtext.o differ diff --git a/pgplot_rhel7/pgtick.o b/pgplot_rhel7/pgtick.o new file mode 100644 index 0000000..9793c91 Binary files /dev/null and b/pgplot_rhel7/pgtick.o differ diff --git a/pgplot_rhel7/pgtikl.o b/pgplot_rhel7/pgtikl.o new file mode 100644 index 0000000..379392f Binary files /dev/null and b/pgplot_rhel7/pgtikl.o differ diff --git a/pgplot_rhel7/pgupdt.o b/pgplot_rhel7/pgupdt.o new file mode 100644 index 0000000..d5c035e Binary files /dev/null and b/pgplot_rhel7/pgupdt.o differ diff --git a/pgplot_rhel7/pgvect.o b/pgplot_rhel7/pgvect.o new file mode 100644 index 0000000..2aea604 Binary files /dev/null and b/pgplot_rhel7/pgvect.o differ diff --git a/pgplot_rhel7/pgvport.o b/pgplot_rhel7/pgvport.o new file mode 100644 index 0000000..a4708e7 Binary files /dev/null and b/pgplot_rhel7/pgvport.o differ diff --git a/pgplot_rhel7/pgvsiz.o b/pgplot_rhel7/pgvsiz.o new file mode 100644 index 0000000..06bc04f Binary files /dev/null and b/pgplot_rhel7/pgvsiz.o differ diff --git a/pgplot_rhel7/pgvsize.o b/pgplot_rhel7/pgvsize.o new file mode 100644 index 0000000..db264c3 Binary files /dev/null and b/pgplot_rhel7/pgvsize.o differ diff --git a/pgplot_rhel7/pgvstand.o b/pgplot_rhel7/pgvstand.o new file mode 100644 index 0000000..0d85e62 Binary files /dev/null and b/pgplot_rhel7/pgvstand.o differ diff --git a/pgplot_rhel7/pgvstd.o b/pgplot_rhel7/pgvstd.o new file mode 100644 index 0000000..ab6d6b0 Binary files /dev/null and b/pgplot_rhel7/pgvstd.o differ diff --git a/pgplot_rhel7/pgvw.o b/pgplot_rhel7/pgvw.o new file mode 100644 index 0000000..92c04f9 Binary files /dev/null and b/pgplot_rhel7/pgvw.o differ diff --git a/pgplot_rhel7/pgwedg.o b/pgplot_rhel7/pgwedg.o new file mode 100644 index 0000000..0943d88 Binary files /dev/null and b/pgplot_rhel7/pgwedg.o differ diff --git a/pgplot_rhel7/pgwindow.o b/pgplot_rhel7/pgwindow.o new file mode 100644 index 0000000..ae5dfba Binary files /dev/null and b/pgplot_rhel7/pgwindow.o differ diff --git a/pgplot_rhel7/pgwnad.o b/pgplot_rhel7/pgwnad.o new file mode 100644 index 0000000..07e8c1d Binary files /dev/null and b/pgplot_rhel7/pgwnad.o differ diff --git a/pgplot_rhel7/pgxwin_server b/pgplot_rhel7/pgxwin_server new file mode 100755 index 0000000..892bc33 Binary files /dev/null and b/pgplot_rhel7/pgxwin_server differ diff --git a/pgplot_rhel7/psdriv.o b/pgplot_rhel7/psdriv.o new file mode 100644 index 0000000..8136e8b Binary files /dev/null and b/pgplot_rhel7/psdriv.o differ diff --git a/pgplot_rhel7/rgb.txt b/pgplot_rhel7/rgb.txt new file mode 100644 index 0000000..e5f6188 --- /dev/null +++ b/pgplot_rhel7/rgb.txt @@ -0,0 +1,738 @@ +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite +245 245 245 white smoke +245 245 245 WhiteSmoke +220 220 220 gainsboro +255 250 240 floral white +255 250 240 FloralWhite +253 245 230 old lace +253 245 230 OldLace +250 240 230 linen +250 235 215 antique white +250 235 215 AntiqueWhite +255 239 213 papaya whip +255 239 213 PapayaWhip +255 235 205 blanched almond +255 235 205 BlanchedAlmond +255 228 196 bisque +255 218 185 peach puff +255 218 185 PeachPuff +255 222 173 navajo white +255 222 173 NavajoWhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemon chiffon +255 250 205 LemonChiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mint cream +245 255 250 MintCream +240 255 255 azure +240 248 255 alice blue +240 248 255 AliceBlue +230 230 250 lavender +255 240 245 lavender blush +255 240 245 LavenderBlush +255 228 225 misty rose +255 228 225 MistyRose +255 255 255 white + 0 0 0 black + 47 79 79 dark slate gray + 47 79 79 DarkSlateGray + 47 79 79 dark slate grey + 47 79 79 DarkSlateGrey +105 105 105 dim gray +105 105 105 DimGray +105 105 105 dim grey +105 105 105 DimGrey +112 128 144 slate gray +112 128 144 SlateGray +112 128 144 slate grey +112 128 144 SlateGrey +119 136 153 light slate gray +119 136 153 LightSlateGray +119 136 153 light slate grey +119 136 153 LightSlateGrey +190 190 190 gray +190 190 190 grey +211 211 211 light grey +211 211 211 LightGrey +211 211 211 light gray +211 211 211 LightGray + 25 25 112 midnight blue + 25 25 112 MidnightBlue + 0 0 128 navy + 0 0 128 navy blue + 0 0 128 NavyBlue +100 149 237 cornflower blue +100 149 237 CornflowerBlue + 72 61 139 dark slate blue + 72 61 139 DarkSlateBlue +106 90 205 slate blue +106 90 205 SlateBlue +123 104 238 medium slate blue +123 104 238 MediumSlateBlue +132 112 255 light slate blue +132 112 255 LightSlateBlue + 0 0 205 medium blue + 0 0 205 MediumBlue + 65 105 225 royal blue + 65 105 225 RoyalBlue + 0 0 255 blue + 30 144 255 dodger blue + 30 144 255 DodgerBlue + 0 191 255 deep sky blue + 0 191 255 DeepSkyBlue +135 206 235 sky blue +135 206 235 SkyBlue +135 206 250 light sky blue +135 206 250 LightSkyBlue + 70 130 180 steel blue + 70 130 180 SteelBlue +176 196 222 light steel blue +176 196 222 LightSteelBlue +173 216 230 light blue +173 216 230 LightBlue +176 224 230 powder blue +176 224 230 PowderBlue +175 238 238 pale turquoise +175 238 238 PaleTurquoise + 0 206 209 dark turquoise + 0 206 209 DarkTurquoise + 72 209 204 medium turquoise + 72 209 204 MediumTurquoise + 64 224 208 turquoise + 0 255 255 cyan +224 255 255 light cyan +224 255 255 LightCyan + 95 158 160 cadet blue + 95 158 160 CadetBlue +102 205 170 medium aquamarine +102 205 170 MediumAquamarine +127 255 212 aquamarine + 0 100 0 dark green + 0 100 0 DarkGreen + 85 107 47 dark olive green + 85 107 47 DarkOliveGreen +143 188 143 dark sea green +143 188 143 DarkSeaGreen + 46 139 87 sea green + 46 139 87 SeaGreen + 60 179 113 medium sea green + 60 179 113 MediumSeaGreen + 32 178 170 light sea green + 32 178 170 LightSeaGreen +152 251 152 pale green +152 251 152 PaleGreen + 0 255 127 spring green + 0 255 127 SpringGreen +124 252 0 lawn green +124 252 0 LawnGreen + 0 255 0 green +127 255 0 chartreuse + 0 250 154 medium spring green + 0 250 154 MediumSpringGreen +173 255 47 green yellow +173 255 47 GreenYellow + 50 205 50 lime green + 50 205 50 LimeGreen +154 205 50 yellow green +154 205 50 YellowGreen + 34 139 34 forest green + 34 139 34 ForestGreen +107 142 35 olive drab +107 142 35 OliveDrab +189 183 107 dark khaki +189 183 107 DarkKhaki +240 230 140 khaki +238 232 170 pale goldenrod +238 232 170 PaleGoldenrod +250 250 210 light goldenrod yellow +250 250 210 LightGoldenrodYellow +255 255 224 light yellow +255 255 224 LightYellow +255 255 0 yellow +255 215 0 gold +238 221 130 light goldenrod +238 221 130 LightGoldenrod +218 165 32 goldenrod +184 134 11 dark goldenrod +184 134 11 DarkGoldenrod +188 143 143 rosy brown +188 143 143 RosyBrown +205 92 92 indian red +205 92 92 IndianRed +139 69 19 saddle brown +139 69 19 SaddleBrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandy brown +244 164 96 SandyBrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 dark salmon +233 150 122 DarkSalmon +250 128 114 salmon +255 160 122 light salmon +255 160 122 LightSalmon +255 165 0 orange +255 140 0 dark orange +255 140 0 DarkOrange +255 127 80 coral +240 128 128 light coral +240 128 128 LightCoral +255 99 71 tomato +255 69 0 orange red +255 69 0 OrangeRed +255 0 0 red +255 105 180 hot pink +255 105 180 HotPink +255 20 147 deep pink +255 20 147 DeepPink +255 192 203 pink +255 182 193 light pink +255 182 193 LightPink +219 112 147 pale violet red +219 112 147 PaleVioletRed +176 48 96 maroon +199 21 133 medium violet red +199 21 133 MediumVioletRed +208 32 144 violet red +208 32 144 VioletRed +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 medium orchid +186 85 211 MediumOrchid +153 50 204 dark orchid +153 50 204 DarkOrchid +148 0 211 dark violet +148 0 211 DarkViolet +138 43 226 blue violet +138 43 226 BlueViolet +160 32 240 purple +147 112 219 medium purple +147 112 219 MediumPurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 AntiqueWhite1 +238 223 204 AntiqueWhite2 +205 192 176 AntiqueWhite3 +139 131 120 AntiqueWhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 PeachPuff1 +238 203 173 PeachPuff2 +205 175 149 PeachPuff3 +139 119 101 PeachPuff4 +255 222 173 NavajoWhite1 +238 207 161 NavajoWhite2 +205 179 139 NavajoWhite3 +139 121 94 NavajoWhite4 +255 250 205 LemonChiffon1 +238 233 191 LemonChiffon2 +205 201 165 LemonChiffon3 +139 137 112 LemonChiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 LavenderBlush1 +238 224 229 LavenderBlush2 +205 193 197 LavenderBlush3 +139 131 134 LavenderBlush4 +255 228 225 MistyRose1 +238 213 210 MistyRose2 +205 183 181 MistyRose3 +139 125 123 MistyRose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 SlateBlue1 +122 103 238 SlateBlue2 +105 89 205 SlateBlue3 + 71 60 139 SlateBlue4 + 72 118 255 RoyalBlue1 + 67 110 238 RoyalBlue2 + 58 95 205 RoyalBlue3 + 39 64 139 RoyalBlue4 + 0 0 255 blue1 + 0 0 238 blue2 + 0 0 205 blue3 + 0 0 139 blue4 + 30 144 255 DodgerBlue1 + 28 134 238 DodgerBlue2 + 24 116 205 DodgerBlue3 + 16 78 139 DodgerBlue4 + 99 184 255 SteelBlue1 + 92 172 238 SteelBlue2 + 79 148 205 SteelBlue3 + 54 100 139 SteelBlue4 + 0 191 255 DeepSkyBlue1 + 0 178 238 DeepSkyBlue2 + 0 154 205 DeepSkyBlue3 + 0 104 139 DeepSkyBlue4 +135 206 255 SkyBlue1 +126 192 238 SkyBlue2 +108 166 205 SkyBlue3 + 74 112 139 SkyBlue4 +176 226 255 LightSkyBlue1 +164 211 238 LightSkyBlue2 +141 182 205 LightSkyBlue3 + 96 123 139 LightSkyBlue4 +198 226 255 SlateGray1 +185 211 238 SlateGray2 +159 182 205 SlateGray3 +108 123 139 SlateGray4 +202 225 255 LightSteelBlue1 +188 210 238 LightSteelBlue2 +162 181 205 LightSteelBlue3 +110 123 139 LightSteelBlue4 +191 239 255 LightBlue1 +178 223 238 LightBlue2 +154 192 205 LightBlue3 +104 131 139 LightBlue4 +224 255 255 LightCyan1 +209 238 238 LightCyan2 +180 205 205 LightCyan3 +122 139 139 LightCyan4 +187 255 255 PaleTurquoise1 +174 238 238 PaleTurquoise2 +150 205 205 PaleTurquoise3 +102 139 139 PaleTurquoise4 +152 245 255 CadetBlue1 +142 229 238 CadetBlue2 +122 197 205 CadetBlue3 + 83 134 139 CadetBlue4 + 0 245 255 turquoise1 + 0 229 238 turquoise2 + 0 197 205 turquoise3 + 0 134 139 turquoise4 + 0 255 255 cyan1 + 0 238 238 cyan2 + 0 205 205 cyan3 + 0 139 139 cyan4 +151 255 255 DarkSlateGray1 +141 238 238 DarkSlateGray2 +121 205 205 DarkSlateGray3 + 82 139 139 DarkSlateGray4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 + 69 139 116 aquamarine4 +193 255 193 DarkSeaGreen1 +180 238 180 DarkSeaGreen2 +155 205 155 DarkSeaGreen3 +105 139 105 DarkSeaGreen4 + 84 255 159 SeaGreen1 + 78 238 148 SeaGreen2 + 67 205 128 SeaGreen3 + 46 139 87 SeaGreen4 +154 255 154 PaleGreen1 +144 238 144 PaleGreen2 +124 205 124 PaleGreen3 + 84 139 84 PaleGreen4 + 0 255 127 SpringGreen1 + 0 238 118 SpringGreen2 + 0 205 102 SpringGreen3 + 0 139 69 SpringGreen4 + 0 255 0 green1 + 0 238 0 green2 + 0 205 0 green3 + 0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 + 69 139 0 chartreuse4 +192 255 62 OliveDrab1 +179 238 58 OliveDrab2 +154 205 50 OliveDrab3 +105 139 34 OliveDrab4 +202 255 112 DarkOliveGreen1 +188 238 104 DarkOliveGreen2 +162 205 90 DarkOliveGreen3 +110 139 61 DarkOliveGreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 LightGoldenrod1 +238 220 130 LightGoldenrod2 +205 190 112 LightGoldenrod3 +139 129 76 LightGoldenrod4 +255 255 224 LightYellow1 +238 238 209 LightYellow2 +205 205 180 LightYellow3 +139 139 122 LightYellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 DarkGoldenrod1 +238 173 14 DarkGoldenrod2 +205 149 12 DarkGoldenrod3 +139 101 8 DarkGoldenrod4 +255 193 193 RosyBrown1 +238 180 180 RosyBrown2 +205 155 155 RosyBrown3 +139 105 105 RosyBrown4 +255 106 106 IndianRed1 +238 99 99 IndianRed2 +205 85 85 IndianRed3 +139 58 58 IndianRed4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 LightSalmon1 +238 149 114 LightSalmon2 +205 129 98 LightSalmon3 +139 87 66 LightSalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 DarkOrange1 +238 118 0 DarkOrange2 +205 102 0 DarkOrange3 +139 69 0 DarkOrange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 OrangeRed1 +238 64 0 OrangeRed2 +205 55 0 OrangeRed3 +139 37 0 OrangeRed4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 DeepPink1 +238 18 137 DeepPink2 +205 16 118 DeepPink3 +139 10 80 DeepPink4 +255 110 180 HotPink1 +238 106 167 HotPink2 +205 96 144 HotPink3 +139 58 98 HotPink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 LightPink1 +238 162 173 LightPink2 +205 140 149 LightPink3 +139 95 101 LightPink4 +255 130 171 PaleVioletRed1 +238 121 159 PaleVioletRed2 +205 104 137 PaleVioletRed3 +139 71 93 PaleVioletRed4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 VioletRed1 +238 58 140 VioletRed2 +205 50 120 VioletRed3 +139 34 82 VioletRed4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 MediumOrchid1 +209 95 238 MediumOrchid2 +180 82 205 MediumOrchid3 +122 55 139 MediumOrchid4 +191 62 255 DarkOrchid1 +178 58 238 DarkOrchid2 +154 50 205 DarkOrchid3 +104 34 139 DarkOrchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 + 85 26 139 purple4 +171 130 255 MediumPurple1 +159 121 238 MediumPurple2 +137 104 205 MediumPurple3 + 93 71 139 MediumPurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 + 0 0 0 gray0 + 0 0 0 grey0 + 3 3 3 gray1 + 3 3 3 grey1 + 5 5 5 gray2 + 5 5 5 grey2 + 8 8 8 gray3 + 8 8 8 grey3 + 10 10 10 gray4 + 10 10 10 grey4 + 13 13 13 gray5 + 13 13 13 grey5 + 15 15 15 gray6 + 15 15 15 grey6 + 18 18 18 gray7 + 18 18 18 grey7 + 20 20 20 gray8 + 20 20 20 grey8 + 23 23 23 gray9 + 23 23 23 grey9 + 26 26 26 gray10 + 26 26 26 grey10 + 28 28 28 gray11 + 28 28 28 grey11 + 31 31 31 gray12 + 31 31 31 grey12 + 33 33 33 gray13 + 33 33 33 grey13 + 36 36 36 gray14 + 36 36 36 grey14 + 38 38 38 gray15 + 38 38 38 grey15 + 41 41 41 gray16 + 41 41 41 grey16 + 43 43 43 gray17 + 43 43 43 grey17 + 46 46 46 gray18 + 46 46 46 grey18 + 48 48 48 gray19 + 48 48 48 grey19 + 51 51 51 gray20 + 51 51 51 grey20 + 54 54 54 gray21 + 54 54 54 grey21 + 56 56 56 gray22 + 56 56 56 grey22 + 59 59 59 gray23 + 59 59 59 grey23 + 61 61 61 gray24 + 61 61 61 grey24 + 64 64 64 gray25 + 64 64 64 grey25 + 66 66 66 gray26 + 66 66 66 grey26 + 69 69 69 gray27 + 69 69 69 grey27 + 71 71 71 gray28 + 71 71 71 grey28 + 74 74 74 gray29 + 74 74 74 grey29 + 77 77 77 gray30 + 77 77 77 grey30 + 79 79 79 gray31 + 79 79 79 grey31 + 82 82 82 gray32 + 82 82 82 grey32 + 84 84 84 gray33 + 84 84 84 grey33 + 87 87 87 gray34 + 87 87 87 grey34 + 89 89 89 gray35 + 89 89 89 grey35 + 92 92 92 gray36 + 92 92 92 grey36 + 94 94 94 gray37 + 94 94 94 grey37 + 97 97 97 gray38 + 97 97 97 grey38 + 99 99 99 gray39 + 99 99 99 grey39 +102 102 102 gray40 +102 102 102 grey40 +105 105 105 gray41 +105 105 105 grey41 +107 107 107 gray42 +107 107 107 grey42 +110 110 110 gray43 +110 110 110 grey43 +112 112 112 gray44 +112 112 112 grey44 +115 115 115 gray45 +115 115 115 grey45 +117 117 117 gray46 +117 117 117 grey46 +120 120 120 gray47 +120 120 120 grey47 +122 122 122 gray48 +122 122 122 grey48 +125 125 125 gray49 +125 125 125 grey49 +127 127 127 gray50 +127 127 127 grey50 +130 130 130 gray51 +130 130 130 grey51 +133 133 133 gray52 +133 133 133 grey52 +135 135 135 gray53 +135 135 135 grey53 +138 138 138 gray54 +138 138 138 grey54 +140 140 140 gray55 +140 140 140 grey55 +143 143 143 gray56 +143 143 143 grey56 +145 145 145 gray57 +145 145 145 grey57 +148 148 148 gray58 +148 148 148 grey58 +150 150 150 gray59 +150 150 150 grey59 +153 153 153 gray60 +153 153 153 grey60 +156 156 156 gray61 +156 156 156 grey61 +158 158 158 gray62 +158 158 158 grey62 +161 161 161 gray63 +161 161 161 grey63 +163 163 163 gray64 +163 163 163 grey64 +166 166 166 gray65 +166 166 166 grey65 +168 168 168 gray66 +168 168 168 grey66 +171 171 171 gray67 +171 171 171 grey67 +173 173 173 gray68 +173 173 173 grey68 +176 176 176 gray69 +176 176 176 grey69 +179 179 179 gray70 +179 179 179 grey70 +181 181 181 gray71 +181 181 181 grey71 +184 184 184 gray72 +184 184 184 grey72 +186 186 186 gray73 +186 186 186 grey73 +189 189 189 gray74 +189 189 189 grey74 +191 191 191 gray75 +191 191 191 grey75 +194 194 194 gray76 +194 194 194 grey76 +196 196 196 gray77 +196 196 196 grey77 +199 199 199 gray78 +199 199 199 grey78 +201 201 201 gray79 +201 201 201 grey79 +204 204 204 gray80 +204 204 204 grey80 +207 207 207 gray81 +207 207 207 grey81 +209 209 209 gray82 +209 209 209 grey82 +212 212 212 gray83 +212 212 212 grey83 +214 214 214 gray84 +214 214 214 grey84 +217 217 217 gray85 +217 217 217 grey85 +219 219 219 gray86 +219 219 219 grey86 +222 222 222 gray87 +222 222 222 grey87 +224 224 224 gray88 +224 224 224 grey88 +227 227 227 gray89 +227 227 227 grey89 +229 229 229 gray90 +229 229 229 grey90 +232 232 232 gray91 +232 232 232 grey91 +235 235 235 gray92 +235 235 235 grey92 +237 237 237 gray93 +237 237 237 grey93 +240 240 240 gray94 +240 240 240 grey94 +242 242 242 gray95 +242 242 242 grey95 +245 245 245 gray96 +245 245 245 grey96 +247 247 247 gray97 +247 247 247 grey97 +250 250 250 gray98 +250 250 250 grey98 +252 252 252 gray99 +252 252 252 grey99 +255 255 255 gray100 +255 255 255 grey100 diff --git a/pgplot_rhel7/ttdriv.o b/pgplot_rhel7/ttdriv.o new file mode 100644 index 0000000..b242495 Binary files /dev/null and b/pgplot_rhel7/ttdriv.o differ diff --git a/pgplot_rhel7/xwdriv.o b/pgplot_rhel7/xwdriv.o new file mode 100644 index 0000000..80780bb Binary files /dev/null and b/pgplot_rhel7/xwdriv.o differ diff --git a/pgplot_sl6/A_README.TXT b/pgplot_sl6/A_README.TXT new file mode 100644 index 0000000..453f08e --- /dev/null +++ b/pgplot_sl6/A_README.TXT @@ -0,0 +1,2 @@ +the pgplot library was compiled with +/afs/psi.ch/project/sinq/common/src/pgplot5.2.2/makemake /afs/psi.ch/project/sinq/common/src/pgplot5.2.2 linux gfortran-gcc diff --git a/pgplot_sl6/drivers.list b/pgplot_sl6/drivers.list new file mode 100644 index 0000000..28c20c4 --- /dev/null +++ b/pgplot_sl6/drivers.list @@ -0,0 +1,114 @@ +! PGPLOT drivers. +!------------------------------------------------------------------------------ +! To configure PGPLOT, ensure that drivers you do not want are +! commented out (place ! in column 1). N.B. Many device-drivers are +! available on selected operating systems only. +!------------------------------------------------------------------------------ +! File Code Description Restrictions +! BCDRIV 0 /BCANON Canon Laser printer (bitmap version), landscape +! CADRIV 0 /CANON Canon Laser printer, LBP-8/A2, landscape +! CCDRIV 0 /CCP DEC LJ250 Color Companion printer +! CGDRIV 1 /CGM CGM metafile, indexed colour selection C +! CGDRIV 2 /CGMD CGM metafile, direct colour selection C +! CWDRIV 0 /CW6320 Gould/Bryans Colourwriter 6320 pen plotter Std F77 +! EPDRIV 0 /EPSON Epson FX100 dot matrix printer +! EXDRIV 1 /EXCL Talaris/EXCL printers, landscape +! EXDRIV 2 /EXCL Talaris/EXCL printers, portrait +! GCDRIV 0 /GENICOM Genicom 4410 dot-matrix printer, landscape +! Caution: use of GIDRIV may require a license from Unisys: + GIDRIV 1 /GIF GIF-format file, landscape + GIDRIV 2 /VGIF GIF-format file, portrait +! GLDRIV 1 /HPGL Hewlett-Packard HP-GL plotters, landscape Std F77 +! GLDRIV 2 /VHPGL Hewlett-Packard HP-GL plotters, portrait Std F77 +! GODRIV 0 /GOC GOC Sigma T5670 terminal VMS +! GVDRIV 0 /GVENICOM Genicom 4410 dot-matrix printer, portrait +! HGDRIV 0 /HPGL2 Hewlett-Packard graphics language +! HIDRIV 0 /HIDMP Houston Instruments HIDMP pen plotter +! HJDRIV 0 /HJ Hewlett-Packard Desk/Laserjet printer +! HPDRIV 0 /HP7221 Hewlett-Packard HP7221 pen plotter Std F77 +! LADRIV 0 /LA50 Dec LA50 and other sixel printers +! LJDRIV 0 /LJ Hewlett-Packard LaserJet printers VMS +! LSDRIV 1 /LIPS2 Canon LaserShot printer (landscape) +! LSDRIV 2 /VLIPS2 Canon LaserShot printer (portrait) +! LNDRIV 0 /LN03 Dec LN03-PLUS Laser printer (landscape) VMS +! LVDRIV 0 /LVN03 Dec LN03-PLUS Laser printer (portrait) VMS +! LXDRIV 0 /LATEX LaTeX picture environment +! MFDRIV 0 /FILE PGPLOT graphics metafile +! NEDRIV 0 /NEXT Computers running NeXTstep operating system + NUDRIV 0 /NULL Null device (no output) Std F77 +! PGDRIV 0 /PGMF PGPLOT metafile (new format, experimental) Std F77 +! PNDRIV 1 /PNG Portable Network Graphics file C +! PNDRIV 2 /TPNG Portable Network Graphics file - transparent background C +! PPDRIV 1 /PPM Portable Pixel Map file, landscape +! PPDRIV 2 /VPPM Portable PIxel Map file, portrait + PSDRIV 1 /PS PostScript printers, monochrome, landscape Std F77 + PSDRIV 2 /VPS Postscript printers, monochrome, portrait Std F77 + PSDRIV 3 /CPS PostScript printers, color, landscape Std F77 + PSDRIV 4 /VCPS PostScript printers, color, portrait Std F77 +! PXDRIV 0 /PRINTRONI Printronix P300 or P600 dot-matrix printer +! QMDRIV 1 /QMS QUIC devices (QMS and Talaris), landscape Std F77 +! QMDRIV 2 /VQMS QUIC devices (QMS and Talaris), portrait Std F77 +! TFDRIV 0 /TFILE Tektronix-format disk file VMS +! TODRIV 0 /TOSHIBA Toshiba "3-in-one" printer, model P351 +! TTDRIV 1 /TEK4010 Tektronix 4006/4010 storage-tube terminal Std F77 +! TTDRIV 2 /GF GraphOn terminal Std F77 +! TTDRIV 3 /RETRO RetroGraphics terminal Std F77 +! TTDRIV 4 /GTERM GTERM Tektronix terminal emulator Std F77 + TTDRIV 5 /XTERM XTERM Tektronix terminal emulator Std F77 +! TTDRIV 6 /ZSTEM ZSTEM terminal emulator Std F77 +! TTDRIV 7 /V603 Visual 603 terminal Std F77 +! TTDRIV 8 /KRM3 Kermit 3 on IBM-PC Std F77 +! TTDRIV 9 /TK4100 Tektronix 4100-series terminals Std F77 +! TTDRIV 10 /VMAC Macintosh VersaTerm-PRO Tektronix-4105 emulator Std F77 +! TXDRIV 0 /TX TeX PK Font Output files +! VADRIV 0 /VCANON Canon Laser printer, LBP-8/A2, portrait +! VBDRIV 0 /VBCANON Canon Laser printer (bitmap version), portrait +! VTDRIV 0 /VT125 Dec Regis terminals (VT125 etc.) Std F77 +! WDDRIV 1 /WD X Window dump file, landscape +! WDDRIV 2 /VWD X Window dump file, portrait +! WSDRIV 0 /WS VAX workstations running VWS software VMS +! X2DRIV 0 /XDISP PGDISP or FIGDISP server for X workstations C + XWDRIV 1 /XWINDOW Workstations running X Window System C + XWDRIV 2 /XSERVE Persistent window on X Window System C +! ZEDRIV 0 /ZETA Zeta 8 Digital Plotter +! +! The following drivers can only be used in PGPLOT installations on MS-DOS +! systems with appropriate hardware and software. Do not select these +! on UNIX or VMS systems. +! +! LHDRIV 0 /LH IBM PCs and clones, Lahey F77 32-bit Fortran v5.0 +! MSDRIV 0 /MSOFT IBM PCs and clones running Microsoft Fortran 5.0 +! SSDRIV 0 /SS IBM PCs and clones, MS-DOS, Salford Software FTN +! +! The following driver can only be used in PGPLOT installations on Acorn +! Archimedes systems with appropriate hardware and software. +! +! ACDRIV 0 /ARC Acorn Archimedes computer +! +! Selection of the XMOTIF driver causes a stub driver to be placed in +! the main PGPLOT library. The real driver is placed in libXmPgplot.a. +! Applications that need the Motif driver should link with libXmPgplot.a +! before the PGPLOT library. This treatment means that only Motif +! applications have to be linked with Motif libraries. +! +! XMDRIV 0 /XMOTIF Motif applications containing XmPgplot widgets. C +! +! Selection of the XATHENA driver causes a stub driver to be placed in +! the main PGPLOT library. The real driver is placed in libXawPgplot.a. +! Applications that need the Athena driver should link with libXawPgplot.a +! before the PGPLOT library. This treatment means that only Athena +! applications have to be linked with Xaw libraries. +! +! XADRIV 0 /XATHENA Motif applications containing XaPgplot widgets. C +! +! Selection of the TK driver causes a stub driver to be placed in +! the main PGPLOT library. The real driver is placed in libtkpgplot.a. +! Applications that need the Tk driver should link with libtkpgplot.a +! before the PGPLOT library. This treatment means that only Tcl/Tk +! applications have to be linked with the Tcl and Tk libraries. +! +! TKDRIV 0 /XTK X-window Tcl/Tk programs with pgplot widgets. C +! +! The following driver is included solely for use by the aips++ team. +! +! RVDRIV 0 /XRV X-window Rivet/Tk programs with pgplot widgets. C diff --git a/pgplot_sl6/grexec.f b/pgplot_sl6/grexec.f new file mode 100644 index 0000000..9dc8fb1 --- /dev/null +++ b/pgplot_sl6/grexec.f @@ -0,0 +1,43 @@ +C*GREXEC -- PGPLOT device handler dispatch routine +C+ + SUBROUTINE GREXEC(IDEV,IFUNC,RBUF,NBUF,CHR,LCHR) + INTEGER IDEV, IFUNC, NBUF, LCHR + REAL RBUF(*) + CHARACTER*(*) CHR +C--- + INTEGER NDEV + PARAMETER (NDEV=10) + CHARACTER*10 MSG +C--- + GOTO(1,2,3,4,5,6,7,8,9,10) IDEV + IF (IDEV.EQ.0) THEN + RBUF(1) = NDEV + NBUF = 1 + ELSE + WRITE (MSG,'(I10)') IDEV + CALL GRWARN('Unknown device code in GREXEC: '//MSG) + END IF + RETURN +C--- +1 CALL GIDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1) + RETURN +2 CALL GIDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2) + RETURN +3 CALL NUDRIV(IFUNC,RBUF,NBUF,CHR,LCHR) + RETURN +4 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1) + RETURN +5 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2) + RETURN +6 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,3) + RETURN +7 CALL PSDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,4) + RETURN +8 CALL TTDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,5) + RETURN +9 CALL XWDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,1) + RETURN +10 CALL XWDRIV(IFUNC,RBUF,NBUF,CHR,LCHR,2) + RETURN +C + END diff --git a/pgplot_sl6/grfont.dat b/pgplot_sl6/grfont.dat new file mode 100644 index 0000000..acde914 Binary files /dev/null and b/pgplot_sl6/grfont.dat differ diff --git a/pgplot_sl6/grpckg1.inc b/pgplot_sl6/grpckg1.inc new file mode 100644 index 0000000..b6a2118 --- /dev/null +++ b/pgplot_sl6/grpckg1.inc @@ -0,0 +1,98 @@ +C----------------------------------------------------------------------- +C Include file for GRPCKG +C Modifications: +C 29-Jan-1985 - add HP2648 (KS/TJP). +C 16-Sep-1985 - remove tabs (TJP). +C 30-Dec-1985 - add PS, VPS (TJP). +C 27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP, +C HP7221, GRINL (TJP). +C 6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP). +C 11-Jun-1987 - remove remaining built-in devices (TJP). +C 5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT. +C 16-Aug-1987 - remove obsolete variables. +C 9-Sep-1989 - add SAVE statement. +C 26-Nov-1990 - remove GRCTYP. +C 5-Jan-1993 - add GRADJU. +C 1-Sep-1994 - add GRGCAP. +C 21-Dec-1995 - increase GRIMAX to 8. +C 30-Apr-1997 - remove GRC{XY}SP +C----------------------------------------------------------------------- +C +C Parameters: +C GRIMAX : maximum number of concurrent devices +C GRFNMX : maximum length of file names +C GRCXSZ : default width of chars (pixels) +C GRCYSZ : default height of chars (pixels) +C + INTEGER GRIMAX, GRFNMX + REAL GRCXSZ, GRCYSZ + PARAMETER (GRIMAX = 8) + PARAMETER (GRFNMX = 90) + PARAMETER (GRCXSZ = 7.0, GRCYSZ = 9.0) +C +C Common blocks: +C GRCIDE : identifier of current plot +C GRGTYP : device type of current plot +C The following are qualified by a plot id: +C GRSTAT : 0 => workstation closed +C 1 => workstation open +C 2 => picture open +C GRPLTD : +C GRDASH : software dashing in effect? +C GRUNIT : unit associated with id +C GRFNLN : length of filename +C GRTYPE : device type +C GRXMXA : x size of plotting surface +C GRYMXA : y size of plotting surface +C GRXMIN : blc of plotting window +C GRYMIN : ditto +C GRXMAX : trc of plotting window +C GRYMAX : ditto +C GRSTYL : line style (integer code) +C GRWIDT : line width (integer code) +C GRCCOL : current color index (integer code) +C GRMNCI : minimum color index on this device +C GRMXCI : maximum color index on this device +C GRCMRK : marker number +C GRXPRE : previous (current) pen position (x) +C GRYPRE : ditto (y) +C GRXORG : transformation variables (GRTRAN) +C GRYORG : ditto +C GRXSCL : ditto +C GRYSCL : ditto +C GRCSCL : character scaling factor +C GRCFAC : +C GRCFNT : character font +C GRFILE : file name (character) +C GRGCAP : device capabilities (character) +C GRPXPI : pixels per inch in x +C GRPYPI : pixels per inch in y +C GRADJU : TRUE if GRSETS (PGPAP) has been called +C + INTEGER GRCIDE, GRGTYP + LOGICAL GRPLTD(GRIMAX), GRDASH(GRIMAX), GRADJU(GRIMAX) + INTEGER GRSTAT(GRIMAX) + INTEGER GRUNIT(GRIMAX), GRFNLN(GRIMAX), GRTYPE(GRIMAX), + 1 GRXMXA(GRIMAX), GRYMXA(GRIMAX), + 2 GRSTYL(GRIMAX), GRWIDT(GRIMAX), GRCCOL(GRIMAX), + 3 GRCMRK(GRIMAX), GRIPAT(GRIMAX), GRCFNT(GRIMAX), + 4 GRMNCI(GRIMAX), GRMXCI(GRIMAX) + REAL GRXMIN(GRIMAX), GRYMIN(GRIMAX), + 1 GRXMAX(GRIMAX), GRYMAX(GRIMAX) + REAL GRXPRE(GRIMAX), GRYPRE(GRIMAX), GRXORG(GRIMAX), + 1 GRYORG(GRIMAX), GRXSCL(GRIMAX), GRYSCL(GRIMAX), + 2 GRCSCL(GRIMAX), GRCFAC(GRIMAX), GRPOFF(GRIMAX), + 3 GRPATN(GRIMAX,8),GRPXPI(GRIMAX),GRPYPI(GRIMAX) + COMMON /GRCM00/ GRCIDE, GRGTYP, GRSTAT, GRPLTD, GRUNIT, + 1 GRFNLN, GRTYPE, GRXMXA, GRYMXA, GRXMIN, GRYMIN, + 2 GRXMAX, GRYMAX, GRWIDT, GRCCOL, GRSTYL, + 3 GRXPRE, GRYPRE, GRXORG, GRYORG, GRXSCL, GRYSCL, + 4 GRCSCL, GRCFAC, GRDASH, GRPATN, GRPOFF, + 5 GRIPAT, GRCFNT, GRCMRK, GRPXPI, GRPYPI, GRADJU, + 6 GRMNCI, GRMXCI +C + CHARACTER*(GRFNMX) GRFILE(GRIMAX) + CHARACTER*11 GRGCAP(GRIMAX) + COMMON /GRCM01/ GRFILE, GRGCAP + SAVE /GRCM00/, /GRCM01/ +C----------------------------------------------------------------------- diff --git a/pgplot_sl6/libpgplot.a b/pgplot_sl6/libpgplot.a new file mode 100644 index 0000000..76a2c40 Binary files /dev/null and b/pgplot_sl6/libpgplot.a differ diff --git a/pgplot_sl6/makefile b/pgplot_sl6/makefile new file mode 100644 index 0000000..4d5edf7 --- /dev/null +++ b/pgplot_sl6/makefile @@ -0,0 +1,932 @@ +# Makefile for PGPLOT. +# /afs/psi.ch/project/sinq/common/src/pgplot/makemake /afs/psi.ch/project/sinq/common/src/pgplot linux gfortran_gcc +# This file is automatically generated. Do not edit. +# +# This generates the PGPLOT binary files (libraries and demos) in the +# current default directory (which need not be the source directory). +#----------------------------------------------------------------------- +SHELL=/bin/sh +# PGPLOT subdirectories +SRC=/afs/psi.ch/project/sinq/common/src/pgplot +SRCDIR=/afs/psi.ch/project/sinq/common/src/pgplot/src +OBSDIR=/afs/psi.ch/project/sinq/common/src/pgplot/obssrc +DEMDIR=/afs/psi.ch/project/sinq/common/src/pgplot/examples +FNTDIR=/afs/psi.ch/project/sinq/common/src/pgplot/fonts +DRVDIR=/afs/psi.ch/project/sinq/common/src/pgplot/drivers +SYSDIR=/afs/psi.ch/project/sinq/common/src/pgplot/sys_linux +PGDDIR=/afs/psi.ch/project/sinq/common/src/pgplot/pgdispd +GENDIR=/afs/psi.ch/project/sinq/common/src/pgplot/sys +XMDIR=/afs/psi.ch/project/sinq/common/src/pgplot/drivers/xmotif +XADIR=/afs/psi.ch/project/sinq/common/src/pgplot/drivers/xathena +TKDIR=/afs/psi.ch/project/sinq/common/src/pgplot/drivers/xtk +# +# Fortran compiler and compilation flags +# +FCOMPL=gfortran +FFLAGC=-g -ffixed-form -ffixed-line-length-none -u -Wall -fPIC -O +FFLAGD=-fno-backslash +# +# C compiler and compilation flags +# +XINCL=-I/usr/X11R6/include +MOTIF_INCL=-I/usr/X11R6/include +ATHENA_INCL=-I/usr/X11R6/include +TK_INCL=-I/usr/include -I/usr/X11R6/include +RV_INCL= +CCOMPL=gcc +CFLAGC=-Wall -fPIC -DPG_PPU -O -I. +CFLAGD=-Wall -O +MCOMPL= +MFLAGC= +# +# Pgbind flags. +# +PGBIND_FLAGS=bsd +# +# Loader library-flags +# +LIBS=-L/usr/X11R6/lib -lX11 +MOTIF_LIBS=-lXm -lXt -L/usr/X11R6/lib -lX11 +ATHENA_LIBS=-lXaw -lXt -lXmu -lXext -L/usr/X11R6/lib -lX11 +TK_LIBS=-L/usr/lib -ltk -ltcl -L/usr/X11R6/lib -lX11 -ldl +# +# Loader command for PGPLOT library +# +PGPLOT_LIB=-L`pwd` -lpgplot +CPGPLOT_LIB=-L`pwd` -lcpgplot -lpgplot +# +# Shared library creation. +# +SHARED_LIB=libpgplot.so +SHARED_LD=gcc -shared -o libpgplot.so +# +# The libraries that the shared PGPLOT library depends upon. +# This is for systems that allow one to specify what libraries +# undefined symbols of a shared library reside in. Such systems +# (eg. Solaris 2.x) use this information at run time so that users of +# the library don't have to list a slew of other implementation-specific +# libraries when they link their executables. +# +SHARED_LIB_LIBS= +# +# Ranlib command if required +# +RANLIB=ranlib +# +# Routine lists. +# +PG_ROUTINES= pgarro.o pgask.o pgaxis.o pgaxlg.o pgband.o pgbbuf.o pgbeg.o pgbin.o pgbox.o pgbox1.o pgcirc.o pgcl.o pgclos.o pgcn01.o pgcnsc.o pgconb.o pgconf.o pgconl.o pgcons.o pgcont.o pgconx.o pgcp.o pgctab.o pgcurs.o pgdraw.o pgebuf.o pgend.o pgenv.o pgeras.o pgerr1.o pgerrb.o pgerrx.o pgerry.o pgetxt.o pgfunt.o pgfunx.o pgfuny.o pggray.o pghi2d.o pghis1.o pghist.o pghtch.o pgiden.o pgimag.o pginit.o pglab.o pglcur.o pgldev.o pglen.o pgline.o pgmove.o pgmtxt.o pgncur.o pgnoto.o pgnpl.o pgnumb.o pgolin.o pgopen.o pgpage.o pgpanl.o pgpap.o pgpixl.o pgpnts.o pgpoly.o pgpt.o pgpt1.o pgptxt.o pgqah.o pgqcf.o pgqch.o pgqci.o pgqcir.o pgqclp.o pgqcol.o pgqcr.o pgqcs.o pgqdt.o pgqfs.o pgqhs.o pgqid.o pgqinf.o pgqitf.o pgqls.o pgqlw.o pgqndt.o pgqpos.o pgqtbg.o pgqtxt.o pgqvp.o pgqvsz.o pgqwin.o pgrect.o pgrnd.o pgrnge.o pgsah.o pgsave.o pgscf.o pgsch.o pgsci.o pgscir.o pgsclp.o pgscr.o pgscrl.o pgscrn.o pgsfs.o pgshls.o pgshs.o pgsitf.o pgslct.o pgsls.o pgslw.o pgstbg.o pgsubp.o pgsvp.o pgswin.o pgtbox.o pgtext.o pgtick.o pgtikl.o pgupdt.o pgvect.o pgvsiz.o pgvstd.o pgvw.o pgwedg.o pgwnad.o +PG_NON_STANDARD= pgadvance.o pgbegin.o pgcurse.o pglabel.o pgmtext.o pgncurse.o pgpaper.o pgpoint.o pgptext.o pgvport.o pgvsize.o pgvstand.o pgwindow.o +GR_ROUTINES= grarea.o grbpic.o grchsz.o grclip.o grclos.o grclpl.o grctoi.o grcurs.o grdot0.o grdot1.o grdtyp.o gresc.o grepic.o gretxt.o grfa.o grfao.o grgfil.o grgray.o grimg0.o grimg1.o grimg2.o grimg3.o grinit.o gritoc.o grlen.o grlin0.o grlin1.o grlin2.o grlin3.o grlina.o grmcur.o grmker.o grmova.o grmsg.o gropen.o grpage.o grpars.o grpixl.o grpocl.o grprom.o grpxpo.o grpxps.o grpxpx.o grpxre.o grqcap.o grqci.o grqcol.o grqcr.o grqdev.o grqdt.o grqfnt.o grqls.o grqlw.o grqpos.o grqtxt.o grqtyp.o grquit.o grrec0.o grrect.o grsci.o grscr.o grscrl.o grsetc.o grsets.o grsfnt.o grsize.o grskpb.o grslct.o grsls.o grslw.o grsyds.o grsymk.o grsyxd.o grterm.o grtext.o grtoup.o grtrim.o grtrn0.o grtxy0.o grvct0.o grwarn.o grxhls.o grxrgb.o +SYSTEM_ROUTINES= grdate.o grfileio.o grflun.o grgcom.o grgenv.o grgetc.o grglun.o grgmem.o grgmsg.o grlgtr.o groptx.o grsy00.o grtermio.o grtrml.o grtter.o gruser.o +OBSOLETE_ROUTINES= grchar.o grchr0.o grdat2.o grgtc0.o grinqfont.o grinqli.o grinqpen.o grlinr.o grmark.o grmovr.o grsetfont.o grsetli.o grsetpen.o grtran.o grvect.o pgsetc.o pgsize.o +DRIVERS=gidriv.o nudriv.o psdriv.o ttdriv.o xwdriv.o +PGDISP_ROUTINES= cleanup.o pgdisp.o figcurs.o getdata.o getvisuals.o handlexevent.o proccom.o resdb.o exposelgwin.o getcolors.o initlgluts.o initlgwin.o initlock.o initwmattr.o mainloop.o resizelgwin.o returnbuf.o waitevent.o updatelgtitle.o +DEMOS= pgdemo1 pgdemo2 pgdemo3 pgdemo4 pgdemo5 pgdemo6 pgdemo7 pgdemo8 pgdemo9 pgdemo10 pgdemo11 pgdemo12 pgdemo13 pgdemo14 pgdemo15 pgdemo16 pgdemo17 +# +#----------------------------------------------------------------------- +# Target "all" makes everything (except the library of obsolete routines) +#----------------------------------------------------------------------- +all: lib grfont.dat prog pgplot.doc pgxwin_server + @echo ' ';echo '*** Finished compilation of PGPLOT ***';echo ' ' + @echo 'Note that if you plan to install PGPLOT in a different' + @echo 'directory than the current one, the following files will be' + @echo 'needed.' + @echo ' ' + @echo ' libpgplot.a' + @echo ' libpgplot.so' + @echo ' grfont.dat' + @echo ' rgb.txt' + @echo ' pgxwin_server' + @echo ' ' + @echo 'Also note that subsequent usage of PGPLOT programs requires that' + @echo 'the full path of the chosen installation directory be named in' + @echo 'an environment variable named PGPLOT_DIR.' + @echo ' ' + +#----------------------------------------------------------------------- +# Rules for compiling the .o files +#----------------------------------------------------------------------- +pgarro.o: $(SRCDIR)/pgarro.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgarro.f +pgask.o: $(SRCDIR)/pgask.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgask.f +pgaxis.o: $(SRCDIR)/pgaxis.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgaxis.f +pgaxlg.o: $(SRCDIR)/pgaxlg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgaxlg.f +pgband.o: $(SRCDIR)/pgband.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgband.f +pgbbuf.o: $(SRCDIR)/pgbbuf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbbuf.f +pgbeg.o: $(SRCDIR)/pgbeg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbeg.f +pgbin.o: $(SRCDIR)/pgbin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbin.f +pgbox.o: $(SRCDIR)/pgbox.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbox.f +pgbox1.o: $(SRCDIR)/pgbox1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbox1.f +pgcirc.o: $(SRCDIR)/pgcirc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcirc.f +pgcl.o: $(SRCDIR)/pgcl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcl.f +pgclos.o: $(SRCDIR)/pgclos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgclos.f +pgcn01.o: $(SRCDIR)/pgcn01.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcn01.f +pgcnsc.o: $(SRCDIR)/pgcnsc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcnsc.f +pgconb.o: $(SRCDIR)/pgconb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconb.f +pgconf.o: $(SRCDIR)/pgconf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconf.f +pgconl.o: $(SRCDIR)/pgconl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconl.f +pgcons.o: $(SRCDIR)/pgcons.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcons.f +pgcont.o: $(SRCDIR)/pgcont.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcont.f +pgconx.o: $(SRCDIR)/pgconx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgconx.f +pgcp.o: $(SRCDIR)/pgcp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcp.f +pgctab.o: $(SRCDIR)/pgctab.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgctab.f +pgcurs.o: $(SRCDIR)/pgcurs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcurs.f +pgdraw.o: $(SRCDIR)/pgdraw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgdraw.f +pgebuf.o: $(SRCDIR)/pgebuf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgebuf.f +pgend.o: $(SRCDIR)/pgend.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgend.f +pgenv.o: $(SRCDIR)/pgenv.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgenv.f +pgeras.o: $(SRCDIR)/pgeras.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgeras.f +pgerr1.o: $(SRCDIR)/pgerr1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerr1.f +pgerrb.o: $(SRCDIR)/pgerrb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerrb.f +pgerrx.o: $(SRCDIR)/pgerrx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerrx.f +pgerry.o: $(SRCDIR)/pgerry.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgerry.f +pgetxt.o: $(SRCDIR)/pgetxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgetxt.f +pgfunt.o: $(SRCDIR)/pgfunt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgfunt.f +pgfunx.o: $(SRCDIR)/pgfunx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgfunx.f +pgfuny.o: $(SRCDIR)/pgfuny.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgfuny.f +pggray.o: $(SRCDIR)/pggray.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pggray.f +pghi2d.o: $(SRCDIR)/pghi2d.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghi2d.f +pghis1.o: $(SRCDIR)/pghis1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghis1.f +pghist.o: $(SRCDIR)/pghist.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghist.f +pghtch.o: $(SRCDIR)/pghtch.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pghtch.f +pgiden.o: $(SRCDIR)/pgiden.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgiden.f +pgimag.o: $(SRCDIR)/pgimag.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgimag.f +pginit.o: $(SRCDIR)/pginit.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pginit.f +pglab.o: $(SRCDIR)/pglab.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglab.f +pglcur.o: $(SRCDIR)/pglcur.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglcur.f +pgldev.o: $(SRCDIR)/pgldev.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgldev.f +pglen.o: $(SRCDIR)/pglen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglen.f +pgline.o: $(SRCDIR)/pgline.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgline.f +pgmove.o: $(SRCDIR)/pgmove.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgmove.f +pgmtxt.o: $(SRCDIR)/pgmtxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgmtxt.f +pgncur.o: $(SRCDIR)/pgncur.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgncur.f +pgnoto.o: $(SRCDIR)/pgnoto.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgnoto.f +pgnpl.o: $(SRCDIR)/pgnpl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgnpl.f +pgnumb.o: $(SRCDIR)/pgnumb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgnumb.f +pgolin.o: $(SRCDIR)/pgolin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgolin.f +pgopen.o: $(SRCDIR)/pgopen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgopen.f +pgpage.o: $(SRCDIR)/pgpage.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpage.f +pgpanl.o: $(SRCDIR)/pgpanl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpanl.f +pgpap.o: $(SRCDIR)/pgpap.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpap.f +pgpixl.o: $(SRCDIR)/pgpixl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpixl.f +pgpnts.o: $(SRCDIR)/pgpnts.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpnts.f +pgpoly.o: $(SRCDIR)/pgpoly.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpoly.f +pgpt.o: $(SRCDIR)/pgpt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpt.f +pgpt1.o: $(SRCDIR)/pgpt1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpt1.f +pgptxt.o: $(SRCDIR)/pgptxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgptxt.f +pgqah.o: $(SRCDIR)/pgqah.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqah.f +pgqcf.o: $(SRCDIR)/pgqcf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcf.f +pgqch.o: $(SRCDIR)/pgqch.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqch.f +pgqci.o: $(SRCDIR)/pgqci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqci.f +pgqcir.o: $(SRCDIR)/pgqcir.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcir.f +pgqclp.o: $(SRCDIR)/pgqclp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqclp.f +pgqcol.o: $(SRCDIR)/pgqcol.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcol.f +pgqcr.o: $(SRCDIR)/pgqcr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcr.f +pgqcs.o: $(SRCDIR)/pgqcs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqcs.f +pgqdt.o: $(SRCDIR)/pgqdt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqdt.f +pgqfs.o: $(SRCDIR)/pgqfs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqfs.f +pgqhs.o: $(SRCDIR)/pgqhs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqhs.f +pgqid.o: $(SRCDIR)/pgqid.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqid.f +pgqinf.o: $(SRCDIR)/pgqinf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqinf.f +pgqitf.o: $(SRCDIR)/pgqitf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqitf.f +pgqls.o: $(SRCDIR)/pgqls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqls.f +pgqlw.o: $(SRCDIR)/pgqlw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqlw.f +pgqndt.o: $(SRCDIR)/pgqndt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqndt.f +pgqpos.o: $(SRCDIR)/pgqpos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqpos.f +pgqtbg.o: $(SRCDIR)/pgqtbg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqtbg.f +pgqtxt.o: $(SRCDIR)/pgqtxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqtxt.f +pgqvp.o: $(SRCDIR)/pgqvp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqvp.f +pgqvsz.o: $(SRCDIR)/pgqvsz.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqvsz.f +pgqwin.o: $(SRCDIR)/pgqwin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgqwin.f +pgrect.o: $(SRCDIR)/pgrect.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgrect.f +pgrnd.o: $(SRCDIR)/pgrnd.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgrnd.f +pgrnge.o: $(SRCDIR)/pgrnge.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgrnge.f +pgsah.o: $(SRCDIR)/pgsah.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsah.f +pgsave.o: $(SRCDIR)/pgsave.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsave.f +pgscf.o: $(SRCDIR)/pgscf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscf.f +pgsch.o: $(SRCDIR)/pgsch.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsch.f +pgsci.o: $(SRCDIR)/pgsci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsci.f +pgscir.o: $(SRCDIR)/pgscir.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscir.f +pgsclp.o: $(SRCDIR)/pgsclp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsclp.f +pgscr.o: $(SRCDIR)/pgscr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscr.f +pgscrl.o: $(SRCDIR)/pgscrl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscrl.f +pgscrn.o: $(SRCDIR)/pgscrn.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgscrn.f +pgsfs.o: $(SRCDIR)/pgsfs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsfs.f +pgshls.o: $(SRCDIR)/pgshls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgshls.f +pgshs.o: $(SRCDIR)/pgshs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgshs.f +pgsitf.o: $(SRCDIR)/pgsitf.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsitf.f +pgslct.o: $(SRCDIR)/pgslct.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgslct.f +pgsls.o: $(SRCDIR)/pgsls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsls.f +pgslw.o: $(SRCDIR)/pgslw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgslw.f +pgstbg.o: $(SRCDIR)/pgstbg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgstbg.f +pgsubp.o: $(SRCDIR)/pgsubp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsubp.f +pgsvp.o: $(SRCDIR)/pgsvp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgsvp.f +pgswin.o: $(SRCDIR)/pgswin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgswin.f +pgtbox.o: $(SRCDIR)/pgtbox.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtbox.f +pgtext.o: $(SRCDIR)/pgtext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtext.f +pgtick.o: $(SRCDIR)/pgtick.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtick.f +pgtikl.o: $(SRCDIR)/pgtikl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgtikl.f +pgupdt.o: $(SRCDIR)/pgupdt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgupdt.f +pgvect.o: $(SRCDIR)/pgvect.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvect.f +pgvsiz.o: $(SRCDIR)/pgvsiz.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvsiz.f +pgvstd.o: $(SRCDIR)/pgvstd.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvstd.f +pgvw.o: $(SRCDIR)/pgvw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvw.f +pgwedg.o: $(SRCDIR)/pgwedg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgwedg.f +pgwnad.o: $(SRCDIR)/pgwnad.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgwnad.f +pgadvance.o: $(SRCDIR)/pgadvance.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgadvance.f +pgbegin.o: $(SRCDIR)/pgbegin.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgbegin.f +pgcurse.o: $(SRCDIR)/pgcurse.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgcurse.f +pglabel.o: $(SRCDIR)/pglabel.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pglabel.f +pgmtext.o: $(SRCDIR)/pgmtext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgmtext.f +pgncurse.o: $(SRCDIR)/pgncurse.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgncurse.f +pgpaper.o: $(SRCDIR)/pgpaper.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpaper.f +pgpoint.o: $(SRCDIR)/pgpoint.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgpoint.f +pgptext.o: $(SRCDIR)/pgptext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgptext.f +pgvport.o: $(SRCDIR)/pgvport.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvport.f +pgvsize.o: $(SRCDIR)/pgvsize.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvsize.f +pgvstand.o: $(SRCDIR)/pgvstand.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgvstand.f +pgwindow.o: $(SRCDIR)/pgwindow.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/pgwindow.f +grarea.o: $(SRCDIR)/grarea.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grarea.f +grbpic.o: $(SRCDIR)/grbpic.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grbpic.f +grchsz.o: $(SRCDIR)/grchsz.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grchsz.f +grclip.o: $(SRCDIR)/grclip.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grclip.f +grclos.o: $(SRCDIR)/grclos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grclos.f +grclpl.o: $(SRCDIR)/grclpl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grclpl.f +grctoi.o: $(SRCDIR)/grctoi.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grctoi.f +grcurs.o: $(SRCDIR)/grcurs.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grcurs.f +grdot0.o: $(SRCDIR)/grdot0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grdot0.f +grdot1.o: $(SRCDIR)/grdot1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grdot1.f +grdtyp.o: $(SRCDIR)/grdtyp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grdtyp.f +gresc.o: $(SRCDIR)/gresc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gresc.f +grepic.o: $(SRCDIR)/grepic.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grepic.f +gretxt.o: $(SRCDIR)/gretxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gretxt.f +grfa.o: $(SRCDIR)/grfa.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grfa.f +grfao.o: $(SRCDIR)/grfao.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grfao.f +grgfil.o: $(SRCDIR)/grgfil.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grgfil.f +grgray.o: $(SRCDIR)/grgray.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grgray.f +grimg0.o: $(SRCDIR)/grimg0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg0.f +grimg1.o: $(SRCDIR)/grimg1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg1.f +grimg2.o: $(SRCDIR)/grimg2.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg2.f +grimg3.o: $(SRCDIR)/grimg3.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grimg3.f +grinit.o: $(SRCDIR)/grinit.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grinit.f +gritoc.o: $(SRCDIR)/gritoc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gritoc.f +grlen.o: $(SRCDIR)/grlen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlen.f +grlin0.o: $(SRCDIR)/grlin0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin0.f +grlin1.o: $(SRCDIR)/grlin1.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin1.f +grlin2.o: $(SRCDIR)/grlin2.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin2.f +grlin3.o: $(SRCDIR)/grlin3.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlin3.f +grlina.o: $(SRCDIR)/grlina.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grlina.f +grmcur.o: $(SRCDIR)/grmcur.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmcur.f +grmker.o: $(SRCDIR)/grmker.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmker.f +grmova.o: $(SRCDIR)/grmova.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmova.f +grmsg.o: $(SRCDIR)/grmsg.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grmsg.f +gropen.o: $(SRCDIR)/gropen.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/gropen.f +grpage.o: $(SRCDIR)/grpage.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpage.f +grpars.o: $(SRCDIR)/grpars.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpars.f +grpixl.o: $(SRCDIR)/grpixl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpixl.f +grpocl.o: $(SRCDIR)/grpocl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpocl.f +grprom.o: $(SRCDIR)/grprom.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grprom.f +grpxpo.o: $(SRCDIR)/grpxpo.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxpo.f +grpxps.o: $(SRCDIR)/grpxps.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxps.f +grpxpx.o: $(SRCDIR)/grpxpx.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxpx.f +grpxre.o: $(SRCDIR)/grpxre.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grpxre.f +grqcap.o: $(SRCDIR)/grqcap.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqcap.f +grqci.o: $(SRCDIR)/grqci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqci.f +grqcol.o: $(SRCDIR)/grqcol.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqcol.f +grqcr.o: $(SRCDIR)/grqcr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqcr.f +grqdev.o: $(SRCDIR)/grqdev.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqdev.f +grqdt.o: $(SRCDIR)/grqdt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqdt.f +grqfnt.o: $(SRCDIR)/grqfnt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqfnt.f +grqls.o: $(SRCDIR)/grqls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqls.f +grqlw.o: $(SRCDIR)/grqlw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqlw.f +grqpos.o: $(SRCDIR)/grqpos.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqpos.f +grqtxt.o: $(SRCDIR)/grqtxt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqtxt.f +grqtyp.o: $(SRCDIR)/grqtyp.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grqtyp.f +grquit.o: $(SRCDIR)/grquit.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grquit.f +grrec0.o: $(SRCDIR)/grrec0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grrec0.f +grrect.o: $(SRCDIR)/grrect.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grrect.f +grsci.o: $(SRCDIR)/grsci.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsci.f +grscr.o: $(SRCDIR)/grscr.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grscr.f +grscrl.o: $(SRCDIR)/grscrl.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grscrl.f +grsetc.o: $(SRCDIR)/grsetc.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsetc.f +grsets.o: $(SRCDIR)/grsets.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsets.f +grsfnt.o: $(SRCDIR)/grsfnt.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsfnt.f +grsize.o: $(SRCDIR)/grsize.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsize.f +grskpb.o: $(SRCDIR)/grskpb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grskpb.f +grslct.o: $(SRCDIR)/grslct.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grslct.f +grsls.o: $(SRCDIR)/grsls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsls.f +grslw.o: $(SRCDIR)/grslw.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grslw.f +grsyds.o: $(SRCDIR)/grsyds.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsyds.f +grsymk.o: $(SRCDIR)/grsymk.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsymk.f +grsyxd.o: $(SRCDIR)/grsyxd.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grsyxd.f +grterm.o: $(SRCDIR)/grterm.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grterm.f +grtext.o: $(SRCDIR)/grtext.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtext.f +grtoup.o: $(SRCDIR)/grtoup.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtoup.f +grtrim.o: $(SRCDIR)/grtrim.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtrim.f +grtrn0.o: $(SRCDIR)/grtrn0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtrn0.f +grtxy0.o: $(SRCDIR)/grtxy0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grtxy0.f +grvct0.o: $(SRCDIR)/grvct0.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grvct0.f +grwarn.o: $(SRCDIR)/grwarn.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grwarn.f +grxhls.o: $(SRCDIR)/grxhls.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grxhls.f +grxrgb.o: $(SRCDIR)/grxrgb.f + $(FCOMPL) -c $(FFLAGC) $(SRCDIR)/grxrgb.f +grdate.o: $(GENDIR)/grdate.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grdate.c +grfileio.o: $(GENDIR)/grfileio.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grfileio.c +grflun.o: $(GENDIR)/grflun.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grflun.f +grgcom.o: $(GENDIR)/grgcom.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grgcom.f +grgenv.o: $(GENDIR)/grgenv.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grgenv.f +grgetc.o: $(GENDIR)/grgetc.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grgetc.c +grglun.o: $(GENDIR)/grglun.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grglun.f +grgmem.o: $(GENDIR)/grgmem.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grgmem.c +grgmsg.o: $(GENDIR)/grgmsg.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grgmsg.f +grlgtr.o: $(GENDIR)/grlgtr.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grlgtr.f +groptx.o: $(GENDIR)/groptx.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/groptx.f +grsy00.o: $(GENDIR)/grsy00.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grsy00.f +grtermio.o: $(GENDIR)/grtermio.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/grtermio.c +grtrml.o: $(GENDIR)/grtrml.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grtrml.f +grtter.o: $(GENDIR)/grtter.f + $(FCOMPL) -c $(FFLAGC) $(GENDIR)/grtter.f +gruser.o: $(GENDIR)/gruser.c + $(CCOMPL) -c $(CFLAGC) $(GENDIR)/gruser.c +grchar.o: $(OBSDIR)/grchar.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grchar.f +grchr0.o: $(OBSDIR)/grchr0.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grchr0.f +grdat2.o: $(OBSDIR)/grdat2.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grdat2.f +grgtc0.o: $(OBSDIR)/grgtc0.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grgtc0.f +grinqfont.o: $(OBSDIR)/grinqfont.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grinqfont.f +grinqli.o: $(OBSDIR)/grinqli.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grinqli.f +grinqpen.o: $(OBSDIR)/grinqpen.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grinqpen.f +grlinr.o: $(OBSDIR)/grlinr.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grlinr.f +grmark.o: $(OBSDIR)/grmark.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grmark.f +grmovr.o: $(OBSDIR)/grmovr.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grmovr.f +grsetfont.o: $(OBSDIR)/grsetfont.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grsetfont.f +grsetli.o: $(OBSDIR)/grsetli.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grsetli.f +grsetpen.o: $(OBSDIR)/grsetpen.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grsetpen.f +grtran.o: $(OBSDIR)/grtran.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grtran.f +grvect.o: $(OBSDIR)/grvect.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/grvect.f +pgsetc.o: $(OBSDIR)/pgsetc.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/pgsetc.f +pgsize.o: $(OBSDIR)/pgsize.f + $(FCOMPL) -c $(FFLAGC) $(OBSDIR)/pgsize.f +cleanup.o: $(PGDDIR)/cleanup.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/cleanup.c +pgdisp.o: $(PGDDIR)/pgdisp.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/pgdisp.c +figcurs.o: $(PGDDIR)/figcurs.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/figcurs.c +getdata.o: $(PGDDIR)/getdata.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/getdata.c +getvisuals.o: $(PGDDIR)/getvisuals.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/getvisuals.c +handlexevent.o: $(PGDDIR)/handlexevent.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/handlexevent.c +proccom.o: $(PGDDIR)/proccom.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/proccom.c +resdb.o: $(PGDDIR)/resdb.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/resdb.c +exposelgwin.o: $(PGDDIR)/exposelgwin.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/exposelgwin.c +getcolors.o: $(PGDDIR)/getcolors.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/getcolors.c +initlgluts.o: $(PGDDIR)/initlgluts.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initlgluts.c +initlgwin.o: $(PGDDIR)/initlgwin.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initlgwin.c +initlock.o: $(PGDDIR)/initlock.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initlock.c +initwmattr.o: $(PGDDIR)/initwmattr.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/initwmattr.c +mainloop.o: $(PGDDIR)/mainloop.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/mainloop.c +resizelgwin.o: $(PGDDIR)/resizelgwin.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/resizelgwin.c +returnbuf.o: $(PGDDIR)/returnbuf.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/returnbuf.c +waitevent.o: $(PGDDIR)/waitevent.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/waitevent.c +updatelgtitle.o: $(PGDDIR)/updatelgtitle.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) -DPGDISP $(PGDDIR)/updatelgtitle.c +gidriv.o: $(DRVDIR)/gidriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/gidriv.f +nudriv.o: $(DRVDIR)/nudriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/nudriv.f +psdriv.o: $(DRVDIR)/psdriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/psdriv.f +ttdriv.o: $(DRVDIR)/ttdriv.f + $(FCOMPL) -c $(FFLAGC) $(DRVDIR)/ttdriv.f +xwdriv.o: $(DRVDIR)/xwdriv.c + $(CCOMPL) -c $(CFLAGC) $(XINCL) $(DRVDIR)/xwdriv.c + +#----------------------------------------------------------------------- +# The device-driver dispatch routine is generated automatically by +# reading the "drivers.list" file. +#----------------------------------------------------------------------- + +DISPATCH_ROUTINE=grexec.o + +grexec.o: grexec.f + $(FCOMPL) -c $(FFLAGC) grexec.f + +#----------------------------------------------------------------------- +# Target "lib" is used to built the PGPLOT subroutine library. +# libpgplot.a is the primary PGPLOT object library. +# "shared" is an optional target for operating systems that allow shared +# libraries. +#----------------------------------------------------------------------- + +lib : libpgplot.a $(SHARED_LIB) + +libpgplot.a : $(PG_ROUTINES) $(PG_NON_STANDARD) $(GR_ROUTINES) \ + $(DISPATCH_ROUTINE) $(DRIVERS) $(SYSTEM_ROUTINES) + ar ru libpgplot.a \ + `ls $(PG_ROUTINES) \ + $(PG_NON_STANDARD) $(GR_ROUTINES) $(DISPATCH_ROUTINE) \ + $(DRIVERS) $(SYSTEM_ROUTINES) | sort | uniq` + $(RANLIB) libpgplot.a + +$(SHARED_LIB): $(PG_ROUTINES) $(PG_NON_STANDARD) \ + $(GR_ROUTINES) $(DISPATCH_ROUTINE) $(DRIVERS) $(SYSTEM_ROUTINES) + $(SHARED_LD) `ls $(PG_ROUTINES) \ + $(PG_NON_STANDARD) $(GR_ROUTINES) $(DISPATCH_ROUTINE) \ + $(DRIVERS) $(SYSTEM_ROUTINES) | sort | uniq` $(SHARED_LIB_LIBS) + +#----------------------------------------------------------------------- +# libpgobs.a contains obsolete routines used by some programs +#----------------------------------------------------------------------- +libpgobs.a : $(OBSOLETE_ROUTINES) + ar ru libpgobs.a $(OBSOLETE_ROUTINES) + $(RANLIB) libpgobs.a + +#----------------------------------------------------------------------- +# Target "prog" is used to make the demo programs. They can also be made +# individually. +#----------------------------------------------------------------------- +prog: $(DEMOS) + +pgdemo1: $(DEMDIR)/pgdemo1.f + $(FCOMPL) $(FFLAGD) -o pgdemo1 $(DEMDIR)/pgdemo1.f $(PGPLOT_LIB) $(LIBS) +pgdemo2: $(DEMDIR)/pgdemo2.f + $(FCOMPL) $(FFLAGD) -o pgdemo2 $(DEMDIR)/pgdemo2.f $(PGPLOT_LIB) $(LIBS) +pgdemo3: $(DEMDIR)/pgdemo3.f + $(FCOMPL) $(FFLAGD) -o pgdemo3 $(DEMDIR)/pgdemo3.f $(PGPLOT_LIB) $(LIBS) +pgdemo4: $(DEMDIR)/pgdemo4.f + $(FCOMPL) $(FFLAGD) -o pgdemo4 $(DEMDIR)/pgdemo4.f $(PGPLOT_LIB) $(LIBS) +pgdemo5: $(DEMDIR)/pgdemo5.f + $(FCOMPL) $(FFLAGD) -o pgdemo5 $(DEMDIR)/pgdemo5.f $(PGPLOT_LIB) $(LIBS) +pgdemo6: $(DEMDIR)/pgdemo6.f + $(FCOMPL) $(FFLAGD) -o pgdemo6 $(DEMDIR)/pgdemo6.f $(PGPLOT_LIB) $(LIBS) +pgdemo7: $(DEMDIR)/pgdemo7.f + $(FCOMPL) $(FFLAGD) -o pgdemo7 $(DEMDIR)/pgdemo7.f $(PGPLOT_LIB) $(LIBS) +pgdemo8: $(DEMDIR)/pgdemo8.f + $(FCOMPL) $(FFLAGD) -o pgdemo8 $(DEMDIR)/pgdemo8.f $(PGPLOT_LIB) $(LIBS) +pgdemo9: $(DEMDIR)/pgdemo9.f + $(FCOMPL) $(FFLAGD) -o pgdemo9 $(DEMDIR)/pgdemo9.f $(PGPLOT_LIB) $(LIBS) +pgdemo10: $(DEMDIR)/pgdemo10.f + $(FCOMPL) $(FFLAGD) -o pgdemo10 $(DEMDIR)/pgdemo10.f $(PGPLOT_LIB) $(LIBS) +pgdemo11: $(DEMDIR)/pgdemo11.f + $(FCOMPL) $(FFLAGD) -o pgdemo11 $(DEMDIR)/pgdemo11.f $(PGPLOT_LIB) $(LIBS) +pgdemo12: $(DEMDIR)/pgdemo12.f + $(FCOMPL) $(FFLAGD) -o pgdemo12 $(DEMDIR)/pgdemo12.f $(PGPLOT_LIB) $(LIBS) +pgdemo13: $(DEMDIR)/pgdemo13.f + $(FCOMPL) $(FFLAGD) -o pgdemo13 $(DEMDIR)/pgdemo13.f $(PGPLOT_LIB) $(LIBS) +pgdemo14: $(DEMDIR)/pgdemo14.f + $(FCOMPL) $(FFLAGD) -o pgdemo14 $(DEMDIR)/pgdemo14.f $(PGPLOT_LIB) $(LIBS) +pgdemo15: $(DEMDIR)/pgdemo15.f + $(FCOMPL) $(FFLAGD) -o pgdemo15 $(DEMDIR)/pgdemo15.f $(PGPLOT_LIB) $(LIBS) +pgdemo16: $(DEMDIR)/pgdemo16.f + $(FCOMPL) $(FFLAGD) -o pgdemo16 $(DEMDIR)/pgdemo16.f $(PGPLOT_LIB) $(LIBS) +pgdemo17: $(DEMDIR)/pgdemo17.f + $(FCOMPL) $(FFLAGD) -o pgdemo17 $(DEMDIR)/pgdemo17.f $(PGPLOT_LIB) $(LIBS) + +#----------------------------------------------------------------------- +# Target "grfont.dat" is the binary font file. +# This is created from grfont.txt with the "pgpack" program. +# (a) compile the `pgpack' program; then +# (b) run `pgpack' to convert the ASCII version of the font file +# (grfont.txt) into the binary version (grfont.dat). When executed, +# `pgpack' should report: +# Characters defined: 996 +# Array cells used: 26732 +#----------------------------------------------------------------------- + +grfont.dat: $(FNTDIR)/grfont.txt $(FNTDIR)/pgpack.f + $(FCOMPL) $(FFLAGC) -o pgpack $(FNTDIR)/pgpack.f + rm -f grfont.dat + ./pgpack <$(FNTDIR)/grfont.txt + rm -f pgpack + +#----------------------------------------------------------------------- +# Documentation files +#----------------------------------------------------------------------- + +PG_SOURCE= $(SRCDIR)/pgarro.f $(SRCDIR)/pgask.f $(SRCDIR)/pgaxis.f $(SRCDIR)/pgaxlg.f $(SRCDIR)/pgband.f $(SRCDIR)/pgbbuf.f $(SRCDIR)/pgbeg.f $(SRCDIR)/pgbin.f $(SRCDIR)/pgbox.f $(SRCDIR)/pgbox1.f $(SRCDIR)/pgcirc.f $(SRCDIR)/pgcl.f $(SRCDIR)/pgclos.f $(SRCDIR)/pgcn01.f $(SRCDIR)/pgcnsc.f $(SRCDIR)/pgconb.f $(SRCDIR)/pgconf.f $(SRCDIR)/pgconl.f $(SRCDIR)/pgcons.f $(SRCDIR)/pgcont.f $(SRCDIR)/pgconx.f $(SRCDIR)/pgcp.f $(SRCDIR)/pgctab.f $(SRCDIR)/pgcurs.f $(SRCDIR)/pgdraw.f $(SRCDIR)/pgebuf.f $(SRCDIR)/pgend.f $(SRCDIR)/pgenv.f $(SRCDIR)/pgeras.f $(SRCDIR)/pgerr1.f $(SRCDIR)/pgerrb.f $(SRCDIR)/pgerrx.f $(SRCDIR)/pgerry.f $(SRCDIR)/pgetxt.f $(SRCDIR)/pgfunt.f $(SRCDIR)/pgfunx.f $(SRCDIR)/pgfuny.f $(SRCDIR)/pggray.f $(SRCDIR)/pghi2d.f $(SRCDIR)/pghis1.f $(SRCDIR)/pghist.f $(SRCDIR)/pghtch.f $(SRCDIR)/pgiden.f $(SRCDIR)/pgimag.f $(SRCDIR)/pginit.f $(SRCDIR)/pglab.f $(SRCDIR)/pglcur.f $(SRCDIR)/pgldev.f $(SRCDIR)/pglen.f $(SRCDIR)/pgline.f $(SRCDIR)/pgmove.f $(SRCDIR)/pgmtxt.f $(SRCDIR)/pgncur.f $(SRCDIR)/pgnoto.f $(SRCDIR)/pgnpl.f $(SRCDIR)/pgnumb.f $(SRCDIR)/pgolin.f $(SRCDIR)/pgopen.f $(SRCDIR)/pgpage.f $(SRCDIR)/pgpanl.f $(SRCDIR)/pgpap.f $(SRCDIR)/pgpixl.f $(SRCDIR)/pgpnts.f $(SRCDIR)/pgpoly.f $(SRCDIR)/pgpt.f $(SRCDIR)/pgpt1.f $(SRCDIR)/pgptxt.f $(SRCDIR)/pgqah.f $(SRCDIR)/pgqcf.f $(SRCDIR)/pgqch.f $(SRCDIR)/pgqci.f $(SRCDIR)/pgqcir.f $(SRCDIR)/pgqclp.f $(SRCDIR)/pgqcol.f $(SRCDIR)/pgqcr.f $(SRCDIR)/pgqcs.f $(SRCDIR)/pgqdt.f $(SRCDIR)/pgqfs.f $(SRCDIR)/pgqhs.f $(SRCDIR)/pgqid.f $(SRCDIR)/pgqinf.f $(SRCDIR)/pgqitf.f $(SRCDIR)/pgqls.f $(SRCDIR)/pgqlw.f $(SRCDIR)/pgqndt.f $(SRCDIR)/pgqpos.f $(SRCDIR)/pgqtbg.f $(SRCDIR)/pgqtxt.f $(SRCDIR)/pgqvp.f $(SRCDIR)/pgqvsz.f $(SRCDIR)/pgqwin.f $(SRCDIR)/pgrect.f $(SRCDIR)/pgrnd.f $(SRCDIR)/pgrnge.f $(SRCDIR)/pgsah.f $(SRCDIR)/pgsave.f $(SRCDIR)/pgscf.f $(SRCDIR)/pgsch.f $(SRCDIR)/pgsci.f $(SRCDIR)/pgscir.f $(SRCDIR)/pgsclp.f $(SRCDIR)/pgscr.f $(SRCDIR)/pgscrl.f $(SRCDIR)/pgscrn.f $(SRCDIR)/pgsfs.f $(SRCDIR)/pgshls.f $(SRCDIR)/pgshs.f $(SRCDIR)/pgsitf.f $(SRCDIR)/pgslct.f $(SRCDIR)/pgsls.f $(SRCDIR)/pgslw.f $(SRCDIR)/pgstbg.f $(SRCDIR)/pgsubp.f $(SRCDIR)/pgsvp.f $(SRCDIR)/pgswin.f $(SRCDIR)/pgtbox.f $(SRCDIR)/pgtext.f $(SRCDIR)/pgtick.f $(SRCDIR)/pgtikl.f $(SRCDIR)/pgupdt.f $(SRCDIR)/pgvect.f $(SRCDIR)/pgvsiz.f $(SRCDIR)/pgvstd.f $(SRCDIR)/pgvw.f $(SRCDIR)/pgwedg.f $(SRCDIR)/pgwnad.f $(SRCDIR)/pgadvance.f $(SRCDIR)/pgbegin.f $(SRCDIR)/pgcurse.f $(SRCDIR)/pglabel.f $(SRCDIR)/pgmtext.f $(SRCDIR)/pgncurse.f $(SRCDIR)/pgpaper.f $(SRCDIR)/pgpoint.f $(SRCDIR)/pgptext.f $(SRCDIR)/pgvport.f $(SRCDIR)/pgvsize.f $(SRCDIR)/pgvstand.f $(SRCDIR)/pgwindow.f +pgplot.doc: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot/makedoc $(PG_SOURCE) > pgplot.doc +pgplot.html: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot/makehtml $(PG_SOURCE) > pgplot.html +pgplot.hlp: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot/makehelp $(PG_SOURCE) > pgplot.hlp +pgplot-routines.tex: $(PG_SOURCE) + /afs/psi.ch/project/sinq/common/src/pgplot/maketex $(PG_SOURCE) > pgplot-routines.tex + +#----------------------------------------------------------------------- +# Target "pgxwin_server" is the server program for the XW driver +#----------------------------------------------------------------------- +pgxwin_server: $(DRVDIR)/pgxwin_server.c + $(CCOMPL) $(CFLAGC) $(XINCL) -o pgxwin_server $(DRVDIR)/pgxwin_server.c $(LIBS) + +#----------------------------------------------------------------------- +# Target "pgdisp" is the pgdisp server program for /XDISP driver +#----------------------------------------------------------------------- +pgdisp: $(PGDISP_ROUTINES) + $(CCOMPL) $(CFLAGC) -o pgdisp $(PGDISP_ROUTINES) $(LIBS) + +#----------------------------------------------------------------------- +# Target "libxmpgplot.a" contains the Motif widget driver. +#----------------------------------------------------------------------- + +libXmPgplot.a: XmPgplot.o + ar ru libXmPgplot.a XmPgplot.o + $(RANLIB) libXmPgplot.a + +XmPgplot.h: $(XMDIR)/XmPgplot.h + cp $(XMDIR)/XmPgplot.h XmPgplot.h + +XmPgplot.o: $(DRVDIR)/pgxwin.h XmPgplot.h $(XMDIR)/XmPgplotP.h $(XMDIR)/XmPgplot.c + $(CCOMPL) -c $(CFLAGC) -I$(DRVDIR) -I$(XMDIR) $(MOTIF_INCL) $(XMDIR)/XmPgplot.c + +#----------------------------------------------------------------------- +# Target "libxapgplot.a" contains the Motif widget driver. +#----------------------------------------------------------------------- + +libXaPgplot.a: XaPgplot.o + ar ru libXaPgplot.a XaPgplot.o + $(RANLIB) libXaPgplot.a + +XaPgplot.h: $(XADIR)/XaPgplot.h + cp $(XADIR)/XaPgplot.h XaPgplot.h + +XaPgplot.o: $(DRVDIR)/pgxwin.h XaPgplot.h $(XADIR)/XaPgplotP.h $(XADIR)/XaPgplot.c + $(CCOMPL) -c $(CFLAGC) -I$(DRVDIR) -I$(XADIR) $(MOTIF_INCL) $(XADIR)/XaPgplot.c + +#----------------------------------------------------------------------- +# Target "libtkpgplot.a" contains the Tk widget driver. +#----------------------------------------------------------------------- + +libtkpgplot.a: tkpgplot.o + ar ru libtkpgplot.a tkpgplot.o + $(RANLIB) libtkpgplot.a + +tkpgplot.h: $(TKDIR)/tkpgplot.h + cp $(TKDIR)/tkpgplot.h tkpgplot.h + +tkpgplot.o: $(DRVDIR)/pgxwin.h tkpgplot.h $(TKDIR)/tkpgplot.c + $(CCOMPL) -c $(CFLAGC) -I$(DRVDIR) -I$(TKDIR) $(TK_INCL) $(TKDIR)/tkpgplot.c + +#----------------------------------------------------------------------- +# Target "librvpgplot.a" contains the Rivet-Tk widget driver. +#----------------------------------------------------------------------- + +librvpgplot.a: rvpgplot.o + ar ru librvpgplot.a rvpgplot.o + $(RANLIB) librvpgplot.a + +rvpgplot.h: $(TKDIR)/rvpgplot.h + cp $(TKDIR)/rvpgplot.h rvpgplot.h + +rvpgplot.o: $(DRVDIR)/pgxwin.h rvpgplot.h $(TKDIR)/tkpgplot.c + $(CCOMPL) -o $@ -c -DUSE_RIVET $(CFLAGC) -I$(DRVDIR) -I$(TKDIR) $(RV_INCL) $(TKDIR)/tkpgplot.c + +#----------------------------------------------------------------------- +# Target "install" is required for Figaro. +#----------------------------------------------------------------------- +install: + +#----------------------------------------------------------------------- +# Target "clean" is used to remove all the intermediate files. +#----------------------------------------------------------------------- +clean : + -@rm -f $(PG_ROUTINES) $(PG_NON_STANDARD) $(GR_ROUTINES)\ + $(DISPATCH_ROUTINE) $(DRIVERS) $(SYSTEM_ROUTINES)\ + $(OBSOLETE_ROUTINES) $(PGDISP_ROUTINES) pgmdemo.o\ + XmPgplot.o pgbind tkpgplot.o pgtkdemo.o rvpgplot.o\ + pgbind.o pgdemo*.o pgawdemo.o + +#----------------------------------------------------------------------- +# Include file dependencies +#----------------------------------------------------------------------- +# The following routines reference pgplot.inc + +pgask.o pgband.o pgbbuf.o pgbox.o pgcirc.o pgcl.o pgclos.o pgconl.o pgcont.o pgcp.o pgebuf.o pgend.o pggray.o pghi2d.o pgiden.o pgimag.o pginit.o pglen.o pgmtxt.o pgncur.o pgnoto.o pgopen.o pgpage.o pgpanl.o pgpap.o pgpoly.o pgptxt.o pgqah.o pgqch.o pgqcir.o pgqclp.o pgqcs.o pgqfs.o pgqhs.o pgqid.o pgqinf.o pgqitf.o pgqtbg.o pgqtxt.o pgqvp.o pgqvsz.o pgqwin.o pgrect.o pgsah.o pgsch.o pgscir.o pgsclp.o pgscrl.o pgsfs.o pgshs.o pgsitf.o pgslct.o pgstbg.o pgsubp.o pgsvp.o pgswin.o pgtikl.o pgvsiz.o pgvstd.o pgvw.o pgwnad.o : $(SRCDIR)/pgplot.inc + +# The following routines reference grpckg1.inc + +grarea.o grbpic.o grchr0.o grchsz.o grclos.o grclpl.o grcurs.o grdot0.o grdot1.o grdtyp.o grepic.o gresc.o gretxt.o grfa.o grgray.o grimg0.o grimg1.o grimg2.o grimg3.o grinit.o grldev.o grlen.o grlin0.o grlin1.o grlin2.o grlin3.o grlina.o grlinr.o grmker.o grmova.o grmovr.o gropen.o grpage.o grpixl.o grpxpo.o grpxps.o grpxpx.o grqcap.o grqci.o grqcol.o grqcr.o grqdev.o grqdt.o grqfnt.o grqls.o grqlw.o grqpos.o grqtxt.o grqtyp.o grrec0.o grrect.o grsci.o grscr.o grscrl.o grsetc.o grsetli.o grsets.o grsfnt.o grsize.o grslct.o grsls.o grslw.o grterm.o grtext.o grtrn0.o grtxy0.o grvct0.o : $(SRCDIR)/grpckg1.inc + + +# Miscellaneous include files required by drivers + +griv00.o : $(DRVDIR)/gadef.h $(DRVDIR)/gmdef.h $(DRVDIR)/gphdef.h +grivas.o : $(DRVDIR)/gadef.h +grtv00.o : $(DRVDIR)/imdef.h +pgxwin.o : $(DRVDIR)/pgxwin.h +pndriv.o : ./png.h ./pngconf.h ./zlib.h ./zconf.h + +x2driv.o figdisp_comm.o: $(DRVDIR)/commands.h + + +cpg: libcpgplot.a cpgplot.h cpgdemo + @echo ' ' + @echo '*** Finished compilation of the C PGPLOT wrapper library ***' + @echo ' ' + @echo 'Note that if you plan to install the library in a different' + @echo 'directory than the current one, both libcpgplot.a and cpgplot.h' + @echo 'will be needed.' + @echo ' ' + +pgbind: $(SRC)/cpg/pgbind.c + $(CCOMPL) $(CFLAGC) $(SRC)/cpg/pgbind.c -o pgbind + +libcpgplot.a cpgplot.h: $(PG_SOURCE) pgbind + ./pgbind $(PGBIND_FLAGS) -h -w $(PG_SOURCE) + $(CCOMPL) -c $(CFLAGC) cpg*.c + rm -f cpg*.c + ar ru libcpgplot.a cpg*.o + $(RANLIB) libcpgplot.a + rm -f cpg*.o + +cpgdemo: cpgplot.h $(SRC)/cpg/cpgdemo.c libcpgplot.a + $(CCOMPL) $(CFLAGD) -c -I. $(SRC)/cpg/cpgdemo.c + $(FCOMPL) -o cpgdemo cpgdemo.o $(CPGPLOT_LIB) $(LIBS) + rm -f cpgdemo.o + +pgmdemo: pgmdemo.o libXmPgplot.a + $(FCOMPL) -o pgmdemo pgmdemo.o -L`pwd` -lXmPgplot $(CPGPLOT_LIB) $(MOTIF_LIBS) + +pgmdemo.o: $(XMDIR)/pgmdemo.c XmPgplot.h libcpgplot.a cpgplot.h + $(CCOMPL) $(CFLAGD) -c -I`pwd` $(MOTIF_INCL) $(XMDIR)/pgmdemo.c + +pgawdemo: pgawdemo.o libXaPgplot.a + $(FCOMPL) -o pgawdemo pgawdemo.o -L`pwd` -lXaPgplot $(CPGPLOT_LIB) $(ATHENA_LIBS) + +pgawdemo.o: $(XADIR)/pgawdemo.c XaPgplot.h libcpgplot.a cpgplot.h + $(CCOMPL) $(CFLAGD) -c -I`pwd` $(ATHENA_INCL) $(XADIR)/pgawdemo.c + +pgtkdemo: pgtkdemo.o libtkpgplot.a + $(FCOMPL) -o pgtkdemo pgtkdemo.o -L`pwd` -ltkpgplot $(CPGPLOT_LIB) $(TK_LIBS) + +pgtkdemo.tcl: $(TKDIR)/pgtkdemo.tcl + cp $(TKDIR)/pgtkdemo.tcl pgtkdemo.tcl + chmod a+x pgtkdemo.tcl + +pgtkdemo.o: $(TKDIR)/pgtkdemo.c tkpgplot.h libcpgplot.a cpgplot.h + $(CCOMPL) $(CFLAGD) -c -I`pwd` $(TK_INCL) $(TKDIR)/pgtkdemo.c diff --git a/pgplot_sl6/pgplot.doc b/pgplot_sl6/pgplot.doc new file mode 100644 index 0000000..cc7b5de --- /dev/null +++ b/pgplot_sl6/pgplot.doc @@ -0,0 +1,3846 @@ +PGPLOT GRAPHICS SUBROUTINE LIBRARY Version 5.1 + +PGPLOT is a Fortran subroutine package for drawing graphs on a variety +of display devices. For more details, see the manual ``PGPLOT Graphics +Subroutine Library'' available from T. J. Pearson +(tjp@astro.caltech.edu). + +INDEX OF ROUTINES + +PGARRO -- draw an arrow +PGASK -- control new page prompting +PGAXIS -- draw an axis +PGBAND -- read cursor position, with anchor +PGBBUF -- begin batch of output (buffer) +PGBEG -- open a graphics device +PGBIN -- histogram of binned data +PGBOX -- draw labeled frame around viewport +PGCIRC -- draw a circle, using fill-area attributes +PGCLOS -- close the selected graphics device +PGCONB -- contour map of a 2D data array, with blanking +PGCONF -- fill between two contours +PGCONL -- label contour map of a 2D data array +PGCONS -- contour map of a 2D data array (fast algorithm) +PGCONT -- contour map of a 2D data array (contour-following) +PGCONX -- contour map of a 2D data array (non rectangular) +PGCTAB -- install the color table to be used by PGIMAG +PGCURS -- read cursor position +PGDRAW -- draw a line from the current pen position to a point +PGEBUF -- end batch of output (buffer) +PGEND -- close all open graphics devices +PGENV -- set window and viewport and draw labeled frame +PGERAS -- erase all graphics from current page +PGERR1 -- horizontal or vertical error bar +PGERRB -- horizontal or vertical error bar +PGERRX -- horizontal error bar +PGERRY -- vertical error bar +PGETXT -- erase text from graphics display +PGFUNT -- function defined by X = F(T), Y = G(T) +PGFUNX -- function defined by Y = F(X) +PGFUNY -- function defined by X = F(Y) +PGGRAY -- gray-scale map of a 2D data array +PGHI2D -- cross-sections through a 2D data array +PGHIST -- histogram of unbinned data +PGIDEN -- write username, date, and time at bottom of plot +PGIMAG -- color image from a 2D data array +PGLAB -- write labels for x-axis, y-axis, and top of plot +PGLCUR -- draw a line using the cursor +PGLDEV -- list available device types on standard output +PGLEN -- find length of a string in a variety of units +PGLINE -- draw a polyline (curve defined by line-segments) +PGMOVE -- move pen (change current pen position) +PGMTXT -- write text at position relative to viewport +PGNCUR -- mark a set of points using the cursor +PGNUMB -- convert a number into a plottable character string +PGOLIN -- mark a set of points using the cursor +PGOPEN -- open a graphics device +PGPAGE -- advance to new page +PGPANL -- switch to a different panel on the view surface +PGPAP -- change the size of the view surface +PGPIXL -- draw pixels +PGPNTS -- draw several graph markers, not all the same +PGPOLY -- draw a polygon, using fill-area attributes +PGPT -- draw several graph markers +PGPT1 -- draw one graph marker +PGPTXT -- write text at arbitrary position and angle +PGQAH -- inquire arrow-head style +PGQCF -- inquire character font +PGQCH -- inquire character height +PGQCI -- inquire color index +PGQCIR -- inquire color index range +PGQCLP -- inquire clipping status +PGQCOL -- inquire color capability +PGQCR -- inquire color representation +PGQCS -- inquire character height in a variety of units +PGQDT -- inquire name of nth available device type +PGQFS -- inquire fill-area style +PGQHS -- inquire hatching style +PGQID -- inquire current device identifier +PGQINF -- inquire PGPLOT general information +PGQITF -- inquire image transfer function +PGQLS -- inquire line style +PGQLW -- inquire line width +PGQNDT -- inquire number of available device types +PGQPOS -- inquire current pen position +PGQTBG -- inquire text background color index +PGQTXT -- find bounding box of text string +PGQVP -- inquire viewport size and position +PGQVSZ -- inquire size of view surface +PGQWIN -- inquire window boundary coordinates +PGRECT -- draw a rectangle, using fill-area attributes +PGRND -- find the smallest `round' number greater than x +PGRNGE -- choose axis limits +PGSAH -- set arrow-head style +PGSAVE -- save PGPLOT attributes +PGUNSA -- restore PGPLOT attributes +PGSCF -- set character font +PGSCH -- set character height +PGSCI -- set color index +PGSCIR -- set color index range +PGSCLP -- enable or disable clipping at edge of viewport +PGSCR -- set color representation +PGSCRL -- scroll window +PGSCRN -- set color representation by name +PGSFS -- set fill-area style +PGSHLS -- set color representation using HLS system +PGSHS -- set hatching style +PGSITF -- set image transfer function +PGSLCT -- select an open graphics device +PGSLS -- set line style +PGSLW -- set line width +PGSTBG -- set text background color index +PGSUBP -- subdivide view surface into panels +PGSVP -- set viewport (normalized device coordinates) +PGSWIN -- set window +PGTBOX -- draw frame and write (DD) HH MM SS.S labelling +PGTEXT -- write text (horizontal, left-justified) +PGTICK -- draw a single tick mark on an axis +PGUPDT -- update display +PGVECT -- vector map of a 2D data array, with blanking +PGVSIZ -- set viewport (inches) +PGVSTD -- set standard (default) viewport +PGWEDG -- annotate an image plot with a wedge +PGWNAD -- set window and adjust viewport to same aspect ratio +PGADVANCE -- non-standard alias for PGPAGE +PGBEGIN -- non-standard alias for PGBEG +PGCURSE -- non-standard alias for PGCURS +PGLABEL -- non-standard alias for PGLAB +PGMTEXT -- non-standard alias for PGMTXT +PGNCURSE -- non-standard alias for PGNCUR +PGPAPER -- non-standard alias for PGPAP +PGPOINT -- non-standard alias for PGPT +PGPTEXT -- non-standard alias for PGPTXT +PGVPORT -- non-standard alias for PGSVP +PGVSIZE -- non-standard alias for PGVSIZ +PGVSTAND -- non-standard alias for PGVSTD +PGWINDOW -- non-standard alias for PGSWIN + + +------------------------------------------------------------------------ +Module: PGARRO -- draw an arrow +------------------------------------------------------------------------ + + SUBROUTINE PGARRO (X1, Y1, X2, Y2) + REAL X1, Y1, X2, Y2 + +Draw an arrow from the point with world-coordinates (X1,Y1) to +(X2,Y2). The size of the arrowhead at (X2,Y2) is determined by +the current character size set by routine PGSCH. The default size +is 1/40th of the smaller of the width or height of the view surface. +The appearance of the arrowhead (shape and solid or open) is +controlled by routine PGSAH. + +Arguments: + X1, Y1 (input) : world coordinates of the tail of the arrow. + X2, Y2 (input) : world coordinates of the head of the arrow. + + +------------------------------------------------------------------------ +Module: PGASK -- control new page prompting +------------------------------------------------------------------------ + + SUBROUTINE PGASK (FLAG) + LOGICAL FLAG + +Change the ``prompt state'' of PGPLOT. If the prompt state is +ON, PGPAGE will type ``Type RETURN for next page:'' and will wait +for the user to type a carriage-return before starting a new page. +The initial prompt state (after the device has been opened) is ON +for interactive devices. Prompt state is always OFF for +non-interactive devices. + +Arguments: + FLAG (input) : if .TRUE., and if the device is an interactive + device, the prompt state will be set to ON. If + .FALSE., the prompt state will be set to OFF. + + +------------------------------------------------------------------------ +Module: PGAXIS -- draw an axis +------------------------------------------------------------------------ + + SUBROUTINE PGAXIS (OPT, X1, Y1, X2, Y2, V1, V2, STEP, NSUB, + : DMAJL, DMAJR, FMIN, DISP, ORIENT) + CHARACTER*(*) OPT + REAL X1, Y1, X2, Y2, V1, V2, STEP, DMAJL, DMAJR, FMIN, DISP + REAL ORIENT + INTEGER NSUB + +Draw a labelled graph axis from world-coordinate position (X1,Y1) to +(X2,Y2). + +Normally, this routine draws a standard LINEAR axis with equal +subdivisions. The quantity described by the axis runs from V1 to V2; +this may be, but need not be, the same as X or Y. + +If the 'L' option is specified, the routine draws a LOGARITHMIC axis. +In this case, the quantity described by the axis runs from 10**V1 to +10**V2. A logarithmic axis always has major, labeled, tick marks +spaced by one or more decades. If the major tick marks are spaced +by one decade (as specified by the STEP argument), then minor +tick marks are placed at 2, 3, .., 9 times each power of 10; +otherwise minor tick marks are spaced by one decade. If the axis +spans less than two decades, numeric labels are placed at 1, 2, and +5 times each power of ten. + +If the axis spans less than one decade, or if it spans many decades, +it is preferable to use a linear axis labeled with the logarithm of +the quantity of interest. + +Arguments: + OPT (input) : a string containing single-letter codes for + various options. The options currently + recognized are: + L : draw a logarithmic axis + N : write numeric labels + 1 : force decimal labelling, instead of automatic + choice (see PGNUMB). + 2 : force exponential labelling, instead of + automatic. + X1, Y1 (input) : world coordinates of one endpoint of the axis. + X2, Y2 (input) : world coordinates of the other endpoint of the axis. + V1 (input) : axis value at first endpoint. + V2 (input) : axis value at second endpoint. + STEP (input) : major tick marks are drawn at axis value 0.0 plus + or minus integer multiples of STEP. If STEP=0.0, + a value is chosen automatically. + NSUB (input) : minor tick marks are drawn to divide the major + divisions into NSUB equal subdivisions (ignored if + STEP=0.0). If NSUB <= 1, no minor tick marks are + drawn. NSUB is ignored for a logarithmic axis. + DMAJL (input) : length of major tick marks drawn to left of axis + (as seen looking from first endpoint to second), in + units of the character height. + DMAJR (input) : length of major tick marks drawn to right of axis, + in units of the character height. + FMIN (input) : length of minor tick marks, as fraction of major. + DISP (input) : displacement of baseline of tick labels to + right of axis, in units of the character height. + ORIENT (input) : orientation of label text, in degrees; angle between + baseline of text and direction of axis (0-360°). + + +------------------------------------------------------------------------ +Module: PGBAND -- read cursor position, with anchor +------------------------------------------------------------------------ + + INTEGER FUNCTION PGBAND (MODE, POSN, XREF, YREF, X, Y, CH) + INTEGER MODE, POSN + REAL XREF, YREF, X, Y + CHARACTER*(*) CH + +Read the cursor position and a character typed by the user. +The position is returned in world coordinates. PGBAND positions +the cursor at the position specified (if POSN=1), allows the user to +move the cursor using the mouse or arrow keys or whatever is available +on the device. When he has positioned the cursor, the user types a +single character on the keyboard; PGBAND then returns this +character and the new cursor position (in world coordinates). + +Some interactive devices offer a selection of cursor types, +implemented as thin lines that move with the cursor, but without +erasing underlying graphics. Of these types, some extend between +a stationary anchor-point at XREF,YREF, and the position of the +cursor, while others simply follow the cursor without changing shape +or size. The cursor type is specified with one of the following MODE +values. Cursor types that are not supported by a given device, are +treated as MODE=0. + +-- If MODE=0, the anchor point is ignored and the routine behaves +like PGCURS. +-- If MODE=1, a straight line is drawn joining the anchor point +and the cursor position. +-- If MODE=2, a hollow rectangle is extended as the cursor is moved, +with one vertex at the anchor point and the opposite vertex at the +current cursor position; the edges of the rectangle are horizontal +and vertical. +-- If MODE=3, two horizontal lines are extended across the width of +the display, one drawn through the anchor point and the other +through the moving cursor position. This could be used to select +a Y-axis range when one end of the range is known. +-- If MODE=4, two vertical lines are extended over the height of +the display, one drawn through the anchor point and the other +through the moving cursor position. This could be used to select an +X-axis range when one end of the range is known. +-- If MODE=5, a horizontal line is extended through the cursor +position over the width of the display. This could be used to select +an X-axis value such as the start of an X-axis range. The anchor point +is ignored. +-- If MODE=6, a vertical line is extended through the cursor +position over the height of the display. This could be used to select +a Y-axis value such as the start of a Y-axis range. The anchor point +is ignored. +-- If MODE=7, a cross-hair, centered on the cursor, is extended over +the width and height of the display. The anchor point is ignored. + +Returns: + PGBAND : 1 if the call was successful; 0 if the device + has no cursor or some other error occurs. +Arguments: + MODE (input) : display mode (0, 1, ..7: see above). + POSN (input) : if POSN=1, PGBAND attempts to place the cursor + at point (X,Y); if POSN=0, it leaves the cursor + at its current position. (On some devices this + request may be ignored.) + XREF (input) : the world x-coordinate of the anchor point. + YREF (input) : the world y-coordinate of the anchor point. + X (in/out) : the world x-coordinate of the cursor. + Y (in/out) : the world y-coordinate of the cursor. + CH (output) : the character typed by the user; if the device has + no cursor or if some other error occurs, the value + CHAR(0) [ASCII NUL character] is returned. + +Note: The cursor coordinates (X,Y) may be changed by PGBAND even if +the device has no cursor or if the user does not move the cursor. +Under these circumstances, the position returned in (X,Y) is that of +the pixel nearest to the requested position. + + +------------------------------------------------------------------------ +Module: PGBBUF -- begin batch of output (buffer) +------------------------------------------------------------------------ + + SUBROUTINE PGBBUF + +Begin saving graphical output commands in an internal buffer; the +commands are held until a matching PGEBUF call (or until the buffer +is emptied by PGUPDT). This can greatly improve the efficiency of +PGPLOT. PGBBUF increments an internal counter, while PGEBUF +decrements this counter and flushes the buffer to the output +device when the counter drops to zero. PGBBUF and PGEBUF calls +should always be paired. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGBEG -- open a graphics device +------------------------------------------------------------------------ + + INTEGER FUNCTION PGBEG (UNIT, FILE, NXSUB, NYSUB) + INTEGER UNIT + CHARACTER*(*) FILE + INTEGER NXSUB, NYSUB + +Note: new programs should use PGOPEN rather than PGBEG. PGOPEN +is retained for compatibility with existing programs. Unlike PGOPEN, +PGBEG closes any graphics devices that are already open, so it +cannot be used to open devices to be used in parallel. + +PGBEG opens a graphical device or file and prepares it for +subsequent plotting. A device must be opened with PGBEG or PGOPEN +before any other calls to PGPLOT subroutines for the device. + +If any device is already open for PGPLOT output, it is closed before +the new device is opened. + +Returns: + PGBEG : a status return value. A value of 1 indicates + successful completion, any other value indicates + an error. In the event of error a message is + written on the standard error unit. + To test the return value, call + PGBEG as a function, eg IER=PGBEG(...); note + that PGBEG must be declared INTEGER in the + calling program. Some Fortran compilers allow + you to use CALL PGBEG(...) and discard the + return value, but this is not standard Fortran. +Arguments: + UNIT (input) : this argument is ignored by PGBEG (use zero). + FILE (input) : the "device specification" for the plot device. + (For explanation, see description of PGOPEN.) + NXSUB (input) : the number of subdivisions of the view surface in + X (>0 or <0). + NYSUB (input) : the number of subdivisions of the view surface in + Y (>0). + PGPLOT puts NXSUB x NYSUB graphs on each plot + page or screen; when the view surface is sub- + divided in this way, PGPAGE moves to the next + panel, not the next physical page. If + NXSUB > 0, PGPLOT uses the panels in row + order; if <0, PGPLOT uses them in column order. + + +------------------------------------------------------------------------ +Module: PGBIN -- histogram of binned data +------------------------------------------------------------------------ + + SUBROUTINE PGBIN (NBIN, X, DATA, CENTER) + INTEGER NBIN + REAL X(*), DATA(*) + LOGICAL CENTER + +Plot a histogram of NBIN values with X(1..NBIN) values along +the ordinate, and DATA(1...NBIN) along the abscissa. Bin width is +spacing between X values. + +Arguments: + NBIN (input) : number of values. + X (input) : abscissae of bins. + DATA (input) : data values of bins. + CENTER (input) : if .TRUE., the X values denote the center of the + bin; if .FALSE., the X values denote the lower + edge (in X) of the bin. + + +------------------------------------------------------------------------ +Module: PGBOX -- draw labeled frame around viewport +------------------------------------------------------------------------ + + SUBROUTINE PGBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB) + CHARACTER*(*) XOPT, YOPT + REAL XTICK, YTICK + INTEGER NXSUB, NYSUB + +Annotate the viewport with frame, axes, numeric labels, etc. +PGBOX is called by on the user's behalf by PGENV, but may also be +called explicitly. + +Arguments: + XOPT (input) : string of options for X (horizontal) axis of + plot. Options are single letters, and may be in + any order (see below). + XTICK (input) : world coordinate interval between major tick marks + on X axis. If XTICK=0.0, the interval is chosen by + PGBOX, so that there will be at least 3 major tick + marks along the axis. + NXSUB (input) : the number of subintervals to divide the major + coordinate interval into. If XTICK=0.0 or NXSUB=0, + the number is chosen by PGBOX. + YOPT (input) : string of options for Y (vertical) axis of plot. + Coding is the same as for XOPT. + YTICK (input) : like XTICK for the Y axis. + NYSUB (input) : like NXSUB for the Y axis. + +Options (for parameters XOPT and YOPT): + A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical + line X=0). + B : draw bottom (X) or left (Y) edge of frame. + C : draw top (X) or right (Y) edge of frame. + G : draw Grid of vertical (X) or horizontal (Y) lines. + I : Invert the tick marks; ie draw them outside the viewport + instead of inside. + L : label axis Logarithmically (see below). + N : write Numeric labels in the conventional location below the + viewport (X) or to the left of the viewport (Y). + P : extend ("Project") major tick marks outside the box (ignored if + option I is specified). + M : write numeric labels in the unconventional location above the + viewport (X) or to the right of the viewport (Y). + T : draw major Tick marks at the major coordinate interval. + S : draw minor tick marks (Subticks). + V : orient numeric labels Vertically. This is only applicable to Y. + The default is to write Y-labels parallel to the axis. + 1 : force decimal labelling, instead of automatic choice (see PGNUMB). + 2 : force exponential labelling, instead of automatic. + +To get a complete frame, specify BC in both XOPT and YOPT. +Tick marks, if requested, are drawn on the axes or frame +or both, depending which are requested. If none of ABC is specified, +tick marks will not be drawn. When PGENV calls PGBOX, it sets both +XOPT and YOPT according to the value of its parameter AXIS: +-1: 'BC', 0: 'BCNST', 1: 'ABCNST', 2: 'ABCGNST'. + +For a logarithmic axis, the major tick interval is always 1.0. The +numeric label is 10**(x) where x is the world coordinate at the +tick mark. If subticks are requested, 8 subticks are drawn between +each major tick at equal logarithmic intervals. + +To label an axis with time (days, hours, minutes, seconds) or +angle (degrees, arcmin, arcsec), use routine PGTBOX. + + +------------------------------------------------------------------------ +Module: PGCIRC -- draw a circle, using fill-area attributes +------------------------------------------------------------------------ + + SUBROUTINE PGCIRC (XCENT, YCENT, RADIUS) + REAL XCENT, YCENT, RADIUS + +Draw a circle. The action of this routine depends +on the setting of the Fill-Area Style attribute. If Fill-Area Style +is SOLID (the default), the interior of the circle is solid-filled +using the current Color Index. If Fill-Area Style is HOLLOW, the +outline of the circle is drawn using the current line attributes +(color index, line-style, and line-width). + +Arguments: + XCENT (input) : world x-coordinate of the center of the circle. + YCENT (input) : world y-coordinate of the center of the circle. + RADIUS (input) : radius of circle (world coordinates). + + +------------------------------------------------------------------------ +Module: PGCLOS -- close the selected graphics device +------------------------------------------------------------------------ + + SUBROUTINE PGCLOS + +Close the currently selected graphics device. After the device has +been closed, either another open device must be selected with PGSLCT +or another device must be opened with PGOPEN before any further +plotting can be done. If the call to PGCLOS is omitted, some or all +of the plot may be lost. + +[This routine was added to PGPLOT in Version 5.1.0. Older programs +use PGEND instead.] + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGCONB -- contour map of a 2D data array, with blanking +------------------------------------------------------------------------ + + SUBROUTINE PGCONB (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR, + 1 BLANK) + INTEGER IDIM, JDIM, I1, I2, J1, J2, NC + REAL A(IDIM,JDIM), C(*), TR(6), BLANK + +Draw a contour map of an array. This routine is the same as PGCONS, +except that array elements that have the "magic value" defined by +argument BLANK are ignored, making gaps in the contour map. The +routine may be useful for data measured on most but not all of the +points of a grid. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1,I2 (input) : range of first index to be contoured (inclusive). + J1,J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of contour levels (in the same units as the + data in array A); dimension at least NC. + NC (input) : number of contour levels (less than or equal to + dimension of C). The absolute value of this + argument is used (for compatibility with PGCONT, + where the sign of NC is significant). + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + BLANK (input) : elements of array A that are exactly equal to + this value are ignored (blanked). + + +------------------------------------------------------------------------ +Module: PGCONF -- fill between two contours +------------------------------------------------------------------------ + + SUBROUTINE PGCONF (A, IDIM, JDIM, I1, I2, J1, J2, C1, C2, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + REAL A(IDIM,JDIM), C1, C2, TR(6) + +Shade the region between two contour levels of a function defined on +the nodes of a rectangular grid. The routine uses the current fill +attributes, hatching style (if appropriate), and color index. + +If you want to both shade between contours and draw the contour +lines, call this routine first (once for each pair of levels) and +then CALL PGCONT (or PGCONS) to draw the contour lines on top of the +shading. + +Note 1: This routine is not very efficient: it generates a polygon +fill command for each cell of the mesh that intersects the desired +area, rather than consolidating adjacent cells into a single polygon. + +Note 2: If both contours intersect all four edges of a particular +mesh cell, the program behaves badly and may consider some parts +of the cell to lie in more than one contour range. + +Note 3: If a contour crosses all four edges of a cell, this +routine may not generate the same contours as PGCONT or PGCONS +(these two routines may not agree either). Such cases are always +ambiguous and the routines use different approaches to resolving +the ambiguity. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1,I2 (input) : range of first index to be contoured (inclusive). + J1,J2 (input) : range of second index to be contoured (inclusive). + C1, C2 (input) : contour levels; note that C1 must be less than C2. + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + + +------------------------------------------------------------------------ +Module: PGCONL -- label contour map of a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGCONL (A, IDIM, JDIM, I1, I2, J1, J2, C, TR, + 1 LABEL, INTVAL, MININT) + INTEGER IDIM, JDIM, I1, J1, I2, J2, INTVAL, MININT + REAL A(IDIM,JDIM), C, TR(6) + CHARACTER*(*) LABEL + +Label a contour map drawn with routine PGCONT. Routine PGCONT should +be called first to draw the contour lines, then this routine should be +called to add the labels. Labels are written at intervals along the +contour lines, centered on the contour lines with lettering aligned +in the up-hill direction. Labels are opaque, so a part of the under- +lying contour line is obscured by the label. Labels use the current +attributes (character height, line width, color index, character +font). + +The first 9 arguments are the same as those supplied to PGCONT, and +should normally be identical to those used with PGCONT. Note that +only one contour level can be specified; tolabel more contours, call +PGCONL for each level. + +The Label is supplied as a character string in argument LABEL. + +The spacing of labels along the contour is specified by parameters +INTVAL and MININT. The routine follows the contour through the +array, counting the number of cells that the contour crosses. The +first label will be written in the MININT'th cell, and additional +labels will be written every INTVAL cells thereafter. A contour +that crosses less than MININT cells will not be labelled. Some +experimentation may be needed to get satisfactory results; a good +place to start is INTVAL=20, MININT=10. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1, I2 (input) : range of first index to be contoured (inclusive). + J1, J2 (input) : range of second index to be contoured (inclusive). + C (input) : the level of the contour to be labelled (one of the + values given to PGCONT). + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. + The world coordinates of the array point A(I,J) + are given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation or + shear. + LABEL (input) : character strings to be used to label the specified + contour. Leading and trailing blank spaces are + ignored. + INTVAL (input) : spacing along the contour between labels, in + grid cells. + MININT (input) : contours that cross less than MININT cells + will not be labelled. + + +------------------------------------------------------------------------ +Module: PGCONS -- contour map of a 2D data array (fast algorithm) +------------------------------------------------------------------------ + + SUBROUTINE PGCONS (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2, NC + REAL A(IDIM,JDIM), C(*), TR(6) + +Draw a contour map of an array. The map is truncated if +necessary at the boundaries of the viewport. Each contour line is +drawn with the current line attributes (color index, style, and +width). This routine, unlike PGCONT, does not draw each contour as a +continuous line, but draws the straight line segments composing each +contour in a random order. It is thus not suitable for use on pen +plotters, and it usually gives unsatisfactory results with dashed or +dotted lines. It is, however, faster than PGCONT, especially if +several contour levels are drawn with one call of PGCONS. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1,I2 (input) : range of first index to be contoured (inclusive). + J1,J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of contour levels (in the same units as the + data in array A); dimension at least NC. + NC (input) : number of contour levels (less than or equal to + dimension of C). The absolute value of this + argument is used (for compatibility with PGCONT, + where the sign of NC is significant). + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + + +------------------------------------------------------------------------ +Module: PGCONT -- contour map of a 2D data array (contour-following) +------------------------------------------------------------------------ + + SUBROUTINE PGCONT (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR) + INTEGER IDIM, JDIM, I1, J1, I2, J2, NC + REAL A(IDIM,JDIM), C(*), TR(6) + +Draw a contour map of an array. The map is truncated if +necessary at the boundaries of the viewport. Each contour line +is drawn with the current line attributes (color index, style, and +width); except that if argument NC is positive (see below), the line +style is set by PGCONT to 1 (solid) for positive contours or 2 +(dashed) for negative contours. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1, I2 (input) : range of first index to be contoured (inclusive). + J1, J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of NC contour levels; dimension at least NC. + NC (input) : +/- number of contour levels (less than or equal + to dimension of C). If NC is positive, it is the + number of contour levels, and the line-style is + chosen automatically as described above. If NC is + negative, it is minus the number of contour + levels, and the current setting of line-style is + used for all the contours. + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. + The world coordinates of the array point A(I,J) + are given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation or + shear. + + +------------------------------------------------------------------------ +Module: PGCONX -- contour map of a 2D data array (non rectangular) +------------------------------------------------------------------------ + + SUBROUTINE PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, PLOT) + INTEGER IDIM, JDIM, I1, J1, I2, J2, NC + REAL A(IDIM,JDIM), C(*) + EXTERNAL PLOT + +Draw a contour map of an array using a user-supplied plotting +routine. This routine should be used instead of PGCONT when the +data are defined on a non-rectangular grid. PGCONT permits only +a linear transformation between the (I,J) grid of the array +and the world coordinate system (x,y), but PGCONX permits any +transformation to be used, the transformation being defined by a +user-supplied subroutine. The nature of the contouring algorithm, +however, dictates that the transformation should maintain the +rectangular topology of the grid, although grid-points may be +allowed to coalesce. As an example of a deformed rectangular +grid, consider data given on the polar grid theta=0.1n(pi/2), +for n=0,1,...,10, and r=0.25m, for m=0,1,..,4. This grid +contains 55 points, of which 11 are coincident at the origin. +The input array for PGCONX should be dimensioned (11,5), and +data values should be provided for all 55 elements. PGCONX can +also be used for special applications in which the height of the +contour affects its appearance, e.g., stereoscopic views. + +The map is truncated if necessary at the boundaries of the viewport. +Each contour line is drawn with the current line attributes (color +index, style, and width); except that if argument NC is positive +(see below), the line style is set by PGCONX to 1 (solid) for +positive contours or 2 (dashed) for negative contours. Attributes +for the contour lines can also be set in the user-supplied +subroutine, if desired. + +Arguments: + A (input) : data array. + IDIM (input) : first dimension of A. + JDIM (input) : second dimension of A. + I1, I2 (input) : range of first index to be contoured (inclusive). + J1, J2 (input) : range of second index to be contoured (inclusive). + C (input) : array of NC contour levels; dimension at least NC. + NC (input) : +/- number of contour levels (less than or equal + to dimension of C). If NC is positive, it is the + number of contour levels, and the line-style is + chosen automatically as described above. If NC is + negative, it is minus the number of contour + levels, and the current setting of line-style is + used for all the contours. + PLOT (input) : the address (name) of a subroutine supplied by + the user, which will be called by PGCONX to do + the actual plotting. This must be declared + EXTERNAL in the program unit calling PGCONX. + +The subroutine PLOT will be called with four arguments: + CALL PLOT(VISBLE,X,Y,Z) +where X,Y (input) are real variables corresponding to +I,J indices of the array A. If VISBLE (input, integer) is 1, +PLOT should draw a visible line from the current pen +position to the world coordinate point corresponding to (X,Y); +if it is 0, it should move the pen to (X,Y). Z is the value +of the current contour level, and may be used by PLOT if desired. +Example: + SUBROUTINE PLOT (VISBLE,X,Y,Z) + REAL X, Y, Z, XWORLD, YWORLD + INTEGER VISBLE + XWORLD = X*COS(Y) ! this is the user-defined + YWORLD = X*SIN(Y) ! transformation + IF (VISBLE.EQ.0) THEN + CALL PGMOVE (XWORLD, YWORLD) + ELSE + CALL PGDRAW (XWORLD, YWORLD) + END IF + END + + +------------------------------------------------------------------------ +Module: PGCTAB -- install the color table to be used by PGIMAG +------------------------------------------------------------------------ + + SUBROUTINE PGCTAB(L, R, G, B, NC, CONTRA, BRIGHT) + INTEGER NC + REAL L(NC), R(NC), G(NC), B(NC), CONTRA, BRIGHT + +Use the given color table to change the color representations of +all color indexes marked for use by PGIMAG. To change which +color indexes are thus marked, call PGSCIR before calling PGCTAB +or PGIMAG. On devices that can change the color representations +of previously plotted graphics, PGCTAB will also change the colors +of existing graphics that were plotted with the marked color +indexes. This feature can then be combined with PGBAND to +interactively manipulate the displayed colors of data previously +plotted with PGIMAG. + +Limitations: + 1. Some devices do not propagate color representation changes + to previously drawn graphics. + 2. Some devices ignore requests to change color representations. + 3. The appearance of specific color representations on grey-scale + devices is device-dependent. + +Notes: + To reverse the sense of a color table, change the chosen contrast + and brightness to -CONTRA and 1-BRIGHT. + + In the following, the term 'color table' refers to the input + L,R,G,B arrays, whereas 'color ramp' refers to the resulting + ramp of colors that would be seen with PGWEDG. + +Arguments: + L (input) : An array of NC normalized ramp-intensity levels + corresponding to the RGB primary color intensities + in R(),G(),B(). Colors on the ramp are linearly + interpolated from neighbouring levels. + Levels must be sorted in increasing order. + 0.0 places a color at the beginning of the ramp. + 1.0 places a color at the end of the ramp. + Colors outside these limits are legal, but will + not be visible if CONTRA=1.0 and BRIGHT=0.5. + R (input) : An array of NC normalized red intensities. + G (input) : An array of NC normalized green intensities. + B (input) : An array of NC normalized blue intensities. + NC (input) : The number of color table entries. + CONTRA (input) : The contrast of the color ramp (normally 1.0). + Negative values reverse the direction of the ramp. + BRIGHT (input) : The brightness of the color ramp. This is normally + 0.5, but can sensibly hold any value between 0.0 + and 1.0. Values at or beyond the latter two + extremes, saturate the color ramp with the colors + of the respective end of the color table. + + +------------------------------------------------------------------------ +Module: PGCURS -- read cursor position +------------------------------------------------------------------------ + + INTEGER FUNCTION PGCURS (X, Y, CH) + REAL X, Y + CHARACTER*(*) CH + +Read the cursor position and a character typed by the user. +The position is returned in world coordinates. PGCURS positions +the cursor at the position specified, allows the user to move the +cursor using the joystick or arrow keys or whatever is available on +the device. When he has positioned the cursor, the user types a +single character on the keyboard; PGCURS then returns this +character and the new cursor position (in world coordinates). + +Returns: + PGCURS : 1 if the call was successful; 0 if the device + has no cursor or some other error occurs. +Arguments: + X (in/out) : the world x-coordinate of the cursor. + Y (in/out) : the world y-coordinate of the cursor. + CH (output) : the character typed by the user; if the device has + no cursor or if some other error occurs, the value + CHAR(0) [ASCII NUL character] is returned. + +Note: The cursor coordinates (X,Y) may be changed by PGCURS even if +the device has no cursor or if the user does not move the cursor. +Under these circumstances, the position returned in (X,Y) is that of +the pixel nearest to the requested position. + + +------------------------------------------------------------------------ +Module: PGDRAW -- draw a line from the current pen position to a point +------------------------------------------------------------------------ + + SUBROUTINE PGDRAW (X, Y) + REAL X, Y + +Draw a line from the current pen position to the point +with world-coordinates (X,Y). The line is clipped at the edge of the +current window. The new pen position is (X,Y) in world coordinates. + +Arguments: + X (input) : world x-coordinate of the end point of the line. + Y (input) : world y-coordinate of the end point of the line. + + +------------------------------------------------------------------------ +Module: PGEBUF -- end batch of output (buffer) +------------------------------------------------------------------------ + + SUBROUTINE PGEBUF + +A call to PGEBUF marks the end of a batch of graphical output begun +with the last call of PGBBUF. PGBBUF and PGEBUF calls should always +be paired. Each call to PGBBUF increments a counter, while each call +to PGEBUF decrements the counter. When the counter reaches 0, the +batch of output is written on the output device. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGEND -- close all open graphics devices +------------------------------------------------------------------------ + + SUBROUTINE PGEND + +Close and release any open graphics devices. All devices must be +closed by calling either PGCLOS (for each device) or PGEND before +the program terminates. If a device is not closed properly, some +or all of the graphical output may be lost. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGENV -- set window and viewport and draw labeled frame +------------------------------------------------------------------------ + + SUBROUTINE PGENV (XMIN, XMAX, YMIN, YMAX, JUST, AXIS) + REAL XMIN, XMAX, YMIN, YMAX + INTEGER JUST, AXIS + +Set PGPLOT "Plotter Environment". PGENV establishes the scaling +for subsequent calls to PGPT, PGLINE, etc. The plotter is +advanced to a new page or panel, clearing the screen if necessary. +If the "prompt state" is ON (see PGASK), confirmation +is requested from the user before clearing the screen. +If requested, a box, axes, labels, etc. are drawn according to +the setting of argument AXIS. + +Arguments: + XMIN (input) : the world x-coordinate at the bottom left corner + of the viewport. + XMAX (input) : the world x-coordinate at the top right corner + of the viewport (note XMAX may be less than XMIN). + YMIN (input) : the world y-coordinate at the bottom left corner + of the viewport. + YMAX (input) : the world y-coordinate at the top right corner + of the viewport (note YMAX may be less than YMIN). + JUST (input) : if JUST=1, the scales of the x and y axes (in + world coordinates per inch) will be equal, + otherwise they will be scaled independently. + AXIS (input) : controls the plotting of axes, tick marks, etc: + AXIS = -2 : draw no box, axes or labels; + AXIS = -1 : draw box only; + AXIS = 0 : draw box and label it with coordinates; + AXIS = 1 : same as AXIS=0, but also draw the + coordinate axes (X=0, Y=0); + AXIS = 2 : same as AXIS=1, but also draw grid lines + at major increments of the coordinates; + AXIS = 10 : draw box and label X-axis logarithmically; + AXIS = 20 : draw box and label Y-axis logarithmically; + AXIS = 30 : draw box and label both axes logarithmically. + +For other axis options, use routine PGBOX. PGENV can be persuaded to +call PGBOX with additional axis options by defining an environment +parameter PGPLOT_ENVOPT containing the required option codes. +Examples: + PGPLOT_ENVOPT=P ! draw Projecting tick marks + PGPLOT_ENVOPT=I ! Invert the tick marks + PGPLOT_ENVOPT=IV ! Invert tick marks and label y Vertically + + +------------------------------------------------------------------------ +Module: PGERAS -- erase all graphics from current page +------------------------------------------------------------------------ + + SUBROUTINE PGERAS + +Erase all graphics from the current page (or current panel, if +the view surface has been divided into panels with PGSUBP). + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGERR1 -- horizontal or vertical error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERR1 (DIR, X, Y, E, T) + INTEGER DIR + REAL X, Y, E + REAL T + +Plot a single error bar in the direction specified by DIR. +This routine draws an error bar only; to mark the data point at +the start of the error bar, an additional call to PGPT is required. +To plot many error bars, use PGERRB. + +Arguments: + DIR (input) : direction to plot the error bar relative to + the data point. + One-sided error bar: + DIR is 1 for +X (X to X+E); + 2 for +Y (Y to Y+E); + 3 for -X (X to X-E); + 4 for -Y (Y to Y-E). + Two-sided error bar: + DIR is 5 for +/-X (X-E to X+E); + 6 for +/-Y (Y-E to Y+E). + X (input) : world x-coordinate of the data. + Y (input) : world y-coordinate of the data. + E (input) : value of error bar distance to be added to the + data position in world coordinates. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + + +------------------------------------------------------------------------ +Module: PGERRB -- horizontal or vertical error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERRB (DIR, N, X, Y, E, T) + INTEGER DIR, N + REAL X(*), Y(*), E(*) + REAL T + +Plot error bars in the direction specified by DIR. +This routine draws an error bar only; to mark the data point at +the start of the error bar, an additional call to PGPT is required. + +Arguments: + DIR (input) : direction to plot the error bar relative to + the data point. + One-sided error bar: + DIR is 1 for +X (X to X+E); + 2 for +Y (Y to Y+E); + 3 for -X (X to X-E); + 4 for -Y (Y to Y-E). + Two-sided error bar: + DIR is 5 for +/-X (X-E to X+E); + 6 for +/-Y (Y-E to Y+E). + N (input) : number of error bars to plot. + X (input) : world x-coordinates of the data. + Y (input) : world y-coordinates of the data. + E (input) : value of error bar distance to be added to the + data position in world coordinates. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + +Note: the dimension of arrays X, Y, and E must be greater +than or equal to N. If N is 1, X, Y, and E may be scalar +variables, or expressions. + + +------------------------------------------------------------------------ +Module: PGERRX -- horizontal error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERRX (N, X1, X2, Y, T) + INTEGER N + REAL X1(*), X2(*), Y(*) + REAL T + +Plot horizontal error bars. +This routine draws an error bar only; to mark the data point in +the middle of the error bar, an additional call to PGPT or +PGERRY is required. + +Arguments: + N (input) : number of error bars to plot. + X1 (input) : world x-coordinates of lower end of the + error bars. + X2 (input) : world x-coordinates of upper end of the + error bars. + Y (input) : world y-coordinates of the data. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + +Note: the dimension of arrays X1, X2, and Y must be greater +than or equal to N. If N is 1, X1, X2, and Y may be scalar +variables, or expressions, eg: + CALL PGERRX(1,X-SIGMA,X+SIGMA,Y) + + +------------------------------------------------------------------------ +Module: PGERRY -- vertical error bar +------------------------------------------------------------------------ + + SUBROUTINE PGERRY (N, X, Y1, Y2, T) + INTEGER N + REAL X(*), Y1(*), Y2(*) + REAL T + +Plot vertical error bars. +This routine draws an error bar only; to mark the data point in +the middle of the error bar, an additional call to PGPT or +PGERRX is required. + +Arguments: + N (input) : number of error bars to plot. + X (input) : world x-coordinates of the data. + Y1 (input) : world y-coordinates of top end of the + error bars. + Y2 (input) : world y-coordinates of bottom end of the + error bars. + T (input) : length of terminals to be drawn at the ends + of the error bar, as a multiple of the default + length; if T = 0.0, no terminals will be drawn. + +Note: the dimension of arrays X, Y1, and Y2 must be greater +than or equal to N. If N is 1, X, Y1, and Y2 may be scalar +variables or expressions, eg: + CALL PGERRY(1,X,Y+SIGMA,Y-SIGMA) + + +------------------------------------------------------------------------ +Module: PGETXT -- erase text from graphics display +------------------------------------------------------------------------ + + SUBROUTINE PGETXT + +Some graphics terminals display text (the normal interactive dialog) +on the same screen as graphics. This routine erases the text from the +view surface without affecting the graphics. It does nothing on +devices which do not display text on the graphics screen, and on +devices which do not have this capability. + +Arguments: + None + + +------------------------------------------------------------------------ +Module: PGFUNT -- function defined by X = F(T), Y = G(T) +------------------------------------------------------------------------ + + SUBROUTINE PGFUNT (FX, FY, N, TMIN, TMAX, PGFLAG) + REAL FX, FY + EXTERNAL FX, FY + INTEGER N + REAL TMIN, TMAX + INTEGER PGFLAG + +Draw a curve defined by parametric equations X = FX(T), Y = FY(T). + +Arguments: + FX (external real function): supplied by the user, evaluates + X-coordinate. + FY (external real function): supplied by the user, evaluates + Y-coordinate. + N (input) : the number of points required to define the + curve. The functions FX and FY will each be + called N+1 times. + TMIN (input) : the minimum value for the parameter T. + TMAX (input) : the maximum value for the parameter T. + PGFLAG (input) : if PGFLAG = 1, the curve is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGFUNT to + start a new plot with automatic scaling. + +Note: The functions FX and FY must be declared EXTERNAL in the +Fortran program unit that calls PGFUNT. + + +------------------------------------------------------------------------ +Module: PGFUNX -- function defined by Y = F(X) +------------------------------------------------------------------------ + + SUBROUTINE PGFUNX (FY, N, XMIN, XMAX, PGFLAG) + REAL FY + EXTERNAL FY + INTEGER N + REAL XMIN, XMAX + INTEGER PGFLAG + +Draw a curve defined by the equation Y = FY(X), where FY is a +user-supplied subroutine. + +Arguments: + FY (external real function): supplied by the user, evaluates + Y value at a given X-coordinate. + N (input) : the number of points required to define the + curve. The function FY will be called N+1 times. + If PGFLAG=0 and N is greater than 1000, 1000 + will be used instead. If N is less than 1, + nothing will be drawn. + XMIN (input) : the minimum value of X. + XMAX (input) : the maximum value of X. + PGFLAG (input) : if PGFLAG = 1, the curve is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGFUNX to + start a new plot with X limits (XMIN, XMAX) + and automatic scaling in Y. + +Note: The function FY must be declared EXTERNAL in the Fortran +program unit that calls PGFUNX. It has one argument, the +x-coordinate at which the y value is required, e.g. + REAL FUNCTION FY(X) + REAL X + FY = ..... + END + + +------------------------------------------------------------------------ +Module: PGFUNY -- function defined by X = F(Y) +------------------------------------------------------------------------ + + SUBROUTINE PGFUNY (FX, N, YMIN, YMAX, PGFLAG) + REAL FX + EXTERNAL FX + INTEGER N + REAL YMIN, YMAX + INTEGER PGFLAG + +Draw a curve defined by the equation X = FX(Y), where FY is a +user-supplied subroutine. + +Arguments: + FX (external real function): supplied by the user, evaluates + X value at a given Y-coordinate. + N (input) : the number of points required to define the + curve. The function FX will be called N+1 times. + If PGFLAG=0 and N is greater than 1000, 1000 + will be used instead. If N is less than 1, + nothing will be drawn. + YMIN (input) : the minimum value of Y. + YMAX (input) : the maximum value of Y. + PGFLAG (input) : if PGFLAG = 1, the curve is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGFUNY to + start a new plot with Y limits (YMIN, YMAX) + and automatic scaling in X. + +Note: The function FX must be declared EXTERNAL in the Fortran +program unit that calls PGFUNY. It has one argument, the +y-coordinate at which the x value is required, e.g. + REAL FUNCTION FX(Y) + REAL Y + FX = ..... + END + + +------------------------------------------------------------------------ +Module: PGGRAY -- gray-scale map of a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGGRAY (A, IDIM, JDIM, I1, I2, J1, J2, + 1 FG, BG, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + REAL A(IDIM,JDIM), FG, BG, TR(6) + +Draw gray-scale map of an array in current window. The subsection +of the array A defined by indices (I1:I2, J1:J2) is mapped onto +the view surface world-coordinate system by the transformation +matrix TR. The resulting quadrilateral region is clipped at the edge +of the window and shaded with the shade at each point determined +by the corresponding array value. The shade is a number in the +range 0 to 1 obtained by linear interpolation between the background +level (BG) and the foreground level (FG), i.e., + + shade = [A(i,j) - BG] / [FG - BG] + +The background level BG can be either less than or greater than the +foreground level FG. Points in the array that are outside the range +BG to FG are assigned shade 0 or 1 as appropriate. + +PGGRAY uses two different algorithms, depending how many color +indices are available in the color index range specified for images. +(This range is set with routine PGSCIR, and the current or default +range can be queried by calling routine PGQCIR). + +If 16 or more color indices are available, PGGRAY first assigns +color representations to these color indices to give a linear ramp +between the background color (color index 0) and the foreground color +(color index 1), and then calls PGIMAG to draw the image using these +color indices. In this mode, the shaded region is "opaque": every +pixel is assigned a color. + +If less than 16 color indices are available, PGGRAY uses only +color index 1, and uses a "dithering" algorithm to fill in pixels, +with the shade (computed as above) determining the faction of pixels +that are filled. In this mode the shaded region is "transparent" and +allows previously-drawn graphics to show through. + +The transformation matrix TR is used to calculate the world +coordinates of the center of the "cell" that represents each +array element. The world coordinates of the center of the cell +corresponding to array element A(I,J) are given by: + + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + +Usually TR(3) and TR(5) are zero -- unless the coordinate +transformation involves a rotation or shear. The corners of the +quadrilateral region that is shaded by PGGRAY are given by +applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5). + +Arguments: + A (input) : the array to be plotted. + IDIM (input) : the first dimension of array A. + JDIM (input) : the second dimension of array A. + I1, I2 (input) : the inclusive range of the first index + (I) to be plotted. + J1, J2 (input) : the inclusive range of the second + index (J) to be plotted. + FG (input) : the array value which is to appear with the + foreground color (corresponding to color index 1). + BG (input) : the array value which is to appear with the + background color (corresponding to color index 0). + TR (input) : transformation matrix between array grid and + world coordinates. + + +------------------------------------------------------------------------ +Module: PGHI2D -- cross-sections through a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGHI2D (DATA, NXV, NYV, IX1, IX2, IY1, IY2, X, IOFF, + 1 BIAS, CENTER, YLIMS) + INTEGER NXV, NYV, IX1, IX2, IY1, IY2 + REAL DATA(NXV,NYV) + REAL X(IX2-IX1+1), YLIMS(IX2-IX1+1) + INTEGER IOFF + REAL BIAS + LOGICAL CENTER + +Plot a series of cross-sections through a 2D data array. +Each cross-section is plotted as a hidden line histogram. The plot +can be slanted to give a pseudo-3D effect - if this is done, the +call to PGENV may have to be changed to allow for the increased X +range that will be needed. + +Arguments: + DATA (input) : the data array to be plotted. + NXV (input) : the first dimension of DATA. + NYV (input) : the second dimension of DATA. + IX1 (input) + IX2 (input) + IY1 (input) + IY2 (input) : PGHI2D plots a subset of the input array DATA. + This subset is delimited in the first (x) + dimension by IX1 and IX2 and the 2nd (y) by IY1 + and IY2, inclusively. Note: IY2 < IY1 is + permitted, resulting in a plot with the + cross-sections plotted in reverse Y order. + However, IX2 must be => IX1. + X (input) : the abscissae of the bins to be plotted. That is, + X(1) should be the X value for DATA(IX1,IY1), and + X should have (IX2-IX1+1) elements. The program + has to assume that the X value for DATA(x,y) is + the same for all y. + IOFF (input) : an offset in array elements applied to successive + cross-sections to produce a slanted effect. A + plot with IOFF > 0 slants to the right, one with + IOFF < 0 slants left. + BIAS (input) : a bias value applied to each successive cross- + section in order to raise it above the previous + cross-section. This is in the same units as the + data. + CENTER (input) : if .true., the X values denote the center of the + bins; if .false. the X values denote the lower + edges (in X) of the bins. + YLIMS (input) : workspace. Should be an array of at least + (IX2-IX1+1) elements. + + +------------------------------------------------------------------------ +Module: PGHIST -- histogram of unbinned data +------------------------------------------------------------------------ + + SUBROUTINE PGHIST(N, DATA, DATMIN, DATMAX, NBIN, PGFLAG) + INTEGER N + REAL DATA(*) + REAL DATMIN, DATMAX + INTEGER NBIN, PGFLAG + +Draw a histogram of N values of a variable in array +DATA(1...N) in the range DATMIN to DATMAX using NBIN bins. Note +that array elements which fall exactly on the boundary between +two bins will be counted in the higher bin rather than the +lower one; and array elements whose value is less than DATMIN or +greater than or equal to DATMAX will not be counted at all. + +Arguments: + N (input) : the number of data values. + DATA (input) : the data values. Note: the dimension of array + DATA must be greater than or equal to N. The + first N elements of the array are used. + DATMIN (input) : the minimum data value for the histogram. + DATMAX (input) : the maximum data value for the histogram. + NBIN (input) : the number of bins to use: the range DATMIN to + DATMAX is divided into NBIN equal bins and + the number of DATA values in each bin is + determined by PGHIST. NBIN may not exceed 200. + PGFLAG (input) : if PGFLAG = 1, the histogram is plotted in the + current window and viewport; if PGFLAG = 0, + PGENV is called automatically by PGHIST to start + a new plot (the x-limits of the window will be + DATMIN and DATMAX; the y-limits will be chosen + automatically. + IF PGFLAG = 2,3 the histogram will be in the same + window and viewport but with a filled area style. + If pgflag=4,5 as for pgflag = 0,1, but simple + line drawn as for PGBIN + + + +------------------------------------------------------------------------ +Module: PGIDEN -- write username, date, and time at bottom of plot +------------------------------------------------------------------------ + + SUBROUTINE PGIDEN + +Write username, date, and time at bottom of plot. + +Arguments: none. + + +------------------------------------------------------------------------ +Module: PGIMAG -- color image from a 2D data array +------------------------------------------------------------------------ + + SUBROUTINE PGIMAG (A, IDIM, JDIM, I1, I2, J1, J2, + 1 A1, A2, TR) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + REAL A(IDIM,JDIM), A1, A2, TR(6) + +Draw a color image of an array in current window. The subsection +of the array A defined by indices (I1:I2, J1:J2) is mapped onto +the view surface world-coordinate system by the transformation +matrix TR. The resulting quadrilateral region is clipped at the edge +of the window. Each element of the array is represented in the image +by a small quadrilateral, which is filled with a color specified by +the corresponding array value. + +The subroutine uses color indices in the range C1 to C2, which can +be specified by calling PGSCIR before PGIMAG. The default values +for C1 and C2 are device-dependent; these values can be determined by +calling PGQCIR. Note that color representations should be assigned to +color indices C1 to C2 by calling PGSCR before calling PGIMAG. On some +devices (but not all), the color representation can be changed after +the call to PGIMAG by calling PGSCR again. + +Array values in the range A1 to A2 are mapped on to the range of +color indices C1 to C2, with array values <= A1 being given color +index C1 and values >= A2 being given color index C2. The mapping +function for intermediate array values can be specified by +calling routine PGSITF before PGIMAG; the default is linear. + +On devices which have no available color indices (C1 > C2), +PGIMAG will return without doing anything. On devices with only +one color index (C1=C2), all array values map to the same color +which is rather uninteresting. An image is always "opaque", +i.e., it obscures all graphical elements previously drawn in +the region. + +The transformation matrix TR is used to calculate the world +coordinates of the center of the "cell" that represents each +array element. The world coordinates of the center of the cell +corresponding to array element A(I,J) are given by: + + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + +Usually TR(3) and TR(5) are zero -- unless the coordinate +transformation involves a rotation or shear. The corners of the +quadrilateral region that is shaded by PGIMAG are given by +applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5). + +Arguments: + A (input) : the array to be plotted. + IDIM (input) : the first dimension of array A. + JDIM (input) : the second dimension of array A. + I1, I2 (input) : the inclusive range of the first index + (I) to be plotted. + J1, J2 (input) : the inclusive range of the second + index (J) to be plotted. + A1 (input) : the array value which is to appear with shade C1. + A2 (input) : the array value which is to appear with shade C2. + TR (input) : transformation matrix between array grid and + world coordinates. + + +------------------------------------------------------------------------ +Module: PGLAB -- write labels for x-axis, y-axis, and top of plot +------------------------------------------------------------------------ + + SUBROUTINE PGLAB (XLBL, YLBL, TOPLBL) + CHARACTER*(*) XLBL, YLBL, TOPLBL + +Write labels outside the viewport. This routine is a simple +interface to PGMTXT, which should be used if PGLAB is inadequate. + +Arguments: + XLBL (input) : a label for the x-axis (centered below the + viewport). + YLBL (input) : a label for the y-axis (centered to the left + of the viewport, drawn vertically). + TOPLBL (input) : a label for the entire plot (centered above the + viewport). + + +------------------------------------------------------------------------ +Module: PGLCUR -- draw a line using the cursor +------------------------------------------------------------------------ + + SUBROUTINE PGLCUR (MAXPT, NPT, X, Y) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + +Interactive routine for user to enter a polyline by use of +the cursor. Routine allows user to Add and Delete vertices; +vertices are joined by straight-line segments. + +Arguments: + MAXPT (input) : maximum number of points that may be accepted. + NPT (in/out) : number of points entered; should be zero on + first call. + X (in/out) : array of x-coordinates (dimension at least MAXPT). + Y (in/out) : array of y-coordinates (dimension at least MAXPT). + +Notes: + +(1) On return from the program, cursor points are returned in +the order they were entered. Routine may be (re-)called with points +already defined in X,Y (# in NPT), and they will be plotted +first, before editing. + +(2) User commands: the user types single-character commands +after positioning the cursor: the following are accepted: + A (Add) - add point at current cursor location. + D (Delete) - delete last-entered point. + X (eXit) - leave subroutine. + + +------------------------------------------------------------------------ +Module: PGLDEV -- list available device types on standard output +------------------------------------------------------------------------ + + SUBROUTINE PGLDEV + +Writes (to standard output) a list of all device types available in +the current PGPLOT installation. + +Arguments: none. + + +------------------------------------------------------------------------ +Module: PGLEN -- find length of a string in a variety of units +------------------------------------------------------------------------ + + SUBROUTINE PGLEN (UNITS, STRING, XL, YL) + REAL XL, YL + INTEGER UNITS + CHARACTER*(*) STRING + +Work out length of a string in x and y directions + +Input + UNITS : 0 => answer in normalized device coordinates + 1 => answer in inches + 2 => answer in mm + 3 => answer in absolute device coordinates (dots) + 4 => answer in world coordinates + 5 => answer as a fraction of the current viewport size + + STRING : String of interest +Output + XL : Length of string in x direction + YL : Length of string in y direction + + + +------------------------------------------------------------------------ +Module: PGLINE -- draw a polyline (curve defined by line-segments) +------------------------------------------------------------------------ + + SUBROUTINE PGLINE (N, XPTS, YPTS) + INTEGER N + REAL XPTS(*), YPTS(*) + +Primitive routine to draw a Polyline. A polyline is one or more +connected straight-line segments. The polyline is drawn using +the current setting of attributes color-index, line-style, and +line-width. The polyline is clipped at the edge of the window. + +Arguments: + N (input) : number of points defining the line; the line + consists of (N-1) straight-line segments. + N should be greater than 1 (if it is 1 or less, + nothing will be drawn). + XPTS (input) : world x-coordinates of the points. + YPTS (input) : world y-coordinates of the points. + +The dimension of arrays X and Y must be greater than or equal to N. +The "pen position" is changed to (X(N),Y(N)) in world coordinates +(if N > 1). + + +------------------------------------------------------------------------ +Module: PGMOVE -- move pen (change current pen position) +------------------------------------------------------------------------ + + SUBROUTINE PGMOVE (X, Y) + REAL X, Y + +Primitive routine to move the "pen" to the point with world +coordinates (X,Y). No line is drawn. + +Arguments: + X (input) : world x-coordinate of the new pen position. + Y (input) : world y-coordinate of the new pen position. + + +------------------------------------------------------------------------ +Module: PGMTXT -- write text at position relative to viewport +------------------------------------------------------------------------ + + SUBROUTINE PGMTXT (SIDE, DISP, COORD, FJUST, TEXT) + CHARACTER*(*) SIDE, TEXT + REAL DISP, COORD, FJUST + +Write text at a position specified relative to the viewport (outside +or inside). This routine is useful for annotating graphs. It is used +by routine PGLAB. The text is written using the current values of +attributes color-index, line-width, character-height, and +character-font. + +Arguments: + SIDE (input) : must include one of the characters 'B', 'L', 'T', + or 'R' signifying the Bottom, Left, Top, or Right + margin of the viewport. If it includes 'LV' or + 'RV', the string is written perpendicular to the + frame rather than parallel to it. + DISP (input) : the displacement of the character string from the + specified edge of the viewport, measured outwards + from the viewport in units of the character + height. Use a negative value to write inside the + viewport, a positive value to write outside. + COORD (input) : the location of the character string along the + specified edge of the viewport, as a fraction of + the length of the edge. + FJUST (input) : controls justification of the string parallel to + the specified edge of the viewport. If + FJUST = 0.0, the left-hand end of the string will + be placed at COORD; if JUST = 0.5, the center of + the string will be placed at COORD; if JUST = 1.0, + the right-hand end of the string will be placed at + at COORD. Other values between 0 and 1 give inter- + mediate placing, but they are not very useful. + TEXT (input) : the text string to be plotted. Trailing spaces are + ignored when justifying the string, but leading + spaces are significant. + + + +------------------------------------------------------------------------ +Module: PGNCUR -- mark a set of points using the cursor +------------------------------------------------------------------------ + + SUBROUTINE PGNCUR (MAXPT, NPT, X, Y, SYMBOL) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + INTEGER SYMBOL + +Interactive routine for user to enter data points by use of +the cursor. Routine allows user to Add and Delete points. The +points are returned in order of increasing x-coordinate, not in the +order they were entered. + +Arguments: + MAXPT (input) : maximum number of points that may be accepted. + NPT (in/out) : number of points entered; should be zero on + first call. + X (in/out) : array of x-coordinates. + Y (in/out) : array of y-coordinates. + SYMBOL (input) : code number of symbol to use for marking + entered points (see PGPT). + +Note (1): The dimension of arrays X and Y must be greater than or +equal to MAXPT. + +Note (2): On return from the program, cursor points are returned in +increasing order of X. Routine may be (re-)called with points +already defined in X,Y (number in NPT), and they will be plotted +first, before editing. + +Note (3): User commands: the user types single-character commands +after positioning the cursor: the following are accepted: +A (Add) - add point at current cursor location. +D (Delete) - delete nearest point to cursor. +X (eXit) - leave subroutine. + + +------------------------------------------------------------------------ +Module: PGNUMB -- convert a number into a plottable character string +------------------------------------------------------------------------ + + SUBROUTINE PGNUMB (MM, PP, FORM, STRING, NC) + INTEGER MM, PP, FORM + CHARACTER*(*) STRING + INTEGER NC + +This routine converts a number into a decimal character +representation. To avoid problems of floating-point roundoff, the +number must be provided as an integer (MM) multiplied by a power of 10 +(10**PP). The output string retains only significant digits of MM, +and will be in either integer format (123), decimal format (0.0123), +or exponential format (1.23x10**5). Standard escape sequences \u, \d +raise the exponent and \x is used for the multiplication sign. +This routine is used by PGBOX to create numeric labels for a plot. + +Formatting rules: + (a) Decimal notation (FORM=1): + - Trailing zeros to the right of the decimal sign are + omitted + - The decimal sign is omitted if there are no digits + to the right of it + - When the decimal sign is placed before the first digit + of the number, a zero is placed before the decimal sign + - The decimal sign is a period (.) + - No spaces are placed between digits (ie digits are not + grouped in threes as they should be) + - A leading minus (-) is added if the number is negative + (b) Exponential notation (FORM=2): + - The exponent is adjusted to put just one (non-zero) + digit before the decimal sign + - The mantissa is formatted as in (a), unless its value is + 1 in which case it and the multiplication sign are omitted + - If the power of 10 is not zero and the mantissa is not + zero, an exponent of the form \x10\u[-]nnn is appended, + where \x is a multiplication sign (cross), \u is an escape + sequence to raise the exponent, and as many digits nnn + are used as needed + (c) Automatic choice (FORM=0): + Decimal notation is used if the absolute value of the + number is less than 10000 or greater than or equal to + 0.01. Otherwise exponential notation is used. + +Arguments: + MM (input) + PP (input) : the value to be formatted is MM*10**PP. + FORM (input) : controls how the number is formatted: + FORM = 0 -- use either decimal or exponential + FORM = 1 -- use decimal notation + FORM = 2 -- use exponential notation + STRING (output) : the formatted character string, left justified. + If the length of STRING is insufficient, a single + asterisk is returned, and NC=1. + NC (output) : the number of characters used in STRING: + the string to be printed is STRING(1:NC). + + +------------------------------------------------------------------------ +Module: PGOLIN -- mark a set of points using the cursor +------------------------------------------------------------------------ + + SUBROUTINE PGOLIN (MAXPT, NPT, X, Y, SYMBOL) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + INTEGER SYMBOL + +Interactive routine for user to enter data points by use of +the cursor. Routine allows user to Add and Delete points. The +points are returned in the order that they were entered (unlike +PGNCUR). + +Arguments: + MAXPT (input) : maximum number of points that may be accepted. + NPT (in/out) : number of points entered; should be zero on + first call. + X (in/out) : array of x-coordinates. + Y (in/out) : array of y-coordinates. + SYMBOL (input) : code number of symbol to use for marking + entered points (see PGPT). + +Note (1): The dimension of arrays X and Y must be greater than or +equal to MAXPT. + +Note (2): On return from the program, cursor points are returned in +the order they were entered. Routine may be (re-)called with points +already defined in X,Y (number in NPT), and they will be plotted +first, before editing. + +Note (3): User commands: the user types single-character commands +after positioning the cursor: the following are accepted: +A (Add) - add point at current cursor location. +D (Delete) - delete the last point entered. +X (eXit) - leave subroutine. + + +------------------------------------------------------------------------ +Module: PGOPEN -- open a graphics device +------------------------------------------------------------------------ + + INTEGER FUNCTION PGOPEN (DEVICE) + CHARACTER*(*) DEVICE + +Open a graphics device for PGPLOT output. If the device is +opened successfully, it becomes the selected device to which +graphics output is directed until another device is selected +with PGSLCT or the device is closed with PGCLOS. + +The value returned by PGOPEN should be tested to ensure that +the device was opened successfully, e.g., + + ISTAT = PGOPEN('plot.ps/PS') + IF (ISTAT .LE. 0 ) STOP + +Note that PGOPEN must be declared INTEGER in the calling program. + +The DEVICE argument is a character constant or variable; its value +should be one of the following: + +(1) A complete device specification of the form 'device/type' or + 'file/type', where 'type' is one of the allowed PGPLOT device + types (installation-dependent) and 'device' or 'file' is the + name of a graphics device or disk file appropriate for this type. + The 'device' or 'file' may contain '/' characters; the final + '/' delimits the 'type'. If necessary to avoid ambiguity, + the 'device' part of the string may be enclosed in double + quotation marks. +(2) A device specification of the form '/type', where 'type' is one + of the allowed PGPLOT device types. PGPLOT supplies a default + file or device name appropriate for this device type. +(3) A device specification with '/type' omitted; in this case + the type is taken from the environment variable PGPLOT_TYPE, + if defined (e.g., setenv PGPLOT_TYPE PS). Because of possible + confusion with '/' in file-names, omitting the device type + in this way is not recommended. +(4) A blank string (' '); in this case, PGOPEN will use the value + of environment variable PGPLOT_DEV as the device specification, + or '/NULL' if the environment variable is undefined. +(5) A single question mark, with optional trailing spaces ('?'); in + this case, PGPLOT will prompt the user to supply the device + specification, with a prompt string of the form + 'Graphics device/type (? to see list, default XXX):' + where 'XXX' is the default (value of environment variable + PGPLOT_DEV). +(6) A non-blank string in which the first character is a question + mark (e.g., '?Device: '); in this case, PGPLOT will prompt the + user to supply the device specification, using the supplied + string as the prompt (without the leading question mark but + including any trailing spaces). + +In cases (5) and (6), the device specification is read from the +standard input. The user should respond to the prompt with a device +specification of the form (1), (2), or (3). If the user types a +question-mark in response to the prompt, a list of available device +types is displayed and the prompt is re-issued. If the user supplies +an invalid device specification, the prompt is re-issued. If the user +responds with an end-of-file character, e.g., ctrl-D in UNIX, program +execution is aborted; this avoids the possibility of an infinite +prompting loop. A programmer should avoid use of PGPLOT-prompting +if this behavior is not desirable. + +The device type is case-insensitive (e.g., '/ps' and '/PS' are +equivalent). The device or file name may be case-sensitive in some +operating systems. + +Examples of valid DEVICE arguments: + +(1) 'plot.ps/ps', 'dir/plot.ps/ps', '"dir/plot.ps"/ps', + 'user:[tjp.plots]plot.ps/PS' +(2) '/ps' (PGPLOT interprets this as 'pgplot.ps/ps') +(3) 'plot.ps' (if PGPLOT_TYPE is defined as 'ps', PGPLOT + interprets this as 'plot.ps/ps') +(4) ' ' (if PGPLOT_DEV is defined) +(5) '? ' +(6) '?Device specification for PGPLOT: ' + +[This routine was added to PGPLOT in Version 5.1.0. Older programs +use PGBEG instead.] + +Returns: + PGOPEN : returns either a positive value, the + identifier of the graphics device for use with + PGSLCT, or a 0 or negative value indicating an + error. In the event of error a message is + written on the standard error unit. +Arguments: + DEVICE (input) : the 'device specification' for the plot device + (see above). + + +------------------------------------------------------------------------ +Module: PGPAGE -- advance to new page +------------------------------------------------------------------------ + + SUBROUTINE PGPAGE + +Advance plotter to a new page or panel, clearing the screen if +necessary. If the "prompt state" is ON (see PGASK), confirmation is +requested from the user before clearing the screen. If the view +surface has been subdivided into panels with PGBEG or PGSUBP, then +PGPAGE advances to the next panel, and if the current panel is the +last on the page, PGPAGE clears the screen or starts a new sheet of +paper. PGPAGE does not change the PGPLOT window or the viewport +(in normalized device coordinates); but note that if the size of the +view-surface is changed externally (e.g., by a workstation window +manager) the size of the viewport is changed in proportion. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGPANL -- switch to a different panel on the view surface +------------------------------------------------------------------------ + + SUBROUTINE PGPANL(IX, IY) + INTEGER IX, IY + +Start plotting in a different panel. If the view surface has been +divided into panels by PGBEG or PGSUBP, this routine can be used to +move to a different panel. Note that PGPLOT does not remember what +viewport and window were in use in each panel; these should be reset +if necessary after calling PGPANL. Nor does PGPLOT clear the panel: +call PGERAS after calling PGPANL to do this. + +Arguments: + IX (input) : the horizontal index of the panel (in the range + 1 <= IX <= number of panels in horizontal + direction). + IY (input) : the vertical index of the panel (in the range + 1 <= IY <= number of panels in horizontal + direction). + + +------------------------------------------------------------------------ +Module: PGPAP -- change the size of the view surface +------------------------------------------------------------------------ + + SUBROUTINE PGPAP (WIDTH, ASPECT) + REAL WIDTH, ASPECT + +This routine changes the size of the view surface ("paper size") to a +specified width and aspect ratio (height/width), in so far as this is +possible on the specific device. It is always possible to obtain a +view surface smaller than the default size; on some devices (e.g., +printers that print on roll or fan-feed paper) it is possible to +obtain a view surface larger than the default. + +This routine should be called either immediately after PGBEG or +immediately before PGPAGE. The new size applies to all subsequent +images until the next call to PGPAP. + +Arguments: + WIDTH (input) : the requested width of the view surface in inches; + if WIDTH=0.0, PGPAP will obtain the largest view + surface available consistent with argument ASPECT. + (1 inch = 25.4 mm.) + ASPECT (input) : the aspect ratio (height/width) of the view + surface; e.g., ASPECT=1.0 gives a square view + surface, ASPECT=0.618 gives a horizontal + rectangle, ASPECT=1.618 gives a vertical rectangle. + + +------------------------------------------------------------------------ +Module: PGPIXL -- draw pixels +------------------------------------------------------------------------ + + SUBROUTINE PGPIXL (IA, IDIM, JDIM, I1, I2, J1, J2, + 1 X1, X2, Y1, Y2) + INTEGER IDIM, JDIM, I1, I2, J1, J2 + INTEGER IA(IDIM,JDIM) + REAL X1, X2, Y1, Y2 + +Draw lots of solid-filled (tiny) rectangles aligned with the +coordinate axes. Best performance is achieved when output is +directed to a pixel-oriented device and the rectangles coincide +with the pixels on the device. In other cases, pixel output is +emulated. + +The subsection of the array IA defined by indices (I1:I2, J1:J2) +is mapped onto world-coordinate rectangle defined by X1, X2, Y1 +and Y2. This rectangle is divided into (I2 - I1 + 1) * (J2 - J1 + 1) +small rectangles. Each of these small rectangles is solid-filled +with the color index specified by the corresponding element of +IA. + +On most devices, the output region is "opaque", i.e., it obscures +all graphical elements previously drawn in the region. But on +devices that do not have erase capability, the background shade +is "transparent" and allows previously-drawn graphics to show +through. + +Arguments: + IA (input) : the array to be plotted. + IDIM (input) : the first dimension of array A. + JDIM (input) : the second dimension of array A. + I1, I2 (input) : the inclusive range of the first index + (I) to be plotted. + J1, J2 (input) : the inclusive range of the second + index (J) to be plotted. + X1, Y1 (input) : world coordinates of one corner of the output + region + X2, Y2 (input) : world coordinates of the opposite corner of the + output region + + +------------------------------------------------------------------------ +Module: PGPNTS -- draw several graph markers, not all the same +------------------------------------------------------------------------ + + SUBROUTINE PGPNTS (N, X, Y, SYMBOL, NS) + INTEGER N, NS + REAL X(*), Y(*) + INTEGER SYMBOL(*) + +Draw Graph Markers. Unlike PGPT, this routine can draw a different +symbol at each point. The markers are drawn using the current values +of attributes color-index, line-width, and character-height +(character-font applies if the symbol number is >31). If the point +to be marked lies outside the window, no marker is drawn. The "pen +position" is changed to (XPTS(N),YPTS(N)) in world coordinates +(if N > 0). + +Arguments: + N (input) : number of points to mark. + X (input) : world x-coordinate of the points. + Y (input) : world y-coordinate of the points. + SYMBOL (input) : code number of the symbol to be plotted at each + point (see PGPT). + NS (input) : number of values in the SYMBOL array. If NS <= N, + then the first NS points are drawn using the value + of SYMBOL(I) at (X(I), Y(I)) and SYMBOL(1) for all + the values of (X(I), Y(I)) where I > NS. + +Note: the dimension of arrays X and Y must be greater than or equal +to N and the dimension of the array SYMBOL must be greater than or +equal to NS. If N is 1, X and Y may be scalars (constants or +variables). If NS is 1, then SYMBOL may be a scalar. If N is +less than 1, nothing is drawn. + + +------------------------------------------------------------------------ +Module: PGPOLY -- draw a polygon, using fill-area attributes +------------------------------------------------------------------------ + + SUBROUTINE PGPOLY (N, XPTS, YPTS) + INTEGER N + REAL XPTS(*), YPTS(*) + +Fill-area primitive routine: shade the interior of a closed +polygon in the current window. The action of this routine depends +on the setting of the Fill-Area Style attribute (see PGSFS). +The polygon is clipped at the edge of the +window. The pen position is changed to (XPTS(1),YPTS(1)) in world +coordinates (if N > 1). If the polygon is not convex, a point is +assumed to lie inside the polygon if a straight line drawn to +infinity intersects and odd number of the polygon's edges. + +Arguments: + N (input) : number of points defining the polygon; the + line consists of N straight-line segments, + joining points 1 to 2, 2 to 3,... N-1 to N, N to 1. + N should be greater than 2 (if it is 2 or less, + nothing will be drawn). + XPTS (input) : world x-coordinates of the vertices. + YPTS (input) : world y-coordinates of the vertices. + Note: the dimension of arrays XPTS and YPTS must be + greater than or equal to N. + + +------------------------------------------------------------------------ +Module: PGPT -- draw several graph markers +------------------------------------------------------------------------ + + SUBROUTINE PGPT (N, XPTS, YPTS, SYMBOL) + INTEGER N + REAL XPTS(*), YPTS(*) + INTEGER SYMBOL + +Primitive routine to draw Graph Markers (polymarker). The markers +are drawn using the current values of attributes color-index, +line-width, and character-height (character-font applies if the symbol +number is >31). If the point to be marked lies outside the window, +no marker is drawn. The "pen position" is changed to +(XPTS(N),YPTS(N)) in world coordinates (if N > 0). + +Arguments: + N (input) : number of points to mark. + XPTS (input) : world x-coordinates of the points. + YPTS (input) : world y-coordinates of the points. + SYMBOL (input) : code number of the symbol to be drawn at each + point: + -1, -2 : a single dot (diameter = current + line width). + -3..-31 : a regular polygon with ABS(SYMBOL) + edges (style set by current fill style). + 0..31 : standard marker symbols. + 32..127 : ASCII characters (in current font). + e.g. to use letter F as a marker, let + SYMBOL = ICHAR('F'). + > 127 : a Hershey symbol number. + +Note: the dimension of arrays X and Y must be greater than or equal +to N. If N is 1, X and Y may be scalars (constants or variables). If +N is less than 1, nothing is drawn. + + +------------------------------------------------------------------------ +Module: PGPT1 -- draw one graph marker +------------------------------------------------------------------------ + + SUBROUTINE PGPT1 (XPT, YPT, SYMBOL) + REAL XPT, YPT + INTEGER SYMBOL + +Primitive routine to draw a single Graph Marker at a specified point. +The marker is drawn using the current values of attributes +color-index, line-width, and character-height (character-font applies +if the symbol number is >31). If the point to be marked lies outside +the window, no marker is drawn. The "pen position" is changed to +(XPT,YPT) in world coordinates. + +To draw several markers with coordinates specified by X and Y +arrays, use routine PGPT. + +Arguments: + XPT (input) : world x-coordinate of the point. + YPT (input) : world y-coordinate of the point. + SYMBOL (input) : code number of the symbol to be drawn: + -1, -2 : a single dot (diameter = current + line width). + -3..-31 : a regular polygon with ABS(SYMBOL) + edges (style set by current fill style). + 0..31 : standard marker symbols. + 32..127 : ASCII characters (in current font). + e.g. to use letter F as a marker, let + SYMBOL = ICHAR('F'). + > 127 : a Hershey symbol number. + + +------------------------------------------------------------------------ +Module: PGPTXT -- write text at arbitrary position and angle +------------------------------------------------------------------------ + + SUBROUTINE PGPTXT (X, Y, ANGLE, FJUST, TEXT) + REAL X, Y, ANGLE, FJUST + CHARACTER*(*) TEXT + +Primitive routine for drawing text. The text may be drawn at any +angle with the horizontal, and may be centered or left- or right- +justified at a specified position. Routine PGTEXT provides a +simple interface to PGPTXT for horizontal strings. Text is drawn +using the current values of attributes color-index, line-width, +character-height, and character-font. Text is NOT subject to +clipping at the edge of the window. + +Arguments: + X (input) : world x-coordinate. + Y (input) : world y-coordinate. The string is drawn with the + baseline of all the characters passing through + point (X,Y); the positioning of the string along + this line is controlled by argument FJUST. + ANGLE (input) : angle, in degrees, that the baseline is to make + with the horizontal, increasing counter-clockwise + (0.0 is horizontal). + FJUST (input) : controls horizontal justification of the string. + If FJUST = 0.0, the string will be left-justified + at the point (X,Y); if FJUST = 0.5, it will be + centered, and if FJUST = 1.0, it will be right + justified. [Other values of FJUST give other + justifications.] + TEXT (input) : the character string to be plotted. + + +------------------------------------------------------------------------ +Module: PGQAH -- inquire arrow-head style +------------------------------------------------------------------------ + + SUBROUTINE PGQAH (FS, ANGLE, BARB) + INTEGER FS + REAL ANGLE, BARB + +Query the style to be used for arrowheads drawn with routine PGARRO. + +Argument: + FS (output) : FS = 1 => filled; FS = 2 => outline. + ANGLE (output) : the acute angle of the arrow point, in degrees. + BARB (output) : the fraction of the triangular arrow-head that + is cut away from the back. + + +------------------------------------------------------------------------ +Module: PGQCF -- inquire character font +------------------------------------------------------------------------ + + SUBROUTINE PGQCF (FONT) + INTEGER FONT + +Query the current Character Font (set by routine PGSCF). + +Argument: + FONT (output) : the current font number (in range 1-4). + + +------------------------------------------------------------------------ +Module: PGQCH -- inquire character height +------------------------------------------------------------------------ + + SUBROUTINE PGQCH (SIZE) + REAL SIZE + +Query the Character Size attribute (set by routine PGSCH). + +Argument: + SIZE (output) : current character size (dimensionless multiple of + the default size). + + +------------------------------------------------------------------------ +Module: PGQCI -- inquire color index +------------------------------------------------------------------------ + + SUBROUTINE PGQCI (CI) + INTEGER CI + +Query the Color Index attribute (set by routine PGSCI). + +Argument: + CI (output) : the current color index (in range 0-max). This is + the color index actually in use, and may differ + from the color index last requested by PGSCI if + that index is not available on the output device. + + +------------------------------------------------------------------------ +Module: PGQCIR -- inquire color index range +------------------------------------------------------------------------ + + SUBROUTINE PGQCIR(ICILO, ICIHI) + INTEGER ICILO, ICIHI + +Query the color index range to be used for producing images with +PGGRAY or PGIMAG, as set by routine PGSCIR or by device default. + +Arguments: + ICILO (output) : the lowest color index to use for images + ICIHI (output) : the highest color index to use for images + + +------------------------------------------------------------------------ +Module: PGQCLP -- inquire clipping status +------------------------------------------------------------------------ + + SUBROUTINE PGQCLP(STATE) + INTEGER STATE + +Query the current clipping status (set by routine PGSCLP). + +Argument: + STATE (output) : receives the clipping status (0 => disabled, + 1 => enabled). + + +------------------------------------------------------------------------ +Module: PGQCOL -- inquire color capability +------------------------------------------------------------------------ + + SUBROUTINE PGQCOL (CI1, CI2) + INTEGER CI1, CI2 + +Query the range of color indices available on the current device. + +Argument: + CI1 (output) : the minimum available color index. This will be + either 0 if the device can write in the + background color, or 1 if not. + CI2 (output) : the maximum available color index. This will be + 1 if the device has no color capability, or a + larger number (e.g., 3, 7, 15, 255). + + +------------------------------------------------------------------------ +Module: PGQCR -- inquire color representation +------------------------------------------------------------------------ + + SUBROUTINE PGQCR (CI, CR, CG, CB) + INTEGER CI + REAL CR, CG, CB + +Query the RGB colors associated with a color index. + +Arguments: + CI (input) : color index + CR (output) : red, green and blue intensities + CG (output) in the range 0.0 to 1.0 + CB (output) + + +------------------------------------------------------------------------ +Module: PGQCS -- inquire character height in a variety of units +------------------------------------------------------------------------ + + SUBROUTINE PGQCS(UNITS, XCH, YCH) + INTEGER UNITS + REAL XCH, YCH + +Return the current PGPLOT character height in a variety of units. +This routine provides facilities that are not available via PGQCH. +Use PGQCS if the character height is required in units other than +those used in PGSCH. + +The PGPLOT "character height" is a dimension that scales with the +size of the view surface and with the scale-factor specified with +routine PGSCH. The default value is 1/40th of the height or width +of the view surface (whichever is less); this value is then +multiplied by the scale-factor supplied with PGSCH. Note that it +is a nominal height only; the actual character size depends on the +font and is usually somewhat smaller. + +Arguments: + UNITS (input) : Used to specify the units of the output value: + UNITS = 0 : normalized device coordinates + UNITS = 1 : inches + UNITS = 2 : millimeters + UNITS = 3 : pixels + UNITS = 4 : world coordinates + Other values give an error message, and are + treated as 0. + XCH (output) : The character height for text written with a + vertical baseline. + YCH (output) : The character height for text written with + a horizontal baseline (the usual case). + +The character height is returned in both XCH and YCH. + +If UNITS=1 or UNITS=2, XCH and YCH both receive the same value. + +If UNITS=3, XCH receives the height in horizontal pixel units, and YCH +receives the height in vertical pixel units; on devices for which the +pixels are not square, XCH and YCH will be different. + +If UNITS=4, XCH receives the height in horizontal world coordinates +(as used for the x-axis), and YCH receives the height in vertical +world coordinates (as used for the y-axis). Unless special care has +been taken to achive equal world-coordinate scales on both axes, the +values of XCH and YCH will be different. + +If UNITS=0, XCH receives the character height as a fraction of the +horizontal dimension of the view surface, and YCH receives the +character height as a fraction of the vertical dimension of the view +surface. + + +------------------------------------------------------------------------ +Module: PGQDT -- inquire name of nth available device type +------------------------------------------------------------------------ + + SUBROUTINE PGQDT(N, TYPE, TLEN, DESCR, DLEN, INTER) + INTEGER N + CHARACTER*(*) TYPE, DESCR + INTEGER TLEN, DLEN, INTER + +Return the name of the Nth available device type as a character +string. The number of available types can be determined by calling +PGQNDT. If the value of N supplied is outside the range from 1 to +the number of available types, the routine returns DLEN=TLEN=0. + +Arguments: + N (input) : the number of the device type (1..maximum). + TYPE (output) : receives the character device-type code of the + Nth device type. The argument supplied should be + large enough for at least 8 characters. The first + character in the string is a '/' character. + TLEN (output) : receives the number of characters in TYPE, + excluding trailing blanks. + DESCR (output) : receives a description of the device type. The + argument supplied should be large enough for at + least 64 characters. + DLEN (output) : receives the number of characters in DESCR, + excluding trailing blanks. + INTER (output) : receives 1 if the device type is an interactive + one, 0 otherwise. + + +------------------------------------------------------------------------ +Module: PGQFS -- inquire fill-area style +------------------------------------------------------------------------ + + SUBROUTINE PGQFS (FS) + INTEGER FS + +Query the current Fill-Area Style attribute (set by routine +PGSFS). + +Argument: + FS (output) : the current fill-area style: + FS = 1 => solid (default) + FS = 2 => outline + FS = 3 => hatched + FS = 4 => cross-hatched + + +------------------------------------------------------------------------ +Module: PGQHS -- inquire hatching style +------------------------------------------------------------------------ + + SUBROUTINE PGQHS (ANGLE, SEPN, PHASE) + REAL ANGLE, SEPN, PHASE + +Query the style to be used hatching (fill area with fill-style 3). + +Arguments: + ANGLE (output) : the angle the hatch lines make with the + horizontal, in degrees, increasing + counterclockwise (this is an angle on the + view surface, not in world-coordinate space). + SEPN (output) : the spacing of the hatch lines. The unit spacing + is 1 percent of the smaller of the height or + width of the view surface. + PHASE (output) : a real number between 0 and 1; the hatch lines + are displaced by this fraction of SEPN from a + fixed reference. Adjacent regions hatched with the + same PHASE have contiguous hatch lines. + + +------------------------------------------------------------------------ +Module: PGQID -- inquire current device identifier +------------------------------------------------------------------------ + + SUBROUTINE PGQID (ID) + INTEGER ID + +This subroutine returns the identifier of the currently +selected device, or 0 if no device is selected. The identifier is +assigned when PGOPEN is called to open the device, and may be used +as an argument to PGSLCT. Each open device has a different +identifier. + +[This routine was added to PGPLOT in Version 5.1.0.] + +Argument: + ID (output) : the identifier of the current device, or 0 if + no device is currently selected. + + +------------------------------------------------------------------------ +Module: PGQINF -- inquire PGPLOT general information +------------------------------------------------------------------------ + + SUBROUTINE PGQINF (ITEM, VALUE, LENGTH) + CHARACTER*(*) ITEM, VALUE + INTEGER LENGTH + +This routine can be used to obtain miscellaneous information about +the PGPLOT environment. Input is a character string defining the +information required, and output is a character string containing the +requested information. + +The following item codes are accepted (note that the strings must +match exactly, except for case, but only the first 8 characters are +significant). For items marked *, PGPLOT must be in the OPEN state +for the inquiry to succeed. If the inquiry is unsuccessful, either +because the item code is not recognized or because the information +is not available, a question mark ('?') is returned. + + 'VERSION' - version of PGPLOT software in use. + 'STATE' - status of PGPLOT ('OPEN' if a graphics device + is open for output, 'CLOSED' otherwise). + 'USER' - the username associated with the calling program. + 'NOW' - current date and time (e.g., '17-FEB-1986 10:04'). + 'DEVICE' * - current PGPLOT device or file. + 'FILE' * - current PGPLOT device or file. + 'TYPE' * - device-type of the current PGPLOT device. + 'DEV/TYPE' * - current PGPLOT device and type, in a form which + is acceptable as an argument for PGBEG. + 'HARDCOPY' * - is the current device a hardcopy device? ('YES' or + 'NO'). + 'TERMINAL' * - is the current device the user's interactive + terminal? ('YES' or 'NO'). + 'CURSOR' * - does the current device have a graphics cursor? + ('YES' or 'NO'). + 'SCROLL' * - does current device have rectangle-scroll + capability ('YES' or 'NO'); see PGSCRL. + +Arguments: + ITEM (input) : character string defining the information to + be returned; see above for a list of possible + values. + VALUE (output) : returns a character-string containing the + requested information, truncated to the length + of the supplied string or padded on the right with + spaces if necessary. + LENGTH (output): the number of characters returned in VALUE + (excluding trailing blanks). + + +------------------------------------------------------------------------ +Module: PGQITF -- inquire image transfer function +------------------------------------------------------------------------ + + SUBROUTINE PGQITF (ITF) + INTEGER ITF + +Return the Image Transfer Function as set by default or by a previous +call to PGSITF. The Image Transfer Function is used by routines +PGIMAG, PGGRAY, and PGWEDG. + +Argument: + ITF (output) : type of transfer function (see PGSITF) + + +------------------------------------------------------------------------ +Module: PGQLS -- inquire line style +------------------------------------------------------------------------ + + SUBROUTINE PGQLS (LS) + INTEGER LS + +Query the current Line Style attribute (set by routine PGSLS). + +Argument: + LS (output) : the current line-style attribute (in range 1-5). + + +------------------------------------------------------------------------ +Module: PGQLW -- inquire line width +------------------------------------------------------------------------ + + SUBROUTINE PGQLW (LW) + INTEGER LW + +Query the current Line-Width attribute (set by routine PGSLW). + +Argument: + LW (output) : the line-width (in range 1-201). + + +------------------------------------------------------------------------ +Module: PGQNDT -- inquire number of available device types +------------------------------------------------------------------------ + + SUBROUTINE PGQNDT(N) + INTEGER N + +Return the number of available device types. This routine is +usually used in conjunction with PGQDT to get a list of the +available device types. + +Arguments: + N (output) : the number of available device types. + + +------------------------------------------------------------------------ +Module: PGQPOS -- inquire current pen position +------------------------------------------------------------------------ + + SUBROUTINE PGQPOS (X, Y) + REAL X, Y + +Query the current "pen" position in world C coordinates (X,Y). + +Arguments: + X (output) : world x-coordinate of the pen position. + Y (output) : world y-coordinate of the pen position. + + +------------------------------------------------------------------------ +Module: PGQTBG -- inquire text background color index +------------------------------------------------------------------------ + + SUBROUTINE PGQTBG (TBCI) + INTEGER TBCI + +Query the current Text Background Color Index (set by routine +PGSTBG). + +Argument: + TBCI (output) : receives the current text background color index. + + +------------------------------------------------------------------------ +Module: PGQTXT -- find bounding box of text string +------------------------------------------------------------------------ + + SUBROUTINE PGQTXT (X, Y, ANGLE, FJUST, TEXT, XBOX, YBOX) + REAL X, Y, ANGLE, FJUST + CHARACTER*(*) TEXT + REAL XBOX(4), YBOX(4) + +This routine returns a bounding box for a text string. Instead +of drawing the string as routine PGPTXT does, it returns in XBOX +and YBOX the coordinates of the corners of a rectangle parallel +to the string baseline that just encloses the string. The four +corners are in the order: lower left, upper left, upper right, +lower right (where left and right refer to the first and last +characters in the string). + +If the string is blank or contains no drawable characters, all +four elements of XBOX and YBOX are assigned the starting point +of the string, (X,Y). + +Arguments: + X, Y, ANGLE, FJUST, TEXT (input) : these arguments are the same as + the corrresponding arguments in PGPTXT. + XBOX, YBOX (output) : arrays of dimension 4; on output, they + contain the world coordinates of the bounding + box in (XBOX(1), YBOX(1)), ..., (XBOX(4), YBOX(4)). + + +------------------------------------------------------------------------ +Module: PGQVP -- inquire viewport size and position +------------------------------------------------------------------------ + + SUBROUTINE PGQVP (UNITS, X1, X2, Y1, Y2) + INTEGER UNITS + REAL X1, X2, Y1, Y2 + +Inquiry routine to determine the current viewport setting. +The values returned may be normalized device coordinates, inches, mm, +or pixels, depending on the value of the input parameter CFLAG. + +Arguments: + UNITS (input) : used to specify the units of the output parameters: + UNITS = 0 : normalized device coordinates + UNITS = 1 : inches + UNITS = 2 : millimeters + UNITS = 3 : pixels + Other values give an error message, and are + treated as 0. + X1 (output) : the x-coordinate of the bottom left corner of the + viewport. + X2 (output) : the x-coordinate of the top right corner of the + viewport. + Y1 (output) : the y-coordinate of the bottom left corner of the + viewport. + Y2 (output) : the y-coordinate of the top right corner of the + viewport. + + +------------------------------------------------------------------------ +Module: PGQVSZ -- inquire size of view surface +------------------------------------------------------------------------ + + SUBROUTINE PGQVSZ (UNITS, X1, X2, Y1, Y2) + INTEGER UNITS + REAL X1, X2, Y1, Y2 + +This routine returns the dimensions of the view surface (the maximum +plottable area) of the currently selected graphics device, in +a variety of units. The size of the view surface is device-dependent +and is established when the graphics device is opened. On some +devices, it can be changed by calling PGPAP before starting a new +page with PGPAGE. On some devices, the size can be changed (e.g., +by a workstation window manager) outside PGPLOT, and PGPLOT detects +the change when PGPAGE is used. Call this routine after PGPAGE to +find the current size. + +Note 1: the width and the height of the view surface in normalized +device coordinates are both always equal to 1.0. + +Note 2: when the device is divided into panels (see PGSUBP), the +view surface is a single panel. + +Arguments: + UNITS (input) : 0,1,2,3 for output in normalized device coords, + inches, mm, or device units (pixels) + X1 (output) : always returns 0.0 + X2 (output) : width of view surface + Y1 (output) : always returns 0.0 + Y2 (output) : height of view surface + + +------------------------------------------------------------------------ +Module: PGQWIN -- inquire window boundary coordinates +------------------------------------------------------------------------ + + SUBROUTINE PGQWIN (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +Inquiry routine to determine the current window setting. +The values returned are world coordinates. + +Arguments: + X1 (output) : the x-coordinate of the bottom left corner + of the window. + X2 (output) : the x-coordinate of the top right corner + of the window. + Y1 (output) : the y-coordinate of the bottom left corner + of the window. + Y2 (output) : the y-coordinate of the top right corner + of the window. + + +------------------------------------------------------------------------ +Module: PGRECT -- draw a rectangle, using fill-area attributes +------------------------------------------------------------------------ + + SUBROUTINE PGRECT (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +This routine can be used instead of PGPOLY for the special case of +drawing a rectangle aligned with the coordinate axes; only two +vertices need be specified instead of four. On most devices, it is +faster to use PGRECT than PGPOLY for drawing rectangles. The +rectangle has vertices at (X1,Y1), (X1,Y2), (X2,Y2), and (X2,Y1). + +Arguments: + X1, X2 (input) : the horizontal range of the rectangle. + Y1, Y2 (input) : the vertical range of the rectangle. + + +------------------------------------------------------------------------ +Module: PGRND -- find the smallest `round' number greater than x +------------------------------------------------------------------------ + + REAL FUNCTION PGRND (X, NSUB) + REAL X + INTEGER NSUB + +Routine to find the smallest "round" number larger than x, a +"round" number being 1, 2 or 5 times a power of 10. If X is negative, +PGRND(X) = -PGRND(ABS(X)). eg PGRND(8.7) = 10.0, +PGRND(-0.4) = -0.5. If X is zero, the value returned is zero. +This routine is used by PGBOX for choosing tick intervals. + +Returns: + PGRND : the "round" number. +Arguments: + X (input) : the number to be rounded. + NSUB (output) : a suitable number of subdivisions for + subdividing the "nice" number: 2 or 5. + + +------------------------------------------------------------------------ +Module: PGRNGE -- choose axis limits +------------------------------------------------------------------------ + + SUBROUTINE PGRNGE (X1, X2, XLO, XHI) + REAL X1, X2, XLO, XHI + +Choose plotting limits XLO and XHI which encompass the data +range X1 to X2. + +Arguments: + X1, X2 (input) : the data range (X1= X2). + + +------------------------------------------------------------------------ +Module: PGSAH -- set arrow-head style +------------------------------------------------------------------------ + + SUBROUTINE PGSAH (FS, ANGLE, BARB) + INTEGER FS + REAL ANGLE, BARB + +Set the style to be used for arrowheads drawn with routine PGARRO. + +Argument: + FS (input) : FS = 1 => filled; FS = 2 => outline. + Other values are treated as 2. Default 1. + ANGLE (input) : the acute angle of the arrow point, in degrees; + angles in the range 20.0 to 90.0 give reasonable + results. Default 45.0. + BARB (input) : the fraction of the triangular arrow-head that + is cut away from the back. 0.0 gives a triangular + wedge arrow-head; 1.0 gives an open >. Values 0.3 + to 0.7 give reasonable results. Default 0.3. + + +------------------------------------------------------------------------ +Module: PGSAVE -- save PGPLOT attributes +------------------------------------------------------------------------ + + SUBROUTINE PGSAVE + +This routine saves the current PGPLOT attributes in a private storage +area. They can be restored by calling PGUNSA (unsave). Attributes +saved are: character font, character height, color index, fill-area +style, line style, line width, pen position, arrow-head style, +hatching style, and clipping state. Color representation is not saved. + +Calls to PGSAVE and PGUNSA should always be paired. Up to 20 copies +of the attributes may be saved. PGUNSA always retrieves the last-saved +values (last-in first-out stack). + +Note that when multiple devices are in use, PGUNSA retrieves the +values saved by the last PGSAVE call, even if they were for a +different device. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGUNSA -- restore PGPLOT attributes +------------------------------------------------------------------------ + + ENTRY PGUNSA + +This routine restores the PGPLOT attributes saved in the last call to +PGSAVE. Usage: CALL PGUNSA (no arguments). See PGSAVE. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGSCF -- set character font +------------------------------------------------------------------------ + + SUBROUTINE PGSCF (FONT) + INTEGER FONT + +Set the Character Font for subsequent text plotting. Four different +fonts are available: + 1: (default) a simple single-stroke font ("normal" font) + 2: roman font + 3: italic font + 4: script font +This call determines which font is in effect at the beginning of +each text string. The font can be changed (temporarily) within a text +string by using the escape sequences \fn, \fr, \fi, and \fs for fonts +1, 2, 3, and 4, respectively. + +Argument: + FONT (input) : the font number to be used for subsequent text + plotting (in range 1-4). + + +------------------------------------------------------------------------ +Module: PGSCH -- set character height +------------------------------------------------------------------------ + + SUBROUTINE PGSCH (SIZE) + REAL SIZE + +Set the character size attribute. The size affects all text and graph +markers drawn later in the program. The default character size is +1.0, corresponding to a character height about 1/40 the height of +the view surface. Changing the character size also scales the length +of tick marks drawn by PGBOX and terminals drawn by PGERRX and PGERRY. + +Argument: + SIZE (input) : new character size (dimensionless multiple of + the default size). + + +------------------------------------------------------------------------ +Module: PGSCI -- set color index +------------------------------------------------------------------------ + + SUBROUTINE PGSCI (CI) + INTEGER CI + +Set the Color Index for subsequent plotting, if the output device +permits this. The default color index is 1, usually white on a black +background for video displays or black on a white background for +printer plots. The color index is an integer in the range 0 to a +device-dependent maximum. Color index 0 corresponds to the background +color; lines may be "erased" by overwriting them with color index 0 +(if the device permits this). + +If the requested color index is not available on the selected device, +color index 1 will be substituted. + +The assignment of colors to color indices can be changed with +subroutine PGSCR (set color representation). Color indices 0-15 +have predefined color representations (see the PGPLOT manual), but +these may be changed with PGSCR. Color indices above 15 have no +predefined representations: if these indices are used, PGSCR must +be called to define the representation. + +Argument: + CI (input) : the color index to be used for subsequent plotting + on the current device (in range 0-max). If the + index exceeds the device-dependent maximum, the + default color index (1) is used. + + +------------------------------------------------------------------------ +Module: PGSCIR -- set color index range +------------------------------------------------------------------------ + + SUBROUTINE PGSCIR(ICILO, ICIHI) + INTEGER ICILO, ICIHI + +Set the color index range to be used for producing images with +PGGRAY or PGIMAG. If the range is not all within the range supported +by the device, a smaller range will be used. The number of +different colors available for images is ICIHI-ICILO+1. + +Arguments: + ICILO (input) : the lowest color index to use for images + ICIHI (input) : the highest color index to use for images + + +------------------------------------------------------------------------ +Module: PGSCLP -- enable or disable clipping at edge of viewport +------------------------------------------------------------------------ + + SUBROUTINE PGSCLP(STATE) + INTEGER STATE + +Normally all PGPLOT primitives except text are ``clipped'' at the +edge of the viewport: parts of the primitives that lie outside +the viewport are not drawn. If clipping is disabled by calling this +routine, primitives are visible wherever they lie on the view +surface. The default (clipping enabled) is appropriate for almost +all applications. + +Argument: + STATE (input) : 0 to disable clipping, or 1 to enable clipping. + +25-Feb-1997 [TJP] - new routine. + + +------------------------------------------------------------------------ +Module: PGSCR -- set color representation +------------------------------------------------------------------------ + + SUBROUTINE PGSCR (CI, CR, CG, CB) + INTEGER CI + REAL CR, CG, CB + +Set color representation: i.e., define the color to be +associated with a color index. Ignored for devices which do not +support variable color or intensity. Color indices 0-15 +have predefined color representations (see the PGPLOT manual), but +these may be changed with PGSCR. Color indices 16-maximum have no +predefined representations: if these indices are used, PGSCR must +be called to define the representation. On monochrome output +devices (e.g. VT125 terminals with monochrome monitors), the +monochrome intensity is computed from the specified Red, Green, Blue +intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television +systems, NTSC encoding. Note that most devices do not have an +infinite range of colors or monochrome intensities available; +the nearest available color is used. Examples: for black, +set CR=CG=CB=0.0; for white, set CR=CG=CB=1.0; for medium gray, +set CR=CG=CB=0.5; for medium yellow, set CR=CG=0.5, CB=0.0. + +Argument: + CI (input) : the color index to be defined, in the range 0-max. + If the color index greater than the device + maximum is specified, the call is ignored. Color + index 0 applies to the background color. + CR (input) : red, green, and blue intensities, + CG (input) in range 0.0 to 1.0. + CB (input) + + +------------------------------------------------------------------------ +Module: PGSCRL -- scroll window +------------------------------------------------------------------------ + + SUBROUTINE PGSCRL (DX, DY) + REAL DX, DY + +This routine moves the window in world-coordinate space while +leaving the viewport unchanged. On devices that have the +capability, the pixels within the viewport are scrolled +horizontally, vertically or both in such a way that graphics +previously drawn in the window are shifted so that their world +coordinates are unchanged. + +If the old window coordinate range was (X1, X2, Y1, Y2), the new +coordinate range will be approximately (X1+DX, X2+DX, Y1+DY, Y2+DY). +The size and scale of the window are unchanged. + +Thee window can only be shifted by a whole number of pixels +(device coordinates). If DX and DY do not correspond to integral +numbers of pixels, the shift will be slightly different from that +requested. The new window-coordinate range, and hence the exact +amount of the shift, can be determined by calling PGQWIN after this +routine. + +Pixels that are moved out of the viewport by this operation are +lost completely; they cannot be recovered by scrolling back. +Pixels that are ``scrolled into'' the viewport are filled with +the background color (color index 0). + +If the absolute value of DX is bigger than the width of the window, +or the aboslute value of DY is bigger than the height of the window, +the effect will be the same as zeroing all the pixels in the +viewport. + +Not all devices have the capability to support this routine. +It is only available on some interactive devices that have discrete +pixels. To determine whether the current device has scroll capability, +call PGQINF. + +Arguments: + DX (input) : distance (in world coordinates) to shift the + window horizontally (positive shifts window to the + right and scrolls to the left). + DY (input) : distance (in world coordinates) to shift the + window vertically (positive shifts window up and + scrolls down). + + +------------------------------------------------------------------------ +Module: PGSCRN -- set color representation by name +------------------------------------------------------------------------ + + SUBROUTINE PGSCRN(CI, NAME, IER) + INTEGER CI + CHARACTER*(*) NAME + INTEGER IER + +Set color representation: i.e., define the color to be +associated with a color index. Ignored for devices which do not +support variable color or intensity. This is an alternative to +routine PGSCR. The color representation is defined by name instead +of (R,G,B) components. + +Color names are defined in an external file which is read the first +time that PGSCRN is called. The name of the external file is +found as follows: +1. if environment variable (logical name) PGPLOT_RGB is defined, + its value is used as the file name; +2. otherwise, if environment variable PGPLOT_DIR is defined, a + file "rgb.txt" in the directory named by this environment + variable is used; +3. otherwise, file "rgb.txt" in the current directory is used. +If all of these fail to find a file, an error is reported and +the routine does nothing. + +Each line of the file +defines one color, with four blank- or tab-separated fields per +line. The first three fields are the R, G, B components, which +are integers in the range 0 (zero intensity) to 255 (maximum +intensity). The fourth field is the color name. The color name +may include embedded blanks. Example: + +255 0 0 red +255 105 180 hot pink +255 255 255 white + 0 0 0 black + +Arguments: + CI (input) : the color index to be defined, in the range 0-max. + If the color index greater than the device + maximum is specified, the call is ignored. Color + index 0 applies to the background color. + NAME (input) : the name of the color to be associated with + this color index. This name must be in the + external file. The names are not case-sensitive. + If the color is not listed in the file, the + color representation is not changed. + IER (output) : returns 0 if the routine was successful, 1 + if an error occurred (either the external file + could not be read, or the requested color was + not defined in the file). + + +------------------------------------------------------------------------ +Module: PGSFS -- set fill-area style +------------------------------------------------------------------------ + + SUBROUTINE PGSFS (FS) + INTEGER FS + +Set the Fill-Area Style attribute for subsequent area-fill by +PGPOLY, PGRECT, or PGCIRC. Four different styles are available: +solid (fill polygon with solid color of the current color-index), +outline (draw outline of polygon only, using current line attributes), +hatched (shade interior of polygon with parallel lines, using +current line attributes), or cross-hatched. The orientation and +spacing of hatch lines can be specified with routine PGSHS (set +hatch style). + +Argument: + FS (input) : the fill-area style to be used for subsequent + plotting: + FS = 1 => solid (default) + FS = 2 => outline + FS = 3 => hatched + FS = 4 => cross-hatched + Other values give an error message and are + treated as 2. + + +------------------------------------------------------------------------ +Module: PGSHLS -- set color representation using HLS system +------------------------------------------------------------------------ + + SUBROUTINE PGSHLS (CI, CH, CL, CS) + INTEGER CI + REAL CH, CL, CS + +Set color representation: i.e., define the color to be +associated with a color index. This routine is equivalent to +PGSCR, but the color is defined in the Hue-Lightness-Saturation +model instead of the Red-Green-Blue model. Hue is represented +by an angle in degrees, with red at 120, green at 240, +and blue at 0 (or 360). Lightness ranges from 0.0 to 1.0, with black +at lightness 0.0 and white at lightness 1.0. Saturation ranges from +0.0 (gray) to 1.0 (pure color). Hue is irrelevant when saturation +is 0.0. + +Examples: H L S R G B + black any 0.0 0.0 0.0 0.0 0.0 + white any 1.0 0.0 1.0 1.0 1.0 + medium gray any 0.5 0.0 0.5 0.5 0.5 + red 120 0.5 1.0 1.0 0.0 0.0 + yellow 180 0.5 1.0 1.0 1.0 0.0 + pink 120 0.7 0.8 0.94 0.46 0.46 + +Reference: SIGGRAPH Status Report of the Graphic Standards Planning +Committee, Computer Graphics, Vol.13, No.3, Association for +Computing Machinery, New York, NY, 1979. See also: J. D. Foley et al, +``Computer Graphics: Principles and Practice'', second edition, +Addison-Wesley, 1990, section 13.3.5. + +Argument: + CI (input) : the color index to be defined, in the range 0-max. + If the color index greater than the device + maximum is specified, the call is ignored. Color + index 0 applies to the background color. + CH (input) : hue, in range 0.0 to 360.0. + CL (input) : lightness, in range 0.0 to 1.0. + CS (input) : saturation, in range 0.0 to 1.0. + + +------------------------------------------------------------------------ +Module: PGSHS -- set hatching style +------------------------------------------------------------------------ + + SUBROUTINE PGSHS (ANGLE, SEPN, PHASE) + REAL ANGLE, SEPN, PHASE + +Set the style to be used for hatching (fill area with fill-style 3). +The default style is ANGLE=45.0, SEPN=1.0, PHASE=0.0. + +Arguments: + ANGLE (input) : the angle the hatch lines make with the + horizontal, in degrees, increasing + counterclockwise (this is an angle on the + view surface, not in world-coordinate space). + SEPN (input) : the spacing of the hatch lines. The unit spacing + is 1 percent of the smaller of the height or + width of the view surface. This should not be + zero. + PHASE (input) : a real number between 0 and 1; the hatch lines + are displaced by this fraction of SEPN from a + fixed reference. Adjacent regions hatched with the + same PHASE have contiguous hatch lines. To hatch + a region with alternating lines of two colors, + fill the area twice, with PHASE=0.0 for one color + and PHASE=0.5 for the other color. + + +------------------------------------------------------------------------ +Module: PGSITF -- set image transfer function +------------------------------------------------------------------------ + + SUBROUTINE PGSITF (ITF) + INTEGER ITF + +Set the Image Transfer Function for subsequent images drawn by +PGIMAG, PGGRAY, or PGWEDG. The Image Transfer Function is used +to map array values into the available range of color indices +specified with routine PGSCIR or (for PGGRAY on some devices) +into dot density. + +Argument: + ITF (input) : type of transfer function: + ITF = 0 : linear + ITF = 1 : logarithmic + ITF = 2 : square-root + + +------------------------------------------------------------------------ +Module: PGSLCT -- select an open graphics device +------------------------------------------------------------------------ + + SUBROUTINE PGSLCT(ID) + INTEGER ID + +Select one of the open graphics devices and direct subsequent +plotting to it. The argument is the device identifier returned by +PGOPEN when the device was opened. If the supplied argument is not a +valid identifier of an open graphics device, a warning message is +issued and the current selection is unchanged. + +[This routine was added to PGPLOT in Version 5.1.0.] + +Arguments: + +ID (input, integer): identifier of the device to be selected. + + +------------------------------------------------------------------------ +Module: PGSLS -- set line style +------------------------------------------------------------------------ + + SUBROUTINE PGSLS (LS) + INTEGER LS + +Set the line style attribute for subsequent plotting. This +attribute affects line primitives only; it does not affect graph +markers, text, or area fill. +Five different line styles are available, with the following codes: +1 (full line), 2 (dashed), 3 (dot-dash-dot-dash), 4 (dotted), +5 (dash-dot-dot-dot). The default is 1 (normal full line). + +Argument: + LS (input) : the line-style code for subsequent plotting + (in range 1-5). + + +------------------------------------------------------------------------ +Module: PGSLW -- set line width +------------------------------------------------------------------------ + + SUBROUTINE PGSLW (LW) + INTEGER LW + +Set the line-width attribute. This attribute affects lines, graph +markers, and text. The line width is specified in units of 1/200 +(0.005) inch (about 0.13 mm) and must be an integer in the range +1-201. On some devices, thick lines are generated by tracing each +line with multiple strokes offset in the direction perpendicular to +the line. + +Argument: + LW (input) : width of line, in units of 0.005 inch (0.13 mm) + in range 1-201. + + +------------------------------------------------------------------------ +Module: PGSTBG -- set text background color index +------------------------------------------------------------------------ + + SUBROUTINE PGSTBG (TBCI) + INTEGER TBCI + +Set the Text Background Color Index for subsequent text. By default +text does not obscure underlying graphics. If the text background +color index is positive, however, text is opaque: the bounding box +of the text is filled with the color specified by PGSTBG before +drawing the text characters in the current color index set by PGSCI. +Use color index 0 to erase underlying graphics before drawing text. + +Argument: + TBCI (input) : the color index to be used for the background + for subsequent text plotting: + TBCI < 0 => transparent (default) + TBCI >= 0 => text will be drawn on an opaque + background with color index TBCI. + + +------------------------------------------------------------------------ +Module: PGSUBP -- subdivide view surface into panels +------------------------------------------------------------------------ + + SUBROUTINE PGSUBP (NXSUB, NYSUB) + INTEGER NXSUB, NYSUB + +PGPLOT divides the physical surface of the plotting device (screen, +window, or sheet of paper) into NXSUB x NYSUB `panels'. When the +view surface is sub-divided in this way, PGPAGE moves to the next +panel, not the next physical page. The initial subdivision of the +view surface is set in the call to PGBEG. When PGSUBP is called, +it forces the next call to PGPAGE to start a new physical page, +subdivided in the manner indicated. No plotting should be done +between a call of PGSUBP and a call of PGPAGE (or PGENV, which calls +PGPAGE). + +If NXSUB > 0, PGPLOT uses the panels in row order; if <0, +PGPLOT uses them in column order, e.g., + + NXSUB=3, NYSUB=2 NXSUB=-3, NYSUB=2 + ++-----+-----+-----+ +-----+-----+-----+ +| 1 | 2 | 3 | | 1 | 3 | 5 | ++-----+-----+-----+ +-----+-----+-----+ +| 4 | 5 | 6 | | 2 | 4 | 6 | ++-----+-----+-----+ +-----+-----+-----+ + +PGPLOT advances from one panels to the next when PGPAGE is called, +clearing the screen or starting a new page when the last panel has +been used. It is also possible to jump from one panel to another +in random order by calling PGPANL. + +Arguments: + NXSUB (input) : the number of subdivisions of the view surface in + X (>0 or <0). + NYSUB (input) : the number of subdivisions of the view surface in + Y (>0). + + +------------------------------------------------------------------------ +Module: PGSVP -- set viewport (normalized device coordinates) +------------------------------------------------------------------------ + + SUBROUTINE PGSVP (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +Change the size and position of the viewport, specifying +the viewport in normalized device coordinates. Normalized +device coordinates run from 0 to 1 in each dimension. The +viewport is the rectangle on the view surface "through" +which one views the graph. All the PG routines which plot lines +etc. plot them within the viewport, and lines are truncated at +the edge of the viewport (except for axes, labels etc drawn with +PGBOX or PGLAB). The region of world space (the coordinate +space of the graph) which is visible through the viewport is +specified by a call to PGSWIN. It is legal to request a +viewport larger than the view surface; only the part which +appears on the view surface will be plotted. + +Arguments: + XLEFT (input) : x-coordinate of left hand edge of viewport, in NDC. + XRIGHT (input) : x-coordinate of right hand edge of viewport, + in NDC. + YBOT (input) : y-coordinate of bottom edge of viewport, in NDC. + YTOP (input) : y-coordinate of top edge of viewport, in NDC. + + +------------------------------------------------------------------------ +Module: PGSWIN -- set window +------------------------------------------------------------------------ + + SUBROUTINE PGSWIN (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +Change the window in world coordinate space that is to be mapped on +to the viewport. Usually PGSWIN is called automatically by PGENV, +but it may be called directly by the user. + +Arguments: + X1 (input) : the x-coordinate of the bottom left corner + of the viewport. + X2 (input) : the x-coordinate of the top right corner + of the viewport (note X2 may be less than X1). + Y1 (input) : the y-coordinate of the bottom left corner + of the viewport. + Y2 (input) : the y-coordinate of the top right corner + of the viewport (note Y2 may be less than Y1). + + +------------------------------------------------------------------------ +Module: PGTBOX -- draw frame and write (DD) HH MM SS.S labelling +------------------------------------------------------------------------ + + SUBROUTINE PGTBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB) + + REAL XTICK, YTICK + INTEGER NXSUB, NYSUB + CHARACTER XOPT*(*), YOPT*(*) + +Draw a box and optionally label one or both axes with (DD) HH MM SS +style numeric labels (useful for time or RA - DEC plots). If this +style of labelling is desired, then PGSWIN should have been called +previously with the extrema in SECONDS of time. + +In the seconds field, you can have at most 3 places after the decimal +point, so that 1 ms is the smallest time interval you can time label. + +Large numbers are coped with by fields of 6 characters long. Thus +you could have times with days or hours as big as 999999. However, +in practice, you might have trouble with labels overwriting themselves +with such large numbers unless you a) use a small time INTERVAL, +b) use a small character size or c) choose your own sparse ticks in +the call to PGTBOX. + +PGTBOX will attempt, when choosing its own ticks, not to overwrite +the labels, but this algorithm is not very bright and may fail. + +Note that small intervals but large absolute times such as +TMIN = 200000.0 s and TMAX=200000.1 s will cause the algorithm +to fail. This is inherent in PGPLOT's use of single precision +and cannot be avoided. In such cases, you should use relative +times if possible. + +PGTBOX's labelling philosophy is that the left-most or bottom tick of +the axis contains a full label. Thereafter, only changing fields are +labelled. Negative fields are given a '-' label, positive fields +have none. Axes that have the DD (or HH if the day field is not +used) field on each major tick carry the sign on each field. If the +axis crosses zero, the zero tick will carry a full label and sign. + +This labelling style can cause a little confusion with some special +cases, but as long as you know its philosophy, the truth can be divined. +Consider an axis with TMIN=20s, TMAX=-20s. The labels will look like + + +----------+----------+----------+----------+ + 0h0m20s 10s -0h0m0s 10s 20s + +Knowing that the left field always has a full label and that +positive fields are unsigned, informs that time is decreasing +from left to right, not vice versa. This can become very +unclear if you have used the 'F' option, but that is your problem ! + +Exceptions to this labelling philosophy are when the finest time +increment being displayed is hours (with option 'Y') or days. +Then all fields carry a label. For example, + + +----------+----------+----------+----------+ + -10h -8h -6h -4h -2h + + +PGTBOX can be used in place of PGBOX; it calls PGBOX and only invokes +time labelling if requested. Other options are passed intact to PGBOX. + +Inputs: + XOPT : X-options for PGTBOX. Same as for PGBOX plus + + 'Z' for (DD) HH MM SS.S time labelling + 'Y' means don't include the day field so that labels + are HH MM SS.S rather than DD HH MM SS.S The hours + will accumulate beyond 24 if necessary in this case. + 'X' label the HH field as modulo 24. Thus, a label + such as 25h 10m would come out as 1h 10m + 'H' means superscript numbers with d, h, m, & s symbols + 'D' means superscript numbers with o, ', & '' symbols + 'F' causes the first label (left- or bottom-most) to + be omitted. Useful for sub-panels that abut each other. + Care is needed because first label carries sign as well. + 'O' means omit leading zeros in numbers < 10 + E.g. 3h 3m 1.2s rather than 03h 03m 01.2s Useful + to help save space on X-axes. The day field does not + use this facility. + + YOPT : Y-options for PGTBOX. See above. + XTICK : X-axis major tick increment. 0.0 for default. + YTICK : Y-axis major tick increment. 0.0 for default. + If the 'Z' option is used then XTICK and/or YTICK must + be in seconds. + NXSUB : Number of intervals for minor ticks on X-axis. 0 for default + NYSUB : Number of intervals for minor ticks on Y-axis. 0 for default + + The regular XOPT and YOPT axis options for PGBOX are + + A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical + line X=0). + B : draw bottom (X) or left (Y) edge of frame. + C : draw top (X) or right (Y) edge of frame. + G : draw Grid of vertical (X) or horizontal (Y) lines. + I : Invert the tick marks; ie draw them outside the viewport + instead of inside. + L : label axis Logarithmically (see below). + N : write Numeric labels in the conventional location below the + viewport (X) or to the left of the viewport (Y). + P : extend ("Project") major tick marks outside the box (ignored if + option I is specified). + M : write numeric labels in the unconventional location above the + viewport (X) or to the right of the viewport (Y). + T : draw major Tick marks at the major coordinate interval. + S : draw minor tick marks (Subticks). + V : orient numeric labels Vertically. This is only applicable to Y. + The default is to write Y-labels parallel to the axis. + 1 : force decimal labelling, instead of automatic choice (see PGNUMB). + 2 : force exponential labelling, instead of automatic. + + The default is to write Y-labels parallel to the axis + + + ****************** EXCEPTIONS ******************* + + Note that + 1) PGBOX option 'L' (log labels) is ignored with option 'Z' + 2) The 'O' option will be ignored for the 'V' option as it + makes it impossible to align the labels nicely + 3) Option 'Y' is forced with option 'D' + + *************************************************************** + + + + +------------------------------------------------------------------------ +Module: PGTEXT -- write text (horizontal, left-justified) +------------------------------------------------------------------------ + + SUBROUTINE PGTEXT (X, Y, TEXT) + REAL X, Y + CHARACTER*(*) TEXT + +Write text. The bottom left corner of the first character is placed +at the specified position, and the text is written horizontally. +This is a simplified interface to the primitive routine PGPTXT. +For non-horizontal text, use PGPTXT. + +Arguments: + X (input) : world x-coordinate of start of string. + Y (input) : world y-coordinate of start of string. + TEXT (input) : the character string to be plotted. + + +------------------------------------------------------------------------ +Module: PGTICK -- draw a single tick mark on an axis +------------------------------------------------------------------------ + + SUBROUTINE PGTICK (X1, Y1, X2, Y2, V, TIKL, TIKR, DISP, + : ORIENT, STR) + REAL X1, Y1, X2, Y2, V, TIKL, TIKR, DISP, ORIENT + CHARACTER*(*) STR + +Draw and label single tick mark on a graph axis. The tick mark is +a short line perpendicular to the direction of the axis (which is not +drawn by this routine). The optional text label is drawn with its +baseline parallel to the axis and reading in the same direction as +the axis (from point 1 to point 2). Current line and text attributes +are used. + +Arguments: + X1, Y1 (input) : world coordinates of one endpoint of the axis. + X2, Y2 (input) : world coordinates of the other endpoint of the axis. + V (input) : draw the tick mark at fraction V (0<=V<=1) along + the line from (X1,Y1) to (X2,Y2). + TIKL (input) : length of tick mark drawn to left of axis + (as seen looking from first endpoint to second), in + units of the character height. + TIKR (input) : length of major tick marks drawn to right of axis, + in units of the character height. + DISP (input) : displacement of label text to + right of axis, in units of the character height. + ORIENT (input) : orientation of label text, in degrees; angle between + baseline of text and direction of axis (0-360°). + STR (input) : text of label (may be blank). + + +------------------------------------------------------------------------ +Module: PGUPDT -- update display +------------------------------------------------------------------------ + + SUBROUTINE PGUPDT + +Update the graphics display: flush any pending commands to the +output device. This routine empties the buffer created by PGBBUF, +but it does not alter the PGBBUF/PGEBUF counter. The routine should +be called when it is essential that the display be completely up to +date (before interaction with the user, for example) but it is not +known if output is being buffered. + +Arguments: none + + +------------------------------------------------------------------------ +Module: PGVECT -- vector map of a 2D data array, with blanking +------------------------------------------------------------------------ + + SUBROUTINE PGVECT (A, B, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR, + 1 BLANK) + INTEGER IDIM, JDIM, I1, I2, J1, J2, NC + REAL A(IDIM,JDIM), B(IDIM, JDIM), TR(6), BLANK, C + +Draw a vector map of two arrays. This routine is similar to +PGCONB in that array elements that have the "magic value" defined by +the argument BLANK are ignored, making gaps in the vector map. The +routine may be useful for data measured on most but not all of the +points of a grid. Vectors are displayed as arrows; the style of the +arrowhead can be set with routine PGSAH, and the the size of the +arrowhead is determined by the current character size, set by PGSCH. + +Arguments: + A (input) : horizontal component data array. + B (input) : vertical component data array. + IDIM (input) : first dimension of A and B. + JDIM (input) : second dimension of A and B. + I1,I2 (input) : range of first index to be mapped (inclusive). + J1,J2 (input) : range of second index to be mapped (inclusive). + C (input) : scale factor for vector lengths, if 0.0, C will be + set so that the longest vector is equal to the + smaller of TR(2)+TR(3) and TR(5)+TR(6). + NC (input) : vector positioning code. + <0 vector head positioned on coordinates + >0 vector base positioned on coordinates + =0 vector centered on the coordinates + TR (input) : array defining a transformation between the I,J + grid of the array and the world coordinates. The + world coordinates of the array point A(I,J) are + given by: + X = TR(1) + TR(2)*I + TR(3)*J + Y = TR(4) + TR(5)*I + TR(6)*J + Usually TR(3) and TR(5) are zero - unless the + coordinate transformation involves a rotation + or shear. + BLANK (input) : elements of arrays A or B that are exactly equal to + this value are ignored (blanked). + + +------------------------------------------------------------------------ +Module: PGVSIZ -- set viewport (inches) +------------------------------------------------------------------------ + + SUBROUTINE PGVSIZ (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +Change the size and position of the viewport, specifying +the viewport in physical device coordinates (inches). The +viewport is the rectangle on the view surface "through" +which one views the graph. All the PG routines which plot lines +etc. plot them within the viewport, and lines are truncated at +the edge of the viewport (except for axes, labels etc drawn with +PGBOX or PGLAB). The region of world space (the coordinate +space of the graph) which is visible through the viewport is +specified by a call to PGSWIN. It is legal to request a +viewport larger than the view surface; only the part which +appears on the view surface will be plotted. + +Arguments: + XLEFT (input) : x-coordinate of left hand edge of viewport, in + inches from left edge of view surface. + XRIGHT (input) : x-coordinate of right hand edge of viewport, in + inches from left edge of view surface. + YBOT (input) : y-coordinate of bottom edge of viewport, in + inches from bottom of view surface. + YTOP (input) : y-coordinate of top edge of viewport, in inches + from bottom of view surface. + + +------------------------------------------------------------------------ +Module: PGVSTD -- set standard (default) viewport +------------------------------------------------------------------------ + + SUBROUTINE PGVSTD + +Define the viewport to be the standard viewport. The standard +viewport is the full area of the view surface (or panel), +less a margin of 4 character heights all round for labelling. +It thus depends on the current character size, set by PGSCH. + +Arguments: none. + + +------------------------------------------------------------------------ +Module: PGWEDG -- annotate an image plot with a wedge +------------------------------------------------------------------------ + + SUBROUTINE PGWEDG(SIDE, DISP, WIDTH, FG, BG, LABEL) + CHARACTER *(*) SIDE,LABEL + REAL DISP, WIDTH, FG, BG + +Plot an annotated grey-scale or color wedge parallel to a given axis +of the the current viewport. This routine is designed to provide a +brightness/color scale for an image drawn with PGIMAG or PGGRAY. +The wedge will be drawn with the transfer function set by PGSITF +and using the color index range set by PGSCIR. + +Arguments: + SIDE (input) : The first character must be one of the characters + 'B', 'L', 'T', or 'R' signifying the Bottom, Left, + Top, or Right edge of the viewport. + The second character should be 'I' to use PGIMAG + to draw the wedge, or 'G' to use PGGRAY. + DISP (input) : the displacement of the wedge from the specified + edge of the viewport, measured outwards from the + viewport in units of the character height. Use a + negative value to write inside the viewport, a + positive value to write outside. + WIDTH (input) : The total width of the wedge including annotation, + in units of the character height. + FG (input) : The value which is to appear with shade + 1 ("foreground"). Use the values of FG and BG + that were supplied to PGGRAY or PGIMAG. + BG (input) : the value which is to appear with shade + 0 ("background"). + LABEL (input) : Optional units label. If no label is required + use ' '. + + +------------------------------------------------------------------------ +Module: PGWNAD -- set window and adjust viewport to same aspect ratio +------------------------------------------------------------------------ + + SUBROUTINE PGWNAD (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +Change the window in world coordinate space that is to be mapped on +to the viewport, and simultaneously adjust the viewport so that the +world-coordinate scales are equal in x and y. The new viewport is +the largest one that can fit within the previously set viewport +while retaining the required aspect ratio. + +Arguments: + X1 (input) : the x-coordinate of the bottom left corner + of the viewport. + X2 (input) : the x-coordinate of the top right corner + of the viewport (note X2 may be less than X1). + Y1 (input) : the y-coordinate of the bottom left corner + of the viewport. + Y2 (input) : the y-coordinate of the top right corner of the + viewport (note Y2 may be less than Y1). + + +------------------------------------------------------------------------ +Module: PGADVANCE -- non-standard alias for PGPAGE +------------------------------------------------------------------------ + + SUBROUTINE PGADVANCE + +See description of PGPAGE. + + +------------------------------------------------------------------------ +Module: PGBEGIN -- non-standard alias for PGBEG +------------------------------------------------------------------------ + + INTEGER FUNCTION PGBEGIN (UNIT, FILE, NXSUB, NYSUB) + INTEGER UNIT + CHARACTER*(*) FILE + INTEGER NXSUB, NYSUB + +See description of PGBEG. + + +------------------------------------------------------------------------ +Module: PGCURSE -- non-standard alias for PGCURS +------------------------------------------------------------------------ + + INTEGER FUNCTION PGCURSE (X, Y, CH) + REAL X, Y + CHARACTER*1 CH + +See description of PGCURS. + + +------------------------------------------------------------------------ +Module: PGLABEL -- non-standard alias for PGLAB +------------------------------------------------------------------------ + + SUBROUTINE PGLABEL (XLBL, YLBL, TOPLBL) + CHARACTER*(*) XLBL, YLBL, TOPLBL + +See description of PGLAB. + + +------------------------------------------------------------------------ +Module: PGMTEXT -- non-standard alias for PGMTXT +------------------------------------------------------------------------ + + SUBROUTINE PGMTEXT (SIDE, DISP, COORD, FJUST, TEXT) + CHARACTER*(*) SIDE, TEXT + REAL DISP, COORD, FJUST + +See description of PGMTXT. + + +------------------------------------------------------------------------ +Module: PGNCURSE -- non-standard alias for PGNCUR +------------------------------------------------------------------------ + + SUBROUTINE PGNCURSE (MAXPT, NPT, X, Y, SYMBOL) + INTEGER MAXPT, NPT + REAL X(*), Y(*) + INTEGER SYMBOL + +See description of PGNCUR. + + +------------------------------------------------------------------------ +Module: PGPAPER -- non-standard alias for PGPAP +------------------------------------------------------------------------ + + SUBROUTINE PGPAPER (WIDTH, ASPECT) + REAL WIDTH, ASPECT + +See description of PGPAP. + + +------------------------------------------------------------------------ +Module: PGPOINT -- non-standard alias for PGPT +------------------------------------------------------------------------ + + SUBROUTINE PGPOINT (N, XPTS, YPTS, SYMBOL) + INTEGER N + REAL XPTS(*), YPTS(*) + INTEGER SYMBOL + +See description of PGPT. + + +------------------------------------------------------------------------ +Module: PGPTEXT -- non-standard alias for PGPTXT +------------------------------------------------------------------------ + + SUBROUTINE PGPTEXT (X, Y, ANGLE, FJUST, TEXT) + REAL X, Y, ANGLE, FJUST + CHARACTER*(*) TEXT + +See description of PGPTXT. + + +------------------------------------------------------------------------ +Module: PGVPORT -- non-standard alias for PGSVP +------------------------------------------------------------------------ + + SUBROUTINE PGVPORT (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +See description of PGSVP. + + +------------------------------------------------------------------------ +Module: PGVSIZE -- non-standard alias for PGVSIZ +------------------------------------------------------------------------ + + SUBROUTINE PGVSIZE (XLEFT, XRIGHT, YBOT, YTOP) + REAL XLEFT, XRIGHT, YBOT, YTOP + +See description of PGVSIZ. + + +------------------------------------------------------------------------ +Module: PGVSTAND -- non-standard alias for PGVSTD +------------------------------------------------------------------------ + + SUBROUTINE PGVSTAND + +See description of PGVSTD. + + +------------------------------------------------------------------------ +Module: PGWINDOW -- non-standard alias for PGSWIN +------------------------------------------------------------------------ + + SUBROUTINE PGWINDOW (X1, X2, Y1, Y2) + REAL X1, X2, Y1, Y2 + +See description of PGSWIN. diff --git a/pgplot_sl6/pgplot.inc b/pgplot_sl6/pgplot.inc new file mode 100644 index 0000000..e15f308 --- /dev/null +++ b/pgplot_sl6/pgplot.inc @@ -0,0 +1,135 @@ +C----------------------------------------------------------------------- +C PGPLOT: common block definition. +C----------------------------------------------------------------------- +C Maximum number of concurrent devices (should match GRIMAX). +C----------------------------------------------------------------------- + INTEGER PGMAXD + PARAMETER (PGMAXD=8) +C----------------------------------------------------------------------- +C Indentifier of currently selected device. +C----------------------------------------------------------------------- + INTEGER PGID +C----------------------------------------------------------------------- +C Device status (indexed by device identifier). +C----------------------------------------------------------------------- +C PGDEVS =0 if device is not open; 1 if device is open. +C PGADVS Set to 0 by PGBEGIN, set to 1 by PGPAGE; used to suppress +C the prompt for the first page. +C PROMPT If .TRUE., ask user before clearing page; set by PGASK +C and (indirectly) by PGBEGIN, used in PGENV. +C PGBLEV Buffering level: incremented by PGBBUF, decremented by +C PGEBUF. +C PGPFIX TRUE if PGPAP has been called, FALSE otherwise. +C + INTEGER PGDEVS(PGMAXD), PGADVS(PGMAXD), PGBLEV(PGMAXD) + LOGICAL PGPRMP(PGMAXD), PGPFIX(PGMAXD) +C----------------------------------------------------------------------- +C Panel parameters (indexed by device identification). +C----------------------------------------------------------------------- +C NX Number of panels in x direction +C NY Number of panels in y direction +C NXC Ordinal number of current X panel +C NYC Ordinal number of current Y panel +C XSZ X dimension of panel (device units) +C YSZ Y dimension of panel (device units) +C PGROWS TRUE if panels are used in row order, FALSE for column +C order. +C + INTEGER PGNX (PGMAXD), PGNY (PGMAXD) + INTEGER PGNXC (PGMAXD), PGNYC (PGMAXD) + REAL PGXSZ (PGMAXD), PGYSZ (PGMAXD) + LOGICAL PGROWS(PGMAXD) +C----------------------------------------------------------------------- +C Attributes (indexed by device identification). +C----------------------------------------------------------------------- +C PGCLP clipping enabled/disabed +C PGFAS fill-area style +C PGCHSZ character height +C PGAHS arrow-head fill style +C PGAHA arrow-head angle +C PGAHV arrow-head vent +C PGTBCI text background color index +C PGMNCI lower range of color indices available to PGGRAY/PGIMAG +C PGMXCI upper range of color indices available to PGGRAY/PGIMAG +C PGITF type of transfer function used by PGGRAY/PGIMAG +C PGHSA hatching line angle +C PGHSS hatching line separation +C PGHSP hatching line phase +C + INTEGER PGCLP (PGMAXD) + INTEGER PGFAS (PGMAXD) + REAL PGCHSZ(PGMAXD) + INTEGER PGAHS (PGMAXD) + REAL PGAHA (PGMAXD) + REAL PGAHV (PGMAXD) + INTEGER PGTBCI(PGMAXD) + INTEGER PGMNCI(PGMAXD) + INTEGER PGMXCI(PGMAXD) + INTEGER PGITF (PGMAXD) + REAL PGHSA (PGMAXD) + REAL PGHSS (PGMAXD) + REAL PGHSP (PGMAXD) +C----------------------------------------------------------------------- +C Viewport parameters (indexed by device identification); all are device +C coordinates: +C----------------------------------------------------------------------- +C PGXOFF X coordinate of blc of viewport. +C PGYOFF Y coordinate of blc of viewport. +C PGXVP X coordinate of blc of viewport, relative to blc of subpage. +C PGYVP Y coordinate of blc of viewport, relative to blc of subpage. +C PGXLEN Width of viewport. +C PGYLEN Height of viewport. +C + REAL PGXOFF(PGMAXD), PGYOFF(PGMAXD) + REAL PGXVP (PGMAXD), PGYVP (PGMAXD) + REAL PGXLEN(PGMAXD), PGYLEN(PGMAXD) +C----------------------------------------------------------------------- +C Scaling parameters (indexed by device identification): +C----------------------------------------------------------------------- +C PGXORG device coordinate value corresponding to world X=0 +C PGYORG device coordinate value corresponding to world Y=0 +C PGXSCL scale in x (device units per world coordinate unit) +C PGYSCL scale in y (device units per world coordinate unit) +C PGXPIN device x scale in device units/inch +C PGYPIN device y scale in device units/inch +C PGXSP Character X spacing (device units) +C PGYSP Character Y spacing (device units) +C + REAL PGXORG(PGMAXD), PGYORG(PGMAXD) + REAL PGXSCL(PGMAXD), PGYSCL(PGMAXD) + REAL PGXPIN(PGMAXD), PGYPIN(PGMAXD) + REAL PGXSP (PGMAXD), PGYSP (PGMAXD) +C----------------------------------------------------------------------- +C Window parameters (indexed by device identification); all are world +C coordinate values: +C----------------------------------------------------------------------- +C PGXBLC world X at bottom left corner of window +C PGXTRC world X at top right corner of window +C PGYBLC world Y at bottom left corner of window +C PGYTRC world Y at top right corner of window +C + REAL PGXBLC(PGMAXD), PGXTRC(PGMAXD) + REAL PGYBLC(PGMAXD), PGYTRC(PGMAXD) +C----------------------------------------------------------------------- +C The following parameters are used in the contouring routines to pass +C information to the action routine. They do not need to be indexed. +C----------------------------------------------------------------------- +C TRANS Transformation matrix for contour plots; copied +C from argument list by PGCONT and used by PGCP. +C + INTEGER PGCINT, PGCMIN + REAL TRANS(6) + CHARACTER*32 PGCLAB +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + COMMON /PGPLT1/ PGID,PGDEVS,PGADVS,PGNX, PGNY, PGNXC, PGNYC , + 1 PGXPIN,PGYPIN,PGXSP, PGYSP, PGXSZ, PGYSZ, + 2 PGXOFF,PGYOFF,PGXVP, PGYVP, PGXLEN,PGYLEN,PGXORG,PGYORG, + 3 PGXSCL,PGYSCL,PGXBLC,PGXTRC,PGYBLC,PGYTRC,TRANS, + 4 PGPRMP,PGCLP, PGFAS, PGCHSZ,PGBLEV,PGROWS, + 5 PGAHS, PGAHA, PGAHV, PGTBCI,PGMNCI,PGMXCI,PGCINT,PGCMIN, + 6 PGPFIX,PGITF, PGHSA, PGHSS, PGHSP + COMMON /PGPLT2/ PGCLAB + SAVE /PGPLT1/ + SAVE /PGPLT2/ +C----------------------------------------------------------------------- diff --git a/pgplot_sl6/pgxwin_server b/pgplot_sl6/pgxwin_server new file mode 100755 index 0000000..33c9562 Binary files /dev/null and b/pgplot_sl6/pgxwin_server differ diff --git a/pgplot_sl6/rgb.txt b/pgplot_sl6/rgb.txt new file mode 100644 index 0000000..e5f6188 --- /dev/null +++ b/pgplot_sl6/rgb.txt @@ -0,0 +1,738 @@ +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite +245 245 245 white smoke +245 245 245 WhiteSmoke +220 220 220 gainsboro +255 250 240 floral white +255 250 240 FloralWhite +253 245 230 old lace +253 245 230 OldLace +250 240 230 linen +250 235 215 antique white +250 235 215 AntiqueWhite +255 239 213 papaya whip +255 239 213 PapayaWhip +255 235 205 blanched almond +255 235 205 BlanchedAlmond +255 228 196 bisque +255 218 185 peach puff +255 218 185 PeachPuff +255 222 173 navajo white +255 222 173 NavajoWhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemon chiffon +255 250 205 LemonChiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mint cream +245 255 250 MintCream +240 255 255 azure +240 248 255 alice blue +240 248 255 AliceBlue +230 230 250 lavender +255 240 245 lavender blush +255 240 245 LavenderBlush +255 228 225 misty rose +255 228 225 MistyRose +255 255 255 white + 0 0 0 black + 47 79 79 dark slate gray + 47 79 79 DarkSlateGray + 47 79 79 dark slate grey + 47 79 79 DarkSlateGrey +105 105 105 dim gray +105 105 105 DimGray +105 105 105 dim grey +105 105 105 DimGrey +112 128 144 slate gray +112 128 144 SlateGray +112 128 144 slate grey +112 128 144 SlateGrey +119 136 153 light slate gray +119 136 153 LightSlateGray +119 136 153 light slate grey +119 136 153 LightSlateGrey +190 190 190 gray +190 190 190 grey +211 211 211 light grey +211 211 211 LightGrey +211 211 211 light gray +211 211 211 LightGray + 25 25 112 midnight blue + 25 25 112 MidnightBlue + 0 0 128 navy + 0 0 128 navy blue + 0 0 128 NavyBlue +100 149 237 cornflower blue +100 149 237 CornflowerBlue + 72 61 139 dark slate blue + 72 61 139 DarkSlateBlue +106 90 205 slate blue +106 90 205 SlateBlue +123 104 238 medium slate blue +123 104 238 MediumSlateBlue +132 112 255 light slate blue +132 112 255 LightSlateBlue + 0 0 205 medium blue + 0 0 205 MediumBlue + 65 105 225 royal blue + 65 105 225 RoyalBlue + 0 0 255 blue + 30 144 255 dodger blue + 30 144 255 DodgerBlue + 0 191 255 deep sky blue + 0 191 255 DeepSkyBlue +135 206 235 sky blue +135 206 235 SkyBlue +135 206 250 light sky blue +135 206 250 LightSkyBlue + 70 130 180 steel blue + 70 130 180 SteelBlue +176 196 222 light steel blue +176 196 222 LightSteelBlue +173 216 230 light blue +173 216 230 LightBlue +176 224 230 powder blue +176 224 230 PowderBlue +175 238 238 pale turquoise +175 238 238 PaleTurquoise + 0 206 209 dark turquoise + 0 206 209 DarkTurquoise + 72 209 204 medium turquoise + 72 209 204 MediumTurquoise + 64 224 208 turquoise + 0 255 255 cyan +224 255 255 light cyan +224 255 255 LightCyan + 95 158 160 cadet blue + 95 158 160 CadetBlue +102 205 170 medium aquamarine +102 205 170 MediumAquamarine +127 255 212 aquamarine + 0 100 0 dark green + 0 100 0 DarkGreen + 85 107 47 dark olive green + 85 107 47 DarkOliveGreen +143 188 143 dark sea green +143 188 143 DarkSeaGreen + 46 139 87 sea green + 46 139 87 SeaGreen + 60 179 113 medium sea green + 60 179 113 MediumSeaGreen + 32 178 170 light sea green + 32 178 170 LightSeaGreen +152 251 152 pale green +152 251 152 PaleGreen + 0 255 127 spring green + 0 255 127 SpringGreen +124 252 0 lawn green +124 252 0 LawnGreen + 0 255 0 green +127 255 0 chartreuse + 0 250 154 medium spring green + 0 250 154 MediumSpringGreen +173 255 47 green yellow +173 255 47 GreenYellow + 50 205 50 lime green + 50 205 50 LimeGreen +154 205 50 yellow green +154 205 50 YellowGreen + 34 139 34 forest green + 34 139 34 ForestGreen +107 142 35 olive drab +107 142 35 OliveDrab +189 183 107 dark khaki +189 183 107 DarkKhaki +240 230 140 khaki +238 232 170 pale goldenrod +238 232 170 PaleGoldenrod +250 250 210 light goldenrod yellow +250 250 210 LightGoldenrodYellow +255 255 224 light yellow +255 255 224 LightYellow +255 255 0 yellow +255 215 0 gold +238 221 130 light goldenrod +238 221 130 LightGoldenrod +218 165 32 goldenrod +184 134 11 dark goldenrod +184 134 11 DarkGoldenrod +188 143 143 rosy brown +188 143 143 RosyBrown +205 92 92 indian red +205 92 92 IndianRed +139 69 19 saddle brown +139 69 19 SaddleBrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandy brown +244 164 96 SandyBrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 dark salmon +233 150 122 DarkSalmon +250 128 114 salmon +255 160 122 light salmon +255 160 122 LightSalmon +255 165 0 orange +255 140 0 dark orange +255 140 0 DarkOrange +255 127 80 coral +240 128 128 light coral +240 128 128 LightCoral +255 99 71 tomato +255 69 0 orange red +255 69 0 OrangeRed +255 0 0 red +255 105 180 hot pink +255 105 180 HotPink +255 20 147 deep pink +255 20 147 DeepPink +255 192 203 pink +255 182 193 light pink +255 182 193 LightPink +219 112 147 pale violet red +219 112 147 PaleVioletRed +176 48 96 maroon +199 21 133 medium violet red +199 21 133 MediumVioletRed +208 32 144 violet red +208 32 144 VioletRed +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 medium orchid +186 85 211 MediumOrchid +153 50 204 dark orchid +153 50 204 DarkOrchid +148 0 211 dark violet +148 0 211 DarkViolet +138 43 226 blue violet +138 43 226 BlueViolet +160 32 240 purple +147 112 219 medium purple +147 112 219 MediumPurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 AntiqueWhite1 +238 223 204 AntiqueWhite2 +205 192 176 AntiqueWhite3 +139 131 120 AntiqueWhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 PeachPuff1 +238 203 173 PeachPuff2 +205 175 149 PeachPuff3 +139 119 101 PeachPuff4 +255 222 173 NavajoWhite1 +238 207 161 NavajoWhite2 +205 179 139 NavajoWhite3 +139 121 94 NavajoWhite4 +255 250 205 LemonChiffon1 +238 233 191 LemonChiffon2 +205 201 165 LemonChiffon3 +139 137 112 LemonChiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 LavenderBlush1 +238 224 229 LavenderBlush2 +205 193 197 LavenderBlush3 +139 131 134 LavenderBlush4 +255 228 225 MistyRose1 +238 213 210 MistyRose2 +205 183 181 MistyRose3 +139 125 123 MistyRose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 SlateBlue1 +122 103 238 SlateBlue2 +105 89 205 SlateBlue3 + 71 60 139 SlateBlue4 + 72 118 255 RoyalBlue1 + 67 110 238 RoyalBlue2 + 58 95 205 RoyalBlue3 + 39 64 139 RoyalBlue4 + 0 0 255 blue1 + 0 0 238 blue2 + 0 0 205 blue3 + 0 0 139 blue4 + 30 144 255 DodgerBlue1 + 28 134 238 DodgerBlue2 + 24 116 205 DodgerBlue3 + 16 78 139 DodgerBlue4 + 99 184 255 SteelBlue1 + 92 172 238 SteelBlue2 + 79 148 205 SteelBlue3 + 54 100 139 SteelBlue4 + 0 191 255 DeepSkyBlue1 + 0 178 238 DeepSkyBlue2 + 0 154 205 DeepSkyBlue3 + 0 104 139 DeepSkyBlue4 +135 206 255 SkyBlue1 +126 192 238 SkyBlue2 +108 166 205 SkyBlue3 + 74 112 139 SkyBlue4 +176 226 255 LightSkyBlue1 +164 211 238 LightSkyBlue2 +141 182 205 LightSkyBlue3 + 96 123 139 LightSkyBlue4 +198 226 255 SlateGray1 +185 211 238 SlateGray2 +159 182 205 SlateGray3 +108 123 139 SlateGray4 +202 225 255 LightSteelBlue1 +188 210 238 LightSteelBlue2 +162 181 205 LightSteelBlue3 +110 123 139 LightSteelBlue4 +191 239 255 LightBlue1 +178 223 238 LightBlue2 +154 192 205 LightBlue3 +104 131 139 LightBlue4 +224 255 255 LightCyan1 +209 238 238 LightCyan2 +180 205 205 LightCyan3 +122 139 139 LightCyan4 +187 255 255 PaleTurquoise1 +174 238 238 PaleTurquoise2 +150 205 205 PaleTurquoise3 +102 139 139 PaleTurquoise4 +152 245 255 CadetBlue1 +142 229 238 CadetBlue2 +122 197 205 CadetBlue3 + 83 134 139 CadetBlue4 + 0 245 255 turquoise1 + 0 229 238 turquoise2 + 0 197 205 turquoise3 + 0 134 139 turquoise4 + 0 255 255 cyan1 + 0 238 238 cyan2 + 0 205 205 cyan3 + 0 139 139 cyan4 +151 255 255 DarkSlateGray1 +141 238 238 DarkSlateGray2 +121 205 205 DarkSlateGray3 + 82 139 139 DarkSlateGray4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 + 69 139 116 aquamarine4 +193 255 193 DarkSeaGreen1 +180 238 180 DarkSeaGreen2 +155 205 155 DarkSeaGreen3 +105 139 105 DarkSeaGreen4 + 84 255 159 SeaGreen1 + 78 238 148 SeaGreen2 + 67 205 128 SeaGreen3 + 46 139 87 SeaGreen4 +154 255 154 PaleGreen1 +144 238 144 PaleGreen2 +124 205 124 PaleGreen3 + 84 139 84 PaleGreen4 + 0 255 127 SpringGreen1 + 0 238 118 SpringGreen2 + 0 205 102 SpringGreen3 + 0 139 69 SpringGreen4 + 0 255 0 green1 + 0 238 0 green2 + 0 205 0 green3 + 0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 + 69 139 0 chartreuse4 +192 255 62 OliveDrab1 +179 238 58 OliveDrab2 +154 205 50 OliveDrab3 +105 139 34 OliveDrab4 +202 255 112 DarkOliveGreen1 +188 238 104 DarkOliveGreen2 +162 205 90 DarkOliveGreen3 +110 139 61 DarkOliveGreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 LightGoldenrod1 +238 220 130 LightGoldenrod2 +205 190 112 LightGoldenrod3 +139 129 76 LightGoldenrod4 +255 255 224 LightYellow1 +238 238 209 LightYellow2 +205 205 180 LightYellow3 +139 139 122 LightYellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 DarkGoldenrod1 +238 173 14 DarkGoldenrod2 +205 149 12 DarkGoldenrod3 +139 101 8 DarkGoldenrod4 +255 193 193 RosyBrown1 +238 180 180 RosyBrown2 +205 155 155 RosyBrown3 +139 105 105 RosyBrown4 +255 106 106 IndianRed1 +238 99 99 IndianRed2 +205 85 85 IndianRed3 +139 58 58 IndianRed4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 LightSalmon1 +238 149 114 LightSalmon2 +205 129 98 LightSalmon3 +139 87 66 LightSalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 DarkOrange1 +238 118 0 DarkOrange2 +205 102 0 DarkOrange3 +139 69 0 DarkOrange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 OrangeRed1 +238 64 0 OrangeRed2 +205 55 0 OrangeRed3 +139 37 0 OrangeRed4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 DeepPink1 +238 18 137 DeepPink2 +205 16 118 DeepPink3 +139 10 80 DeepPink4 +255 110 180 HotPink1 +238 106 167 HotPink2 +205 96 144 HotPink3 +139 58 98 HotPink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 LightPink1 +238 162 173 LightPink2 +205 140 149 LightPink3 +139 95 101 LightPink4 +255 130 171 PaleVioletRed1 +238 121 159 PaleVioletRed2 +205 104 137 PaleVioletRed3 +139 71 93 PaleVioletRed4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 VioletRed1 +238 58 140 VioletRed2 +205 50 120 VioletRed3 +139 34 82 VioletRed4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 MediumOrchid1 +209 95 238 MediumOrchid2 +180 82 205 MediumOrchid3 +122 55 139 MediumOrchid4 +191 62 255 DarkOrchid1 +178 58 238 DarkOrchid2 +154 50 205 DarkOrchid3 +104 34 139 DarkOrchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 + 85 26 139 purple4 +171 130 255 MediumPurple1 +159 121 238 MediumPurple2 +137 104 205 MediumPurple3 + 93 71 139 MediumPurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 + 0 0 0 gray0 + 0 0 0 grey0 + 3 3 3 gray1 + 3 3 3 grey1 + 5 5 5 gray2 + 5 5 5 grey2 + 8 8 8 gray3 + 8 8 8 grey3 + 10 10 10 gray4 + 10 10 10 grey4 + 13 13 13 gray5 + 13 13 13 grey5 + 15 15 15 gray6 + 15 15 15 grey6 + 18 18 18 gray7 + 18 18 18 grey7 + 20 20 20 gray8 + 20 20 20 grey8 + 23 23 23 gray9 + 23 23 23 grey9 + 26 26 26 gray10 + 26 26 26 grey10 + 28 28 28 gray11 + 28 28 28 grey11 + 31 31 31 gray12 + 31 31 31 grey12 + 33 33 33 gray13 + 33 33 33 grey13 + 36 36 36 gray14 + 36 36 36 grey14 + 38 38 38 gray15 + 38 38 38 grey15 + 41 41 41 gray16 + 41 41 41 grey16 + 43 43 43 gray17 + 43 43 43 grey17 + 46 46 46 gray18 + 46 46 46 grey18 + 48 48 48 gray19 + 48 48 48 grey19 + 51 51 51 gray20 + 51 51 51 grey20 + 54 54 54 gray21 + 54 54 54 grey21 + 56 56 56 gray22 + 56 56 56 grey22 + 59 59 59 gray23 + 59 59 59 grey23 + 61 61 61 gray24 + 61 61 61 grey24 + 64 64 64 gray25 + 64 64 64 grey25 + 66 66 66 gray26 + 66 66 66 grey26 + 69 69 69 gray27 + 69 69 69 grey27 + 71 71 71 gray28 + 71 71 71 grey28 + 74 74 74 gray29 + 74 74 74 grey29 + 77 77 77 gray30 + 77 77 77 grey30 + 79 79 79 gray31 + 79 79 79 grey31 + 82 82 82 gray32 + 82 82 82 grey32 + 84 84 84 gray33 + 84 84 84 grey33 + 87 87 87 gray34 + 87 87 87 grey34 + 89 89 89 gray35 + 89 89 89 grey35 + 92 92 92 gray36 + 92 92 92 grey36 + 94 94 94 gray37 + 94 94 94 grey37 + 97 97 97 gray38 + 97 97 97 grey38 + 99 99 99 gray39 + 99 99 99 grey39 +102 102 102 gray40 +102 102 102 grey40 +105 105 105 gray41 +105 105 105 grey41 +107 107 107 gray42 +107 107 107 grey42 +110 110 110 gray43 +110 110 110 grey43 +112 112 112 gray44 +112 112 112 grey44 +115 115 115 gray45 +115 115 115 grey45 +117 117 117 gray46 +117 117 117 grey46 +120 120 120 gray47 +120 120 120 grey47 +122 122 122 gray48 +122 122 122 grey48 +125 125 125 gray49 +125 125 125 grey49 +127 127 127 gray50 +127 127 127 grey50 +130 130 130 gray51 +130 130 130 grey51 +133 133 133 gray52 +133 133 133 grey52 +135 135 135 gray53 +135 135 135 grey53 +138 138 138 gray54 +138 138 138 grey54 +140 140 140 gray55 +140 140 140 grey55 +143 143 143 gray56 +143 143 143 grey56 +145 145 145 gray57 +145 145 145 grey57 +148 148 148 gray58 +148 148 148 grey58 +150 150 150 gray59 +150 150 150 grey59 +153 153 153 gray60 +153 153 153 grey60 +156 156 156 gray61 +156 156 156 grey61 +158 158 158 gray62 +158 158 158 grey62 +161 161 161 gray63 +161 161 161 grey63 +163 163 163 gray64 +163 163 163 grey64 +166 166 166 gray65 +166 166 166 grey65 +168 168 168 gray66 +168 168 168 grey66 +171 171 171 gray67 +171 171 171 grey67 +173 173 173 gray68 +173 173 173 grey68 +176 176 176 gray69 +176 176 176 grey69 +179 179 179 gray70 +179 179 179 grey70 +181 181 181 gray71 +181 181 181 grey71 +184 184 184 gray72 +184 184 184 grey72 +186 186 186 gray73 +186 186 186 grey73 +189 189 189 gray74 +189 189 189 grey74 +191 191 191 gray75 +191 191 191 grey75 +194 194 194 gray76 +194 194 194 grey76 +196 196 196 gray77 +196 196 196 grey77 +199 199 199 gray78 +199 199 199 grey78 +201 201 201 gray79 +201 201 201 grey79 +204 204 204 gray80 +204 204 204 grey80 +207 207 207 gray81 +207 207 207 grey81 +209 209 209 gray82 +209 209 209 grey82 +212 212 212 gray83 +212 212 212 grey83 +214 214 214 gray84 +214 214 214 grey84 +217 217 217 gray85 +217 217 217 grey85 +219 219 219 gray86 +219 219 219 grey86 +222 222 222 gray87 +222 222 222 grey87 +224 224 224 gray88 +224 224 224 grey88 +227 227 227 gray89 +227 227 227 grey89 +229 229 229 gray90 +229 229 229 grey90 +232 232 232 gray91 +232 232 232 grey91 +235 235 235 gray92 +235 235 235 grey92 +237 237 237 gray93 +237 237 237 grey93 +240 240 240 gray94 +240 240 240 grey94 +242 242 242 gray95 +242 242 242 grey95 +245 245 245 gray96 +245 245 245 grey96 +247 247 247 gray97 +247 247 247 grey97 +250 250 250 gray98 +250 250 250 grey98 +252 252 252 gray99 +252 252 252 grey99 +255 255 255 gray100 +255 255 255 grey100 diff --git a/rhel7/fit_help.html b/rhel7/fit_help.html new file mode 100644 index 0000000..2514def --- /dev/null +++ b/rhel7/fit_help.html @@ -0,0 +1,781 @@ +
FIT HELP
+
+

+Available fit functions: 
+  1-20 Gaussian, Lorentzian or Gaussian folded with Lorentzian 
+  Critical exponents, Strange peaks, User defineable functions 
+  
+Data files supported: 
+  TASMAD, NeXus (DMC, HRPT, FOCUS, MARS, RITA) 
+  ASCII multicolumn format, SICS ascii, 
+  LNS Powder Ascii, TASCOM, Fullprof plot output 
+  5c2, INX, IDA, 2T, PANDA, CCL 
+  
+Most fit commands can also be linked to a user FORTRAN program. 
+  
+Report bugs & wishes to markus.zolliker@psi.ch 
+  
+Topic                                    Available keyword 
+----------------------------------------------------------------------------- 
+Command syntax                           commands 
+Features in plot window                  graphics 
+New features since 1990                  history 
+Programming your own user function       user_function  cinfo  init 
+Control FIT from a FORTRAN program       callable 
+Fortran interface of any FIT command     fit_X (where X is any FIT command) 
+Datafile specific options                opt 
+  
+Commands             Available keywords 
+----------------------------------------------------------------------------- 
+fitting commands:    fit mig sim epsi vtest err pri 
+function definiton:  fun auto newpeak 
+parameter handling:  set lim fix cor rel fcn reserr 
+input:               load dat link next opt 
+output:              save file out list export 
+fit region:          win exclude include keep 
+data manipulation:   mon merge mul sub add abskor trans bgedit 
+plot:                plot scal rsc choose plog plin file 
+plot style:          bars connect style colors legend 
+miscellaneous:       help info exit tit @ 
+
+

+Syntax of an interactive command: 
+  
+Command   parameter1,parameter2,parameter3,... 
+  
+If you omit some parameters, usually default values are taken or, 
+if it is explicitly documented, the program asks for missing 
+parameters. 
+Some commands can be shortened (indicated in brackets []) 
+
+

+FIT n    Start fitting by minimum gradient method (Davidon-Fletcher-Powell 
+[F]      algorithm). If the algorithm fails, simplex is called. 
+  
+MIG n    Start fitting by minimum gradient method. Even if the algorithm 
+         fails, simplex is not called. 
+  
+SIM n    Start fitting by simplex method. 
+  
+MIN n    Start fitting by simplex followed by gradient method 
+[M] 
+     (n: Limit for the number of function calls, default n=1000) 
+  
+ERR f    Errors correspond to a FCN change of f (default: f=1.0). 
+  
+         FCN = sum over { (Ycal(i)-Yobs(i)) / Sig(i) }**2 
+         Chi**2 = FCN / Nfree 
+  
+EPSI e   Convergence criterion (Estimated distance to minimum). 
+         Default e=0.1*f 
+  
+VTEST v  Second convergence criterion for gradient method 
+         (fractional change in variance matrix). Default: v=0.01 
+  
+PRI i    Amount of printout during fit algorithm (i=0..5, default: i=0) 
+
+

+FCN            Show all parameters 
+  
+SET i,v,e      Set parameter i to value v with estimated error e 
+i=v,e          Alternative command syntax 
+  
+LIM i,l,u      Set limits of parameter i to l and u. 
+LIM i          Remove limits of parameter i 
+  
+SET i,v,e,l,u  a combination of the commands SET and LIM 
+  
+FIX i,j,...    FIX parameter i and j and ... at actual value 
+  
+COR i,j,f,c    Correlate parameters p(i)=p(j)*f+c 
+               Default: f=1.0, c=0.0 
+  
+REL i,j,...    Release parameter i and j and ... from FIX or COR 
+               If MaxInt or IntInt is released, the other of the two will be 
+               correlated automatically. 
+REL            Release all parameters 
+  
+RESERR         should be called when after an unsuccesful fit the errors are 
+               set to very small values. A further FIT step will then often 
+               be successful. 
+  
+Note: instead of the parameter number i you can use the short parameter name. 
+
+

+LOAD filename     Load data and parameters. 
+LOAD              Ask for filename to load context. 
+  
+DAT               Ask for filetype, filename/version number 
+                    (parameters are not loaded) 
+DAT filelist      Load data file(s) (syntax for filelist see below) 
+  
+LINK filelist     Add more data (syntax for filelist see below) 
+  
+NEXT       [N]    The same as DAT; MON; WIN; BARS; FUN 
+  
+Filelist syntax examples: 
+  
+101,103-105        Read numors 101,103,104,105 (actual year, actual instrument) 
+TASP/2000/10       Read numor 10 (year 2000 from TASP) 
+dmc/33             Read numor 33 from DMC (actual year, case not relevant) 
+2001/203,2002/10   Read numor 203 from 2001 and numor 10 from 2002 
+&101,103-105       Read numors 101,103,104,105 and merge them 
++103-105           Read numors 103-105, conserving old data (as in the LINK command) 
+  
+Example with options (see also command OPT): 
+  
+focus/101[bank=b]  Read middle bank from numor 101 on focus 
+
+

+You can preset options with the OPT command for successive data input, or 
+you may specify the options directly after the filename or numor enclosed 
+by square brackets [ ]. 
+  
+OPT     Show a list of options for the type of the last read 
+        file, show the previous selected options, and enter new options 
+  
+OPT ?   Show a list of possible options and actually selected options 
+
+

+SAVE filename         Save data, fit parameters, window and scaling 
+SAVE                  Ask for filename before saving 
+  
+FILE xstep, filename  Save two files with observed and calculated dataset 
+                      for other plot software (xstep for calculated dataset, 
+                      xstep=0: a default value of (xmax-xmin)/100 is taken). 
+                      Give TT as filename for output at terminal directly 
+FILE                  Ask for filename and step 
+  
+LIST [L]              Listing on terminal (x, y, yfit) 
+  
+OUT                   Output of listing (not a program-readable format!) 
+  
+OPEN file             Open a file for output of fit results (default: fit.txt) 
+  
+K par1,par2 ..        (K=keep) Write a line with values of given parameters 
+K                     Write parameters used last time or all parameters 
+                      You might use 'K' in the plot window for this command 
+  
+EXPORT type,filename  export data (file types available: DMC, D1A) 
+EXPORT step,type,filename   export with given x step 
+
+

+WIN xmin,xmax            Set fit window. 
+WIN                      Ask for fit window 
+WIN 1,1                  Maximal fit window. 
+[W] 
+  
+EXCLUDE x1,x2            Exclude range x1..x2 
+EXCLUDE x1,x2,y1,y2      Exclude rectangle (x1,x2,y1,y2) 
+EXCLUDE 1,1,y1,y2        Exclude range y1..y2 
+[EXCL] 
+  
+INCLUDE ...              Re-include regions (syntax as for EXCLUDE) 
+[INCL] 
+  
+KEEP                     List window and in-/excluded regions and 
+                           ask if they have to be kept on new data 
+KEEP Y                   Enable persistent window/regions 
+KEEP N                   Disable persistent window/regions 
+
+

+MON m            Change Monitor 
+MON              Ask for Monitor 
+  
+USEMON           Choose which channel to use as monitor 
+  
+MERGE s          Add datapoints with same x (within a limit s). 
+                 If s is omitted, it is determined automatically 
+                 Overall monitor is changed, if appropriate 
+  
+MUL s1,s2,s3...  Multiply datasets with scale factor. 
+  
+ABSKOR muR,ri,ra Correct for absorption 
+                 muR<0 inverse correction (muR as for a full cylinder) 
+                 ri>0: hollow cylinder (inner radius/outer radius) 
+                 ra: sample radius/radial collimator fwhm 
+  
+TRANS d,lambda   Transform x-axis from to d (powder diffraction) 
+TRANS q          Transform x-axis to q (lambda is taken from file or last cmd) 
+TRANS 2theta     Transform back to 2-Theta 
+TRANS            Ask for x-axis to transform to 
+  
+SUB filename     Subtract a file from actual data 
+  
+ADD constant     Add a constant to data 
+  
+BGEDIT file      Edit graphically a background file 
+[BG] 
+
+

+FUN            Ask for fit function and start parameters. 
+  
+FUN n          Select fit function n (ask for start parameters, if needed) 
+  
+               n=0,1  Single Gaussian/Lorentzian  (auto start parameters) 
+               n=2,3  Multiple (1..4) Gaussian/Lorentzian 
+               n=4    Gaussian+Lorentzian 
+               n=5    Critical exponent 
+               n=6    Strange peak (auto start parameters) 
+               n=7    User function (see topic User_function) 
+               n=8    Plot only (no parameters) 
+  
+AUTO           Determine start values for first peak (for function 0,1,2,3,4) 
+  
+NEWPEAK        Create a new peak (for function 0,1,2,3,4). 
+  
+               Delete a peak by setting intensity and error to zero. 
+
+

+PLOT               [P]    Plot (See also topic Graphics) 
+PLOT  yes                 Plot, make hardcopy file and do not wait. 
+PLOT  auto                automatic plot after every command 
+PLOT  off                 switch off automatic plot 
+  
+SCAL xmin,xmax,ymin,ymax  Set plot scale 
+SCAL              [SC]    Ask for scale 
+  
+RSC                       Reset plot scale (auto scale). 
+  
+PLOG shift                Set logarithmic mode (and set shift between datasets) 
+PLIN shift                Set linear mode (and set shift between datasets) 
+  
+CHOOSE           [CHO]    Select printer and printer options 
+  
+See also: 
+  
+  FILE  (export for other plot software) 
+  STYLE (plot style, legend) 
+  Graphics (hot keys in plot window) 
+
+

+BARS Yes/No               Enable/disable error bars. 
+  
+CONNECT Yes/No   [CON]    Enable/disable lines between data points 
+  
+STYLE s1,s2,s3...         Change style of dataset points 
+STYLE                     Ask for dataset styles 
+  
+COLORS           [COL]    Use colors for different datasets 
+COLORS n                  Use n colors for different datasets 
+COLORS 0                  Use black and white 
+  
+NCURVES n                 Set number of curves for User-Function 
+  
+LEGEND           [LEG]    Show legend (Numor is default) 
+LEGEND var                Use 'var' for legend ('LEGEND Temp' for temperature) 
+LEGEND 0                  Do not show legend 
+LEGEND label1|label2|label3 .... 
+                          Show a customized legend 
+LEGEND |label4|label5|label6 .... 
+                          Append to a customized legend 
+LEGEND @x,y               Set top left coordinate of legend (percent of window 
+                          width/height, y is measured from the top) 
+  
+See also: 
+  PLOT  (other commands related to plot) 
+  Graphics (hot keys in plot window) 
+
+

+@filename              Execute commandfile 
+  
+HELP            [H]    Get help 
+HELP command           Get help on command. 
+  
+INFO                   Show additional information from the last 
+                       read data file. 
+INFO level             level is a small number controlling the amount 
+                       of output for the info command 
+  
+INFO variable          show the value of this variable 
+  
+variable=value         set a variable 
+  
+EXIT           [EX]    Exit program and save parameters and datapoints. 
+  
+QUIT           [QU]    Quit program without saving.. 
+  
+TITLE title   [TIT]    Change title. 
+TITLE                  Ask for title. 
+  
+FULLMESS               After this command, error messages are more detailed, and 
+                       the program quits after an error. 
+
+

+On Unix: 
+  
+  Get an example file:    myfit 
+  
+  Rename fitexample.f to a name of your choice (i.e. xxx.f) 
+  and edit the parameters and the fit function. 
+  
+  Compile:                myfit -o xxx xxx.f 
+  Run:                    ./xxx 
+  
+You may add any g77 option or parameter to the myfit argument list. 
+  
+  
+On VMS: 
+  
+To define your own user function, type MYFIT and change the file 
+FIT.FOR to your own function, rename the file to your own program 
+name xxx, compile it, link the program with 
+  
+  LINK xxx,FIT4_SHR/OPT 
+  
+and start your program with 
+  
+  RUN xxx 
+  
+  
+Related keywords: init     (inititalisation of user function) 
+                  function () 
+                  cinfo    (how to speed up complex fit functions) 
+
+

+User function initialisation 
+  
+You have to call FIT_USERFUN to define title and function reference, and 
+you have to call FIT_USERPAR to define the name of each parameter. 
+Short name of variables can be given before long name, separated by 
+a colon ':'. 
+  
+Call FIT_MAIN afterwards to switch to fit command mode. 
+  
+If you want to keep control by program, you can call almost 
+every command (prefix FIT_, i.e. for plot you call FIT_PLOT). 
+In that case you must call FIT_INIT before calling other subroutines. 
+  
+Short help is available under the name of the subroutine. 
+
+

+You have to program a user function, whitch will be called from three 
+different places within FIT: 
+  
+1.  when command FUN is called or a new function is loaded: 
+    MODE=-1 
+    all other arguments are undefined 
+  
+2.  before each calculation of Chi-Square, i.e. before each Fit-Step: 
+    MODE=1 
+    X=0.0 
+    N:       number of parameters 
+    P(1..N): parameters 
+    CINFO:   Info about changed parameters (See Topic CINFO) 
+  
+3.  for each point of Dataset(s) and when plotting function: 
+    MODE=0 
+    X:       X-value 
+    N:       number of parameters 
+    P(1..N): parameters 
+    CINFO:   Dataset number or curve number 
+
+

+how to speed up complex fit functions 
+  
+this section is useful only, if the main part of the calculation 
+does not depend on X, i.e. matrix diagonalisation 
+  
+- split your calculation into several parts 
+- the subroutine FIT_USERCINFO(CINFO) determine the dependencies of the 
+  calc. parts and the parameters. The integer CINFO is a bit map, where 
+  each bit corresponds to a part of the calculation. The bit should be 
+  set if the part depends on the parameters named in the following calls 
+  to FIT_USERPAR. 
+- The integer CINFO within the fit user function determines, which 
+  part of the calculation has to be redone (corresponding 
+  bit set) and which part remains unchanged (bit clear) 
+
+

+For example for automatic fitting of many files, you probably want 
+to call the fit-commands from a FORTRAN program. Before any call 
+to the FIT subroutines you have to call FIT_INIT. 
+  
+                        for instructions on compile and link see topic build 
+  
+Explanations for the topics below: 
+  
+Specified arguments:   Call with specified arguments. 
+Default arguments:     For unspecified arguments, the subroutine uses 
+                       default values. 
+Ask for arguments:     The subroutine asks for unspecified arguments. 
+                       If you want to start your program in batch 
+                       mode you normally have to avoid these calls. 
+  
+Available routines (use routine name as help keyword): 
+------------------------------------------------------- 
+fitting:            fit_fit fit_sim fit_min fit_chisq 
+                    fit_pri fit_err fit_epsi fit_vtest 
+function definiton: fit_fun fit_newpeak fit_auto 
+parameter handling: fit_set fit_fix fit_rel fit_cor fit_get_array 
+input / output:     fit_save fit_load fit_init fit_command fit_exit fit_range 
+                    fit_dat fit_link 
+data manipulation:  fit_win fit_mon fit_dat fit_link fit_subtract fit_merge 
+                    fit_auto_mon fit_multiply fit_add fit_abskor 
+                    fit_dat_put fit_bgedit fit_keep 
+                    fit_include fit_exclude 
+                    fit_get_array, fit_get_real, fit_get_str 
+                    fit_put_array, fit_put_real, fit_put_str 
+plot:               fit_plot fit_scale fit_rsc fit_bars fit_connect fit_title 
+                    fit_file 
+user commands:      fit_usercmd 
+                    arg_check_cmd arg_str arg_real arg_int arg_par arg_lit 
+library routines:   str_upcase, str_trim, str_append 
+                    sys_get_cmdpar, sys_setenv, sys_getenv 
+
+

+Specified arguments        Default arguments     Default value 
+-------------------------------------------------------------- 
+CALL FIT_FIT(n)            CALL FIT_FIT(0)       n=1000 
+CALL FIT_SIM(n)            CALL FIT_SIM(0)       n=1000 
+CALL FIT_MIN(n)            CALL FIT_MIN(0)       n=1000 
+CALL FIT_PRI(n)            CALL FIT_PRI(0)       n=0 
+CALL FIT_ERR(err)          CALL FIT_ERR(0)       err=0.5 
+CALL FIT_EPSI(eps)         CALL FIT_EPSI(0)      eps=0,1*err 
+CALL FIT_VTEST(v)          CALL FIT_VTEST(0)     vtest=0.01 
+  
+CALL FIT_CHISQ(chisq, istat)    get chi square and fit success status 
+  
+     INTEGER n, istat 
+     REAL err,eps,v, chisq 
+  
+
+

+Specified arguments        Default arguments        Default value 
+------------------------------------------------------------------ 
+CALL FIT_SET(i,p,e,l,u)    CALL FIT_SET(i,p,e,0,0)  l=0,u=0: no limit 
+CALL FIT_LIM(i,l,u) 
+CALL FIT_FIX(i) 
+CALL FIT_REL(i) 
+CALL FIT_COR(i,j,f,c)      CALL FIT_COR(i,j,0,0)    f=1.0, c=0.0 
+  
+     INTEGER i, j 
+     REAL p, e, l, u, f, c 
+
+

+Get and put parameters and or data 
+  
+CALL FIT_GET_ARRAY(name, array, ndim, nret) 
+where: 
+     INTEGER ndim                ! dimension (input) 
+     REAL array(ndim)            ! resultant array (output) 
+     INTEGER nret                ! array length returned (output) 
+     CHARACTER*(*) name          ! name of array 
+                            ! 'P': fit parameter, 'E': parameter error 
+                            ! 'X','Y': data, 'S': data error, 'W': data weight 
+  
+CALL FIT_PUT_ARRAY(name, array, nlen) 
+where: 
+     INTEGER nlen                ! length of array (must match length of data) 
+     REAL array(nlen)            ! array (input) 
+     CHARACTER*(*) name          ! name of array 
+                            ! 'X','Y': data, 'S': data error, 'W': data weight 
+                            ! to change parameters use subroutine FIT_SET 
+  
+CALL FIT_GET_REAL(name, value) 
+CALL FIT_GET_STR(name, l, str) 
+CALL FIT_PUT_REAL(name, value) 
+CALL FIT_PUT_STR(name, str) 
+where: 
+     REAL value          ! value to get or put 
+     INTEGER l           ! string length returned 
+     CHARACTER*(*) str   ! value to get or put 
+     CHARACTER*(*) name  ! call INFO 99 to see what variables are available 
+
+

+User defineable commands 
+  
+CALL FIT_USERCMD(cmds)        ! install command dispatch routine 
+  
+logical fucntion to check command: 
+ARG_CHECK_CMD(command, len)   ! check for command (significant length: len) 
+  
+subroutines returning arguments: 
+  
+CALL ARG_REAL(value, default) ! get a real value argument from command line 
+CALL ARG_INT(value, default)  ! get an integer value argument from command line 
+CALL ARG_PAR(value)           ! get a parameter name/number as argument from .. 
+CALL ARG_LIT(string)          ! get a name as argument from command line 
+CALL ARG_STR(string)          ! get remaining arguments as string from comm... 
+  
+Usage: 
+    external cmds 
+    call fit_usercmd(cmds)    ! call this within main module, after fit_init 
+  
+    subroutine cmds(done)         ! subroutine to define 
+    logical done 
+  
+    if (arg_check_cmd('DAT', 3)) then 
+      ... treat command dat ... 
+      done=.true. 
+    elseif (arg_check_cmd('PLOT', 1)) then ! P is accepted as well 
+      ... treat command plot ... 
+      done=.true. 
+    endif 
+    end 
+
+

+Specified arguments        Default arguments        Ask for arguments 
+--------------------------------------------------------------------- 
+CALL FIT_DAT(filename)                              CALL FIT_DAT(' ') 
+CALL FIT_WIN(xmin, xmax)   CALL FIT_WIN(1.,1.) (= max. window) 
+                                                    CALL FIT_WIN(0,0) 
+  
+CALL FIT_MON(m)                                     CALL FIT_MON(0) 
+CALL FIT_USEMON(m)                                  CALL FIT_USEMON(0) 
+CALL FIT_LINK(filename)                             CALL FIT_LINK(' ') 
+CALL FIT_SUBTRACT(filename)                         CALL FIT_SUBTRACT(' ') 
+  
+CALL FIT_RANGE(r1, r2, filenames) ! attention: r1, r2 are REALs 
+  
+CALL FIT_MERGE(step)       CALL FIT_MERGE(0.0) 
+CALL FIT_AUTO_MON                adjust monitor after a FIT_MERGE 
+  
+CALL FIT_MULTIPLY(scale,0)       one scale factor for all data 
+CALL FIT_MULTIPLY(scale,n)       scale is an array of factors for each dataset 
+  
+CALL FIT_ABSKOR(mur,ri)                             CALL FIT_ABSKOR(0.0,0.0) 
+CALL FIT_ABSKOR2(mur,ri,ra)                         CALL FIT_ABSKOR(0.0,0.0,0.0) 
+  
+CALL FIT_ADD(const,0)       const to add to all data 
+CALL FIT_ADD(const,n)       const is an array for constants for each dataset 
+  
+CALL FIT_BGEDIT(file) 
+  
+CALL FIT_EXCLUDE(x1,x2,y1,y2) 
+  
+CALL FIT_INCLUDE(x1,x2,y1,y2) 
+  
+CALL FIT_KEEP('Y')                                  CALL FIT_KEEP(' ') 
+CALL FIT_KEEP('N') 
+
+

+Put new datapoints into FIT 
+  
+CALL FIT_DAT_PUT(mode, x, nx, y, ny, s, ns, w, nw) 
+where: 
+     INTEGER mode   ! 0: purge before, 1: link new dataset, 2: link to existing dataset 
+     INTEGER nx     ! nx=1: x-values are xx(1),xx(1)+1,xx(1)+2,...,xx(1)+(nx-1) 
+     INTEGER ny     ! number of data points 
+     INTEGER ns     ! ns=1: ss(1) <> 0.0: sigma values are ss(1) 
+                    !       ss(1) =  0.0: sigma values are sqrt(max(1.0,yy(i))) 
+     INTEGER nw     ! nw=1: weights are ww(1) 
+     REAL xx(nx)    ! x-values 
+     REAL yy(ny)    ! y-values 
+     REAL ss(ns)    ! sigma values 
+     REAL ww(nw)    ! weights 
+  
+! precondition: (ny>0) and (nx=ny or nx=1 or nx=2) 
+!           and (nx=ny or ns=1) and (nw=ny or nw=1) 
+  
+
+

+Specified/auto arguments        Ask for start parameters 
+---------------------------------------------------------------------- 
+CALL FIT_FUN(0, 0, 0.0,0.0)                         Gaussian 
+CALL FIT_FUN(1, 0, 0.0,0.0)                         Voigtian 
+CALL FIT_FUN(0, 1, pos,poserr)                      Gaussian at given start pos 
+CALL FIT_FUN(1, 1, pos,poserr)                      Voigtian at given start pos 
+CALL FIT_FUN(2, n, par,err)     CALL FIT_FUN(2, 0)  Multi-Gaussian 
+CALL FIT_FUN(3, n, par,err)     CALL FIT_FUN(3, 0)  Multi-Voigtian 
+CALL FIT_FUN(4, 12,par,err)     CALL FIT_FUN(4, 0)  Gaussian+Voigtian 
+                                CALL FIT_FUN(5)     Crit. exponent 
+CALL FIT_FUN(6, 0, 0.0,0.0)                         Strange 
+CALL FIT_FUN(7, n, par,err)     CALL FIT_FUN(7, 0)  User function 
+CALL FIT_FUN(8, 0, 0.0,0.0)                         Plot only 
+  
+                                Ask for function and start parameters 
+                                ------------------------------------- 
+                                CALL FIT_FUN(-1, 0) 
+  
+CALL FIT_NEWPEAK 
+CALL FIT_AUTO 
+  
+where: 
+    REAL par(np), err(np), pos, poserr 
+    INTEGER n 
+
+

+Specified arguments        Default arguments      Ask for arguments 
+----------------------------------------------------------------------- 
+CALL FIT_PLOT('Y')                                CALL FIT_PLOT(' ') 
+CALL FIT_SCALE(x1,x2,y1,y2) 
+                                                  CALL FIT_SCALE(0,0,0,0) 
+  
+                           CALL FIT_SCAL(1.,1.,y1,y2)   (auto x-range) 
+                           CALL FIT_SCAL(x1,y1,1.,1.)   (auto y-range) 
+CALL FIT_RSC (auto range) 
+  
+CALL FIT_BARS('Y')                                CALL FIT_BARS(' ') 
+CALL FIT_BARS('N') 
+CALL FIT_CONNECT('Y')                             CALL FIT_CONNECT(' ') 
+CALL FIT_CONNECT('N') 
+CALL FIT_PLOG(log,shift) ! log=0,1 
+CALL FIT_TITLE(title)                             CALL FIT_TITLE(' ') 
+CALL FIT_FILE(xstep, filename)                    CALL FIT_FILE(0,' ') 
+
+

+Specified arguments    Ask for filename 
+--------------------------------------- 
+CALL FIT_PRINT(1)                   (equivalent to command FCN) 
+CALL FIT_PRINT(0)                   (print variable parameters) 
+                       CALL FIT_LIST 
+                       CALL FIT_OUT 
+
+

+Specified arguments        Ask for arguments 
+-------------------------------------------- 
+CALL FIT_SAVE(filename)    CALL FIT_SAVE(' ') 
+CALL FIT_LOAD(filename)    CALL FIT_LOAD(' ') 
+CALL FIT_EXPORT(step, type, filename)   (auto step: step=0) 
+  
+CALL FIT_INIT                        (has to be called first) 
+CALL FIT_COMMAND(filename)           (equivalent to command @filename) 
+CALL FIT_COMMAND('  ')               (switch to interactive mode) 
+CALL FIT_EXIT 
+
+

+CALL FIT_USERFUN(title,function)  define user function (has to be called 
+                                  before FIT_USERPAR 
+CALL FIT_USERPAR(name)            define user parameter name (call once 
+                                  for each parameter) 
+CALL FIT_USERCINFO(mask)          define user calculation info mask for 
+                                  following calls to FIT_USERPAR 
+CALL FIT_MAIN                     start fit command mode 
+
+

+CALL STR_UPCASE(out, in)           convert to upper case 
+CALL STR_TRIM(out, in, length)     determine string length without trailing space 
+CALL STR_APPEND(inout, length, in) append in to inout(1:length) 
+  
+CALL SYS_GET_CMDPAR(out, length)   get command line parameters 
+CALL SYS_SETENV(name, value)       set environment variable 
+CALL SYS_GETENV(name, value)       get environment variable 
+
+

+Within the graphic window, you hit a key for a command: 
+  
+Command        Shortcut 
+  
+Print          P     Printing Graphics 
+Insert         I     Insert peak at the actual x/y position. 
+                     the halfwidth is determined automaticaly. 
+                     (BGEDIT: insert point) 
+Delete         D     Delete peak (BGEDIT: delete point) 
+Repaint        R     Repaint graph 
+Zoom in        Z     Zoom in*. 
+Zoom out       O     Zoom out by a factor 2:1 
+Jump           J     Center graph at cursor position without changing scale 
+max.Scale      X     Automatic scaling (observed data fits the data window) 
+Window         W     Set fit window* 
+Exclude        E     Mark excluded region* 
+Include        N     Mark region to re-include* 
+Log/Lin        L     Switch between log and lin 
+Colors         C     Switch between colors and b/w 
+Show Coord.    S     Show (X,Y) value of cursor 
+Quit           Q     Leave graphic user-interface 
+  
+* move to the first corner, click the correspoding key, move to the second 
+  corner, press the key again. If you want to perform the command only in one 
+  dimension, move to locations below the x-axis or left to the y-axis. 
+
+

+Version 2.0 
+- FIT saves all parameters and the data file name on exit. 
+- You can now enter directly to command mode by pressing RETURN at the 
+    first prompt. 
+- The parameters of most commands can now be passed directly via 
+    command line. 
+- Command line editing (recall of previous 20 commands). 
+- Command-files can be executed. 
+- Old command WIN is now separated into the commands WIN, MON and BARS. 
+- New command MIG (call migrad only) 
+- Abort of fit algorithm by pressing  (return to command level). 
+- All commands of FIT are now callable FORTRAN subroutines. 
+- Enhanced user fit-function definition. 
+- Extended HELP 
+  
+Version 3.0 
+- All peak functions (Gaussian, Lorentzian, Voigtian) have now the same 
+    parameters and switching between them can be done by changing parameters 
+    (If fwhm L = 0: Gaussian, if fwhm G =0: pure Lorentzian, else Voigtian) 
+- Graphics package is changed from PLOT10 to GRAPHX. FIT runs now on most 
+    graphic devices, including X-Window. 
+- Graphic user-interface: zoom, edit peaks, create new peaks, delete peaks. 
+- New peaks can be created by command NEWPEAK 
+- Peaks can be deleted by setting intensity to 0 
+- New command CHOOSE (printer options) 
+- COR i1,i2,f no longer has the restriction i1>i2 
+  
+Version 3.3 
+- Load multiple data files 
+- Command LINK to load additional data 
+- Data from different files are plotted with different symbols 
+- Command MERGE to add points with same X-value 
+- New data file types available: IN3, D1A5, D1A6, 3-column 
+  
+Version 3.5 
+- MULtiply data with scale factor 
+- SUBtract datafiles 
+- D2B-files readable 
+  
+Version 3.6 
+- Data can be saved as DMC or D1A format 
+     use command SAVE with extension .DMC (or .D1A respectively) 
+- Command ABSKOR for absorption correction 
+- Parameter can be given as name instead of number (Example: FIX P1 = FIX 3) 
+- Short form for SET command. Example:  G1=0.4 
+- Command STYLE to set marker symbols or to connect points 
+- Enhanced output for Mac Plot Software (Kaleidagraph, ProFit...) 
+     use command FILE TT and Copy-Table in VersaTerm 
+- New command AUTO: determine start-values for Gaussian Fit without loosing 
+     FIX and COR settings. 
+- Bug corrected: Sometimes fit was not correct and errors were very small 
+     after a DAT command. This is now corrected. 
+  
+Version 3.7 
+- Command CONNECT Y to connect data points 
+  
+Version 4.0 
+- Now available on Digital Unix 
+- PGPLOT Graphics package instead of GRAPHX 
+  
+Version 4.1 
+- Background editing command BGEDIT (replaces GEDIT program) 
+- Export command (actually supporting DMC and D1A datafile type) 
+- Enhanced Fortran-Interface 
+  
+Version 4.2 
+- ADD a constant do data 
+- new data types: INX, CCL 
+- RANGE command for 2D data and multi-dataset files like INX or CCL 
+- subroutine FIT_DAT_PUT: load data from memory of calling program 
+- subroutines FIT_GET_ARRAY, FIT_GET_REAL and FIT_GET_STR: inquire data 
+    and parameters 
+- subroutines FIT_PUT_ARRAY, FIT_PUT_REAL and FIT_PUT_STR: modifiy data 
+- subroutine FIT_USERCMD: plug-in commands 
+- subroutine FIT_DAT_MERGE: fit_dat and fit_merge in one command 
+    (to avoid memory overflow) 
+- made available some library soutines: STR_UPCASE, STR_TRIM, STR_APPEND 
+    SYS_GET_CMDPAR, SYS_SETENV, SYS_GETENV 
+- subroutine FIT_VERS: get actual version 
+  
+Version 4.3 
+- new commands EXCLUDE, INCLUDE: excluded regions 
+- new command KEEP: persistent fit-window (select if fit window and 
+    excluded regions are kept on DAT command) 
+  
+Version 4.4 
+- new commands PLOG and PLIN for logarithmic plots and shifted 
+  datasets 
+- new commands LEGEND and COLORS 
+- can read RITA single detector files 
+  
+Version 4.5 
+- absorption correction for hollow cylinders 
+- plot fullprof output files 
+- new command TRANS (transform x-axis between 2theta/d/q for powder diffraction) 
+- more options for calibration of powder diffraction data 
+- user function may be folded with gaussian (example: program BOSE) 
+- can read HDF5 files (TriCS NeXus files) 
+
diff --git a/rhel7/libreadline.so b/rhel7/libreadline.so new file mode 120000 index 0000000..e1c0d5f --- /dev/null +++ b/rhel7/libreadline.so @@ -0,0 +1 @@ +/usr/lib64/libreadline.so.6 \ No newline at end of file diff --git a/rhel7/src b/rhel7/src new file mode 120000 index 0000000..d20e0bc --- /dev/null +++ b/rhel7/src @@ -0,0 +1 @@ +/afs/psi.ch/user/z/zolliker/public/fit/src/. \ No newline at end of file diff --git a/unix/CVS/Entries b/unix/CVS/Entries new file mode 100644 index 0000000..505c1d3 --- /dev/null +++ b/unix/CVS/Entries @@ -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// diff --git a/unix/CVS/Repository b/unix/CVS/Repository new file mode 100644 index 0000000..c22617a --- /dev/null +++ b/unix/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/unix diff --git a/unix/CVS/Root b/unix/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/unix/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/unix/cfg/CVS/Entries b/unix/cfg/CVS/Entries new file mode 100644 index 0000000..5835182 --- /dev/null +++ b/unix/cfg/CVS/Entries @@ -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 diff --git a/unix/cfg/CVS/Repository b/unix/cfg/CVS/Repository new file mode 100644 index 0000000..99767a6 --- /dev/null +++ b/unix/cfg/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/unix/cfg diff --git a/unix/cfg/CVS/Root b/unix/cfg/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/unix/cfg/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/unix/cfg/linux b/unix/cfg/linux new file mode 100644 index 0000000..5e0395b --- /dev/null +++ b/unix/cfg/linux @@ -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 diff --git a/unix/cfg/macosx b/unix/cfg/macosx new file mode 100644 index 0000000..443fc47 --- /dev/null +++ b/unix/cfg/macosx @@ -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 + diff --git a/unix/cfg/tru64 b/unix/cfg/tru64 new file mode 100644 index 0000000..d72aef5 --- /dev/null +++ b/unix/cfg/tru64 @@ -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 + diff --git a/unix/cfg/zm_fit b/unix/cfg/zm_fit new file mode 100644 index 0000000..2b71f58 --- /dev/null +++ b/unix/cfg/zm_fit @@ -0,0 +1 @@ +this file is used by config diff --git a/unix/fitv b/unix/fitv new file mode 100755 index 0000000..bc94862 --- /dev/null +++ b/unix/fitv @@ -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 diff --git a/unix/myc_tmp.c b/unix/myc_tmp.c new file mode 100755 index 0000000..eadebfc --- /dev/null +++ b/unix/myc_tmp.c @@ -0,0 +1,98 @@ +#include +#include +#include +#include +#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(); +} diff --git a/unix/myc_tmp.h b/unix/myc_tmp.h new file mode 100755 index 0000000..10c8e53 --- /dev/null +++ b/unix/myc_tmp.h @@ -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 diff --git a/unix/napif.f b/unix/napif.f new file mode 100644 index 0000000..d72ff3e --- /dev/null +++ b/unix/napif.f @@ -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 +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 diff --git a/unix/sys.f b/unix/sys.f new file mode 100755 index 0000000..81e7015 --- /dev/null +++ b/unix/sys.f @@ -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 diff --git a/unix/sys1.f b/unix/sys1.f new file mode 100644 index 0000000..0053cec --- /dev/null +++ b/unix/sys1.f @@ -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 diff --git a/unix/sys3.f b/unix/sys3.f new file mode 100644 index 0000000..bb42dcc --- /dev/null +++ b/unix/sys3.f @@ -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 diff --git a/unix/sys_cmdpar.f b/unix/sys_cmdpar.f new file mode 100644 index 0000000..1bed707 --- /dev/null +++ b/unix/sys_cmdpar.f @@ -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 diff --git a/unix/sys_date.f b/unix/sys_date.f new file mode 100644 index 0000000..17ebc57 --- /dev/null +++ b/unix/sys_date.f @@ -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 diff --git a/unix/sys_env.c b/unix/sys_env.c new file mode 100755 index 0000000..2823164 --- /dev/null +++ b/unix/sys_env.c @@ -0,0 +1,181 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#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; +} diff --git a/unix/sys_file.f b/unix/sys_file.f new file mode 100644 index 0000000..c259292 --- /dev/null +++ b/unix/sys_file.f @@ -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 diff --git a/unix/sys_fun.c b/unix/sys_fun.c new file mode 100644 index 0000000..a21eac4 --- /dev/null +++ b/unix/sys_fun.c @@ -0,0 +1,5 @@ +#include "myc_fortran.h" + +void F_FUN(sys_funadr)(void (*f)(void), void (**a)(void)) { + *a=f; +} diff --git a/unix/sys_fvi.c b/unix/sys_fvi.c new file mode 100644 index 0000000..a2ed519 --- /dev/null +++ b/unix/sys_fvi.c @@ -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));} diff --git a/unix/sys_getenv.f b/unix/sys_getenv.f new file mode 100644 index 0000000..ca1243a --- /dev/null +++ b/unix/sys_getenv.f @@ -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 diff --git a/unix/sys_home.f b/unix/sys_home.f new file mode 100644 index 0000000..0bcd906 --- /dev/null +++ b/unix/sys_home.f @@ -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 diff --git a/unix/sys_lun.f b/unix/sys_lun.f new file mode 100644 index 0000000..48dfb7a --- /dev/null +++ b/unix/sys_lun.f @@ -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 diff --git a/unix/sys_open.f b/unix/sys_open.f new file mode 100644 index 0000000..c0094fe --- /dev/null +++ b/unix/sys_open.f @@ -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 diff --git a/unix/sys_parse.f b/unix/sys_parse.f new file mode 100644 index 0000000..633439c --- /dev/null +++ b/unix/sys_parse.f @@ -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 diff --git a/unix/sys_rdline.c b/unix/sys_rdline.c new file mode 100644 index 0000000..6ba0006 --- /dev/null +++ b/unix/sys_rdline.c @@ -0,0 +1,40 @@ +#include +#include +#include +#include +#include +#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; + } +} + + diff --git a/unix/sys_rdline0.c b/unix/sys_rdline0.c new file mode 100644 index 0000000..3e0e535 --- /dev/null +++ b/unix/sys_rdline0.c @@ -0,0 +1,29 @@ +#include +#include +#include +#include +#include +#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; + } +} diff --git a/unix/sys_remote_host.f b/unix/sys_remote_host.f new file mode 100755 index 0000000..653ccc6 --- /dev/null +++ b/unix/sys_remote_host.f @@ -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 diff --git a/unix/sys_try.c b/unix/sys_try.c new file mode 100644 index 0000000..20a4617 --- /dev/null +++ b/unix/sys_try.c @@ -0,0 +1,56 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#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); +} diff --git a/unix/sys_unix.c b/unix/sys_unix.c new file mode 100644 index 0000000..64b0a23 --- /dev/null +++ b/unix/sys_unix.c @@ -0,0 +1,167 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#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; i0)) + { 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");}; +} + diff --git a/unix/sys_wait.f b/unix/sys_wait.f new file mode 100644 index 0000000..17fae65 --- /dev/null +++ b/unix/sys_wait.f @@ -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 diff --git a/unix/sysc.c b/unix/sysc.c new file mode 100755 index 0000000..59aa335 --- /dev/null +++ b/unix/sysc.c @@ -0,0 +1,274 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#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; i0)) + { 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); +} diff --git a/unix/sysc1.c b/unix/sysc1.c new file mode 100644 index 0000000..f396101 --- /dev/null +++ b/unix/sysc1.c @@ -0,0 +1,100 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#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); +} diff --git a/unix/terinq.f b/unix/terinq.f new file mode 100644 index 0000000..5e3736d --- /dev/null +++ b/unix/terinq.f @@ -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 diff --git a/unix/terinq_new.f b/unix/terinq_new.f new file mode 100644 index 0000000..ce19755 --- /dev/null +++ b/unix/terinq_new.f @@ -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 diff --git a/unix/terinq_old.f b/unix/terinq_old.f new file mode 100644 index 0000000..8040152 --- /dev/null +++ b/unix/terinq_old.f @@ -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 diff --git a/unix/tru64/CVS/Entries b/unix/tru64/CVS/Entries new file mode 100644 index 0000000..cc1f151 --- /dev/null +++ b/unix/tru64/CVS/Entries @@ -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 diff --git a/unix/tru64/CVS/Repository b/unix/tru64/CVS/Repository new file mode 100644 index 0000000..a37d061 --- /dev/null +++ b/unix/tru64/CVS/Repository @@ -0,0 +1 @@ +analysis/fit/unix/tru64 diff --git a/unix/tru64/CVS/Root b/unix/tru64/CVS/Root new file mode 100644 index 0000000..710e291 --- /dev/null +++ b/unix/tru64/CVS/Root @@ -0,0 +1 @@ +/afs/psi.ch/project/sinq/cvs diff --git a/unix/tru64/sys_open.f b/unix/tru64/sys_open.f new file mode 100644 index 0000000..185db86 --- /dev/null +++ b/unix/tru64/sys_open.f @@ -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 diff --git a/unix/tru64/zm_fit b/unix/tru64/zm_fit new file mode 100644 index 0000000..2b71f58 --- /dev/null +++ b/unix/tru64/zm_fit @@ -0,0 +1 @@ +this file is used by config diff --git a/unix/zm_fit b/unix/zm_fit new file mode 100644 index 0000000..2b71f58 --- /dev/null +++ b/unix/zm_fit @@ -0,0 +1 @@ +this file is used by config