C----------------------------------------------------------------------- C This subroutine controls the sequence of reflections to be measured C from the knowledge of the data collection parameters C----------------------------------------------------------------------- SUBROUTINE GOLOOP INCLUDE 'COMDIF' DIMENSION ENREFB(10) EQUIVALENCE (NREFB(1),ENREFB(1)) CHARACTER KQ*1 C----------------------------------------------------------------------- C Start of the measuring cycle C ISEG = 1 if end of segment from INCHKL C KQFLG2 = 0 if K or 2 if Q stops. 1 if OK. C NBETWN is the count of reflections between stds. C IORNT is the flag to cause re-orientation every NINTOR reflns. C If NINTOR = 0, i.e. no re-orientation IORNT is always 0. C ICADFL is the flag to say the CAD4 is measuring +++ or --- C----------------------------------------------------------------------- KQFLG2 = 1 NBETWN = 0 IORNT = 0 ICADFL = 0 CALL SHUTTR (99) C----------------------------------------------------------------------- C In automatic mode get the first refln. Then calculate angles. C----------------------------------------------------------------------- IF (IAUTO .EQ. 1) THEN IH = IHO(8) IK = IKO(8) IL = ILO(8) ENDIF 100 IPRVAL = 0 IUMPTY = 1 CALL ANGCAL IUMPTY = 0 C----------------------------------------------------------------------- C Check for cryostat chi collision (IVALID = 16), C the 0,0,0 refln (IVALID = 8), C 2theta outside limits (IVALID = 4), C lattice or specific absence (IVALID = 2), C translation absence (IVALID = 1). C Translation absence flag IHO(7) = 0 if to be measured, C lattice or specific absence flag NCOND = 0 if to be measured. C If IROT = 1 hereit means rotation is not allowed in the parallel mode C----------------------------------------------------------------------- IF (IVALID .LT. 3 .AND. IROT .EQ. 0) THEN ILATAB = IVALID/2 ITRNAB = IVALID - 2*ILATAB IF ((ILATAB .EQ. 0 .OR. NCOND .EQ. 0) .AND. $ (ITRNAB .EQ. 0 .OR. IHO(7) .EQ. 0)) GO TO 110 ENDIF CALL INCHKL IF (ISEG .NE. 1) GO TO 100 C----------------------------------------------------------------------- C Save the current indices C----------------------------------------------------------------------- 110 IND(1) = IH IND(2) = IK IND(3) = IL C----------------------------------------------------------------------- C Save the indices when in the automatic mode. C----------------------------------------------------------------------- IF (IAUTO .EQ. 1 .AND. ICADFL .EQ. 0) THEN IHO(8) = IH IKO(8) = IK ILO(8) = IL JH = IH*IDH(8,1,1) + IK*IDH(8,2,1) + IL*IDH(8,3,1) JK = IH*IDH(8,1,2) + IK*IDH(8,2,2) + IL*IDH(8,3,2) JL = IH*IDH(8,1,3) + IK*IDH(8,2,3) + IL*IDH(8,3,3) IH = JH IK = JK IL = JL ENDIF C----------------------------------------------------------------------- C Test for K or Q stops. KQFLAG = 0 for K; 1 for OK; 2 for Q. C----------------------------------------------------------------------- CALL KORQ (KQFLAG) C----------------------------------------------------------------------- C If not K-stop, measure reflection or standards if necessary. C----------------------------------------------------------------------- IF (KQFLAG .GT. 0) THEN IF (KQFLAG .EQ. 2) KQFLG2 = 2 C----------------------------------------------------------------------- C No K was typed. End of segment (ISEG .NE. 0) ? C----------------------------------------------------------------------- IF (ISEG .NE. 0) THEN NMSEG = NMSEG + 1 IH = 0 IK = 0 IL = 0 CALL STDMES IF (KQFLAG .EQ. 1) KQFLAG = KQFLG2 ELSE C----------------------------------------------------------------------- C Not end of segment. Normal reflection, but is it time for stds? C----------------------------------------------------------------------- IF (NBETWN .NE. NINTRR) THEN C----------------------------------------------------------------------- C No. Is it time for re-orientation ? Save KQFLAG C----------------------------------------------------------------------- IF (IORNT .EQ. 1) THEN CALL ALIGN C----------------------------------------------------------------------- C Was K or Q typed during ALIGN ? C----------------------------------------------------------------------- IF (KQFLAG .EQ. 0) THEN IORNT = 0 GO TO 200 ELSE IF (KQFLAG .EQ. 2) KQFLG2 = 2 CALL LSORMT IORNT = 0 CALL STDMES C----------------------------------------------------------------------- C Was K or Q typed during STDMES ? C----------------------------------------------------------------------- IF (KQFLAG .NE. 1) GO TO 200 IF (KQFLG2 .EQ. 2) THEN KQFLAG = KQFLG2 GO TO 200 ENDIF ENDIF ENDIF ELSE C----------------------------------------------------------------------- C Time for stds. Was Q typed ? KQFLAG .EQ. 2 means Q C Save KQFLAG because KORQ will be called again in STDMES. C----------------------------------------------------------------------- IF (KQFLAG .EQ. 2 .OR. KQFLG2 .EQ. 2) THEN KQFLG2 = 2 CALL STDMES IF (KQFLAG .EQ. 1) KQFLAG = KQFLG2 GO TO 200 ELSE CALL STDMES NBETWN = 0 C----------------------------------------------------------------------- C Was K or Q typed during STDMES ? C----------------------------------------------------------------------- IF (KQFLAG .NE. 1) GO TO 200 C----------------------------------------------------------------------- C No. Is it time for re-orientation ? Save KQFLAG C----------------------------------------------------------------------- IF (IORNT .EQ. 1) THEN KQFLG2 = KQFLAG CALL ALIGN C----------------------------------------------------------------------- C Was K or Q typed during ALIGN ? C----------------------------------------------------------------------- IF (KQFLAG .EQ. 0) THEN IORNT = 0 GO TO 200 ELSE IF (KQFLAG .EQ. 2) KQFLG2 = 2 CALL LSORMT IORNT = 0 CALL STDMES C----------------------------------------------------------------------- C Was K or Q typed during STDMES ? C----------------------------------------------------------------------- IF (KQFLAG .NE. 1) GO TO 200 IF (KQFLG2 .EQ. 2) THEN KQFLAG = KQFLG2 GO TO 200 ENDIF ENDIF ENDIF ENDIF ENDIF C----------------------------------------------------------------------- C This is really the start of intensity measurement C First test if rotation is required and allowed (IROT = 0). C----------------------------------------------------------------------- 120 PSI = 0.0 IF (ABS(DPSI) .GT. 0.0001) THEN PSI = PSIMIN TPSI = PSIMIN IF (TPSI .GE. 180.0) TPSI = TPSI - 360.0 ENDIF 130 PSISAV = PSI IF (PSI .NE. 0.0) PSI = 360.0 - PSI IPRVAL = 0 IUMPTY = 1 CALL ANGCAL IUMPTY = 0 PSI = PSISAV IF (IROT .NE. 0) GO TO 160 C----------------------------------------------------------------------- C For Compton or TDS, test if the point is within the Brillouin Zone C----------------------------------------------------------------------- IF (ISCAN .EQ. 1) THEN IBZ = 1 CALL COMPTN (IBZ) IF (IBZ .EQ. 3) GO TO 170 ENDIF C----------------------------------------------------------------------- C Set the display C----------------------------------------------------------------------- NSENT = NREF CALL HKLN (IH,IK,IL,NSENT) C----------------------------------------------------------------------- C Measure the reflection C----------------------------------------------------------------------- IMESR = 0 C----------------------------------------------------------------------- C Compton or TDS measurements C----------------------------------------------------------------------- 140 IF (ISCAN .EQ. 1) THEN IBZ = 2 CALL COMPTN(IBZ) GO TO 150 ENDIF C----------------------------------------------------------------------- C SAMMES -- Measure reflection for Precision mode measurements C MESINT -- For ALL other measuring modes C----------------------------------------------------------------------- IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN CALL SAMMES (ITIME,ICC) ELSE CALL MESINT (IROFL,ICC) ENDIF IF (ICC .GE. 4) THEN NBETWN = NINTRR ICC = ICC - 4 ENDIF IF (ICC .EQ. 2) THEN WRITE (COUT,10000) IH,IK,IL CALL GWRITE (ITP,' ') GO TO 160 ENDIF C----------------------------------------------------------------------- C Do the profile analysis, whether wanted or not. C----------------------------------------------------------------------- CALL PROFIL IF (IWARN .EQ. 2) IMESR = IMESR + 1 IF (IMESR .EQ. 1 .AND. IWARN .EQ. 2) GO TO 140 C----------------------------------------------------------------------- C With the CAD4 only the next sequence can force the -,-,- rfln to be C measured if there is a high-angle scan problem with the +,+,+ C ICADFL = 0 for +,+,+ OR 1 for -,-,- C ICADSW = 1 if this switching is to be done OR 0 if not. C C To test refln sequences with no instrument, disable the next test C----------------------------------------------------------------------- 150 IF (DFMODL .EQ. 'CAD4' .AND. IDEL .LT. 10) THEN IF (ICADFL .EQ. 0) THEN IF (ICADSW .EQ. 1) THEN IH = -IH IK = -IK IL = -IL ICADFL = 1 WRITE (LPT,10100) IH,IK,IL 10100 FORMAT (' Trying ',3I4) WRITE (COUT,10100) IH,IK,IL CALL GWRITE (ITP,' ') GO TO 100 ENDIF ELSE ICADFL = 0 GO TO 160 ENDIF ENDIF C----------------------------------------------------------------------- C Pack h & k and l & Natt (See basinp.f (SD) for ITYPE and ISCAN) C----------------------------------------------------------------------- IHK(NB) = (IH + 500)*1000 + IK + 500 ILA(NB) = (IL + 500)*1000 + NATT C----------------------------------------------------------------------- C Switch h,k,l if -,-,- measured with CAD4 C----------------------------------------------------------------------- IF (ICADFL .EQ. 1) THEN IH = -IH IK = -IK IL = -IL ICADFL = 0 ENDIF BCOUNT(NB) = COUNT IF (IPRFLG .EQ. 0) BCOUNT(NB) = SUM BBGR1(NB) = BGRD1 BBGR2(NB) = BGRD2 BTIME(NB) = PRESET IF (IPRFLG .EQ. 0) THEN IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) THEN BTIME(NB) = FRAC1 + 10*ITIME ELSE BTIME(NB) = FRAC1 ENDIF ENDIF ENREFB(NB) = NREF IF (ISCAN .EQ. 3 .OR. ISCAN .EQ. 4) ENREFB(NB) = PRESET BPSI(NB) = PSI C----------------------------------------------------------------------- C Write a block of intensity data to file, if 10 reflns done. C Close and reopen the file because a system crash could result in C data loss if we don't do this. C----------------------------------------------------------------------- IF (NB .EQ. 10) THEN WRITE (IID,REC=NBLOCK) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME, $ ENREFB,BPSI NBLOCK = NBLOCK + 1 NB = 0 IDREC = 85*IBYLEN STATUS = 'OD' CALL IBMFIL (IDNAME,-IID,IDREC,STATUS,IERR) CALL IBMFIL (IDNAME, IID,IDREC,STATUS,IERR) ENDIF NB = NB + 1 NBETWN = NBETWN + 1 IF (NINTOR .NE. 0 .AND. IORNT .EQ. 0) THEN NDIFF = NREF - NREFOR + 1 I = NDIFF - NINTOR*(NDIFF/NINTOR) IF (I .EQ. 0) IORNT = 1 ENDIF NREF = NREF + 1 C----------------------------------------------------------------------- C Do Psi rotation, if required. C----------------------------------------------------------------------- 160 IF (ABS(DPSI) .GT. 0.0001) THEN TPSI = TPSI + DPSI PSI = PSI + DPSI IF (PSI .GE. 360.0) PSI = PSI - 360.0 IF (TPSI .LE. PSIMAX) GO TO 130 PSI = PSIMIN ENDIF C----------------------------------------------------------------------- C Get the equivalent indices in set 1 C----------------------------------------------------------------------- 170 IF (IAUTO .EQ. 1) THEN IH = IHO(8) IK = IKO(8) IL = ILO(8) ENDIF C----------------------------------------------------------------------- C Increment the indices. ISEG = 1 at end of segment. C----------------------------------------------------------------------- CALL INCHKL IF (ISEG .EQ. 1) GO TO 110 GO TO 100 ENDIF ENDIF C----------------------------------------------------------------------- C Fill up last record if K or Q stops, or end of segment. C----------------------------------------------------------------------- 200 NBL = NB KQFLG2 = 1 IF (NBL .NE. 1) THEN DO 210 NB = NBL,10 IHK(NB) = 599599 ILA(NB) = 599001 BCOUNT(NB) = 0.0 BBGR1(NB) = 0.0 BBGR2(NB) = 0.0 BTIME(NB) = 0.0 ENREFB(NB) = 0 BPSI(NB) = 0.0 210 CONTINUE WRITE (IID,REC=NBLOCK) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB, $ BPSI NBLOCK = NBLOCK + 1 NB = 1 ENDIF C----------------------------------------------------------------------- C Look after K-stop and Q-stop. May coincide with end of segment. C Write restart information on the IDATA file C--------------------------------------------------------------- CALL SHUTTR (-99) IF (KQFLAG .NE. 1) THEN KQ = 'Q' IF (KQFLAG .EQ. 0) KQ = 'K' C------ modified: MK: output to terminal --> SICS WRITE (COUT,11000) KQ,IH,IK,IL,NREF,NSET,NMSEG,NBLOCK CALL GWRITE(IPT,' ') IF (ISEG .NE. 0) THEN IND(1) = 0 IND(2) = 0 IND(3) = 0 WRITE (LPT, 12000) NBLOCK WRITE (COUT,12000) NBLOCK CALL GWRITE (ITP,' ') ENDIF IF (IAUTO .EQ. 1) THEN SAVE = NBLOCK IRES = 1 WRITE (IID,REC=9) IRES,IHO(8),IKO(8),ILO(8),NSET,IHO(6),IHO(5) NBLOCK = SAVE ENDIF KI = 'W2' CALL WRBAS KI = ' ' RETURN ELSE C----------------------------------------------------------------------- C It is the end of a segment and maybe the end of data collection. C----------------------------------------------------------------------- IND(1) = 0 IND(2) = 0 IND(3) = 0 WRITE (LPT, 12000) NBLOCK WRITE (COUT,12000) NBLOCK CALL GWRITE (ITP,' ') IF (NMSEG .LE. NSEG) THEN KI = 'GO' RETURN ENDIF C----------------------------------------------------------------------- C Check if it is the end of data collection in automatic mode ? C----------------------------------------------------------------------- IF (IAUTO .EQ. 1) THEN C----------------------------------------------------------------------- C Get the next set parameters in the automatic mode C----------------------------------------------------------------------- CALL NEXSEG IF (NSET .NE. 0) THEN KI = 'GO' RETURN ELSE IAUTO = 0 ENDIF ENDIF CALL SHUTTR (-99) C------- modified: MK --> IO to SICS instead of LPT WRITE (COUT,13000) CALL GWRITE(ITP,' ') KI = ' ' RETURN ENDIF 10000 FORMAT (3I4,' Scan Collision in GOLOOP') 11000 FORMAT (10X,A1,'-stop. Restart at'/ $ 3I4,', number',I5,' in set',I3,' segment',I2, $ ' at Idata Record',I4) 12000 FORMAT (10X,'End of Segment. Start next data at Record',I4) 13000 FORMAT (10X,'End of Data Collection ---- HURRAY !!') END