linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- Fixed a bug which caused the SICServer to die when a socket was broken.

Browse Source 
- Fixed many things in DIFRAC subsystem:
  * Recoded tcentr.f etc so that the course centering will work and will not
    go into an endless loop.
  * fixed boundary overwrites which occurred when yesno or alfnum where
    uset to get a single character and several were given.
  * Addeded documentation for DIFRAC
- Added tcl-files which  support the WWW status system
This commit is contained in:
cvs
2000-03-31 13:16:50 +00:00
parent d02a81400f
commit 714b8ae84d
35 changed files with 3069 additions and 203 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
difrac/Makefile
View File

@@ -3,7 +3,7 @@
#
# Mark Koennecke, November 1999
#----------------------------------------------------------------------------
CFLAGS = -g -c
CFLAGS = -C -g -c
FL = f77 $(CFLAGS)
ROOT = ..
LIBS = $(ROOT)\libs

11
difrac/align.f
View File

@@ -474,7 +474,7 @@ C-----------------------------------------------------------------------
SUBROUTINE ALEDIT (NTOT)
INCLUDE 'COMDIF'
DIMENSION NDEL(100)
CHARACTER IOPT*1
CHARACTER IOPT*1,LINE*80
C-----------------------------------------------------------------------
C Read in the existing list of h,k,l values and write it to terminal
C-----------------------------------------------------------------------
@@ -504,7 +504,8 @@ C-----------------------------------------------------------------------
C Get the edit option IOPT
C-----------------------------------------------------------------------
WRITE (COUT,13000)
CALL ALFNUM (IOPT)
CALL ALFNUM (LINE)
IOPT = LINE(1:1)
IF (IOPT .EQ. ' ') IOPT = 'U'
C-----------------------------------------------------------------------
C Option E. Exit from AL with 0 reflns
@@ -519,7 +520,8 @@ C-----------------------------------------------------------------------
IF (IOPT .EQ. 'U') THEN
ITRUE = 0
WRITE (COUT,14100)
CALL YESNO ('N',ANS)
CALL YESNO ('N',LINE)
ANS = LINE(1:1)
IF (ANS .EQ. 'Y') ITRUE = 1
RETURN
ENDIF
@@ -530,7 +532,8 @@ C-----------------------------------------------------------------------
IF (IOPT .EQ. 'N') NTOT = 0
ISYMOR = 0
WRITE (COUT,14000)
CALL YESNO ('Y',ANS)
CALL YESNO ('Y',LINE)
ANS = LINE(1:1)
IF (ANS .EQ. 'Y') THEN
ISYMOR = 1
IOUT = -1

5
difrac/blind.f
View File

@@ -576,7 +576,7 @@ C EDLIST Edit the reflection list
C--------------------------------------------------------------------
SUBROUTINE EDLIST
INCLUDE 'COMDIF'
CHARACTER FLAG*1,REFNAM*40
CHARACTER FLAG*1,REFNAM*40,LINE*80
DIMENSION THETAS(NSIZE),
$ OMEGAS(NSIZE),CHIS(NSIZE),PHIS(NSIZE),ICNTS(NSIZE)
EQUIVALENCE (ACOUNT( 1),THETAS(1)),
@@ -596,7 +596,8 @@ C--------------------------------------------------------------------
90 WRITE (COUT,11000)
CALL GWRITE (ITP,' ')
100 WRITE (COUT,12000)
CALL ALFNUM (ANS)
CALL ALFNUM (LINE)
ANS = LINE(1:1)
IF (ANS .NE. 'L' .AND. ANS .NE. 'D' .AND. ANS .NE. 'R' .AND.
$ ANS .NE. 'A' .AND. ANS .NE. 'F' .AND. ANS .NE. 'E')
$ GO TO 90

43
difrac/cfind.f
View File

