C ***  SUINDEX - SETS UP FOR THE INDEXING PROGRAMS
C *
C *
C *  PROGRAMMER: Robert. L. Snyder  and Scott A. Howard
C *              Alfred University  1984
C *
	CHARACTER*80 TITLE, Q
	CHARACTER*40 KFIL, NFIL
	COMMON /CHAR/ TITLE, KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT, IDAT
      INCH=5
      IOUT=6
      IBAT=20
      IFIL=10
      IDAT=30
      ALAMDF=1.540598
      DEG=57.29577951308
      RAD=1.0/DEG
C *
C *  SAY HELLO
C
      WRITE(IOUT,1800)
1800  FORMAT(/,' ***> SUINDEX - sets up for indexing programs')
C
C  INPUT DATA FROM ADR FILE
C
	CALL ADRIN
C
C  SAVE THE FILE NAME IN THE LAST 20 COL'S OF THE TITLE
C
       TITLE(61:80) = NFIL(1:20)
C
C  GET THE NAME OF THE BATCH FILE
C
	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'COM'
      WRITE(IOUT,1810) NFIL
1810  FORMAT(/' Enter your batch command file name (default =', A40)
      READ(INCH,1820) KFIL
1820  FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
      OPEN(UNIT=IBAT,FILE=KFIL,STATUS='NEW',FORM='FORMATTED',
     +CARRIAGECONTROL='LIST')
c
c  add the default directory to the .com file
c
	INQUIRE(UNIT=IBAT, NAME=Q)
	J=INDEX(Q,']')
	WRITE(IBAT,1) Q(:J)
1	FORMAT('$ SET DEF ',A<J>)
C *
C *  GET THE SETUP INFORMATION
C *
1700  WRITE(IOUT,1705)
1705  FORMAT(//,' ***   O P T I O N A L   D A T A    ***',//,
     1' If the following data is not known, the defaults are used')
C *  IF A DATA FILE IS TO BE READ, DO NOT PROMPT FOR DATA NOW
C *  GET THE WAVELENGTH OF RADIATION
      WRITE(IOUT,1725)
1725  FORMAT(/,' Radiation wavelength? (default = 1.54056 A):')
      READ(INCH,1730) ALAMBD
1730  FORMAT(F12.6)
      IF( ALAMBD .LE. 0.0 ) ALAMBD = ALAMDF
      QCONST=4.0/(ALAMBD*ALAMBD)
C  * GET THE NUMBER OF LINES TO OUPUT FOR ATTEMPTED INDEXING
       IF(NOBS .LE. 40)GO TO 1734
       WRITE(IOUT,1731) NOBS
1731   FORMAT(/1X,I5,' Lines were read input.  Enter the number',
     1' to try to index'/'$(Default = 40) : ')
       READ(INCH,1732) NOUT
1732   FORMAT(I)
       IF(NOUT .EQ. 0)NOUT = 40
C *  GET THE OBSERVED DELTA 2THETA VALUE
1734  WRITE(IOUT,1735)
1735  FORMAT(/,' 2Theta deviation? (default = 0.06 deg)')
      READ(INCH,1730) D2TH
      IF( D2TH .LE. 0.0 ) D2TH = 0.06
C *  GET ZERO POINT CORRECTION
      WRITE(IOUT,1755)
1755  FORMAT(/,' Zero point correction value? (default = 0.0 deg)')
      READ(INCH,1730) Z2TCOR
      IF( Z2TCOR .LT. 0.0 )Z2TCOR=0.0
C *  GET THE MOLECULAR WEIGHT
      WRITE(IOUT,1760)
1760  FORMAT(/,' Molecular weight of compound? (default = 0.0 gm)')
      READ(INCH,1730) AMOLWT
      IF( AMOLWT .LT. 0.0 )AMOLWT=0.0
C *  GET DENSITY VALUES
      WRITE(IOUT,1740)
1740  FORMAT(/,' Density and delta density? (default = 0.0 g/cm3)')
      READ(INCH,1745) DENS,DDENS
1745  FORMAT(2F10.5)
      DDENS = 0.0
      IF( DENS .LE. 0.0 ) DENS = 0.0
      IF( DENS.GT.0.0 .AND. DDENS.LE.0.0 )DDENS = 0.1
C *  GET THE NUMBER OF FORMULA UNITS PER CELL
      WRITE(IOUT,1750)
1750  FORMAT(/,' No. of formula units per cell? (default = 1.0)')
      READ(INCH,1730) ZMULT
      IF( ZMULT .LT. 0.0 )ZMULT = 1.0
C *  GET THE NUMBER OF SPURIOUS LINES EXPECTED
      WRITE(IOUT,1770)
1770  FORMAT(/,' Number of spurious lines allowed? (default = 0)')
      READ(INCH,1805)NSPURI
1805	FORMAT(I)
      IF( NSPURI .LT. 0 ) NSPURI = 0
      GO TO 1900
C *
C *  CONFIRM THE OPTIONAL DATA
C *
1900  WRITE(IOUT,1905)
1905  FORMAT(/,' ** the information as entered:')
      WRITE(IOUT,1910) TITLE
