1327 lines
32 KiB
Fortran
1327 lines
32 KiB
Fortran
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
|