@@ -1,24 +1,31 @@
C-----------------------------------------------------------------------
C Subroutine to find the coarse centre for Chi
C-----------------------------------------------------------------------
SUBROUTINE CFIND (TIM)
SUBROUTINE CFIND (TIM,MAXCOUNT)
INCLUDE 'COMDIF'
REAL MAXCOUNT, MCOUNT
DIMENSION TCOUNT(NSIZE)
EQUIVALENCE (ACOUNT(9*NSIZE+1),TCOUNT(1))
ICPSMX = 25000
STEPM = 0.02
SENSE = -1.0
CSTEP = 0.25
CSTEP = 1.5
NPTS = 10
CHI = CHI + NPTS*CSTEP/2
NRUN = 0
100 IF (CHI .LT. 0) CHI = CHI + 360
IF (CHI .GE. 360) CHI = CHI - 360
CHI = CHI + NPTS*CSTEP/2
CHISV = CHI
110 CALL ANGSET (THETA,OMEGA,CHISV,PHI,NATT,ICOL)
ICOUNT = 0
MCOUNT = 0
DO 120 I = 1,NPTS
CALL CCTIME (TIM,TCOUNT(I))
CALL KORQ (IFLAG1)
IF (IFLAG1 .NE. 1) THEN
KI = 'O4'
RETURN
ENDIF
IF (TCOUNT(I)/TIM .GT. ICPSMX .AND. NATT .LT. NATTEN) THEN
NATT = NATT + 1
GO TO 110
@@ -32,25 +39,25 @@ C-----------------------------------------------------------------------
IF (CHI .GE. 360) CHI = CHI - 360
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
120 CONTINUE
MAXCOUNT = REAL(MCOUNT)
IF (ICOUNT .EQ. 1) THEN
C
C try the other direction, but only once otherwise we get into an
C endless loop
C
IF(NRUN .GT. 0) THEN
MAXCOUNT = 0.
RETURN
ENDIF
SENSE = -SENSE
CHI = CHI + 9*SENSE*CSTEP
CHI = CHISV + 9*SENSE*CSTEP
NRUN = NRUN + 1
GO TO 100
ELSE IF (ICOUNT .EQ. 10) THEN
CHI = CHI - 3*SENSE*CSTEP
ELSE IF (ICOUNT .EQ. 20) THEN
CHI = CHISV - 3*SENSE*CSTEP
GO TO 100
ENDIF
CHI = CHI + (ICOUNT - 12.25)*SENSE*CSTEP
IF(TCOUNT(ICOUNT) .GT. 0)THEN
TIM = 500.*TIM/TCOUNT(ICOUNT)
ELSE
TIM = 500 * TIM
ENDIF
IF (TIM .LT. 10000.0) THEN
IF (TIM .LT. 1000.) TIM =1000.
CSTEP = CSTEP/4
IF (CSTEP .GT. STEPM) GO TO 100
ENDIF
CHI = CHI + 5*SENSE*CSTEP
C CHI = CHI + (ICOUNT - 12.25)*SENSE*CSTEP
CHI = CHISV + ICOUNT*SENSE*CSTEP
RETURN
END

5
difrac/cinput.f
View File

@@ -5,7 +5,7 @@ C-----------------------------------------------------------------------
INCLUDE 'COMDIF'
DIMENSION A(3),ALP(3),SYS(7),TRANS(3,3,7),AA(3,3),PRIM(3),
$ ANPRIM(3),TRANSF(3,3),H(3,3)
CHARACTER CATMOD*1,SYS*1
CHARACTER CATMOD*1,SYS*1,LINE*80
DATA SYS/'P','A','B','C','I','F','R'/
DATA TRANS/ 1, 0, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 0,.5,.5,
$ 0, 0, 1, .5, 0,.5, 0, 1, 0, 0, 0, 1, .5,.5, 0,
@@ -20,7 +20,8 @@ C-----------------------------------------------------------------------
ALP(I) = RADEG*ATAN2(SANG(I),CANG(I))
100 CONTINUE
110 WRITE (COUT,10000)
CALL ALFNUM (CATMOD)
CALL ALFNUM (LINE)
CATMOD = LINE(1:1)
IF (CATMOD .EQ. ' ') CATMOD = 'P'
READ (CATMOD,11000) ATMOD
WRITE (COUT,12000) A,ALP,CATMOD

22
difrac/difint.f
View File

