Initial revision
This commit is contained in:
cvs
436
difrac/begin.f
Normal file
436
difrac/begin.f
Normal file
@@ -0,0 +1,436 @@
|
||||
C-----------------------------------------------------------------------
|
||||
C This subroutine reads the info necessary to start the data collection
|
||||
C at the start of data collection and at each new segment
|
||||
C Modofied to give output to ITP-->SICS, MK
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE BEGIN
|
||||
INCLUDE 'COMDIF'
|
||||
DIMENSION INDX(3),ISET(25),DHC(3,3),JUNKP(200),FDH(3,3),
|
||||
$ FDHI(3,3)
|
||||
EQUIVALENCE (ACOUNT(301),JUNKP(1))
|
||||
IRES = 0
|
||||
100 IF (ISEG .EQ. 0) THEN
|
||||
IF (IAUTO .NE. 1) THEN
|
||||
C-----------------------------------------------------------------------
|
||||
C GO entry point
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,10000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Save the Basic Data in the first 3 blocks of the IDATA file
|
||||
C-----------------------------------------------------------------------
|
||||
CALL WRBAS
|
||||
IF (ILN .EQ. 1) THEN
|
||||
WRITE (COUT,11000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') ILN = 0
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Is this run manual?
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IKO(5) .NE. -777) THEN
|
||||
WRITE (COUT,12000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'Y') THEN
|
||||
NB = 1
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Was the last automatic run stopped by K or Q ?
|
||||
C-----------------------------------------------------------------------
|
||||
IKO(5) = -777
|
||||
IAUTO = 1
|
||||
CALL WRBAS
|
||||
C-----------------------------------------------------------------------
|
||||
C IHO(5) = 0/1 Normal sequence/Pointer mode
|
||||
C IHO(6) = Sequence number of the present set in the Pointer mode
|
||||
C IHO(7) = 0/1 Do not/Do measure the translation-element absences
|
||||
C IHO(8),IKO(8),ILO(8) = Indices of current reflection
|
||||
C IKO(5) = -777 if DH matrices were NOT typed in
|
||||
C IKO(6) = 0/1 Acentric/Centric Space-group
|
||||
C-----------------------------------------------------------------------
|
||||
IHO(5) = 0
|
||||
ZERO = 0
|
||||
SAVE = NBLOCK
|
||||
READ (IID,REC=9) IRES,IND,NSET,IPOINT,IHO(5)
|
||||
WRITE (IID,REC=9) ZERO
|
||||
NBLOCK = SAVE
|
||||
C-----------------------------------------------------------------------
|
||||
C Propose an automatic restart
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IRES .EQ. 1) THEN
|
||||
WRITE (COUT,13000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'Y') GO TO 170
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Call the space-group generation routines
|
||||
C-----------------------------------------------------------------------
|
||||
IOUT = -1
|
||||
CALL SPACEG (IOUT,1)
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C The information written by the space-group routines is :--
|
||||
C LATCEN Lattice-centering code
|
||||
C 1=P 2=A 3=B 4=C 5=I 6=F 7=R
|
||||
C NSYM Number of matrices generated
|
||||
C JRT The matrices generated
|
||||
C IPOINT The number of set pointers entered
|
||||
C ICENT 0/1 Acentric/Centric
|
||||
C JUNKP The set pointers
|
||||
C LAUENO The Laue group code
|
||||
C 1=-1, 2=2/m, 3=mmm, 4=4/m, 5=4/mmm, 6=R-3R, 7=R-3mR
|
||||
C 8=-3, 9=-31m, 10=-3m1, 11=6/m, 12=6/mmm, 13=m3, 14=m3m
|
||||
C-----------------------------------------------------------------------
|
||||
NUMDH = NSEG
|
||||
IPOINT = NSET
|
||||
IKO(6) = ICENT
|
||||
C-----------------------------------------------------------------------
|
||||
C Constrain the orientation matrix according to the Laue group
|
||||
C-----------------------------------------------------------------------
|
||||
IF ( LAUENO .GE. 13) ISYS = 7
|
||||
IF (LAUENO .GE. 8 .AND. LAUENO .LT. 13) ISYS = 5
|
||||
IF (LAUENO .GE. 6 .AND. LAUENO .LT. 8) ISYS = 6
|
||||
IF (LAUENO .LT. 6) THEN
|
||||
ISYS = LAUENO
|
||||
IF (LAUENO .EQ. 5) ISYS = 4
|
||||
IF (LAUENO .EQ. 2) ISYS = 7 + NAXIS
|
||||
ENDIF
|
||||
CALL SINMAT
|
||||
C-----------------------------------------------------------------------
|
||||
C Propose a package deal.
|
||||
C Start at Refln 1, Segment 1, Set 1, at Record 20
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,14000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'Y') THEN
|
||||
NREF = 1
|
||||
NMSEG = 1
|
||||
NSET = 1
|
||||
IPOINT = 1
|
||||
NBLOCK = 20
|
||||
IND(1) = 0
|
||||
IND(2) = 0
|
||||
IND(3) = 0
|
||||
ELSE
|
||||
C-----------------------------------------------------------------------
|
||||
C Get detailed information from the terminal
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,15000)
|
||||
CALL FREEFM (ITR)
|
||||
IND(1) = IFREE(1)
|
||||
IND(2) = IFREE(2)
|
||||
IND(3) = IFREE(3)
|
||||
WRITE (COUT,16000)
|
||||
CALL FREEFM (ITR)
|
||||
NREF = IFREE(1)
|
||||
C-----------------------------------------------------------------------
|
||||
C Pointer mode
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IHO(5) .NE. 0) THEN
|
||||
110 WRITE (COUT,17000)
|
||||
CALL FREEFM (ITR)
|
||||
ITEMP1 = IFREE(1)
|
||||
IF (ITEMP1 .LT. 0) THEN
|
||||
WRITE (COUT,18000)
|
||||
CALL GWRITE (ITP,' ')
|
||||
GO TO 110
|
||||
ENDIF
|
||||
WRITE (COUT,19000)
|
||||
CALL FREEFM (ITR)
|
||||
NMSEG = IFREE(1)
|
||||
C write (6,99991) itemp1,ipoint
|
||||
C99991 format (' itemp1,ipoint',2i5)
|
||||
IF (ITEMP1 .LT. IPOINT) IPOINT = ITEMP1
|
||||
ELSE
|
||||
C-----------------------------------------------------------------------
|
||||
C Normal sequence 1,-1,2,-2....
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,20000)
|
||||
CALL FREEFM (ITR)
|
||||
NSET = IFREE(1)
|
||||
NMSEG = IFREE(2)
|
||||
ENDIF
|
||||
WRITE (COUT,21000)
|
||||
CALL FREEFM (ITR)
|
||||
NBLOCK = IFREE(1)
|
||||
C-----------------------------------------------------------------------
|
||||
C Find the equivalent in Set 1 of the starting reflection
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IHO(5) .NE. 0) THEN
|
||||
READ (IID,REC=4) (JUNK,J = 1,52),(JUNKP(J),J = 1,25)
|
||||
C write (6,99992) iho(5),ipoint,junkp(ipoint)
|
||||
C99992 format (' iho(5),ipoint,junkp ',3i5)
|
||||
NSET = JUNKP(IPOINT)
|
||||
ENDIF
|
||||
MSET = 1
|
||||
IF (NSET .LT. 0) MSET = -1
|
||||
NSET = NSET*MSET
|
||||
DO 120 I = 1,3
|
||||
DO 120 J = 1,3
|
||||
FDH(I,J) = JRT(I,J,NSET)*MSET
|
||||
120 CONTINUE
|
||||
CALL MATRIX (FDH,FDHI,FDHI,FDHI,'INVERT')
|
||||
DO 130 J = 1,3
|
||||
JUNKP(J) = 0
|
||||
DO 130 I = 1,3
|
||||
JUNKP(J) = JUNKP(J)+IND(I)*FDHI(I,J)
|
||||
130 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C Store its indices in IND
|
||||
C-----------------------------------------------------------------------
|
||||
DO 140 I = 1,3
|
||||
IND(I) = JUNKP(I)
|
||||
140 CONTINUE
|
||||
NSET = NSET*MSET
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Are there lattice-mode absences ?
|
||||
C NCOND = -1 if lattice absences are to be applied
|
||||
C = 0 if no lattice absences
|
||||
C > 0 if specified absences (SE) to be applied
|
||||
C-----------------------------------------------------------------------
|
||||
NCOND = 0
|
||||
IF (LATCEN .NE. 1) THEN
|
||||
WRITE (COUT,22000)
|
||||
CALL YESNO ('N',ANS)
|
||||
IF (ANS .EQ. 'N') NCOND = -1
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Are there translation elements and if so, are they to be measured ?
|
||||
C-----------------------------------------------------------------------
|
||||
DO 150 M = 1,NSYM
|
||||
DO 150 I = 1,3
|
||||
IF (JRT(I,4,M) .NE. 0) THEN
|
||||
IHO(7) = 0
|
||||
WRITE (COUT,23000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') IHO(7) = 1
|
||||
GO TO 160
|
||||
ENDIF
|
||||
150 CONTINUE
|
||||
IHO(7) = 0
|
||||
160 WRITE (COUT,24000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Attach the profile file to unit 7 if wanted
|
||||
C-----------------------------------------------------------------------
|
||||
170 CALL RSW (9,J)
|
||||
IF (J .EQ. 1) THEN
|
||||
WRITE (COUT,25000)
|
||||
PRNAME = 'DONT DO IT'//' '
|
||||
CALL ALFNUM (PRNAME)
|
||||
IF (PRNAME .EQ. ' ') PRNAME = 'PROFL7.DAT'
|
||||
IDREC = 32*IBYLEN
|
||||
IPR = IOUNIT(7)
|
||||
STATUS = 'DU'
|
||||
CALL IBMFIL (PRNAME,IPR,IDREC,STATUS,IERR)
|
||||
CALL LENFIL (IPR,NPR)
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Everything is now known, start here in the automatic mode
|
||||
C-----------------------------------------------------------------------
|
||||
READ (IID,REC=4) LATCEN,NUMDH,(IHO(I),IKO(I),ILO(I),
|
||||
$ ((IDH(I,J,M),J = 1,3),M = 1,3),I = 1,4),NSYM,
|
||||
$ LSET,ISET,LAUENO,NAXIS,ICENT
|
||||
READ (IID,REC=5) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 1, 6)
|
||||
READ (IID,REC=6) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 7,12)
|
||||
READ (IID,REC=7) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 13,18)
|
||||
READ (IID,REC=8) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 19,24)
|
||||
NSEG = NUMDH
|
||||
MSET = 1
|
||||
C-----------------------------------------------------------------------
|
||||
C Pointer mode
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IHO(5) .NE. 0) THEN
|
||||
IF (NMSEG .GT. NSEG) THEN
|
||||
NMSEG = 1
|
||||
IPOINT = IPOINT+1
|
||||
ENDIF
|
||||
NSET = ISET(IPOINT)
|
||||
IHO(6) = IPOINT
|
||||
ENDIF
|
||||
IF (NSET .LE. 0) THEN
|
||||
MSET = -1
|
||||
NSET = -NSET
|
||||
ENDIF
|
||||
DO 180 I = 1,3
|
||||
DO 180 J = 1,3
|
||||
IDH(8,I,J) = JRT(I,J,NSET)*MSET
|
||||
180 CONTINUE
|
||||
NSET = NSET*MSET
|
||||
C-----------------------------------------------------------------------
|
||||
C Start here in the Manual Mode. Set record pointer NB to 1 and
|
||||
C re-orientation reflection counter NREFOR to NREF
|
||||
C-----------------------------------------------------------------------
|
||||
NB = 1
|
||||
NREFOR = NREF
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Sequence to set new segment parameters
|
||||
C-----------------------------------------------------------------------
|
||||
200 IF (IAUTO .EQ. 1) THEN
|
||||
C-----------------------------------------------------------------------
|
||||
C Calculate and output the data collection info in the automatic mode
|
||||
C-----------------------------------------------------------------------
|
||||
DO 210 M = 1,3
|
||||
DO 210 J = 1,3
|
||||
DHC(J,M) = 0
|
||||
DO 210 I = 1,3
|
||||
DHC(J,M) = DHC(J,M)+IDH(NMSEG,I,M)*IDH(8,I,J)
|
||||
210 CONTINUE
|
||||
NG = NMSEG
|
||||
INH = IHO(NG)*IDH(8,1,1)+IKO(NG)*IDH(8,2,1)+ILO(NG)*IDH(8,3,1)
|
||||
INK = IHO(NG)*IDH(8,1,2)+IKO(NG)*IDH(8,2,2)+ILO(NG)*IDH(8,3,2)
|
||||
INL = IHO(NG)*IDH(8,1,3)+IKO(NG)*IDH(8,2,3)+ILO(NG)*IDH(8,3,3)
|
||||
WRITE (COUT,26000) NSET,NMSEG,INH,INK,INL,DHC
|
||||
CALL GWRITE(ITP,' ')
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Select the new segment
|
||||
C-----------------------------------------------------------------------
|
||||
ISEG = 0
|
||||
DO 220 I = 1,3
|
||||
DO 220 J = 1,3
|
||||
NDH(I,J) = IDH(NMSEG,I,J)
|
||||
220 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C Find the starting reflection
|
||||
C-----------------------------------------------------------------------
|
||||
IH0 = IHO(NMSEG)
|
||||
IK0 = IKO(NMSEG)
|
||||
IL0 = ILO(NMSEG)
|
||||
IF (IND(1) .EQ. 0 .AND. IND(2) .EQ. 0 .AND. IND(3) .EQ. 0) THEN
|
||||
IND(1) = IH0
|
||||
IND(2) = IK0
|
||||
IND(3) = IL0
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Invert the current segment
|
||||
C-----------------------------------------------------------------------
|
||||
DO 230 I = 1,3
|
||||
DO 230 J = 1,3
|
||||
FDH(I,J) = NDH(I,J)
|
||||
230 CONTINUE
|
||||
CALL MATRIX (FDH,FDHI,FDHI,FDHI,'INVERT')
|
||||
DO 240 I = 1,3
|
||||
INDX(I) = FDHI(I,1)*(IND(1) - IH0) +
|
||||
$ FDHI(I,2)*(IND(2) - IK0) +
|
||||
$ FDHI(I,3)*(IND(3) - IL0)
|
||||
IF (INDX(I) .GE. 0) INDX(I) = INDX(I) + 0.5
|
||||
IF (INDX(I) .LT. 0) INDX(I) = INDX(I) - 0.5
|
||||
240 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C Calculate the starting reflection matrix
|
||||
C-----------------------------------------------------------------------
|
||||
IFSHKL(1,1) = NDH(1,1)*INDX(1) + IH0
|
||||
IFSHKL(2,1) = NDH(2,1)*INDX(1) + IK0
|
||||
IFSHKL(3,1) = NDH(3,1)*INDX(1) + IL0
|
||||
DO 250 I = 1,3
|
||||
IFSHKL(I,2) = NDH(I,2)*INDX(2) + IFSHKL(I,1)
|
||||
IFSHKL(I,3) = NDH(I,3)*INDX(3) + IFSHKL(I,2)
|
||||
250 CONTINUE
|
||||
IH = IFSHKL(1,3)
|
||||
IK = IFSHKL(2,3)
|
||||
IL = IFSHKL(3,3)
|
||||
C-----------------------------------------------------------------------
|
||||
C Set IUPDWN for incrementing the indices
|
||||
C IUPDWN = 1 if INDX(2) is even
|
||||
C IUPDWN =-1 if INDX(2) is odd
|
||||
C-----------------------------------------------------------------------
|
||||
I = INDX(2)
|
||||
IF (I .LT. 0) I = -I
|
||||
I = I-2*(I/2)
|
||||
IUPDWN = 1
|
||||
IF (I .NE. 0) IUPDWN = -1
|
||||
ISTOP = 0
|
||||
IF (IH .EQ. IFSHKL(1,2) .AND. IK .EQ. IFSHKL(2,2) .AND.
|
||||
$ IL .EQ. IFSHKL(3,2) .AND. IUPDWN .EQ. -1) ISTOP = 1
|
||||
C-----------------------------------------------------------------------
|
||||
C Find the indices of the 1st refln in the current set for printing
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IAUTO .EQ. 1) THEN
|
||||
IHO(8) = IH
|
||||
IKO(8) = IK
|
||||
ILO(8) = IL
|
||||
ITEMP1 = IH*IDH(8,1,1) + IK*IDH(8,2,1) + IL*IDH(8,3,1)
|
||||
ITEMP2 = IH*IDH(8,1,2) + IK*IDH(8,2,2) + IL*IDH(8,3,2)
|
||||
ITEMP3 = IH*IDH(8,1,3) + IK*IDH(8,2,3) + IL*IDH(8,3,3)
|
||||
IH = ITEMP1
|
||||
IK = ITEMP2
|
||||
IL = ITEMP3
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C If Psi rotation is asked for, check if it is rrrreally wanted!
|
||||
C-----------------------------------------------------------------------
|
||||
IF (DPSI .NE. 0.0) THEN
|
||||
WRITE (COUT,27000)
|
||||
CALL YESNO ('N',ANS)
|
||||
IF (ANS .EQ. 'N') DPSI = 0.0
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Write all this to IDATA just for safety
|
||||
C-----------------------------------------------------------------------
|
||||
CALL WRBAS
|
||||
C-----------------------------------------------------------------------
|
||||
C Do re-orientation if wanted, but not at the very start
|
||||
C-----------------------------------------------------------------------
|
||||
IF (NINTOR .NE. 0 .AND. NREF .NE. 0) THEN
|
||||
NDIFF = NREF - NREFOR
|
||||
I = NDIFF - NINTOR*(NDIFF/NINTOR)
|
||||
IF (I .EQ. 0) THEN
|
||||
IORNT = 1
|
||||
CALL ALIGN
|
||||
CALL LSORMT
|
||||
ENDIF
|
||||
IORNT = 0
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C Measure standards in STDMES and then data proper
|
||||
C-----------------------------------------------------------------------
|
||||
CALL STDMES
|
||||
IF (KQFLAG .EQ. 1) THEN
|
||||
CALL GOLOOP
|
||||
IF (KI .EQ. 'GO') GO TO 100
|
||||
C-----------------------------------------------------------------------
|
||||
C This is the return to KEYS
|
||||
C-----------------------------------------------------------------------
|
||||
ELSE
|
||||
KI = ' '
|
||||
ENDIF
|
||||
RETURN
|
||||
10000 FORMAT (' Start Data Collection (Y) ? ',$)
|
||||
11000 FORMAT (' Is this a Low-Temperature run (Y) ? ',$)
|
||||
12000 FORMAT (' Use the DH matrices already typed in (Y) ? ',$)
|
||||
13000 FORMAT (' Is this an Automatic Restart (Y) ? ',$)
|
||||
14000 FORMAT (' Start at Reflection 1, Segment 1, Set 1, Record 20',
|
||||
$ ' (Y) ? ',$)
|
||||
15000 FORMAT (' Type the indices of the Starting Reflection ',$)
|
||||
16000 FORMAT (' Type the reflection number ',$)
|
||||
17000 FORMAT (' Type the sequence number of the starting set ',$)
|
||||
18000 FORMAT (' The sequence number cannot be negative.'/
|
||||
$ ' The sequence number is the position of the starting',
|
||||
$ ' set in the'/
|
||||
$ ' previously typed in list of set numbers.')
|
||||
19000 FORMAT (' Type the segment number ',$)
|
||||
20000 FORMAT (' Type the set and segment numbers ',$)
|
||||
21000 FORMAT (' Type the Idata record number ',$)
|
||||
22000 FORMAT (' Measure the lattice-mode absences (N) ? ',$)
|
||||
23000 FORMAT (' Measure the Translation-element absences (Y) ? ',$)
|
||||
24000 FORMAT (' Force the shutter open now if necessary.'/
|
||||
$ ' Is everything OK (Y) ? ',$)
|
||||
25000 FORMAT (' Type the name of the profile file (PROFL7.DAT) ',$)
|
||||
26000 FORMAT (///' Set ',I3,4X,'Segment ',I2,4X,'Matrix',
|
||||
$ 3I3,4X,3(3F3.0,2X))
|
||||
27000 FORMAT (' Psi rotation is turned on.',
|
||||
$ ' Do you really want it (N) ? ',$)
|
||||
END
|
||||
Reference in New Issue
Block a user