linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
714b8ae84d7379d71310e513ff9ebf42644b8ed5
sics/difrac/mesint.f
cvs 714b8ae84d - Fixed a bug which caused the SICServer to die when a socket was broken. 
- Fixed many things in DIFRAC subsystem:
  * Recoded tcentr.f etc so that the course centering will work and will not
    go into an endless loop.
  * fixed boundary overwrites which occurred when yesno or alfnum where
    uset to get a single character and several were given.
  * Addeded documentation for DIFRAC
- Added tcl-files which  support the WWW status system
2000-03-31 13:16:50 +00:00

408 lines
13 KiB
Fortran
Raw Blame History

C-----------------------------------------------------------------------
C Subroutine to measure a reflection by :--
C Theta/2Theta scan (ITYPE=0) or Omega scan (ITYPE=1)
C
C IROFL = 1 Count-rate Overflow; ICC = 2 indicates a Collision
C
C Modified for doing step scans at TRICS.
C IO to COUT instead LPT for SICS
C Mark Koennecke, November 1999
C-----------------------------------------------------------------------
SUBROUTINE MESINT (IROFL,ICC)
INCLUDE 'COMDIF'
INTEGER IHTAGS(4), IRUPT
REAL SPRESET
ICPSMX = 45000
IF (DFMODL .EQ. 'CAD4') ICPSMX = 25000
C-----------------------------------------------------------------------
C Reset the liquid nitrogen loading flag
C-----------------------------------------------------------------------
IFILN = 0
SPRESET = PRESET
100 STIME = PRESET
ICS = 0
IROFL = 0
NATT = 0
IWARN = 0
ISIGN = 1
IF (THETA .LT. 0.0 .OR. THETA .GT. 180.0) ISIGN = -1
C---- Modified MK: there is no alpha1 alpha2 separation with neutrons
C D12 = BS*ABS(TAN(0.5*THETA/DEG))
D12 = 0.
C---- end of modification
TTIME = 0.20*PRESET
110 CALL SHUTTR (1)
IF (NATTEN .GT. 0) THEN
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
IF (ICOL .NE. 0) THEN
ICC = 2
CALL FILLN2 (IFILN,NFLG)
IF (NFLG .EQ. 1) GO TO 100
PRESET = SPRESET
RETURN
ENDIF
120 CALL CCTIME (TTIME,COUNT)
IF (COUNT/TTIME .GE. ICPSMX) THEN
NATT = NATT + 1
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
IF (NATT .LT. NATTEN) GO TO 120
ENDIF
ENDIF
IF ((ITYPE+1)/2 .EQ. 4) STIME = QTIME
IF (ITYPE .GE. 4) GO TO 160
IF (ITYPE .EQ. 0 .OR. ITYPE .EQ. 1) THEN
DEL1 = AS + D12 + CS
ANG1 = THETA - ISIGN*AS
ANG2 = OMEGA
ELSE
DEL1 = AS + D12/2 + CS
ANG1 = THETA + ISIGN*D12/3
ANG2 = OMEGA - ISIGN*(AS + D12/6)
ENDIF
C-----------------------------------------------------------------------
C Offset to low angle side of reflection
C-----------------------------------------------------------------------
ICC = 0
130 CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL)
IF (ICOL .NE. 0) THEN
ICC = 2
CALL FILLN2 (IFILN,NFLG)
IF (NFLG .EQ. 1) GO TO 100
PRESET = SPRESET
RETURN
ENDIF
C-----------------------------------------------------------------------
C Measure the low angle background for BGDTIM
C-----------------------------------------------------------------------
BGDTIM = FRAC*PRESET
CALL CCTIME (BGDTIM,BGRD1)
C-----------------------------------------------------------------------
C Do the scan:
C ITYPE Type of scan 0 -- theta/2-theta b-p-b
C 1 -- theta/2-theta precision
C 2 -- omega b-p-b
C 3 -- omega precision
C DEL1 Range of the scan (2-theta for types 0 & 1)
C ACOUNT Array of profile points with sum in ACOUNT(1)
C TIME Return value of scan time in secs
C SPEED Scan speed in degs/min.
C NPPTS No of points in returned profile
C IERR Error code 0 -- OK
C 1 -- Ratemeter overflow
C 2 -- Really bad!
C-----------------------------------------------------------------------
SDEL1 = ISIGN*DEL1
CALL TSCAN (ITYPE,SDEL1,ACOUNT(1),PRESET,STEP,NPPTS,IERR)
CALL KORQ(IRUPT)
IF(IRUPT .NE. 1)THEN
WRITE(COUT,11000)
CALL GWRITE(ITP,' ')
PRESET = SPRESET
RETURN
ENDIF
MAX = 1
IEND = 10*NSIZE
DO 135 I = 2,NPPTS
IF (MAX .LT. ACOUNT(I)) MAX = ACOUNT(I)
ACOUNT(IEND - I) = ACOUNT(I)
135 CONTINUE
C-----------------------------------------------------------------------
C For the CAD-4 at -ve 2theta the profile is delivered backwards.
C-----------------------------------------------------------------------
IF (DFMODL .EQ. 'CAD4' .AND.
$ (THETA .LT. 0.0 .OR. THETA .GT. 180.0)) THEN
J = IEND - NPPTS - 2
DO 138 I = 2,NPPTS
ACOUNT(I) = ACOUNT(J + I)
138 CONTINUE
ENDIF
C WRITE (COUT,99999) MAX,NPPTS,TIME
C CALL GWRITE (ITP,' ')
C99999 FORMAT (I6,I4,F8.3)
C-----------------------------------------------------------------------
C For the CAD-4 at high 2theta and chi near 90 there can be no profile,
C because the interface detects a potential collision.
C Then TIME = 0, and the profile analysis should not be done IDEL < 10
C-----------------------------------------------------------------------
IF (DFMODL .EQ. 'CAD4') THEN
RTIME = ABS(60*DEL1/SPEED)
IF (TIME .LT. RTIME/3) THEN
WRITE (LPT,12200) IH,IK,IL
WRITE (COUT,12200) IH,IK,IL
CALL GWRITE (ITP,' ')
IDEL = 5
GO TO 150
ENDIF
ENDIF
IF (MAX*NPPTS/PRESET .GT. ICPSMX) IROFL = 1
IF (IERR .GE. 2) THEN
WRITE (LPT,16000) IH,IK,IL
WRITE (COUT,16000) IH,IK,IL
CALL GWRITE (ITP,' ')
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
GO TO 110
ENDIF
C-----------------------------------------------------------------------
C Test for low angle count too high near direct beam
C-----------------------------------------------------------------------
IF (IROFL .NE. 0 .AND. PRESET .LT. 10) THEN
WRITE (COUT,12000) IH,IK,IL
CALL GWRITE(ITP,' ')
GO TO 150
ENDIF
C-----------------------------------------------------------------------
C Plot the last reflection if SR2 is ON
C For details of the profile plotting see PROFIL
C-----------------------------------------------------------------------
ISTEP = 1000.0/DEL1
IDEL = NPPTS + 1
C-----------------------------------------------------------------------
C Test for -ve 2theta scan problem with SIERAY 145D
C-----------------------------------------------------------------------
IF (IDEL .LT. 10) THEN
WRITE (COUT,12100) IH,IK,IL
CALL GWRITE (ITP,' ')
GO TO 150
ENDIF
C-----------------------------------------------------------------------
C Possibly draw the raw data profile
C-----------------------------------------------------------------------
CALL RSW (0,I)
IF (I .EQ. 1) THEN
DO 140 I = 1,4
IHTAGS(I) = 0
140 CONTINUE
IHTAGS(2) = AS*STEPDG
CALL PTPREP (NPPTS,ACOUNT(2),IHTAGS)
ENDIF
C-----------------------------------------------------------------------
C Check that the scan time is reasonably close to the calculated value
C-----------------------------------------------------------------------
COUNT = ACOUNT(1)
IF (ICOL .NE. 0) THEN
ICS = ICS + 1
IF (ICS .LT. 2) GO TO 130
ICC = 2
CALL FILLN2 (IFILN,NFLG)
IF (NFLG .EQ. 1) GO TO 100
PRESET = SPRESET
RETURN
ENDIF
C-----------------------------------------------------------------------
C Change the attenuator if necessary and try again.
C-----------------------------------------------------------------------
IF (IROFL .NE. 0) THEN
IF (NATTEN .GT. 0 .AND. NATT .LT. NATTEN) THEN
NATT = NATT + 1
GO TO 130
ENDIF
ENDIF
C-----------------------------------------------------------------------
C The scan is OK.
C Correct the low angle background to the time FRAC*TIME, measure the
C high angle background and then return.
C-----------------------------------------------------------------------
I = BGRD1*PRESET*FRAC/BGDTIM + 0.5
BGRD1 = I
BGDTIM = PRESET*FRAC
CALL CCTIME (BGDTIM,BGRD2)
IF (BGRD1 + BGRD2 .GT. 4.0*COUNT) THEN
WRITE (COUT,11000) IH,IK,IL
CALL GWRITE(ITP,' ')
ENDIF
CALL FILLN2 (IFILN,NFLG)
IF (NFLG .EQ. 1) GO TO 100
PRESET = SPRESET
RETURN
C-----------------------------------------------------------------------
C Return if there are counting problems
C-----------------------------------------------------------------------
150 COUNT = 2
SUM = 2
BGRD1 = 1
BGRD2 = 1
FRAC = 0.1
PRESET = SPRESET
NATT = 0
ICC = 0
IROFL = 0
IWARN = 1
CALL FILLN2 (IFILN,NFLG)
IF (NFLG .EQ. 1) GO TO 100
RETURN
C-----------------------------------------------------------------------
C Set up peak top counting for appropriate angles
C-----------------------------------------------------------------------
160 IF (ITYPE .EQ. 4 .OR. ITYPE .EQ. 6) THEN
ANG1 = THETA - AS
ANG2 = OMEGA
ANG3 = THETA + BS*TAN(0.5*THETA/DEG) + CS
ANG4 = OMEGA
PRESET= STIME
ELSE
ANG1 = THETA
ANG2 = OMEGA - AS
ANG3 = THETA
ANG4 = OMEGA + CS
ENDIF
170 CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
IF (ICOL .NE. 0) THEN
WRITE (COUT,13000) IH,IK,IL
CALL GWRITE(ITP,' ')
GO TO 150
ENDIF
C-----------------------------------------------------------------------
C Count at peak for time TIME
C-----------------------------------------------------------------------
420 CALL CCTIME (PRESET,COUNT)
C C = COUNT/PRESET
IF (C .GE. ICPSMX .AND. NATTEN .GT. 0 .AND. NATT .LT. NATTEN) THEN
NATT = NATT + 1
GO TO 170
ENDIF
C-----------------------------------------------------------------------
C Drive to high angle background position and count
C-----------------------------------------------------------------------
CALL ANGSET (ANG3,ANG4,CHI,PHI,NATT,ICOL)
IF (ICOL .NE. 0) THEN
WRITE (COUT,13000) IH,IK,IL
CALL GWRITE(ITP,' ')
GO TO 150
ENDIF
C-----------------------------------------------------------------------
C Measure the backgrounds
C-----------------------------------------------------------------------
IF (ITYPE .EQ. 5 .OR. ITYPE .EQ. 6) THEN
BGDTIM = FRAC*PRESET
CALL CCTIME (BGDTIM,BGRD2)
CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL)
CALL CCTIME (BGDTIM,BGRD1)
IF (BGRD1 + BGRD2 .GT. 4.0*COUNT) THEN
WRITE (COUT,11000) IH,IK,IL
CALL GWRITE(LPT,' ')
ENDIF
CALL FILLN2 (IFILN,NFLG)
PRESET = SPRESET
IF (NFLG .EQ. 1) GO TO 100
RETURN
ENDIF
C-----------------------------------------------------------------------
C Sample background on high side
C-----------------------------------------------------------------------
PRESET = STIME*0.5
CALL CCTIME (PRESET,BGRD2)
C-----------------------------------------------------------------------
C Evaluate rough Peak/Background ratio and Time required to
C accumulate a preset number FRAC of counts on the peak.
C-----------------------------------------------------------------------
RRAT = COUNT/(2*BGRD2 + 1.0)
IF (RRAT .LT. 1.05) RRAT = 1.05
RTIM = FRAC*STIME/(COUNT + 1.0)
C-----------------------------------------------------------------------
C Optimum time splitting and required total time
C-----------------------------------------------------------------------
OPT = (RRAT - SQRT(RRAT))/(RRAT - 1.0)
TOT = RTIM/OPT
IF (TOT .GT. TMAX) TOT = TMAX
IBCT = (TOT*(1.0 - OPT) + 1.0)/2.0
IPCT = (TOT*OPT) + 1
C-----------------------------------------------------------------------
C Finish measurement of high background
C-----------------------------------------------------------------------
BCT = (IBCT - (STIME/2.0))
IF (BCT .GT. 0.) THEN
CALL CCTIME (BCT,BKG2)
BGRD2 = BGRD2 + BKG2
BCT = IBCT
ICC = 0
ELSE
BCT = STIME/2.0
ENDIF
PCT = IPCT - STIME
IF (PCT .GT. 0.) THEN
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
IF (ICOL .NE. 0) THEN
ICC = 2
CALL FILLN2 (IFILN,NFLG)
PRESET = SPRESET
IF (NFLG .EQ. 1) GO TO 100
RETURN
ENDIF
PPCT = PCT
PCT = IPCT
CALL CCTIME (PPCT,PC)
COUNT = COUNT + PC
ELSE
PCT = STIME
ENDIF
CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL)
IF (ICOL .NE. 0) THEN
ICC = 2
CALL FILLN2 (IFILN,NFLG)
PRESET = SPRESET
IF (NFLG .EQ. 1) GO TO 100
RETURN
ENDIF
PRESET = BCT
CALL CCTIME (PRESET,BGRD1)
PRESET = PCT + BCT
CALL FILLN2 (IFILN,NFLG)
IF (NFLG .EQ. 1) GO TO 100
PRESET = SPRESET
RETURN
10000 FORMAT (' Clock Problems in reflection ',3I4)
11000 FORMAT (' Trouble Warning in reflection ',3I4)
12000 FORMAT (' Low Angle Problem in ',3I4)
12100 FORMAT (' Scan problem in ',3I4)
12200 FORMAT (' Potential CAD4 scan collision in',3I4)
13000 FORMAT (' Collision in reflection ',3I4)
16000 FORMAT (' Scan error in ',3I4,' Trying again')
END
C-----------------------------------------------------------------------
C Finish the measurement, with or without low temperature.
C-----------------------------------------------------------------------
SUBROUTINE FILLN2 (IFILN,NFLG)
INCLUDE 'COMDIF'
NFLG = 0
IF (ILN .EQ. 0) THEN
CALL SHUTTR (-1)
RETURN
ENDIF
DUM1 = 1.0/16.0
DUM2 = 0.5
CALL ONEBEP (DUM1,DUM2)
IF (DUM2 .GT. 1) THEN
TMIN = 0
WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
100 TIM1 = 1500
CALL CCTIME (TIM1,CONT)
DUM1 = 1.0/16.0
DUM2 = 0.5
CALL ONEBEP (DUM1,DUM2)
IF (DUM2 .GE. 1.0) THEN
TMIN = TMIN + 0.25
GO TO 100
ENDIF
WRITE (COUT,11000) IH,IK,IL,NREF,TMIN,DELAY
CALL GWRITE (ITP,' ')
TMIN = DELAY*6000
IF (TMIN .LE. 1) TMIN = 1
CALL CCTIME (TMIN,DUM2)
IFILN = 1
NFLG = 1
ENDIF
IF (IFILN .NE. 0) ICC = ICC + 4
CALL SHUTTR (-1)
RETURN
10000 FORMAT (' Liquid Nitrogen fillup. Waiting...')
11000 FORMAT (' Liquid Nitrogen Tank now full',/,
$ ' Reflection',3I3,' # ',I5,'. Filling lasted',F6.2,
$ ' minutes.',/,
$ ' Now starting a ',F5.2,' minutes delay before',
$ ' resuming data collection.')
END
Reference in New Issue View Git Blame Copy Permalink