src/sim_con.f

Fortran project SIMRES, source module src/sim_con.f.

Source module last modified on Tue, 29 Mar 2005, 14:17;
HTML image of Fortran source automatically generated by for2html on Mon, 23 May 2005, 21:29.


#//////////////////////////////////////////////////////////////////////
#////
#////  R E S T R A X   4.4
#////
#////  Conversion subroutines between RESCAL and TRAX parameters
#////   
#////  * SUBROUTINE RT_CONVRT
#////  * SUBROUTINE VIVF(VI,VF)
#////  
#//////////////////////////////////////////////////////////////////////

#----------------------------------------------------
      SUBROUTINE READ_SOU(line,ns,dia,w,h,ier)
# Read parameters of a DETECTOR from the CFG file     
#-----------------------------------------------------------  
      implicit none
      integer*4 ns,ier
      real*8 dia,w,h
      character*128 line
      
      ier=0
      read(line,*,err=99) ns,dia,w,h
      
      return
      
99    ier=1      
      end      

#----------------------------------------------------
      SUBROUTINE READ_DET(line,nd,dia,w,h,angle,nseg,space,phi,ier)
# Read parameters of a DETECTOR from the CFG file     
#-----------------------------------------------------------  
      implicit none
      
      integer*4 nd,nseg,ier
      real*8 dia,w,h,angle,space,phi
      character*128 line
      
      ier=0
      read(line,*,err=1) nd,dia,w,h,angle,nseg,space,phi
      return    
1     read(line,*,err=99) nd,dia,w,h
      angle=0.d0
      nseg=1
      space=0.d0
      phi=0.d0
      return
      
99    ier=1      
      end      

#----------------------------------------------------
      SUBROUTINE READ_MONO(line,chi,aniz,pois,thick,height,width,
     *                     nh,nv,nb,ier)
# Read parameters of a CRYSTAL from the CFG file     
#-----------------------------------------------------------  
      implicit none
      
      real*8 chi,aniz,pois,thick,height,width
      integer*4 nh,nv,nb,ier
      character*128 line
      ier=0
      
      read(line,*,err=1) chi,aniz,pois,thick,height,width,
     *                   nh,nv,nb
      return    
1     read(line,*,err=99) chi,aniz,pois,thick,height,width,
     *                   nh,nv
      nb=1
      return
      
99    ier=1      
      end      

#-----------------------------------------------------------
      SUBROUTINE READ_COL(line,dist,leng,h1,h2,v1,v2,ic,ier)
# Read parameters of a GUIDE/COLLIMATOR from the CFG file
# IC .. collimator index     
#-----------------------------------------------------------  
      implicit none      
      INCLUDE 'collimators.inc'
      
      real*8 dist,leng,h1,h2,v1,v2
      integer*4 ic,ier
      character*128 line

10    format(a15,8(1x,g10.4))
      ier=0
# full format
      read(line,*,err=1) ctyp(ic),dist,leng,h1,h2,v1,v2,roh(ic),rov(ic),
     &   gamh(ic),gamv(ic),refh(ic),refv(ic),nlam(ic),vlam(ic),
     &   dlamh(ic),dlamv(ic)
#      write(*,10) 'full format',IC,CTYP(IC),ROH(IC),ROV(IC) 
      
      if (ctyp(ic).gt.4.or.ctyp(ic).lt.-1) goto 1  ! -1 >= CTYP <= 4, else error      
      if (leng.le.0) ctyp(ic)=-1      
      return    
     
# old RESTRAX format, extended by NLAM, VLAM, DLAM  
1     read(line,*,err=2) dist,leng,h1,h2,v1,v2,roh(ic),gamh(ic),
     &   gamv(ic),refh(ic),refv(ic),nlam(ic),vlam(ic),dlamh(ic)   
#      write(*,*) 'format 1!'
      ctyp(ic)=0
      dlamv(ic)=dlamh(ic)
      rov(ic)=0
      if (gamh(ic).gt.0.or.gamv(ic).gt.0) ctyp(ic)=1
      if (leng.le.0) ctyp(ic)=-1
      return    
      
# old RESTRAX format, extended by NLAM,DLAM  
2     read(line,*,err=3) dist,leng,h1,h2,v1,v2,roh(ic),gamh(ic),
     &                   gamv(ic),refh(ic),refv(ic),nlam(ic),dlamh(ic)
#      write(*,*) 'format 2!'
      vlam(ic)=0
      dlamv(ic)=dlamh(ic)
      rov(ic)=0
      ctyp(ic)=0
      if (gamh(ic).gt.0.or.gamv(ic).gt.0) ctyp(ic)=1
      if (leng.le.0) ctyp(ic)=-1
      return   

