C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        REFLECTION SORT-MERGE PROGRAM SORT                             0002.000
C        GX PACKAGE  APRIL 1985   K.W. MUIR & P.R. MALLINSON            0003.000
C                                                                       0004.000
      PROGRAM NSORKWM                                                   0005.000
C     READS A CAD4 OUTPUT FILE, REJECTS SYSTEMATIC ABSENCES,            0006.000
C     SORTS ON H AND AVERAGES EQUIVALENT REFLECTIONS.                   0007.000
C                                                                       0008.000
C     STORAGE FOR MODEL FILE AND FOR FREE FORMAT READING                0009.000
      CHARACTER COMPID(72),LINE(148)                                    0010.000
      CHARACTER*8 LABEL(200),FTYPE(13)                                  0011.000
      INTEGER CN(200),CONTNT(13),FCH(20),FWD(20)                        0012.000
      COMMON /MODELC/COMPID,LABEL,FTYPE                                 0013.000
      COMMON /MODEL/ NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),            0014.000
     1CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),           0015.000
     2WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,                    0016.000
     3SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT                         0017.000
      CHARACTER JOV (67)                                                0018.000
C                                                                       0019.000
C     SET UP  AND INITIALIZE STORAGE                                    0020.000
C LM=1     MODEL FILE         KSPACE=7500  SIZE OF IX,IY,A,B            0021.000
C LIN=2    REFLEXION INPUT    NMAX= 47     SIZE OF IG,IGG,GA,GB         0022.000
C LSCRA=3  SCRATCH FILE       KIN - INPUT COUNT                         0023.000
C LOUT=4   REFLEXION OUTPUT   KABS - SYSTEMATICALLY ABSENT              0024.000
C LC=5     INSTRUCTION INPUT  KIS - TOTAL ENTERING SORT                 0025.000
C LP=6     PROMPTS            KORE - TOTAL IN MEMORY                    0026.000
C LT=7     PRINTER            KSCR - MARKER FOR SCRATCH USE             0027.000
C KOUT - INDEPENDENT REFLEXIONS WRITTEN ON LOUT                         0028.000
C KR   - NUMBER OBSERVED AT LEAST TWICE                                 0029.000
      CHARACTER*8 TAG,MIL(3)                                            0030.000
      COMMON IX(7500),IY(7500),A(7500),B(7500),                         0031.000
     1IG(47),IGG(47),GA(47),GB(47)                                      0032.000
      DIMENSION IA(3),IB(3),TR(3,3),IIN(3)                              0033.000
      DIMENSION ITS(3,24),IS(2,3,24),IT(3,4),KT(256)                    0034.000
      DATA LINE/148*' '/,MIL/'H','K','L'/                               0035.000
      DATA  TR/1.,0.,0.,0.,1.,0.,0.,0.,1./,IMAX/-1/                     0036.000
      DATA LM,LIN,LSCRA,LOUT,LC,LP,LT/1,2,3,4,5,6,7/                    0037.000
      DATA FACTOR/3.0/,KSPACE/7500/,NMAX/47/                            0038.000
      DATA ITAG,KIN,KEOF,KABS,KIS,KORE,KSCR,KOUT,KR,KLOS,KRR,KT/267*0/  0039.000
      DATA RUP,RDOWN,PFAC/2*0.,1.04/,KDISC/0/,RFAC/0.0/,KSTAN/0/        0040.000
      KH=2**16                                                          0041.000
      KK=2**8                                                           0042.000
      KL=1                                                              0043.000
      K0=128                                                            0044.000
      KORIG=K0*(KH+KK+KL)                                               0045.000
      KINV=2*KORIG                                                      0046.000
 1001 FORMAT(3I4,' FSQ = ',F11.2,' SIG = ',F9.2,                        0047.000
     1' IS A SYSTEMATIC  ABSENCE')                                      0048.000
 1002 FORMAT(3I4,' MEAN FOBS=',F8.2,' ESD= ',F6.2,' RANGE ESD= ',F6.2,  0049.000
     1' FROM ',I3,' MEASUREMENTS ')                                     0050.000
 1003 FORMAT(/20X,'REFLECTIONS COUNTS ',//1H ,72('-')/                  0051.000
     16X,I6,' WERE READ FROM THE INPUT FILE',//                         0052.000
     26X,I6,' OF THESE WERE SYSTEMATIC ABSENCES',//                     0053.000
     36X,I6,' WERE LEFT FOR SORTING AND AVERAGING',//                   0054.000
     46X,I6,' INDEPENDENT REFLECTIONS WERE WRITTEN TO THE OUTPUT FILE',/0055.000
     5/6X,I6,' INDEPENDENT INTENSITIES LESS THAN ',F4.1,                0056.000
     6' SIGMA WERE REJECTED AT OUTPUT STAGE',//                         0057.000
     6  12X,' R FOR MERGING ',I6,' OBSERVATIONS TO GET',I6,/            0058.000
     7  12X,' INDEPENDENT INTENSITIES = ',F6.3,/1H ,72('-'))            0059.000
 1005 FORMAT(72A1)                                                      0060.000
 1006 FORMAT(10X,'  NEW ',A2,'= H*R1 + K*R2 + L*R3'//                   0061.000
     110X,'  TYPE R1  R2  R3 '/)                                        0062.000
 1009 FORMAT(1H1,'SORT AND AVERAGE REFLECTIONS FOR '/1H ,72A1//)        0063.000
 1010 FORMAT(/10X,' PLEASE WAIT. I AM READING THE MODEL FILE'/)         0064.000
 1011 FORMAT(///10X,' DISCREPANCIES DURING AVERAGING'/)                 0065.000
 1012 FORMAT(/20X,'NONE'///)                                            0066.000
 2000 FORMAT(/10X,' APPLY SEPARATE BATCH SCALES?',/                     0067.000
     110X,' AFTER SORT NSET = 1 FOR ALL REFLECTION'/)                   0068.000
 2001 FORMAT(/10X,' EXCLUDE UNOBSERVEDS FROM THE OUTPUT FILE ? '/)      0069.000
 2002 FORMAT(10X,' DO NOT OUTPUT REFLECTION IF I  <   G*SIGI',//        0070.000
     110X,' TYPE IN THE VALUE OF G REQUIRED '/)                         0071.000
 2003 FORMAT(10X,' TRANSFORM THE INDICES  ? '/)                         0072.000
 2004 FORMAT(/10X,'TRANSFORMATION MATRIX FOR INDICES'/,                 0073.000
     1 3(/10X,A1,'NEW = (',F5.2,')H + (',F5.2,')K + (',F5.2,')L'))      0074.000
 2005 FORMAT(10X,' LIST REFLECTIONS AFTER SORTING ? '/)                 0075.000
 2006 FORMAT(4(9(2X,F6.1,F5.2)/))                                       0076.000
 2007 FORMAT(/7X,' EQUIVALENT REFLECTIONS TO BE AVERAGED ')             0077.000
 2008 FORMAT(9X,' TOGETHER WITH THEIR FRIEDEL PAIRS '/)                 0078.000
 2009 FORMAT(7X,67A1)                                                   0079.000
 2010 FORMAT(/7X,' EQUIVALENT POSITIONS  ')                             0080.000
 2011 FORMAT(/6X,A3,' LATTICE  . ',A3,' CENTROSYMMETRIC UNIT CELL'/)    0081.000
 2012 FORMAT(//)                                                        0082.000
      WRITE(LP,1010)                                                    0083.000
      CALL MDLIN(LM)                                                    0084.000
      DO 101 J=1,NT                                                     0085.000
      DO 101 I=1,3                                                      0086.000
  101 IT(I,J)=NINT(T(I,J)*6.)                                           0087.000
      DO 103 J=1,NR                                                     0088.000
      DO 102 I=1,3                                                      0089.000
      ITS(I,J)=NINT(R(J,I,4)*12.)                                       0090.000
      DO 102 K=1,2                                                      0091.000
  102 IS(K,I,J)=0                                                       0092.000
      DO 103 I=1,3                                                      0093.000
      K=1                                                               0094.000
      DO 103 L=1,3                                                      0095.000
      IF(ABS(R(J,I,L)) .LT. 0.1)GOTO 103                                0096.000
      IS(K,I,J)=ISIGN(L,NINT(R(J,I,L)))                                 0097.000
      K=2                                                               0098.000
  103 CONTINUE                                                          0099.000
C                                                                       0100.000
C     INPUT USER'S INSTRUCTIONS                                         0101.000
C                                                                       0102.000
      IF(NQ.EQ.1)GOTO 200                                               0103.000
      WRITE(LP,2000)                                                    0104.000
      CALL QUERY(LC,LP,KSTAN)                                           0105.000
  200 WRITE(LP,2005)                                                    0106.000
      CALL QUERY(LC,LP,IPRINT)                                          0107.000
      WRITE(LP,2001)                                                    0108.000
      CALL QUERY(LC,LP,KILL)                                            0109.000
      IF(KILL.EQ.0)GOTO 202                                             0110.000
  201 WRITE(LP,2002)                                                    0111.000
      READ(LC,1005)(LINE(I),I=2,73)                                     0112.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0113.000
      IF(NFS.NE.1)GOTO 201                                              0114.000
      CALL FFORMT(LINE,FCH(1),FWD(1),FACTOR)                            0115.000
  202 WRITE(LP,2003)                                                    0116.000
      CALL QUERY(LC,LP,KTRAN)                                           0117.000
      IF(KTRAN.EQ.0)GOTO 250                                            0118.000
  105 DO 107 I=1,3                                                      0119.000
  108 WRITE(LP,1006)MIL(I)                                              0120.000
      READ(LC,1005)(LINE(J),J=2,73)                                     0121.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0122.000
      IF(NFS.NE.3)GOTO 108                                              0123.000
      DO 109 J=1,3                                                      0124.000
  109 CALL FFORMT(LINE,FCH(J),FWD(J),TR(I,J))                           0125.000
  107 CONTINUE                                                          0126.000
C                                                                       0127.000
C     READ IN THE DIFFRACTOMETER REFLEXION FILE                         0128.000
C     REJECT SYSTEMATICALLY ABSENT REFLEXIONS AND SORT WHAT'S LEFT      0129.000
C     IF ALL REFLEXIONS HAVE BEEN READ AND ARE IN MEMORY EXIT TO        0130.000
C     AVERAGE AND OUTPUT SECTION - LABEL 25                             0131.000
C                                                                       0132.000
  250 REWIND(LIN)                                                       0133.000
      WRITE(LT,1009)COMPID                                              0134.000
      TAG='   '                                                         0135.000
      IF(ICENT.EQ.1)TAG='NON'                                           0136.000
      JOV(1)='P'                                                        0137.000
      IF(NT.EQ.2.AND.ABS(T(1,2)).LT..1)JOV(1)='A'                       0138.000
      IF(NT.EQ.2.AND.ABS(T(2,2)).LT..1)JOV(1)='B'                       0139.000
      IF(NT.EQ.2.AND.ABS(T(3,2)).LT..1)JOV(1)='C'                       0140.000
      IF(NT.EQ.3)JOV(1)='R'                                             0141.000
      IF(NT.EQ.4)JOV(1)='I'                                             0142.000
      WRITE(LT,2011)JOV(1),TAG                                          0143.000
      WRITE(LT,2010)                                                    0144.000
      DO 2100 I=1,NR                                                    0145.000
      DO 2101 J=1,67                                                    0146.000
 2101 JOV(J)=' '                                                        0147.000
      DO 2102 J=1,3                                                     0148.000
      K=1+10*(J-1)                                                      0149.000
      CALL CRDOUT(JOV,K,R(I,J,1),R(I,J,2),R(I,J,3),R(I,J,4))            0150.000
 2102 CONTINUE                                                          0151.000
      WRITE(LT,2009)(JOV(J),J=1,K)                                      0152.000
 2100 CONTINUE                                                          0153.000
      WRITE(LT,2007)                                                    0154.000
      IF(ICENT.EQ.0)WRITE(LT,2008)                                      0155.000
      DO 1100 I=1,NR                                                    0156.000
      DO 1101 J=1,67                                                    0157.000
 1101 JOV(J)=' '                                                        0158.000
      DO 1102 J=1,3                                                     0159.000
      K=1+10*(J-1)                                                      0160.000
      CALL CRDOUT(JOV,K,R(I,1,J),R(I,2,J),R(I,3,J),0.)                  0161.000
 1102 CONTINUE                                                          0162.000
      DO 1103 J=1,67                                                    0163.000
      IF(JOV(J).EQ.'X')JOV(J)='H'                                       0164.000
      IF(JOV(J).EQ.'Y')JOV(J)='K'                                       0165.000
      IF(JOV(J).EQ.'Z')JOV(J)='L'                                       0166.000
 1103 CONTINUE                                                          0167.000
      WRITE(LT,2009)(JOV(J),J=1,K)                                      0168.000
 1100 CONTINUE                                                          0169.000
      WRITE(LT,2012)                                                    0170.000
      IF(KTRAN.EQ.1)WRITE(LT,2004)(MIL(J),(TR(J,I),I=1,3),J=1,3)        0171.000
    1 READ(LIN,END=10)JAA,JBB,FF,SIGI                                   0172.000
      CALL KRAKJA(JAA,ISET,IIN(1),IIN(2),IIN(3))                        0173.000
      FSCALE=1.0                                                        0174.000
      IF(KSTAN.EQ.0)GOTO 97                                             0175.000
      IF(ISET.LT.1.OR.ISET.GT.4)ISET=1                                  0176.000
      FSCALE=1.0/SCALE(ISET)                                            0177.000
   97 DO 98 I=1,3                                                       0178.000
   98 IA(I)=NINT(IIN(1)*TR(I,1)+IIN(2)*TR(I,2)+IIN(3)*TR(I,3))          0179.000
      KIN=KIN+1                                                         0180.000
      DO 2 J=2,NT                                                       0181.000
      I=MOD(IA(1)*IT(1,J)+IA(2)*IT(2,J)+IA(3)*IT(3,J), 6)               0182.000
      IF(I.NE.0)GOTO 9                                                  0183.000
    2 CONTINUE                                                          0184.000
      IND=IA(1)*KH+IA(2)*KK+IA(3)+KORIG                                 0185.000
      INE=IND                                                           0186.000
      DO 8 J=1,NR                                                       0187.000
      DO 3 I=1,3                                                        0188.000
    3 IB(I)=0                                                           0189.000
      DO 5 I=1,3                                                        0190.000
      DO 4 K=1,2                                                        0191.000
      M=IABS(IS(K,I,J))                                                 0192.000
      IF(M.NE.0)IB(M)=IB(M)+IA(I)*ISIGN(1,IS(K,I,J))                    0193.000
    4 CONTINUE                                                          0194.000
    5 CONTINUE                                                          0195.000
      INR=IB(1)*KH+IB(2)*KK+IB(3)+KORIG                                 0196.000
      IGO=0                                                             0197.000
    6 IF(IND.NE.INR)GOTO 7                                              0198.000
      I=MOD(IA(1)*ITS(1,J)+IA(2)*ITS(2,J)+IA(3)*ITS(3,J), 12)           0199.000
      IF(I.NE.0)GOTO 9                                                  0200.000
    7 IF(INE.LT.INR)INE=INR                                             0201.000
      IF(ICENT.EQ.1 .OR. IGO.EQ.1)GOTO 8                                0202.000
      IGO=1                                                             0203.000
      INR=KINV-INR                                                      0204.000
      GOTO 6                                                            0205.000
    8 CONTINUE                                                          0206.000
      KORE=KORE+1                                                       0207.000
      FF=SQRT(ABS(FF))                                                  0208.000
      IX(KORE)=INE                                                      0209.000
      IY(KORE)=JBB                                                      0210.000
      A(KORE)=FF*FSCALE                                                 0211.000
      B(KORE)=0.5*FSCALE*SIGI/FF                                        0212.000
      IF(KORE-KSPACE)1,99,99                                            0213.000
    9 KABS=KABS+1                                                       0214.000
      IF(FF.LT.FACTOR*SIGI) GO TO 1                                     0215.000
      WRITE(LT,1001)IA,FF,SIGI                                          0216.000
      GOTO 1                                                            0217.000
   10 KEOF=1                                                            0218.000
      WRITE(LT,1011)                                                    0219.000
   99 KIS=KIS+KORE                                                      0220.000
      CALL SORT(A,B,IX,IY,KORE)                                         0221.000
      IF(KEOF.EQ.1  .AND.  KSCR.EQ.0)GOTO 25                            0222.000
C                                                                       0223.000
C     MEMORY COMPLETEY FILLED AND MORE REFLEXIONS TO BE READ            0224.000
C     DUMP MEMORY CONTENTS TO SCRATCH AND RETURN TO INPUT               0225.000
C     SECTION - LABEL 1                                                 0226.000
C                                                                       0227.000
      IF(KORE.LE.0)GOTO 15                                              0228.000
      KSCR=1                                                            0229.000
      NBUF=0                                                            0230.000
      ILAST=IX(1)/KH                                                    0231.000
      DO 14 J=1,KORE                                                    0232.000
      ICURR=IX(J)/KH                                                    0233.000
      IF(ICURR.NE.ILAST)GOTO 12                                         0234.000
      IF(NBUF.GE.NMAX)GOTO 12                                           0235.000
   11 NBUF=NBUF+1                                                       0236.000
      GA(NBUF)=A(J)                                                     0237.000
      GB(NBUF)=B(J)                                                     0238.000
      IG(NBUF)=IX(J)                                                    0239.000
      IGG(NBUF)=IY(J)                                                   0240.000
      KT(ILAST)=KT(ILAST)+1                                             0241.000
      GOTO 14                                                           0242.000
   12 WRITE(LSCRA)ILAST,NBUF,IG,IGG,GA,GB                               0243.000
      NBUF=0                                                            0244.000
      ILAST=ICURR                                                       0245.000
      GOTO 11                                                           0246.000
   14 CONTINUE                                                          0247.000
      IF(NBUF.GT.0)WRITE(LSCRA)ILAST,NBUF,IG,IGG,GA,GB                  0248.000
      KORE=0                                                            0249.000
   15 IF(KEOF.EQ.0)GOTO 1                                               0250.000
      ENDFILE(LSCRA)                                                    0251.000
C                                                                       0252.000
C     READ AS MANY REFLEXIONS AS POSSIBLE INTO MEMORY FROM              0253.000
C     THE SCRATCH FILE                                                  0254.000
C                                                                       0255.000
   16 REWIND(LSCRA)                                                     0256.000
      IMIN=IMAX+1                                                       0257.000
      DO 17 I=2,256                                                     0258.000
      KGET=KT(I-1)                                                      0259.000
      KT(I-1)=0                                                         0260.000
      IF(KT(I)+KGET .GT. KSPACE)GOTO 18                                 0261.000
      KT(I)=KT(I)+KGET                                                  0262.000
      IMAX=I                                                            0263.000
   17 CONTINUE                                                          0264.000
   18 KORE=0                                                            0265.000
      IF(KGET.LE.0)GOTO 32                                              0266.000
   19 READ(LSCRA,END=21)ICURR,NBUF,IG,IGG,GA,GB                         0267.000
      IF(ICURR.GT.IMAX.OR.ICURR.LT.IMIN)GOTO 19                         0268.000
      DO 20 I=1,NBUF                                                    0269.000
      IX(I+KORE)=IG(I)                                                  0270.000
      IY(I+KORE)=IGG(I)                                                 0271.000
      A(I+KORE)=GA(I)                                                   0272.000
   20 B(I+KORE)=GB(I)                                                   0273.000
      KORE=KORE+NBUF                                                    0274.000
      IF(KORE.LT.KGET)GOTO 19                                           0275.000
   21 CALL SORT(A,B,IX,IY,KORE)                                         0276.000
C                                                                       0277.000
C     AVERAGE AND OUTPUT ALL REFLEXIONS IN MEMORY                       0278.000
C     IF NOT FINISHED RETURN TO LABEL 16 TO PICK UP                     0279.000
C     A FRESH LOAD FROM SCRATCH                                         0280.000
C     DETECTION OF INCONSISTENCIES AS IN SHELX                          0281.000
   25 I=0                                                               0282.000
      N=1                                                               0283.000
   26 I=I+N                                                             0284.000
      IF(I.GT.KORE)GOTO 31                                              0285.000
      JIX=IX(I)                                                         0286.000
      IA(1)=JIX/KH-K0                                                   0287.000
      JIX=MOD(JIX,KH)                                                   0288.000
      IA(2)=JIX/KK-K0                                                   0289.000
      IA(3)=MOD(JIX,KK)-K0                                              0290.000
      JBB=IY(I)                                                         0291.000
      FF=A(I)                                                           0292.000
      SIGI=B(I)                                                         0293.000
      N=1                                                               0294.000
   27 IF(I+N .GT. KORE)GOTO 28                                          0295.000
      IF(IX(I+N) .NE. IX(I))GOTO 28                                     0296.000
      N=N+1                                                             0297.000
      GOTO 27                                                           0298.000
   28 IF(N.EQ.1)GOTO 30                                                 0299.000
      J=I+N-1                                                           0300.000
      SW=0.                                                             0301.000
      SWX=0.                                                            0302.000
      SWT=0.                                                            0303.000
      SWX2=0.                                                           0304.000
      DO 29 K=I,J                                                       0305.000
      X=A(K)                                                            0306.000
      W=B(K)                                                            0307.000
      W=1.0/(W*W)                                                       0308.000
      SW=SW+W                                                           0309.000
      SWX=SWX+W*X                                                       0310.000
      SWT=SWT+W*FLOAT(IY(K)/65536)                                      0311.000
   29 SWX2=SWX2+W*X*X                                                   0312.000
      KR=KR+1                                                           0313.000
      KRR=KRR+N                                                         0314.000
      FF=SWX/SW                                                         0315.000
      SIGI=1.0/SW                                                       0316.000
      S=SW*SWX2                                                         0317.000
      Q=SWX*SWX                                                         0318.000
      RUP=RUP+REAL(N)*(S-Q)*SIGI                                        0319.000
      RDOWN=RDOWN+REAL(N-1)*SWX2                                        0320.000
      SIGI=SQRT(SIGI)                                                   0321.000
      TBAR=SWT/SW                                                       0322.000
      JBB=ANINT(TBAR)*65536                                             0323.000
      IF(PFAC*Q .GT. S)GOTO 30                                          0324.000
      SRNGE=SQRT(ABS(S/Q-1.))*FF                                        0325.000
      IF(SRNGE.LT.SIGI+SIGI.AND.IPRINT.EQ.0)GOTO 30                     0326.000
      WRITE(LT,1002)IA,FF,SIGI,SRNGE,N                                  0327.000
      WRITE(LT,2006)(A(K),B(K),K=I,J)                                   0328.000
      KDISC=KDISC+1                                                     0329.000
   30 IF(KILL.EQ.0)GOTO 34                                              0330.000
      IF(FF.GE.2.0*FACTOR*SIGI) GO TO 34                                0331.000
      KLOS=KLOS+1                                                       0332.000
      GOTO 26                                                           0333.000
   34 SIGI=2.0*SIGI*FF                                                  0334.000
      FF=FF*FF                                                          0335.000
      JAA=16777216+65536*IA(1)+256*IA(2)+IA(3)+8421504                  0336.000
      WRITE(LOUT)JAA,JBB,FF,SIGI                                        0337.000
      KOUT=KOUT+1                                                       0338.000
      GOTO 26                                                           0339.000
   31 IF(KSCR.EQ.0)GOTO 32                                              0340.000
      GOTO 16                                                           0341.000
   32 IF (KDISC.EQ.0)WRITE(LT,1012)                                     0342.000
      IF(RDOWN.GT.0.00001 .AND. KR.GT.0)RFAC=SQRT(RUP/RDOWN)            0343.000
   41 WRITE(LT,1003)KIN,KABS,KIS,KOUT,KLOS,FACTOR,KRR,KR,RFAC           0344.000
      ENDFILE(LOUT)                                                     0345.000
      STOP                                                              0346.000
      END                                                               0347.000
      SUBROUTINE SORT(A,B,IX,IY,N)                                      0348.000
C**** SORTS IX,IY,A,B WITH IX AS THE KEY                                0349.000
      DIMENSION A(N),B(N),IX(N),IY(N)                                   0350.000
      INT=2                                                             0351.000
   10 INT=2*INT                                                         0352.000
      IF(INT.LT.N) GO TO 10                                             0353.000
      INT=MIN0(N,(3*INT)/4-1)                                           0354.000
   20 INT=INT/2                                                         0355.000
      IFIN=N-INT                                                        0356.000
      DO 70 II=1,IFIN                                                   0357.000
      I=II                                                              0358.000
      J=I+INT                                                           0359.000
      IF(IX(I).LE.IX(J)) GO TO 70                                       0360.000
      T=A(J)                                                            0361.000
      X=B(J)                                                            0362.000
      M=IY(J)                                                           0363.000
      L=IX(J)                                                           0364.000
   40 A(J)=A(I)                                                         0365.000
      B(J)=B(I)                                                         0366.000
      IX(J)=IX(I)                                                       0367.000
      IY(J)=IY(I)                                                       0368.000
      J=I                                                               0369.000
      I=I-INT                                                           0370.000
      IF(I.LE.0) GO TO 60                                               0371.000
      IF(IX(I).GT.L) GO TO 40                                           0372.000
   60 A(J)=T                                                            0373.000
      B(J)=X                                                            0374.000
      IX(J)=L                                                           0375.000
      IY(J)=M                                                           0376.000
   70 CONTINUE                                                          0377.000
      IF(INT.GT.1) GO TO 20                                             0378.000
      RETURN                                                            0379.000
      END                                                               0380.000
      SUBROUTINE QUERY(LIN,LOUT,ANSWER)                                 0381.000
      CHARACTER LINE(148)                                               0382.000
      CHARACTER*8 TAG                                                   0383.000
      INTEGER FCH(20),FWD(20),ANSWER                                    0384.000
      DATA LINE/148*' '/                                                0385.000
 1001 FORMAT(72A1)                                                      0386.000
 1002 FORMAT(//9X,' PLEASE ANSWER YES OR NO'/)                          0387.000
    1 READ(LIN,1001)(LINE(I),I=2,73)                                    0388.000
      CALL PARSE(LINE,NFS,FCH,FWD)                                      0389.000
      IF(NFS.NE.1)GOTO 2                                                0390.000
      CALL AFORMT(LINE,FCH(1),FWD(1),TAG)                               0391.000
      IF(TAG.EQ.'YES'.OR.TAG.EQ.'Y')GOTO 3                              0392.000
      IF(TAG.EQ.'NO'.OR.TAG.EQ.'N')GOTO 4                               0393.000
    2 WRITE(LOUT,1002)                                                  0394.000
      GOTO 1                                                            0395.000
    3 ANSWER=1                                                          0396.000
      GOTO 5                                                            0397.000
    4 ANSWER=0                                                          0398.000
    5 RETURN                                                            0399.000
      END                                                               0400.000
      SUBROUTINE KRAKJA(JA,NSET,IH,IK,IL)                               0401.000
      NSET=JA/16777216                                                  0402.000
      JA=JA-16777216*NSET                                               0403.000
      IH=JA/65536                                                       0404.000
      JA=JA-65536*IH                                                    0405.000
      IH=IH-128                                                         0406.000
      IK=JA/256                                                         0407.000
      IL=JA-256*IK-128                                                  0408.000
      IK=IK-128                                                         0409.000
      RETURN                                                            0410.000
      END                                                               0411.000
