C     CAD4 DATA PROCESSOR HURSTHOUSE.                                   0001.000
C     2976 VERSION FROM 370 VERSION P.R.M. MAY 1978                     0002.000
C     32/27 PRELIMINARY IMPLEMENTATION P.R.M. NOV 1980                  0003.000
C     MENUS AND OTHER IMPROVEMENTS KWM SEP  1983                        0004.000
C        GX PACKAGE APRIL 1985                                          0005.000
      PROGRAM CAD4KWM                                                   0006.000
      DIMENSION  ITEXT(9),JTITL(15),DVECT(3),LABS(3,6)      
      DIMENSION NSEQ(2),NPSIFL(2),FNAME(2),R(3,3),AM(3,3),LCARD(15)     0008.000
      DIMENSION JD(96),COSINES(7)      
      DIMENSION CX(3),DX(3),A(9),KNT(13),ISEQU1(8),TLIM(0:15)           0010.000
      REAL*8 COMPID                                                     0011.000
      CHARACTER INSTRU(81),ISTATUS(6),JSTATUS(9),
     *KA,KB,KC,KD,KE,KF,KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,
     *KT,KU,KV,KW,KX,KY,KZ,M1,M2,M3,M4,LSTAR,LBLANK,NUMB(10)
      INTEGER FIRSTCH(10),FWIDTH(10)                                    0013.000
      CHARACTER*4 IPAD(20),IARO,NOYES(0:1),HEAD2(3)        
      CHARACTER*8 HEAD1(17)                                             0015.000
      CHARACTER*61 LINE
      COMMON FREL,SIGF,TX,FLAM1,IPRINT                                  0016.000
      COMMON /SHELX/IHS,IKS,ILS,FSQS,SIGS,ILIM(3,2),SLIM(5,2)
      COMMON/ANABLK/K1(50),K2(50),K3(50),TTS(50),FFS(50)                0017.000
      EQUIVALENCE (COMPID,ITEXT(1)),(LINE,INSTRU(2))
      DATA NUMB/1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1H0/,IXRAYT/0/      0019.000
      DATA KA,KB,KC,KD,KE,KF,KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,    0020.000
     *KT,KU,KV,KW,KX,KY,KZ/ 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,1HK,0021.000
     * 1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ/     0022.000
      DATA LHATCH/1H?/,LBLANK/1H /,LSTAR/1H*/,IOV/4H****/               0023.000
      DATA JSTATUS/1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H /                 0024.000
      DATA RTD/57.2957795/,DTR/.017453/,LT/4/,LD/14/,LX/1/,LB/24/,LH/7/ 0025.000
      DATA LC/5/,LP/6/,KERR/0/,IRCK/1/,MODE/0/,FRAC/2.0/,LIMGO/100000/  0026.000
      DATA ILIMGO/1/,SCALE/1./,IFADE/0/,NSET/1/,IPRIN/0/,QFAC/0.03/     0027.000
      DATA Y3/1./,GRAD/0./,XN1/0./,Y2/1./,IEND/0/,NREFL/1/,NLD/0/,IT1/0/0028.000
      DATA IT2/0/,IT3/0/,JH/0/,JK/0/,JL/0/,ISW1/0/,ISW2/0/,IPOINT/1H./  0029.000
      DATA IBGIN/1/,IPROF/0/,IPAD/20*'    '/,IARO/4H    /,IMISS/1/    
      DATA MISS/0/,TAKE/6.0817/,  ATEN/019.20000/,ISUPP/0/,JHKLF/5/     0031.000
      DATA WAVL/0.7114/,IFORT/0/,ICOPY/0/,ICARD/0/,ILP/1/               0032.000
      DATA KNT/13*0/,XIMIN/1.0/,INSTRU/81*' '/,LK/2/,LXX/8/,LHH/3/      0033.000
      DATA IREJP/0/,IDCOS/0/,IOUTP/100/,NOYES/'NO','YES'/               0034.000
      DATA HEAD1/'ALL DATA','H+K+L   ','K+L     ','H+L     ',           0035.000
     *'H+K     ','0KL K   ','0KL L   ','0KL K+L ','H0L H   ','HOL L   ',0036.000
     *'H0L H+L ','HK0 H   ','HK0 K   ','HK0 H+K ','H00 H   ','0K0 K   ',0037.000
     *'00L L   '/                                                       0038.000
      DATA HEAD2/'EVEN','ODD ','    '/                                  0039.000
      DATA ILIM/6*0/,SLIM/10*0.0/
C                                                                       0040.000
      DO 42 I = 1, 4
      SLIM(I,1)=+999.0
      SLIM(I,2)=-999.0
   42 CONTINUE
      NEW=0
      WRITE(LP,40)                                                      0041.000
   40 FORMAT(1H1/ 1X,25HCAD4 PROCESSOR MARK (IV) ,/,1X,110(1H-))   
      OPEN (UNIT=9,FILE='NAME.HKL',FORM='FORMATTED',STATUS='NEW')
      CALL ANA(0,0.,0.)                                                 0043.000
C                                                                       0044.000
C CARD INSTRUCTION INPUT                                                0045.000
C                                                                       0046.000
  800 WRITE(LK,8000)                                                    0047.000
 8000 FORMAT(/30X,'<<<<SELECT MENU OPTIONS>>>>',/                       0048.000
     1/10X,'1. TITL  <TITLE>',24X,'8. FADE <I0 I1 I2 N1 N2>',           0049.000
     2/10X,'2. MONO  <THETA(DEG)>',19X,'9. PROF -PROFILES PRESENT',     0050.000
     3/10X,'3. ATEN  <ATTENUATOR FACTOR>',11X,'10. REJP -CALL REJECT',  0051.000
     4/10X,'4. SCAL  <SCALE FACTOR>',16X,'11. DCOS -WRITE COSINES',     0052.000
     5/10X,'5. NSET  <SCALE FACTOR NO.>',12X,'12. BGIN <NREFA>',        0053.000
     6/10X,'6. PFAC  <ADD PFAC*I TO SIGI>',10X,'13. SKIP -ADD OLD DATA',0054.000
     7/10X,'7. IMIN  <I FOR I(OBS).LE.0> ',10X,'14. OUTP <I>',/         0055.000
     8/10X,'   MENU          --- REPEATS THIS MENU',                    0056.000
     9/10X,'   END   OR <CR> --- STARTS PROCESSING',                    0057.000
     1/10X,'   DOTO  <NREFB> --- PROCESS TO NREFB THEN READ NEW INPUT', 0058.000
     2/10X,'   STOP          --- PROGRAM HALTS IMMEDIATELY'//)          0059.000
  100 READ(LC,110,END=899)LINE                                          0060.000
  110 FORMAT(A61)            
      READ (LINE,120)M1,M2,M3,M4,LCARD          
  120 FORMAT(4A1,14A4,A1)                                               0063.000
      IF(ISW2.EQ.0)GOTO 124                                             0064.000
      ISW2=0                                                            0065.000
      WRITE(LP,1080)                                                    0066.000
  124 WRITE(LP,125)M1,M2,M3,M4,LCARD                                    0067.000
  125 FORMAT(10X,4A1,15A4)                                              0068.000
         IF (M1.EQ.LBLANK) GO TO 899                                    0069.000
      IF(M1.EQ.KE.AND.M2.EQ.KN.AND.M3.EQ.KD)GOTO 899                    0070.000
      IF(M1.EQ.KT.AND.M2.EQ.KI.AND.M3.EQ.KT.AND.M4.EQ.KL)GOTO 130       0071.000
      IF(M1.EQ.KF.AND.M2.EQ.KR.AND.M3.EQ.KA.AND.M4.EQ.KC)GOTO 200       0072.000
      IF(M1.EQ.KB.AND.M2.EQ.KA.AND.M3.EQ.KL.AND.M4.EQ.KF)GOTO 220       0073.000
      IF(M1.EQ.KM.AND.M2.EQ.KI.AND.M3.EQ.KS.AND.M4.EQ.KS)GOTO 230       0074.000
      IF(M1.EQ.KM.AND.M2.EQ.KO.AND.M3.EQ.KN.AND.M4.EQ.KO)GOTO 240       0075.000
      IF(M1.EQ.KA.AND.M2.EQ.KT.AND.M3.EQ.KE.AND.M4.EQ.KN)GOTO 250       0076.000
      IF(M1.EQ.KD.AND.M2.EQ.KO.AND.M3.EQ.KT.AND.M4.EQ.KO)GOTO 260       0077.000
      IF(M1.EQ.KS.AND.M2.EQ.KC.AND.M3.EQ.KA.AND.M4.EQ.KL)GOTO 270       0078.000
      IF(M1.EQ.KF.AND.M2.EQ.KA.AND.M3.EQ.KD.AND.M4.EQ.KE)GOTO 280       0079.000
      IF(M1.EQ.KN.AND.M2.EQ.KS.AND.M3.EQ.KE.AND.M4.EQ.KT)GOTO 290       0080.000
      IF(M1.EQ.KP.AND.M2.EQ.KR.AND.M3.EQ.KI.AND.M4.EQ.KN)GOTO 300       0081.000
      IF(M1.EQ.KP.AND.M2.EQ.KF.AND.M3.EQ.KA.AND.M4.EQ.KC)GOTO 310       0082.000
      IF(M1.EQ.KS.AND.M2.EQ.KK.AND.M3.EQ.KI.AND.M4.EQ.KP)GOTO 320       0083.000
      IF(M1.EQ.KB.AND.M2.EQ.KG.AND.M3.EQ.KI.AND.M4.EQ.KN)GOTO 340       0084.000
      IF(M1.EQ.KP.AND.M2.EQ.KR.AND.M3.EQ.KO.AND.M4.EQ.KF)GOTO 350       0085.000
      IF(M1.EQ.KH.AND.M2.EQ.KK.AND.M3.EQ.KL.AND.M4.EQ.KF)GOTO 360       0086.000
      IF(M1.EQ.KS.AND.M2.EQ.KU.AND.M3.EQ.KP.AND.M4.EQ.KP)GOTO 370       0087.000
      IF(M1.EQ.KW.AND.M2.EQ.KA.AND.M3.EQ.KV.AND.M4.EQ.KL)GOTO 380       0088.000
      IF(M1.EQ.KC.AND.M2.EQ.KE.AND.M3.EQ.KL.AND.M4.EQ.KL)GOTO 390       0089.000
      IF(M1.EQ.KF.AND.M2.EQ.KO.AND.M3.EQ.KR.AND.M4.EQ.KT)GOTO 400       0090.000
      IF(M1.EQ.KC.AND.M2.EQ.KO.AND.M3.EQ.KP.AND.M4.EQ.KY)GOTO 410       0091.000
      IF(M1.EQ.KI.AND.M2.EQ.KM.AND.M3.EQ.KI.AND.M4.EQ.KN)GOTO 420       0092.000
      IF(M1.EQ.KM.AND.M2.EQ.KA.AND.M3.EQ.KT.AND.M4.EQ.KR)GOTO 430       0093.000
      IF(M1.EQ.KR.AND.M2.EQ.KE.AND.M3.EQ.KJ.AND.M4.EQ.KP)GOTO 440       0094.000
      IF(M1.EQ.KD.AND.M2.EQ.KC.AND.M3.EQ.KO.AND.M4.EQ.KS)GOTO 450       0095.000
      IF(M1.EQ.KO.AND.M2.EQ.KU.AND.M3.EQ.KT.AND.M4.EQ.KP)GOTO 460       0096.000
      IF(M1.EQ.KM.AND.M2.EQ.KE.AND.M3.EQ.KN.AND.M4.EQ.KU)GOTO 800       0097.000
      IF(M1.EQ.KS.AND.M2.EQ.KT.AND.M3.EQ.KO.AND.M4.EQ.KP)GOTO 9000      0098.000
 7935 IERR=4                                                            0099.000
      WRITE(LK,9110)IERR,LINE                                           0100.000
      GOTO 9100                                                         0101.000
C*************** TITL ***************                                   0102.000
  130 READ (LINE,'(15A4)') JTITL            
      GOTO 100                                                          0104.000
C*************** FRAC ***************                                   0105.000
  200 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0106.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0107.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),FRAC)                    0108.000
  210 FORMAT(10X,7F10.0)                                                0109.000
      GOTO 100                                                          0110.000