# old RESTRAX format       
3     read(line,*,err=99)  dist,leng,h1,h2,v1,v2,roh(ic),gamh(ic),
     &     gamv(ic),refh(ic),refv(ic)
     
#      write(*,*) 'format 3!'
      nlam(ic)=0
      vlam(ic)=0
      dlamh(ic)=0.0
      dlamv(ic)=dlamh(ic)
      rov(ic)=0
      ctyp(ic)=0
      if (gamh(ic).gt.0.or.gamv(ic).gt.0) ctyp(ic)=1
      if (leng.le.0) ctyp(ic)=-1
      return      
99    ier=1      
      end      


#--------------------------------------------------------------
      SUBROUTINE READ_COL1(line,nf,dist,leng,h1,h2,v1,v2,ic,ier)
# Read parameters of a GUIDE/COLLIMATOR from the CFG file, with presence indicator     
#--------------------------------------------------------------  
      implicit none      
      
      real*8 dist,leng,h1,h2,v1,v2
      integer*4 ic,nf,is,il,ier
      character*128 line
      
      ier=0
      is=1
      call FINDPAR(line,1,is,il)
      if (il.le.0) goto 99
      read(line(is:is+il-1),*,err=99) nf
      call READ_COL(line(is+il:128),dist,leng,h1,h2,v1,v2,ic,ier)
      return
      
99    ier=1      
      end      

#----------------------------------------------------------
      SUBROUTINE READCFG(fname)
#  Read configuration from FNAME (assume that exists)
# + some initial conversions  
#----------------------------------------------------------      
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'collimators.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'trax.inc'

      integer*4 iu
      parameter (iu=25)
      character*(*) fname
 
      character*128 line     
      data nhm,nha,nvm,nva /1,1,1,1/       
      integer*4 ier,iline,i,is,il  
      
      
          

#xxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxx
100   format(a60)
101   format(a) 

      call BOUNDS(fname,is,il)
      open(unit=iu,file=fname(is:is+il-1),status= 'OLD',err=999,
     *     iostat=ier)
      
# ***  READ CFG FILE  ***
      iline=0  
