C ***  SUCELREF
C *
C PROGRAM TO SET UP INPUT DECK FOR VAX TO EXECUTE THE NBS VERSION
C OF THE APPLEMAN LEAST SQUARES (IE NBSLSQ83)
C   PROGRAMMED BY R.L. SNYDER ALFRED UNIVERSITY ALFRED N.Y. 14802
C
C 20 IS AN OUTPUT FILE TO BE SUBMITTED TO BATCH
C 10 IS THE d-I INPUT FILE OF 2-THETA'S AND D'S.(REQUIRED)
C PROGRAM FILMOD MUST FIRST BE RUN TO CREATE A d-I FILE IF IT WASN'T
C CREATED BY AN AUTOMATED DIFFRACTION SCAN
C
	CHARACTER KFILE*40
	CHARACTER TITLE*68
	CHARACTER*5 NAME(7)
	DIMENSION DUNK(200), THUNK(200), INUNK(200), IT(2), IPE(2)
	DATA IO5,IO6,IO7,IO10,IO20,IO30/5,6,6,10,20,30/
      DATA NAME/'TRICL','RHOMB',
     1'MONOC',
     2'HEXAG',
     3'CUBIC',
     4'TETRA',
     5'ORTHO'/
      DATA YES/'Y'/,IBL/' '/,ICOM/','/,IYES/'Y'/
      ITYP = 6
      IREAD = 5
      RTD=57.29578
C *
C *  SAY HELLO, GET FILE ASSIGNMENTS...
C *
      WRITE(ITYP,2)
    2 FORMAT(/,' Program to set up a batch file to run NBSLSQ'//
     1' To determine least squares, best',
     2' fit, lattice parameters',/)
C *
C *  ARE WE USING AN INPUT DATA FILE?
C *
      WRITE(ITYP,122)
122   FORMAT(' Enter the name of the d-I file'/' (if blank d''s will',
     1' be calculated from input lattice parameters without any cell',
     2' refinement)'/'$Enter file name or blank: ')
      READ(IREAD,123) KFILE
123	FORMAT(A32)
       CALL ADRIN( DUNK, THUNK, INUNK, NUMDI, TITLE,
     1 AHI, ALO, TIME, STEP, NFILE)
	JFILE = 0
	IF(KFILE(1:4) .EQ. '    ')JFILE = 1
C *
C *  GET BATCH FILE INFORMATION AND SET UP FRONT END
C *
	IF(JFILE .EQ. 0)GO TO 103
	KFILE(1:7) = 'LSQ.COM'
	GO TO 105
103	DO 108 I=1,40
	IF(KFILE(I:I) .EQ. '.')GO TO 109
108	CONTINUE
	STOP' FILE NAME MUST CONTAIN A DOT "."'
109	KFILE(I+1:I+3) = 'COM'
105	OPEN(UNIT=IO20, NAME=KFILE, TYPE='NEW',FORM='FORMATTED')
      WRITE(IO20,104)
  104 FORMAT('$ RUN POWD:[POWDER.LSQ]NBSLSQ')
C *
C *  GET THE RADIATION WAVELENGTH
C *

50    IF( JFILE .EQ. 1 )GO TO 919
      WRITE(ITYP,106)
  106 FORMAT(/' Type in title information identifing the run'/)
      DO 7 I=1,4
    7 IGO(I) = 1
      READ(IREAD,102)TITLE
102	FORMAT(A68)
919      WRITE(ITYP,1)
    1 FORMAT(//' Type in lambda for K alpha 1 (in F10.6)'/
     1' IF CU RADIATION JUST HIT RETURN'/)
      READ(IREAD,5)WAVE1
    5 FORMAT(3F10.6)
C *
C *  GET THE CRUDE CELL DIMENSIONS FOR REFINEMENT
C *
	WRITE(ITYP,110)
110   FORMAT(/' Enter crude values for a,b,c separated by commas')
      READ(IREAD,5)   A,B,C
      WRITE(ITYP,112)
112   FORMAT(/,' Enter the angles for alpha, beta, and gamma')
      READ(IREAD,114) ALPHA,BETA,GAMMA
114   FORMAT(6G)
C *  CONVERT TO ANGLES AND MINUTES FOR CELREF INPUT FORMAT
      I1 = INT( ALPHA )
      A1 = ALPHA - FLOAT( I1 )
      I2 = INT( BETA )
      A2 = BETA - FLOAT( I2 )
      I3 = INT( GAMMA )
      A3 = GAMMA - FLOAT( I3 )
C *  DETERMINE THE CRYSTAL SYSTEM
      IF(I1.EQ.90.AND.A1.EQ.0.) GO TO 200
      ICELL = 1
      IF(I3.NE.60)  GO TO 300
      ICELL = 2
      GO TO 300
200   IF(I2.EQ.90.AND.A2.EQ.0.) GO TO 210
      ICELL = 3
      GO TO 300
