723 lines
26 KiB
Fortran
723 lines
26 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Read in all Basic Data from the terminal commands
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE BASINP
|
|
INCLUDE 'COMDIF'
|
|
CHARACTER KISAVE*2
|
|
C-----------------------------------------------------------------------
|
|
C Select data to be read from keys with the value in KI
|
|
C If KI = 'BD' then all basic data must be typed in.
|
|
C The following keys are allowed :--
|
|
C AD BD CZ DH FR LA M2 M3 MM OM PS RO RR SD SE TM TP
|
|
C
|
|
C If M2, M3 or MM reset the indices corresponding to 2thetamax
|
|
C
|
|
C BD -- All Basic Data
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'BD') THEN
|
|
WRITE (COUT,10000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C AD -- Attenuator Data
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'AD' .OR. KI .EQ. 'BD') THEN
|
|
IF (NATTEN .EQ. 0) THEN
|
|
WRITE (COUT,12000)
|
|
ELSE
|
|
WRITE (COUT,12100) (ATTEN(I),I=1,NATTEN+1)
|
|
ENDIF
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (COUT,12200)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') THEN
|
|
WRITE (COUT,12300)
|
|
CALL FREEFM (ITR)
|
|
NATTEN = 0
|
|
ATTEN(1) = 1.0
|
|
DO 100, I = 1,6
|
|
IF (RFREE(I) .GT. 1.0) THEN
|
|
NATTEN = NATTEN + 1
|
|
ATTEN(NATTEN+1) = RFREE(I)
|
|
ENDIF
|
|
100 CONTINUE
|
|
ENDIF
|
|
IF (KI .EQ. 'AD') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C LA -- Wavelength. When a new wavelength is to be used, the R matrix,
|
|
C SINABS and IH,K,LMAX must all be changed
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'LA' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,11000) WAVE
|
|
CALL FREEFM (ITR)
|
|
OWAVE = WAVE
|
|
IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1)
|
|
WAVFAC = WAVE/OWAVE
|
|
IF (KI .EQ. 'LA') THEN
|
|
DO 110 I = 1,3
|
|
SINABS(I) = WAVFAC*WAVFAC*SINABS(I)
|
|
SINABS(I+3) = WAVFAC*WAVFAC*SINABS(I+3)
|
|
DO 110 J = 1,3
|
|
R(I,J) = WAVFAC*R(I,J)
|
|
110 CONTINUE
|
|
S = 2.0*SIN((THEMAX*0.5)/DEG)
|
|
IHMAX = 1.0+S/(APS(1)*SANGS(2)*SANG(3)*WAVE)
|
|
IKMAX = 1.0+S/(APS(2)*SANGS(3)*SANG(1)*WAVE)
|
|
ILMAX = 1.0+S/(APS(3)*SANGS(1)*SANG(2)*WAVE)
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C OM -- Orientation Matrix
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'OM' .OR. KI .EQ. 'BD') THEN
|
|
IF (KI .EQ. 'OM') THEN
|
|
WRITE (COUT,11000) WAVE
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1)
|
|
ENDIF
|
|
WRITE (COUT,13000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 120 I = 1,3
|
|
WRITE (COUT,13100)
|
|
CALL FREEFM (ITR)
|
|
R(I,1) = RFREE(1)
|
|
R(I,2) = RFREE(2)
|
|
R(I,3) = RFREE(3)
|
|
120 CONTINUE
|
|
DO 130 I = 1,3
|
|
DO 130 J = 1,3
|
|
R(I,J) = R(I,J)*WAVE
|
|
130 CONTINUE
|
|
KISAVE = KI
|
|
KI = 'OM'
|
|
CALL ORMAT3
|
|
KI = KISAVE
|
|
CALL WRBAS
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C CZ -- Circle Zero Corrections
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'CZ' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,14000) DTHETA,DOMEGA,DCHI,DPHI
|
|
CALL FREEFM (ITR)
|
|
DTHETA = RFREE(1)
|
|
DOMEGA = RFREE(2)
|
|
DCHI = RFREE(3)
|
|
DPHI = RFREE(4)
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C RO -- Re-Orientation reflections for use during GO
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'RO' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,15000)
|
|
CALL YESNO ('N',ANS)
|
|
NINTOR = 0
|
|
REOTOL = 10.0
|
|
IF (ANS .EQ. 'N') THEN
|
|
CALL WRBAS
|
|
ELSE
|
|
WRITE (COUT,15100)
|
|
CALL FREEFM (ITR)
|
|
NINTOR = IFREE(1)
|
|
IF (NINTOR .EQ. 0) NINTOR = 500
|
|
WRITE (COUT,15200)
|
|
CALL FREEFM (ITR)
|
|
REOTOL = RFREE(1)
|
|
IF (REOTOL .EQ. 0.0) REOTOL = 0.1
|
|
CALL WRBAS
|
|
CALL ALIGN
|
|
ENDIF
|
|
KI = ' '
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C RR -- Reference Reflections
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'RR' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,16000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS. EQ. 'Y') THEN
|
|
WRITE (COUT,16100)
|
|
CALL FREEFM (ITR)
|
|
NSTAN = 0
|
|
NINTRR = IFREE(1)
|
|
IF (NINTRR .EQ. 0) NINTRR = 100
|
|
WRITE (COUT,19000)
|
|
CALL GWRITE (ITP,' ')
|
|
140 WRITE (COUT,19100)
|
|
CALL FREEFM (ITR)
|
|
IF (IFREE(1) .NE. 0 .OR. IFREE(2) .NE. 0 .OR.
|
|
$ IFREE(3) .NE. 0) THEN
|
|
NSTAN = NSTAN + 1
|
|
IHSTAN(NSTAN) = IFREE(1)
|
|
IKSTAN(NSTAN) = IFREE(2)
|
|
ILSTAN(NSTAN) = IFREE(3)
|
|
GO TO 140
|
|
ENDIF
|
|
ELSE
|
|
NSTAN = 0
|
|
NINTRR = 0
|
|
ENDIF
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C TM -- 2Theta min and max
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'TM' .OR. KI .EQ. 'OM' .OR. KI .EQ. 'BD' .OR.
|
|
$ KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. KI .EQ. 'MM' .OR.
|
|
$ KI .EQ. 'TO') THEN
|
|
IF (KI .EQ. 'TM' .OR. KI .EQ. 'OM' .OR. KI .EQ. 'BD' .OR.
|
|
$ THEMAX .LT. 1.0) THEN
|
|
WRITE (COUT,21000) THEMIN,THEMAX
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .NE. 0.0) THEMIN = RFREE(1)
|
|
IF (RFREE(2) .NE. 0.0) THEMAX = RFREE(2)
|
|
IF (ITYPE .GE. 0 .AND. ITYPE .LE. 3) THEN
|
|
NPTS = (AS + BS*TAN(0.5*THEMAX/DEG) + CS)*STEPDG + 0.5
|
|
IF (NPTS .GT. 499) THEN
|
|
WRITE (COUT,22000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Optionally retain old matrix for M2, M3 or MM
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. KI .EQ. 'MM' .OR.
|
|
$ KI .EQ. 'TO') THEN
|
|
WRITE (COUT,24000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
DO 145 I = 1,3
|
|
DO 145 J = 1,3
|
|
R(I,J) = ROLD(I,J)
|
|
145 CONTINUE
|
|
ELSE
|
|
DO 148 I = 1,3
|
|
DO 148 J = 1,3
|
|
R(I,J) = R(I,J)/WAVE
|
|
148 CONTINUE
|
|
ENDIF
|
|
CALL GETPAR
|
|
DO 146 I = 1,3
|
|
SANG(I) = SIN(CANG(I)/DEG)
|
|
CANG(I) = COS(CANG(I)/DEG)
|
|
SANGS(I) = SIN(CANGS(I)/DEG)
|
|
CANGS(I) = COS(CANGS(I)/DEG)
|
|
146 CONTINUE
|
|
DO 147 I = 1,3
|
|
DO 147 J = 1,3
|
|
R(I,J) = R(I,J)*WAVE
|
|
147 CONTINUE
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Set new h,k,l max values
|
|
C-----------------------------------------------------------------------
|
|
S = 2.0*SIN((THEMAX*0.5)/DEG)
|
|
IHMAX = 1.0 + S/(APS(1)*SANGS(2)*SANG(3)*WAVE)
|
|
IKMAX = 1.0 + S/(APS(2)*SANGS(3)*SANG(1)*WAVE)
|
|
ILMAX = 1.0 + S/(APS(3)*SANGS(1)*SANG(2)*WAVE)
|
|
IF (KI .EQ. 'OM') ANS = 'Y'
|
|
IF (KI .NE. 'TM' .AND. KI .NE. 'BD' .AND. ANS .EQ. 'Y')
|
|
$ CALL SYSPNT
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C SE -- Systematic Extinction Conditions
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'SE' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,25000)
|
|
CALL FREEFM (ITR)
|
|
NCOND = IFREE(1)
|
|
IF (NCOND .NE. 0) THEN
|
|
WRITE (COUT,28000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 150 J = 1,NCOND
|
|
WRITE (COUT,13100)
|
|
CALL FREEFM (ITR)
|
|
ICOND(J) = IFREE(1)
|
|
IHS(J) = IFREE(2)
|
|
IKS(J) = IFREE(3)
|
|
ILS(J) = IFREE(4)
|
|
IR(J) = IFREE(5)
|
|
IS(J) = IFREE(6)
|
|
150 CONTINUE
|
|
ENDIF
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C SD -- Scan Control Data
|
|
C
|
|
C Values of ITYPE on input & during running and IBSECT & ISCAN
|
|
C
|
|
C ITYPE
|
|
C Type of Operation Input Running IBSECT3 ISCAN
|
|
C
|
|
C Theta/2Theta b/P/b scan 0 0 0 0
|
|
C Omega b/P/b scan 1 2 0 0
|
|
C Compton or T.D.S. 2 0 0 1
|
|
C Theta/2Theta Precision scan 3 1 0 3
|
|
C Omega Precision scan 4 3 0 4
|
|
C Peak Top Theta backgrounds 5 5 0 0
|
|
C Peak Top Omega backgrounds 6 6 0 0
|
|
C Economized Peak Top Theta 7 7 0 0
|
|
C Economized Peak Top Omega 8 8 0 0
|
|
C
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'SD' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,30000)
|
|
CALL FREEFM (ITR)
|
|
ITYPE = IFREE(1)
|
|
WRITE (COUT,30100) AS,BS,CS
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .NE. 0.0) AS = RFREE(1)
|
|
IF (RFREE(2) .NE. 0.0) BS = RFREE(2)
|
|
IF (RFREE(3) .NE. 0.0) CS = RFREE(3)
|
|
IPRFLG = 1
|
|
IF (ITYPE .LT. 4) THEN
|
|
WRITE (COUT,31000)
|
|
CALL FREEFM (ITR)
|
|
IPRFLG = IFREE(1)
|
|
ENDIF
|
|
ISCAN = 0
|
|
IBSECT = 0
|
|
ITEMP = ITYPE
|
|
IF (ITYPE .EQ. 1) ITEMP = 2
|
|
C IF (ITYPE .EQ. 2) THEN
|
|
C ITEMP = 0
|
|
C ISCAN = 1
|
|
C ENDIF
|
|
IF (ITYPE .EQ. 2) THEN
|
|
ITEMP = 1
|
|
ISCAN = 3
|
|
ENDIF
|
|
IF (ITYPE .EQ. 3) THEN
|
|
ITEMP = 3
|
|
ISCAN = 4
|
|
ENDIF
|
|
IF (ITYPE .GE. 4) ITEMP = ITYPE + 1
|
|
ITYPE = ITEMP
|
|
IBSECT = 0
|
|
C WRITE (COUT,32000)
|
|
C CALL FREEFM (ITR)
|
|
C IBSECT = IFREE(1)
|
|
IF (ITYPE .LT. 4) THEN
|
|
C WRITE (COUT,33000)
|
|
C CALL FREEFM (ITR)
|
|
C SPEED = RFREE(1)
|
|
C IF (SPEED .EQ. 0.0) SPEED = 4.0
|
|
ENDIF
|
|
C---------------------------------------------------------------------
|
|
C Step and Preset for TRICS
|
|
C-------------------------------------------------------------------
|
|
OLDDSTEP = STEP
|
|
OLDPRE = PRESET
|
|
WRITE(COUT,33500)STEP,PRESET
|
|
CALL FREEFM(ITR)
|
|
STEP = RFREE(1)
|
|
PRESET = RFREE(2)
|
|
IF(STEP .LE. 0.)STEP = OLDSTEP
|
|
IF(PRESET .LE. 0)PRESET = OLDPRE
|
|
IF(STEP .LE. 0.)STEP = 0.02
|
|
IF(PRESET .LE. 0)PRESET = 10000
|
|
C-----------------------------------------------------------------------
|
|
C Horizontal aperture width for CAD-4 data collection
|
|
C-----------------------------------------------------------------------
|
|
IF (DFMODL .EQ. 'CAD4') THEN
|
|
CADSL = ICADSL/10.0
|
|
WRITE (COUT,33100) CADSL
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .EQ. 0.0) RFREE(1) = CADSL
|
|
ICADSL = 10*RFREE(1) + 0.5
|
|
WRITE (COUT,33200)
|
|
CALL YESNO ('Y',ANS)
|
|
ICADSW = 1
|
|
IF (ANS .EQ. 'N') ICADSW = 0
|
|
ENDIF
|
|
STEPOF = 0.5
|
|
IF (IPRFLG .EQ. 0) THEN
|
|
WRITE (COUT,34000)
|
|
CALL FREEFM (ITR)
|
|
STEPOF = RFREE(1)
|
|
IF (STEPOF .EQ. 0) STEPOF = 0.5
|
|
ENDIF
|
|
IF (ITYPE .GE. 0 .AND. ITYPE .LE. 3) THEN
|
|
NPTS = (AS + BS*TAN(0.5*THEMAX/DEG) + CS)*STEPDG + 0.5
|
|
IF (NPTS .GT. 499) THEN
|
|
WRITE (COUT,22000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
ENDIF
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C TP -- Time and Precision control data
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'TP' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,35000)
|
|
CALL GWRITE (ITP,' ')
|
|
I = ITYPE
|
|
IF (ISCAN .EQ. 1) THEN
|
|
WRITE (COUT,37000)
|
|
CALL FREEFM (ITR)
|
|
FRAC = RFREE(1)
|
|
TMAX = RFREE(2)
|
|
PA = RFREE(3)
|
|
PM = RFREE(4)
|
|
ELSE
|
|
IF (I .EQ. 0 .OR. I .EQ. 2 .OR. I .EQ. 5 .OR. I .EQ. 6) THEN
|
|
WRITE (COUT,36000)
|
|
CALL FREEFM (ITR)
|
|
FRAC = RFREE(1)
|
|
IF (FRAC .EQ. 0.0) FRAC = 0.1
|
|
IF (I .EQ. 5 .OR. I .EQ. 6) THEN
|
|
WRITE (COUT,35900)
|
|
CALL FREEFM (ITR)
|
|
PRESET = RFREE(1)
|
|
IF (PRESET .EQ. 0.0) PRESET = 1000.0
|
|
ENDIF
|
|
ELSE IF (I .EQ. 1 .OR. I .EQ. 3) THEN
|
|
WRITE (COUT,36000)
|
|
CALL FREEFM (ITR)
|
|
FRAC = RFREE(1)
|
|
IF (FRAC .EQ. 0.0) FRAC = 0.1
|
|
WRITE (COUT,37100)
|
|
CALL FREEFM (ITR)
|
|
TMAX = RFREE(1)
|
|
IF (TMAX .EQ. 0.0) TMAX = 240.0
|
|
WRITE (COUT,37200)
|
|
CALL FREEFM (ITR)
|
|
PA = RFREE(1)
|
|
IF (PA .EQ. 0.0) PA = 0.02
|
|
WRITE (COUT,37300)
|
|
CALL FREEFM (ITR)
|
|
PM = RFREE(1)
|
|
IF (PM .EQ. 0.0) PM = 0.10
|
|
ELSE IF (I .EQ. 7 .OR. I .EQ. 8) THEN
|
|
WRITE (COUT,38000)
|
|
CALL FREEFM (ITR)
|
|
FRAC = RFREE(1)
|
|
TMAX = RFREE(2)
|
|
PA = RFREE(3)
|
|
ENDIF
|
|
ENDIF
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
CALL WRBAS
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C DH -- DH Matrix Data
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'DH' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,40000)
|
|
CALL FREEFM (ITR)
|
|
NSEG = IFREE(1)
|
|
NMSEG = 1
|
|
WRITE (COUT,42000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 160 J = 1,NSEG
|
|
WRITE (COUT,13100)
|
|
CALL FREEFM (ITR)
|
|
IHO(J) = IFREE(1)
|
|
IKO(J) = IFREE(2)
|
|
ILO(J) = IFREE(3)
|
|
IDH(J,1,1) = IFREE(4)
|
|
IDH(J,2,1) = IFREE(5)
|
|
IDH(J,3,1) = IFREE(6)
|
|
IDH(J,1,2) = IFREE(7)
|
|
IDH(J,2,2) = IFREE(8)
|
|
IDH(J,3,2) = IFREE(9)
|
|
IDH(J,1,3) = IFREE(10)
|
|
IDH(J,2,3) = IFREE(11)
|
|
IDH(J,3,3) = IFREE(12)
|
|
160 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Read the B.Z. limits for COMPTON or TDS
|
|
C-----------------------------------------------------------------------
|
|
IF (ISCAN .EQ. 1) THEN
|
|
WRITE (COUT,44000)
|
|
CALL GWRITE (ITP,' ')
|
|
DO 170 J = 1,NSEG
|
|
WRITE (COUT,13100)
|
|
CALL FREEFM (ITR)
|
|
JA(J) = IFREE(1)
|
|
JB(J) = IFREE(2)
|
|
JC(J) = IFREE(3)
|
|
JMIN(J) = IFREE(4)
|
|
JMAX(J) = IFREE(5)
|
|
170 CONTINUE
|
|
ENDIF
|
|
IF (KI .EQ. 'DH') CALL SYSPNT
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Psi Scan Data
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ.'PS' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,47000)
|
|
CALL FREEFM (ITR)
|
|
DPSI = RFREE(1)
|
|
PSIMIN = RFREE(2)
|
|
PSIMAX = RFREE(3)
|
|
IF (KI .NE. 'BD') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C FR -- First Reflection Data
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'FR' .OR. KI .EQ. 'BD') THEN
|
|
WRITE (COUT,49000)
|
|
CALL FREEFM (ITR)
|
|
IND(1) = IFREE(1)
|
|
IND(2) = IFREE(2)
|
|
IND(3) = IFREE(3)
|
|
WRITE (COUT,52000)
|
|
CALL FREEFM (ITR)
|
|
NREF = IFREE(1)
|
|
NMSEG = IFREE(2)
|
|
WRITE (COUT,53000)
|
|
CALL FREEFM (ITR)
|
|
NBLOCK = IFREE(1)
|
|
KI = ' '
|
|
ENDIF
|
|
RETURN
|
|
10000 FORMAT (' Basic Data Input (Y) ',$)
|
|
11000 FORMAT (' Type the wavelength (',F7.5,') ',$)
|
|
12000 FORMAT (' There are no attenuators at present.')
|
|
12100 FORMAT (' The current attenuator coefficients are'/6F8.3)
|
|
12200 FORMAT (' Do you wish to change this (Y) ? ',$)
|
|
12300 FORMAT (' Type the new values ',$)
|
|
13000 FORMAT (' Type the Orientation Matrix on 3 lines.'/)
|
|
13100 FORMAT (' > ',$)
|
|
14000 FORMAT (' The current 2Theta, Omega, Chi and PHI zeroes are :--',
|
|
$ /4F7.3/,
|
|
$ ' Type the new values ',$)
|
|
15000 FORMAT (' Perform re-orientation during data collection (N) ? ',$)
|
|
15100 FORMAT (' Type the re-orientation frequency (500) ',$)
|
|
15200 FORMAT (' Type the re-orientation angular tolerance (0.1) ',$)
|
|
16000 FORMAT (' Measure reference reflections during data collection',
|
|
$ ' (Y) ? ',$)
|
|
16100 FORMAT (' Type the measurement frequency (100) ',$)
|
|
19000 FORMAT (' Type up to 6 sets of h,k,l values.')
|
|
19100 FORMAT (' h,k,l > ',$)
|
|
21000 FORMAT (' Type 2Thetamin and 2Thetamax (',F4.1,F6.1,') ',$)
|
|
22000 FORMAT (' **WARNING** More than 500 profile points possible.'/
|
|
$ ' Reduce either 2theta(max), or the scan parameters',
|
|
$ ' AS and/or CS.')
|
|
24000 FORMAT (' You can keep the new matrix or retain the old one.'/
|
|
$ ' Do you wish to keep the new matrix (Y) ? ',$)
|
|
25000 FORMAT (' Systematic Extinction Conditions'/
|
|
$ ' Type the number of conditions ',$)
|
|
28000 FORMAT (' For each condition type the following :--'/
|
|
$ ' A reflection class number 1 to 7,'/
|
|
$ ' 1=00l 2=0k0 3=h00 4=0kl 5=h0l 6=hk0 7=hkl'/
|
|
$ ' followed by the coefficients A to E of an equation'/
|
|
$ ' Ah + Bk + Cl = Dn + E'/
|
|
$ ' which is the condition for h,k,l to be present.')
|
|
30000 FORMAT (' Scan data : Scan type, As,Bs,Cs, Profile flag.'//
|
|
$ ' Scan type: 0 2Theta, 1 Omega,'/
|
|
$ ' 2 2Theta precision, 3 Omega precision,'/
|
|
$ ' 4 2Theta peak top, 5 Omega peak top,'/
|
|
$ ' 6 2Theta econ. pktop, 7 Omega econ. pk top;'/
|
|
$ ' Type the scan type (0) ',$)
|
|
30100 FORMAT (' Reflection width in degs is As + Bs*tan(theta) + Cs'/
|
|
$ ' Type the new As, Bs, Cs (',3F6.3,') ',$)
|
|
31000 FORMAT (' Profile flag 0/1 for DO/DONT-DO profile analysis.'/
|
|
$ ' Type the flag (0) ',$)
|
|
C32000 FORMAT (' Bisecting (0) or Parallel (1) mode ',$)
|
|
33000 FORMAT (' Scan speed in deg/min 2theta or omega (4) ',$)
|
|
33500 FORMAT (' Scan step in deg (',F8.3,
|
|
& ') and Scan Preset (',F12.3,') ',
|
|
& $)
|
|
33100 FORMAT (' Horizontal aperture width in mms (',F4.1,') ',$)
|
|
33200 FORMAT (' Try -,-,- refln if high-angle scan problems (Y) ? ',$)
|
|
34000 FORMAT (' Fraction of A & C to step off for profile analysis',
|
|
$ ' (0.5) ',$)
|
|
35000 FORMAT (' Time and Precision Parameters')
|
|
35900 FORMAT (' Type the peak-top measuring preset (1000.0) ',$)
|
|
36000 FORMAT (' Type the Background fraction (0.1) ',$)
|
|
37000 FORMAT (' Type Bkfrac,Qtime,PresetMax,Pa,Pm ',$)
|
|
37100 FORMAT (' Type the maximum preset/reflection (240) ',$)
|
|
37200 FORMAT (' Type the precision desired (0.02) ',$)
|
|
37300 FORMAT (' Type the minimum precision acceptable (0.10) ',$)
|
|
38000 FORMAT (' Max Counts, Sample & Max Time (secs) ',$)
|
|
40000 FORMAT (' Segment Data (DH Matrices)'/
|
|
$ ' Type the number of segments ',$)
|
|
42000 FORMAT (' For each segment type the 12 integer values'/
|
|
$ ' HOO KOO LOO D11 D21 D31 D12 D22 D32 D13 D23 D33')
|
|
44000 FORMAT (' B.Z. Limits for each segment'/
|
|
$ ' JA,JB,JC,Jmin,Jmax ',$)
|
|
47000 FORMAT (' Psi Data: Dpsi,Psimin,Psimax')
|
|
49000 FORMAT (' First Reflection Data'/
|
|
$ ' Type h,k,l for the reflection ',$)
|
|
52000 FORMAT (' Type the Reflection and Segment numbers ',$)
|
|
53000 FORMAT (' Type the Data record number ',$)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Get the crystal system pointer for an absolute matrix
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE SYSPNT
|
|
INCLUDE 'COMDIF'
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
IF (LAUENO .NE. 0) THEN
|
|
ISYS = LAUENO
|
|
IF (LAUENO .GE. 4 .AND. LAUENO .LE. 5) ISYS = 4
|
|
IF (LAUENO .GE. 6 .AND. LAUENO .LE. 7) ISYS = 6
|
|
IF (LAUENO .GE. 8 .AND. LAUENO .LE. 12) ISYS = 5
|
|
IF (LAUENO .GE. 13 .AND. LAUENO .LE. 14) ISYS = 7
|
|
ELSE
|
|
CALL SYSANG (AP,SANG,CANG,ISYS,KI)
|
|
ENDIF
|
|
ISYSAN = ISYS
|
|
IF (ISYS .GT. 7) ISYS = 2
|
|
WRITE (COUT,11000) ISYS
|
|
CALL FREEFM (ITR)
|
|
IF (IFREE(1) .NE. 0) ISYS = IFREE(1)
|
|
IF (ISYS .EQ. 2) THEN
|
|
IF (LAUENO .NE. 0) THEN
|
|
ISYS = NAXIS + 7
|
|
ELSE
|
|
ISYS = ISYSAN
|
|
ENDIF
|
|
ENDIF
|
|
CALL SINMAT
|
|
RETURN
|
|
10000 FORMAT (' Select a number for the cell geometry to be used'/
|
|
$ ' Triclinic 1 Monoclinic 2'/
|
|
$ ' Orthorhombic 3 Tetragonal 4'/
|
|
$ ' Hexagonal 5 Rhombohedral 6 Cubic 7')
|
|
11000 FORMAT (' Type your selection (',I1,') ',$)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C
|
|
C Decide on the crystal system based on the cell-edges and angles
|
|
C The routine looks for differences between cell-edges which are less
|
|
C than a tolerance based on the cell-edge/500.0; and differnces
|
|
C between 90.0 and the cell angles which are less than TOLANG
|
|
C ICTE is the count of cell edges which are equal within TOLIJ;
|
|
C ICTA is the count of cell angles which are equal to 90 within TOLANG
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE SYSANG (ABC,SANG,CANG,ISYS,KI)
|
|
DIMENSION ABC(3),SANG(3),CANG(3),ANG(3),
|
|
$ DEIJ(3),DAI(3),TOLEI(3),TOLEIJ(3)
|
|
CHARACTER KI*2
|
|
RMULT = 1.0
|
|
IF (KI .EQ. 'OP') RMULT = 3.0
|
|
TOLANG = 0.1*RMULT
|
|
C-----------------------------------------------------------------------
|
|
C Make the angles from their sines and cosines; the 90 differences DA,
|
|
C and the cell-edge tolerances.
|
|
C-----------------------------------------------------------------------
|
|
DO 100 I = 1,3
|
|
ANG(I) = 57.2958*ATAN2(SANG(I),CANG(I))
|
|
DAI(I) = ABS(90.0 - ANG(I))
|
|
TOLEI(I) = ABC(I)/500.0
|
|
100 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Make the cell-edge differences and their tolerances
|
|
C-----------------------------------------------------------------------
|
|
K = 0
|
|
DO 110 I = 1,2
|
|
DO 110 J = I+1,3
|
|
K = K + 1
|
|
DEIJ(K) = ABS(ABC(I) - ABC(J))
|
|
TOLEIJ(K) = RMULT*SQRT(TOLEI(I)*TOLEI(I) + TOLEI(J)*TOLEI(J))
|
|
110 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Count the agreements etween cell-edges and angles
|
|
C-----------------------------------------------------------------------
|
|
ICTE = 0
|
|
ICTA = 0
|
|
DO 120 I = 1,3
|
|
IF (DEIJ(I) .LT. TOLEIJ(I)) ICTE = ICTE + 1
|
|
IF (DAI(I) .LT. TOLANG) ICTA = ICTA + 1
|
|
120 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Set ISYS according to ICTE and ICTA
|
|
C-----------------------------------------------------------------------
|
|
ISYS = 0
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 0 and ICTA = 0 -- Triclinic
|
|
C-----------------------------------------------------------------------
|
|
IF (ICTE .EQ. 0 .AND. ICTA .EQ. 0) ISYS = 1
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 0 and ICTA = 2 -- Monoclinic
|
|
C-----------------------------------------------------------------------
|
|
130 IF (ICTE .EQ. 0 .AND. ICTA .EQ. 2) THEN
|
|
IF (DAI(1) .GT. TOLANG) ISYS = 8
|
|
IF (DAI(2) .GT. TOLANG) ISYS = 9
|
|
IF (DAI(3) .GT. TOLANG) ISYS = 10
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 0 and ICTA = 3 -- Orthorhombic
|
|
C-----------------------------------------------------------------------
|
|
IF (ICTE .EQ. 0 .AND. ICTA .EQ. 3) ISYS = 3
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 1 and ICTA = 3 -- Tetragonal
|
|
C-----------------------------------------------------------------------
|
|
IF (ICTE .EQ. 1 .AND. ICTA .EQ. 3) ISYS = 4
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 1 and ICTA = 2 -- Hexagonal (maybe monoclinic)
|
|
C-----------------------------------------------------------------------
|
|
IF (ICTE .EQ. 1 .AND. ICTA .EQ. 2) THEN
|
|
IF (ABS(120.0 - ANG(3)) .LT. TOLANG) THEN
|
|
ISYS = 5
|
|
ELSE
|
|
ICTE = 0
|
|
GO TO 130
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 3 and ICTA = 0 -- Rhombohedral
|
|
C-----------------------------------------------------------------------
|
|
IF (ICTE .EQ. 3 .AND. ICTA .EQ. 0) ISYS = 6
|
|
C-----------------------------------------------------------------------
|
|
C ICTE = 3 and ICTA = 3 -- Cubic
|
|
C-----------------------------------------------------------------------
|
|
IF (ICTE .EQ. 3 .AND. ICTA .EQ. 3) ISYS = 7
|
|
C-----------------------------------------------------------------------
|
|
C Safety - just in case !
|
|
C-----------------------------------------------------------------------
|
|
IF (ISYS .EQ. 0) ISYS = 1
|
|
RETURN
|
|
END
|