PSI sics-cvs-psi_pre-ansto
This commit is contained in:
Douglas Clowes
209
difrac/peaksr.f
Normal file
209
difrac/peaksr.f
Normal file
@@ -0,0 +1,209 @@
|
||||
C----------------------------------------------------------------------
|
||||
C Search for peaks to use with Index (OC)
|
||||
C----------------------------------------------------------------------
|
||||
SUBROUTINE PEAKSR
|
||||
INCLUDE 'COMDIF'
|
||||
DIMENSION PHIP(40),THETAS(NSIZE),OMEGS(NSIZE),CHIS(NSIZE),
|
||||
$ PHIS(NSIZE),ITIMS(NSIZE)
|
||||
REAL SPRESET
|
||||
EQUIVALENCE (ACOUNT( 1),THETAS(1)),
|
||||
$ (ACOUNT( NSIZE+1),OMEGS(1)),
|
||||
$ (ACOUNT(2*NSIZE+1),CHIS(1)),
|
||||
$ (ACOUNT(3*NSIZE+1),PHIS(1)),
|
||||
$ (ACOUNT(4*NSIZE+1),ITIMS(1)),
|
||||
$ (BCOUNT( 1),PHIP(1))
|
||||
NATT = 0
|
||||
NSTORE = 1
|
||||
NTOT = 0
|
||||
SPRESET = 10000
|
||||
C----------------------------------------------------------------------
|
||||
C Write the header and find out if this is new search
|
||||
C----------------------------------------------------------------------
|
||||
WRITE (COUT,9000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
C----------------------------------------------------------------------
|
||||
C If the answer is yes, then do a straight search;
|
||||
C if the answer is no, then there are 4 possibilities :--
|
||||
C 1) Recentre the existing peaks only;
|
||||
C 2) Do nothing and exit;
|
||||
C 3) Continue searching adding more peaks to the list and then
|
||||
C centre the new ones only;
|
||||
C 4) As 3), but recentre the old peaks as well.
|
||||
C----------------------------------------------------------------------
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
CALL ANGRW (0,1,NTOT,160,0)
|
||||
C----------------------------------------------------------------------
|
||||
C Search for more peaks ?
|
||||
C----------------------------------------------------------------------
|
||||
WRITE (COUT,10000) NTOT
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
C----------------------------------------------------------------------
|
||||
C Recentre existing peaks ?
|
||||
C----------------------------------------------------------------------
|
||||
WRITE (COUT,11000)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'Y') CALL TCENTR (NSTORE)
|
||||
KI = ' '
|
||||
RETURN
|
||||
C----------------------------------------------------------------------
|
||||
C Centre all peaks or just the new peaks
|
||||
C----------------------------------------------------------------------
|
||||
ELSE
|
||||
WRITE (COUT,11100)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') NSTORE = NTOT + 1
|
||||
ENDIF
|
||||
ENDIF
|
||||
C-----------------------------------------------------------------------
|
||||
C 2theta min, max and step
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,12000)
|
||||
CALL FREEFM (ITR)
|
||||
TTMIN = RFREE(1)
|
||||
TTMAX = RFREE(2)
|
||||
TTSTEP = RFREE(3)
|
||||
IF (TTMIN .EQ. 0.0) TTMIN = 10.0
|
||||
IF (TTMAX .LT. TTMIN) TTMAX = TTMIN + 20.0
|
||||
IF (TTSTEP .EQ. 0.0) TTSTEP = 4.0
|
||||
C-----------------------------------------------------------------------
|
||||
C Chi min, max and step
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,13000)
|
||||
CALL FREEFM (ITR)
|
||||
CHMIN = RFREE(1)
|
||||
CHMAX = RFREE(2)
|
||||
CHSTEP = RFREE(3)
|
||||
IF (CHMIN .EQ. 0.0 .AND. CHMAX .EQ. 0.0) THEN
|
||||
CHMIN = 220.0
|
||||
CHMAX = 140.0
|
||||
ENDIF
|
||||
IF (CHSTEP .EQ. 0.0) CHSTEP = 10.0
|
||||
C-----------------------------------------------------------------------
|
||||
C How many peaks to search for
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,14000)
|
||||
CALL FREEFM (ITR)
|
||||
MAXPKS = IFREE(1)
|
||||
IF (MAXPKS .EQ. 0) MAXPKS = 20
|
||||
MAXPKS = NTOT + MAXPKS
|
||||
C----------------------------------------------------------------------
|
||||
C Preset for searching ?
|
||||
C---------------------------------------------------------------------
|
||||
WRITE (COUT,13500)
|
||||
CALL FREEFM (ITR)
|
||||
SPRESET = RFREE(1)
|
||||
IF(SPRESET .LE. 0.)SPRESET = 10000
|
||||
C-----------------------------------------------------------------------
|
||||
C Is everything OK ?
|
||||
C-----------------------------------------------------------------------
|
||||
WRITE (COUT,14100)
|
||||
CALL YESNO ('Y',ANS)
|
||||
IF (ANS .EQ. 'N') THEN
|
||||
KI = ' '
|
||||
RETURN
|
||||
ENDIF
|
||||
C----------------------------------------------------------------------
|
||||
C Use PSCAN to find MAXPKS peaks
|
||||
C----------------------------------------------------------------------
|
||||
WTHETA = TTMIN
|
||||
WOMEGA = 0.0
|
||||
WCHI = CHMIN
|
||||
WPHI = 270.
|
||||
NATT = 0
|
||||
WRITE (COUT,14900)
|
||||
CALL GWRITE (ITP,' ')
|
||||
WRITE (LPT,14900)
|
||||
100 CALL ANGSET (WTHETA,WOMEGA,WCHI,WPHI,NATT,ICOL)
|
||||
CALL PSCAN (NMAX,NTOT,SPRESET)
|
||||
C----------------------------------------------------------------------
|
||||
C Save the peaks we found on disk
|
||||
C----------------------------------------------------------------------
|
||||
CALL ANGRW (0,5,JUNK,160,0)
|
||||
NMAX = NMAX + NTOT
|
||||
IF (NMAX .GT. NSIZE) NMAX = NSIZE
|
||||
NMIN = NTOT + 1
|
||||
C----------------------------------------------------------------------
|
||||
C Add peaks found by this PSCAN
|
||||
C----------------------------------------------------------------------
|
||||
J = 0
|
||||
IF (NMIN .LE. NMAX) THEN
|
||||
DO 110 I = NMIN,NMAX
|
||||
J = J + 1
|
||||
THETAS(I) = RTHETA
|
||||
OMEGS(I) = ROMEGA
|
||||
CHIS(I) = RCHI
|
||||
PHIS(I) = PHIP(J)
|
||||
ITIMS(I) = 100
|
||||
110 CONTINUE
|
||||
NTOT = NMAX
|
||||
C----------------------------------------------------------------------
|
||||
C And write them out just in case
|
||||
C----------------------------------------------------------------------
|
||||
CALL ANGRW (1,5,NTOT,160,0)
|
||||
ENDIF
|
||||
C----------------------------------------------------------------------
|
||||
C Check for K or Q flag setting
|
||||
C----------------------------------------------------------------------
|
||||
CALL KORQ (KQFLAG)
|
||||
IF (KQFLAG .NE. 1) THEN
|
||||
WRITE (COUT,15000) NTOT
|
||||
CALL GWRITE (ITP,' ')
|
||||
GO TO 120
|
||||
ENDIF
|
||||
C----------------------------------------------------------------------
|
||||
C If we have too few peaks change angles and look for more
|
||||
C----------------------------------------------------------------------
|
||||
IF (NTOT .LT. MAXPKS) THEN
|
||||
IF (WCHI .GE. CHMAX) THEN
|
||||
WCHI = CHMIN
|
||||
IF (WTHETA .GE. TTMAX) THEN
|
||||
WRITE (COUT,16000) NTOT
|
||||
CALL GWRITE (ITP,' ')
|
||||
WRITE (LPT,16000) NTOT
|
||||
GO TO 120
|
||||
ENDIF
|
||||
WTHETA = WTHETA + TTSTEP
|
||||
ELSE
|
||||
WCHI = WCHI + CHSTEP
|
||||
ENDIF
|
||||
CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI)
|
||||
WPHI = RPHI
|
||||
GO TO 100
|
||||
ENDIF
|
||||
NFOUND = NTOT - NSTORE + 1
|
||||
WRITE (COUT,17000) NFOUND
|
||||
CALL GWRITE (ITP,' ')
|
||||
WRITE (LPT,17000) NFOUND
|
||||
C----------------------------------------------------------------------
|
||||
C We have finished searching for one reason or another
|
||||
C----------------------------------------------------------------------
|
||||
120 IF (NTOT .GT. 0) THEN
|
||||
CALL ANGRW (1,4,NTOT,160,0)
|
||||
C----------------------------------------------------------------------
|
||||
C CAll TCENTR to center the peaks and return
|
||||
C----------------------------------------------------------------------
|
||||
CALL TCENTR (NSTORE)
|
||||
ENDIF
|
||||
KI = ' '
|
||||
RETURN
|
||||
9000 FORMAT (' Routine to Search for Reflection Positions'//
|
||||
$ ' Is this a new search (Y) ',$)
|
||||
10000 FORMAT (' There are ',I2,' old positions in the list'/
|
||||
$ ' Do you want to search for more (Y) ',$)
|
||||
11000 FORMAT (' Do you want to re-centre the old positions (Y) ',$)
|
||||
11100 FORMAT (' New positions will be added to the list as they are',
|
||||
$ ' found.'/
|
||||
$ ' Re-centre the old positions before',
|
||||
$ ' centreing the new ones (Y) ? ',$)
|
||||
12000 FORMAT (' 2-theta search: min, max, step (10,30,4) ',$)
|
||||
13000 FORMAT (' Chi search (allowed range 270 to 90):'/
|
||||
$ ' min, max, step (220,140,10) ',$)
|
||||
13500 FORMAT(' Counter preset during search (10000): ',$)
|
||||
14000 FORMAT (' How many peaks do you want to find (20) ? ',$)
|
||||
14100 FORMAT (' Is everything OK (Y) ? ',$)
|
||||
14900 FORMAT (/18X,'2theta',5X,'Omega',6X,'Chi',7X,'Phi',7X,'INT')
|
||||
15000 FORMAT (' User interrupt after ',I2,' peaks found')
|
||||
16000 FORMAT (' Search for complete range. ',I2,' peaks found.')
|
||||
17000 FORMAT (I4,' new peaks found before the end of the search.')
|
||||
END
|
||||
Reference in New Issue
Block a user