210   IF(I3.EQ.90.AND.A3.EQ.0.) GO TO 220
      ICELL = 3
      IF(I3.NE.120) GO TO 220
      ICELL = 4
      GO TO 300
220   IF(C.NE.B) GO TO 230
      ICELL = 5
      GO TO 300
230   IF(A.NE.B) GO TO 240
      ICELL = 6
      GO TO 300
240   ICELL = 7
C *
C *  GET THE H,K,L WITH D/2THETA VALUES
C *
300   IF( JFILE .EQ. 1 )GO TO 1000
C *  WRITE THE TITLE TO THE OUTPUT FILE
      WRITE(IO20,918)ITITLE
918   FORMAT('TITLE   ',A68)
C *  WRITE THE PARAMETER CARD TO THE OUTPUT FILE
      WRITE(IO20,116) A,B,C,I1,A1,I2,A2,I3,A3
116   FORMAT('PARAM '3F9.6,3(I3,F5.2))
C *  GET THE INPUT DATA FROM THE TERMINAL
C      WRITE(ITYP,120)
C120   FORMAT(/'ARE TWO-THETA''S TO BE ENTERED?'/
C     1'    IF ANSWER IS NO, THEN D''S ARE ASSUMED.')
C      READ(IREAD,108) IANS
C      JTHETA = 0
C      IF(IANS.NE.1HY ) JTHETA=1
C      IFLAG = 0
C320   WRITE(ITYP,130)
C130   FORMAT(/' ENTER H,K,L AND D OR 2-THETAS SEPERATED BY COMMAS'
C     1/'AFTER LAST ENTRY, HIT RETURN.')
C330   READ(IREAD,114) J,K,L,D
C      IF(D.EQ.0.) GO TO 400
C      MAX = D
CC *  CONVERT D TO 2THETA
C      IF(JTHETA.EQ.0) GO TO 345
      W=WAVE1
      IF(W.EQ.0.) W=1.540598
C      MAX=2.*RTD*ASIN(W/(2.*D))
345   IF(IFLAG.EQ.0)WRITE(IO20,118)(NAME1(ICELL,M),M=1,2),MAX,WAVE1
118   FORMAT('SYSEXT',A4,A1,I3,F6.4)
      IFLAG = 1
C *  WRITE THE TWO-THETA VALUE
C348   IF(JTHETA.NE.0) GO TO 350
C      WRITE(IO20,132) J,K,L,D
C132   FORMAT(6X,3I5,17X,F9.5)
C      GO TO 330
C *  WRITE THE D VALUE
C350   WRITE(IO20,134) J,K,L,D
C134   FORMAT(6X,3I5,F9.6)
C      GO TO 330
400   WRITE(IO20,136)
136   FORMAT('END',/,'FINISH',/,'!EOD')
      GO TO 2000
C *
C *  GET THE INPUT INFO FROM THE DATA FILE, TITLE FIRST
1000  READ(IO10,1010)(ITITLE(I),I=1,18),WAVE1
      OUTPUT WAVE1
