src/res_mfit.f

Fortran project RESTRAX, source module src/res_mfit.f.

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