714b8ae84d
- Fixed many things in DIFRAC subsystem:
* Recoded tcentr.f etc so that the course centering will work and will not
go into an endless loop.
* fixed boundary overwrites which occurred when yesno or alfnum where
uset to get a single character and several were given.
* Addeded documentation for DIFRAC
- Added tcl-files which support the WWW status system
126 lines
4.4 KiB
Fortran
126 lines
4.4 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C This subroutine calculates the reciprocal coordinates of a reflection
|
|
C Called by 3 commands :--
|
|
C AH - to convert Euler angles to h,k,l
|
|
C MR - to convert direct beam Euler angles to h,k,l
|
|
C FI - to convert face indexing Euler angles to h,k,l
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE RCPCOR
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION RM1(3,3),XA(3),HA(3)
|
|
CHARACTER STRING*80
|
|
IF (KI .EQ. 'AH') THEN
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
CALL MATRIX (R,RM1,RJUNK,RJUNK,'INVERT')
|
|
100 IF (KI .EQ. 'MR') THEN
|
|
CALL ANGET (THETAS,OMEGS,CHIS,PHIS)
|
|
OMEGS = OMEGS - 90.0 + 0.5*THETAS
|
|
ELSE IF (KI .EQ. 'FI') THEN
|
|
THETAS = THETA
|
|
OMEGS = OMEGA
|
|
CHIS = CHI
|
|
PHIS = PHI
|
|
ELSE
|
|
WRITE (COUT,11000)
|
|
CALL FREEFM (ITR)
|
|
IF (RFREE(1) .EQ. 0) THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
THETAS = RFREE(1)
|
|
OMEGS = RFREE(2)
|
|
CHIS = RFREE(3)
|
|
PHIS = RFREE(4)
|
|
ENDIF
|
|
CO = COS(OMEGS/DEG)
|
|
SO = SIN(OMEGS/DEG)
|
|
CC = COS(CHIS/DEG)
|
|
SC = SIN(CHIS/DEG)
|
|
CP = COS(PHIS/DEG)
|
|
SP = SIN(PHIS/DEG)
|
|
ESS = 2.0*SIN(THETAS/(2.0*DEG))
|
|
XA(1) = ESS*(CO*CC*CP - SO*SP)
|
|
XA(2) = ESS*(CO*CC*SP + SO*CP)
|
|
XA(3) = ESS*CO*SC
|
|
CALL MATRIX (RM1,XA,HA,RJUNK,'MVMULT')
|
|
WRITE (COUT,12000) HA
|
|
CALL GWRITE (ITP,' ')
|
|
IF (KI .EQ. 'MR') KI = ' '
|
|
IF (KI .EQ. 'MR' .OR. KI .EQ. 'FI') RETURN
|
|
GO TO 100
|
|
10000 FORMAT (' Calculate Reciprocal Coordinates ')
|
|
11000 FORMAT (' Type the reflection angles (End) ',$)
|
|
12000 FORMAT (5X,' Reciprocal Coordinates (h,k,l)',3F10.3)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Index faces for ABSORP when they are set so that the face normal is
|
|
C in the equator plane and normal to the microscope viewing direction
|
|
C at the Kappa angles -45, 78, kappa (-60 start), phi (0 start)
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE FACEIN
|
|
CHARACTER STRING*80
|
|
INCLUDE 'COMDIF'
|
|
DATA ISENSE/-1/
|
|
NATT = 0
|
|
ICOL = 0
|
|
C-----------------------------------------------------------------------
|
|
C Set the microscope to the initial viewing position and print message
|
|
C The viewing position Kappa angles are -45, 78, -60, 0
|
|
C The Euler equivalent is used below.
|
|
C-----------------------------------------------------------------------
|
|
THETA = -90.0
|
|
OMEGA = 102.63
|
|
CHI = -45.0
|
|
PHI = -20.37
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
C-----------------------------------------------------------------------
|
|
C Get the adjusted angles and transform them
|
|
C-----------------------------------------------------------------------
|
|
100 WRITE (COUT,11000)
|
|
CALL ALFNUM (STRING)
|
|
ANS = STRING(1:1)
|
|
C write (cout,99990)
|
|
C99990 format (' Type omk, kap, phk for face ',$)
|
|
C call freefm (itr)
|
|
C omk = rfree(1)
|
|
C if (omk .eq. 0) omk = 78.0
|
|
C rka = rfree(2)
|
|
C phk = rfree(3)
|
|
C call eulkap (1,omega,chi,phi,omk,rka,phk,isttus)
|
|
C99991 format (i3,7f8.2)
|
|
CALL ANGET (THETA,OMEGA,CHI,PHI)
|
|
CALL EULKAP (0,OMEGA,CHI,PHI,OMK,RKA,PHK,ISTTUS)
|
|
C i = 2
|
|
C write (COUT,99991) i,theta,omega,chi,phi,omk,rka,phk
|
|
C call gwrite (itp, ' ')
|
|
C OMK = OMK - 135.0
|
|
IRL = 1
|
|
IF (ANS .EQ. 'L') IRL = 0
|
|
OMK = OMK - IRL*180.0
|
|
CALL EULKAP (1,OMEGA,CHI,PHI,OMK,RKA,PHK,ISTTUS)
|
|
THETA = 20.0
|
|
C i = 3
|
|
C write (COUT,99991) i,theta,omega,chi,phi,omk,rka,phk
|
|
C call gwrite (itp, ' ')
|
|
CALL RCPCOR
|
|
WRITE (COUT,12000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') GO TO 100
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (/20X,' CAD-4 Face Indexing'/
|
|
$ ' Adjust Kappa and Phi with the pocket terminal,',
|
|
$ ' so that the face-normal is'/
|
|
$ ' a. Horizontal,'/
|
|
$ ' b. Normal to the view direction, pointing right',
|
|
$ ' or left.')
|
|
11000 FORMAT (' When the face is set correctly, type R or L to',
|
|
$ ' indicate whether'/
|
|
$ ' the normal is pointing to the Right or Left (R) ',$)
|
|
12000 FORMAT (/' Index another face (Y) ? ',$)
|
|
END
|