#* Source
  3   read(iu,*,end=997)
      read(iu,100,end=997) cfgtitle
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call READ_SOU(line,nsou,diasou,wsou,hsou,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* Guide A
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL(line,dga,lga,hga1,hga2,vga1,vga2,1,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* Guide B
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL1(line,nfg,dguide,lguide,hg1,hg2,vg1,vg2,2,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  
      if (nfg.eq.0) then  ! ignore guides
         ctyp(2)=-1
         ctyp(1)=-1         
      endif
#* Monochromator
      read(iu,*,end=997)
      read(iu,101,end=997) line      
      call  READ_MONO(line,himon,anrm,poissm,thmon,hmon,wmon,nhm,
     &      nvm,nbm,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* Analyzer
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_MONO(line,hiana,anra,poissa,thana,hana,wana,nha,
     &      nva,nba,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* Detector
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_DET(line,ndet,diadet,wdet,hdet,adet,nsegdet,spacedet,
     *      phidet,ier)
      if(nsegdet.gt.64) nsegdet=64 
      if (ier.ne.0) goto 997
      iline=iline+2  

#* Distances
      read(iu,*,end=997)
      read(iu,*,end=997,err=997) vl0,vl1,vl2,vl3
      iline=iline+2  
#* COL1
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL(line,vlcanm,vlsm,hdm1,hdm2,vdm1,vdm2,3,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* COL2 A
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL(line,dist2a,len2a,h2a1,h2a2,v2a1,v2a2,4,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* COL2 B
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL(line,vlcans,vlms,hds1,hds2,vds1,vds2,5,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* COL3
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL(line,vlcana,vlsa,hda1,hda2,vda1,vda2,6,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

#* COL4
      read(iu,*,end=997)
      read(iu,101,end=997) line
      call  READ_COL(line,vlcand,vlad,hdd1,hdd2,vdd1,vdd2,7,ier)
      if (ier.ne.0) goto 997
      iline=iline+2  

# ***  END OF READ CFG FILE, go to interpretation  ***
      close(iu)
      go to 2     

# ***  ERROR while reading, show message and go to interpretation anyway ***      
997   write(sout,*)  'ERROR after line ',iline, ' in file '//fname
      write(sout,*) line
      pause
      close(iu)

2     continue   
# some unit conversions
      do i=1,nco
         gamh(i)=gamh(i)*gammani
         gamv(i)=gamv(i)*gammani
         if (ctyp(i).le.1) then  ! convert RO to [mm]
           roh(i)=roh(i)/1000.
           rov(i)=rov(i)/1000.
         endif  
      enddo                             
      
      write(sout,*)  'Configuration updated from ',fname(is:is+il-1)
      return
         
        
999   write(*,998) ier   
998   format( 'Fatal error: ',i5, ' cannot open configuration file. ',/,
      'Check privileges or disk space !')
      stop 
      end


#----------------------------------------------------------
      SUBROUTINE WRITEDEFCFG
#  Write default config. file to the current directory
#  Use the full format (new in since version 4.9.92)
# TYP=-1 no collimator
# TYP=0  standard collimator (course or soller)
# TYP=1  guide (or bender), can be curved (RO means curvature in [1/m] )
# TYP=2  parabolic guide, equal lengths of the lamellae (RO means focal distance in [cm] !)
# TYP=3  parabolic guide, optimized lengths of the lamellae 
# TYP=4  elliptic guide, wider window is the smaller ellipse axis
#
# extended detector format:
# =========================
# if eta>0, then assumes vertical tube(s)
# nseg = number of tubes 
# space = space between tubes [mm]
# phi = inclination angle [deg], phi=0 means tube is vertical
# detector efficiency: 1-EXP(-eta*lambda*pathlength)
#---------------------------------------------------------- 
      implicit none
      character*16 c(13)
      character*82 vals(13),head(13)
      integer*4 i
# element names      
      data c/
     &   'title',
     &   'n-guide A',
     &   'n-guide B',
     &   'monochromator',
     &   'analyzer',
     &   'segments',
     &   'detector',
     &   'distances',
     &   '1st collimator',
     &   '2nd collimator A',
     &   '2nd collimator B',
     &   '3nd collimator',     
     &   '4th collimator'/
# some headers 
      
      vals(1)= 'default setup (IN14 with PG and Soller)'
      vals(2)= '0   21.   6.   12.'
      vals(3)= '1  7.5  584.5  6.  6. 12. 12.  0.  0.  1.2  1.2  1  1'//
     1       '  1  1  0. 0.'
     
      vals(4)= '1  1  807.5  1050.  6.  6.  12.  12.  0.  0. 1.2  1.2'//
     1       '  1  1  1  1  0. 0.'
     
      vals(5)= '0.  1.  0.3  0.2  12.  15.  1  7  1'
      vals(6)= '0.  1.  0.3  1.0  12.  16.  1  5  1'
      vals(7)= '1   4.0   4.0  6.0  0.0  1  0.  0.'
      vals(8)= '22.5  270.  155.  64.'
      
      vals(9)= '0     1.     5.  10.  10.   15.   15.  0.  0.  0.  0.'// 
     1       '  0.  0. 1  1  0. 0.'
     
      vals(10)= '-1    2.     0.   6.   6    12.   12.  0.  0.  0.  0.'// 
     1       '  0.  0. 1  1  0. 0.'
     
      vals(11)= '0   100.    20.   4.   4.   12.   12   0.  0.  0.  0.'//  
     1       '  0.  0. 1  1  0. 0.'
     
      vals(12)= '0   113.    20.   4.   4.   12.   12.  0.  0.  0.  0.'// 
     1       '  0.  0. 1  1  0. 0.'
     
      vals(13)= '0    35.    20.   4.   4.   12.   12.  0.  0.  0.  0.'// 
     1       '  0.  0. 1  1  0. 0.'
     
      head(1)= 'title (max.60 characters)'
      
      head(2)= 'shape, dia, width, height' 
      head(3)= 'typ, gap, len, H1, H2, V1, V2, roh, rov,'//
     1         ' mh, mv, refh, refv, nh, nv, dh, dv'

      head(4)= 'use, typ, dist, len, H1, H2, V1, V2, roh, rov,'//
     1 ' mh, mv, refh, refv, nh, nv, dh, dv'

      head(5)= 'chi, aniz., poiss., thick., height, length, nh, nv, nt'
     
      head(6)=head(5)
      head(7)= 'shape, dia, width, height, eta, nseg, space, angle'
      head(8)= 'sou-mono, mono-sample, sample-anal, anal-det'
      head(9)= 'typ, dist, len, H1, H2, V1, V2, roh, rov,'//
     1 ' mh, mv, refh, refv, nh, nv, dh, dv'
      head(10)=head(3)
      head(11)=head(9)
      head(12)=head(9)
      head(13)=head(9)

1     format(a13, ' (',a, ')')
2     format(a)
      
      
      open(unit=24,file= 'simres00.cfg',status= 'UNKNOWN',err=10)
      do i=1,13        
         write(24,1) c(i),head(i)
         write(24,2) vals(i)
      enddo
      close(24)
10    continue       
      end
      
#----------------------------------------------------------
      SUBROUTINE SETDEFRES
#  Sets the default rescal parameters and write to default.res file 
#  in the current directory
#----------------------------------------------------------
      implicit none
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      integer*4 i
      
      do i=1,mres
        res_dat(i)=res_def(i)
      enddo
      call WRITE_RESCAL(rescal_defname,i)
      end