434 lines
17 KiB
Fortran
434 lines
17 KiB
Fortran
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
|