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