C*************** BALF ***************                                   0111.000
  220 MODE=1                                                            0112.000
      GOTO 100                                                          0113.000
C*************** MISS ***************                                   0114.000
  230 IMISS=1                                                           0115.000
      GOTO 100                                                          0116.000
C*************** MONO ***************                                   0117.000
  240 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0118.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0119.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),TAKE)                    0120.000
      MODE=0                                                            0121.000
      GOTO 100                                                          0122.000
C*************** ATEN ***************                                   0123.000
  250 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0124.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0125.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),ATEN)                    0126.000
      GOTO 100                                                          0127.000
C*************** DOTO ***************                                   0128.000
  260 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0129.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0130.000
      CALL IFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),LIMGO)                   0131.000
  265 FORMAT(10X,5I5)                                                   0132.000
      GOTO 900                                                          0133.000
C*************** SCAL ***************                                   0134.000
  270 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0135.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0136.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),SCALE)                   0137.000
      GOTO 100                                                          0138.000
C*************** FADE ***************                                   0139.000
  280 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0140.000
      IF (NFIELDS.NE.6) GO TO 7935                                      0141.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),Y3)                      0142.000
      CALL FFORMAT(INSTRU,FIRSTCH(3),FWIDTH(3),Y2)                      0143.000
      CALL FFORMAT(INSTRU,FIRSTCH(4),FWIDTH(4),Y1)                      0144.000
      CALL FFORMAT(INSTRU,FIRSTCH(5),FWIDTH(5),XN1)                     0145.000
      CALL FFORMAT(INSTRU,FIRSTCH(6),FWIDTH(6),XN2)                     0146.000
      IXN1=XN1                                                          0147.000
      IXN2=XN2                                                          0148.000
      WRITE(LK,2828)Y3,IXN1,Y2,IXN2,Y1                                  0149.000
 2828 FORMAT(/10X,'DECOMPOSITION CORRECTION',/5X,'AT REFLECTION     1 TH0150.000
     1E INTENSITY IS',F10.4,/5X,'AT REFLECTION',I6,' THE INTENSITY IS', 0151.000
     2F10.4,/5X,'AT REFLECTION',I6,' THE INTENSITY IS',F10.4//)         0152.000
      IFADE=1                                                           0153.000
      GRAD=-(Y2-Y1)/(XN2-XN1)                                           0154.000
      WRITE(LP,285)Y3,GRAD,XN1,Y2                                       0155.000
  285 FORMAT(10X,5HDECO ,E12.5,2H/(,E12.5,8H*(NREFL-,E12.5,2H)+,E12.5,  0156.000
     *1H))                                                              0157.000
      GOTO 100                                                          0158.000
C*************** NSET ***************                                   0159.000
  290 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0160.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0161.000
      CALL IFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),NSET)                    0162.000
      GOTO 100                                                          0163.000
C*************** PRIN ***************                                   0164.000
  300 READ (LINE,265) IPRIN        
      GOTO 100                                                          0166.000
C*************** PFAC ***************                                   0167.000
  310 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0168.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0169.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),QFAC)                    0170.000
      GOTO 100                                                          0171.000
C*************** SKIP **********                                        0172.000
 320  IF (JHKLF.EQ.5) GO TO 5712                                        0173.000
      WRITE(LK,8001)                                                    0174.000
      WRITE(LP,8001)                                                    0175.000
 8001 FORMAT(' YOU CANNOT SKIP WITH NON-STANDARD OUTPUT ********'//)    0176.000
      GOTO 100                                                          0177.000
 5712 NTOT1=0                                                           0178.000
      NTOT2=0                                                           0179.000
      REWIND LHH                                                        0180.000
      REWIND LH                                                         0181.000
  321 READ(LHH,END=322)IH,IK,IL,FF,SS,NREFL,IXRAYT                      0182.000
      NTOT1=NTOT1+1                                                     0183.000
      WRITE(LH)IH,IK,IL,FF,SS,NREFL,IXRAYT                              0184.000
      GOTO 321                                                          0185.000
  322 REWIND LXX                                                        0186.000
      REWIND LX                                                         0187.000
      J=1+6*IDCOS                                                       0188.000
  323 READ(LXX,END=324)JA,JB,FF,(COSINES(I),I=1,J)                      0189.000
      NTOT2=NTOT2+1                                                     0190.000
      WRITE(LX)JA,JB,FF,(COSINES(I),I=1,J)                              0191.000
      GOTO 323                                                          0192.000
  324 WRITE(LP,8002)NTOT1,NTOT2                                         0193.000
 8002 FORMAT(//,10X,' STANDARDS COPIED =   ',I8,                        0194.000
     1/10X,' REFLECTIONS COPIED = ',I8/)                                0195.000
      GOTO 100                                                          0196.000
C*************** BGIN **********                                        0197.000
  340 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0198.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0199.000
      CALL IFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),IBGIN)                   0200.000
      NREFL=IBGIN                                                       0201.000
      GOTO 100                                                          0202.000
C*************** PROF **********                                        0203.000
  350 IPROF=MOD(IPROF+1,2)                                              0204.000
      GOTO 100                                                          0205.000
C*************** HKLF **********                                        0206.000
  360 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0207.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0208.000
      CALL IFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),JHKLF)                   0209.000
C     DEFAULT IS 'HKLF 4'                                               0210.000
      GOTO 100                                                          0211.000
C*************** SUPP **********                                        0212.000
  370 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0213.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0214.000
      CALL IFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),ISUPP)                   0215.000
      ISUPP=ISUPP-1                                                     0216.000
      GOTO 100                                                          0217.000
C*************** WAVL **********                                        0218.000
  380 READ (LINE,210) WAVL      
      GOTO 100                                                          0220.000
