SUBROUTINE VALUE (NUMBER) C C C C C CHARACTER*1 C1,C2,CCP,CCA,CCB,CCC,CCF,CCI,CCR,CCH CHARACTER*1 ANS C C C C CCP='P' CCA='A' CCC='C' CCF='F' CCI='I' CCR='R' CCH='H' C C IOIN=5 IOOUT=6 IOFILE=20 C C C DO 5000 ITOTAL=1,NUMBER ICOL1=0 N1=0 N2=0 WRITE(IOOUT,6000) 6000 FORMAT(/' **** START OF NEW CASE ****') 1301 WRITE(IOOUT,1302) 1302 FORMAT(' DO YOU WANT TO DO:'/ 1 5X,'0. NO REDUCTION / SUPERCELLS / SUBCELLS'/ 2 5X,'1. REDUCTION AND SUPERCELLS'/ 3 5X,'2. REDUCTION AND SUBCELLS'/ 4 5X,'3. REDUCTION, SUPERCELLS, AND SUBCELLS'/ 5 5X,' PLEASE ENTER YOUR CHOICE: [3] ',$) READ(IOIN,3434,ERR=1301,END=999) NCR,ICOL1 3434 FORMAT(Q,I10) IF(NCR.EQ.0) ICOL1=3 IF(ICOL1.LT.0 .OR. ICOL1.GT.3) GO TO 1301 1303 IF(ICOL1.EQ.0) GO TO 139 WRITE(IOOUT,1304) 1304 FORMAT(' DO YOU WANT TO CALCULATE DERIVATIVE LATTICES ?', 1 1X,'(Y OR N) [Y] ',$) READ(IOIN,1305,END=999) NCR,ANS 1305 FORMAT(Q,1A1) IF(NCR.EQ.0) ANS='Y' IKEY=STR$UPCASE(ANS,ANS) IF(ANS.EQ.'Y' .OR. ANS.EQ.'N') GO TO 1306 GO TO 1303 1306 IF(ANS.EQ.'N') GO TO 139 1401 WRITE(IOOUT,1402) 1402 FORMAT(' PLEASE ENTER THE INITIAL VALUE--TO DEFINE THE', 1 1X,'RANGE OF VOLUMES OF'/5X,'THE CALCULATED DERIVATIVE', 2 1X,'LATTICES (2,3,4,5,6,7,8, OR 9) ' / 3 1X,'SUGGESTED VALUE NOT TO EXCEED 4 [2] ',$) READ(IOIN,3456,ERR=1401,END=999) NCR,N1 3456 FORMAT(Q,I10) IF(NCR.EQ.0) N1=2 IF(N1.EQ.1) GO TO 1401 IF(N1.LT.2 .OR. N1.GT.9) GO TO 1401 1501 WRITE(IOOUT,1502) 1502 FORMAT(' PLEASE ENTER THE FINAL VALUE---TO DEFINE THE', 1 1X,'RANGE OF VOLUMES OF'/5X,'THE CALCULATED DERIVATIVE', 2 1X,'LATTICES (2,3,4,5,6,7,8, OR 9) '/ 3 1X,'SUGGESTED VALUE NOT TO EXCEED 4 [4] ',$) READ(IOIN,3456,ERR=1501,END=999) NCR,N2 IF(NCR.EQ.0) N2=4 IF(N2.EQ.1) GO TO 1501 IF(N2.LT.2 .OR. N2.GT.9) GO TO 1501 IF(N2.LT.N1) THEN WRITE(6,26000) 26000 FORMAT(' FINAL VALUE MUST BE GREATER THAN INITIAL VALUE') GO TO 1401 ENDIF 139 WRITE(IOOUT,13911) 13911 FORMAT(/' **** NOTE **** ENTER DECIMAL VALUES') WRITE(IOOUT,140) 140 FORMAT(' PLEASE ENTER A [ NO DEFAULT ] ',$) READ(IOIN,1234,ERR=139,END=999)L, A 1234 FORMAT(Q,F10.2) IF(L.EQ.0) GO TO 139 IF(A.LT.0.5.OR.A.GT.50.0) GO TO 139 149 WRITE(IOOUT,150) 150 FORMAT(' PLEASE ENTER B [ DEFAULT B=A] ',$) READ(IOIN,1234,ERR=149,END=999) L,B IF(L.EQ.0) B=A IF(B.LT.0.5.OR.B.GT.50.0) GO TO 149 159 WRITE(IOOUT,160) 160 FORMAT(' PLEASE ENTER C [ DEFAULT C=B] ',$) READ(IOIN,1234,ERR=159,END=999) L,C IF(L.EQ.0) C=B IF(C.LT.0.5.OR.C.GT.50.0) GO TO 159 ANGLE=90.0 169 WRITE(IOOUT,170) ANGLE=90.0 170 FORMAT(' PLEASE ENTER ALPHA [ DEFAULT = 90.0 ] ',$) READ(IOIN,1234,ERR=169,END=999)L,ALPHA IF(L.EQ.0) ALPHA=ANGLE IF(ALPHA.LT.30.0.OR.ALPHA.GT.150.0) GO TO 169 179 WRITE(IOOUT,180) 180 FORMAT(' PLEASE ENTER BETA [ DEFAULT = ALPHA] ',$) READ(IOIN,1234,ERR=179,END=999) L,BETA IF(L.EQ.0) BETA=ALPHA IF(BETA.LT.30.0.OR.BETA.GT.150.0) GO TO 179 189 WRITE(IOOUT,190) 190 FORMAT(' PLEASE ENTER GAMMA [ DEFAULT = BETA ] ',$) READ(IOIN,1234,ERR=189,END=999) L,GAMMA IF(L.EQ.0) GAMMA=BETA IF(GAMMA.LT.30.0.OR.GAMMA.GT.150.0) GO TO 189 2000 WRITE(IOOUT,12000) C1=' ' C2=' ' 12000 FORMAT(' PLEASE ENTER THE CELL CENTERING'/ 1 5X,'P/A/B/C/F/I/R ' / 2 5X,'(FOR ELECTRON DIFFRACTION, CONSIDER P) ',$) READ(IOIN,2001,END=999)C1 2001 FORMAT(1A1) IKEY=STR$UPCASE(C1,C1) IF(C1.EQ.CCA .OR. C1.EQ.CCB .OR. C1.EQ.CCC .OR. 1 C1.EQ.CCP .OR. C1.EQ.CCF .OR. C1.EQ.CCI .OR. 2 C1.EQ.CCR) GO TO 2010 GO TO 2000 2010 IF(C1.EQ.CCR) THEN 2011 WRITE(IOOUT,2002) 2002 FORMAT(' PLEASE ENTER R OR H FOR RHOMBOHEDRAL LATTICES ',$) READ(IOIN,2001,END=999)C2 IKEY=STR$UPCASE(C2,C2) IF(C2.EQ.CCR .OR. C2.EQ.CCH) GO TO 2030 GO TO 2011 ENDIF 2030 WRITE(IOFILE,1000) ICOL1,N1,N2,C1,C2,A,B,C, 1 ALPHA,BETA,GAMMA 1000 FORMAT(I1,2X,2I1,3X,2A1,6F10.4) 5000 CONTINUE RETURN 999 STOP 'ABNORMAL END OF FILE' END