@@ -12,6 +12,7 @@ C-----------------------------------------------------------------------
SUBROUTINE DIFINT(COMMAND, LEN)
INTEGER COMMAND(256), LEN
INCLUDE 'COMDIF'
CHARACTER STRING*80
KI(1:1) = CHAR(COMMAND(1))
KI(2:2) = CHAR(COMMAND(2))
@@ -83,7 +84,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 2) THEN
@@ -91,7 +93,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 3) THEN
@@ -99,7 +102,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 4) THEN
@@ -107,7 +111,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 5) THEN
@@ -115,7 +120,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 6) THEN
@@ -125,7 +131,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (DFMODL .EQ. 'CAD4' .AND. (I .EQ. 0 .OR. I .EQ. 7)) THEN
@@ -133,7 +140,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
ENDIF

5
difrac/mesint.f
View File

@@ -26,7 +26,10 @@ C-----------------------------------------------------------------------
IWARN = 0
ISIGN = 1
IF (THETA .LT. 0.0 .OR. THETA .GT. 180.0) ISIGN = -1
D12 = BS*ABS(TAN(0.5*THETA/DEG))
C---- Modified MK: there is no alpha1 alpha2 separation with neutrons
C D12 = BS*ABS(TAN(0.5*THETA/DEG))
D12 = 0.
C---- end of modification
TTIME = 0.20*PRESET
110 CALL SHUTTR (1)
IF (NATTEN .GT. 0) THEN

17
difrac/pfind.f
View File

@@ -1,8 +1,9 @@
C-----------------------------------------------------------------------
C Get the coarse value of Phi for PCENTR
C-----------------------------------------------------------------------
SUBROUTINE PFIND (TIM)
SUBROUTINE PFIND (TIM,MAXCOUNT)
INCLUDE 'COMDIF'
REAL MAXCOUNT, MCOUNT
DIMENSION PCOUNT(NSIZE)
EQUIVALENCE (ACOUNT(9*NSIZE + 1), PCOUNT(1))
C-----------------------------------------------------------------------
@@ -30,6 +31,11 @@ C-----------------------------------------------------------------------
MCOUNT = 0
DO 110 I = 1,NPTS
CALL CCTIME (TIM,PCOUNT(I))
CALL KORQ (IFLAG1)
IF (IFLAG1 .NE. 1) THEN
KI = 'O4'
RETURN
ENDIF
IF (PCOUNT(I) .GT. MCOUNT) THEN
MCOUNT = PCOUNT(I)
ICOUNT = I
@@ -39,16 +45,11 @@ C-----------------------------------------------------------------------
IF (PHI .GE. 360.0) PHI = PHI - 360.0
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
110 CONTINUE
MAXCOUNT = REAL(MCOUNT)
IF (ICOUNT .EQ. 1 .OR. ICOUNT .EQ. NPTS) THEN
TIM = 5.0
TIM = -5.0
RETURN
ENDIF
PHI = PHIOFF + (ICOUNT - 1)*PSTEP
TIM = 500.0*TIM/PCOUNT(ICOUNT)
IF (TIM .LT. 10000.0) THEN
IF (TIM .LT. 1000.) TIM = 1000.
PSTEP = PSTEP/4
IF (PSTEP .GT. STEPM) GO TO 100
ENDIF
RETURN
END

6
difrac/prnbas.f
View File

