Initial revision
This commit is contained in:
cvs
637
difrac/align.f
Normal file
637
difrac/align.f
Normal file
@@ -0,0 +1,637 @@
|
||||
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
|
||||
Reference in New Issue
Block a user