Initial revision
This commit is contained in:
cvs
433
difrac/goloop.f
Normal file
433
difrac/goloop.f
Normal file
@@ -0,0 +1,433 @@
|
||||
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
|
||||
Reference in New Issue
Block a user