@@ -6,7 +6,8 @@ C-----------------------------------------------------------------------
DIMENSION RW(3,3),ANG(3)
CHARACTER CPROF*4,STRING*10
WRITE (COUT,10000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
KZ = -1
IF (ANS .EQ. ' ' .OR. ANS .EQ. '0') KZ = 0
IF (ANS .EQ. '1') KZ = 1
@@ -115,7 +116,8 @@ C-----------------------------------------------------------------------
C Pause to allow users to read the screen
C-----------------------------------------------------------------------
WRITE (COUT,20000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
C-----------------------------------------------------------------------
C Theta min/max and h,k,l max data
C-----------------------------------------------------------------------

14
difrac/profil.f
View File

@@ -183,8 +183,10 @@ C The profile is suitable for analysis to find the limits
C J1 is the beginning of the low angle search
C J2 is the beginning of the high angle search
C-----------------------------------------------------------------------
J1 = MAXI - STEPOF*CON*AS - A2*ID12
J2 = MAXI + STEPOF*CON*CS + A1*ID12
C J1 = MAXI - STEPOF*CON*AS - A2*ID12
C J2 = MAXI + STEPOF*CON*CS + A1*ID12
J1 = MAXI - ((STEPOF*AS)/STEP) - A2*ID12
J2 = MAXI + ((STEPOF*CS)/STEP) + A1*ID12
IF (J1 .LE. NWIND .OR. J2 .GE. NP-NWIND) THEN
ILOW = 1
IHIGH = NP
@@ -255,6 +257,9 @@ C-----------------------------------------------------------------------
DO 220 I = 1,ILOW-1
B1 = B1 + ACOUNT(I)
220 CONTINUE
C---mk
B1 = B1/ILOW
C---
ENDIF
FRAC1 = (FRAC*NP + ILOW - 1)/NPK
PEAK = 0.0
@@ -266,9 +271,12 @@ C-----------------------------------------------------------------------
DO 230 I = IHIGH+1,NP
B2 = B2 + ACOUNT(I)
230 CONTINUE
IDIV = NP - IHIGH
IF(IDIV .LE. 0)IDIV =1
B2 = B2/IDIV
ENDIF
FRAC2 = (FRAC*NP + NP - IHIGH)/NPK
BTOT = 0.5*(B1/FRAC1 + B2/FRAC2)
BTOT = 0.5*(B1/FRAC1 + B2/FRAC2)*NP
TOP1 = PEAK - BTOT
BOT1 = SQRT(PEAK + 0.25*(B1/(FRAC1*FRAC1) + B2/(FRAC2*FRAC2)))
FRAC1 = 0.5*(FRAC1 + FRAC2)

7
difrac/rcpcor.f
View File

@@ -8,6 +8,7 @@ C-----------------------------------------------------------------------
SUBROUTINE RCPCOR
INCLUDE 'COMDIF'
DIMENSION RM1(3,3),XA(3),HA(3)
CHARACTER STRING*80
IF (KI .EQ. 'AH') THEN
WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
@@ -58,7 +59,8 @@ C Index faces for ABSORP when they are set so that the face normal is
C in the equator plane and normal to the microscope viewing direction
C at the Kappa angles -45, 78, kappa (-60 start), phi (0 start)
C-----------------------------------------------------------------------
SUBROUTINE FACEIN
SUBROUTINE FACEIN
CHARACTER STRING*80
INCLUDE 'COMDIF'
DATA ISENSE/-1/
NATT = 0
@@ -79,7 +81,8 @@ C-----------------------------------------------------------------------
C Get the adjusted angles and transform them
C-----------------------------------------------------------------------
100 WRITE (COUT,11000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
C write (cout,99990)
C99990 format (' Type omk, kap, phk for face ',$)
C call freefm (itr)

25
difrac/setop.f
View File

@@ -11,8 +11,10 @@ C
C-----------------------------------------------------------------------
SUBROUTINE SETOP
INCLUDE 'COMDIF'
CHARACTER STRING*80
100 WRITE (COUT,10000)
CALL ALFNUM (KI)
CALL ALFNUM (STRING)
KI = STRING(1:2)
IF (KI .EQ. 'Q') THEN
CALL WNEND
STOP
@@ -74,7 +76,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 2) THEN
@@ -82,7 +85,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 3) THEN
@@ -90,7 +94,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 4) THEN
@@ -98,7 +103,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 5) THEN
@@ -106,7 +112,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 6) THEN
@@ -116,7 +123,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (DFMODL .EQ. 'CAD4' .AND. (I .EQ. 0 .OR. I .EQ. 7)) THEN
@@ -124,7 +132,8 @@ C-----------------------------------------------------------------------
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (ANS)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
ENDIF

123
difrac/tcentr.f
View File

