Initial revision
This commit is contained in:
cvs
466
difrac/indmes.f
Normal file
466
difrac/indmes.f
Normal file
@@ -0,0 +1,466 @@
|
||||
C-----------------------------------------------------------------------
|
||||
C Subroutine for the following functions
|
||||
C 1. To set and measure a given hkl reflection IR
|
||||
C 2. To set only a given hkl reflection SR
|
||||
C 3. To measure only a given hkl reflection IM
|
||||
C 4. To move the circles to given angles SA (& ST,SO,SC,SP)
|
||||
C 5. Perform Psi scans IP
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE INDMES
|
||||
INCLUDE 'COMDIF'
|
||||
CHARACTER ITF*1,IT(NSIZE)*1,PSNAME*40
|
||||
REAL RW(3,3)
|
||||
NJREF = NREF
|
||||
NATT = 0
|
||||
PSI = 0.0
|
||||
C-----------------------------------------------------------------------
|
||||
C Set up for the DE function
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'DE') THEN
|
||||
CALL HKLN (IH,IK,IL,NJREF)
|
||||
CALL ANGET (THETA,OMEGA,CHI,PHI)
|
||||
CALL MESRIT
|
||||
CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL)
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Default values for IH,IK,IL and write the appropriate header
|
||||
C-----------------------------------------------------------------------
|
||||
IH = 0
|
||||
IK = 0
|
||||
IL = 0
|
||||
NIREF = 0
|
||||
IF (KI .EQ. 'IR') THEN
|
||||
WRITE (COUT,10000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'IE') THEN
|
||||
WRITE (COUT,11000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF (KI .EQ. 'SR') THEN
|
||||
WRITE (COUT,14000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'MS') THEN
|
||||
WRITE (COUT,14100)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'IM') THEN
|
||||
WRITE (COUT,15000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'SA') THEN
|
||||
WRITE (COUT,24000)
|
||||
CALL GWRITE (ITP,'$')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'ST') THEN
|
||||
WRITE (COUT,28000)
|
||||
CALL GWRITE (ITP,'$')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'SO') THEN
|
||||
WRITE (COUT,29000)
|
||||
CALL GWRITE (ITP,'$')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'SC') THEN
|
||||
WRITE (COUT,30000)
|
||||
CALL GWRITE (ITP,'$')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'SP') THEN
|
||||
WRITE (COUT,31000)
|
||||
CALL GWRITE (ITP,'$')
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C The SA function angle input
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'SA') THEN
|
||||
CALL ANGET (THETA,OMEGA,CHI,PHI)
|
||||
CALL FREEFM (ITR)
|
||||
THETA = RFREE(1)
|
||||
OMEGA = RFREE(2)
|
||||
CHI = RFREE(3)
|
||||
PHI = RFREE(4)
|
||||
NJREF = -NJREF
|
||||
CALL SETIT (NJREF)
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C The ST, SO, SC, SP functions angle input
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'ST' .OR. KI .EQ. 'SO' .OR.
|
||||
$ KI .EQ. 'SC' .OR. KI .EQ. 'SP') THEN
|
||||
CALL ANGET (THETA,OMEGA,CHI,PHI)
|
||||
CALL FREEFM (ITR)
|
||||
IF (KI .EQ. 'ST' )THETA = RFREE(1)
|
||||
IF (KI .EQ. 'SO') OMEGA = RFREE(1)
|
||||
IF (KI .EQ. 'SC') CHI = RFREE(1)
|
||||
IF (KI .EQ. 'SP') PHI = RFREE(1)
|
||||
NJREF = -NJREF
|
||||
CALL SETIT (NJREF)
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Only the IM, IR, IE and SR functions are left at this point. Do IM.
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'IM' ) THEN
|
||||
WRITE (COUT,13000)
|
||||
CALL FREEFM (ITR)
|
||||
IH = IFREE(1)
|
||||
IK = IFREE(2)
|
||||
IL = IFREE(3)
|
||||
CALL HKLN (IH,IK,IL, NJREF)
|
||||
CALL ANGET (THETA,OMEGA,CHI,PHI)
|
||||
CALL MESRIT
|
||||
CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICC)
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Input instruction for the IE function
|
||||
C-----------------------------------------------------------------------
|
||||
IOUT = -1
|
||||
IF (KI .EQ. 'IE') THEN
|
||||
CALL SPACEG (IOUT,0)
|
||||
WRITE (COUT,17000)
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Input instruction for the SR AND IR functions
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'SR' .OR. KI .EQ. 'MS') THEN
|
||||
WRITE (COUT,18000)
|
||||
ENDIF
|
||||
IF (KI .EQ. 'IR') THEN
|
||||
IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0)
|
||||
$ CALL SPACEG (IOUT,0)
|
||||
WRITE (COUT,16000)
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Set up the IP instruction and CURVES.DAT
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'IP') THEN
|
||||
WRITE (COUT,33000)
|
||||
IIP = LPT
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'Y') THEN
|
||||
IIP = IOUNIT(8)
|
||||
PSNAME = 'CURVES.DAT'
|
||||
CALL IBMFIL (PSNAME,IIP,80,'US',IERR)
|
||||
WRITE (IIP,34000) WAVE
|
||||
DO 100 I = 1,3
|
||||
DO 110 J = 1,3
|
||||
RW(I,J) = R(I,J)/WAVE
|
||||
110 CONTINUE
|
||||
WRITE (IIP,35000) (RW(I,J),J=1,3)
|
||||
100 CONTINUE
|
||||
ENDIF
|
||||
DPSI = 10
|
||||
PSIMIN = 0.0
|
||||
PSIMAX = 360.0
|
||||
WRITE (COUT,17000)
|
||||
ENDIF
|
||||
CALL GWRITE (ITP,' ')
|
||||
C-----------------------------------------------------------------------
|
||||
C Interpret the free-form input for SR, IR and IE
|
||||
C-----------------------------------------------------------------------
|
||||
150 WRITE (COUT,32000)
|
||||
CALL ALFNUM (OCHAR)
|
||||
DO 160 J = 1,100
|
||||
I = 101 - J
|
||||
ANS = OCHAR(I:I)
|
||||
IF (ANS .NE. ' ') THEN
|
||||
ITF = '+'
|
||||
IF (ANS .EQ. '-') ITF = '-'
|
||||
IF (ANS .EQ. '-' .OR. ANS .EQ. '+') OCHAR(I:I) = ' '
|
||||
GO TO 170
|
||||
ENDIF
|
||||
160 CONTINUE
|
||||
170 CALL FREEFM (1000)
|
||||
IH = IFREE(1)
|
||||
IK = IFREE(2)
|
||||
IL = IFREE(3)
|
||||
C-----------------------------------------------------------------------
|
||||
C SR Function - Set the display and then the reflection
|
||||
C MS Function for the CAD4 only
|
||||
C-----------------------------------------------------------------------
|
||||
IF (KI .EQ. 'SR' .OR. KI .EQ. 'MS') THEN
|
||||
CALL HKLN (IH,IK,IL,NJREF)
|
||||
ISTAN = 0
|
||||
DPSISV = DPSI
|
||||
DPSI = 180.
|
||||
IPRVAL = 1
|
||||
CALL ANGCAL
|
||||
DPSI = DPSISV
|
||||
IF (IVALID .EQ. 32) THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
IF (IVALID .NE. 0) THEN
|
||||
WRITE (COUT,19000)
|
||||
CALL YESNO ('N',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF (KI .EQ. 'MS') OMEGA = OMEGA + 90.0 - 0.5*THETA
|
||||
IF (ITF .EQ. '-') THETA = 360.0 - THETA
|
||||
CALL SETIT (NJREF)
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Store the h,k,l values for the IR and IE functions
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
|
||||
ILIST = 0
|
||||
IF (KI .EQ. 'IE') ILIST = 1
|
||||
IPRVAL = 1
|
||||
CALL ANGCAL
|
||||
IF (IVALID .EQ. 32) GO TO 150
|
||||
IF (IVALID .NE. 0) THEN
|
||||
WRITE (COUT,19100)
|
||||
CALL YESNO ('N',ANS)
|
||||
IF (ANS .EQ. 'N') GO TO 150
|
||||
ENDIF
|
||||
CALL DEQHKL (NHKL,ILIST)
|
||||
NIREF = NIREF + 1
|
||||
IOH(NIREF) = IH
|
||||
IOK(NIREF) = IK
|
||||
IOL(NIREF) = IL
|
||||
IT(NIREF) = ITF
|
||||
IF (NIREF .EQ. NSIZE) THEN
|
||||
WRITE (COUT,18500)
|
||||
CALL GWRITE (ITP,' ')
|
||||
GO TO 180
|
||||
ENDIF
|
||||
GO TO 150
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C IR and IE Functions
|
||||
C-----------------------------------------------------------------------
|
||||
180 DO 220 I = 1,NIREF
|
||||
IH = IOH(I)
|
||||
IK = IOK(I)
|
||||
IL = IOL(I)
|
||||
ITF = IT(I)
|
||||
JHKL(1,1) = IH
|
||||
JHKL(2,1) = IK
|
||||
JHKL(3,1) = IL
|
||||
NHKL = 1
|
||||
ILIST = 0
|
||||
IPRVAL = 0
|
||||
IF (KI .EQ. 'IE') CALL DEQHKL (NHKL,ILIST)
|
||||
DO 210 J = 1,NHKL
|
||||
IH = JHKL(1,J)
|
||||
IK = JHKL(2,J)
|
||||
IL = JHKL(3,J)
|
||||
PSI = 0.0
|
||||
C-----------------------------------------------------------------------
|
||||
C Set the display
|
||||
C-----------------------------------------------------------------------
|
||||
CALL HKLN (IH,IK,IL,NJREF)
|
||||
ISTAN = 0
|
||||
C-----------------------------------------------------------------------
|
||||
C Test if psi rotation is required
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ABS(DPSI) .GT. 0.0001) THEN
|
||||
TPSI = PSIMIN
|
||||
IF (TPSI .GE. 180.0) TPSI = TPSI - 360.0
|
||||
PSI = PSIMIN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Calculate angles for given h,k,l and psi. Why is Psi reversed ???
|
||||
C Psi has to be reversed for the absorp calculation to work
|
||||
C could have something to do with the handedness of the NRC
|
||||
C Picker.
|
||||
C-----------------------------------------------------------------------
|
||||
200 PSISAV = PSI
|
||||
PSI = 360.0 - PSI
|
||||
IPRVAL = 0
|
||||
CALL ANGCAL
|
||||
IF (ITF .EQ. '-') THETA = 360.0 - THETA
|
||||
PSI = PSISAV
|
||||
C-----------------------------------------------------------------------
|
||||
C If ANGCAL found rotation is possible set the circles and measure
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IROT .EQ. 0) THEN
|
||||
CALL MESRIT
|
||||
ELSE
|
||||
WRITE (COUT,25000) IH,IK,IL,PSI
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
CALL KORQ (KQFLAG)
|
||||
IF (KQFLAG .EQ. 1) THEN
|
||||
C-----------------------------------------------------------------------
|
||||
C Increment the psi value for rotation
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ABS(DPSI) .GT. 0.0001) THEN
|
||||
TPSI = TPSI + DPSI
|
||||
PSI = PSI + DPSI
|
||||
IF (PSI .GE. 360.0) PSI = PSI - 360.0
|
||||
IF (TPSI .LE. PSIMAX) GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Return circles to omega=0 and peak centre before exit
|
||||
C-----------------------------------------------------------------------
|
||||
ICC = 0
|
||||
PSI = 0.0
|
||||
SDPSI = DPSI
|
||||
DPSI = 0.0
|
||||
IPRVAL = 0
|
||||
CALL ANGCAL
|
||||
IF (ITF .EQ. '-') THETA = 360.0 - THETA
|
||||
DPSI = SDPSI
|
||||
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
||||
IF (ICC .NE. 0) THEN
|
||||
WRITE (COUT,26000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
C CALL KORQ (KQFLAG)
|
||||
IF (KQFLAG .NE. 1) THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
IF (KI .EQ. 'IP') THEN
|
||||
IF (IIP .NE. LPT)
|
||||
$ CALL IBMFIL (PSNAME,-IIP,80,'US',IERR)
|
||||
ENDIF
|
||||
KI = ' '
|
||||
RETURN
|
||||
10000 FORMAT (' Intensity Measurements for Individual Reflections')
|
||||
11000 FORMAT (' Intensity Measurements for Equivalent Reflections',
|
||||
$ ' (Y) ? ',$)
|
||||
13000 FORMAT (' Type h,k,l for label ',$)
|
||||
14000 FORMAT (' Set One Reflection')
|
||||
14100 FORMAT (' Set a Crystal Face for absorption measurements')
|
||||
15000 FORMAT (' Measure the Reflection which is now in the Detector')
|
||||
16000 FORMAT (' Type h,k,l and +/- 2Theta sense (+) for up to 50',
|
||||
$ ' reflections. CR = End.')
|
||||
17000 FORMAT (' Type h,k,l for up to 50 reflections. CR = End.')
|
||||
18000 FORMAT (' Type h,k,l and +/- 2theta sense (+) ',$)
|
||||
18500 FORMAT (' No more reflections allowed.')
|
||||
19000 FORMAT (' Do you want to set it anyway (N) ? ',$)
|
||||
19100 FORMAT (' Do you want to measure it anyway (N) ? ',$)
|
||||
20000 FORMAT (3I4,5F8.3)
|
||||
24000 FORMAT (' Type 2Theta,Omega,Chi,Phi (0) ',$)
|
||||
25000 FORMAT (3I4,' Rotation to Psi',F7.2,' is NOT possible.')
|
||||
26000 FORMAT (' Setting Collision')
|
||||
28000 FORMAT (' Type 2-Theta ',$)
|
||||
29000 FORMAT (' Type Omega ',$)
|
||||
30000 FORMAT (' Type Chi ',$)
|
||||
31000 FORMAT (' Type Phi ',$)
|
||||
32000 FORMAT (' Next h,k,l (End) > ',$)
|
||||
33000 FORMAT (' Collect Psi scan data'/
|
||||
$ ' Do you want to write data to CURVES.DAT (Y) ? ')
|
||||
34000 FORMAT (1X,F8.5)
|
||||
35000 FORMAT (1X,3F10.6)
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C Measure the reflection
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE MESRIT
|
||||
INCLUDE 'COMDIF'
|
||||
ITIME = 1
|
||||
IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN
|
||||
CALL SAMMES (ITIME,ICC)
|
||||
ELSE
|
||||
CALL MESINT (IROFL,ICC)
|
||||
ENDIF
|
||||
IF (ICC .EQ. 2) THEN
|
||||
WRITE (COUT,10000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
RETURN
|
||||
ENDIF
|
||||
CALL PROFIL
|
||||
IBGRD1 = BGRD1
|
||||
IBGRD2 = BGRD2
|
||||
ISUM = SUM
|
||||
ICOUNT = COUNT
|
||||
ATT = ATTEN(NATT+1)
|
||||
IF (IPRFLG .EQ. 0) THEN
|
||||
if(FRAC1 .GT. 0.01) THEN
|
||||
PEAK = ATT*(SUM - 0.5*(BGRD1 + BGRD2)/FRAC1)
|
||||
ELSE
|
||||
PEAK = 0.
|
||||
END IF
|
||||
IPEAK = PEAK
|
||||
IF (KI .EQ. 'DE') THEN
|
||||
WRITE (COUT,11000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (LPT .NE. ITP)
|
||||
$ WRITE (LPT,12000) IH,IK,IL,THETA,FRAC1,NATT,
|
||||
$ IBGRD1,ISUM,IBGRD2,PSI,IPEAK,ITIME
|
||||
WRITE (COUT,12000) IH,IK,IL,THETA,FRAC1,NATT,
|
||||
$ IBGRD1,ISUM,IBGRD2,PSI,IPEAK,ITIME
|
||||
CALL GWRITE (ITP,' ')
|
||||
ELSE
|
||||
FFRAC = FRAC
|
||||
IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN
|
||||
IP = PRESET
|
||||
BB = 1000*(PRESET - IP)
|
||||
FFRAC = BB/IP
|
||||
ENDIF
|
||||
PEAK = ATT*(COUNT - 0.5*(BGRD1 + BGRD2)/FFRAC)
|
||||
IPEAK = PEAK
|
||||
IF (LPT .NE. ITP)
|
||||
$ WRITE (LPT,12000) IH,IK,IL,THETA,PRESET,NATT,
|
||||
$ IBGRD1,ICOUNT,IBGRD2,PSI,IPEAK,ITIME
|
||||
WRITE (COUT,12000) IH,IK,IL,THETA,TIME,NATT,
|
||||
$ IBGRD1,ICOUNT,IBGRD2,PSI,IPEAK,ITIME
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
IF (KI .EQ. 'IP') THEN
|
||||
WRITE (IIP,13000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI,
|
||||
$ IPEAK
|
||||
ENDIF
|
||||
RETURN
|
||||
10000 FORMAT (' Scan Collision')
|
||||
11000 FORMAT (/,3X' h k l 2-Theta Time',
|
||||
$ ' Att Bkg Peak Bkg Psi Inet ')
|
||||
12000 FORMAT (3I4,F7.2,F7.3,1X,I1,I5,I7,I5,F7.2,I7,I4)
|
||||
13000 FORMAT (3I4,5F8.2,I8)
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C Set the display and the circles
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE SETIT (NJREF)
|
||||
INCLUDE 'COMDIF'
|
||||
IF (NJREF .LT. 0) THEN
|
||||
RH = IH
|
||||
RK = IK
|
||||
RL = IL
|
||||
NJREF = -NJREF
|
||||
ELSE
|
||||
RH = RFREE(1)
|
||||
RK = RFREE(2)
|
||||
RL = RFREE(3)
|
||||
ENDIF
|
||||
IF (ABS(RH - IH) .GT. 0.0001 .OR.
|
||||
$ ABS(RK - IK) .GT. 0.0001 .OR.
|
||||
$ ABS(RL - IL) .GT. 0.0001) THEN
|
||||
WRITE (COUT,10100) RH,RK,RL,THETA,OMEGA,CHI,PHI,PSI
|
||||
ELSE
|
||||
WRITE (COUT,10000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI
|
||||
ENDIF
|
||||
CALL GWRITE (ITP,' ')
|
||||
CALL HKLN (IH,IK,IL,NJREF)
|
||||
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
||||
IF (ICC .NE. 0) THEN
|
||||
WRITE (COUT,11000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
ENDIF
|
||||
KI = ' '
|
||||
RETURN
|
||||
10000 FORMAT (3I4,5F8.3)
|
||||
10100 FORMAT (8F8.3)
|
||||
11000 FORMAT (' Setting Collision')
|
||||
END
|
||||
Reference in New Issue
Block a user