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