@@ -16,6 +16,7 @@ C-----------------------------------------------------------------------
$ (ACOUNT(6*NSIZE+1),OMEGP(1)),
$ (ACOUNT(7*NSIZE+1),CHIP(1)),
$ (ACOUNT(8*NSIZE+1),PHIP(1))
REAL CURCTS,MAXCTS
WIDTH = 1.25
C-----------------------------------------------------------------------
C Read the peaks from disk
@@ -60,85 +61,57 @@ C Set the angles at the approximate position of the peak and adjust
C Phi, Chi and 2Theta to get maximum intensity in the detector.
C Sietronics interface works via MAXPOINT; CAD4 via CADCEN
C-----------------------------------------------------------------------
C CAD-4 and Sietronics deleted for clarity: Mark Koennecke
CALL SHUTTR (99)
ITIMS(J) = 0
IF (DFMODL .EQ. 'CAD4') THEN
KI = 'SP'
CALL CADCEN (0)
IF (KI .EQ. 'FF') THEN
WHICH = 'Phi'
WRITE (COUT,13000) WHICH
CALL GWRITE (ITP,' ')
WRITE (LPT,13000) WHICH
GO TO 200
ENDIF
110 CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
KI = 'ST'
IGOOD = 0
CALL CADCEN (IGOOD)
C write (lpt,99993) ki,igood
C99993 format (' KI,igood ',a,i4)
IF (KI .EQ. 'FF' .OR. KI .EQ. 'TO' .OR. KI .EQ. 'BO') THEN
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR)
KI = 'SC'
RTIM = PRESET
CALL CFIND (RTIM)
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
IF (RTIM .GT. 3.0) THEN
WHICH = 'Chi'
WRITE (COUT,13000) WHICH
CALL GWRITE (ITP,' ')
WRITE (LPT,13000) WHICH
GO TO 200
ENDIF
KI = 'SO'
IGOOD = 0
CALL CADCEN (IGOOD)
IF (KI .EQ. 'FF') THEN
WHICH = 'Omega'
WRITE (COUT,13000) WHICH
CALL GWRITE (ITP,' ')
WRITE (LPT,13000) WHICH
GO TO 200
ENDIF
GO TO 110
ENDIF
IF (IGOOD .NE. 0) GO TO 110
C-----------------------------------------------------------------------
C Sietronics 145D centring
C-----------------------------------------------------------------------
ELSE IF (DFMODL .EQ. '145D') THEN
PWIDTH = 2*WIDTH
CALL MAXPOINT (3,PWIDTH,0.1,RMAXPT)
PHI = RMAXPT
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
CWIDTH = 4*WIDTH
CALL MAXPOINT (2,CWIDTH,0.1,RMAXPT)
CHI = RMAXPT
OMEGA = OMEGA - 0.5*TWIDTH
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
TWIDTH = WIDTH
CALL MAXPOINT (4,TWIDTH,0.1,RMAXPT)
THETA = RMAXPT
C-----------------------------------------------------------------------
C All other machines for the moment
C Modified: Mark Koennecke for TRICS
C Do initial search. But use the results of the searches
C only if they improved the countrate.
C-----------------------------------------------------------------------
ELSE
RTIM = 1000.
CALL PFIND (RTIM)
THETA = RTHETA
OMEGA = ROMEGA
IF (RTIM .GT. 10000.0) GO TO 200
C IF (RTIM .GT. 1.0) RTIM = 1.0
CHI = RCHI + 1.25
CALL CFIND (RTIM)
THETA = RTHETA + 1.25
OMEGA = OMEGA - 0.625
IF (RTIM .GT. 10000.0) GO TO 200
C IF (RTIM .GT. 1.0) RTIM = 1.0
CALL TFIND (RTIM)
IF (RTIM .GT. 10000.0) GO TO 200
ENDIF
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
CALL CCTIME (PRESET,CURCTS)
C----- first two theta
RTIM = PRESET
CALL TFIND(RTIM,MAXCTS)
IF(MAXCTS .LT. CURCTS) THEN
THETA = RTHETA
OMEGA = ROMEGA
ELSE
CURCTS = MAXCTS
ENDIF
CALL KORQ (IFLAG1)
IF (IFLAG1 .NE. 1) THEN
KI = 'O4'
RETURN
ENDIF
C----- now phi
RTIM = PRESET
CALL PFIND(RTIM,MAXCTS)
IF(MAXCTS .LT. CURCTS) THEN
PHI = RPHI
ELSE
CURCTS = MAXCTS
ENDIF
CALL KORQ (IFLAG1)
IF (IFLAG1 .NE. 1) THEN
KI = 'O4'
RETURN
ENDIF
C------ finally phi
RTIM = PRESET
CALL CFIND(RTIM,MAXCTS)
IF(MAXCTS .LT. CURCTS) THEN
CHI = RCHI
ELSE
CURCTS = MAXCTS
ENDIF
CALL KORQ (IFLAG1)
IF (IFLAG1 .NE. 1) THEN
KI = 'O4'
RETURN
ENDIF
C------- end of pre centering
WRITE (COUT,11000) THETA,OMEGA,CHI,PHI
CALL GWRITE (ITP,' ')
WRITE (LPT,11000) THETA,OMEGA,CHI,PHI

