210 lines
8.1 KiB
Fortran
210 lines
8.1 KiB
Fortran
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
|