C----------------------------------------------------------------------- C C Reflection Alignment routine C C The routine has 5 entry points :-- C C CR aligns the reflection which is already in the detector, or C a single reflection which is set before alignment. C AL firstly reads in h,k,l values and generates symmetry equivalent C reflections if wanted; C secondly aligns both + and - h,k,l values for use by MM. C AR resumes alignment after AL has been interrupted. C RO reads in reflections as for the first part of AL. C IORNT .EQ. 1 does re-orientation during data collection via the C second part of AL. C----------------------------------------------------------------------- SUBROUTINE ALIGN INCLUDE 'COMDIF' DIMENSION IBH(10),IBK(10),IBL(10),BTHETA(10),BOMEGA(10),BCHI(10), $ BPHI(10),T4(4),O4(4),C4(4),P4(4) CHARACTER CPM*1 100 IF (KI .EQ. 'CR') WRITE (COUT,10000) IF (KI .EQ. 'AL') WRITE (COUT,11000) IF (KI .EQ. 'AR') WRITE (COUT,12000) CALL GWRITE (ITP,' ') DT = IDTDEF DO = IDODEF DC = IDCDEF AFRAC = 0.5 PRESET = 1000. C----------------------------------------------------------------------- C Read the angle steps DT, DO and DC, counting TIME and AFRAC C----------------------------------------------------------------------- IF (KI .EQ. 'AL' .OR. KI .EQ. 'CR' .OR. KI. EQ. 'RO') THEN IF (DFMODL .EQ. 'CAD4') THEN WRITE (COUT,12900) CALL FREEFM (ITR) DT = RFREE(1) ISLIT = 10.0*DT + 0.5 IF (ISLIT .EQ. 0) ISLIT = 40 IF (ISLIT .LT. 10) ISLIT = 10 IF (ISLIT .GT. 60) ISLIT = 60 ELSE ISLIT = 0 WRITE (COUT,13000) IDTDEF,IDODEF,IDCDEF,IFRDEF CALL FREEFM (ITR) DT = RFREE(1) DO = RFREE(2) DC = RFREE(3) IF (DT .EQ. 0) DT = IDTDEF IF (DO .EQ. 0) DO = IDODEF IF (DC .EQ. 0) DC = IDCDEF DT = DT/IFRDEF DO = DO/IFRDEF DC = DC/IFRDEF WRITE (COUT,14000) CALL FREEFM (ITR) PRESET = RFREE(1) IF (PRESET .EQ. 0.0) PRESET = 1000. WRITE (COUT,15000) CALL FREEFM (ITR) AFRAC = RFREE(1) IF (AFRAC .EQ. 0.) AFRAC = 0.5 WRITE (COUT,16000) CALL YESNO ('Y',ANS) IF (ANS .EQ. 'N') GO TO 100 ENDIF ENDIF C----------------------------------------------------------------------- C For CR, set the reflection if necessary C----------------------------------------------------------------------- IF (KI .EQ. 'CR') THEN ITRY = 1 IHSET = 0 WRITE (COUT,17000) CALL YESNO ('Y',ANS) IF (ANS .EQ. 'N') THEN 110 WRITE (COUT,18000) CALL FREEFM (ITR) IH = IFREE(1) IK = IFREE(2) IL = IFREE(3) IF (IH .EQ. 0 .AND. IK .EQ. 0 .AND. IL .EQ. 0) THEN KI = ' ' RETURN ENDIF IHSET = 1 MREF = MREF + 1 CALL HKLN (IH,IK,IL,MREF) IPRVAL = 1 CALL ANGCAL IF (IVALID .NE. 0) GO TO 110 CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) IF (ICC .NE. 0) THEN WRITE (COUT,19000) CALL GWRITE (ITP,' ') GO TO 110 ENDIF ENDIF IF (IHSET .EQ. 0) THEN WRITE (COUT,20000) CALL FREEFM (ITR) IHNEW = IFREE(1) IKNEW = IFREE(2) ILNEW = IFREE(3) IF (IHNEW .NE. 0 .OR. IKNEW .NE. 0 .OR. ILNEW .NE. 0) THEN IH = IHNEW IK = IKNEW IL = ILNEW ENDIF ENDIF CALL ANGET (RTHETA,ROMEGA,RCHI,RPHI) WRITE (COUT,21000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI CALL GWRITE (ITP,' ') IF (LPT .NE. ITP) WRITE (LPT,21000) $ IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI 115 CALL HKLN (IH,IK,IL,MREF) CALL WXW2T (DT,DO,DC,ISLIT) IF (KI .EQ. 'FF') THEN IF (ITRY .EQ. 1) THEN WRITE (COUT,22000) IH,IK,IL CALL GWRITE (ITP,' ') ITRY = 2 IPRVAL = 1 CALL ANGCAL CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) GO TO 115 ELSE WRITE (COUT,22100) IH,IK,IL CALL GWRITE (ITP,' ') KI = ' ' RETURN ENDIF ENDIF CALL SHUTTR (1) CALL CCTIME (PRESET,CT1) CALL SHUTTR (-1) WRITE (COUT,23000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1 CALL GWRITE (ITP,' ') IF (LPT .NE. ITP) WRITE (LPT,23000) $ IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1 WRITE (COUT,24000) CALL YESNO ('Y',ANS) IF (ANS .EQ. 'Y') THEN WRITE (COUT,25000) CALL FREEFM (ITR) I = IFREE(1) IHK(I) = IH NREFB(I) = IK ILA(I) = IL BCOUNT(I) = RTHETA BBGR1(I) = ROMEGA BBGR2(I) = RCHI BTIME(I) = RPHI ENDIF KI = ' ' RETURN ENDIF C----------------------------------------------------------------------- C AR -- Resume AL-type alignment from where it was interrupted. C----------------------------------------------------------------------- IF (KI .EQ. 'AR') THEN READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC READ (IID,REC=17) (IOK(J),J = 1,80),NTOT READ (IID,REC=18) (IOL(J),J = 1,80) READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) IF (DFMODL .EQ. 'CAD4') THEN ISLIT = 10.0*DT + 0.5 IF (ISLIT .EQ. 0) ISLIT = 40 ENDIF NBLOKO = 250 NDONE = 0 120 READ (ISD,REC=NBLOKO) $ (JUNK,I = 1,80),NINBLK,NLIST,IPLUS,NTOT,NBLOKO IF (NINBLK .NE. 0) THEN NBLOKO = NBLOKO + 1 NDONE = NDONE + NINBLK GO TO 120 ENDIF NBLOKO = NBLOKO - 1 READ (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI, $ BPSI,NINBLK,NLIST,IPLUS,NTOT,NBLOKO IF (IPLUS .EQ. -1) NLIST = NLIST + 1 IPLUS = -IPLUS IH = IPLUS*IOH(NLIST) IK = IPLUS*IOK(NLIST) IL = IPLUS*IOL(NLIST) WRITE (COUT,26000) NDONE,IH,IK,IL CALL GWRITE (ITP,' ') NSTART = NLIST ENDIF C----------------------------------------------------------------------- C AL -- First Part -- Read in a list of h,k,l values & generate C symmetry equivs if wanted; C Second Part -- Align the + and - Friedel reflections C RO -- First part of AL C Second part of AL, when IORNT = 1 C----------------------------------------------------------------------- IF (KI .EQ. 'AL' .OR. KI .EQ. 'RO') THEN CALL ALEDIT (NTOT) IF (NTOT .EQ. 0) THEN KI = ' ' RETURN ENDIF C----------------------------------------------------------------------- C Write the h,k,l values to file for use with AR and RO C----------------------------------------------------------------------- WRITE (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC WRITE (IID,REC=17) (IOK(J),J = 1,80),NTOT WRITE (IID,REC=18) (IOL(J),J = 1,80) WRITE (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) ENDIF IF (KI .EQ. 'RO') RETURN C----------------------------------------------------------------------- C Read in data if IORNT = 1 (RO) C----------------------------------------------------------------------- IF (IORNT .EQ. 1) THEN READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC READ (IID,REC=17) (IOK(J),J = 1,80),NTOT READ (IID,REC=18) (IOL(J),J = 1,80) READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) WRITE (LPT,27000) NREF ENDIF C----------------------------------------------------------------------- C Get ready for the second part of AL or OR C----------------------------------------------------------------------- IF (KI .EQ. 'AL' .OR. IORNT .EQ. 1) THEN NBLOKO = 250 NINBLK = 0 MREF = 0 NSTART = 1 IPLUS = 1 IHSV = IH IKSV = IK ILSV = IL ENDIF C----------------------------------------------------------------------- C Do alignment on these reflections (+ and -) C----------------------------------------------------------------------- DO 150 NLIST = NSTART,NTOT 130 IH = IPLUS*IOH(NLIST) IK = IPLUS*IOK(NLIST) IL = IPLUS*IOL(NLIST) ISTAN = 0 DPSI = 0.0 ITRY = 1 MREF = MREF + 1 NTRUE = 0 IPRVAL = 0 CALL ANGCAL IF (IVALID .NE. 0 .AND. IVALID .NE. 4) GO TO 140 IF (DFMODL .EQ. 'CAD4' .AND. THETA .GT. 110.0 .AND. $ (CHI .GT. 270.0 .AND. CHI .LT. 300)) THEN WRITE (LPT,28000) IH,IK,IL GO TO 140 ENDIF IF (ITRUE .EQ. 1) THEN T4(1) = THETA T4(2) = 360.0 - THETA T4(3) = THETA T4(4) = 360.0 - THETA O4(1) = OMEGA O4(2) = OMEGA O4(3) = OMEGA O4(4) = OMEGA C4(1) = CHI C4(2) = CHI C4(3) = 360.0 - CHI C4(4) = 360.0 - CHI P34 = 180.0 + PHI IF (P34 .GE. 360.0) P34 = P34 - 360.0 P4(1) = PHI P4(2) = PHI P4(3) = P34 P4(4) = P34 ENDIF 135 CALL HKLN (IH,IK,IL,MREF) IF (ITRUE .EQ. 1 .AND. ITRY .EQ. 1) THEN NTRUE = NTRUE + 1 THETA = T4(NTRUE) OMEGA = O4(NTRUE) CHI = C4(NTRUE) PHI = P4(NTRUE) ENDIF CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC) IF (ICC .NE. 0) GO TO 140 CPM = '+' IF (IPLUS .EQ. -1) CPM = '-' WRITE (LPT,29000) NLIST,CPM,IH,IK,IL,THETA,OMEGA,CHI,PHI CALL WXW2T (DT,DO,DC,ISLIT) IF (KI .EQ. 'FF') THEN IF (ITRY .EQ. 1) THEN WRITE (LPT,22000) IH,IK,IL WRITE (COUT,22000) IH,IK,IL CALL GWRITE (ITP,' ') ITRY = 2 GO TO 135 ELSE WRITE (LPT,22100) IH,IK,IL WRITE (COUT,22100) IH,IK,IL CALL GWRITE (ITP,' ') GO TO 140 ENDIF ENDIF CALL SHUTTR (1) CALL CCTIME (PRESET,CT1) CALL SHUTTR (-1) WRITE (LPT,30000) IH,IK,IL,RTHETA,ROMEGA,RCHI,RPHI,CT1 IF (ITRUE .EQ. 1) THEN T4(NTRUE) = RTHETA O4(NTRUE) = ROMEGA C4(NTRUE) = RCHI P4(NTRUE) = RPHI IF (NTRUE .LT. 4) THEN ITRY = 1 GO TO 135 ELSE DO 136 I4 = 1,4 IF (T4(I4) .GT. 180.0) T4(I4) = T4(I4) - 360.0 IF (O4(I4) .GT. 180.0) O4(I4) = O4(I4) - 360.0 IF (C4(I4) .GT. 180.0) C4(I4) = C4(I4) - 360.0 136 CONTINUE RTHETA = (T4(1) - T4(2) + T4(3) - T4(4))/4.0 ROMEGA = (O4(1) + O4(2) + O4(3) + O4(4))/4.0 IF (ROMEGA .LT. 0.0) ROMEGA = ROMEGA + 360.0 RCHI = (C4(1) + C4(2) - C4(3) - C4(4))/4.0 IF (RCHI .LT. 0.0) RCHI = RCHI + 360.0 RPHI = P4(1) WRITE ( LPT,22200) RTHETA,ROMEGA,RCHI,RPHI WRITE (COUT,22200) RTHETA,ROMEGA,RCHI,RPHI CALL GWRITE (ITP,' ') ENDIF ENDIF NINBLK = NINBLK + 1 IBH(NINBLK) = IH IBK(NINBLK) = IK IBL(NINBLK) = IL BTHETA(NINBLK) = RTHETA BOMEGA(NINBLK) = ROMEGA BCHI(NINBLK) = RCHI BPHI(NINBLK) = RPHI BPSI(NINBLK) = 0.0 C----------------------------------------------------------------------- C Write the block of alignment data so far C----------------------------------------------------------------------- WRITE (ISD,REC=NBLOKO) IBH,IBK,IBL,BTHETA,BOMEGA,BCHI,BPHI, $ BPSI,NINBLK,NLIST,IPLUS,NTOT,NBLOKO IF (NINBLK .EQ. 10) THEN NBLOKO = NBLOKO + 1 NINBLK = 0 ENDIF 140 CALL KORQ (KQFLAG) IF (KQFLAG .NE. 1) GO TO 160 IF (IPLUS .EQ. 1) THEN IPLUS = -1 GO TO 130 ELSE IPLUS = 1 ENDIF 150 CONTINUE C----------------------------------------------------------------------- C Write guard block on the end C----------------------------------------------------------------------- 160 IF (NINBLK .GT. 0) NBLOKO = NBLOKO + 1 NINBLK = 0 WRITE (ISD,REC=NBLOKO) (IOH(I),I = 1,80),NINBLK,NINBLK,NINBLK, $ NTOT,NBLOKO IF (IORNT .EQ. 1) THEN IH = IHSV IK = IKSV IL = ILSV ENDIF CALL ZERODF KI = ' ' RETURN 10000 FORMAT (10X,' Centre the reflection already in the detector ') 11000 FORMAT (/10X,' Alignment of Symmetry and Friedel Equivalent', $ ' Reflections'/,'%') 12000 FORMAT (10X,' Resume alignment from the AL command') 12900 FORMAT (' Type the horizontal slit width in mms (4.0) ',$) 13000 FORMAT (' Type the size of steps in 2T,Om,Chi,', $ ' (',I2,',',I2,',',I2,') 1/',I3,'deg ',$) 14000 FORMAT (' Type the count preset for each step (1000.0) ',$) 15000 FORMAT (' Fraction of max. count for half-height cutoff (0.5) ',$) 16000 FORMAT (' All OK (Y) ? ',$) 17000 FORMAT (' Is the reflection already set (Y) ? ',$) 18000 FORMAT (' Type h,k,l for the reflection (Exit) ',$) 19000 FORMAT (3I3,' setting collision. Try again.') 20000 FORMAT (' Type h,k,l for use in M2/M3 ',$) 21000 FORMAT (' Starting Values ',3I4,4F10.3) 22000 FORMAT (3I4,' ailignment failed on first attempt'/) 22100 FORMAT (3I4,' ailignment failed on both attempts'/) 22200 FORMAT (' Mean Values ',12X,4F10.3/) 23000 FORMAT (' Final Values ',3I4,4F10.3,F7.0/) 24000 FORMAT (' Do you wish to save the angles for M2 or M3 (Y) ? ',$) 25000 FORMAT (' What is the sequence number of this reflection ? ',$) 26000 FORMAT (I4,' reflections have been aligned. Resuming at ',3I3/) 27000 FORMAT (/' Reorientation before Reflection ',I5) 28000 FORMAT (3I4,' is probably inaccessible on a CAD-4.'/) 29000 FORMAT (I4,A,' Starting Values ',3I4,4F10.3) 30000 FORMAT (' Final Values ',3I4,4F10.3,F7.0/) END C----------------------------------------------------------------------- C Routine to generate equivalent reflections (Not Friedel) C----------------------------------------------------------------------- SUBROUTINE DEQHKL (NHKL,ILIST) INCLUDE 'COMDIF' C----------------------------------------------------------------------- C Work out the reflection details and the unique equivalents C----------------------------------------------------------------------- NHKL = 0 NRCEN = 0 IEXCL = 0 DO 110 K = 1,NSYM IM = 0 JS = 0 JH = IH*JRT(1,1,K) + IK*JRT(2,1,K) + IL*JRT(3,1,K) JK = IH*JRT(1,2,K) + IK*JRT(2,2,K) + IL*JRT(3,2,K) JL = IH*JRT(1,3,K) + IK*JRT(2,3,K) + IL*JRT(3,3,K) IPHASE = IH*JRT(1,4,K) + IK*JRT(2,4,K) + IL*JRT(3,4,K) IF (MOD(IPHASE,12) .EQ. 0) IPHASE = 0 IF (IH .EQ. JH .AND. IK .EQ. JK .AND. IL .EQ. JL) IM = 1 IF (IH .EQ. -JH .AND. IK .EQ. -JK .AND. IL .EQ. -JL) JS = 1 IF (JS .EQ. 1) NRCEN = 1 IF (IM .EQ. 1 .AND. IPHASE .NE. 0) IEXCL = 1 IF (ICENT .EQ. 0) JS = 0 IF (JS .EQ. 1 .AND. IPHASE .NE. 0) IEXCL = 1 IF (NHKL .NE. 0) THEN DO 100 I = 1,NHKL IF (JHKL(1,I) .EQ. JH .AND. $ JHKL(2,I) .EQ. JK .AND. $ JHKL(3,I) .EQ. JL) GO TO 110 IF (JHKL(1,I) .EQ. -JH .AND. $ JHKL(2,I) .EQ. -JK .AND. $ JHKL(3,I) .EQ. -JL) GO TO 110 100 CONTINUE ENDIF NHKL = NHKL + 1 JHKL(1,NHKL) = JH JHKL(2,NHKL) = JK JHKL(3,NHKL) = JL 110 CONTINUE IVALID = IEXCL IEXCL = 0 IF (LATCEN .NE. 1) THEN IF (LATCEN .EQ. 2) IREM = MOD((IK + IL),2) IF (LATCEN .EQ. 3) IREM = MOD((IH + IL),2) IF (LATCEN .EQ. 4) IREM = MOD((IH + IK),2) IF (LATCEN .EQ. 5) IREM = MOD((IH + IK + IL),2) IF (LATCEN .EQ. 6) THEN IREM = MOD((IH + IK),2) IF (IREM .EQ. 0) IREM = MOD((IH + IL),2) ENDIF IF (LATCEN .EQ. 7) IREM = MOD((-IH + IK + IL),3) IF (IEXCL .EQ. 0) IEXCL = IREM ENDIF IF (IEXCL .NE. 0) THEN IVALID = IVALID + 2 RETURN ENDIF C----------------------------------------------------------------------- C Print the equivalent indices C----------------------------------------------------------------------- IF (ILIST .EQ. 1) THEN WRITE (COUT,10000) ((JHKL(J,K),J = 1,3),K = 1,NHKL) CALL GWRITE (ITP,' ') ENDIF RETURN 10000 FORMAT (4(5X,3I4)) END C----------------------------------------------------------------------- C Edit the h,k,l list for the AL or RO commands C----------------------------------------------------------------------- SUBROUTINE ALEDIT (NTOT) INCLUDE 'COMDIF' DIMENSION NDEL(100) CHARACTER IOPT*1,LINE*80 C----------------------------------------------------------------------- C Read in the existing list of h,k,l values and write it to terminal C----------------------------------------------------------------------- READ (IID,REC=16) (IOH(J),J = 1,80),DT,DO,DC,TIME,AFRAC READ (IID,REC=17) (IOK(J),J = 1,80),NTOT READ (IID,REC=18) (IOL(J),J = 1,80) READ (IID,REC=19) (IOH(J),IOK(J),IOL(J),J = 81,100) 100 IF (NTOT .LE. 0) THEN WRITE (COUT,10000) CALL GWRITE (ITP,' ') ELSE WRITE (COUT,11000) NTOT CALL GWRITE (ITP,' ') NLINE = NTOT/4 IF (NTOT - 4*NLINE .NE. 0) NLINE = NLINE + 1 I1 = 1 I2 = 4 DO 110 N = 1,NLINE IF (N .EQ. NLINE) I2 = NTOT WRITE (COUT,12000) (I,IOH(I),IOK(I),IOL(I),I = I1,I2) CALL GWRITE (ITP,' ') I1 = I1 + 4 I2 = I2 + 4 110 CONTINUE ENDIF C----------------------------------------------------------------------- C Get the edit option IOPT C----------------------------------------------------------------------- WRITE (COUT,13000) CALL ALFNUM (LINE) IOPT = LINE(1:1) IF (IOPT .EQ. ' ') IOPT = 'U' C----------------------------------------------------------------------- C Option E. Exit from AL with 0 reflns C----------------------------------------------------------------------- IF (IOPT .EQ. 'E') THEN NTOT = 0 RETURN ENDIF C----------------------------------------------------------------------- C Option U. Use the present list and get the TRUANG flag. C----------------------------------------------------------------------- IF (IOPT .EQ. 'U') THEN ITRUE = 0 WRITE (COUT,14100) CALL YESNO ('N',LINE) ANS = LINE(1:1) IF (ANS .EQ. 'Y') ITRUE = 1 RETURN ENDIF C----------------------------------------------------------------------- C Options A and N. Add reflns or use new ones. C----------------------------------------------------------------------- IF (IOPT .EQ. 'A' .OR. IOPT .EQ. 'N') THEN IF (IOPT .EQ. 'N') NTOT = 0 ISYMOR = 0 WRITE (COUT,14000) CALL YESNO ('Y',LINE) ANS = LINE(1:1) IF (ANS .EQ. 'Y') THEN ISYMOR = 1 IOUT = -1 CALL SPACEG (IOUT,0) ENDIF NPOSS = 100 - NTOT WRITE (COUT,15000) NPOSS CALL GWRITE (ITP,' ') 120 WRITE (COUT,16000) CALL FREEFM (ITR) IH = IFREE(1) IK = IFREE(2) IL = IFREE(3) IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN IPRVAL = 1 CALL ANGCAL IF (IVALID .EQ. 0) THEN IF (ISYMOR .EQ. 1) THEN ILIST = 1 CALL DEQHKL (NHKL,ILIST) DO 130 I = 1,NHKL NTOT = NTOT + 1 IOH(NTOT) = JHKL(1,I) IOK(NTOT) = JHKL(2,I) IOL(NTOT) = JHKL(3,I) IF (NTOT .EQ. NSIZE/2) THEN WRITE (COUT,17000) CALL GWRITE (ITP,' ') GO TO 100 ENDIF 130 CONTINUE ELSE NTOT = NTOT + 1 IOH(NTOT) = IH IOK(NTOT) = IK IOL(NTOT) = IL ENDIF ENDIF GO TO 120 ENDIF ENDIF C----------------------------------------------------------------------- C Option D. Delete reflections from the list C----------------------------------------------------------------------- IF (IOPT .EQ. 'D') THEN DO 140 I = 1,100 NDEL(I) = 0 140 CONTINUE 150 WRITE (COUT,18000) CALL FREEFM (ITR) IH = IFREE(1) IK = IFREE(2) IL = IFREE(3) IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN DO 160 N = 1,NTOT IF (IH .EQ. IOH(N) .AND. IK .EQ. IOK(N) .AND. $ IL .EQ. IOL(N)) THEN NDEL(N) = 1 GO TO 150 ENDIF 160 CONTINUE WRITE (COUT,19000) IH,IK,IL CALL GWRITE (ITP,' ') GO TO 150 ELSE C----------------------------------------------------------------------- C Form the new list C----------------------------------------------------------------------- NEW = 0 DO 170 N = 1,NTOT IF (NDEL(N) .EQ. 0) THEN NEW = NEW + 1 IOH(NEW) = IOH(N) IOK(NEW) = IOK(N) IOL(NEW) = IOL(N) ENDIF 170 CONTINUE NTOT = NEW ENDIF ENDIF C----------------------------------------------------------------------- C List the existing list and get new option C----------------------------------------------------------------------- GO TO 100 10000 FORMAT (' There are no reflections in the AL/RO list.') 11000 FORMAT (' The following',I4,' reflections are in the AL/RO list') 12000 FORMAT (4(I3,'.',3I4,3X)) 13000 FORMAT (' The following options are available :--'/ $ ' U. Use the existing AL/RO list;'/ $ ' A. Add reflections to the existing AL/RO list;'/ $ ' D. Delete reflections from the existing AL/RO list;'/ $ ' N. New AL/RO list.'/ $ ' L. List the reflections in the existing AL/RO list;'/ $ ' E. Exit from AL/RO.'/ $ ' Which option do you want (U) ? ',$) 14000 FORMAT (' Friedel equivalents are always used.'/ $ ' Do you want symmetry equivalents as well (Y) ? ',$) 14100 FORMAT (' Align 4 equivalent settings for each refln (N) ? ',$) 15000 FORMAT (' Type h,k,l for up to',I4,' reflections ') 16000 FORMAT (' h,k,l (End) ',$) 17000 FORMAT (' No more reflections allowed.') 18000 FORMAT (' Type h,k,l for the reflection to be deleted (End) ',$) 19000 FORMAT (3I4,' not found. Try again please.') END