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