linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
4cf814d179e85b4374a0229ce3d20b343c6e2c59
sics/difrac/indmes.f
cvs cbc7fdf334 Compiled under Redhat Linux<Right
2000-02-18 15:54:23 +00:00

467 lines
15 KiB
Fortran
Raw Blame History

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 View Git Blame Copy Permalink