286 lines
11 KiB
Fortran
286 lines
11 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Subroutine to calculate 2Theta, chi,phi when Dpsi=0
|
|
C and 2Theta,omega,chi,phi otherwise
|
|
C IVALID = 32 if 2theta .ge. 180.0
|
|
C 16 if low temp. and chi is not in +/- 90 range
|
|
C 8 if reflection is 0,0,0, or
|
|
C 4 if not within 2Theta limits, or
|
|
C 2 if lattice or specific absence, or
|
|
C 1 if translation absence.
|
|
C IROT=1 if rotation is not possible
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE ANGCAL
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION Q(3,3),VEC(3)
|
|
CHARACTER INTFLT*3
|
|
RAD = 1.0/DEG
|
|
SM4 = 2.0*SIN(THEMIN*RAD*0.5)
|
|
SM4 = SM4*SM4
|
|
SS4 = 2.0*SIN(THEMAX*RAD*0.5)
|
|
SS4 = SS4*SS4
|
|
IROT = 0
|
|
IVALID = 0
|
|
C-----------------------------------------------------------------------
|
|
C If called by RA allow for fractional h,k,l values
|
|
C-----------------------------------------------------------------------
|
|
INTFLT = 'INT'
|
|
IF ((KI .EQ. 'RA' .OR. KI .EQ. 'SR' .OR. KI .EQ. 'MS') .AND.
|
|
$ (ABS(RFREE(1) - IH) .GT. 0.0001 .OR.
|
|
$ ABS(RFREE(2) - IK) .GT. 0.0001 .OR.
|
|
$ ABS(RFREE(3) - IL) .GT. 0.0001)) INTFLT = 'FLT'
|
|
IF (INTFLT .EQ. 'INT') THEN
|
|
RH = IH
|
|
RK = IK
|
|
RL = IL
|
|
ELSE
|
|
RH = RFREE(1)
|
|
RK = RFREE(2)
|
|
RL = RFREE(3)
|
|
ENDIF
|
|
IF (INTFLT .EQ. 'INT') THEN
|
|
C-----------------------------------------------------------------------
|
|
C Test for the 0,0,0 reflection
|
|
C-----------------------------------------------------------------------
|
|
IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN
|
|
IVALID = 8
|
|
IF (IPRVAL .NE. 0) THEN
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Test for translation and lattice absences
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .NE. 'IE') CALL DEQHKL (NHKL,0)
|
|
IF (IVALID .NE. 0 .AND. IPRVAL .NE. 0) THEN
|
|
WRITE (COUT,11000) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Tests for typed in specific absence conditions (NCOND .GT. 0)
|
|
C If only the direction is of interest (NN), bypass these tests.
|
|
C-----------------------------------------------------------------------
|
|
IF (NCOND .GT. 0 .AND. NN .NE. -1) THEN
|
|
DO 100 J = 1,NCOND
|
|
JCOND = ICOND(J)
|
|
IF ((JCOND .EQ. 1 .AND. IH .EQ. 0 .AND. IK .EQ. 0) .OR.
|
|
$ (JCOND .EQ. 2 .AND. IH .EQ. 0 .AND. IL .EQ. 0) .OR.
|
|
$ (JCOND .EQ. 3 .AND. IK .EQ. 0 .AND. IL .EQ. 0) .OR.
|
|
$ (JCOND .EQ. 4 .AND. IH .EQ. 0) .OR.
|
|
$ (JCOND .EQ. 5 .AND. IK .EQ. 0) .OR.
|
|
$ (JCOND .EQ. 6 .AND. IL .EQ. 0) .OR.
|
|
$ JCOND .EQ. 7) THEN
|
|
LHS = IABS(IH*IHS(J) + IK*IKS(J) + IL*ILS(J))
|
|
M = IR(J)
|
|
IF (MOD(LHS,M) .NE. IS(J)) THEN
|
|
IVALID = 2
|
|
IF (IPRVAL .NE. 0) THEN
|
|
WRITE (COUT,12000) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
100 CONTINUE
|
|
ENDIF
|
|
ENDIF
|
|
SUM = 0.0
|
|
DO 110 I = 1,3
|
|
VEC(I) = R(I,1)*RH + R(I,2)*RK + R(I,3)*RL
|
|
SUM = SUM + VEC(I)*VEC(I)
|
|
110 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Calculate Theta from SINABS to avoid segment problems
|
|
C Test for 2Theta limits, if not a reference reflection and print
|
|
C error message if not the UM command.
|
|
C-----------------------------------------------------------------------
|
|
SINMAX = RH*RH*SINABS(1) + RK*RK*SINABS(2) + RL*RL*SINABS(3) +
|
|
$ RH*RK*SINABS(4) + RH*RL*SINABS(5) + RK*RL*SINABS(6)
|
|
IF (ISTAN .EQ. 0 .AND. NN .NE. -1) THEN
|
|
IF (IUMPTY .EQ. 0 .AND. SINMAX .GE. 4.0) THEN
|
|
IF (INTFLT .EQ. 'INT') THEN
|
|
WRITE (COUT,13000) IH,IK,IL
|
|
ELSE
|
|
WRITE (COUT,13100) RH,RK,RL
|
|
ENDIF
|
|
CALL GWRITE (ITP,' ')
|
|
IVALID = 32
|
|
RETURN
|
|
ENDIF
|
|
IF (SINMAX .LT. SM4 .OR. SINMAX .GT. SS4) THEN
|
|
IVALID = 4
|
|
IF (IPRVAL .NE. 0) THEN
|
|
IF (INTFLT .EQ. 'INT') THEN
|
|
WRITE (COUT,14000) IH,IK,IL
|
|
ELSE
|
|
WRITE (COUT,14100) RH,RK,RL
|
|
ENDIF
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
CALL CALANG (VEC)
|
|
CALL CHICOL
|
|
C-----------------------------------------------------------------------
|
|
C Rotation about scattering vector. Omega,Chi,Phi for a given Psi
|
|
C-----------------------------------------------------------------------
|
|
C Modified MK. Make PSI calculation all the time and add 180 to PSI
|
|
C This is because TRICS seems to have a PSI rotation by 180 degree
|
|
C hidden in its setup. This may be WRONG!
|
|
C IF (ISTAN .EQ. 0 .AND. DPSI .NE. 0) THEN
|
|
C
|
|
IF(.TRUE.) THEN
|
|
PSIDUM = PSI + 180
|
|
IF(PSIDUM .GT. 360) PSIDUM = PSIDUM - 360.
|
|
CHO = CHI*RAD
|
|
PHO = PHI*RAD
|
|
C PSO = PSI*RAD
|
|
PSO = PSIDUM*RAD
|
|
Q(3,1) = SIN(PSO)*SIN(PHO) - COS(PSO)*SIN(CHO)*COS(PHO)
|
|
Q(3,2) = -SIN(PSO)*COS(PHO) - COS(PSO)*SIN(CHO)*SIN(PHO)
|
|
Q(3,3) = COS(PSO)*COS(CHO)
|
|
Q(1,3) = SIN(CHO)
|
|
Q(2,3) = SIN(PSO)*COS(CHO)
|
|
OMEGA = DEG*ATAN2(-Q(2,3), Q(1,3))
|
|
PHI = DEG*ATAN2(-Q(3,2),-Q(3,1))
|
|
CHI = DEG*ATAN2(SQRT(Q(3,1)*Q(3,1) + Q(3,2)*Q(3,2)),Q(3,3))
|
|
IF (OMEGA .LT. 0) OMEGA = OMEGA + 360.0
|
|
IF (PHI .LT. 0) PHI = PHI + 360.0
|
|
IF (OMEGA .LT. 270.0 .AND. OMEGA .GT. 90.0) THEN
|
|
PHI = PHI + 180.0
|
|
CHI = 360.0 - CHI
|
|
OMEGA = 180.0 + OMEGA
|
|
ENDIF
|
|
IF (PHI .GE. 360.0) PHI = PHI - 360.0
|
|
IF (OMEGA .GE. 360.0) OMEGA = OMEGA - 360.0
|
|
CALL OMGCOL
|
|
IF (IROT .EQ. 0) CALL CHICOL
|
|
ENDIF
|
|
CALL MOD360 (OMEGA)
|
|
CALL MOD360 (CHI)
|
|
CALL ANGCHECK(THETA,OMEGA,CHI,PHI,IVALID)
|
|
IF(IVALID .GE. 4) IROT = 1
|
|
RETURN
|
|
10000 FORMAT (' Reflection 0,0,0 is invalid.')
|
|
11000 FORMAT (' Reflection',3I4,' is a systematic absence')
|
|
12000 FORMAT (' Reflection',3I4,' is a specified absence')
|
|
13000 FORMAT (' Reflection',3I4,' has 2theta .ge. 180. Impossible!')
|
|
13100 FORMAT (' Reflection',3F8.3,' has 2theta .ge. 180. Impossible!')
|
|
14000 FORMAT (' Reflection',3I4,' is outside the 2theta limits ')
|
|
14100 FORMAT (' Reflection',3F8.3,' is outside the 2theta limits ')
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Calculate 2Theta, Chi, Phi for the Omega=0 position
|
|
C If chi .gt. 89.999 (cos**2(89.999) = 3.0E-10) chi is set to 90.0
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE CALANG (VEC)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION VEC(3)
|
|
BOT = ABS(VEC(1))
|
|
CEN = ABS(VEC(2))
|
|
TOP = ABS(VEC(3))
|
|
IF (BOT .EQ. 0.0) THEN
|
|
PHI = 90.0
|
|
ELSE
|
|
PHI = ATAN2(CEN,BOT)*DEG
|
|
ENDIF
|
|
SUM = SUM - TOP*TOP
|
|
IF (SUM .LT. 3.0E-10) THEN
|
|
CHI = 90.0
|
|
ELSE
|
|
CHI = ATAN2(TOP,SQRT(SUM))*DEG
|
|
ENDIF
|
|
IF (VEC(3) .LT. 0.0) CHI = 360.0 - CHI
|
|
IF (VEC(1) .LT. 0.0) THEN
|
|
IF (VEC(2) .LT. 0.0) THEN
|
|
PHI = 180.0 + PHI
|
|
ELSE
|
|
PHI = 180.0 - PHI
|
|
ENDIF
|
|
ELSE
|
|
IF (VEC(2) .LT. 0.0) PHI = 360.0 - PHI
|
|
ENDIF
|
|
IF (CHI .EQ. 90.0 .OR. CHI .EQ. 270.0) PHI = 0.0
|
|
SINSQ = 0.25*(SUM + TOP*TOP)
|
|
IF (SINSQ .GE. 0.999999) THEN
|
|
THETA = 180.0
|
|
ELSE
|
|
THETA = 2.0*DEG*ATAN(SQRT(SINSQ/(1.0 - SINSQ)))
|
|
ENDIF
|
|
OMEGA = 0.0
|
|
C-----------------------------------------------------------------------
|
|
C Bisecting or parallel mode IBSECT = 0/1 (forced 0)
|
|
C-----------------------------------------------------------------------
|
|
IF (IBSECT .EQ. 1) THEN
|
|
PHI = PHI + 90.0
|
|
IF (PHI .GE. 360.0) PHI = PHI - 360.0
|
|
OMEGA = CHI + 270.0
|
|
IF (OMEGA .GE. 360.0) OMEGA = OMEGA - 360.0
|
|
CHI = 90.0
|
|
CALL OMGCOL
|
|
IF (IROT .EQ. 0) CALL CHICOL
|
|
ENDIF
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Test if rotation is possible without omega collisions.
|
|
C Limits are set for 4 possible collisions as follows :--
|
|
C a. Chi ring with front of tube housing;
|
|
C b. Chi ring with rear of tube housing;
|
|
C c. Chi ring with front of detector mount;
|
|
C d. Chi ring with rear of detector mount attenuator housing.
|
|
C For a. and d. omega is in the range 0 to 90, and
|
|
C for b. and c. omega is in the range 270 to 360.
|
|
C The chi ring has an angular half width DELCHI = 16degs.
|
|
C The angular restrictions for a., b., c. and d. are
|
|
C DELA = 13, DELB = 31, DELC = 5, DELD = 33, each plus DELCHI.
|
|
C If chi is in the range 53 to 117, i.e. in a position where the phi
|
|
C base could be caught between the front of the tube housing and the
|
|
C detector mount, DELCHI must be increased by 3 for a. and 6 for c.
|
|
C The limits are conservative, but will need to be changed for
|
|
C different instruments.
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE OMGCOL
|
|
INCLUDE 'COMDIF'
|
|
DELCHI = 16.0
|
|
DELA = 13.0
|
|
DELB = 31.0
|
|
DELC = 5.0
|
|
DELD = 33.0
|
|
CHIBOT = 53.0
|
|
CHITOP = 117.0
|
|
IROT = 0
|
|
THET = 0.5*THETA
|
|
IF (OMEGA .LT. 90.0) THEN
|
|
OMEGAD = OMEGA
|
|
T1 = 90.0 - DELA - DELCHI - THET
|
|
IF (CHI .GT. CHIBOT .AND. CHI .LT. CHITOP) T1 = T1 - 3.0
|
|
T2 = 90.0 - DELD - DELCHI + THET
|
|
ELSE
|
|
OMEGAD = 360.0 - OMEGA
|
|
T1 = 90.0 - DELB - DELCHI + THET
|
|
T2 = 90.0 - DELC - DELCHI - THET
|
|
IF (CHI .GT. CHIBOT .AND. CHI .LT. CHITOP) T2 = T2 - 6.0
|
|
ENDIF
|
|
IF (OMEGAD .GE. T1 .OR. OMEGAD .GE. T2) IROT = 1
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Sample routine to ensure that the range of CHI is restricted when
|
|
C there is a cryostat on the instrument.
|
|
C It is assumed that 2thetamax is set realistically to ensure that
|
|
C there will be no OMEGA collisions with the cryostat.
|
|
C CHI is restricted to the range +/- 90
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE CHICOL
|
|
INCLUDE 'COMDIF'
|
|
IF (ILN .EQ. 1) THEN
|
|
IF (CHI .GE. 270.0 .OR. CHI .LE. 90.0) THEN
|
|
IVALID = 0
|
|
ELSE
|
|
IVALID = 16
|
|
ENDIF
|
|
ENDIF
|
|
RETURN
|
|
END
|