linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ef5a0354f3edfc92ac90fc462f77df3478bad641
sics/difrac/begin.f
cvs ff5e8cf0b2 - Improved centering in DIFRAC 
- Fixed a bug in UserWait
- Improved scan message in scancom
- Added zero point correction in lin2ang
- fixed an issue with uuencoded messages
2000-04-06 12:18:53 +00:00

437 lines
17 KiB
Fortran
Raw Blame History

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 Modified 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 View Git Blame Copy Permalink