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)*NPK) 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