1910  FORMAT(/,' ',A80)
      WRITE(IOUT,1915) ALAMBD,NSPURI
1915  FORMAT(/,' Rad wavelength:   ',F10.4,3X,
     1         ' Spurious lines:   ',I10)
      WRITE(IOUT,1920)D2TH,Z2TCOR
1920  FORMAT(  ' Delta 2theta:     ',F10.4,3X,
     1         ' Zero shift:       ',F10.4)
      WRITE(IOUT,1925) DENS,DDENS
1925  FORMAT(  ' Density:          ',F10.4,3X,
     1         ' Delta density:    ',F10.4)
      WRITE(IOUT,1930)AMOLWT,ZMULT
1930  FORMAT(  ' Molecular wgt:    ',F10.4,3X,
     1         ' Multiplicity:     ',F10.4)
      WRITE(IOUT,1940)
1940  FORMAT(/,' Is this information correct? <0> yes <1> no :')
      READ(INCH,1805) IANS
      IF( IANS .NE. 0 )GO TO 1700
C *
C *  ADD ZERO POINT CORRECTIONS IS NECESSARY
C *
      INSERT=.FALSE.
      I2TCOR=.FALSE.
      IF( Z2TCOR .EQ. 0.0 )GO TO 2000
      I2TCOR=.TRUE.
      WRITE(IOUT,1090)Z2TCOR
 1090 FORMAT(1H0,'Correction of',F10.6,'  Degrees to be added to each',
     1 ' 2Theta value')
C *
C *  VERIFY THE DATA
C *
2000	WRITE(IOUT,1905)
      WRITE(IOUT,1780)
1780  FORMAT(/,42H  No  2Theta   Theta     Sinth     Sinthsq,8X,1HQ,
     1 8X,1Hd,5X,7HInt  No/)
      DO 1025 I=1,NOBS
      QOBS(I)=10000.0/(D(I)*D(I))
      THETA=DEG*ASIN(0.5*ALAMBD/D(I))
      TWOTH(I)=2.0*THETA
      SINTH=SIN(RAD*THETA)
      SINSQ=SINTH*SINTH
      DMAX=0.5*ALAMBD/SIN(0.5/DEG*(TWOTH(I)-D2TH))
      DELTAD(I)=DMAX-D(I)
      WRITE(IOUT,1010)I,TWOTH(I),THETA,SINTH,SINSQ,QOBS(I),
     1 D(I),INT(AINT(I)),I
1010  FORMAT(1H ,I3,2F8.3,F11.6,F12.7,F11.3,F9.4,2X,I3,1X,I3)
1025  CONTINUE
      WRITE(IOUT,1020) NOBS
1020  FORMAT(/17H Input completed,,I3,22H lines to be processed)
C *
C *  INPUT COMPLETED, SETUP FOR INDEXING PROGRAM
C *
2300  WRITE(IOUT,2305)
2305  FORMAT(//,' ***    I N D E X    M E T H O D   D E T E R',
     1          ' M I N A T I O N    ***',//,
     2' There are currently five techniques available.',/,
     3' Choose the technique(s) which are most suitable.')
      WRITE(IOUT,2310)
