Source module last modified on Sat, 16 Jul 2005, 18:46;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
# $Id: res_mfit.f,v 1.2 2005/07/16 16:46:06 saroun Exp $
#------------------------------------------------------------------------
SUBROUTINE MFIT_SET(indx)
# Set fileds from INDX-th item of /MFIT/ fields as the current setting
#------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
INCLUDE 'rescal.inc'
INCLUDE 'trax.inc'
integer*4 indx,i,j
if (indx.le.0.or.indx.gt.mf_max) return
do i=1,4
do j=1,4
atrax(i,j)=mf_a(i,j,indx)
aness(i,j)=mf_amc(i,j,indx)
mcr(i,j)=mf_mcr(i,j,indx)
mrc(i,j)=mf_mrc(i,j,indx)
enddo
amean(i)=mf_amean(i,indx)
end do
do i=1,res_nvar
res_dat(i)=mf_par(i,indx)
enddo
datname=mf_name(indx)
reltrax=reltr(indx)
relness=relmc(indx)
volcki=mf_vki(indx)
volckf=mf_vkf(indx)
vkiness=mf_mvki(indx)
vkfness=mf_mvkf(indx)
if(datname.ne. ' ') rescal_name= ' '
call SPEC_SET(mf_device(1,indx),mf_setup(1,indx))
cfgmode=mf_cfgmode(indx)
checksum=mf_chksum(indx)
ischanged=mf_changed(indx)
mf_cur=indx
end
#-------------------------------------------------------------------
SUBROUTINE MFIT_GET(indx)
# make mf_*(INDX) fileds equivalent to the current setting
# Get also mf_chksum and mf_done fields by calculation
# equivalent to MFIT_SYNC in this version
#-------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
integer*4 indx
# IF (INDX.LE.0.OR.INDX.GT.MDAT) RETURN
call MFIT_SYNC(indx)
# CALL SPEC_GETCHK(mf_chksum(INDX))
end
#-------------------------------------------------------------------
SUBROUTINE MFIT_SYNC(indx)
# copy current setup parameters to the INDX-th item fields
#-------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
INCLUDE 'rescal.inc'
INCLUDE 'trax.inc'
integer*4 indx,i,j
if (indx.le.0.or.indx.gt.mdat) return
do i=1,4
do j=1,4
mf_a(i,j,indx)=atrax(i,j)
mf_amc(i,j,indx)=aness(i,j)
mf_mcr(i,j,indx)=mcr(i,j)
mf_mrc(i,j,indx)=mrc(i,j)
end do
mf_amean(i,indx)=amean(i)
end do
do i=1,res_nvar
mf_par(i,indx)=res_dat(i)
end do
mf_name(indx)=datname
reltr(indx)=reltrax
relmc(indx)=relness
mf_vki(indx)=volcki
mf_vkf(indx)=volckf
mf_mvki(indx)=vkiness
mf_mvkf(indx)=vkfness
mf_cfgmode(indx)=cfgmode
mf_chksum(indx)=checksum
mf_changed(indx)=ischanged
call SPEC_GET(mf_device(1,indx),mf_setup(1,indx))
end
#--------------------------------------------------------
SUBROUTINE MFIT_LIST
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
integer*4 i,j,i1,i2
character*4 arrow
character*3 mc
character*1 mark
100 format(a3, '[',i2, ']',a1,4x,a3,4x,i3,2x ,
* ' [',f6.3,2(1x,f6.3,1x),f6.3, '] ',a)
101 format(a3, '[',i2, ']',a1,2x, 'no data')
102 format( ' DATA | MC valid | NP |',14x, 'QE',14x '| filename ')
write(sout,102)
do i=1,mf_max
if(i.eq.mf_cur) then
arrow= '-->'
else
arrow= ' '
endif
if(mf_active(i)) then
mark= '*'
else
mark= ' '
endif
if (mf_done(i).and.(.not.mf_changed(i))) then
mc= 'Yes'
else
mc= 'No'
endif
if (mf_loaded(i)) then
call BOUNDS(mf_name(i),i1,i2)
write(sout,100) arrow,i,mark,mc,npt(i)-npt(i-1),
* (qe0(j,i),j=1,4),mf_name(i)(i1:i1+i2-1)
else
# write(sout,101) arrow,I,mark
write(sout,100) arrow,i,mark,mc,npt(i)-npt(i-1),
* (mf_par(i_qh+j-1,i),j=1,4), 'no data'
endif
enddo
end
#-------------------------------------------------------------------
SUBROUTINE ADDDATA(line,npar,istart,isil)
# Load a range of data starting at the ISTART-th position.
# Input:
# LINE ... string describing data filename or data range (see below)
# NPAR ... number of parameters (= space separated strings) on LINE
# ISTART ... 1st position on data list to be used
# ISIL ... silence level (0..3) , influences the information output about data
#
# Range is passed through the LINE string as:
# 1) comma-separated minimum and maximum number (numbers=filenames)
# 2) space-separated list of strings (strings=filenames)
# 3) if LINE=' ', then one data set is loaded, program asks for a filename
#----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
character*(*) line
integer*4 npar,istart,isil
character*60 name
logical*4 addnew,readmore,create
integer*4 i,j,cur0,is,il,ix,sil,n1,n2,id,nread,ires
#1 FORMAT(I)
3 format(a)
#201 FORMAT('range: item: ',I3,' read: ',I3,' data: ',a20)
#202 FORMAT('list item: ',I3,' of ,'I3,' read: ',I3,' data: ',a60)
sil=silent
silent=isil ! silent mode for adding data
nread=0 ! clear counter of newly read data
cur0=mf_cur ! backup current data index
create=.false. ! if true then data is not read, but created from the current set
# interpret command line parameters:
n1=0
n2=0
is=1
call FINDPAR(line,1,is,il)
ix=index(line(is:is+il-1), ',') ! check for comma-separated list
if (ix.gt.0) then ! try range of numbers, separated by comma, e.g. 20056,20071
read(line(is:is+ix-2),*,err=100) n1
read(line(is+ix:is+il-1),*,err=100) n2
if (n1.gt.n2.or.n1.le.0) goto 100 ! not a valid range of data numbers
if (npar.gt.1) then ! try to read second parameter
is=1
call FINDPAR(line,2,is,il)
if (il.gt.0.and.line(is:is).eq. 'c') create=.true.
endif
endif
# decide where to put new data:
addnew=(istart.gt.mf_max)
if (addnew) then ! start above the allocated range, add new data
mf_max=mf_max+1
id=mf_max
mf_cur=id
mf_done(id)=.false.
else if (istart.le.0.or.istart.eq.mf_cur) then
id=mf_cur ! start at mf_cur
else
call mfit_set(istart) ! start at an item ISTART, update current RESTRAX fields
id=istart
endif
i=n1-1 ! integer=data filename
j=1
readmore=.true.
do while (readmore)
if (n2.gt.0.and.i.lt.n2) then ! take next data filename as integer
i=i+1
write(name,*) i
call BOUNDS(name,is,il)
if (create) name= 'channel'//name(is:is+il-1)
else if (j.le.npar) then ! take name from a list of filenames separated by spaces
is=1
call FINDPAR(line,j,is,il)
name=line(is:is+il-1)
j=j+1
else
name= ' ' ! prompt for filename
endif
# write(*,*) 'ADDDATA: ',NAME
call OPENFILE(name,ires) ! read data to mf_cur
if(ires.gt.0) then
nread=nread+1
id=id+1
else
#// write(*,*) 'Cannot open: ',IRES,NAME
call mfit_set(cur0) ! load back the former data set if open not successful
if (addnew) mf_max=mf_max-1
endif
readmore=(ires.ne.1.and. ! not a RESCAL file
& id.lt.mdat.and. ! doesn't exceed array dimensions
& name.ne. ' '.and. ! didn't get the name interactively
& i.lt.n2.and.j.le.npar) ! didn't reach the end of given range
if (readmore) then
cur0=mf_cur
addnew=(id.gt.mf_max)
if (addnew) then
mf_max=mf_max+1
mf_cur=id
mf_done(id)=.false.
else
if (id.ne.mf_cur) call mfit_set(id)
endif
endif
enddo
100 silent=sil
return
end
#--------------------------------------------------------
SUBROUTINE DELDATA(nmin,nmax)
# delete all data sets between NMIN and NMAX (incl.)
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'restrax.inc'
integer*4 i,k,np,nmin,nmax,n1,n2
n1=nmin
n2=nmax
if(n2.gt.mf_max) n2=mf_max
if(n1.lt.1) n1=1
if (n2.lt.n1.or.n2.lt.1.or.n1.gt.mf_max) return
# IF (N1.LE.1.AND.N2.GE.mf_max) RETURN ! can't delete all data
np=npt(n2)-npt(n1-1) ! number of items to be deleted
do k=npt(n1-1)+1,npt(mf_max)-np ! shift data above N2 by NP down
spx(k)=spx(k+np)
spy(k)=spy(k+np)
spz(k)=spz(k+np)
ipt(k)=ipt(k+np)
enddo
do i=n1,mf_max-n2+n1-1 ! copy fields above ITEM to the position below the deleted range
npt(i)=npt(i+1+n2-n1)-np ! ... and decrease number-of-points values NP
mf_loaded(i)=mf_loaded(i+1+n2-n1)
mf_active(i)=mf_active(i+1+n2-n1)
mf_done(i)=mf_done(i+1+n2-n1)
do k=1,4
qe0(k,i)=qe0(k,i+1+n2-n1)
dqe0(k,i)=dqe0(k,i+1+n2-n1)
enddo
do k=5,6
dqe0(k,i)=dqe0(k,i+1+n2-n1)
enddo
call mfit_set(i+1+n2-n1)
call mfit_get(i)
mf_cur=i
enddo
do i=mf_max-n2+n1,mdat ! there are no data at and above mf_max
npt(i)=npt(i-1)
mf_loaded(i)=.false.
mf_active(i)=.false.
mf_done(i)=.false.
mf_changed(i)=.true.
mf_chksum(i)=0
enddo
mf_max=mf_max-1-n2+n1 ! update mf_max
if (mf_max.le.0) mf_max=1
if (mf_cur.gt.mf_max) then ! update mf_cur if necessary (should never happen!)
mf_cur=mf_max
call mfit_set(mf_cur)
endif
call KSTACK_FREERANGE(n1,n2) ! free allocated memory for MC events
end
#---------------------------------------------------------------------------------
integer*4 FUNCTION GETIDENT()
# Search in the data sets for any one identical with the current settings
# Start with the current data set and test, whether it has been changed
# Then try the other ones.
# If such data set is found and MC has been run for it, return the data set index,
# otherwise return 0
#---------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
integer*4 i
logical*4 log1
1 format( 'Setup ',i3, ' is identical to ',i3)
log1=.false.
GETIDENT=0 ! no identical setup found
#* check first for the current data
log1=mf_done(mf_cur) ! Are there MC events already accumulated ?
# IF (LOG1) CALL SPEC_UNCHANGED(LOG1) ! Has the setup not changed since last MC tracing ?
log1=(log1.and.(.not.mf_changed(mf_cur)))
if (log1) then ! => the current setup is up to date, no MC tracing is needed
GETIDENT=mf_cur
return
endif
i=0
#* try to find an equivalent setup with MC tracing already done
do while ((.not.log1).and.(i.lt.mf_max))
i=i+1
if (i.ne.mf_cur) then ! skip the current setup
# write(*,*) 'ID: ',I,' done: ',mf_done(I),' mod: ',mf_changed(I)
if(mf_chksum(i).eq.checksum) then ! Do the check sums agree ?
call SPEC_COMPARE(mf_device(1,i),mf_setup(1,i),log1) ! Are I and mf_cur identical ?
log1=(log1.and.mf_done(i).and.(.not.mf_changed(i))) ! Is I up to date ?
#
else
# write(*,*) 'CHKSUM: ',I,mf_chksum(I),checkSUM
endif
endif
enddo
if (log1) GETIDENT=i
end