C*************** CELL **********                                        0221.000
  390 READ (LINE,210)WAVL,D1,D2,D3,D4,D5,D6   
      D7=COS(DTR*D4)                                                    0223.000
      D8=COS(DTR*D5)                                                    0224.000
      D9=COS(DTR*D6)                                                    0225.000
      D10=SIN(DTR*D4)                                                   0226.000
      D11=SIN(DTR*D5)                                                   0227.000
      D12=SIN(DTR*D6)                                                   0228.000
      VOL=D1*D2*D3*SQRT(1.-D7*D7-D8*D8-D9*D9+2.*D7*D8*D9)               0229.000
      R1=D2*D3*D10/VOL                                                  0230.000
      R2=D1*D3*D11/VOL                                                  0231.000
      R3=D1*D2*D12/VOL                                                  0232.000
      R7=(D8*D9-D7)/(D11*D12)                                           0233.000
      R8=(D7*D9-D8)/(D10*D12)                                           0234.000
      R9=(D7*D8-D9)/(D10*D11)                                           0235.000
      R4=RTD*ACOS(R7)                                                   0236.000
      R5=RTD*ACOS(R8)                                                   0237.000
      R6=RTD*ACOS(R9)                                                   0238.000
      GOTO 100                                                          0239.000
C*************** FORT **********                                        0240.000
  400 IFORT=1                                                           0241.000
      GOTO 100                                                          0242.000
C*************** COPY **********                                        0243.000
  410 ICOPY=1                                                           0244.000
      GOTO 100                                                          0245.000
C*************** IMIN **********                                        0246.000
  420 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0247.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0248.000
      CALL FFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),XIMIN)                   0249.000
      GOTO 100                                                          0250.000
C*************** MATR **********                                        0251.000
  430 READ (LINE,432) (A(I),I=1,9)       
  432 FORMAT(10X,9F10.0)                                                0253.000
      DO 433 I=1,9                                                      0254.000
      A(I)=A(I)*0.00001                                                 0255.000
  433 CONTINUE                                                          0256.000
      GOTO 100                                                          0257.000
C*************** REJP **********                                        0258.000
  440 IREJP=MOD(IREJP+1,2)                                              0259.000
      GOTO 100                                                          0260.000
C*************** DCOS **********                                        0261.000
  450 IDCOS=MOD(IDCOS+1,2)                                              0262.000
      GOTO 100                                                          0263.000
C*************** OUTP **********                                        0264.000
  460 CALL PARSE(INSTRU,NFIELDS,FIRSTCH,FWIDTH)                         0265.000
      IF (NFIELDS.NE.2) GO TO 7935                                      0266.000
      CALL IFORMAT(INSTRU,FIRSTCH(2),FWIDTH(2),IOUTP)                   0267.000
      IF(IOUTP.EQ.0)IOUTP=1                                             0268.000
      GOTO 100                                                          0269.000
C*********************************                                      0270.000
C                                                                       0271.000
C     NOW LIST SELECTED OPTIONS                                         0272.000
C                                                                       0273.000
C*********************************                                      0274.000
  900 WRITE(LP,910)                                                     0275.000
  910 FORMAT(10X,3HEND,/,1X,110(1H-))                                   0276.000
      ISW2=1                                                            0277.000
