638 lines
23 KiB
Fortran
638 lines
23 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C
|
|
C Reflection Alignment routine
|
|
C
|
|
C The routine has 5 entry points :--
|
|
C
|
|
C CR aligns the reflection which is already in the detector, or
|
|
C a single reflection which is set before alignment.
|
|
C AL firstly reads in h,k,l values and generates symmetry equivalent
|
|
C reflections if wanted;
|
|
C secondly aligns both + and - h,k,l values for use by MM.
|
|
C AR resumes alignment after AL has been interrupted.
|
|
C RO reads in reflections as for the first part of AL.
|
|
C IORNT .EQ. 1 does re-orientation during data collection via the
|
|
C second part of AL.
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE ALIGN
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10),
|
|
$ BPHI(10),T4(4),O4(4),C4(4),P4(4)
|
|
CHARACTER CPM*1
|
|
100 IF (KI .EQ. 'CR') WRITE (COUT,10000)
|
|
IF (KI .EQ. 'AL') WRITE (COUT,11000)
|
|
IF (KI .EQ. 'AR') WRITE (COUT,12000)
|
|
CALL GWRITE (ITP,' ')
|
|
DT = IDTDEF
|
|
DO = IDODEF
|
|
DC = IDCDEF
|
|
AFRAC = 0.5
|
|
PRESET = 1000.
|
|
C-----------------------------------------------------------------------
|
|
C Read the angle steps DT, DO and DC, counting TIME and AFRAC
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'AL' .OR. KI .EQ. 'CR' .OR. KI. EQ. 'RO') THEN
|
|
IF (DFMODL .EQ. 'CAD4') THEN
|
|
WRITE (COUT,12900)
|
|
CALL FREEFM (ITR)
|
|
DT = RFREE(1)
|
|
ISLIT = 10.0*DT + 0.5
|
|
IF (ISLIT .EQ. 0) ISLIT = 40
|
|
IF (ISLIT .LT. 10) ISLIT = 10
|
|
IF (ISLIT .GT. 60) ISLIT = 60
|
|
ELSE
|
|
ISLIT = 0
|
|
WRITE (COUT,13000) IDTDEF,IDODEF,IDCDEF,IFRDEF
|
|
CALL FREEFM (ITR)
|
|
DT = RFREE(1)
|
|
DO = RFREE(2)
|
|
DC = RFREE(3)
|
|
IF (DT .EQ. 0) DT = IDTDEF
|
|
IF (DO .EQ. 0) DO = IDODEF
|
|
IF (DC .EQ. 0) DC = IDCDEF
|
|
DT = DT/IFRDEF
|
|
DO = DO/IFRDEF
|
|
DC = DC/IFRDEF
|
|
WRITE (COUT,14000)
|
|
CALL FREEFM (ITR)
|
|
PRESET = RFREE(1)
|
|
IF (PRESET .EQ. 0.0) PRESET = 1000.
|
|
WRITE (COUT,15000)
|
|
CALL FREEFM (ITR)
|
|
AFRAC = RFREE(1)
|
|
IF (AFRAC .EQ. 0.) AFRAC = 0.5
|
|
WRITE (COUT,16000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') GO TO 100
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C For CR, set the reflection if necessary
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'CR') THEN
|
|
ITRY = 1
|
|
IHSET = 0
|
|
WRITE (COUT,17000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
110 WRITE (COUT,18000)
|
|
CALL FREEFM (ITR)
|
|
IH = IFREE(1)
|
|
IK = IFREE(2)
|
|
IL = IFREE(3)
|
|
IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
IHSET = 1
|
|
MREF = MREF + 1
|
|
CALL HKLN (IH,IK,IL,MREF)
|
|
IPRVAL = 1
|
|
CALL ANGCAL
|
|
IF (IVALID .NE. 0) GO TO 110
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
|
IF (ICC .NE. 0) THEN
|
|
WRITE (COUT,19000)
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 110
|
|
ENDIF
|
|
ENDIF
|
|
IF (IHSET .EQ. 0) THEN
|
|
WRITE (COUT,20000)
|
|
CALL FREEFM (ITR)
|
|
IHNEW = IFREE(1)
|
|
IKNEW = IFREE(2)
|
|
ILNEW = IFREE(3)
|
|
IF (IHNEW .NE. 0 .OR. IKNEW .NE. 0 .OR. ILNEW .NE. 0) THEN
|
|
IH = IHNEW
|
|
IK = IKNEW
|
|
IL = ILNEW
|
|
ENDIF
|
|
ENDIF
|
|
CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI)
|
|
WRITE (COUT,21000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI
|
|
CALL GWRITE (ITP,' ')
|
|
IF (LPT .NE. ITP) WRITE (LPT,21000)
|
|
$ IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI
|
|
115 CALL HKLN (IH,IK,IL,MREF)
|
|
CALL WXW2T (DT,DO,DC,ISLIT)
|
|
IF (KI .EQ. 'FF') THEN
|
|
IF (ITRY .EQ. 1) THEN
|
|
WRITE (COUT,22000) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
ITRY = 2
|
|
IPRVAL = 1
|
|
CALL ANGCAL
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
|
GO TO 115
|
|
ELSE
|
|
WRITE (COUT,22100) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
CALL SHUTTR (1)
|
|
CALL CTIME (PRESET,CT1)
|
|
CALL SHUTTR (-1)
|
|
WRITE (COUT,23000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1
|
|
CALL GWRITE (ITP,' ')
|
|
IF (LPT .NE. ITP) WRITE (LPT,23000)
|
|
$ IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1
|
|
WRITE (COUT,24000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') THEN
|
|
WRITE (COUT,25000)
|
|
CALL FREEFM (ITR)
|
|
I = IFREE(1)
|
|
IHK(I) = IH
|
|
NREFB(I) = IK
|
|
ILA(I) = IL
|
|
BCOUNT(I) = RTHETA
|
|
BBGR1(I) = ROMEGA
|
|
BBGR2(I) = RCHI
|
|
BTIME(I) = RPHI
|
|
ENDIF
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C AR -- Resume AL-type alignment from where it was interrupted.
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'AR') THEN
|
|
READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC
|
|
READ (IID,REC=17) (IOK(J),J = 1,80),NTOT
|
|
READ (IID,REC=18) (IOL(J),J = 1,80)
|
|
READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100)
|
|
IF (DFMODL .EQ. 'CAD4') THEN
|
|
ISLIT = 10.0*DT + 0.5
|
|
IF (ISLIT .EQ. 0) ISLIT = 40
|
|
ENDIF
|
|
NBLOKO = 250
|
|
NDONE = 0
|
|
120 READ (ISD,REC=NBLOKO)
|
|
$ (JUNK,I = 1,80),NINBLK,NLIST,IPLUS,NTOT,NBLOKO
|
|
IF (NINBLK .NE. 0) THEN
|
|
NBLOKO = NBLOKO + 1
|
|
NDONE = NDONE + NINBLK
|
|
GO TO 120
|
|
ENDIF
|
|
NBLOKO = NBLOKO - 1
|
|
READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,
|
|
$ BPSI,NINBLK,NLIST,IPLUS,NTOT,NBLOKO
|
|
IF (IPLUS .EQ. -1) NLIST = NLIST + 1
|
|
IPLUS = -IPLUS
|
|
IH = IPLUS*IOH(NLIST)
|
|
IK = IPLUS*IOK(NLIST)
|
|
IL = IPLUS*IOL(NLIST)
|
|
WRITE (COUT,26000) NDONE,IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
NSTART = NLIST
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C AL -- First Part -- Read in a list of h,k,l values & generate
|
|
C symmetry equivs if wanted;
|
|
C Second Part -- Align the + and - Friedel reflections
|
|
C RO -- First part of AL
|
|
C Second part of AL, when IORNT = 1
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'AL' .OR. KI .EQ. 'RO') THEN
|
|
CALL ALEDIT (NTOT)
|
|
IF (NTOT .EQ. 0) THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Write the h,k,l values to file for use with AR and RO
|
|
C-----------------------------------------------------------------------
|
|
WRITE (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC
|
|
WRITE (IID,REC=17) (IOK(J),J = 1,80),NTOT
|
|
WRITE (IID,REC=18) (IOL(J),J = 1,80)
|
|
WRITE (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100)
|
|
ENDIF
|
|
IF (KI .EQ. 'RO') RETURN
|
|
C-----------------------------------------------------------------------
|
|
C Read in data if IORNT = 1 (RO)
|
|
C-----------------------------------------------------------------------
|
|
IF (IORNT .EQ. 1) THEN
|
|
READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC
|
|
READ (IID,REC=17) (IOK(J),J = 1,80),NTOT
|
|
READ (IID,REC=18) (IOL(J),J = 1,80)
|
|
READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100)
|
|
WRITE (LPT,27000) NREF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Get ready for the second part of AL or OR
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'AL' .OR. IORNT .EQ. 1) THEN
|
|
NBLOKO = 250
|
|
NINBLK = 0
|
|
MREF = 0
|
|
NSTART = 1
|
|
IPLUS = 1
|
|
IHSV = IH
|
|
IKSV = IK
|
|
ILSV = IL
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Do alignment on these reflections (+ and -)
|
|
C-----------------------------------------------------------------------
|
|
DO 150 NLIST = NSTART,NTOT
|
|
130 IH = IPLUS*IOH(NLIST)
|
|
IK = IPLUS*IOK(NLIST)
|
|
IL = IPLUS*IOL(NLIST)
|
|
ISTAN = 0
|
|
DPSI = 0.0
|
|
ITRY = 1
|
|
MREF = MREF + 1
|
|
NTRUE = 0
|
|
IPRVAL = 0
|
|
CALL ANGCAL
|
|
IF (IVALID .NE. 0 .AND. IVALID .NE. 4) GO TO 140
|
|
IF (DFMODL .EQ. 'CAD4' .AND. THETA .GT. 110.0 .AND.
|
|
$ (CHI .GT. 270.0 .AND. CHI .LT. 300)) THEN
|
|
WRITE (LPT,28000) IH,IK,IL
|
|
GO TO 140
|
|
ENDIF
|
|
IF (ITRUE .EQ. 1) THEN
|
|
T4(1) = THETA
|
|
T4(2) = 360.0 - THETA
|
|
T4(3) = THETA
|
|
T4(4) = 360.0 - THETA
|
|
O4(1) = OMEGA
|
|
O4(2) = OMEGA
|
|
O4(3) = OMEGA
|
|
O4(4) = OMEGA
|
|
C4(1) = CHI
|
|
C4(2) = CHI
|
|
C4(3) = 360.0 - CHI
|
|
C4(4) = 360.0 - CHI
|
|
P34 = 180.0 + PHI
|
|
IF (P34 .GE. 360.0) P34 = P34 - 360.0
|
|
P4(1) = PHI
|
|
P4(2) = PHI
|
|
P4(3) = P34
|
|
P4(4) = P34
|
|
ENDIF
|
|
135 CALL HKLN (IH,IK,IL,MREF)
|
|
IF (ITRUE .EQ. 1 .AND. ITRY .EQ. 1) THEN
|
|
NTRUE = NTRUE + 1
|
|
THETA = T4(NTRUE)
|
|
OMEGA = O4(NTRUE)
|
|
CHI = C4(NTRUE)
|
|
PHI = P4(NTRUE)
|
|
ENDIF
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
|
IF (ICC .NE. 0) GO TO 140
|
|
CPM = '+'
|
|
IF (IPLUS .EQ. -1) CPM = '-'
|
|
WRITE (LPT,29000) NLIST,CPM,IH,IK,IL,THETA,OMEGA,CHI,PHI
|
|
CALL WXW2T (DT,DO,DC,ISLIT)
|
|
IF (KI .EQ. 'FF') THEN
|
|
IF (ITRY .EQ. 1) THEN
|
|
WRITE (LPT,22000) IH,IK,IL
|
|
WRITE (COUT,22000) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
ITRY = 2
|
|
GO TO 135
|
|
ELSE
|
|
WRITE (LPT,22100) IH,IK,IL
|
|
WRITE (COUT,22100) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 140
|
|
ENDIF
|
|
ENDIF
|
|
CALL SHUTTR (1)
|
|
CALL CTIME (PRESET,CT1)
|
|
CALL SHUTTR (-1)
|
|
WRITE (LPT,30000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1
|
|
IF (ITRUE .EQ. 1) THEN
|
|
T4(NTRUE) = RTHETA
|
|
O4(NTRUE) = ROMEGA
|
|
C4(NTRUE) = RCHI
|
|
P4(NTRUE) = RPHI
|
|
IF (NTRUE .LT. 4) THEN
|
|
ITRY = 1
|
|
GO TO 135
|
|
ELSE
|
|
DO 136 I4 = 1,4
|
|
IF (T4(I4) .GT. 180.0) T4(I4) = T4(I4) - 360.0
|
|
IF (O4(I4) .GT. 180.0) O4(I4) = O4(I4) - 360.0
|
|
IF (C4(I4) .GT. 180.0) C4(I4) = C4(I4) - 360.0
|
|
136 CONTINUE
|
|
RTHETA = (T4(1) - T4(2) + T4(3) - T4(4))/4.0
|
|
ROMEGA = (O4(1) + O4(2) + O4(3) + O4(4))/4.0
|
|
IF (ROMEGA .LT. 0.0) ROMEGA = ROMEGA + 360.0
|
|
RCHI = (C4(1) + C4(2) - C4(3) - C4(4))/4.0
|
|
IF (RCHI .LT. 0.0) RCHI = RCHI + 360.0
|
|
RPHI = P4(1)
|
|
WRITE ( LPT,22200) RTHETA,ROMEGA,RCHI,RPHI
|
|
WRITE (COUT,22200) RTHETA,ROMEGA,RCHI,RPHI
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
ENDIF
|
|
NINBLK = NINBLK + 1
|
|
IBH(NINBLK) = IH
|
|
IBK(NINBLK) = IK
|
|
IBL(NINBLK) = IL
|
|
BTHETA(NINBLK) = RTHETA
|
|
BOMEGA(NINBLK) = ROMEGA
|
|
BCHI(NINBLK) = RCHI
|
|
BPHI(NINBLK) = RPHI
|
|
BPSI(NINBLK) = 0.0
|
|
C-----------------------------------------------------------------------
|
|
C Write the block of alignment data so far
|
|
C-----------------------------------------------------------------------
|
|
WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI,
|
|
$ BPSI,NINBLK,NLIST,IPLUS,NTOT,NBLOKO
|
|
IF (NINBLK .EQ. 10) THEN
|
|
NBLOKO = NBLOKO + 1
|
|
NINBLK = 0
|
|
ENDIF
|
|
140 CALL KORQ (KQFLAG)
|
|
IF (KQFLAG .NE. 1) GO TO 160
|
|
IF (IPLUS .EQ. 1) THEN
|
|
IPLUS = -1
|
|
GO TO 130
|
|
ELSE
|
|
IPLUS = 1
|
|
ENDIF
|
|
150 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Write guard block on the end
|
|
C-----------------------------------------------------------------------
|
|
160 IF (NINBLK .GT. 0) NBLOKO = NBLOKO + 1
|
|
NINBLK = 0
|
|
WRITE (ISD,REC=NBLOKO) (IOH(I),I = 1,80),NINBLK,NINBLK,NINBLK,
|
|
$ NTOT,NBLOKO
|
|
IF (IORNT .EQ. 1) THEN
|
|
IH = IHSV
|
|
IK = IKSV
|
|
IL = ILSV
|
|
ENDIF
|
|
CALL ZERODF
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (10X,' Centre the reflection already in the detector ')
|
|
11000 FORMAT (/10X,' Alignment of Symmetry and Friedel Equivalent',
|
|
$ ' Reflections'/,'%')
|
|
12000 FORMAT (10X,' Resume alignment from the AL command')
|
|
12900 FORMAT (' Type the horizontal slit width in mms (4.0) ',$)
|
|
13000 FORMAT (' Type the size of steps in 2T,Om,Chi,',
|
|
$ ' (',I2,',',I2,',',I2,') 1/',I3,'deg ',$)
|
|
14000 FORMAT (' Type the count preset for each step (1000.0) ',$)
|
|
15000 FORMAT (' Fraction of max. count for half-height cutoff (0.5) ',$)
|
|
16000 FORMAT (' All OK (Y) ? ',$)
|
|
17000 FORMAT (' Is the reflection already set (Y) ? ',$)
|
|
18000 FORMAT (' Type h,k,l for the reflection (Exit) ',$)
|
|
19000 FORMAT (3I3,' setting collision. Try again.')
|
|
20000 FORMAT (' Type h,k,l for use in M2/M3 ',$)
|
|
21000 FORMAT (' Starting Values ',3I4,4F10.3)
|
|
22000 FORMAT (3I4,' ailignment failed on first attempt'/)
|
|
22100 FORMAT (3I4,' ailignment failed on both attempts'/)
|
|
22200 FORMAT (' Mean Values ',12X,4F10.3/)
|
|
23000 FORMAT (' Final Values ',3I4,4F10.3,F7.0/)
|
|
24000 FORMAT (' Do you wish to save the angles for M2 or M3 (Y) ? ',$)
|
|
25000 FORMAT (' What is the sequence number of this reflection ? ',$)
|
|
26000 FORMAT (I4,' reflections have been aligned. Resuming at ',3I3/)
|
|
27000 FORMAT (/' Reorientation before Reflection ',I5)
|
|
28000 FORMAT (3I4,' is probably inaccessible on a CAD-4.'/)
|
|
29000 FORMAT (I4,A,' Starting Values ',3I4,4F10.3)
|
|
30000 FORMAT (' Final Values ',3I4,4F10.3,F7.0/)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Routine to generate equivalent reflections (Not Friedel)
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE DEQHKL (NHKL,ILIST)
|
|
INCLUDE 'COMDIF'
|
|
C-----------------------------------------------------------------------
|
|
C Work out the reflection details and the unique equivalents
|
|
C-----------------------------------------------------------------------
|
|
NHKL = 0
|
|
NRCEN = 0
|
|
IEXCL = 0
|
|
DO 110 K = 1,NSYM
|
|
IM = 0
|
|
JS = 0
|
|
JH = IH*JRT(1,1,K) + IK*JRT(2,1,K) + IL*JRT(3,1,K)
|
|
JK = IH*JRT(1,2,K) + IK*JRT(2,2,K) + IL*JRT(3,2,K)
|
|
JL = IH*JRT(1,3,K) + IK*JRT(2,3,K) + IL*JRT(3,3,K)
|
|
IPHASE = IH*JRT(1,4,K) + IK*JRT(2,4,K) + IL*JRT(3,4,K)
|
|
IF (MOD(IPHASE,12) .EQ. 0) IPHASE = 0
|
|
IF (IH .EQ. JH .AND. IK .EQ. JK .AND. IL .EQ. JL) IM = 1
|
|
IF (IH .EQ. -JH .AND. IK .EQ. -JK .AND. IL .EQ. -JL) JS = 1
|
|
IF (JS .EQ. 1) NRCEN = 1
|
|
IF (IM .EQ. 1 .AND. IPHASE .NE. 0) IEXCL = 1
|
|
IF (ICENT .EQ. 0) JS = 0
|
|
IF (JS .EQ. 1 .AND. IPHASE .NE. 0) IEXCL = 1
|
|
IF (NHKL .NE. 0) THEN
|
|
DO 100 I = 1,NHKL
|
|
IF (JHKL(1,I) .EQ. JH .AND.
|
|
$ JHKL(2,I) .EQ. JK .AND.
|
|
$ JHKL(3,I) .EQ. JL) GO TO 110
|
|
IF (JHKL(1,I) .EQ. -JH .AND.
|
|
$ JHKL(2,I) .EQ. -JK .AND.
|
|
$ JHKL(3,I) .EQ. -JL) GO TO 110
|
|
100 CONTINUE
|
|
ENDIF
|
|
NHKL = NHKL + 1
|
|
JHKL(1,NHKL) = JH
|
|
JHKL(2,NHKL) = JK
|
|
JHKL(3,NHKL) = JL
|
|
110 CONTINUE
|
|
IVALID = IEXCL
|
|
IEXCL = 0
|
|
IF (LATCEN .NE. 1) THEN
|
|
IF (LATCEN .EQ. 2) IREM = MOD((IK + IL),2)
|
|
IF (LATCEN .EQ. 3) IREM = MOD((IH + IL),2)
|
|
IF (LATCEN .EQ. 4) IREM = MOD((IH + IK),2)
|
|
IF (LATCEN .EQ. 5) IREM = MOD((IH + IK + IL),2)
|
|
IF (LATCEN .EQ. 6) THEN
|
|
IREM = MOD((IH + IK),2)
|
|
IF (IREM .EQ. 0) IREM = MOD((IH + IL),2)
|
|
ENDIF
|
|
IF (LATCEN .EQ. 7) IREM = MOD((-IH + IK + IL),3)
|
|
IF (IEXCL .EQ. 0) IEXCL = IREM
|
|
ENDIF
|
|
IF (IEXCL .NE. 0) THEN
|
|
IVALID = IVALID + 2
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Print the equivalent indices
|
|
C-----------------------------------------------------------------------
|
|
IF (ILIST .EQ. 1) THEN
|
|
WRITE (COUT,10000) ((JHKL(J,K),J = 1,3),K = 1,NHKL)
|
|
CALL GWRITE (ITP,' ')
|
|
ENDIF
|
|
RETURN
|
|
10000 FORMAT (4(5X,3I4))
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Edit the h,k,l list for the AL or RO commands
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE ALEDIT (NTOT)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION NDEL(100)
|
|
CHARACTER IOPT*1
|
|
C-----------------------------------------------------------------------
|
|
C Read in the existing list of h,k,l values and write it to terminal
|
|
C-----------------------------------------------------------------------
|
|
READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC
|
|
READ (IID,REC=17) (IOK(J),J = 1,80),NTOT
|
|
READ (IID,REC=18) (IOL(J),J = 1,80)
|
|
READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100)
|
|
100 IF (NTOT .LE. 0) THEN
|
|
WRITE (COUT,10000)
|
|
CALL GWRITE (ITP,' ')
|
|
ELSE
|
|
WRITE (COUT,11000) NTOT
|
|
CALL GWRITE (ITP,' ')
|
|
NLINE = NTOT/4
|
|
IF (NTOT - 4*NLINE .NE. 0) NLINE = NLINE + 1
|
|
I1 = 1
|
|
I2 = 4
|
|
DO 110 N = 1,NLINE
|
|
IF (N .EQ. NLINE) I2 = NTOT
|
|
WRITE (COUT,12000) (I,IOH(I),IOK(I),IOL(I),I = I1,I2)
|
|
CALL GWRITE (ITP,' ')
|
|
I1 = I1 + 4
|
|
I2 = I2 + 4
|
|
110 CONTINUE
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Get the edit option IOPT
|
|
C-----------------------------------------------------------------------
|
|
WRITE (COUT,13000)
|
|
CALL ALFNUM (IOPT)
|
|
IF (IOPT .EQ. ' ') IOPT = 'U'
|
|
C-----------------------------------------------------------------------
|
|
C Option E. Exit from AL with 0 reflns
|
|
C-----------------------------------------------------------------------
|
|
IF (IOPT .EQ. 'E') THEN
|
|
NTOT = 0
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Option U. Use the present list and get the TRUANG flag.
|
|
C-----------------------------------------------------------------------
|
|
IF (IOPT .EQ. 'U') THEN
|
|
ITRUE = 0
|
|
WRITE (COUT,14100)
|
|
CALL YESNO ('N',ANS)
|
|
IF (ANS .EQ. 'Y') ITRUE = 1
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Options A and N. Add reflns or use new ones.
|
|
C-----------------------------------------------------------------------
|
|
IF (IOPT .EQ. 'A' .OR. IOPT .EQ. 'N') THEN
|
|
IF (IOPT .EQ. 'N') NTOT = 0
|
|
ISYMOR = 0
|
|
WRITE (COUT,14000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'Y') THEN
|
|
ISYMOR = 1
|
|
IOUT = -1
|
|
CALL SPACEG (IOUT,0)
|
|
ENDIF
|
|
NPOSS = 100 - NTOT
|
|
WRITE (COUT,15000) NPOSS
|
|
CALL GWRITE (ITP,' ')
|
|
120 WRITE (COUT,16000)
|
|
CALL FREEFM (ITR)
|
|
IH = IFREE(1)
|
|
IK = IFREE(2)
|
|
IL = IFREE(3)
|
|
IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
|
|
IPRVAL = 1
|
|
CALL ANGCAL
|
|
IF (IVALID .EQ. 0) THEN
|
|
IF (ISYMOR .EQ. 1) THEN
|
|
ILIST = 1
|
|
CALL DEQHKL (NHKL,ILIST)
|
|
DO 130 I = 1,NHKL
|
|
NTOT = NTOT + 1
|
|
IOH(NTOT) = JHKL(1,I)
|
|
IOK(NTOT) = JHKL(2,I)
|
|
IOL(NTOT) = JHKL(3,I)
|
|
IF (NTOT .EQ. NSIZE/2) THEN
|
|
WRITE (COUT,17000)
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 100
|
|
ENDIF
|
|
130 CONTINUE
|
|
ELSE
|
|
NTOT = NTOT + 1
|
|
IOH(NTOT) = IH
|
|
IOK(NTOT) = IK
|
|
IOL(NTOT) = IL
|
|
ENDIF
|
|
ENDIF
|
|
GO TO 120
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Option D. Delete reflections from the list
|
|
C-----------------------------------------------------------------------
|
|
IF (IOPT .EQ. 'D') THEN
|
|
DO 140 I = 1,100
|
|
NDEL(I) = 0
|
|
140 CONTINUE
|
|
150 WRITE (COUT,18000)
|
|
CALL FREEFM (ITR)
|
|
IH = IFREE(1)
|
|
IK = IFREE(2)
|
|
IL = IFREE(3)
|
|
IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
|
|
DO 160 N = 1,NTOT
|
|
IF (IH .EQ. IOH(N) .AND. IK .EQ. IOK(N) .AND.
|
|
$ IL .EQ. IOL(N)) THEN
|
|
NDEL(N) = 1
|
|
GO TO 150
|
|
ENDIF
|
|
160 CONTINUE
|
|
WRITE (COUT,19000) IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 150
|
|
ELSE
|
|
C-----------------------------------------------------------------------
|
|
C Form the new list
|
|
C-----------------------------------------------------------------------
|
|
NEW = 0
|
|
DO 170 N = 1,NTOT
|
|
IF (NDEL(N) .EQ. 0) THEN
|
|
NEW = NEW + 1
|
|
IOH(NEW) = IOH(N)
|
|
IOK(NEW) = IOK(N)
|
|
IOL(NEW) = IOL(N)
|
|
ENDIF
|
|
170 CONTINUE
|
|
NTOT = NEW
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C List the existing list and get new option
|
|
C-----------------------------------------------------------------------
|
|
GO TO 100
|
|
10000 FORMAT (' There are no reflections in the AL/RO list.')
|
|
11000 FORMAT (' The following',I4,' reflections are in the AL/RO list')
|
|
12000 FORMAT (4(I3,'.',3I4,3X))
|
|
13000 FORMAT (' The following options are available :--'/
|
|
$ ' U. Use the existing AL/RO list;'/
|
|
$ ' A. Add reflections to the existing AL/RO list;'/
|
|
$ ' D. Delete reflections from the existing AL/RO list;'/
|
|
$ ' N. New AL/RO list.'/
|
|
$ ' L. List the reflections in the existing AL/RO list;'/
|
|
$ ' E. Exit from AL/RO.'/
|
|
$ ' Which option do you want (U) ? ',$)
|
|
14000 FORMAT (' Friedel equivalents are always used.'/
|
|
$ ' Do you want symmetry equivalents as well (Y) ? ',$)
|
|
14100 FORMAT (' Align 4 equivalent settings for each refln (N) ? ',$)
|
|
15000 FORMAT (' Type h,k,l for up to',I4,' reflections ')
|
|
16000 FORMAT (' h,k,l (End) ',$)
|
|
17000 FORMAT (' No more reflections allowed.')
|
|
18000 FORMAT (' Type h,k,l for the reflection to be deleted (End) ',$)
|
|
19000 FORMAT (3I4,' not found. Try again please.')
|
|
END
|