C     PROGRAM SET UP LATTICE
C     THE FRONTEND PROGRAM TO SET UP PARAMETERS FOR NBS*LATTICE
C
C
C     GERALD G. JOHNSON JR.
C     MRL/PSU
C     UNIVERSITY PARK PA., 16802
C     814-865-1637
C
C
C     LINKS WITH ITSELF,VALUE,MATRIX,CELLS
C
C
C
      INTEGER ONLY1,ZERO_ALWAYS
      CHARACTER*18 FILEX
      CHARACTER*1 ANS
C
C
C
C

      IOIN=5
      IOOUT=6
      IOFILE=20
      WRITE(IOOUT,1)
1     FORMAT(' PROGRAM TO BUILD INPUT FILE TO NBS*SEARCH'//
     1       10x,'*******************************'/
     1       10X,'NEW FORMAT FOR 1987 NBS (now NIST) PROGRAM'/
     1       10X,'INPUT DATA BUILT FOR PREVIOUS PROGRAM NBS*LATTICE'/
     1       10X,'IS NOT COMPATIBLE WITH NBS*SEARCH !'/
     1       10x,'***********************************'// 
     1       10X,'VAX VERSION SEPT 20, 1988'//)
109   WRITE(IOOUT,1110)
1110  FORMAT(' PLEASE ENTER A NAME FOR THE OUTPUT FILE'/
     1  10X,'IT SHOULD BE OF THE FORM XXXXXXXX.LAT'/
     2  10X,'PLEASE ENTER ONLY XXXXXXX, THE EXTENSION .LAT'/
     3  10X,'WILL BE ADDED BY THE SYSTEM    ',$)
      READ(IOIN,111) FILEX
      IF(FILEX.EQ.' ') GO TO 109
111   FORMAT(A18)
      IKEY=STR$UPCASE(FILEX,FILEX)
      OPEN(UNIT=IOFILE,FILE=FILEX,STATUS='NEW',RECL=80,ERR=109,
     1   CARRIAGECONTROL='LIST',DEFAULTFILE='.LAT')
11    CONTINUE
D      WRITE(IOOUT,222)
222   FORMAT(///' ***** START OF PROBLEM *****')
D      WRITE(IOOUT,2)
2     FORMAT(/' YOU HAVE THE FOLLOWING OPTIONS:'/
     1    5X,'0  EXIT'/
     1    5X,'1  LATTICE MATCH (SEARCHING THE CRYSTAL DATA FILE)'/
     2    5X,'2  REDUCTION AND DERIVATIVE SUPERCELL AND SUBCELL'/
     5    5X,'   PLEASE ENTER YOUR CHOICE:   ',$)
D      READ(IOIN,*,ERR=11) KEY
      KEY=1
      IF(KEY.LT.0.OR.KEY.GT.2) GO TO 11
      IF(KEY.EQ.0) GO TO 999
22    continue
      number=1
d      WRITE(IOOUT,3)
3     FORMAT(' PLEASE ENTER THE NUMBER OF'
     1  1X,'PROBLEM CASES (MAX 20)   ',$)
d      READ(IOIN,*,ERR=22)NUMBER
      IF(NUMBER.LT.1.OR.NUMBER.GT.20) GO TO 22
C*****************************************
      IF(KEY.EQ.1) THEN
      WRITE(IOFILE,100) NUMBER
100   FORMAT('LM   ',I5)
102   WRITE(IOOUT,101)
101   FORMAT(' DO YOU WANT TO SEARCH:'/
     1    5X,'1  59613 INORGANIC (YEARS COVERAGE TO ABOUT 1984)'/
     2    5X,'2  56140 ORGANIC   (YEARS COVERAGE TO ABOUT 1985)'/
     3    5X,'3  BOTH (NOTE WITH THIS CHOICE, YOU CAN NOT COMBINE'/
     4    5X,'       METRIC AND CHEMICAL SEARCH DUE TO DUPLICATION '/
     4    5X,'       OF "UNIQUE" REFERENCE NUMBERS.'/
     4    5X,'4  NEITHER--JUST CELL REDUCTION TO SEE SUPER/SUB CELLS.'/
     4    5X,'PLEASE ENTER YOUR CHOICE: [1] ',$)
      READ(IOIN,6600,ERR=102) NCR,KEY1
6600  FORMAT(Q,I10)
      IF(NCR.EQ.0) KEY1=1
      IF(KEY1.LT.1.OR.KEY1.GT.4) GO TO 102
      IF(KEY1.EQ.4) THEN
                    TOLE=0.0
                    TOLA=0.0
                    TOLV=0.0
                    NZERO=1
                    GO TO 13001
      ENDIF
9999  WRITE(IOOUT,4000)
4000  FORMAT(/' PLEASE ENTER THE TOLERANCE FOR THE CELL EDGE'/
     1   5X,'VALUE OF 0.1 IS IN ANGSTROMS'/
     1   5X,'SUGGESTED VALUES 0.02 TO 0.50 [DEFAULT 0.10]   ',$)
      READ(IOIN,149,ERR=9999) L,TOLE
149   FORMAT(Q,F10.0)
      IF(L.EQ.0) TOLE=0.10
      IF(TOLE.LT.0.02) GO TO 9999
      IF(TOLE.GT.0.50) GO TO 9999
29999  WRITE(IOOUT,24000)
24000  FORMAT(' PLEASE ENTER THE TOLERANCE FOR THE CELL ANGLES.'/
     1   5X,'IF THE VALUE IS SET EQUAL TO 60.0, THIS PARAMETER'/
     1   5X,'WILL NOT SELECT/REJECT ENTRIES, SINCE THE REDUCED'/
     1   5X,'ANGLES ARE ALWAYS IN THE RANGE 60-120.'/
     1   5X,'SUGGESTED VALUES 1.00 TO 60.0 [DEFAULT 60.0]   ',$)
      READ(IOIN,9149,ERR=9999) L,TOLA
9149  FORMAT(Q,F10.0)
      IF(L.EQ.0) TOLA=60.0
      IF(TOLA.LT.1.00) GO TO 29999
      IF(TOLA.GT.60.0) GO TO 29999
989   WRITE(IOOUT,1001)
1001  FORMAT(' PLEASE ENTER THE TOLERANCE FOR THE CELL VOLUME'/
     1   5X,'THIS VALUE IS IN PERCENTAGE'/
     1   5X,'SUGGESTED VALUES 5.0 TO 20.0  [DEFAULT 10.0]   ',$)
      READ(IOIN,149,ERR=989)L,TOLV
      IF(L.EQ.0) TOLV=10.0
      IF(TOLV.LT.5.0) GO TO 989
      IF(TOLV.GT.20.0)GO TO 989
1200   WRITE(IOOUT,201)
201   FORMAT(' DO YOU WANT TO SEE THE PRINTOUT OF BOTH'/
     1     10X,'SUPER AND/OR SUB-CELL.'/
     2     10X,'FOR LATTICE MATCHING THIS IS USUALLY NO'/
     3     10X,'FOR VIEWING SUPER/SUB CELLS THIS IS YES'/
     4     01X,'YOUR RESPONSE PLEASE (Y/[N])  ',$)
      READ(IOIN,202) NCR,ANS
202   FORMAT(Q,A)
      KEY=STR$UPCASE(ANS,ANS)
      IF(NCR.EQ.0) ANS='N'
      NZERO=-1
      IF(ANS.EQ.'Y') THEN
                     NZERO=1
      ENDIF
      IF(ANS.EQ.'N') NZERO=0
      IF(NZERO.EQ.(-1)) GO TO 1200
13001 IF(KEY1.EQ.1) WRITE(IOFILE,110)TOLE,TOLA,TOLV,NZERO
110   FORMAT(F10.4,F10.4,F10.4,4X,'I',4X,I1)
      IF(KEY1.EQ.2) WRITE(IOFILE,120)TOLE,TOLA,TOLV,NZERO
120   FORMAT(F10.4,F10.4,F10.4,4X,'O',4X,I1)
      IF(KEY1.EQ.3) WRITE(IOFILE,130)TOLE,TOLA,TOLV,NZERO
130   FORMAT(F10.4,F10.4,F10.4,3X,'IO',4X,I1)
      IF(KEY1.EQ.4) WRITE(IOFILE,6120)TOLE,TOLA,TOLV,NZERO
6120  FORMAT(F10.4,F10.4,F10.4,4X,'I',4X,I1)
      WRITE(6,3737)
3737  FORMAT(/' THE FOLLOWING TABLE WILL ILLUSTRATE THE NUMBER'/
     1 10X,'OF RESULTS FOR SUPER/SUB CELLS.'//
     1 10X,'N  RESULTS TOTAL'/
     2 10X,'2     7      7'/
     3 10X,'3    13     20'/
     4 10X,'4    35     55'/
     5 10X,'5    31     86'/
     6 10X,'6    91    177'/
     7 10X,'7    57    234'/
     8 10X,'8   155    389'/
     9 10X,'9   130    519')
      CALL VALUE(NUMBER)
d      GO TO 11
      go to 5000
      ENDIF
C*****************************************
      IF(KEY.EQ.2) THEN
      WRITE(IOFILE,200) NUMBER
      CALL VALUE(NUMBER)
200   FORMAT('RSS  ',I5)
d      GO TO 11
      go to 5000
      ENDIF
C*****************************************
      IF(KEY.EQ.3) THEN
      ONLY1=1
      WRITE(IOFILE,300) NUMBER
      DO 501 LOOP=1,NUMBER
      CALL MATRIX(ONLY1)
      CALL CELL
501   CONTINUE
300   FORMAT('TRANS',I5)
      GO TO 11
      ENDIF
C*****************************************
      IF(KEY.EQ.4) THEN
      WRITE(IOFILE,400) NUMBER
      CALL MATRIX(NUMBER)
400   FORMAT('INV  ',I5)
      GO TO 11
      ENDIF
C*****************************************
5000  CONTINUE
999   STOP 'END OF SET UP LATTICE PROGRAM'
      END