C                                                                       0278.000
  899 WRITE(LP,8010)JTITL,NSET,SCALE,QFAC,ATEN,IBGIN,LIMGO,XIMIN        0279.000
      WRITE(LP,8011)NOYES(IREJP),NOYES(IPROF),NOYES(IDCOS)              0280.000
      IF(JHKLF.NE.5)WRITE(LP,8012)                                      0281.000
      IF(MODE.EQ.0)GOTO 880                                             0282.000
      WRITE(LP,8013)                                                    0283.000
      GOTO 8899                                                         0284.000
  880 TOOK=ABS(TAKE)                                                    0285.000
      WRITE(LP,8014)TOOK                                                0286.000
      IF(TAKE.LT.-0.1)WRITE(LP,8016)                                    0287.000
      IF(TAKE.GT.  .1)WRITE(LP,8015)                                    0288.000
 8010 FORMAT(/                            /,10X,15A4,//10X,'SCALE FACTOR0289.000
     1 NUMBER =',I4,' SCALE FACTOR = ',F9.5,//10X,'PFAC = ',F6.4,10X,'AT0290.000
     2TENUATOR FACTOR = ',F7.4,//10X,'PROCESS FROM NREF = ',I8,' TO',I9,0291.000
     3 ' INCLUSIVE',//10X,'INTENSITY ASSIGNED WHEN I.LE.0 = ',7X,F10.4/)0292.000
 8011 FORMAT( 10X,'CALL REJECT PATCH -----',A6,//10X,'EXPECT PROFILES   0293.000
     1-----',A6,//10X,'WRITE COSINES ---------',A6/)                    0294.000
 8012 FORMAT(10X,'NON STANDARD OUTPUT FILES '/)                         0295.000
 8013 FORMAT(10X,'BALANCED FILTERS USED '/)                             0296.000
 8014 FORMAT(10X,'MONOCHROMATOR THETA ANGLE IN DEGREES = ',F7.4/)       0297.000
 8015 FORMAT(10X,'IDEALLY IMPERFECT MONOCHROMATOR',/)                   0298.000
 8016 FORMAT(10X,'PERFECT MONOCHROMATOR CRYSTAL ',/)                    0299.000
 8899 IHKLF=IABS(JHKLF)-3                                               0300.000
      IF(JHKLF.LT.0)ICARD=1                                             0301.000
      PFAC=QFAC*QFAC                                                    0302.000
      C2=COS(2.*ABS(TAKE)*DTR)                                          0303.000
      IF(TAKE)241,242,242                                               0304.000
  241 C2=ABS(C2)                                                        0305.000
      GOTO 243                                                          0306.000
  242 C2=C2*C2                                                          0307.000
  243 C3=1.+C2                                                          0308.000
C TRANSFER NEXT TAPE RECORD TO BUFFER                                   0309.000
C                                                                       0310.000
 1040 READ(LT,'(1X,A61)',END=1060,ERR=7812)LINE      
      READ (LINE,1050,ERR=7812) NF  
 1050 FORMAT(1X,I2)                                                     0322.000
      N1=1+NF/10                                                        0323.000
      N2=NF-(N1-1)*10                                                   0324.000
      GOTO(4000,4000,1070,1070),N1                                      0325.000
 1055 IERR=2                                                            0326.000
      GOTO 9100                                                         0327.000
 1060 IEND=1                                                            0328.000
      GOTO 9000                                                         0329.000
 1070 IF(ISW1)1071,1090,1071                                            0330.000
 1071 ISW1=0                                                            0331.000
      WRITE(LP,1080)                                                    0332.000
 1080 FORMAT(1X,110(1H-))                                               0333.000
      BACKSPACE LT                                                      0334.000
      GOTO 4400                                                         0335.000
 7812 WRITE (LP,7811) LINE                                              0336.000
 7811 FORMAT (' ***** INPUT ERROR ',A61)              
      GO TO 1040                                                        0338.000
 1090 GOTO(1055,1055,2000,3000),N1                                      0339.000
C                                                                       0340.000
C DATA COLLECTION PARAMETERS                                            0341.000
C                                                                       0342.000
 2000 GOTO(2100,2200,2300,2400,2500,2600),N2                            0343.000
      IERR=3                                                            0344.000
      GOTO 9100                                                         0345.000
 2100 READ (LINE,2110)IJUNK,ITEXT,IRADIUS,SLIT,APMIN,APMAX     
      WRITE(LP,2120)ITEXT,IRADIUS,SLIT,APMIN,APMAX                      0347.000
 2110 FORMAT(3X,I6,9A4,I4,3F4.1)                                        0348.000
 2120 FORMAT(10X,6HTEXT  ,3X,9A4,/,10X,6HRADIUS,3X,I4,/,10X,6HSLIT,     0349.000
     *3X,F4.1,/,10X,6HAPMIN ,3X,F4.1,/,10X,6HAPMAX ,3X,F4.1)            0350.000
      GOTO 1040                                                         0351.000
 2200 READ (LINE,2210)DTHMIN,DTHMAX,DOMA,DOMB,APTA,APTB,ISCANT,   
     *SIGPRE,SIGMA,NPIPRE,ITMAX,IDUMPF,NBALF,NFRIDL                     0353.000
 2210 FORMAT(3X,2F6.2,4F5.2,I2,2F6.3,I2,I4,3I2)                         0354.000
      WRITE(LP,2220)DTHMIN,DTHMAX,DOMA,DOMB,APTA,APTB,ISCANT,SIGPRE,SIGM0355.000
     *A,NPIPRE,ITMAX,IDUMPF,NBALF,NFRIDL                                0356.000
 2220 FORMAT(10X,6HDTHMIN,2X,F6.2,/,10X,6HDTHMAX,2X,F6.2,/,10X,6HDOMA  ,0357.000
     *3X,F5.2,/,10X,6HDOMB  ,3X,F5.2,/,10X,6HAPTA  ,3X,F5.2,/,10X,6HAPTB0358.000
     *  ,3X,F5.2,/,10X,6HISCANT,3X,I2,/,10X,6HSIGPRE,3X,F6.3,/,10X,6HSIG0359.000
     *MA ,3X,F6.3,/,10X,6HNPIPRE,3X,I2,/,10X,6HITMAX ,3X,I4,/,10X,6HIDUM0360.000
     *PF,3X,I2,/,10X,6HNBALF ,3X,I2,/,10X,6HNFRIDL,3X,I2)               0361.000
      IF(NBALF.EQ.0.AND.MODE.EQ.0)GOTO 1040                             0362.000
      IF(NBALF.NE.0.AND.MODE.NE.0)GOTO 1040                             0363.000
      IERR=12                                                           0364.000
      GOTO 9100                                                         0365.000
 2300 READ (LINE,2310)NEQFL,NPSIFL,NRPSI,PSIST,DELPSI,DVECT     
 2310 FORMAT(3X,I2,1X,A4,A2,I5,2F7.2,3F10.6)                            0367.000
      WRITE(LP,2320)NEQFL,NPSIFL,NRPSI,PSIST,DELPSI,DVECT               0368.000
 2320 FORMAT(10X,6HNEQFL  ,3X,I2/10X,6HNPSIFL,4X,A4,A2/10X,6HNRPSI ,3X, 0369.000
     *I5,/,10X,6HPSIST ,3X,F7.2,/,10X,6HDELPSI,3X,F7.2,/,10X,6HDVECT ,  0370.000
     *2X,3F10.6)                                                        0371.000
      GOTO 1040                                                         0372.000
 2400 READ (LINE,2410)NSEQ,NFMS,IZZH,IHMIN,IHMAX,IZZK,KMIN,KMAX,  
     *IZZL,LMIN, LMAX                                                   0374.000
 2410 FORMAT(4X,A4,A2,2X,A4,9I5)                                        0375.000
      WRITE(LP,2420)NSEQ,NFMS,IZZH,IHMIN,IHMAX,IZZK,KMIN,KMAX,IZZL,LMIN,0376.000
     *LMAX                                                              0377.000
 2420 FORMAT(10X,4HNSEQ,6X,A4,A2/,10X,6HNFMS  ,4X,A4,/,10X,6HZZH   ,2X, 0378.000
     *I5,/,10X,6HHMIN  ,2X,I5,/,10X,6HHMAX  ,2X,I5,/,10X,6HZZK   ,2X,I5,0379.000
     */,10X,6HKMIN  ,2X,I5,/,10X,6HKMAX  ,2X,I5,/,10X,6HZZL   ,2X,I5,/, 0380.000
     *10X,6HLMIN  ,2X,I5,/,10X,6HLMAX  ,2X,I5)                          0381.000
      GOTO 1040                                                         0382.000
 2500 READ (LINE,2510)NABS,((LABS(I,J),I=1,3),J=1,6)    
 2510 FORMAT(3X,I2,1X,9I3,1X,9I3)                                       0384.000
      WRITE(LP,2520)NABS,((LABS(I,J),I=1,3),J=1,6)                      0385.000
 2520 FORMAT(10X,6HNABS  ,3X,I2,/,10X,6HLABS  ,3X,3I3,5(/,19X,3I3))     0386.000
      GOTO 1040                                                         0387.000
 2600 READ (LINE,2610)ICHKT,SIGMI,FADING,NORCHK,DANG,CON1,CON2,  
     *IXRAYT                                                            0389.000
 2610 FORMAT(3X,I7,F7.3,F6.3,I5,F6.3,2F10.7,I7)                         0390.000
      WRITE(LP,2620)ICHKT,SIGMI,FADING,NORCHK,DANG,CON1,CON2,IXRAYT     0391.000
 2620 FORMAT(10X,6HICHKT ,2X,I7,/,10X,6HSIGMI ,2X,F7.3,/,10X,6HFADING,3X0392.000
     *,F6.3,/,10X,6HNORCHK,4X,I5,/,10X,6HDANG  ,3X,F6.3,/,10X,6HCON1  , 0393.000
     *3X,F10.7,/,10X,6HCON2  ,3X,F10.7,/,10X,6HXRAYT ,2X,I7)            0394.000
      GOTO 1040                                                         0395.000
C                                                                       0396.000
C ORIENTATION MATRIX AND WAVELENGTH VALUES                              0397.000
C                                                                       0398.000
 3000 GOTO(3100,3200),N2                                                0399.000
      IERR=6                                                            0400.000
      GOTO 9100                                                         0401.000
 3100 READ (LINE,3110)((R(J,I),J=1,3),I=1,2)       
 3110 FORMAT(3X,2(2X,3F9.6))                                            0403.000
      IRCK=IRCK+1                                                       0404.000
      GOTO 3300                                                         0405.000
 3200 READ (LINE,3110)(R(J,3),J=1,3),FLAM1,FLAM2,BETA 
      IRCK=IRCK+1                                                       0407.000
 3300 GOTO(1040,1040,3400),IRCK                                         0408.000
      IERR=7                                                            0409.000
      GOTO 9100                                                         0410.000
 3400 DO 3410 I=1,3                                                     0411.000
      DO 3410 J=1,3                                                     0412.000
      AM(I,J)=0.                                                        0413.000
      DO 3410 K=1,3                                                     0414.000
 3410 AM(I,J)=AM(I,J)+R(I,K)*R(J,K)                                     0415.000
      WRITE(LP,3420)FLAM1,FLAM2,BETA,((R(J,I),J=1,3),I=1,3),((AM(I,J),J=0416.000
     *1,3),I=1,3)                                                       0417.000
 3420 FORMAT(10X,6HFLAM1 ,3X,F9.6,/,10X,6HFLAM2 ,3X,F9.6,/,10X,6HBETA  ,0418.000
     *3X,F9.6,//10X,6HR     ,3X,3F9.6,2(/,19X,3F9.6),//,10X,6HMETRIC,3X,0419.000
     *3F9.6,2(/,19X,3F9.6),/)                                           0420.000
      R1=SQRT(AM(1,1))                                                  0421.000
      R2=SQRT(AM(2,2))                                                  0422.000
      R3=SQRT(AM(3,3))                                                  0423.000
      R7=AM(2,3)/(R2*R3)                                                0424.000
      R8=AM(1,3)/(R1*R3)                                                0425.000
      R9=AM(1,2)/(R1*R2)                                                0426.000
      VOL=1./(R1*R2*R3*SQRT(1.-R7*R7-R8*R8-R9*R9+2.*R7*R8*R9))          0427.000
      R4=RTD*ACOS(R7)                                                   0428.000
      R5=RTD*ACOS(R8)                                                   0429.000
      R6=RTD*ACOS(R9)                                                   0430.000
      R10=SIN(DTR*R4)                                                   0431.000
      R11=SIN(DTR*R5)                                                   0432.000
      R12=SIN(DTR*R6)                                                   0433.000
      D1=R2*R3*R10*VOL                                                  0434.000
      D2=R1*R3*R11*VOL                                                  0435.000
      D3=R1*R2*R12*VOL                                                  0436.000
      D7=(R8*R9-R7)/(R11*R12)                                           0437.000
      D8=(R7*R9-R8)/(R10*R12)                                           0438.000
      D9=(R7*R8-R9)/(R10*R11)                                           0439.000
      D4=RTD*ACOS(D7)                                                   0440.000
      D5=RTD*ACOS(D8)                                                   0441.000
      D6=RTD*ACOS(D9)                                                   0442.000
      WRITE(LP,3430)D1,D2,D3,D4,D5,D6,R1,R2,R3,R4,R5,R6                 0443.000
 3430 FORMAT(10X,6HCELL  ,3X,3F9.4,3F9.3/,19X,3F9.6,3F9.3)              0444.000
      IRCK=1                                                            0445.000
      DTTMIN=1.0                                                        0446.000
      DTTMAX=32.0                                                       0447.000
      IF(WAVL.GT.1.0)DTTMAX=90.                                         0448.000
      TLIM(0)=DTTMIN                                                    0449.000
      ST0=SIN(DTTMIN*DTR)                                               0450.000
      STN=SIN(DTTMAX*DTR)                                               0451.000
      ST0=ST0*ST0*ST0                                                   0452.000
      STN=(STN*STN*STN-ST0)/15.                                         0453.000
      DO 2229 I=1,15                                                    0454.000
      SSS=ST0+FLOAT(I)*STN                                              0455.000
 2229 TLIM(I)=ASIN(EXP(ALOG(SSS)/3.))/DTR                               0456.000
      GOTO 1040                                                         0457.000
C                                                                       0458.000
C REFLECTION DATA                                                       0459.000
C                                                                       0460.000
 4000 IF(NF)4040,4001,4040                                              0461.000
 4001 READ (LINE,4020)LISTNR,IH,IK,IL,ISTATUS,RTHETA,RPHIK,ROMK,   
     *RKAPPA,    IRNPI,RSCANG,IRSCINT                                   0463.000
 4020 FORMAT(3X,I2,3I3,6A1,F6.2,3F7.2,I3,F5.2,I6)                       0464.000
      WRITE(LP,4030)LISTNR,IH,IK,IL,ISTATUS,RTHETA,RPHIK,ROMK,RKAPPA,   0465.000
     *IRNPI,RSCANG,IRSCINT                                              0466.000
 4030 FORMAT(10X,7HREFDUMP,I3,3I4,3X,6A1,2X,F6.2,3F7.2,I3,F5.2,I6)      0467.000
      GOTO 1040                                                         0468.000
 4040 READ (LINE,4101)NREFX              
      IF(NREFX-IBGIN)1040,4045,4045                                     0470.000
 4045 IF(NREFX-NREFL)4400,4050,4400                                     0471.000
 4050 GOTO(4100,4200,4300,4300,4300,4300,4300,4300,4300,4300),NF        0472.000
      IERR=8                                                            0473.000
      GOTO 9100                                                         0474.000
 4100 IT1=1                                                             0475.000
      IT4=0                                                             0476.000
      READ(LINE,4101)NREFL,IH,IK,IL,ISTATUS,PSI,NPI,IBGL,INT,IBGR 
 4101 FORMAT(3X,I6,3I5,1X,6A1,F7.2,I4,I6,I7,I6)                         0478.000
      LS=1                                                              0479.000
      JCODE=1                                                           0480.000
      IF(ISTATUS(1).EQ.KN)GOTO 4102                                     0481.000
      JSTATUS(LS)=KI                                                    0482.000
      KNT(1)=KNT(1)+1                                                   0483.000
      LS=LS+1                                                           0484.000
      IF(IMISS.EQ.1)MISS=1                                              0485.000
 4102 IF(ISTATUS(2).EQ.LSTAR)GOTO 4103                                  0486.000
      JSTATUS(LS)=ISTATUS(2)                                            0487.000
      IF(ISTATUS(2).EQ.KD)KNT(7)=KNT(7)+1                               0488.000
      IF(ISTATUS(2).NE.KD)KNT(13)=KNT(13)+1                             0489.000
      LS=LS+1                                                           0490.000
 4103 IF(ISTATUS(4).EQ.LSTAR)GOTO 4104                                  0491.000
      JSTATUS(LS)=ISTATUS(4)                                            0492.000
      KNT(2)=KNT(2)+1                                                   0493.000
      LS=LS+1                                                           0494.000
      IF(ISTATUS(4).NE.KW)GOTO 9003                                     0495.000
      JCODE=2                                                           0496.000
      GO TO 4104                                                        0497.000
9003      IF(ISTATUS(4).EQ.KS)KNT(8)=KNT(8)+1                           0498.000
      IF(ISTATUS(4).EQ.KT)KNT(9)=KNT(9)+1                               0499.000
      KNT(2)=KNT(2)-1                                                   0500.000
 4104 IF(ISTATUS(5).NE.NUMB(2))GOTO 4105                                0501.000
      JSTATUS(LS)=KF                                                    0502.000
      KNT(10)=KNT(10)+1                                                 0503.000
      LS=LS+1                                                           0504.000
 4105 IF(ISTATUS(6).EQ.LSTAR.OR.ISTATUS(6).EQ.NUMB(10))GOTO 4106        0505.000
      JSTATUS(LS)=KC                                                    0506.000
      KNT(6)=KNT(6)+1                                                   0507.000
      LS=LS+1                                                           0508.000
 4106 IF(NPI)4107,4108,4108                                             0509.000
 4107 JSTATUS(LS)=KA                                                    0510.000
      KNT(4)=KNT(4)+1                                                   0511.000
      LS=LS+1                                                           0512.000
 4108 IF(ISW1-1)4109,4111,4109                                          0513.000
 4109 ISW1=1                                                            0514.000
      WRITE(LP,4110)                                                    0515.000
 4110 FORMAT(1X,110(1H-)///14X,1HH,3X,1HK,3X,1HL,4X,4HFREL,4X,4HSIGF,3X,0516.000
     *4HNREF,3X                                                         0517.000
     *      ,2HBL,4X,3HINT,4X,2HBR,3X,5HTHETA,4X,1HT,4X,4H1/LP,6X,3HDEC,0518.000
     *6X,5HXRAYT,2X,'JCODE',3X,4HNSET,/)                                0519.000
 4111 IF(IPRIN)4112,1040,4112                                           0520.000
 4112 WRITE(LP,4115)LINE                                                0521.000
 4115 FORMAT(27X,A61)                       
      GOTO 1040                                                         0523.000
 4200 READ (LINE,4210)NREFL,THETA,PHIK,OMK,XKAPPA,WIDTH,IXRAYT,  
     *IFRIDL                                                            0525.000
 4210 FORMAT(3X,I6,F8.3,3F9.3,F7.3,I7,I3)                               0526.000
      IT2=1                                                             0527.000
      IF(IPRIN)4215,1040,4215                                           0528.000
 4215 WRITE(LP,4115)LINE                                                0529.000
      GOTO 1040                                                         0530.000
 4300 IF(IPROF)4301,1040,4301                                           0531.000
 4301 I1=(NF-3)*12+1                                                    0532.000
      I2=I1+11                                                          0533.000
      READ (LINE,4305)(JD(I),I=I1,I2)      
 4305 FORMAT(9X,4(1X,3A4))                                              0535.000
      DO 4306 I=I1,I2                                                   0536.000
 4306 IF(JD(I).EQ.IOV)IT4=IT4+1                                         0537.000
      IF(IT4)4309,4309,4315                                             0538.000
 4309 READ (LINE,4310)NREFL,(JD(I),I=I1,I2)                 
 4310 FORMAT(3X,I6,4(1X,3I4))                                           0540.000
      IT3=1                                                             0541.000
 4315 NLD=NLD+1                                                         0542.000
      IF(IPRIN)4316,1040,4316                                           0543.000
 4316 WRITE(LP,4115)LINE                                                0544.000
      GOTO 1040                                                         0545.000
C                                                                       0546.000
C CHECK REFLECTION DATA INPUT                                           0547.000
C                                                                       0548.000
 4400 IF(IT1)4401,4401,4410                                             0549.000
 4401 IERR=9                                                            0550.000
      GOTO 9100                                                         0551.000
 4410 IF(IT3)4411,4460,4411                                             0552.000
 4411 IF(IT4)4412,4415,4412                                             0553.000
 4412 JSTATUS(LS)=KO                                                    0554.000
      LS=LS+1                                                           0555.000
      GOTO 4460                                                         0556.000
 4415 IF(NLD-8)4416,4420,4416                                           0557.000
 4416 IERR=10                                                           0558.000
      GOTO 9100                                                         0559.000
 4420 JBGL=0                                                            0560.000
      JINT=0                                                            0561.000
      JBGR=0                                                            0562.000
      DO 4430 I=1,16                                                    0563.000
 4430 JBGL=JBGL+JD(I)                                                   0564.000
      DO 4440 I=17,80                                                   0565.000
 4440 JINT=JINT+JD(I)                                                   0566.000
      DO 4450 I=81,96                                                   0567.000
 4450 JBGR=JBGR+JD(I)                                                   0568.000
      IF(JBGL-IBGL)4453,4451,4453                                       0569.000
 4451 IF(JINT-INT)4453,4452,4453                                        0570.000
 4452 IF(JBGR-IBGR)4453,4454,4453                                       0571.000
 4453 IERR=11                                                           0572.000
      GOTO 9100                                                         0573.000
 4454 IF(IPROF.LE.1)GOTO 4460                                           0574.000
      CALL PROFILE(JD,IBGL,IBGR,IPROF)                                  0575.000
 4460 IF(NBALF)5000,5000,4470                                           0576.000
 4470 IPCK1=IH*10000+IK*100+IL                                          0577.000
      IPCK2=JH*10000+JK*100+JL                                          0578.000
      IF(IPCK1-IPCK2)4471,4490,4471                                     0579.000
 4471 IF(ISTATUS(3).EQ.KA)KBALF=1                                       0580.000
      IF(ISTATUS(3).EQ.KB)KBALF=2                                       0581.000
      JH=IH                                                             0582.000
      JK=IK                                                             0583.000
      JL=IL                                                             0584.000
      LBGL=IBGL                                                         0585.000
      LINT=INT                                                          0586.000
      LBGR=IBGR                                                         0587.000
      IT1=0                                                             0588.000
      IT2=0                                                             0589.000
      IT3=0                                                             0590.000
      NREFL=NREFX                                                       0591.000
      GOTO 4040                                                         0592.000
 4490 IF(ISTATUS(3).EQ.KA)KBALF=KBALF+1                                 0593.000
      IF(ISTATUS(3).EQ.KB)KBALF=KBALF+2                                 0594.000
      IF(KBALF-3)4495,4500,4495                                         0595.000
 4495 IT1=0                                                             0596.000
      IT2=0                                                             0597.000
      IT3=0                                                             0598.000
      NREFL=NREFX                                                       0599.000
      IERR=13                                                           0600.000
      GOTO 9100                                                         0601.000
 4500 IBGL=IABS(IBGL-LBGL)                                              0602.000
      INT=IABS(INT-LINT)                                                0603.000
      IBGR=IABS(IBGR-LBGR)                                              0604.000
C                                                                       0605.000
C LP AND SCALE FACTORS                                                  0606.000
C                                                                       0607.000
 5000 IF (NPI.EQ.0) THEN                                                1FEB91
        WRITE (LP,1735) NREFL,IH,IK,IL,ISTATUS                          1FEB91
 1735   FORMAT (' ZERO COUNTING TIME, NREF =',I10,'  (hkl) =',3I5,      1FEB91
     1  'FLAGS =',6A1)                                                  1FEB91
         GO TO 6000                                                     1FEB91
      ENDIF                                                             1FEB91
      XNPI=FLOAT(IABS(NPI))                                             1FEB91
      IF(IT2)5007,5003,5007                                             0609.000
 5003 AH=FLOAT(IH)                                                      0610.000
      AK=FLOAT(IK)                                                      0611.000
      AL=FLOAT(IL)                                                      0612.000
      TX=AH*AH*R1*R1+AK*AK*R2*R2+AL*AL*R3*R3+2.*AH*AK*R1*R2*R9          0613.000
     *+2.*AH*AL*R1*R3*R8+2.*AK*AL*R2*R3*R7                              0614.000
      IF(TX)5004,5005,5005                                              0615.000
 5004 TX=0.                                                             0616.000
      IERR=14                                                           0617.000
      GOTO 9100                                                         0618.000
 5005 TX=.5*WAVL*SQRT(TX)                                               0619.000
      IF(TX.LE.1.0)GOTO 5006                                            0620.000
      IERR=14                                                           0621.000
      GOTO 9100                                                         0622.000
 5006 THETA=ASIN(TX)*RTD                                                0623.000
 5007 TX=2.*ABS(THETA)*DTR                                              0624.000
      C1=COS(TX)                                                        0625.000
      TY=C2+C1*C1                                                       0626.000
      RLP=SIN(TX)*C3/TY                                                 0627.000
      XINT=FLOAT(INT)                                                   0628.000
      BACK=FLOAT(IBGL+IBGR)                                             0629.000
      OBSI=XINT-BACK-BACK                                               0630.000
C NEW REPLACES NREFL HERE 6DEC93
         NEW=NEW+1                                                      0662.000
      DEC=Y3/(GRAD*(FLOAT(NEW)-XN1)+Y2)                                 0631.000
      SCL=RLP*SCALE*DEC/XNPI                          
      IF(NPI)5400,5500,5500                                             0633.000
 5400 SCL=SCL*ATEN                                                      0634.000
 5500 XOBSI=OBSI*SCL                                                    0635.000
C***********************SHELX ******************************************
      IHS=IH
      IKS=IK
      ILS=IL
      FSQS=XOBSI
      SIGS=SCL*SQRT(XINT+4.0*BACK+PFAC*OBSI*OBSI)
      IF (ISTATUS(1).EQ.KI) GO TO 6666
      IF(ILIM(1,1).GT.IH)ILIM(1,1)=IH
      IF(ILIM(2,1).GT.IK)ILIM(2,1)=IK
      IF(ILIM(3,1).GT.IL)ILIM(3,1)=IL
      IF(ILIM(1,2).LT.IH)ILIM(1,2)=IH
      IF(ILIM(2,2).LT.IK)ILIM(2,2)=IK
      IF(ILIM(3,2).LT.IL)ILIM(3,2)=IL
      IF(SLIM(1,1).GT.FSQS)SLIM(1,1)=FSQS
      IF(SLIM(1,2).LT.FSQS)SLIM(1,2)=FSQS
      IF(SLIM(2,1).GT.THETA)SLIM(2,1)=THETA
      IF(SLIM(2,2).LT.THETA)SLIM(2,2)=THETA
      TURN=DOMA+DOMB*TAN(DTR*THETA)
      AHOR=APTA+APTB*TAN(DTR*THETA)
      IF(SLIM(3,1).GT.TURN)SLIM(3,1)=TURN
      IF(SLIM(3,2).LT.TURN)SLIM(3,2)=TURN
      IF(SLIM(4,1).GT.AHOR)SLIM(4,1)=AHOR
      IF(SLIM(4,2).LT.AHOR)SLIM(4,2)=AHOR
 6666 CONTINUE
C**********************************************************************
      IF(XOBSI)5550,5550,5556                                           0636.000
 5550 XOBSI=XIMIN*SCL*XNPI                                              0637.000
      FREL=SQRT(XOBSI)                                                  0638.000
      SIGI=5.*XOBSI                                                     0639.000
      SIGF=5.*FREL                                                      0640.000
      DO 5555 I=1,LS                                                    0641.000
      IF(JSTATUS(I).NE.KW)GOTO 5555                                     0642.000
      JSTATUS(I)=KU                                                     0643.000
C     KNT(2)=KNT(2)-1                                                   0644.000
      KNT(3)=KNT(3)+1                                                   0645.000
      GOTO 5560                                                         0646.000
 5555 CONTINUE                                                          0647.000
      JSTATUS(LS)=KU                                                    0648.000
      KNT(3)=KNT(3)+1                                                   0649.000
      JCODE=2                                                           0650.000
      LS=LS+1                                                           0651.000
      GOTO 5560                                                         0652.000
C     XOBSI IS FSQUARED                                                 0653.000
C     SIGI IS SIGMA(FSQUARED)                                           0654.000
 5556 FREL=SQRT(XOBSI)                                                  0655.000
      SIGI=XINT+4.*BACK+PFAC*OBSI*OBSI                                  0656.000
      SIGI=SQRT(SIGI)*SCL                                               0657.000
      SIGF=.5*SIGI/FREL                                                 0658.000
 5560 IF(ISUPP)5570,5562,5562                                           0659.000
 5562 IF(XOBSI-FRAC*SIGI)5563,5570,5570                                 0660.000
 5563 JCODE=2                                                           0661.000
5570      NREFPR=NREFL*10  
         IPRINT=0                                                       0663.000
         XRAYT=FLOAT(IXRAYT)/3600.0                                     0664.000
         IF(MOD(NREFL,IOUTP).EQ.0)IPRINT=1                              0665.000
         IF(ISTATUS(4).EQ.'S'.OR.ISTATUS(4).EQ.'T'.OR.NPI.LT.0)IPRINT=1 0666.000
         IF(ISTATUS(5).EQ.'2')IPRINT=1                                  0667.000
         IF(FREL.GT.5.0*SIGF.AND.ISTATUS(2).NE.'*')IPRINT=1             0668.000
      IF(IREJP.EQ.1)CALL REJECT(IH,IK,IL,ISTATUS,NREFL,MISS)            0669.000
      IF (MISS.EQ.0) GO TO 5002                                         0670.000
      JSTATUS(9)=LSTAR                                                  0671.000
      JSTATUS(LS)=KR                                                    0672.000
      KNT(5)=KNT(5)+1                                                   0673.000
 5002   IF (NREFL.LE.15.OR.IPRINT.EQ.1)                                 0674.000
     1WRITE(LP,5600)JSTATUS,IH,IK,IL,FREL,SIGF,NREFL,IBGL,INT,IBGR,THETA0675.000
     *,NPI,RLP,DEC,XRAYT,NEW  ,NSET                                     0676.000
 5600 FORMAT(2X,9A1,3I4,F8.2,F8.2,I7,I6 ,I7,I6,F8.2,I5,F9.4,2F9.4,I7,I4)0677.000
      IF(MISS)5601,5602,5601                                            0678.000
 5601    IF (ISTATUS(1).NE.KI) GO TO 6000                               0679.000
         SS=2.*SIGF*FREL                                                0680.000
         FS=FREL*FREL                                                   0681.000
         WRITE (LH)IH,IK,IL,FS,SS,NEW,IXRAYT                            0682.000
C         WRITE (LH,5622)IH,IK,IL,FS,SS,NREFL,IXRAYT                    682.000
C 5622   FORMAT(3I4,2F8.2,2I10) 
        GO TO 6000                                                      0683.000
 5602 IF(IHKLF)5705,5700,5800                                           0684.000
C                                                                       0685.000
C 'HKLF 3' AND 'HKLF 2' OUTPUT FOR XRAY (FORMATTED FILE 14)             0686.000
C                                                                       0687.000
 5705 IF (JCODE.EQ.2) GO TO 6000                                        0688.000
 5700 CALL LEADZO(8,NREFPR,ISEQU1)                                      0689.000
      WRITE(LD,5710)COMPID,IH,IK,IL,JCODE,NSET,FREL,SIGF,ISEQU1         0690.000
 5710 FORMAT(3HHKL,4X,A6,3I3,3X,2I3,F9.2,9X,F5.2,18X,8I1)               0691.000
      KNT(11)=KNT(11)+1                                                 0692.000
      GOTO 6000                                                         0693.000
C                                                                       0694.000
C 'HKLF 4' OUTPUT FOR SHELX AND MULTAN (UNFORMATTED FILE 1)             0695.000
C     'HKLF -4' GIVES FILE 1 AND FILE 14 FOR SHELX                      0696.000
C                                                                       0697.000
 5800 T=.5*FREL/SIGF                                                    0698.000
      CALL ANB(T,IH,IK,IL,FREL)                                         0699.000
      I=0                                                               0700.000
 5802 I=I+1                                                             0701.000
      IF(THETA.LT.TLIM(I).OR.I.EQ.15)GOTO 5803                          0702.000
      GOTO 5802                                                         0703.000
 5803 CALL ANA(34+I,T,FREL)                                             0704.000
 5801 CALL DCOSN(IH,IK,IL,FREL,SIGF,THETA,PHIK,OMK,XKAPPA,CON1,CON2,R,  0705.000
     1NSET,JCODE-1,LD,LX,KNT,ICARD,IHKLF,IDCOS,NREFL,IXRAYT)            0706.000
 6000 NLD=0                                                             0707.000
      IT1=0                                                             0708.000
      IT2=0                                                             0709.000
      IT3=0                                                             0710.000
      MISS=0                                                            0711.000
      NREFL=NREFX                                                       0712.000
      DO 6990 I=1,9                                                     0713.000
 6990 JSTATUS(I)=LBLANK                                                 0714.000
      IF(ISW1-1)6991,6995,6991                                          0715.000
 6991 NREFL=NREFL+1                                                     0716.000
      GOTO 1040                                                         0717.000
 6995 IF(IEND-1)6996,9000,6996                                          0718.000
 6996 IF(NREFL-LIMGO)4040,4040,6997                                     0719.000
 6997 BACKSPACE LT                                                      0720.000
      GOTO 100                                                          0721.000
C                                                                       0722.000
C END OF JOB                                                            0723.000
C                                                                       0724.000
 9000 IF (IHKLF.LE.0) GO TO 9013                                        0725.000
      ENDFILE LX                                                        0726.000
      IF (ICARD) 9020,9020,9015                                         0727.000
 9013 CALL LEADZO(8,NREFPR+10,ISEQU1)                                   0728.000
      WRITE(LD,9010)ISEQU1                                              0729.000
 9010 FORMAT (5HFILES,3X,1H5,63X,8I1)                                   0730.000
 9015      ENDFILE LD                                                   0731.000
 9020 WRITE(LP,9030)(KNT(I),I=1,10),KNT(13)                             0732.000
 9030 FORMAT(1X,110(1H-),//10X,1HI,I7,X,' INTENSITY STANDARDS',/        0733.000
     110X,1HW,I7,X,' MEASURED ON PRESCAN ONLY',/                        0734.000
     210X,1HU,I7,X,' OF THESE HAD I LESS THAN OR EQUAL TO ZERO',/       0735.000
     310X,1HA,I7,X,' USED THE ATTENUATOR',/                             0736.000
     410X,1HR,I7,X,' REFLECTIONS, INCLUDING INTENSITY  STANDARDS, WERE  0737.000
     5 REJECTED',/                                                      0738.000
     610X,1HC,I7,X,' OPTIMUM PSI SETTING NOT ATTAINABLE',/              0739.000
     710X,1HD,I7,X,' PEAK DISPLACED BY MORE THAN DANG',/                0740.000
     810X,1HS,I7,X,' S - COUNT LOSS OF MORE THAN 1%',/                  0741.000
     910X,1HT,I7,X,' T - COUNT LOSS OF MORE THAN 1% WITH ATTENUATOR',/  0742.000
     110X,1HF,I7,X,' FAILED NON-EQUALITY TEST'/                         0743.000
     210X,1HX,I7,X,' C OR X POSITIONING PROBLEM'/)                      0744.000
      IF (ICARD.EQ.1.OR.IHKLF.LE.0) WRITE(LP,9040)KNT(11)               0745.000
 9040 FORMAT(  7X,I7,' REFLECTIONS WRITTEN TO FILE 14')                 0746.000
      IF (IHKLF.GT.0) WRITE (LP,6724) KNT(12)                           0747.000
 6724 FORMAT (7X,I7,' REFLECTIONS WRITTEN TO FILE 1'//)                   0748.000
 6725 FORMAT (7X,I7,' REFLECTIONS WRITTEN TO NAME.HKL FOR SHELXS'//)
      WRITE(LP,6725)KNT(12)
 6726 FORMAT (8X,'    H   K   L        FSQ   THETA    SCAN    APERTURE')
 6727 FORMAT (1X,' MINIMUM',3I4,3X,4F8.2)
 6728 FORMAT (1X,' MAXIMUM',3I4,3X,4F8.2)
      WRITE(LP,6726)
      WRITE(LP,6727)(ILIM(I,1),I=1,3),(SLIM(I,1),I=1,4)
      WRITE(LP,6728)(ILIM(I,2),I=1,3),(SLIM(I,2),I=1,4)
      IF(IHKLF.LE.0)GOTO 9067                                           0749.000
      CALL ANA(-1,0.,0.)                                                0750.000
      WRITE(LP,9061)                                                    0751.000
      DO 9065 J=1,33                                                    0752.000
      J1=1+J/2                                                          0753.000
      J2=MOD(J,2)+1                                                     0754.000
      IF(J.EQ.1)J2=3                                                    0755.000
      WRITE(LP,9062)HEAD1(J1),HEAD2(J2),K1(J),K2(J),K3(J),TTS(J),FFS(J) 0756.000
 9065 CONTINUE                                                          0757.000
      WRITE(LP,9063)                                                    0758.000
      DO 9066 I=1,15                                                    0759.000
      J1=I-1                                                            0760.000
      J2=34+I                                                           0761.000
      WRITE(LP,9064)TLIM(J1),TLIM(I),K1(J2),K2(J2),K3(J2),TTS(J2),FFS(J20762.000
     *)                                                                 0763.000
 9066 CONTINUE                                                          0764.000
 9061 FORMAT(1H1,//14X,'ANALYSIS OF DATA BY INDICES - I IS THE NET INTEN0765.000
     *SITY AND S ITS ESD',//20X,'INDEX CLASS',5X,'TOTAL',2X,'I/S>3',2X, 0766.000
     *'I/S>6',2X,'MEAN I/S',2X,'MEAN F'/)                               0767.000
 9062 FORMAT(20X,A8,A4,2X,3I7,2X,2F8.1)                                 0768.000
 9063 FORMAT(1H1,//21X,'ANALYSIS OF DATA BY BRAGG ANGLE',//12X,'THETA RA0769.000
     *NGE',3X,        'TOTAL',2X,'I/S>3',2X,'I/S>6',2X,'MEAN I/S',      0770.000
     *2X,'MEAN F'/)                                                     0771.000
 9064 FORMAT(10X,F6.1,' -',F6.1,3I7,2X,2F8.1)                           0772.000
 9067 WRITE(LP,9060)                                                    0773.000
 9060 FORMAT(/,10X,8HFINISHED,/,1X,110(1H-))                            0774.000
      GOTO 9999                                                         0775.000
C                                                                       0776.000
C ERROR MESSAGES                                                        0777.000
C                                                                       0778.000
 9100 WRITE(LP,9110) IERR,LINE                                          0779.000
 9110 FORMAT( /,4X,16HXXXXX ERROR TYPE,I4,19H, LAST RECORD READ(,A61/)
      KERR=KERR+1                                                       0781.000
      IF(KERR.LE.30)GOTO 9996                                           0782.000
      WRITE(LP,9995)                                                    0783.000
 9995 FORMAT(/,10X,29HTHIRTY ERRORS, JOB TERMINATED)    
      GOTO 9999                                                         0785.000
 9996 GOTO(9997,1040,1040,100,9997,1040,9997,1040,4050,4460,4460,1040,  0786.000
     *4040,9997),IERR                                                   0787.000
 9997 WRITE(LP,9998)                                                    0788.000
 9998 FORMAT(/,10X,14HJOB TERMINATED)                                   0789.000
 9999 WRITE(9,9800)0,0,0,0.,0.
 9800 FORMAT(3I4,2F8.2)
      STOP                                                              0790.000
      END                                                               0791.000
      SUBROUTINE DCOSN(IH,IK,IL,FREL,SIGF,THETA,PHIK,OMK,XKAPPA,        0792.000
     1CON1,CA,A,NSET,IUNOBS,LD,LX,KNT,ICARD,IHKLF,IDCOS,NREFL,IXRAYT)   0793.000
C     GET BEAM DIRECTION COSINES W.R.T. CRYSTAL AXES                    0794.000
C     FROM KAPPA GEOMETRY SETTING ANGLES ON TAPE. K.W.M. APRIL 1979     0795.000
C     MATRIX R (A IN DCOSN) TRANSFORMS VECTOR H TO X,Y,Z COORD. SYSTEM, 0796.000
C     I.E. SPECTROMETER FIXED SYSTEM - SAME AS PHI SYSTEM WHEN          0797.000
C     OMEGA=CHI=PHI=0.
      COMMON /SHELX/IHS,IKS,ILS,FSQS,SIGS,ILIM(3,2),SLIM(5,2)
      DIMENSION CX(3),DX(3),A(3,3),KNT(12)                              0799.000
      IF(IDCOS.EQ.0)GOTO 1                                              0800.000
      DATA RTD/57.2957795/                                              0801.000
      THETA=THETA/RTD                                                   0802.000
      PHIK=PHIK/RTD                                                     0803.000
      OMK=OMK/RTD                                                       0804.000
      XKAPPA=XKAPPA/RTD                                                 0805.000
      CTT=COS(2.*THETA)                                                 0806.000
      STT=SIN(2.*THETA)                                                 0807.000
      CP=COS(PHIK)                                                      0808.000
      SP=SIN(PHIK)                                                      0809.000
      CW=COS(OMK)                                                       0810.000
      SW=SIN(OMK)                                                       0811.000
      CK=COS(XKAPPA)                                                    0812.000
      SK=SIN(XKAPPA)                                                    0813.000
      SA=SQRT(CON1)                                                     0814.000
      DO 35 I=1,3                                                       0815.000
      ASTARI=SQRT(A(I,1)*A(I,1)+A(I,2)*A(I,2)+A(I,3)*A(I,3))            0816.000
C     GET UNIT VECTOR ALONG ASTARI WITH ALL ANGLES ZERO.                0817.000
      X1=A(I,1)/ASTARI                                                  0818.000
      Y1=A(I,2)/ASTARI                                                  0819.000
      Z1=A(I,3)/ASTARI                                                  0820.000
      X2=X1*CP+Y1*SP                                                    0821.000
      Y2=-X1*SP+Y1*CP                                                   0822.000
      X3=CA*X2-SA*Z1                                                    0823.000
      Z3=SA*X2+CA*Z1                                                    0824.000
      X4=CK*X3+SK*Y2                                                    0825.000
      Y4=-SK*X3+CK*Y2                                                   0826.000
      X5=CA*X4+SA*Z3                                                    0827.000
C     GET COMPONENTS OF UNIT VECTOR ALONG ASTARI AT                     0828.000
C     (PHIK,K,OMK). Z6 IS NOT ACTUALLY NEEDED.                          0829.000
      Z6=-SA*X4+CA*Z3                                                   0830.000
      CX(I)=X5*CW+Y4*SW                                                 0831.000
      Y6=-X5*SW+Y4*CW                                                   0832.000
 35   DX(I)=-CX(I)*CTT+Y6*STT                                           0833.000
    1 SIGI=2.0*FREL*SIGF                                                0834.000
      FF=FREL*FREL                                                      0835.000
      IF(IHKLF.GT.1)GOTO 2                                              0836.000
      WRITE(LX) IH,IK,IL,FF,SIGI,IUNOBS,NSET,(CX(I),DX(I),I=1,3)        0837.000
      KNT(12)=KNT(12)+1                                                 0838.000
      IF (ICARD.EQ.0) RETURN                                            0839.000
      WRITE(LD,41) IH,IK,IL,FREL,SIGF,NSET,(CX(I),DX(I),I=1,3),IUNOBS   0840.000
   41 FORMAT(3I3,2E13.7,I2,6F7.4,I1)                                    0841.000
      KNT(11)=KNT(11)+1                                                 0842.000
      RETURN                                                            0843.000
    2 JA=16777216*NSET+65536*IH+256*IK+IL+8421504                       0844.000
C*****   SET TBAR TO 0.03 MM ***************                            0845.000
      JB=NREFL+163840000                                                0846.000
      IF(IDCOS.EQ.0)GOTO 3                                              0847.000
      WRITE(LX)JA,JB,FF,SIGI,(CX(I),DX(I),I=1,3)                        0848.000
      GOTO 4                                                            0849.000
    3 WRITE(LX)JA,JB,FF,SIGI                                            0850.000
    4 WRITE(9,9999)IHS,IKS,ILS,FSQS,SIGS
 9999 FORMAT(3I4,2F8.2)
      KNT(12)=KNT(12)+1                                                 0851.000
      RETURN                                                            0852.000
      END                                                               0853.000
      SUBROUTINE LEADZO(IFW,N,IOUT)                                     0854.000
      DIMENSION IOUT(8)                                                 0855.000
      J=N                                                               0856.000
      DO 1 I=1,IFW                                                      0857.000
      IOUT (IFW+1-I)=MOD(J,10)                                          0858.000
    1 J=J/10                                                            0859.000
      RETURN                                                            0860.000
      END                                                               0861.000
      SUBROUTINE REJECT(J,K,L,ISTAT,NREF,IREJ)                          0862.000
C     DUMMY REJECT                                                      0863.000
      DIMENSION ISTAT(6)                                                0864.000
      COMMON FREL,SIGF,TX,FLAM1,IPRINT                                  0865.000
      RETURN                                                            0866.000
      END                                                               0867.000
      SUBROUTINE PARSE(LINE,J,NPOS,LENGTH)                              0868.000
C     GIVEN A LINE OF INPUT, RETURNS NUMBER OF FIELDS,                  0869.000
C     BEGINNING AND LENGTH OF EACH FIELD                                0870.000
      CHARACTER LINE(81)                                                0871.000
      DIMENSION NPOS(10),LENGTH(10)                                     0872.000
      J=0                                                               0873.000
      DO 1 I=1,80                                                       0874.000
      IF (.NOT.(LINE(I).EQ.' '.AND.LINE(I+1).NE.' ')) GO TO 1           0875.000
      J=J+1                                                             0876.000
      NPOS(J)=I+1                                                       0877.000
 1    CONTINUE                                                          0878.000
      NPOS(J+1)=82                                                      0879.000
      DO 2 I=1,J                                                        0880.000
      DO 3 K=NPOS(I),NPOS(I+1)-1                                        0881.000
      IF (LINE(K).EQ.' ') GO TO 2                                       0882.000
 3    CONTINUE                                                          0883.000
 2    LENGTH(I)=K-NPOS(I)                                               0884.000
      RETURN                                                            0885.000
      END                                                               0886.000
      SUBROUTINE IFORMAT(LINE,ISTART,LENGTH,IVALUE)                     0887.000
C     DECODES AN INTEGER OF GIVEN FIELD-POSITION & WIDTH                0888.000
      CHARACTER*81 LINE(1)        
      CHARACTER*80 SPEC
      NX=ISTART-1                                                       0890.000
      WRITE (SPEC,10) NX,LENGTH               
 10   FORMAT('(',I2,'X,I',I2,')')                                       0892.000
      READ (LINE,SPEC) IVALUE 
      RETURN                                                            0894.000
      END                                                               0895.000
      SUBROUTINE FFORMAT(LINE,ISTART,LENGTH,VALUE)                      0896.000
      CHARACTER*81 LINE(1)             
      CHARACTER*80 SPEC
      NX=ISTART-1                                                       0898.000
      WIDTH=LENGTH                                                      0899.000
      WRITE (SPEC,10) NX,WIDTH                       
 10   FORMAT('(',I2,'X,F',F4.1,')')                                     0901.000
      READ (LINE,SPEC) VALUE            
      RETURN                                                            0903.000
      END                                                               0904.000
      SUBROUTINE PROFILE(JD,IBGL,INT,IBGR,IPROF)                        0905.000
      DIMENSION JD(96)                                                  0906.000
      RETURN                                                            0907.000
      END                                                               0908.000
      SUBROUTINE ANA(I,T,F)                                             0909.000
      COMMON/ANABLK/K1(50),K2(50),K3(50),TTS(50),FFS(50)                0910.000
      IF(I)30,10,20                                                     0911.000
C*****INITIALISE STORAGE WHEN I = 0                                     0912.000
   10 DO 11 J=1,50                                                      0913.000
      K1(J)=0                                                           0914.000
      K2(J)=0                                                           0915.000
      K3(J)=0                                                           0916.000
      FFS(J)=0.                                                         0917.000
   11 TTS(J)=0.                                                         0918.000
      RETURN                                                            0919.000
C*****INCREMENT FOR TYPE I REFLECTION                                   0920.000
   20 TTS(I)=TTS(I)+T                                                   0921.000
      FFS(I)=FFS(I)+F                                                   0922.000
      K1(I)=K1(I)+1                                                     0923.000
      IF(T.GT.3.0)K2(I)=K2(I)+1                                         0924.000
      IF(T.GT.6.0)K3(I)=K3(I)+1                                         0925.000
      RETURN                                                            0926.000
C*****TIDY MEANS FOR OUTPUT I < 0                                       0927.000
   30 DO 32 J=1,50                                                      0928.000
      IF(K1(J).NE.0)GOTO 31                                             0929.000
      TTS(J)=0.                                                         0930.000
      FFS(J)=0.                                                         0931.000
      GOTO 32                                                           0932.000
   31 TTS(J)=TTS(J)/FLOAT(K1(J))                                        0933.000
      FFS(J)=FFS(J)/FLOAT(K1(J))                                        0934.000
   32 CONTINUE                                                          0935.000
      RETURN                                                            0936.000
      END                                                               0937.000
      SUBROUTINE ANB(T,IH,IK,IL,F)                                      0938.000
      NHKL=IABS(MOD(IH+IK+IL,2))                                        0939.000
      NKL=IABS(MOD(IK+IL,2))                                            0940.000
      NLH=IABS(MOD(IL+IH,2))                                            0941.000
      NHK=IABS(MOD(IH+IK,2))                                            0942.000
      NH=IABS(MOD(IH,2))                                                0943.000
      NK=IABS(MOD(IK,2))                                                0944.000
      NL=IABS(MOD(IL,2))                                                0945.000
      CALL ANA(1,T,F)                                                   0946.000
      CALL ANA(2+NHKL,T,F)                                              0947.000
      CALL ANA(4+NKL,T,F)                                               0948.000
      CALL ANA(6+NLH,T,F)                                               0949.000
      CALL ANA(8+NHK,T,F)                                               0950.000
      IF(IH.NE.0)GOTO 1                                                 0951.000
      CALL ANA(10+NK,T,F)                                               0952.000
      CALL ANA(12+NL,T,F)                                               0953.000
      CALL ANA(14+NKL,T,F)                                              0954.000
    1 IF(IK.NE.0)GOTO 2                                                 0955.000
      CALL ANA(16+NH,T,F)                                               0956.000
      CALL ANA(18+NL,T,F)                                               0957.000
      CALL ANA(20+NLH,T,F)                                              0958.000
    2 IF(IL.NE.0)GOTO 3                                                 0959.000
      CALL ANA(22+NH,T,F)                                               0960.000
      CALL ANA(24+NK,T,F)                                               0961.000
      CALL ANA(26+NHK,T,F)                                              0962.000
    3 IF(IK.EQ.0.AND.IL.EQ.0)CALL ANA(28+NH,T,F)                        0963.000
      IF(IH.EQ.0.AND.IL.EQ.0)CALL ANA(30+NK,T,F)                        0964.000
      IF(IH.EQ.0.AND.IK.EQ.0)CALL ANA(32+NL,T,F)                        0965.000
      RETURN                                                            0966.000
      END                                                               0967.000
