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