Initial commit
This commit is contained in:
468
gen/dat_table.f
Normal file
468
gen/dat_table.f
Normal file
@ -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
|
||||
Reference in New Issue
Block a user