Initial revision
This commit is contained in:
cvs
401
difrac/mesint.f
Normal file
401
difrac/mesint.f
Normal file
@@ -0,0 +1,401 @@
|
||||
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
|
||||
D12 = BS*ABS(TAN(0.5*THETA/DEG))
|
||||
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 CTIME (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 CTIME (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 CTIME (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 CTIME (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 CTIME (BGDTIM,BGRD2)
|
||||
CALL ANGSET (ANG1,ANG2,CHI,PHI,NATT,ICOL)
|
||||
CALL CTIME (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 CTIME (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 CTIME (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 CTIME (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 CTIME (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 CTIME (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 CTIME (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
Block a user