linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- Improved centering in DIFRAC

Browse Source 
- Fixed a bug in UserWait
- Improved scan message in scancom
- Added zero point correction in lin2ang
- fixed an issue with uuencoded messages
This commit is contained in:
cvs
2000-04-06 12:18:53 +00:00
parent 8ba6bf7758
commit ff5e8cf0b2
35 changed files with 227 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
difrac/COMDIF
View File

@@ -15,7 +15,7 @@
$ BGRD2,NATT,AS,BS,CS,PA,PM,QTIME,TMAX,AFRAC,
$ ATTEN(6)
COMMON /PROFL/ ACOUNT(10*NSIZE),D12,ILOW,IHIGH,IDEL,IWARN,SUM,
$ FRAC1,IPRFLG,IAUTO,STEPOF,FRAC,PJUNK(9)
$ FRAC1,IPRFLG,IAUTO,STEPOF,FRAC,PJUNK(9),NPK
COMMON /CUTOFF/ ISYS,SINABS(6),ILN,DELAY,STEP,IUPDWN,ISTOP,
$ CJUNK(8)
COMMON /CELL/ SR(3,3),SSG(3,3),GI(3,3),AP(3),APS(3),SANGS(3),

2
difrac/begin.f
View File

@@ -1,7 +1,7 @@
C-----------------------------------------------------------------------
C This subroutine reads the info necessary to start the data collection
C at the start of data collection and at each new segment
C Modofied to give output to ITP-->SICS, MK
C Modified to give output to ITP-->SICS, MK
C-----------------------------------------------------------------------
SUBROUTINE BEGIN
INCLUDE 'COMDIF'

28
difrac/centre.f
View File

@@ -2,14 +2,23 @@ C-----------------------------------------------------------------------
C Routine to align one circle by accumulating a distribution
C of intensity values against degrees & then
C finding the median of the distribution.
C
C Modifications: Mark Koennecke, April 2000
C Added code for doing PH optimizations as well.
C Added code for monitoring the centering process as well.
C When a peak is not found, drive back to start and give an FP error
C code instead of an FF. Then the alignement of another circle
C might resolve the issue.
C-----------------------------------------------------------------------
SUBROUTINE CENTRE (DX,ANG,ISLIT)
INCLUDE 'COMDIF'
DIMENSION XA(100),YA(100),AN(4),ST(4),ANG(4)
CHARACTER ANGLE(3)*6
DATA ANGLE/'2theta','Omega','Chi'/
CHARACTER ANGLE(4)*6
DATA ANGLE/'2theta','Omega','Chi','PH'/
INTEGER IRUPT
NATT = 0
C------- a debug flag! Set to 0 for no debug output
IDEBUG = 1
C-----------------------------------------------------------------------
C If CAD-4 call the scan fitting version of the routine
C-----------------------------------------------------------------------
@@ -30,6 +39,7 @@ C-----------------------------------------------------------------------
IF (KI .EQ. 'ST') N = 1
IF (KI .EQ. 'SO') N = 2
IF (KI .EQ. 'SC') N = 3
IF (KI .EQ. 'SP') N = 4
ICHI = 0
IF (ST(3) .GE. 350.0 .OR. ST(3) .LE. 10.0) ICHI = 1
IPHI = 0
@@ -67,6 +77,11 @@ C-----------------------------------------------------------------------
RETURN
ENDIF
CALL CCTIME (PRESET,COUNT)
IF(IDEBUG .EQ. 1)THEN
WRITE(COUT,20000),AN(1),AN(2),AN(3),AN(4),COUNT
20000 FORMAT('TH = ',F8.2,' OM = ',F8.2,' CH = ',F8.2,' PH = ' F8.2,
& ' CTS = ', F8.2)
ENDIF
CALL KORQ(IRUPT)
IF(IRUPT .NE. 1) THEN
WRITE (COUT,10000)
@@ -154,11 +169,18 @@ C-----------------------------------------------------------------------
IF (IMAX .EQ. 100 .AND. AFRAC*MAX .GT. MIN) GO TO 100
C-----------------------------------------------------------------------
C Case 2. There is no significant peak.
C
C Modified: Drive back to start positions. So that other circle centering
C will not fail.
C Modified error code to give an FP in order to decide between
C interrupt and bad peak.
C Mark Koennecke, April 2000
C-----------------------------------------------------------------------
IF (ILOW .LT. 1 .OR. IHIGH .GT. 100) THEN
WRITE (COUT,11000) ANGLE(N),ILOW,IHIGH
CALL GWRITE (ITP,' ')
KI = 'FF'
KI = 'FP'
CALL ANGSET(ST(1),ST(2),ST(3),ST(4),IA,IC)
RETURN
ENDIF
C-----------------------------------------------------------------------

2
difrac/difini.f
View File

@@ -240,7 +240,7 @@ C-----------------------------------------------------------------------
$ RTHETA,ROMEGA,RCHI,RPHI/4*0.0/, IH,IK,IL/1,2,3/
DATA IDH/72*0/, IBSECT,ISCAN/2*0/, FRAC/0.1/, IPRFLG/0/,
$ ISYS/1/, SINABS/3*0.00503135,3*0.0/, ILN/0/, DELAY/100/
DATA COUT/20*' '/,IWNCUR/0/,ISREG/1,1,1,7*0/
DATA COUT/20*' '/,IWNCUR/0/,ISREG/1,1,1,0,0,0,0,0,1,0/
DATA STEP/0.02/,PRESET/15000./DPHI/0./
RETURN
END