1010  FORMAT(18A4,//,19X,F10.4,//////)
      WRITE(IO20,918)(ITITLE(I),I=1,18)
      WRITE(ITYP,1030)(ITITLE(I),I=1,18)
1030  FORMAT(/,' ',18A4)
C *  WRITE THE PARAMETER CARD TO THE OUTPUT FILE
      WRITE(IO20,116) A,B,C,I1,A1,I2,A2,I3,A3
C *  GET THE D OR TWO-THETA WITH HKL
      NLINES = 0
      IFLAG = 0
      WRITE(ITYP,1020)
1020  FORMAT(/,' For each line read from your input file the ',
     1'hkl values are required.',//,
     2' i will print the d and two-theta value for each line,',/,
     3' follow the prompt by entering the hkl in 3I format.',//,
     4' you can delete a line by entering 0,0,0 for the hkl.')
1040  READ(IO10,1050,END=1090)NUML,TWOTH,DSP,INTSI
1050  FORMAT(1X,I,F8.3,42X,F9.4,2X,I)
      WRITE(ITYP,1060)NUML,TWOTH,DSP,INTSI
1060  FORMAT(/,' Line ',I3,' : ',F8.4,' two-theta,',F8.4,' d sp,',
     1 I3,' rel int')
      READ(IREAD,1070) J,K,L
1070  FORMAT(3I)
      IF( J.EQ.0 .AND. K.EQ.0 .AND. L.EQ.0 ) GO TO 1040
      MAX = INT( TWOTH )
      IF(IFLAG.EQ.0)WRITE(IO20,118)(NAME1(ICELL,M),M=1,2),MAX,WAVE1
      IFLAG = 1
      NLINES = NLINES + 1
      WRITE(IO20,1080) J,K,L,DSP
1080  FORMAT(6X,3I5,F9.6)
      GO TO 1040
C *  INPUT FROM FILE COMPLETED
1090  WRITE(IO20,136)
      WRITE(ITYP,1095) NLINES
1095  FORMAT(/,' *** Input completed,',I3,' lines to be ',
     1'processed')
C *
C *  END OF DATA INPUT
C *
32    WRITE(ITYP,33)
   33 FORMAT(//' Do you wish a second data set run? (yes or no)')
      READ(IREAD,108) ANS
      IF(ANS.EQ.1HY ) GO TO 50
2000  WRITE(ITYP,888)
  888 FORMAT(///' As soon as terminal returns a  !  type'/
     1,' "batch fid" where fid is the name you assigned to'/
     2,' your output file. your job will be run shortly.'/
     3,' pick up your results at the computer center.'/)
      CALL EXIT
      END

       SUBROUTINE ADRIN( DUNK, THUNK, INUNK, NUMDI, TITLE,
     1 AHI, ALO, TIME, STEP, NFILE)
C
C  THIS IS A GENERAL SUBROUTINE READ TO THE d-I INFORMATION
C  FROM AN ADR FILE. 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*40 NFILE
	CHARACTER*1 IDOT, IBL, NAST, IAST
	CHARACTER*68 TITLE
	DIMENSION DUNK(200), THUNK(200), INUNK(200), IT(2), IPE(2)
	DATA IO5,IO6,IO7,IO10,IO20,IO30/5,6,6,10,20,30/
	DATA IDOT, IBL, IAST, IPE/'.', ' ', '*','PE','AK'/
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 you must exit this program and ',
     2'run POWD:[POWDER.GENRAL]FILMOD to create'/
     1' the required file from'
     1' typed input.  The normal format is Siemens'//
     1 '$ENTER your d-I file type: <0>=Siemens (Default), <1>=',
     1 'Alfred, <2>=EXIT: ')
	READ(IO5,535) IFMT
535	FORMAT(I)
	IF(IFMT .GE. 2)STOP 'TYPE RUN POWD:[POWDER.GENRAL]FILMOD'
	IF(IFMT .EQ. 1) IFMT = 2
	IF(IFMT .LE. 0) IFMT = 1
C
C  GET NAME OF THE FILE
C
	WRITE(IO7,540)
540	FORMAT(/'$Enter the name of the ADR d-I file :')
	READ(IO5,550)NFILE
550	FORMAT(A40)
C
C  OPEN THE ADR FILE
C
	OPEN(UNIT=IO30, NAME=NFILE, 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,A68)
	GO TO 600
580	READ(IO30,590,END=710) TITLE
590	FORMAT(12X,A68)
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
770	FORMAT(3X,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( TEMP0 .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
	INUNK(NUMDI) = TEMP1 + 0.5
	IF( NUMDI .LT. 200 )GO TO 750
        WRITE(IO7,810)
810    FORMAT(/1X,'INPUT D-I LIST TRUNCATED TO 200 VALUES')
C
C  TEST OUTPUT ROUTINE
C
C830	CALL OUTPUT( DUNK, THUNK, INUNK, NUMDI, TITLE,
C     1 AHI, ALO, TIME, STEP)
830	RETURN
	CALL EXIT
        END

	SUBROUTINE OUTPUT( DUNK, THUNK, INUNK, NUMDI, TITLE,
     1 AHI, ALO, TIME, STEP)
C
C  THIS SUBROUTINE ALLOWS THE WRITING OF A SEARCHABLE PATTERN WITH A
C  NEW FILE NAME OR WRITING AN EDITED FILE WITH THE ORIGINAL NAME
C
	CHARACTER*68 TITLE
	BYTE NAMEN(16), NAME(16), IBL
	LOGICAL*1 DAT(9)
	DIMENSION INUNK(200),DUNK(200),THUNK(200)
	DATA IO5, IO6, IO7, IO20/5,6,6,6/
	DATA IBL/' '/
400	CALL DATE(DAT)
	WRITE(IO20,2000)DAT,TITLE
2000	FORMAT(//' XRAY POWDER DATA ANALYSIS',/4X,
     1	'MODIFIED PATTERN',/1X,'DATE: ',9A1,//1X,'SAMPLE ID: ',
     2	A68,64X,/1X)
	WRITE(IO20,2001)ALO,TIME,AHI,STEP
2001	FORMAT(1X,'STARTING ANGLE : ',F8.4,5X,'COUNT TIME  : ',
     1	F6.1/1X,'ENDING ANGLE  : ',F9.4,/1X,'ANGLE INCREMENT: ',F8.4)
	WRITE(IO20,2002)
2002	FORMAT(//1X,'PEAK  2-THETA      D     RELINT')
	DO 700 I=1,NUMDI
	WRITE(IO20,1060)I,THUNK(I),DUNK(I),INUNK(I)
1060	FORMAT(1X,I3,2X,F9.5,2X,F7.4,F6.2,I6)
700	CONTINUE
999	RETURN
	END

