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

Initial revision

Browse Source
This commit is contained in:
cvs
2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

722
difrac/basinp.f Normal file
View File

@@ -0,0 +1,722 @@
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