2
difrac/difint.f
View File

@@ -20,7 +20,7 @@ C----------------------------------------------------------------------
C Disabling some unsupported commands for TRICS
C----------------------------------------------------------------------
IF(KI .EQ. 'AD' .OR. KI .EQ. 'LT' .OR. KI .EQ. 'SH' .OR.
$ KI .EQ. 'IN' .OR. KI .EQ. 'NR' .OR. KI .EQ. 'SW' .OR.
$ KI .EQ. 'IN' .OR. KI .EQ. 'NR' .OR.
$ KI .EQ. 'EK' .OR. KI .EQ. 'FI' .OR. KI .EQ. 'KE' .OR.
$ KI .EQ. 'MR' .OR. KI .EQ. 'MS')THEN
WRITE(COUT,23000)

2
difrac/indmes.f
View File

@@ -387,7 +387,7 @@ C-----------------------------------------------------------------------
ATT = ATTEN(NATT+1)
IF (IPRFLG .EQ. 0) THEN
if(FRAC1 .GT. 0.01) THEN
PEAK = ATT*(SUM - 0.5*(BGRD1 + BGRD2)/FRAC1)
PEAK = ATT*(SUM - (0.5*(BGRD1 + BGRD2)/FRAC1)*NPK)
ELSE
PEAK = 0.
END IF

12
difrac/profil.f
View File

@@ -257,9 +257,6 @@ C-----------------------------------------------------------------------
DO 220 I = 1,ILOW-1
B1 = B1 + ACOUNT(I)
220 CONTINUE
C---mk
B1 = B1/ILOW
C---
ENDIF
FRAC1 = (FRAC*NP + ILOW - 1)/NPK
PEAK = 0.0
@@ -271,12 +268,9 @@ C---
DO 230 I = IHIGH+1,NP
B2 = B2 + ACOUNT(I)
230 CONTINUE
IDIV = NP - IHIGH
IF(IDIV .LE. 0)IDIV =1
B2 = B2/IDIV
ENDIF
FRAC2 = (FRAC*NP + NP - IHIGH)/NPK
BTOT = 0.5*(B1/FRAC1 + B2/FRAC2)*NP
BTOT = 0.5*(B1/FRAC1 + B2/FRAC2)
TOP1 = PEAK - BTOT
BOT1 = SQRT(PEAK + 0.25*(B1/(FRAC1*FRAC1) + B2/(FRAC2*FRAC2)))
FRAC1 = 0.5*(FRAC1 + FRAC2)
@@ -306,7 +300,9 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
ENDIF
240 CALL RSW(9,JSW)
IF (JSW .NE. 0 .and. istan .ne. 0) CALL PRFWRT (NP)
C------- always write profile at TRICS!
C IF (JSW .NE. 0 .and. istan .ne. 0) CALL PRFWRT (NP)
CALL PRFWRT (NP)
C-----------------------------------------------------------------------
C Prepare the profile for display on the c.r.t. if wanted
C Code below here is not needed for profile analysis

1
difrac/sammes.f
View File

@@ -113,3 +113,4 @@ C-----------------------------------------------------------------------
210 CONTINUE
RETURN
END

1
difrac/trics.f
View File

@@ -145,6 +145,7 @@ C RSW Read the switch register
C-----------------------------------------------------------------------
SUBROUTINE RSW (N,IVALUE)
INCLUDE 'COMDIF'
IVALUE = ISREG(N)
RETURN
END
C-----------------------------------------------------------------------

16
difrac/wxw2t.f
View File

@@ -8,7 +8,13 @@ C-----------------------------------------------------------------------
SUBROUTINE WXW2T (DT,DO,DC,ISLIT)
INCLUDE 'COMDIF'
DIMENSION ANG(4)
CALL SHUTTR (99)
CALL SHUTTR (99)
C----- a fixed value for PHI alignement, MK
DP = .1
C----- debug message: MK
WRITE(COUT,22)DT, DO, DC
22 FORMAT('STEP OM: ',F8.2,' Step TH: ',F8.2,' Step CH: ',F8.2)
CALL GWRITE(ITP,' ')
C-----------------------------------------------------------------------
C For the CAD-4 centering is as follows :--
C 1. an omega/2theta scan with the 4mm variable slit,
@@ -43,17 +49,25 @@ C-----------------------------------------------------------------------
CALL CENTRE (DC,ANG,0)
IF (KI .EQ. 'FF') GO TO 100
C-----------------------------------------------------------------------
C Align Phi
C----------------------------------------------------------------------
KI = 'SP'
CALL CENTRE(DP,ANG,0)
IF (KI .EQ. 'FF') GO TO 100
C-----------------------------------------------------------------------
C Omega again
C-----------------------------------------------------------------------
KI = 'SO'
CALL CENTRE (DO,ANG,0)
IF (KI .EQ. 'FF') GO TO 100
IF (KI .EQ. 'FP') GO TO 100
C-----------------------------------------------------------------------
C Align 2Theta
C----------------------------------------------------------------------
KI = 'ST'
CALL CENTRE (DT,ANG,0)
IF (KI .EQ. 'FF') GO TO 100
IF (KI .EQ. 'FP') GO TO 100
ENDIF
C-----------------------------------------------------------------------
C The answers are passed in BPSI in COMMON