27
difrac/tfind.f
View File

@@ -1,8 +1,9 @@
C-----------------------------------------------------------------------
C Find the Coarse setting for 2-Theta
C-----------------------------------------------------------------------
SUBROUTINE TFIND (TIM)
SUBROUTINE TFIND (TIM, MAXCOUNT)
INCLUDE 'COMDIF'
REAL MAXCOUNT, MCOUNT
DIMENSION TCOUNT(NSIZE)
EQUIVALENCE (ACOUNT(9*NSIZE+1),TCOUNT(1))
STEPM = 0.01
@@ -10,6 +11,7 @@ C-----------------------------------------------------------------------
TSTEP = 0.25
NATT = 0
NPTS = 10
NRUN = 0
100 THEOFF = THETA
OMEOFF = OMEGA
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
@@ -17,6 +19,11 @@ C-----------------------------------------------------------------------
MCOUNT = 0
DO 110 I = 1,NPTS
CALL CCTIME (TIM,TCOUNT(I))
CALL KORQ (IFLAG1)
IF (IFLAG1 .NE. 1) THEN
KI = 'O4'
RETURN
ENDIF
IF (TCOUNT(I) .GT. MCOUNT) THEN
MCOUNT = TCOUNT(I)
ICOUNT = I
@@ -25,10 +32,20 @@ C-----------------------------------------------------------------------
OMEGA = OMEGA - SENSE*TSTEP*0.5
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
110 CONTINUE
MAXCOUNT = MCOUNT
IF (ICOUNT .EQ. 1) THEN
C
C try, the other direction. But only once as checked by NRUN
C otherwise we end in an endless loop.
C
IF (NRUN .GT. 0) THEN
MAXCOUNT = 0.
RETURN
ENDIF
SENSE = -SENSE
THETA = THEOFF + 9.0*SENSE*TSTEP
OMEGA = OMEOFF - 9.0*SENSE*TSTEP/2
NRUN = NRUN + 1
GO TO 100
ENDIF
IF (ICOUNT .EQ. 10) THEN
@@ -36,14 +53,6 @@ C-----------------------------------------------------------------------
OMEGA = OMEOFF + 3.0*SENSE*TSTEP/2
GO TO 100
ENDIF
THETA = THEOFF + (ICOUNT - 2.25)*SENSE*TSTEP
OMEGA = OMEOFF - 0.5*(ICOUNT - 2.25)*SENSE*TSTEP
TIM = 500.0*TIM/TCOUNT(ICOUNT)
IF (TIM .LT. 10000.0) THEN
IF (TIM .LT. 1000.) TIM = 1000.
TSTEP = TSTEP/4.0
IF (TSTEP .GT. STEPM) GO TO 100
ENDIF
THETA = THEOFF + ICOUNT*SENSE*TSTEP
OMEGA = OMEOFF - ICOUNT*SENSE*TSTEP/2
RETURN

5
difrac/yesno.f
View File

@@ -18,14 +18,15 @@ C-----------------------------------------------------------------------
COMMON /IOUASS/ IOUNIT(12)
CHARACTER*132 COUT(20)
COMMON /IOUASC/ COUT
CHARACTER DEFOLT*1,ANS*1
CHARACTER DEFOLT*1,ANS*1,LINE*80
ITR = IOUNIT(5)
ITP = IOUNIT(6)
C-----------------------------------------------------------------------
C This code gets round IBM VM/CMS limitations
C-----------------------------------------------------------------------
100 CALL GWRITE (ITP,'$')
CALL GETLIN (ANS)
CALL GETLIN (LINE)
ANS=LINE(1:1)
IF (ANS .EQ. '?') STOP
IF (ANS .EQ. 'y') ANS = 'Y'
IF (ANS .EQ. 'n') ANS = 'N'