2310  FORMAT(/,' GOBEL-WILSON: Cubic, Tetragonal, and Hexagonal ',
     1 'Systems',/,
     1' VISSER: appropriate for low symmetry systems',/,
     2' LOUER: exhaustive search for Cubic, Hex Tet Ortho or Mono'//
     3' WERNER: exhaustive search for all symmetries'/
     3' TAUPIN: exhaustive search for all symmetries'/
     4' BEWARE - The Monoclinic feature of Louer and all of',
     5' Taupin can take extensive'/' amounts of',
     5' computer time and should only be used for special cases'//)
      WRITE(IOUT,2315)
2315  FORMAT(/,' Do you want GOBEL-WILSON indexing? <0> no <1> yes:')
      READ(INCH,1805)IANS
      IF( IANS .EQ. 1 )CALL GOBWIL
      WRITE(IOUT,2320)
2320  FORMAT(/,' Do you want VISSER indexing? <0> no <1> yes:')
      READ(INCH,1805) IANS
      IF( IANS .EQ. 1 )CALL VISSER
      WRITE(IOUT,2325)
2325  FORMAT(/,' Do you want LOUER indexing? <0> no <1> yes:')
      READ(INCH,1805)IANS
      IF( IANS .EQ. 1 )CALL LOUER
c      WRITE(IOUT,2330)
c2330  FORMAT(/,' Do you want LOUERM indexing (5-100 CPU hrs)?',
c     1' <0> no <1> yes:')
c      READ(INCH,1805)IANS
c      IF( IANS .EQ. 1 )CALL LOUERM
      WRITE(IOUT,2335)
2335  FORMAT(/,' Do you want TAUPIN indexing (5-20 CPU hrs)?',
     1' <0> no <1> yes:')
      READ(INCH,1805)IANS
      IF( IANS .EQ. 1 )CALL TAUPIN
      WRITE(IOUT,2336)
2336  FORMAT(/' Do you want Werner''s TREOR indexing ?',
     1' <0> no <1> yes:')
      READ(INCH,1805)IANS
      IF( IANS .EQ. 1 )CALL WERNER
C *
C *  FINAL INSTRUCTIONS
C *
2400  	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'COM'
       	WRITE(IOUT,2405) NFIL
2405  FORMAT(//' As soon as terminal returns a  $  type'/
     1 ' $ SUB ',A40/
     2 /' Your job will run in batch mode.'/
     3 ' You may monitor its status by typing "look" or ',
     4 ' "show queue/order"'//' When your job is finished you',
     5 ' examine the results by typing'/' the .GOB, .LOU',
     6 ' .VIS .LOM, or .TAU files'/)
      CALL EXIT
      END

       SUBROUTINE ADRIN
C
C  THIS IS A GENERAL SUBROUTINE READ TO THE d-I INFORMATION
C  FROM AN ADR FILE. OR A DIFFRAC 11 FILE
C  THE ADR INPUT FORMAT FOR SIEMENS FILES IS:
C  RECORD  1: BLANK
C  RECORD  2: BLANK
C  RECORD  3: BLANK
C  RECORD  4: ADR HEADER RECORD
C  RECORD  5: ALFRED UNIVERSITY HEADER RECORD
C  RECORD  6: DATE AND TIME OF PROCESSESING WITH ADR
C	(1X,'DATE:',1X,9A1,5X,'TIME: ',1X,8A1)
C	FOR INPUT: (7X,9A1,12X,8A1)
C  RECORD  7: OUTPUT FILE NAME
C	(' OUTPUT FILE NAME:'40A1) - (18X,10A1)
C  RECORD  8: TITLE OF RUN
C	('TITLE OF RUN:',80A1) - (13X,80A1)
C  RECORD  9: DATE OF RUN
C	(' DATE OF RUN: ',9A1) - (14X,9A1)
C  RECORD 10: BLANK
C  RECORD 11: STARTING ANGLE AND COUNT TIME (17X,F9.4,4X,F7.2)
C  RECORD 12: ENDING ANGLE AND X SIGMA (17X,F9.4,4X,F7.2)
C  RECORD 13: ANGLE INCREMENT AND Y SIGMA (17X,F9.4,4X,F7.2)
C  RECORD 14: POINTS FOR SMOOTH AND MAXIMUM FWHM
C  RECORDS 15-?: EXTRA RUN PARAMETERS
C  RECORD 16: d-I HEADER
C	(' PEAK',....)
C  RECORD 17: PK. #, 2-THETA, *, d, RELI, DELTA d, ABS I, FWHM
C	(1XI3,1XF9.4,A1,F8.3,F8.2,10X,F6.4,F9.1,F9.4)
C  OPTIONAL INFO ON d-I RECORD: IN PLACE OF 10X - hkl's in 3I3,1X
C
	CHARACTER*1 IDOT, IBL, NAST, IAST
	CHARACTER*80 TITLE
	CHARACTER*40 KFIL, NFIL
	COMMON /CHAR/ TITLE, KFIL, NFIL
	COMMON /ADATA/ NUMDI, DUNK(100), DELTAD(100), THUNK(100),
     1      QOBS(100), AINT(100), NOUT
	DIMENSION IT(2), IPE(2)
	DATA IO5,IO6,IO7,IO30 /5,6,6,30/
	DATA IDOT, IBL, IAST, IPE/'.', ' ', '*','PE','AK'/
C
C d-I LIMIT FOR INDEXING IS 100
C
	DATA LIM /100/
C
C   INITIALIZE NUMDI - ZERO MEANS NO DATA ON FILE OR NO SUCH FILE
C
	NUMDI = 0
C
C  ALFRED OR SIEMENS FORMAT?
C
	WRITE(IO7,530)
530	FORMAT(/' Input must be from a d-I file.  If your d''s and',
     1' I''s are not',/' on a file exit this program and ',
     2'RUN XRAY:FILMOD or XRAY:VAXCONV to create'/
     1' the required file',
     1' from typed input.  The normal format is Siemens'//
     1 ' ENTER your d-I file type: '/
     1 ' <0>=Diffrac 11 (Default), <1>=',
     1 'Alfred, <2>=Siemens, <3>=EXIT: ')
	READ(IO5,535) IFMT
535	FORMAT(I)
	IF(IFMT .GE. 3)STOP 'TYPE "RUN XRAY:FILMOD'
        IF(IFMT .EQ. 0) IFMT = 3
	IF(IFMT .EQ. 1) IFMT = 2
	IF(IFMT .EQ. 2) IFMT = 1
C
C  GET NAME OF THE FILE
C
	WRITE(IO7,540)
540	FORMAT(/'$Enter the name of the d-I file :')
	READ(IO5,550)NFIL
550	FORMAT(A40)
C
C  OPEN THE DIFFRAC 11 FILE
C
       IF(IFMT .NE. 3)GO TO 5555
       NTIN = IO30
       OPEN ( UNIT=NTIN, NAME=NFIL, TYPE='OLD', 
     +	  READONLY, FORM='UNFORMATTED', ACCESS='DIRECT', 
     &    RECORDSIZE=1, ASSOCIATEVARIABLE=NEXT)
C  Read title, operator, time & date
	NEXT=1
	DO 9110,I=1,45,4
9110	READ(NTIN'NEXT) TITLE(I:I+3)
	TITLE(26:28)='   '
	DO 9120,I=1,18
	 IF(' '.LE.TITLE(I:I) .AND. TITLE(I:I).LE.'~') GOTO 9120
C  Non ascii garbage detected in first twelve
C  records so this is not Diffrac-11 format.
	 WRITE(6,9101)
9101	FORMAT(' File not in Diffrac 11 format!')
       CALL EXIT
C
C  Read number of peaks
9120	READ(NTIN'13) ALO
	READ(NTIN'14) AHI
	READ(NTIN'15) STEP
	READ(NTIN'16) TIME
	READ(NTIN'19) PWL
	READ(NTIN'21) NUMDI
	NEXT = 41
C
C  READ DIFFRAC 11 FORMAT
C
       IF(NUMDI.LE.LIM)GO TO 5001
       NUMDI = LIM
        WRITE(IO7,810)LIM
5001        DO 5002 I=1,NUMDI
	READ(NTIN'NEXT) DUNK(I)
	READ(NTIN'NEXT) AINT(I)
        THUNK(I) = ASIN(PWL / (2.*DUNK(I)) ) / 0.017453293 
	NEXT = NEXT + 4
5002    CONTINUE
       	GO TO 830
C
C  OPEN THE ADR FILE
C
5555	OPEN(UNIT=IO30, NAME=NFIL, TYPE='OLD',FORM='FORMATTED',
     1 READONLY)	
C
C  SKIP OFF THE FIRST SEVEN BLANK RECORDS
C
	DO 556 I=1,7
556	READ(IO30,555)
555	FORMAT(1X)
C
C  READ HEADER RECORDS AND GET THE TITLE
C
	GO TO (560,580), IFMT
560	READ(IO30,570,END=710) TITLE
570	FORMAT(11X,A80)
	GO TO 600
580	READ(IO30,590,END=710) TITLE
590	FORMAT(12X,A80)
C
C  SKIP THE NEXT TWO RECORDS
C
600	READ(IO30,555)
	READ(IO30,555)
C
C  GET SCAN LIMITS AND MEAS. CONDITIONS.
C
	GO TO (610,630), IFMT
610	READ(IO30,620,END=710) ALO,TIME,AHI,STEP
620	FORMAT(17X,F8.4,19X,F6.1/16X,F9.4/17X,F8.4)
	GO TO 650
630	READ(IO30,640,END=710) ALO,TIME,AHI,STEP
640	FORMAT(18X,F8.4,19X,F6.1/17X,F9.4/18X,F8.4)
C
C  SEARCH FOR THE RECORD WITH "PEAK" STARTING IN COLUMN 1 OR 2
C
650	DO 700 I=1,50
	GO TO (660,680), IFMT
660	READ(IO30,670,END=710)(IT(J),J=1,2)
670	FORMAT(2A2)
	GO TO 695
680	READ(IO30,690,END=710) (IT(J),J=1,2)
690	FORMAT(1X,2A2)
695	IF( IT(1).EQ.IPE(1) .AND. IT(2).EQ.IPE(2) )GO TO 750
700     CONTINUE
C
C **	FILE IN WRONG FORMAT
C
710	STOP ' ????? File in wrong format'
C
C  FILE IS IN CORRECT FORMAT
C
C  READ THE TWO-THETA AND INTENSITIES
C
750	GO TO (760,780),IFMT
760	READ(IO30,770,END=830) THETA,NAST,TEMP0,TEMP1
C  I KNOW THE FOLLOWING SHOULD BE (3X,... BUT $X IS NEEDED TO GET FULL 
C  SIGNIFICANCE OF THE D VALUE!
770	FORMAT(4X,1XF9.5,A1,1XF7.4,1XF7.2,16X,F9.1,F9.4)
	GO TO 800
780	READ(IO30,790,END=830) THETA,NAST,TEMP0,TEMP1
790	FORMAT(4X,1XF9.5,A1,1XF7.4,1XF7.2,16X,F9.1,F9.4)
800	IF( THETA .EQ. 0 )GO TO 830
C
C  ELIMINATE ALPHA 2 PEAK FROM INPUT LIST
C
        IF(IAST.EQ.NAST)GO TO 750
	NUMDI = NUMDI + 1
	THUNK(NUMDI) = THETA
	DUNK(NUMDI) = TEMP0
	AINT(NUMDI) = TEMP1 
	IF( NUMDI .LT. LIM )GO TO 750
        WRITE(IO7,810)LIM
810    FORMAT(/1X,'Input d-I list truncated to ',I3,' values')
830	NOUT = NUMDI
     	RETURN
        END


	SUBROUTINE LOCATE(NAME,LOC)
C
C  THIS SUBROUTINE RETURNS THE VARIABLE LOC POINTING TO THE
C  NEXT CHARACTER AFTER THE DECIMAL POINT IN A FILE NAME
C
	CHARACTER*40 NAME
	DO 100 I=1,40
	IF(NAME(I:I) .EQ. '.')GO TO 200
100	CONTINUE
C
C  NO DECIMAL POINT FOUND - SET LOC TO ZERO
C
	LOC = 0
	GO TO 999
200	LOC = I + 1
999	RETURN
	END

      SUBROUTINE VISSER
C *
C ***  VISSER - SETS UP APPROPRIATE CARD DECK
C *
	CHARACTER*80 TITLE
	CHARACTER*40 KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT
	COMMON /CHAR/ TITLE, KFIL, NFIL
C 
C  IS THIS A REASONABLE REQUWEST?
C
       IF(NOUT .GE. 20)GO TO 50
       WRITE(6,10)NOUT
10	FORMAT(//' Sorry, Visser''s program requires a minimum of',
     1 ' 20 lines.'/' Your file contains only ',I3,'.  Visser',
     2 ' request ignored')
       GO TO 999
C
C  GET THE OUTPUT FILE FOR VISSER INDEXING
C
50	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'VIS'
      WRITE(IOUT,1830) NFIL
1830  FORMAT(/' Visser''s (low symmetry) indexing ',
     1/' This program produces a large amount of output'/
     2/' A summary of the solutions only, will be written to',
     3' VISSER.SUM'
     1/' Normal output will be written to: ',a40/
     1 '$Enter a different file name if you wish to change it: ')
      READ(5,1820) KFIL
1820	FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
       WRITE(IBAT,1000)KFIL
1000   FORMAT('$ ASSIGN ',A40,' FOR066'/
     1'$ ASSIGN VISSER.SUM FOR020'/
     1'$! To view full output reassign FOR006 to the line printer'
     1 / '$ ASSIGN NL: FOR016'
     1 / '$ RUN POWD:[PUBLIC.EXE.INDEX]VISSER')
C *
C *  WRITE TITLE
      WRITE(IBAT,2000)TITLE
2000  FORMAT(1X,A80)
C *  WRITE PARAMETER CARDS
      OUT = NOUT
      WRITE(IBAT,2010)ALAMBD,AMOLWT,DENS,Z2TCOR
c2010  FORMAT('9004010101',10X,F10.5,20X,F10.5,F10.5,/F10.5)
2010  FORMAT('0000010101',10X,F10.5,20X,F10.5,F10.5,/F10.5)
      NITER = NOUT / 8
      IF( NITER .LT. 1 )GO TO 2026
      DO 2020 I=1,NITER
      NS =  8 * ( I-1 ) + 1
      NE =  NS + 7
      WRITE(IBAT,2025) (D(J),J=NS,NE)
2020  CONTINUE
2025  FORMAT(8F10.5)
2026  NREM = NOUT - ( 8 * NITER )
      IF( NREM .LE. 0 )GO TO 3000
      NS = NS + 8
      NE = NS + NREM - 1
      WRITE(IBAT,2025) (D(J),J=NS,NE)
C *
3000  WRITE(IBAT,3005)
3005  FORMAT('    ',/,'END ')
999   RETURN
      END

      SUBROUTINE GOBWIL
C *
C ***  GOBWIL - SETS UP APPROPRIATE CARD DECK
C *
	CHARACTER*80 TITLE
	CHARACTER*40 KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT
	COMMON /CHAR/ TITLE, KFIL, NFIL
C
C  GET THE OUTPUT FILE FOR GOBEL-WILSON INDEXING
C
	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'GOB'
      WRITE(IOUT,1830) NFIL
1830  FORMAT(/' Gobel and Wilson''s (high symmetry) indexing ',
     1/' Results will be written to: ',a40/
     1 '$Enter a different file name if you wish to change it: ')
      READ(5,1820) KFIL
1820	FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
       WRITE(IBAT,1000)KFIL
1000   FORMAT('$ ASSIGN ',A40,' FOR006'
     1 / '$ RUN POWD:[PUBLIC.EXE.INDEX]GOBWIL')
C *
      WRITE(IBAT,2000) TITLE
2000  FORMAT(21X,A80)
      ERROR = SIN( D2TH )**2
      WRITE(IBAT,2010)ALAMBD,ALAMBD,ERROR
2010  FORMAT('00001',3F10.6,30X,'0001')
      NITER = NOUT / 7
      IF( NITER .LT. 1 )GO TO 2026
      DO 2020 I=1,NITER
      NS =  7 * ( I-1 ) + 1
      NE =  NS + 6
      WRITE(IBAT,2025) (TWOTH(J),J=NS,NE)
2020  CONTINUE
2025  FORMAT(7F10.5)
2026  NREM = NOUT - ( 7 * NITER )
      IF( NREM .LE. 0 )GO TO 3000
      NS = NS + 7
      NE = NS + NREM - 1
      WRITE(IBAT,2025) (TWOTH(J),J=NS,NE)
C *
3000  WRITE(IBAT,3005)
3005  FORMAT('    ')
      RETURN
      END

      SUBROUTINE LOUER
C *
C ***  LOUER - SETS UP AN INPUT FILE FOR LOUERS PROGRAM
C *
	CHARACTER TITLE*80, IANS*1
	CHARACTER*40 KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT
	COMMON /CHAR/ TITLE, KFIL, NFIL
C
C  GET THE OUTPUT FILE FOR LOUER INDEXING
C
	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'LOU'
      WRITE(IOUT,1830) NFIL
1830  FORMAT(/' Louer''s (cubic, hexagonal, tetragonal',
     1' orthorhombic and monoclinic) indexing '/
     1/' This program does an exhaustive search of solution',
     1' space and'/' requires an increasing amount of CPU time',
     1' as symmetry decreases.'/' It is advised not to routinely',
     1' run the monoclinic search.'/
     1/' Results will be written to: ',A40/
     1 '$Enter a different file name if you wish to change it: ')
      READ(5,1820) KFIL
1820	FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
       WRITE(IBAT,1000)KFIL
1000   FORMAT('$ ASSIGN ',A40,' FOR006'
     1 / '$ RUN POWD:[PUBLIC.EXE.INDEX]LOUER')
C *
      WRITE(IBAT,1010) TITLE
1010  FORMAT(1X,A80)
C *
C---LOUV(7), LOUM(7) @ LOSH(3)
      VOLMIN=0.
	write(iout,1020)
1020	format(/' Input the maximum of the following parameters',
     1' within which'/' to search for solutions'//
     2' Parameter:  a    b    c   Volume     Beta(min) Beta(max)'/
     3' Default  : 20., 20., 20., 1000(A**3),   90.0,      130.0')
	read(inch,1030) amax, bmax, cmax, volmax, bemin, bemax
1030	format(6g)
	if(volmax .eq. 0.0) VOLMAX=1000.
	if(amax .eq. 0.0) AMAX=20
	if(bmax .eq. 0.0) BMAX=20
	if(cmax .eq. 0.0) CMAX=20
	if(bemin .eq. 0.0) BEMIN=90.
	if(bemax .eq. 0.0) BEMAX=130.
     	WRITE(IOUT,1022)
1022	FORMAT(/'$Do you wish to test the Cubic system? (Y/N) <Y>: ')
     	READ(5,1023) IANS
1023	FORMAT(A1)
     	I1 = 1
     	IF(IANS.EQ.'N') I1 = 0
     	WRITE(IOUT,1024)
1024	FORMAT(/'$Do you wish to test the Tetragonal',
     1' system? (Y/N) <Y>: ')
     	READ(5,1023) IANS
     	I2 = 1
     	IF(IANS.EQ.'N') I2 = 0
     	WRITE(IOUT,1025)
1025	FORMAT(/'$Do you wish to test the Hexagonal',
     1' system? (Y/N) <Y>: ')
     	READ(5,1023) IANS
     	I3 = 1
     	IF(IANS.EQ.'N') I3 = 0
     	WRITE(IOUT,1026)
1026	FORMAT(/'$Do you wish to test the Orthorhombic system? (Y/N)',
     1'  <Y>: ')
     	READ(5,1023) IANS
     	I4 = 1
     	IF(IANS.EQ.'N') I4 = 0
     	WRITE(IOUT,1028)
1028	FORMAT(/'$Do you wish to test the Monoclinic system? (Y/N)',
     1 ' <N>: ')
     	READ(5,1023) IANS
     	I5 = 0
     	IF(IANS.EQ.'Y') I5 = 1
      ILOU = 1
     	ID = 3
       WRITE(IBAT,1200) NOUT,ID,I1,I2,I3,I4,I5
 1200 FORMAT(7I2)
       WRITE(IBAT,1210) AMAX,BMAX,CMAX,VOLMIN,VOLMAX,BEMIN,BEMAX
1210	FORMAT(7F10.2)           
       WRITE(IBAT,1220) ALAMBD,AMOLWT,DENS,DDENS
1220	FORMAT(4F10.5)           
      DO 1205 I=1,NOUT
      WRITE(IBAT,1250) D(I),DELTAD(I)
1205  CONTINUE
 1250 FORMAT(2F10.4)
C *  SET UP COMPLETE
      RETURN
      END

      SUBROUTINE LOUERM
C *
C ***  LOUERM - SETS UP AN INPUT FILE FOR LOUERS MONOCLINIC PROGRAM
C *
	CHARACTER*80 TITLE
	CHARACTER*40 KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT
	COMMON /CHAR/ TITLE, KFIL, NFIL
C
C  GET THE OUTPUT FILE FOR LOUER INDEXING
C
	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'LOM'
      WRITE(IOUT,1830) NFIL
1830  FORMAT(/' Louer''s (monoclinic) indexing ',
     1/' results will be written to: ',A40/
     1 '$Enter a different file name if you wish to change it: ')
      READ(5,1820) KFIL
1820	FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
       WRITE(IBAT,1000)KFIL
1000   FORMAT('$ ASSIGN ',A40,' FOR006'
     1 / '$ RUN POWD:[PUBLIC.EXE.INDEX]LOUERM')
C *
      WRITE(IBAT,1010) TITLE
1010  FORMAT(1X,A80)
C *
C---LOUV(7), LOUM(7) @ LOSH(3)
      VOLMIN=0.
	write(iout,1020)
1020	format(/' Input the maximum of the following parameters',
     1' within which'/' to search for solutions'//
     2' Parameter:  a    b    c   Volume     Beta(min) Beta(max)'/
     3' Default  : 20., 20., 20., 1000(A**3),   90.0,      130.0')
	read(inch,1030) amax, bmax, cmax, volmax, bemin, bemax
1030	format(6g)
	if(volmax .eq. 0.0) VOLMAX=1000.
	if(amax .eq. 0.0) AMAX=20
	if(bmax .eq. 0.0) BMAX=20
	if(cmax .eq. 0.0) CMAX=20
	if(bemin .eq. 0.0) BEMIN=90.
	if(bemax .eq. 0.0) BEMAX=130.
      ILOU = 1
       WRITE(IBAT,1200) NOUT,AMOLWT,DENS,DDENS,
     1 AMAX,BMAX,CMAX,VOLMIN,VOLMAX,BEMIN,BEMAX
 1200 FORMAT(I3,3X,F10.3,2F10.4,/,
     4 7F7.0,17H  0  30.00  30.00)
      DO 1205 I=1,NOUT
      WRITE(IBAT,1250) D(I),DELTAD(I),I,INT(AINT(I)),D2TH,ILOU
1205  CONTINUE
 1250 FORMAT(2F7.4,6X,'LINE',I3,3X,I3,17X,'D2TH=',F6.3,4H DEG,7X,
     1 'LOUVMS',I2)
C *  SET UP COMPLETE
999	RETURN
      END

      SUBROUTINE TAUPIN
C *
C ***  TAUPIN - SETS UP A DATA FILE FOR TAUPIN'S PROGRAM
C *
	CHARACTER*80 TITLE
	CHARACTER*40 KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT
	COMMON /CHAR/ TITLE, KFIL, NFIL
C
C  GET THE OUTPUT FILE FOR TAUPIN INDEXING
C
	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'TAU'
      WRITE(IOUT,1830) NFIL
1830  FORMAT(/' Taupin''s (all symmetry) indexing ',
     1/' This program uses a great deal of CPU time - please use',
     1' it with care'
     1/' Results will be written to: ',a40/
     1 '$Enter a different file name if you wish to change it: ')
1      READ(5,1820) KFIL
1820	FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
       WRITE(IBAT,1000)KFIL
1000   FORMAT('$ ASSIGN ',A40,' FOR006'
     1 / '$ ASSIGN POWD:[PUBLIC.EXE.INDEX]TAUPIN.DAT FOR002'
     2 / '$ RUN POWD:[PUBLIC.EXE.INDEX]TAUPIN')
C *
      WRITE(IBAT,1010) TITLE
1010  FORMAT('FGX         ',A80)
C       - NUMBER OF GIVEN EXPERIMENTAL LINES
C       - MAXIMUM NUMBER OF EXTRANEOUS LINES
C       - MAXIMUM DEGENERESCENCE FACTOR   MAXIMUM NUMBER OF ADDITIONAL
C         LINES TO BE USED WHEN THE FIRST ONES LEAD TO A DEGENERATE EQUA
C         TION SYSTEM FOR CELL PARAMETER DETERMINATION (A GOOD VALUE IS
C         2 OR 3)
C       - UPPER LIMIT FOR H**2+K**2+L**2 FOR THE FIRST LINE ( THIS
C         VALUE IS USED TO COMPUTE THE UPPER LIMIT FOR H**2+K**2+L**2 OF
C         THE FOLLOWING LINES, ASSUMING THEY ARE PROPORTIONAL TO
C         Q=1/D**2 ( THIS IS OBVIOUSLY A ROUGHLY APPROXIMATE EXTRAPOLA
C         TION )
C       - MAXIMUM TIME LIMIT ( MINUTES ); WHEN THIS LIMIT IS EXCEEDED
C         THE PROGRAMM WILL SUSPEND ITSELF AND WRITE 2 OR MORE RESTART
C         ING RECORDS; THIS LIMIT SHOULD BE SMALLER THAN THAT STATED IN
C         THE 'JOB' CARD TO PREVENT IT FROM BEING KILLED BY THE
C         OPERATING SYSTEM.
C       - MAXIMUM VOLUME OF THE UNIT CELL (ANGSTROEM**3)
C       - THE MINIMAL FIGURE OF MERIT (SEE DE-WOLFF'S PAPER IN JOURNAL
C         OF APPLIED CRISTALLOGRAPHY - 1968); USUAL VALUE = 4; HIGHER
C         VALUES MAY BE STATED IF EXPERIMENTAL MEASUREMENTS ARE GOO;.
C    WHEN OPTION 'V' IS PRESENT
C       - MOLECULAR MASS ( OR MASS OF THE ASYMETRIC UNIT )
C       - DENSITY ( GRAMS/CM**3 )
C       - RELATIVE ESTIMATED ERROR ON THAT DENSITY
C
C=============# NOTE THAT YOU MAY LEAVE ALL OR PART OF THESE TWO FIRST
C CARDS BLANK; THEN THE PROGRAM WILL USE DEFAULT VALUES WHICH ARE
C - ALL SYSTEM TESTED;
C - LINES WILL BE COUNTED TO FIND THEIR EFFECTIVE NUMBER;
C - NO EXTRANEOUS LINES ALLOWED;
C - DEGENERESCENCE FACTOR EQUAL TO 2 ;
C - H**2+K**2+L**2 LIMITED TO 6 FOR THE FIRST LINE;
C - NO TIME LIMIT, THEN NO RESTART ;
C - MAXIMUM VOLUME = 1000 ANGSTROEM**3 ;
C - FIGURE OF MERIT EQUAL TO 4 ;
C *
	WRITE(IBAT,1190)
1190	FORMAT(/)
C FOLLOWING CARDS
C==================
C ONE CARD FOR EACH LINE; FORMAT IS (F10.0,F10.0,1X,A1,3I3) ;
C VALUES ARE RESPECTIVELY
C       - D(HKL) IN ANGSTROEMS OR 1/D(HKL)**2 IF 'Q' OPTION;
C       - ABSOLUTE ESTIMATED ERROR ON D(HKL) OR ON Q=1/D**2 IF 'Q' OPT;
C         IF THIS VALUE IS BLANK, THEN EXTRAPOLATION IS MADE ASSUMING
C         THE ERROR ON 1/D IS CONSTANT ;
C       - COL 22   ANY NON BLANK CHARACTER MEANS THAT THIS LINE MAY
C         BE EXTRANEOUS; THIS ALLOWS THE PROGRAMM TO CONTINUE A TRIAL
C         EVEN IF IT WAS NOT ABLE TO ASSIGN INDICES TO THAT LINE; IF
C         ALL LINES HAVE BLANK CHARACTER IN COL-22, ALTHOUGH THE
C         MAXIMUM NUMBER OF EXTRANEOUS LINES IS NON-ZERO, THEN ALL
C         LINES ARE CONSIDERED AS POSSIBLY EXTRANEOUS.
C       - COL 23-25,26-28,29-31   VALUES OF H, K, L, FOR THAT LINE,
C         IF THEY ARE KNOWN; ONLY 10 LINES ARE ALLOWED TO HAVE H,K,L
C         INDICATIONS;
C
      DO 1205 I=1,NOUT
      WRITE(IBAT,1250) D(I),DELTAD(I)
1205  CONTINUE
1250	FORMAT(F10.5,F10.5,1X,A1,3I3) 
C *  SET UP COMPLETE
999      RETURN
    	  END

        SUBROUTINE WERNER
C *
C ***  WERNER - SETS UP A DATA FILE FOR WERNER'S TREOR PROGRAM
C *
	CHARACTER*80 TITLE
	CHARACTER*40 KFIL, NFIL
      COMMON/ADATA/NOBS,D(100),DELTAD(100),TWOTH(100),QOBS(100),
     1             AINT(100), NOUT
      COMMON/BDATA/IDTYPE,ALAMBD,D2TH,Z2TCOR,DENS,DDENS,AMOLWT,
     1             ZMULT,NSPURI
      COMMON/CDATA/ LOGON(12),NAME(12),IBAT,IFIL,INCH,IOUT
	COMMON /CHAR/ TITLE, KFIL, NFIL
C
C  GET THE OUTPUT FILE FOR TREOR INDEXING
C
	CALL LOCATE(NFIL,LOC)
	NFIL(LOC:LOC+2) = 'TRE'
      WRITE(IOUT,1830) NFIL
1830  FORMAT(/' Werner''s (all symmetry) indexing ',
     1/' This program uses a fair amount of CPU time - ',
     1'Please use it with care'
     1/' Results will be written to: ',a40/
     1 '$Enter a different file name if you wish to change it: ')
1      READ(5,1820) KFIL
1820	FORMAT(A40)
	IF(KFIL(1:1) .EQ. ' ')KFIL = NFIL
       WRITE(IBAT,1000)KFIL
1000   FORMAT('$ ASSIGN ',A40,' FOR006'
     2 / '$ RUN POWD:[PUBLIC.EXE.INDEX]TREOR')
C *
      WRITE(IBAT,1010) TITLE
1010  FORMAT(1X,A80)
      DO 1205 I=1,NOUT
       INT = AINT(I)
      WRITE(IBAT,1250) D(I),INT
1205  CONTINUE
1250	FORMAT(1x,F15.6,10X,I4) 
	WRITE(IBAT,1190)
1190	FORMAT(/' CHOICE=4, END*')
C *  SET UP COMPLETE
999      RETURN
      END


	FUNCTION BRAGG(A)
	DATA WAVE/1.540598/, DTOR/0.0174533/
	BRAGG= WAVE / (2.0*SIN((A/2.0)*DTOR))
	RETURN
	END

