*      PROGRAM PFSR(TAPE3=O"1001",TAPE4=O"1001",TAPE5=O"1001",TAPE6,OUTPU
*     * T=O"301",TAPE7=OUTPUT,TAPE8=O"10001")
      PROGRAM DBWS
C   PROGRAM FOR RIETVELD ANALYSIS OF X-RAY AND NEUTRON (NUCLEAR SCATTERING
C       ONLY) POWDER DIFFRACTION PATTERNS
C   VERSION DBWS-9006, RELEASE 21.11.90
C   SCHOOL OF PHYSICS (R. A. YOUNG)
C   GEORGIA INSTITUTE OF TECHNOLOGY, ATLANTA, GA. 30332  USA
C   PRECURSOR PROGRAM, DBW3.2, WRITTEN BY D. B. WILES
C   MUCH OF SUBROUTINE SPGP AND RELATED SYMMETRY AND MULTIPLICITY
C       CALCULATIONS TAKEN FROM `SPGP' BY ALLEN C. LARSON
C   DBW3.2S CREATED BY A. SAKTHIVEL BY MODIFICATION OF DBW3.2
C   DURING JAN 86 - AUG 88.
C   DBWS-9006 CREATED BY A. SAKTHIVEL APR-JUN 90. MARCH-DOLLASE PREFERRED
C       ORIENTATION ADDED, ANSI FILE OPEN CHANGES MADE
C   INPTR MOD 12.6.90 TO USE SRS DATA
C   NEW TYPO RE IOF IN CALCUL AFTER LINE 4340 CORRECTED  17.8.90
C   FUNCTION MULT MOD 21.11.90 PER RJ HILL TO CORRECT 0KL MULTIPLICITY
C       IN POINT GROUP 2/M
C   PROGRAM, USER'S GUIDE AND TEST CASE AVAILABLE FROM PROF. R. A. YOUNG
C       AT ABOVE ADDRESS
*
*     Modified by David P. Matheis    1991
*                 New York State College of Ceramics
*                 Alfred University  Alfred, NY 14802
*     To include refinement of incommensurate modulated structures
*
*     modifications for vax use indicated by ***vax 
*
      PARAMETER (idsz=16384,irs=2048,NATS=64,msz=128 ,nov=512)
C     CHANGE THESE VARIABLES TO SUIT THE SIZE OF THE COMPUTER AND THE PROBLEM
C     IDSZ = MAXIMUM NUMBER OF DATA POINTS IN TAPE 4
C     IRS  = MAXIMUM NUBMER OF REFLECTIONS IN THE PATTERN
C     NATS = MAXIMUM NUMBER OF ATOMS IN THE PROBLEM
C     MSZ  = MAXIMUM NUMBER OF REFINABLE PARAMETERS (MATRIX SIZE)
C     NOV  = MAXIMUM NUMBER OF BRAGG REFLECTIONS CONTRIBUTING TO ONE STEP
      REAL LAMDA
      INTEGER PTR
      COMMON/DC/SAVE(8,6),NSAVE
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      COMMON/ALLP/FINAL(8*MSZ,2),ILOC
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      COMMON/RTMTX/IVEC(8,192),MLT(8),ICET(8)
***mod
      CHARACTER*40   QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
      COMMON/QFILES/ QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
      common/vax/ lvax
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      character ssgrp*1,qmodbc*20,qmodac*10
      logical lvax,lqmod
***mod
***vax: For multi-user vax use set lvax to .true.
      lvax = .true.
***vax
      if(.not.lvax)then
        open (4,file='ps1286fs.xda',status='old')
        open (5,file='rfap.new',status='old')
        open (6,file='junk1.lis',status='new')
      endif
      open (7,file='unit7.dat',status='new')
      open (8,file='unit8.dat',form='unformatted',status='new')
***** file unit number specifiers
*     unit=5 => input control file
*     unit=4 => input data file
*     unit=6 => output list file
*****
      CALL INPTR
      CALL ITER
      IF (MAXS.GT.0) THEN
        MCYCLX = MCYCLE
        MAXSX  = MAXS
        MCYCLE = 1
        MAXS   = 0
        CALL ITER
        MCYCLE = MCYCLX
        MAXS   = MAXSX
      END IF
      CALL EXPUT
      close (4)
      close (5)
      close (6)
      close (7)
      close (8)
      STOP
      END
      SUBROUTINE COEF(J,K)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/CNV/N,SINLAM(30),F(30)
      DIMENSION AB(10)
      EXTERNAL CV1,CV2
      DO 10 I=1,K
        SINLAM(I)=POSI(I)*POSI(I)
10      F(I)=SCAT(I)
      N=K
      NN=MIN0(N,9)
      DO 15 I=1,NN
15      AB(I)=I
      NN1=NN+1
      DO 16 I=NN1,10
16      AB(I)=0
      CALL STEEP(AB,3,10,CV2,CV1)
      IF(AB(3).EQ.0.)AB(3)=-1E-6
      DO 20 I=1,9
20      AC(I,J)=AB(I)
      RETURN
      END
      SUBROUTINE CV1(AB,V)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/CNV/N,SINLAM(30),F(30)
      DIMENSION AB(10),V(10)
      MAXX=MIN0(9,N)
      DO 30 K=1,MAXX,2
        V(K)=0
        DO 20 I=1,N
          V(K)=V(K)+F(I)
          DO 20 J=1,MAXX,2
20          V(K)=V(K)-AB(J)*EXP(-AB(J+1)*SINLAM(I))
        V(K)=-2.*V(K)*EXP(-AB(K+1)*SINLAM(K))
30      V(K+1)=-V(K)*SINLAM(K)*AB(K)
      NN=MAXX+1
      DO 10 I=NN,10
10      V(I)=0
      RETURN
      END
      SUBROUTINE CV2(AB,G)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/CNV/N,SINLAM(30),F(30)
      DIMENSION AB(10)
      MAXX=MIN0(9,N)
      G=0
      DO 30 I=1,N
        T=F(I)
        DO 20 J=1,MAXX,2
20        T=T-AB(J)*EXP(-AB(J+1)*SINLAM(I))
30      G=G+T*T
      RETURN
      END
      SUBROUTINE SPGP(SPG)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C
C                             THIS SR INTERPRETS THE SPACE GROUP SYMBOL
C                           AND GENERATES OPERATORS WHICH SYMOPR USES TO
C                           GENERATE THE FULL SET OF EQUIVALENT
C                           POSITIONS AND OP1 AND SMTRY2 USE TO GENERATE
C                           THE FULL SET OF EQUIVALENT INDICES.
      CHARACTER*1 SPG(20),CHR(25)
      DIMENSION L(4,4),ICO(6,15)
      COMMON /SPG/NSP(2),NCONT(10),FILL(3)
      common/vax/ lvax
      logical lvax
      DIMENSION NDAT(7)
***vax modification
      INTEGER AND,OR
      AND(I,J) = IAND(I,J)
      OR(I,J) = IOR(I,J)
***vax
      LODGDF(I,J) = AND(ieOR(I,J),307)
1     FORMAT (20H0THE SPACE GROUP IS ,80A1)
2     FORMAT (34H1DID YOU PUNCH THE CARD CORRECTLY.,/,
     *  35H ERRORS OF SOME SORT WERE DETECTED.,/,
     *   22H0THE CARD WAS READ AS ,80A1)
24    FORMAT (34H0A CENTER IS PRESENT, NOT AT 0,0,0)
      DATA NDAT(1),NDAT(2),NDAT(3),NDAT(4),NDAT(5),NDAT(6),NDAT(7)/
     * 3,1,2,0,2,1,3/
      DATA CHR(1),CHR(2),CHR(3),CHR(4),CHR(5),CHR(6),CHR(7),CHR(8),
     * CHR(9),CHR(10),CHR(11),CHR(12),CHR(13),CHR(14),CHR(15),CHR(16),
     *  CHR(17),CHR(18),CHR(19),CHR(20),CHR(21)/' ','C','B','A','P',
     *   'F','I','R','M','N','D','1','2','3','4','5','6','-','/','H','.'
     * /
CDB 2
C     PRINT 8,CHR
C   8 FORMAT (1X25A1)
      WRITE(6,1)SPG
      DO 97 I=1,6
        DO 97 J=1,15
97        ICO(I,J)=0
      DO 98 I=1,4
        DO 98 J=1,4
98        L(I,J) = 0
      M2 = 0
      K = 1
      M = 1
      NSP(1) = 0
      NSP(2) = 0
      N = 0
      DO 110 J=1,20
99      DO 100 I=1,21
          IF ( SPG(J).EQ.CHR(I) ) GO TO 101
100       CONTINUE
CDB 2
C     PRINT 7,SPG(J),J
C   7 FORMAT (1XA1* IS AN UNRECOGNIZABLE CHARACTER IN COL. *I2)
        GO TO 110
101     IF ( K+M+I.EQ.3 ) GO TO 110
        IF ( I.EQ.1 ) GO TO 108
        L(M,K) = I
        N = 0
        M = M+1
        IF ( M-4 ) 110,110,108
108     IF ( N.EQ.1 ) GO TO 110
        N = 1
        M = 1
        K = K+1
        IF ( K.GT.4 ) GO TO 200
110     CONTINUE
200   IF ( K.LE.2 ) GO TO 500
CDB 3
C     PRINT 3,N,M,K,J,L
C   3 FORMAT (*0N =*I3*  M =*I3*  K =*I3*  J =*I3/
C    1  * L =*4I4/(4X4I4))
      IF ( L(1,1).GT.8 ) GO TO 500
      J = 1
      I = L(1,1)-1
      GO TO (203,202,201,119,204,205,206),I
      CALL GOTOER
201   NCONT(J) = 576
      GO TO 209
202   NCONT(J) = 516
      GO TO 209
203   NCONT(J) = 68
      GO TO 209
204   NCONT(J) = 576
      J = J+1
      GO TO 202
205   NCONT(J) = 580
      GO TO 209
207   K = K-1
      NSP(1) = K+3
      GO TO 210
206   IF ( L(1,3).EQ.8.OR.L(1,4).EQ.8 ) GO TO 207
      NCONT(J) = 8192
      IF ( L(1,K-1).EQ.20 ) K=K-1
      NSP(1) = K+5
      J = J+1
      GO TO 210
209   J = J+1
119   IF ( K-4 ) 120,130,140
120   IF ( L(1,2).EQ.18 ) GO TO 121
      IF ( L(1,2).EQ.17 ) GO TO 122
      IF ( L(1,2).EQ.14 ) GO TO 123
      IF ( L(1,2).EQ.15 ) GO TO 124
      IF ( L(1,2).EQ.12 ) GO TO 125
      NSP(1) = 2
      NSP(2) = 2
      GO TO 210
121   IF ( L(2,2).EQ.17 ) GO TO 122
      IF ( L(2,2).EQ.14 ) GO TO 123
      IF ( L(2,2).EQ.15 ) GO TO 124
      IF ( L(2,2).EQ.12 ) GO TO 125
      GO TO 500
122   NSP(1) = 11
      GO TO 210
123   NSP(1) = 8
      GO TO 210
124   NSP(1) = 4
      GO TO 210
125   NSP(1) = 1
      GO TO 210
130   IF ( L(1,3).NE.14 ) GO TO 500
      NSP(1) = 13
      GO TO 210
140   IF ( L(1,3).EQ.14 ) GO TO 151
      IF ( L(1,2).EQ.18 ) GO TO 152
      IF ( L(1,2).EQ.17 ) GO TO 153
      IF ( L(1,2).EQ.14 ) GO TO 154
      IF ( L(1,2).EQ.15 ) GO TO 155
      IF ( L(1,2).EQ.12 ) GO TO 141
      IF ( L(1,3).EQ.12 ) GO TO 142
      IF ( L(1,4).EQ.12 ) GO TO 500
      NSP(1) = 3
      GO TO 210
141   IF ( L(1,3).EQ.12 ) GO TO 143
      IF ( L(1,4).NE.12 ) GO TO 500
      NSP(1) = 2
      NSP(2) = 2
      GO TO 210
142   IF ( L(1,4).NE.12 ) GO TO 500
      NSP(1) = 2
      NSP(2) = 1
      GO TO 210
143   IF ( L(1,4).EQ.12 ) GO TO 500
      NSP(1) = 2
      NSP(2) = 3
      GO TO 210
151   NSP(1) = 14
      GO TO 210
152   IF ( L(2,2).EQ.17 ) GO TO 153
      IF ( L(2,2).EQ.14 ) GO TO 154
      IF ( L(2,2).EQ.15 ) GO TO 155
      GO TO 500
153   NSP(1) = 12
      GO TO 210
154   IF ( L(1,3).EQ.12 ) GO TO 156
      IF ( L(1,4).NE.12 ) GO TO 500
      NSP(1) = 9
      GO TO 210
155   NSP(1) = 5
      GO TO 210
156   IF ( L(1,4).EQ.12 ) GO TO 123
      NSP(1) = 10
210   K = K-1
CDB 2
C     PRINT 4,K,NSP,J,NCONT
C   4 FORMAT (*0K =*I3*  NSP =*2I4*  J=*I3/* NCONT =*10I4)
      N = 1
      DO 300 M=2,K
        IF ( L(1,M).EQ.0 ) GO TO 500
218     I = IABS(L(1,M)-5)
219     IF ( I.LE.0.OR.I.GT.15 ) GO TO 500
C              A   B   C   M   N   D   1   2   3   4   5   6   -   /
        GO TO (220,220,220,220,220,245,250,255,260,265,500,270,275,300,
     *      300),I
        CALL GOTOER
C        H
220     GO TO (500,221,222,223),M
        CALL GOTOER
221     IF ( L(1,3).EQ.14 ) GO TO 2230
        IF ( L(1,2).EQ.15 ) GO TO 2230
        IF ( L(1,2).EQ.17 ) GO TO 2230
        IF ( K.EQ.2 ) GO TO 2220
2210    ICO(1,N) = 2
        ICO(2,N) = 0
        ICO(3,N) = 0
        ICO(4,N) = 4
        IF ( I.EQ.2.OR.I.EQ.5 ) ICO(5,N) = 1
        IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
2211    N = N+1
        IF ( L(1,2).NE.15 ) GO TO 300
        ICO(1,N) = ICO(2,N-1)
        ICO(2,N) = ICO(1,N-1)
        ICO(3,N) = ICO(3,N-1)
        ICO(4,N) = ICO(5,N-1)
        ICO(5,N) = ICO(4,N-1)
        ICO(6,N) = ICO(6,N-1)
        N= N+1
        GO TO 300
222     IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 225
        IF ( L(1,2).EQ.15 ) GO TO 2210
2220    ICO(1,N) = 0
        ICO(2,N) = 2
        ICO(3,N) = 0
        ICO(5,N) = 4
        IF ( I.EQ.1.OR.I.EQ.5 ) ICO(4,N) = 1
        IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
        N = N+1
        GO TO 300
223     IF ( L(1,3).EQ.14.OR.L(1,2).EQ.15 ) GO TO 224
        IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 224
2230    ICO(1,N) = 0
        ICO(2,N) = 0
        ICO(3,N) = 2
        ICO(6,N) = 4
        IF ( I.EQ.1.OR.I.EQ.5 ) ICO(4,N) = 1
        IF ( I.EQ.2.OR.I.EQ.5 ) ICO(5,N) = 1
        N = N+1
        IF ( M.EQ.2.AND.L(1,2).EQ.15.AND.I.EQ.5 ) ICO(4,N-3)=1
        IF ( M.NE. 2.OR.L(1,2).NE.17) GO TO 300
        IF ( L(1,3).EQ.2 ) ICO(6,N-1)=1
        IF ( L(1,4).EQ.2 ) ICO(6,N-1)=MOD(ICO(6,N-1)+1,2)
        GO TO 300
224     ICO(1,N) = 1
        ICO(2,N) = 1
        ICO(3,N) = 0
        ICO(4,N) = 4
        ICO(5,N) = 4
        IF ( I.EQ.3.OR.I.EQ.5 ) ICO(6,N) = 1
        IF ( NSP(1).EQ.7.AND.I.EQ.3 ) GO TO 2240
        IF ( I.NE.5 ) GO TO 226
2240    ICO(4,N) = 5
        ICO(5,N) = 5
        N = N+1
        GO TO 300
225     IF ( NSP(1).EQ.7 ) GO TO 224
        ICO(1,N) = 3
        ICO(2,N) = 3
        ICO(3,N) = 0
        ICO(4,N) = 4
        ICO(5,N) = 4
        IF ( I.EQ.3 ) ICO(6,N) = 1
226     N = N+1
        GO TO 300
C    D TYPE MIRROR
245     GO TO (500,246,247,248),M
        CALL GOTOER
246     IF ( K.EQ.2 ) GO TO 247
        ICO(1,N) = 2
        ICO(2,N) = 0
        ICO(3,N) = 0
        ICO(4,N) = 6
        ICO(5,N) = 6
        ICO(6,N) = 6
        N = N+1
        GO TO 300
247     ICO(1,N) = 0
        ICO(2,N) = 2
        ICO(3,N) = 0
        ICO(4,N) = 6
        ICO(5,N) = 6
        ICO(6,N) = 6
        N = N+1
        GO TO 300
248     IF ( L(1,2).EQ.15.OR.L(1,3).EQ.14 ) GO TO 249
        ICO(1,N) = 0
        ICO(2,N) = 0
        ICO(3,N) = 2
        ICO(4,N) = 6
        ICO(5,N) = 6
        ICO(6,N) = 6
        N = N+1
        GO TO 300
249     ICO(1,N) = 1
        ICO(2,N) = 1
        ICO(3,N) = 0
        ICO(4,N) = 6
        ICO(5,N) = 6
        ICO(6,N) = 6
        IF (L(1,3).NE.13) GO TO 226
        ICO(4,N) = 0
        ICO(5,N) = 1
        N = N+1
        GO TO 300
C    1 FOLD ROTATION
250     IF ( L(2,M).NE.3 ) GO TO 300
        ICO(1,N) = 2
        ICO(2,N) = 2
        ICO(3,N) = 2
        ICO(4,N) = 4
        ICO(5,N) = 4
        ICO(6,N) = 4
        N = N+1
        GO TO 300
255     GO TO (500,256,257,258),M
        CALL GOTOER
C    2 FOLD ROTATION
256     IF ( K.EQ.2 ) GO TO 2571
2561    ICO(1,N) = 0
        ICO(2,N) = 2
        ICO(3,N) = 2
        ICO(4,N) = 0
        ICO(5,N) = 4
        ICO(6,N) = 4
        IF ( IABS(L(2,M)-13).EQ.1 ) ICO(4,N) = 1
2560    N = N+1
        DO 2562 I=2,4
          IF ( L(I,M).EQ.19 ) GO TO 2563
2562      CONTINUE
        GO TO 300
2563    IF ( L(I+1,M).LE.1 ) GO TO 500
        I = IABS(L(I+1,M)-5)
        GO TO 219
257     IF ( L(1,2).EQ.14.OR.L(1,2).EQ.17 ) GO TO 259
2571    ICO(1,N) = 2
        ICO(2,N) = 0
        ICO(3,N) = 2
        ICO(4,N) = 4
        ICO(5,N) = 0
        ICO(6,N) = 4
        IF ( L(2,M).EQ.12 ) ICO(5,N)=1
        IF ( L(1,2).EQ.15 ) GO TO 2211
        GO TO 2560
258     IF ( L(1,2).GE.14   ) GO TO 2595
        IF ( L(1,3).EQ.14 ) GO TO 259
2581    ICO(1,N) = 2
        ICO(2,N) = 2
        ICO(3,N) = 0
        ICO(4,N) = 4
        ICO(5,N) = 4
        ICO(6,N) = 0
        IF ( IABS(L(2,M)-13).EQ.1 ) ICO(6,N) = 1
        IF (      L(2,M).EQ.16    ) ICO(6,N) = 1
        GO TO 2560
259     IF ( L(1,3).EQ.8.OR.L(1,4).EQ.8 ) GO TO 2595
        ICO(1,N) = 1
        ICO(2,N) = 1
        ICO(3,N) = 2
        ICO(4,N) = 0
        ICO(5,N) = 0
        ICO(6,N) = 4
        GO TO 2560
2595    IF ( L(1,2).EQ.15)GO TO 259
        ICO(1,N) = 3
        ICO(2,N) = 3
        ICO(3,N) = 2
        ICO(4,N) = 4
        ICO(5,N) = 4
        ICO(6,N) = 4
        GO TO 2560
C    3 FOLD ROTATION
260     GO TO (500,261,262,500),M
        CALL GOTOER
261     IF ( L(1,1).EQ.8.AND.J.EQ.1 ) GO TO 262
        IX = 0
        IF ( L(2,M).EQ.12 ) GO TO 2611
        IF ( L(2,M).EQ.13 ) GO TO 2612
2610    NCONT(J) = 8196
        GO TO 2613
2611    NCONT(J) = 8200
        IF ( L(1,4).NE.13 ) GO TO 2613
        J = J+1
        NCONT(J) = 2321
        IF ( L(1,2).EQ.14 ) NCONT(J)=4403
        L(1,3) = 12
        L(1,4) = 12
        GO TO 2613
2612    NCONT(J) = 8204
        IF ( L(1,4).NE.13 ) GO TO 2613
        J = J+1
        NCONT(J) = 4369
        IF ( L(1,2).EQ.14 ) NCONT(J)=2355
        L(1,3) = 12
        L(1,4) = 12
2613    J = J+1
        IF ( IX-1 ) 250,2581,2230
C    CUBIC OR RHOMBOHEDERAL
262     NCONT(J) = 16384
        IF (L(2,M).NE.3 ) GO TO 2620
        J = J+1
        NCONT(J) = 290
2620    J = J+1
        IF ( N.EQ.1 ) GO TO 300
        I = N-1
        IN1 = N
        IN2 = N+1
        ICO(1,IN1) = ICO(3,I)
        ICO(2,IN1) = ICO(1,I)
        ICO(3,IN1) = ICO(2,I)
        ICO(4,IN1) = ICO(6,I)
        ICO(5,IN1) = ICO(4,I)
        ICO(6,IN1) = ICO(5,I)
        ICO(1,IN2) = ICO(2,I)
        ICO(2,IN2) = ICO(3,I)
        ICO(3,IN2) = ICO(1,I)
        ICO(4,IN2) = ICO(5,I)
        ICO(5,IN2) = ICO(6,I)
263     ICO(6,IN2) = ICO(4,I)
        N = IN2+1
        GO TO 300
265     IF ( M.NE.2 ) GO TO 500
        ICO(1,N) = 3
        ICO(2,N) = 1
        ICO(3,N) = 0
        ICO(4,N) = 4
        ICO(5,N) = 4
        ICO(6,N) = 0
        IF ( L(2,2).EQ.12 ) ICO(6,N) = 2
        IF ( L(2,2).EQ.13 ) ICO(6,N) = 1
        IF ( L(2,2).EQ.14 ) ICO(6,N) = 3
        IF ( L(2,2).EQ. 3 ) ICO(3,N) = 2
        N = N+1
        IF ( L(2,2).EQ.3.AND.L(1,3).EQ.14.AND.L(1,4).EQ.11 ) GO TO 266
        IF ( L(1,3).EQ.14 ) GO TO 2561
        IF ( K.GT.2.OR.L(1,1).NE.7 ) GO TO 2581
        IF ( L(2,2)+L(3,2).NE.12 ) GO TO 2581
        L(2,2) = 0
        ICO(5,N-1) = 1
        GO TO 2581
266     IF ( L(1,1).NE.7.OR.L(1,2).NE.15 ) GO TO 500
        NCONT(J  ) = 16384
        NCONT(J+1) = 356
        NCONT(J+2) = 834
        NCONT(J+3) = 1177
        J = J+3
        GO TO 410
270     IF ( M.NE.2 ) GO TO 500
        IX = 1
        IF ( L(2,2).EQ.12 ) GO TO 2611
        IF ( L(2,2).EQ.13 ) GO TO 2612
        IF ( L(2,2).EQ.14 ) GO TO 2610
        IF ( L(2,2).EQ.15 ) GO TO 2611
        IF ( L(2,2).EQ.16 ) GO TO 2612
        IF ( L(2,2).EQ. 3 ) GO TO 271
        GO TO 2610
271     IX = 2
        GO TO 2610
275     IF ( M.NE.2 ) GO TO 500
        L(1,2) = L(2,2)
        L(2,2) = 3
        GO TO 218
300     CONTINUE
      N = N-1
      IJ = J
      IF ( N.GT.0 ) GO TO 301
      J = J-1
      GO TO 410
301   DO 305 I=1,N
        NCONT(J) = ICO(1,I)+16*ICO(2,I)+128*ICO(3,I)+4*MOD(ICO(4,I),4)
     *      +64*MOD(ICO(5,I),4)+ 512*MOD(ICO(6,I),4)
305     J = J+1
306   J = J-1
CDB 4
C     PRINT 5,J,IJ,N,NSP,NCONT
C    1 ,ICO
C   5 FORMAT (*0J =*I3*  IJ =*I3*  N =*I3*  NSP =*2I5/* NCONT =*10I4/
C    1 * ICO =*6I3/(6X6I3))
310   DO 400 I=IJ,J
        NCI = I-IJ+1
        ICO4 = MOD(ICO(4,NCI),4)
        ICO5 = MOD(ICO(5,NCI),4)
        ICO6 = MOD(ICO(6,NCI),4)
        NI4 = NDAT(ICO4+4)
        NI5 = NDAT(ICO5+4)
        NI6 = NDAT(ICO6+4)
        KJ = I+1
        IF ( AND(NCONT(I),307)-290 ) 320,315,320
315     IF ( AND(NCONT(I),7884) ) 316,318,316
C   A CENTER IS PRESENT, NOT AT 0,0,0
316     CONTINUE
        WRITE(6,24)
        GO TO 320
C   A CENTER AT 0,0,0 IS PRESENT
318     CONTINUE
320     IF ( KJ.GT.J ) GO TO 400
        DO 390 K=KJ,J
          NCK = K-IJ+1
          KCO4 = MOD(ICO(4,NCK),4)
          KCO5 = MOD(ICO(5,NCK),4)
          KCO6 = MOD(ICO(6,NCK),4)
          NK4 = NDAT(KCO4+4)
          NK5 = NDAT(KCO5+4)
          NK6 = NDAT(KCO6+4)
          NXC = MOD(NI4+NK4,4)
          NYC = MOD(NI5+NK5,4)
          NZC = MOD(NI6+NK6,4)
          MJ = K+1
          LOD = LODGDF(NCONT(K),NCONT(I))
          IF ( LOD.NE.290 ) GO TO 330
C   A CENTER IS GENERATED
          IF ( NXC+NYC+NZC.EQ.0 ) GO TO 330
          IF ( L(1,2).EQ.15.AND.I.EQ.IJ+1 ) GO TO 324
321       IF ( NXC.EQ.0 ) GO TO 322
          IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
          IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
322       IF ( NYC.EQ.0 ) GO TO 323
          IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
          IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
323       IF ( NZC.EQ.0 ) GO TO 325
          IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
          IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
          GO TO 325
324       L(1,2) = 30
          NIJ = ICO(6,1)
          NIJ = NDAT(NIJ+4)
          NJX = MOD(NIJ+NXC,4)
          NCONT(IJ) = AND(NCONT(IJ),2035)+NDAT(NJX+4)*4
          NCONT(IJ) = AND(NCONT(IJ),1855)+NDAT(NIJ+4)*64
          GO TO 321
325       CONTINUE
          ICO(4,NCI) = 0
          ICO(4,NCK) = 0
          ICO(5,NCK) = 0
          ICO(5,NCI) = 0
          ICO(6,NCI) = 0
          ICO(6,NCK) = 0
330       CONTINUE
          ICO4 = MOD(NCONT(I)/4  ,4)
          IKO4 = MOD(NCONT(K)/4  ,4)
          ICO5 = MOD(NCONT(I)/64 ,4)
          IKO5 = MOD(NCONT(K)/64 ,4)
          ICO6 = MOD(NCONT(I)/512,4)
          IKO6 = MOD(NCONT(K)/512,4)
          NI4 = NDAT(ICO4+4)
          NK4 = NDAT(IKO4+4)
          NI5 = NDAT(ICO5+4)
          NK5 = NDAT(IKO5+4)
          NI6 = NDAT(ICO6+4)
          NK6 = NDAT(IKO6+4)
          IF ( MJ.GT.J ) GO TO 390
          DO 380 M=MJ,J
            NCM = M-IJ+1
            MCO4 = MOD(ICO(4,NCM),4)
            MCO5 = MOD(ICO(5,NCM),4)
            MCO6 = MOD(ICO(6,NCM),4)
            NM4 = NDAT(MCO4+4)
            NM5 = NDAT(MCO5+4)
            NM6 = NDAT(MCO6+4)
            LOD1 = LODGDF(LOD,NCONT(M))
            NXC = MOD(NI4+NK4+NM4,4)
            NYC = MOD(NI5+NK5+NM5,4)
            NZC = MOD(NI6+NK6+NM6,4)
            IF ( LOD1.NE.290 ) GO TO 350
            IF  ( L(1,2).EQ.11 ) GO TO 334
            IF ( NXC+NYC+NZC.EQ.0 ) GO TO 380
            IF ( IJ.EQ.1 ) GO TO 331
            IF(NXC +NYC .EQ.0 )GO TO 333
            IF ( L(1,3).EQ.14 ) GO TO 331
            IF ( L(1,2).EQ.15 ) GO TO 331
            IF ( L(1,2).EQ.14 ) GO TO 331
            IF ( L(1,2).EQ.17 ) GO TO 331
            IF ( L(1,2)+L(1,3)+L(1,4).LT.18.AND.L(1,2).NE.9 ) GO TO 331
            NXC = MOD(NCONT(1)/2  +NXC,4)
            NYC = MOD(NCONT(1)/32 +NYC,4)
            NZC = MOD(NCONT(1)/256+NZC,4)
331         CONTINUE
            IF ( NXC.EQ.0 ) GO TO 332
            IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
            IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
            IF ( ICO(4,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NXC)*4
332         IF ( NYC.EQ.0 ) GO TO 333
            IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
            IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
            IF ( ICO(5,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NYC)*64
333         IF ( NZC.EQ.0 ) GO TO 335
            IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
            IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
            IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
            GO TO 335
334         NCONT(I) = AND(NCONT(I),2035)
            NCONT(K) = AND(NCONT(K),1855)
            NCONT(M) = AND(NCONT(M),511)
335         ICO(4,NCI) = 0
            ICO(5,NCI) = 0
            ICO(6,NCI) = 0
            ICO(4,NCK) = 0
            ICO(5,NCK) = 0
            ICO(6,NCK) = 0
            ICO(4,NCM) = 0
            ICO(5,NCM) = 0
            ICO(6,NCM) = 0
            GO TO 380
350         IF ( LOD1.NE.0 ) GO TO 380
CDB 3
C     PRINT 9,LOD1,NXC,NYC,NZC,NI4,NK4,NI5,NK5,NI6,NK6
C   9 FORMAT (* LOD1 = *O10* NXC =*I4* NYC =*I4* NZC =*I4/
C    1 * NI4 =*I3* NK4 =*I3* NI5 =*I3* NK5 =*I3* NI6 =*I3* NK6 =*I3)
            IF ( NXC+NYC+NZC.EQ.0 ) GO TO 359
            IF ( L(1,2).EQ.30 ) GO TO 3500
            IF ( L(1,2).EQ.15 ) GO TO 355
            IF ( L(1,2).EQ.17 ) GO TO 359
            IF ( L(1,2).EQ.13 ) GO TO 351
            IF ( L(1,3).EQ.13 ) GO TO 352
            IF ( L(1,4).EQ.13 ) GO TO 353
            GO TO 500
3500        IF ( NXC.EQ.0 ) GO TO 359
            IF ( L(4,2).EQ.4 ) GO TO 359
            IF ( NXC.EQ.NK4 ) GO TO 359
            NCONT(K) = OR(NCONT(K),NDAT(NXC)*4)
            IF ( L(1,4).EQ.13.AND.L(2,4).EQ.0 ) GO TO 3580
            GO TO 359
351         NYC = MOD(NK5+NM5,4)
            NZC = MOD(NK6+NM6,4)
            IF ( L(1,3).EQ.13 ) GO TO 354
            IF ( L(1,3).EQ.14 ) GO TO 354
            IF ( L(1,4).EQ.13 ) GO TO 354
            M2 = I+1
3511        CONTINUE
            IF(L(2,2).EQ.12.AND.(L(1,3).EQ.9 .OR.L(1,4).EQ.9))  GO TO 36
     *       0
            IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
            IF ( ICO(5,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NYC)*64
3510        IF ( NZC.LE.0 ) GO TO 360
            IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
            IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
            GO TO 360
352         NXC = MOD(NI4+NM4,4)
            NZC = MOD(NI6+NM6,4)
            M2 = K+1
            IF(L(2,3).EQ.12 .AND.(L(1,2).EQ.9 .OR. L(1,4).EQ.9)) GO TO 3
     *       60
            IF ( NXC.LE.0 ) GO TO 3520
            IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
            IF ( ICO(4,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NXC)*4
3520        IF ( NZC.LE.0 ) GO TO 360
            IF ( ICO(6,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NZC)*512
            IF ( ICO(6,NCM).EQ.4 ) NCONT(M) = NCONT(M)+NDAT(NZC)*512
            GO TO 360
353         NXC = MOD(NI4+NK4,4)
            NYC = MOD(NI5+NK5,4)
            IF(L(2,4).EQ.12 .AND. ( L(1,2).EQ.9.OR.L(1,3).EQ.9)) GO TO 3
     *       59
            IF ( NXC.LE.0 ) GO TO 3530
            IF ( ICO(4,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NXC)*4
            IF ( ICO(4,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NXC)*4
3530        IF ( NYC.LE.0 ) GO TO 359
            IF ( ICO(5,NCI).EQ.4 ) NCONT(I) = NCONT(I)+NDAT(NYC)*64
            IF ( ICO(5,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NYC)*64
            GO TO 359
354         IF ( NYC.LE.0 ) GO TO 3540
            IF ( IABS(L(2,2)-13).EQ.1 ) NCONT(I)=NCONT(I)+NDAT(NYC)*64
3540        IF ( NZC.LE.0 ) GO TO 3541
            IF ( ICO(6,NCK).EQ.4 ) NCONT(K) = NCONT(K)+NDAT(NZC)*512
3541        IF ( NXC.LE.0 ) GO TO 359
            IF ( L(1,4).EQ.0.OR.L(1,3).EQ.14 ) GO TO 359
            IF ( L(2,4).NE.12 ) NCONT(K)=NCONT(K)+NDAT(NXC)*4
            GO TO 359
355         L(1,2) = 30
            IF ( L(1,3).EQ.14 ) GO TO 370
            IF ( L(1,3).EQ.13.AND.L(2,3).EQ.12 ) GO TO 3561
            IF ( L(1,1).EQ. 7.AND.L(2,2).EQ.12 ) GO TO 357
            IF ( L(1,1).EQ. 7.AND.L(2,2).EQ.14 ) GO TO 357
            IF ( L(1,1).EQ. 6.AND.L(2,2).EQ.12 ) GO TO 358
            IF ( L(1,1).EQ. 6.AND.L(2,2).EQ.14 ) GO TO 358
            IF ( L(1,1).EQ.7.AND.L(1,3).EQ.13 ) GO TO 3581
            IF ( MOD(NCONT(I),1024).EQ.19 ) GO TO 350
            IF ( NXC+NYC.GT.0 ) GO TO 356
            IF ( NZC.NE.NM6 ) GO TO 359
            IF ( NZC.LE.0 ) GO TO 359
            NCONT(K) = NCONT(K)+NDAT(NZC)*512
            GO TO 359
356         IF ( L(3,2).EQ.10.OR.L(4,2).EQ.10 ) GO TO 359
            IF ( L(1,3).NE.10 ) GO TO 359
3561        IF ( L(2,2).EQ.3 ) GO TO 3560
            NCONT(I) = OR(NCONT(I),68)
            GO TO 3580
3560        IF ( L(1,4).EQ.2 ) NCONT(K)= OR(NCONT(K),512)
            GO TO 359
357         NCONT(I) = NCONT(I)+64
            IF ( L(3,2).NE.19 ) NCONT(I+1) = NCONT(I+1)-512
            IF ( L(1,4).EQ.11.AND.L(3,2).EQ.19 )NCONT(I) = NCONT(I)+588
            GO TO 3580
358         NCONT(I) = NCONT(I)+136
3580        IF ( L(1,3).NE.13 ) GO TO 359
3581        M2 = K+1
            GO TO 360
359         M2 = M+1
360         CONTINUE
            IF ( M2.GT.J ) GO TO 306
CDB 2
C     PRINT 6,M2,I,J,K,M
C   6 FORMAT (*0M2 =*I3*  I =*I3*  J =*I3* K =*I3*  M =*I3)
            DO 365 M1=M2,J
              NCONT(M1-1) = NCONT(M1)
              DO 365 M3=1,6
365             ICO(M3,M1-1) = ICO(M3,M1)
            GO TO 306
370         IF ( L(1,4).GT.12 ) GO TO 371
            M2 = I+1
            GO TO 360
371         CONTINUE
            L(1,2) = 13
            IF ( L(2,2).EQ.12.AND.L(1,1).EQ.5 ) NCONT(I) = NCONT(I)+200
            IF ( L(2,2).EQ.12.AND.L(1,1).EQ.6 ) NCONT(I) = NCONT(I)+136
            IF ( L(2,2).EQ.12.AND.L(1,1).EQ.7 ) NCONT(I) = NCONT(I)+652
            IF ( L(2,2).EQ.13 )                 NCONT(I) = NCONT(I)+68
            IF ( L(2,2).EQ.14 )                 NCONT(I) = NCONT(I)+140
            GO TO 359
380         CONTINUE
390       CONTINUE
400     CONTINUE
      LD = 0
      DO 405 I=1,J
405     LD = LODGDF(LD,NCONT(I))
      IF ( LD.NE.0 ) GO TO 410
      NCONT(J-1) = NCONT(J)
      J = J-1
410   CONTINUE
      NCONT(J+1) = 0
CDB 1
C     PRINT 4,K,NSP,J,NCONT
450   RETURN
500   WRITE(6,2)SPG
      NSP(2) = 4
      GO TO 450
      END
***  subroutine to determine the rational modulation vector components 
*    from the superspace group symbol
      subroutine ssgroup(iphase)
*
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      logical lqmod
* determine rational components of q vector from superspace group
*
      do i=1,3
        qmodrc(iphase,i) = 0.0
      enddo
      if(ssgrp(iphase,1).eq.'A')qmodrc(iphase,1) = 0.5
      if(ssgrp(iphase,1).eq.'B')qmodrc(iphase,2) = 0.5
      if(ssgrp(iphase,1).eq.'C')qmodrc(iphase,3) = 0.5
      if(ssgrp(iphase,1).eq.'L')qmodrc(iphase,1) = 1.0
      if(ssgrp(iphase,1).eq.'M')qmodrc(iphase,2) = 1.0
      if(ssgrp(iphase,1).eq.'N')qmodrc(iphase,3) = 1.0
      if(ssgrp(iphase,1).eq.'U')then
        qmodrc(iphase,2) = 0.5
        qmodrc(iphase,3) = 0.5
      endif
      if(ssgrp(iphase,1).eq.'V')then 
        qmodrc(iphase,1) = 0.5
        qmodrc(iphase,3) = 0.5
      endif
      if(ssgrp(iphase,1).eq.'W')then
        qmodrc(iphase,1) = 0.5
        qmodrc(iphase,2) = 0.5
      endif
      if(ssgrp(iphase,1).eq.'R')then
        qmodrc(iphase,1) = 0.33
        qmodrc(iphase,2) = 0.33
      endif
*
      if(qmodrc(iphase,1).ne.0.0.or.qmodrc(iphase,2).ne.0.0.or
     *.qmodrc(iphase,3).ne.0.0)write(*,1)(qmodrc(i,iphase),i=1,3)
1      format(/,' The rational coefficients of the modulation vector 
     *are:',/,2x,3f8.5,/,/,' Be causious of symmetry operator generation
     * for nonprimitive superspace groups.',/' They may not be correct')
*
      return
      end
      SUBROUTINE ASSIGN
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),MLT(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      DIMENSION KRR(2,IDSZ)
      ICX=0
      DO 4100 J =1,NPHASE
4100    ICX = ICX + IC(J)
      IF(NPHASE.GT.1)CALL SORT(1000)
      DO 2 J=1,2
        DO 2 K=1,IDSZ
2         KRR(J,K)=0
      IF(LST3.EQ.0)GOTO 7
      DO 8 I=1,ICX
        IRL=MOD(IREFS(I),256)-128
        IRK=MOD(IREFS(I)/256,256)-128
        IRH=MOD(IREFS(I)/256/256,256)-128
        IRC=MOD(IREFS(I)/256/256/256,8)
        IPHAS=IREFS(I)/256/256/256/8
        IF(MOD(I-1,60).EQ.0)WRITE(6,9)
8       WRITE(6,10)I,IRC,IRH,IRK,IRL,IPHAS,(REFS(I,JX),JX=1,2)
9     FORMAT(38H1NO.  CODE    H   K   L  PHASE  HW       ,
     * 16HPOSN              /)
10    FORMAT(1X,2I4,3X,3I4,I6,2F8.3)
7     DO 479 I=1,ICX
        RMIN=REFS(I,2)-WDT*REFS(I,1)
        RMAX=REFS(I,2)+WDT*REFS(I,1)
        MIN=(RMIN-THMIN)/STEP+1.5
        MAX=(RMAX-THMIN)/STEP+1.5
        MIN=MAX0(MIN,1)
        MIN=MIN0(MIN,NPTS)
        MAX=MIN0(MAX,NPTS)
        DO 479 K=MIN,MAX
          KRR(2,K)=I
479       IF(KRR(1,K).EQ.0)KRR(1,K)=I
      DO 482 J=1,NEXCRG
        IF(AHIGH(J).LE.THMIN)GOTO 482
        IN1=(ALOW(J)-THMIN)/STEP+1.5
        IN1=MAX0(IN1,1)
        IN2=(AHIGH(J)-THMIN)/STEP+1.5
        IN2=MIN0(IN2,NPTS)
        DO 483 I=IN1,IN2
          KRR(2,I)=1
483       KRR(1,I)=0
        IF(IN2.EQ.NPTS)GOTO 484
482     CONTINUE
484   IF(LST2.EQ.0)GOTO 530
      WRITE(6,589)THMIN,THMAX,STEP
589   FORMAT(13H1PATTERN FROM,F8.4,1X,2HTO,F8.4,1X,11HIN STEPS OF,
     * F8.4,1X,7HDEGREES)
      WRITE(6,544)
544   FORMAT(6H0 POSN,6X,3HI+B,5X,1HB,5X,1HI,2X,5H100*W,6X,3HK11,2X,
     * 3HK21)
      DO 520 J=1,NPTS
        PX=THMIN+FLOAT(J-1)*STEP
        YUN=Y(J)-BK(J)
        WT=1./VAR(J)
        WRITE(6,559)PX,Y(J),BK(J),YUN,WT,(KRR(J2,J),J2=1,2)
559     FORMAT(1X,F8.4,3F7.0,2PF9.4,2I5)
520     CONTINUE
530   CONTINUE
      DO 600 I=1,NPTS
        IF(KRR(2,I)-KRR(1,I).GT.NOV)THEN
          WRITE(7,601) I,KRR(2,I)-KRR(1,I),NOV
          WRITE(6,601) I,KRR(2,I)-KRR(1,I),NOV
601       FORMAT(1X,'EXCESSIVE PEAK OVERLAP',/,
     *          5X,'AT THE',I5,'TH STEP THERE ARE ',I5,' REFLECTIONS',/,
     *               5X,'INCREASE THE VALUE OF *NOV* WHICH IS NOW',I5/)
          STOP 'EXCESSIVE PEAK OVERLAP'
        ENDIF
600     CONTINUE
      DO 531 I=1,NPTS
        KR(I)=KRR(1,I)+IRS *KRR(2,I)
531     CONTINUE
      DO 602 I=1,NPTS
        IF(KR(I).NE.0.AND.KR(I).NE.IRS )GOTO 603
602     CONTINUE
      STOP 'NO REFLECTIONS FOUND '
C THE FOLLOWING TEST IS REALLY ONLY VALID FOR THE SINGLE PHASE CASE
603   IF(REFS(KRR(1,I),2).GE.RLIM.AND.LPAR(1,14).NE.0)THEN
        WRITE(6,604)
        WRITE(7,604)
604     FORMAT(1X,'ASYMMETRY PARAMETER USAGE INVALID')
        STOP 'ASYMMETRY PARAMETER USAGE INVALID'
      ENDIF
      DO 606 I=1,NPHASE
        IF(PAR(I,12).EQ.0..AND.PAR(I,13).EQ.0..AND.LPAR(I,13).NE.0)THEN
          WRITE(6,605)
          WRITE(7,605)
605       FORMAT(1X,'PREFERRED ORIENTATION USAGE INVALID')
          STOP 'PREFERRED ORIENTATION USAGE INVALID'
        ENDIF
606     CONTINUE
      RETURN
      END
      SUBROUTINE CHISQ
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/G2/S1,S2,S3,S4,D1,D2,D4,R1,R2,R3
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
C     COMMON/JNK/FILL(155),NBCKGD,NEXCRG,NSCAT
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      S1=0.
      S2=0.
      S3=0.
      S4=0.
      D1=0.
      D2=0.
      D4=0.
      DELW =  1.0E+25
      DELWP=  1.0E+25
      DO 10 I=1,NPTS
        IF((NBCKGD.NE.0.AND.KR(I).EQ.0).OR.KR(I).EQ.IRS )GOTO 10
        IF(NEXCRG.GT.0) THEN
          DO 1400 IEXC=1,NEXCRG
            NPTLOW = (ALOW(IEXC)-THMIN)/STEP + 1.5
            NPTHI  = (AHIGH(IEXC)-THMIN)/STEP + 1.5
            IF (I.GE.NPTLOW.AND.I.LE.NPTHI) GO TO 10
1400        CONTINUE
        END IF
        IF (DELW.LT.1.0E+24) DELWP = DELW
        DEL=Y(I)-BK(I)-YC(I)
        DELW = DEL/SQRT(VAR(I))
        S1=S1+ABS(DEL)
        S2=S2+DEL*DEL/VAR(I)
        IF (DELWP.LT.1.0E+24) S4=S4+(DELW-DELWP)*(DELW-DELWP)
10      CONTINUE
      DO 15 I=1,NPTS
        IF((NBCKGD.NE.0.AND.KR(I).EQ.0).OR.KR(I).EQ.IRS )GOTO 15
        IF(NEXCRG.GT.0) THEN
          DO 1401 IEXC=1,NEXCRG
            NPTLOW = (ALOW(IEXC)-THMIN)/STEP + 1.5
            NPTHI  = (AHIGH(IEXC)-THMIN)/STEP + 1.5
            IF (I.GE.NPTLOW.AND.I.LE.NPTHI) GO TO 15
1401        CONTINUE
        END IF
        D1=D1+Y(I)
        D2=D2+Y(I)*Y(I)/VAR(I)
        S3=S3+BK(I)+YC(I)
15      CONTINUE
      R1=0
      R2=100.*S1/D1
      R3=100.*SQRT(S2/D2)
      RETURN
      END
*** subroutine iter goes here ***
      SUBROUTINE ITER
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/F1/RJAC(MSZ,MSZ),VX(MSZ)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/G2/S1,S2,S3,S4,D1,D2,D4,R1,R2,R3
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),MLT(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      COMMON/ALLP/FINAL(8*MSZ,2),ILOC
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      COMMON/G3/COND,IORD1,IORD2,TH,NUM
***mod
      logical lqmod
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
***mod
      DIMENSION RJ(MSZ,MSZ),VLAST(MSZ),KS(50)
C     EQUIVALENCE (RJ(1,1),KR(1))
      do j=1,8
        do i=1,3
          if(qmodic(j,i).ne.0.0)lqmod(j) = .true.
        enddo
      enddo
      DO 70 I=1,MSZ
70      VLAST(I)=0.
      DO 10 IX=1,MCYCLE
        CALL ASSIGN
        DO 1 I=1,MSZ
          VX(I)=0.
          DO 1 J=1,MSZ
1           RJAC(I,J)=0.
        NUM=0
        IPREV=1
        IF(NBCKGD.NE.0)GOTO 30
        TH=THMIN-STEP
        DO 31 I=1,NPTS
          TH=TH+STEP
          THX=TH/BKPOS-1.
          BK(I)=GLB(2)
          DO 31 J=2,6
31          BK(I)=BK(I)+GLB(J+1)*THX**(J-1)
30      TH=THMIN-STEP
        DO 9 IPM=1,NPTS
          TH=TH+STEP
          IF(KR(IPM).EQ.IRS )GOTO 9
          IORD1=MOD(KR(IPM),IRS )
          IORD2=MOD(KR(IPM)/IRS ,IRS )
          IF((IORD2.EQ.0.OR.IORD1.EQ.0).AND.NBCKGD.NE.0)GOTO 9
C     IF (IX.EQ.1) GOTO 15
C     IF ((IORD2-IORD1).LT.NOV) GOTO 15
C     WRITE (6,1234) IORD2-IORD1,NOV,IPM
C1234 FORMAT(1X,'NO.OF REFLECTIONS IS ',I4,2X,'AT STEP NO.',I6)
C     STOP
15        NUM=NUM+1
          IF(IPREV.GT.IORD2)GOTO 40
*          write(*,1203)(qmodic(1,j),j=1,3)
*1203      format(' the mod vector is',3f8.4)
          DO 21 J=IPREV,IORD2
            IPHAS=IREFS(J)/256/256/256/8
*            write(*,1201)iphas
            if(lqmod(iphas))then
*              write(*,1200)j
              call calmod(j)
            else
*              write(*,1202)j
              CALL CALCUL(J)
            endif
21        continue
1200      format(' Calling calmod(',i3,')')
1201      format(' phase number ',i3)
1202      format(' Calling calcul(',i3,')')
40        IPREV=MAX0(IPREV,IORD2+1)
108       CALL SUMMAT(IPM)
9       CONTINUE
        IF(JOBTYP.GT.2)RETURN
        DO 50 I=1,MAXS
          DO 50 J=I,MAXS
50          RJAC(J,I)=RJAC(I,J)
        COND=DPINV(RJAC(1,1),VX(1),MAXS)
        CALL CHISQ
        OOM=S2/FLOAT(NUM-MAXS)
        DO 55 I=1,MAXS
          DO 55 J=1,MAXS
55          RJAC(I,J)=RJAC(I,J)*OOM
C CODE TO ATTEMPT TO STABILIZE OSCILLATIONS
        DO 60 I=1,MAXS
          IF(SIGN(1.,VX(I)).EQ.SIGN(1.,VLAST(I)))GOTO 60
          IF(ABS(VX(I)).GT.1.2*ABS(VLAST(I)))GOTO 60
          IF(ABS(VX(I)).LT..8*ABS(VLAST(I)))GOTO 60
          VX(I)=VX(I)/2.
60        VLAST(I)=VX(I)
        CALL OUTPTR(IX)
        DO 5 I=1,MAXS
          X1=SQRT(ABS(RJAC(I,I)))*EPS
          IF(ABS(VX(I)).GT.X1)GOTO 10
5         CONTINUE
        IF (MAXS.GT.0) WRITE (6,1111)
1111    FORMAT(/,10X,'***** EPSED OUT *****'/)
        IF (MAXS.GT.0) ICYRUN = IX
        GOTO 20
10      CONTINUE
20    DO 6 I=1,MAXS
        DO 6 J=1,MAXS
6         RJ(I,J)=RJAC(I,J)
C     CODE FOR PRINTING CORRELATION MATRIX MOVED FROM EXPUT (65-85)
      IF(MAT.EQ.0.OR.MAXS.EQ.0) RETURN
      WRITE(6,7)
      IA=1
      LIM=19
38    LIM=MIN0(MAXS,LIM)
      WRITE(6,8)(I,I=IA,LIM)
      DO 39 I=1,MAXS
        L=0
        X=RJAC(I,I)
        DO 400 J=IA,LIM
          L=L+1
          YY=RJAC(J,J)*X
400       KS(L)=100.*RJAC(I,J)/(SQRT(ABS(YY))*SIGN(1.,YY))+0.5
39      WRITE(6,12)I,(KS(J),J=1,L)
      IF(LIM.GE.MAXS)GOTO 37
      IA=LIM+1
      LIM=LIM+19
      GOTO 38
7     FORMAT(//,20H0CORRELATION MATRIX=)
8     FORMAT(5H0    ,19I6)
12    FORMAT(I5,19I6)
37    CONTINUE
      RETURN
      END
*
      FUNCTION DPINV(A1,B1,N)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      DOUBLE PRECISION A,B,U,T
      DIMENSION A(MSZ,MSZ),A1(MSZ,MSZ),B(MSZ),B1(MSZ),U(MSZ),M(MSZ)
      IF(N.NE.1)GOTO 50
      A1(1,1)=1./A1(1,1)
      B1(1)=B1(1)*A1(1,1)
      DPINV=1
      GOTO 99
50    DPINV=0
      DO 1 I=1,N
        B(I)=B1(I)
        DO 1 J=1,N
1         A(I,J)=A1(I,J)
      DO 2 I=1,N
        U(I)=DABS(A(I,1))
        C=U(I)
        DO 3 J=2,N
          U(I)=DMAX1(U(I),DABS(A(I,J)))
3         C=C+DABS(A(I,J))
        DPINV=AMAX1(DPINV,C)
        M(I)=I
        B(I)=B(I)/U(I)
        DO 2 J=1,N
2         A(I,J)=A(I,J)/U(I)
      DO 10 I=1,N
        IF(I.EQ.N)GOTO 15
        J=I
        I1=I+1
        MI=M(I)
        S=DABS(A(MI,I))
        DO 4 K=I1,N
          MI=M(K)
          IF(DABS(A(MI,I)).LE.S)GOTO 4
          S=DABS(A(MI,I))
          J=K
4         CONTINUE
        MK1=M(J)
        M(J)=M(I)
        M(I)=MK1
15      MI1=M(I)
        A(MI1,I)=1./A(MI1,I)
        B(MI1)=B(MI1)*A(MI1,I)
        DO 20 J=1,N
          IF(I.EQ.J)GOTO 20
          A(MI1,J)=A(MI1,J)*A(MI1,I)
20        CONTINUE
        DO 30 J=1,N
          IF(J.EQ.I)GOTO 30
          MJ=M(J)
          T=A(MJ,I)
          MI1=M(I)
          B(MJ)=B(MJ)-T*B(MI1)
          A(MJ,I)=-T*A(MI1,I)
          DO 40 K=1,N
            IF(K.EQ.I)GOTO 40
            A(MJ,K)=A(MJ,K)-T*A(MI1,K)
40          CONTINUE
30        CONTINUE
10      CONTINUE
      DO 93 I=1,N
        MI1=M(I)
        B1(I)=B(MI1)
        DO 94 J=1,N
          MJ=M(J)
94        A1(I,MJ)=A(MI1,J)/U(MJ)
93      CONTINUE
      C=0
      DO 91 I=1,N
        D=ABS(A1(I,1))
        DO 92 J=2,N
92        D=D+ABS(A1(I,J))
91      C=AMAX1(C,D)
      DPINV=DPINV*C
99    RETURN
      END
      SUBROUTINE DIRECT(SM,V,IPH)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/F1/SMM(MSZ,MSZ),VX(MSZ)
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      DIMENSIONV(6),SM(6,6)
      DO 1 J=1,6
        V(J)=PAR(IPH,J+5)
        K=LPAR(IPH,J+5)
        X=APAR(IPH,J+5)
        IF(K.EQ.0)X=0.
        DO 1 L=J,6
          M=LPAR(IPH,L+5)
          SM(L,J)=0.
          IF((M.EQ.0).OR.(K.EQ.0))GOTO 1
          SM(L,J)=SMM(M,K)*X*APAR(IPH,L+5)
1         SM(J,L)=SM(L,J)
      CALL ESD(SM,V,1.)
      RETURN
      END
      SUBROUTINE ESD(SM,V,SUM)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      DIMENSION SM(6,6),V(6),S(6),R(6),E(6)
      I=0
      DO 1 IA=1,3
        I=I+1
        IB=IA+1
        IF(IB.GT.3)IB=IB-3
        IC=IB+1
        IF(IC.GT.3)IC=IC-3
        ID=IA+3
        IE=IB+3
        IP=IC+3
        FNUM=4.*V(IB)*V(IC)-V(ID)*V(ID)
        DEN=4.*V(IA)*V(IB)*V(IC)-V(IA)*V(ID)*V(ID)-V(IB)*V(IE)*V(IE)-V(I
     *   C)*V(IP)*V(IP)+V(ID)*V(IE)*V(IP)
        S(I)=SQRT(FNUM/DEN)
        R(IA)=-S(I)**4
        DENL=1./(DEN*DEN)
        R(IB)=DENL*(4.*V(IC)*DEN-(4.*V(IA)*V(IC)-V(IE)*V(IE))*FNUM)
        R(IC)=DENL*(4.*V(IB)*DEN-(4.*V(IA)*V(IB)-V(IP)*V(IP))*FNUM)
        R(ID)=-DENL*(2.*V(ID)*DEN-(2.*V(IA)*V(ID)-V(IE)*V(IP))*FNUM)
        R(IE)=DENL*FNUM*(2.*V(IB)*V(IE)-V(ID)*V(IP))
        R(IP)=DENL*FNUM*(2.*V(IC)*V(IP)-V(ID)*V(IE))
        E(I)=ERROR(SM(1,1),R(1),SUM)
        E(I)=E(I)/(2.*S(I))
        FNUM=V(IE)*V(IP)-2.*V(IA)*V(ID)
        DEN=16.*V(IA)*V(IA)*V(IB)*V(IC)+V(IE)*V(IE)*V(IP)*V(IP)-4.*(V(IA
     *   )*V(IB)*V(IE)*V(IE)+V(IC)*V(IA)*V(IP)*V(IP))
        DENL=1./(DEN*DEN)
        FNUML=FNUM*FNUM
        S(I+3)=FNUML/DEN
        R(IA)=-4.*FNUM*DENL*(V(ID)*DEN+FNUM*(8.*V(IA)*V(IB)*V(IC)-V(IB)*
     *   V(IE)*V(IE)-V(IC)*V(IP)*V(IP)))
        R(IB)=-4.*FNUML*DENL*(4.*V(IA)*V(IA)*V(IC)-V(IA)*V(IE)*V(IE))
        R(IC)=-4.*FNUML*DENL*(4.*V(IA)*V(IA)*V(IB)-V(IA)*V(IP)*V(IP))
        R(ID)=-4.*FNUM/DEN*V(IA)
        R(IE)=2.*FNUM*DENL*(V(IP)*DEN-FNUM*(V(IE)*V(IP)*V(IP)-4.*V(IA)*V
     *   (IB)*V(IE)))
        R(IP)=2.*FNUM*DENL*(V(IE)*DEN-FNUM*(V(IE)*V(IE)*V(IP)-4.*V(IC)*V
     *   (IA)*V(IP)))
        E(I+3)=ERROR(SM(1,1),R(1),SUM)
        IF(S(I+3).EQ.0.0) GOTO 3
        E(I+3)=E(I+3)/(2.*SQRT(S(I+3)*(1.-S(I+3))))*180./3.14159265359
        S(I+3)=ATAN(SQRT((1.-S(I+3))/S(I+3)))*180./3.14159265359
        GOTO 4
3       S(I+3)=90.
        E(I+3)=0.0
4       CONTINUE
        IF(FNUM.LT.0.)S(I+3)=180.-S(I+3)
        IF(SM(ID,ID).EQ.0.)E(ID)=0.
1       CONTINUE
      IF(ABS(S(1)-S(2)).LT..00008)E(1)=E(2)
      DO 2 I=1,6
        SM(I,I)=E(I)
2       V(I)=S(I)
      RETURN
      END
      FUNCTION ERROR(A,B,OMEGA)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      DIMENSION A(6,6),B(6)
      SUM=0.
      DO 1 I=1,6
        DO 1 J=I,6
          X=2.
          IF(I.EQ.J)X=1.
1         SUM=SUM+A(I,J)*B(I)*B(J)*X
      IF(SUM.LT.0.)SUM=0.
      ERROR=SQRT(SUM*OMEGA)
      RETURN
      END
      SUBROUTINE STEEP(X,N,M,CHISQ,GRAD)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      DIMENSION Z(16),X(16),T(16),ZNT(16),SIGT(16),SIG(16)
      DIMENSION Y(16,16),XI(16),ZN(16)
      IF(N.EQ.0)RETURN
      CALL GRAD(X,Z)
      CALL CHISQ(X,G)
      DO 10 I=1,M
        DO 10 J=1,M
          Y(I,J)=0.0
          IF(I.EQ.J)Y(I,J)=1.0
10        CONTINUE
      DO 200 K=1,N
        U=0
        DO 20 I=1,M
          T1=0
          DO 30 J=1,M
30          T1=T1+Z(J)*Y(I,J)
          SIG(I)=T1
20        U=U-SIG(I)*Z(I)
        ETA=AMIN1(1.0,ABS(2.*G/U))
        DO 40 I=1,M
40        T(I)=X(I)-ETA*SIG(I)
        CALL GRAD(T,ZN)
        V=0
        DO 50 I=1,M
50        V=V-ZN(I)*SIG(I)
        CALL CHISQ(T,G1)
        D=3.*ABS(G-G1)/ETA+U+V
        W=SQRT(D*D-U*V)
        ALPHA=ETA*(1.-(V+W-D)/(V-U+2.*W))
        DO 60 I=1,M
          SIG(I)=-1.0*ALPHA*SIG(I)
          X(I)=X(I)+SIG(I)
60        ZN(I)=Z(I)
        CALL GRAD(X,Z)
        CALL CHISQ(X,G)
        T1=0
        DO 70 I=1,M
          XI(I)=Z(I)-ZN(I)
70        T1=T1+XI(I)*SIG(I)
        DO 80 I=1,M
80        SIGT(I)=SIG(I)/T1
        T1=0
        DO 90 I=1,M
          T2=0
          DO 100 J=1,M
100         T2=T2+XI(J)*Y(I,J)
          ZN(I)=T2
90        T1=T1+ZN(I)*XI(I)
        DO 110 I=1,M
          T2=0
          DO 120 J=1,M
120         T2=T2+XI(J)*Y(J,I)
110       ZNT(I)=T2/T1
        DO 131 I=1,M
          DO 130 J=1,M
130         Y(I,J)=Y(I,J)+SIG(I)*SIGT(J)-ZN(I)*ZNT(J)
131       CONTINUE
200     CONTINUE
      RETURN
      END
      SUBROUTINE RTMT(IPRT,IPHASE)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C    THE MATRICES ARE IN THE FIRST THREE ROWS OF VCTR AND THE VECTORS
C    ARE IN THE FOURTH ROW OF VCTR.
C    THE MATRICES ARE PACKED INTO IVEC.
      COMMON/BLNK1/N,NMAX,MULTX,Y(192,3),XLT,IXB,FILL(192)
      COMMON /SPG/NXX(14),MULT
      COMMON/RTMTX/IVEC(8,192),MLT(8),ICET(8)
***mod
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      character ssgrp*1,qmodbc*20,qmodac*10
      logical lqmod
***mod
      DIMENSION VCTR(3,4)
6     FORMAT(3H0 (,3F3.0,18H )     ( X )     (,F6.3,13H )     ( X2 ) /
     *       3H ( ,3F3.0,18H  ) * (  Y  ) + ( ,F6.3,14H  ) = (  Y2  )/
     *       3H  (,3F3.0,18H )     ( Z )     (,F6.3,13H )     ( Z2 )
     *    ,10X,5HIVEC(,I3,3H) =,I15)
10    FORMAT (40H1THE OPERATIONS OF THE SPACE GROUP ARE  )
      Y(1,1) = 2.0/108.0
      Y(1,2) = 3.0/108.0
      Y(1,3) = 4.0/108.0
      CALL SYMOPR
      MULT = MULTX-1
      DO 310 I=1,MULT
        IVEC(IPHASE,I) = 0
        DO 300 K=1,3
          IX = Y(I,K)*108.0+0.1
          VCTR(K,4) = FLOAT((IX+4)/9)/12.0
          VCTR(K,4) = AMOD(VCTR(K,4),1.0)
          IY = MOD(IX+4,9)-4
          IZ = IABS(IY)
          GO TO ( 220,230,240,250),IZ
          CALL GOTOER
220       VCTR(K,1) = -1.0*FLOAT(ISIGN(1,IY))
          VCTR(K,2) =  1.0*FLOAT(ISIGN(1,IY))
          VCTR(K,3) = 0.0
          GO TO 300
230       VCTR(K,1) =  1.0*FLOAT(ISIGN(1,IY))
          VCTR(K,2) = 0.0
          VCTR(K,3) = 0.0
          GO TO 300
240       VCTR(K,1) = 0.0
          VCTR(K,2) =  1.0*FLOAT(ISIGN(1,IY))
          VCTR(K,3) = 0.00
          GO TO 300
250       VCTR(K,1) = 0.0
          VCTR(K,2) = 0.0
          VCTR(K,3) =  1.0*FLOAT(ISIGN(1,IY))
300       IVEC(IPHASE,I) = IVEC(IPHASE,I)+(9*(INT(VCTR(K,1)+1.5))
     *                              +3*(INT(VCTR(K,2)+1.5))
     *                    +INT(VCTR(K,3)+1.5))*32768*32**(3-K)
     *                    +(INT(VCTR(K,4)*12.0+.5)+16)*32**(3-K)
***mod  set up 4-d symmetry operator matrix
        if(lqmod(iphase))then
          do k=1,3
            qmsym(k,4,i) = 0.0
            qmsym(k,5,i) = vctr(k,4)
            do j=1,3
              qmsym(k,j,i) = vctr(k,j)
            enddo
          enddo
        endif
      qmsym(4,4,k) = 0.0
      if(qmodic(1,iphase).ne.0.0.and.qmodic(2,iphase).eq.0.0
     *.and.qmodic(3,iphase).eq.0.0)qmsym(4,4,i)=qmsym(1,1,i)
      if(qmodic(1,iphase).eq.0.0.and.qmodic(2,iphase).ne.0.0
     *.and.qmodic(3,iphase).eq.0.0)qmsym(4,4,i)=qmsym(2,2,k)
      if(qmodic(1,iphase).ne.0.0.and.qmodic(2,iphase).eq.0.0
     *.and.qmodic(3,iphase).ne.0.0)qmsym(4,4,i)=qmsym(3,3,k)
      do k=1,3
        qmsym(4,k,i) = qmsym(4,4,i) * qmodrc(k,iphase)
        do j=1,3
          qmsym(4,k,i) = qmsym(4,k,i) - qmodrc(j,iphase)*qmsym(k,j,i)
        enddo
      enddo
      qmsym(4,5,i) = 0.0
        IF ( IPRT.LE.0 ) GOTO 310
          IF ( MOD(I-1,15).EQ.0)WRITE(6,10)
        if(lqmod(iphase))then
          write(6,7)((qmsym(kk,j,i),j=1,5),kk=1,4)
        else
          WRITE(6,6)((VCTR(K,J),J=1,4),K=1,3),I,IVEC(IPHASE,I)
        endif
310   CONTINUE
7     FORMAT(/,3H  (,4F3.0,18H )     ( X )     (,F6.3,13H )     ( X' )/
     1       3H ( ,4F3.0,18H  ) * (  Y  ) + ( ,F6.3,14H  ) = (  Y'  )/
     1       3H ( ,4F3.0,18H  )   (  Z  )   ( ,F6.3,14H  ) = (  Y'  )/
     2       3H  (,4F3.0,18H )     ( X4)     (,F6.3,13H )     ( X4') )
***mod
      MLT(IPHASE)=MULT
      ICET(IPHASE)=1
      IF(NXX(13).EQ.0)ICET(IPHASE)=2
      RETURN
      END
      SUBROUTINE OPERTR(I,L2)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C
C                             THIS SR GENERATES THE SYMMETRY EQUIVALENT
C                           POSITIONS. IT IS CALLED BY SYMOPR.
C
      COMMON/BLNK1/ N(2),L,X(192),Y(192),Z(192),XLT,IXB,FILL2(192)
      COMMON /SPG/NSP(2),M(10),FILL(3)
      I1 = MOD(M(I),4)+1
      I2 = MOD(M(I)/4,4)+1
      I3 = MOD(M(I)/16,4)+1
      I4 = MOD(M(I)/64,4)+1
      I5 = MOD(M(I)/256,2)
      I6 = MOD(M(I)/512,4)+1
      I7 = MOD(M(I)/2048,4)+1
      I8 = M(I)/8192+1
      GO TO (100,200,300),I8
      CALL GOTOER
100   GO TO (101,102,103,104),I1
      CALL GOTOER
101   X(L) = X(L2)
      GO TO 105
102   X(L) = Y(L2)
      GO TO 105
103   X(L) = -X(L2)
      GOTO 105
104   X(L) = -Y(L2)
105   GO TO (110,107,108,106),I2
      CALL GOTOER
106   X(L) = X(L)+0.25
107   X(L) = X(L)+0.25
108   X(L) = X(L)+0.25
110   GO TO (111,112,113,114),I3
      CALL GOTOER
111   Y(L) = Y(L2)
      GO TO 115
112   Y(L) = X(L2)
      GO TO 115
113   Y(L) = -Y(L2)
      GOTO 115
114   Y(L) = -X(L2)
115   GO TO (120,117,118,116),I4
      CALL GOTOER
116   Y(L) = Y(L)+0.25
117   Y(L) = Y(L)+0.25
118   Y(L) = Y(L)+0.25
120   Z(L) = Z(L2)*FLOAT(1-2*I5)
      GO TO (125,122,123,121),I6
      CALL GOTOER
121   Z(L) = Z(L)+0.25
122   Z(L) = Z(L)+0.25
123   Z(L) = Z(L)+0.25
125   GO TO (130,127,126),I7
      CALL GOTOER
126   Z(L) = Z(L)+0.333333333
127   Z(L) = Z(L)+0.333333333
130   L = L+1
      CALL CEL000
      RETURN
200   X(L) = -Y(L2)
      Y(L) = X(L2)-Y(L2)
      Z(L) = Z(L2)+0.333333333*FLOAT(I2-2)
      L = L+1
      CALL CEL000
      X(L) = -Y(L-1)
      Y(L) = -X(L2)
      Z(L) = Z(L2)-0.333333333*FLOAT(I2-2)
      GO TO 130
300   I1 = L2
301   X(L) = Z(I1)
      Y(L) = X(I1)
      Z(L) = Y(I1)
      IF ( I1-L2 ) 302,302,130
302   I1 = L
      L = L+1
      CALL CEL000
      GO TO 301
      END
      SUBROUTINE SYMOPR
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C
C                             THIS SR TAKES A POINT XYZ, DETERMINES THE
C                           SITE MULTIPLICITY, THE SITE SYMMETRY, AND
C                           THE SYMMETRY CONSTRAINTS ON THE POSITIONAL
C                           AND THERMAL PARAMETERS.
C
      COMMON/BLNK1/ N(2),L,X(192),Y(192),Z(192),XLT,KXB,NCTR(192)
      COMMON /SPG/NSP(2),M(10),FILL(3)
      common/vax/ lvax
      logical lvax
***vax modification
      INTEGER AND,OR
      AND(I,J) = IAND(I,J)
      OR(I,J) = IOR(I,J)
***vax
      ISCK = 0
103   L = 2
      ISRH = 0
      KXB = 0
      XLT = 1.0
      J = 1
      CALL CEL000
      L1=J
      DO 100 I=1,8
        IOP = 0
        IF ( M(I).EQ.0 ) GO TO 104
1       DO 99 L2=J,L1
          L3=L-1
          IF ( M(I)-8192 ) 4,5,4
5         X(L)=X(L2)+1.0/3.0
          Y(L)=Y(L2)+2.0/3.0
          Z(L)=Z(L2)+2.0/3.0
          X(L+1)=X(L2)+2.0/3.0
          Y(L+1)=Y(L2)+1.0/3.0
          Z(L+1)=Z(L2)+1.0/3.0
          L=L+1
          CALL CEL000
          L=L+1
          CALL CEL000
          GO TO 6
4         CALL OPERTR(I,L2)
6         L5=L
          L6=M(I)
7         L = L3+1
8         L4 = 1
          IF ( ABS(X(L)-X(L4))-0.0001 ) 2,2,90
2         IF ( ABS(Y(L)-Y(L4))-0.0001 ) 3,3,90
3         IF ( ABS(Z(L)-Z(L4))-0.0001 ) 91,91,90
91        CONTINUE
          IF ( NCTR(L)-8192 ) 92,94,93
92        KX = MOD(NCTR(L),4)+1
          KY = MOD(NCTR(L)/16,4)+1
          KZ = MOD(NCTR(L)/256,2)
          IF ( IOP.EQ.0 ) XLT=XLT/2.0
          IOP = 1
          GO TO (920,930,940,950),KX
          CALL GOTOER
920       GO TO (921,1000,922,1000),KY
          CALL GOTOER
921       IF ( KZ.EQ.0 ) GO TO 1000
          KXB = OR(KXB,2621450)
          GO TO 90
922       CONTINUE
          IF ( KZ.EQ.0 ) KXB= OR(KXB,2228292)
          IF ( KZ.EQ.1 ) KXB= OR(KXB, 655432)
          GO TO 90
930       KXB = OR(KXB,32768)
          GO TO (1000,931,1000,932),KY
          CALL GOTOER
931       CONTINUE
          IF ( KZ.EQ.0 ) KXB= OR(KXB, 4194464)
          IF ( KZ.EQ.1 ) KXB= OR(KXB,12583048)
          GO TO 90
932       KXB = OR(KXB,2753088)
          IF ( KZ.EQ.1 ) KXB = OR(KXB,8)
          GO TO 90
940       KXB = OR(KXB,512)
          GO TO (941,1000,942,1000),KY
          CALL GOTOER
941       KXB = OR(KXB,131072)
          IF ( KZ.EQ.1 ) GO TO 943
          KXB = OR(KXB,525312)
          GO TO 90
942       KXB = OR(KXB,64)
          IF ( KZ.EQ.1 ) GO TO 944
          KXB = OR(KXB,2623488)
          GO TO 90
943       KXB = OR(KXB,2097152)
944       KXB = OR(KXB,8)
          GO TO 90
950       KXB = OR(KXB,32768)
          GO TO (1000,951,1000,952),KY
          CALL GOTOER
951       KXB = OR(KXB,2753088)
          IF ( KZ.EQ.1 ) KXB = OR(KXB,8)
          GO TO 90
952       IF ( KZ.EQ.0 ) KXB = OR(KXB,8388864)
          IF ( KZ.EQ.1 ) KXB= OR(KXB,4194568)
          GO TO 90
93        CONTINUE
          IF ( MOD(NCTR(L),16384).EQ.0 ) GO TO 95
          ISRH = 1
          IF ( AND(307,NCTR(L)-M(I)).EQ.0 ) GO TO 92
          GO TO 90
94        KXB = OR(KXB,2916928)
          XLT = XLT/3.0
          GO TO 99
95        KXB = OR(KXB,17924240)
          XLT = XLT/3.0
          GO TO 99
90        CONTINUE
          IF ( L6-8192 ) 99, 98,98
98        L6=1
          L = L+1
          GO TO 8
99        L=L5
100     L1=L-1
104   CONTINUE
      IF ( ISRH.EQ.0 ) GO TO 200
      IF ( ISCK.GT.1 ) GO TO 2000
      ISCK = ISCK+1
      DO 1010 J=1,I
        IF ( M(J).EQ.16384 ) GO TO 1011
1010    CONTINUE
      DO 101 L2 = 1,L1
        IF ( ABS(X(L2)-Y(L2)).LE.0.0001 ) GO TO 102
        IF ( ABS(X(L2)+Y(L2)-1.0).LE.0.0002 ) GO TO 102
101     CONTINUE
      ISCK = 2
      WRITE(6,110) X(1),Y(1),Z(1),XLT
      GO TO 200
1011  CONTINUE
      IF ( ABS(X(1)-Y(1)).LT.0.0001 ) GO TO 120
      WRITE(6,111)X(1),Y(1),Z(1),Y(1),Z(1),X(1)
      X3 = X(1)
      X(1) = Y(1)
      Y(1) = Z(1)
      Z(1) = X3
      GO TO 103
110   FORMAT (37H0NO X,X,Z OR X,-X,Z SET WAS FOUND FOR,4F8.5)
102   IF ( L2.EQ.1 ) GO TO 120
      WRITE(6,111)X(1),Y(1),Z(1),X(L2),Y(L2),Z(L2)
111   FORMAT (12H0THE ATOM AT ,3F8.5,11H WAS PUT AT,3F8.5)
      X(1) = X(L2)
      Y(1) = Y(L2)
      Z(1) =Z(L2)
      GO TO 103
1000  WRITE(6,112) NCTR(L)
112   FORMAT (22H0THE SYMMETRY OPERATOR ,I10,9H IS WRONG)
      STOP 7701
2000  CONTINUE
      WRITE(6,113)X(1),Y(1),Z(1)
113   FORMAT (  '0THERE ARE UNRESOLVABLE PROBLEMS WITH THE POSITION SET'
     *  ,3F8.5,/,' ATTEMPTS TO DEFINE THE TRUE SITE SYMMETRY WERE ',
     * 'ABANDONED.')
120   IF ( ABS(X(1)-Y(1))+ABS(X(1)-Z(1)).LE.0.0002 ) GO TO 200
      DO 130 L2=2,L1
        IF ( ABS(X(L2)-Y(L2))+ABS(X(L2)-Z(L2)).LE.0.0002 ) GO TO 102
130     CONTINUE
200   CONTINUE
      KXB = MAX0( AND(KXB,18874367), AND(KXB,16777215))
      IF (  AND(KXB,384).EQ.384 ) KXB= OR(KXB,512)
      RETURN
      END
      SUBROUTINE CEL000
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C
C                             THIS SR IS USED TO FORCE A POINT XYZ TO
C                           LIE IN THE UNIT CELL AT 000.
C
      COMMON/BLNK1/ N(2),L,X(192),Y(192),Z(192),XLT,IXB,FILL(192)
      X(L-1) = AMOD(X(L-1)+8.0,1.0)
      IF ( X(L-1)-.99999 ) 2,1,1
1     X(L-1) = 0.0
2     Y(L-1) = AMOD(Y(L-1)+8.0,1.0)
      IF ( Y(L-1)-.99999 ) 4,3,3
3     Y(L-1) = 0.0
4     Z(L-1) = AMOD(Z(L-1)+8.0,1.0)
      IF ( Z(L-1)-.99999 ) 6,5,5
5     Z(L-1) = 0.0
6     RETURN
      END
      SUBROUTINE OP1
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C
C                             THIS SR GENERATES THE OPERATORS FOR
C                           SMTRY2, DETERMINES THE POLARITY OF THE SPACE
C                           GROUP, NOTES THE PRESENCE OF A CENTER(1BAR),
C                           AND GENERATES A SET OF PSEUDO-OPERATORS FOR
C                           USE IN SYMOPR TO DEFINE SITE SYMMETRY.
      COMMON /SPG/NSP,NOR,NCONT(10),NC,NPOL,MULT
      COMMON/BLNK1/N(581),NCTR(192)
      COMMON /HKLCTL/KL(4,24),NC1(10,7),IC,N1,IER,HN
***vax modification
      INTEGER AND
      AND(I,J) = IAND(I,J)
***vax
      K = 2
      NPOL = 7
      DO 40 I=1,7
40      NC1(1,I) = 0
      NCTR(1) = 0
      DO 100 I=1,8
        IF ( NCONT(I).LE.0 ) GO TO 101
        IF ( NCONT(I).LT.8192 ) GO TO 80
        IF ( NCONT(I).LE.08192 ) GO TO 60
        IF ( NCONT(I).EQ.16384 ) GO TO 70
        NPOL = 4
        NC1(I,1) = 2
50      DO 51 J=2,7
51        NC1(I,J) = 0
        NC1(I,6) = MOD(NCONT(I)/4,32)
        GO TO 90
60      NC1 (I,1) = 3
        NPOL = 1
        GO TO 50
70      NC1(I,1) = 1
        GO TO 50
80      NC1(I,1) = 0
        NC1(I,2) = MOD(NCONT(I),4)
        NC1(I,3) = MOD(NCONT(I)/4,4)
        NC1(I,4) = MOD(NCONT(I)/16,4)
        NC1(I,5) = MOD(NCONT(I)/64,4)
        NC1(I,6) = MOD(NCONT(I)/256,2)
        NC1(I,7) = MOD(NCONT(I)/512,16)
90      CONTINUE
        L = K-1
        DO 100 J=1,L
          IF ( NCONT(I).EQ.8192 ) GO TO 95
***vax modification
            NCTR(K) = AND( ieOR(NCONT(I),NCTR (J )),57651)
*            NCTR(K) = AND( XOR(NCONT(I),NCTR (J )),57651)
***vax
          IF( AND(NCONT(I),17).EQ.0) GO TO 92
          IF( AND(NCTR(J),34).EQ.0) GO TO 92
          IF( AND(NCTR(J),34).EQ.34) GO TO 92
***vax modification
            NCTR(K)= ieOR(NCTR(K),34)
*            NCTR(K)= XOR(NCTR(K),34)
***vax
92        CONTINUE
          K = K+1
          IF ( NCONT(I).LT.8192 ) GO TO 100
          NCTR(K) = NCTR(K-1)+32768
          K = K+1
          GO TO 100
95        CONTINUE
          NCTR(K  ) = 0
          NCTR(K+1) = 0
          K = K+2
100       CONTINUE
101   MULT = K-1
      N1 = I-1
      IF ( N1.LT.2 ) GO TO 105
      DO 102 N2=2,N1
        IF ( NC1(N2-1,1).EQ.1 ) GO TO 103
102     CONTINUE
      GO TO 105
103   DO 104 I=N2,N1
        DO 104 J=1,7
104       NC1(I-1,J) = NC1(I,J)
      NC1(N1,1) = 1
105   CONTINUE
      NC = 1
      DO 200 I=1,MULT
***vax modification
          IF (  ieOR(NCTR(I),290).EQ.0 ) NC = 0
*          IF (  XOR(NCTR(I),290).EQ.0 ) NC = 0
***vax
        IF ( AND(NCTR(I),3).GT.0 ) NPOL = AND(NPOL,6)
        IF ( AND(NCTR(I),48).GT.0 ) NPOL = AND(NPOL,5)
200     IF ( AND(NCTR(I),256).GT.0 ) NPOL = AND(NPOL,3)
      RETURN
      END
      SUBROUTINE SMTRY2
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C                             THIS SR GENERATES THE FULL SET OF
C                           EQUIVALENT HKLS FROM ANY MEMBER OF THE SET.
C                           IT ALSO DETERMINES THE PHASE SHIFTS RELATIVE
C                           TO THE INPUT HKL PHASE.
      COMMON /HKLCTL/K(3,24),A(24),NCONT(10,7),IC,N1,IER
     *  ,HM
      COMMON /SPG/NSP(12),NC,FILL(2)
      common/vax/ lvax
      logical lvax
      DIMENSION KD(6),KE(3),KF(3)
      DIMENSION NCH(24),NCK(24),NCL(24)
      DIMENSION LD(3,24)
      DIMENSION IPH(24)
      DATA KD(1),KD(2),KD(3),KD(4),KD(5),KD(6)/0,6,3,9,4,8/
      DATA KE(1),KE(2),KE(3),KF(1),KF(2),KF(3)/0,4,8,0,8,4/
CDB 1
C   1 FORMAT (7I5,F10.5,10I3)
      IF ( NC.GT.0 ) GO TO 14
      IF ( K(1,1) ) 11,9,14
9     IF ( K(2,1) ) 12,10,14
10    IF ( K(3,1) ) 13,14,14
11    K(1,1) = -K(1,1)
12    K(2,1) = -K(2,1)
13    K(3,1) = -K(3,1)
14    CONTINUE
      IPH(1) = K(3,1)+512*(K(2,1)+512*K(1,1))
      CI = 1.0
      IC = 1
      A(1) = 0.0
      LD(1,1) = 0
      LD(2,1) = 0
      LD(3,1) = 0
      NCH(1) = 0
      NCK(1) = 0
      NCL(1) = 1
      IF ( N1.EQ.0 ) GO TO 1000
      L = 2
      DO 900 I=1,N1
        CI = CI*2.0
        IF ( NCONT(I,1).GT.0 ) CI = CI*1.5
        DO 890 J=1,IC
          NCO = NCONT(I,1)+1
          GO TO (20,700,800,15),NCO
          CALL GOTOER
15        IF(MOD(K(1,1)-K(2,1)-K(3,1),3).NE.0 ) GO TO 1002
          GO TO 900
***vax modification
20          NCH(L) =  ieOR(NCH(J),NCONT(I,2))
            IF(MOD(NCONT(I,2),2).NE.0) NCH(L)= ieOR(NCK(J),NCONT(I,2))
*            NCH(L) =  XOR(NCH(J),NCONT(I,2))
*            IF(MOD(NCONT(I,2),2).NE.0) NCH(L)= XOR(NCK(J),NCONT(I,2))
***vax
          M = 1+MOD(NCH(L),2)
          MS = 1-2*MOD(NCH(L)/2,2)
          N = IABS(NCL(J))
          K(M,L) = K(1,N)*MS
          M = 1+MOD(NCONT(I,2),2)
          MS = 1-2*MOD(NCONT(I,2)/2,2)
          NCX = NCONT(I,3)+1
          LD(1,L) = KD(NCX)+LD(M,J)*MS
***vax modification
            NCK(L) =  ieOR(NCK(J),NCONT(I,4))
            IF(MOD(NCONT(I,4),2).NE.0) NCK(L)= ieOR(NCH(J),NCONT(I,4))
*            NCK(L) =  XOR(NCK(J),NCONT(I,4))
*            IF(MOD(NCONT(I,4),2).NE.0) NCK(L)= XOR(NCH(J),NCONT(I,4))
***vax
          M = 2-MOD(NCK(L),2)
          MS = 1-2*MOD(NCK(L)/2,2)
          K(M,L) = K(2,N)*MS
          M = 2-MOD(NCONT(I,4),2)
          MS = 1-2*MOD(NCONT(I,4)/2,2)
          NCX = NCONT(I,5)+1
          LD(2,L) = KD(NCX)+LD(M,J)*MS
          MS = (1-2*NCONT(I,6))*ISIGN(1,NCL(J))
          NCL(L) = MS*NCL(N)
          K(3,L) = K(3,N)*MS
70        NCO = NCONT(I,7)+1
          IF ( NCO.GT.5 ) NCO=6
          MS = 1-2*NCONT(I,6)
          IF ( N.GT.1.AND.NCK(J).GE.4.AND.M.EQ.1 ) MS=-MS
          LD(3,L) = KD(NCO)+LD(3,J)*MS
80        IXIT = 0
81        CONTINUE
          IPH(L) = K(3,L)+512*(K(2,L)+512*K(1,L))
87        LA = LD(1,L)*K(1,1)+LD(2,L)*K(2,1)+LD(3,L)*K(3,1)
          A(L) = FLOAT(LA)/12.0
CDB 2
C     IF ( J1(20).GT.0 ) PRINT 1,L,(K(M,L),M=1,3),(LD(M,L),M=1,3),A(L),
C    Z NCH(L),NCK(L),NCL(L),(NCONT(I,M),M=1,7)
          IF ( NC.NE.0 ) GO TO 89
          IF ( NSP(1).LT.12 ) GO TO 89
          IF ( NCONT(I,1).GT.0 ) GO TO 89
          IF ( MOD(NCONT(I,2),2).EQ.1 ) GO TO 89
          IF ( IPH(L).LE.0 ) GO TO 680
89        CONTINUE
          DO 90 M=2,L
            IF ( IPH(M-1).EQ.IPH(L) ) GO TO 690
            IF ( NC.NE.0 ) GO TO 90
            IF ( IPH(M-1).EQ.-IPH(L) ) GO TO 690
90          CONTINUE
          L = L+1
680       IF ( IXIT-1 ) 890,750,850
690       IF ( AMOD(ABS(A(L)-A(M-1)),1.).NE.0. ) GO TO 1002
          GO TO 680
700       IXIT = 2
          JD = J
750       IXIT = IXIT-1
          LD(1,L) = LD(1,JD)
          LD(2,L) = LD(2,JD)
          LD(3,L) = LD(3,JD)
          NCH(L) = 0
          NCK(L) = 0
          NCL(L) = L
          K1JD = K(1,JD)
          K(1,L) = K(2,JD)
          K(2,L) = K(3,JD)
          K(3,L) = K1JD
          JD = L
          GO TO 81
800       IXIT = 4
          JD = J
          NCO = NCONT(I,6)
850       IXIT = IXIT-2
          NCH(L) = 0
          NCK(L) = 4
          NCL(L) = L
          LD(1,L) = 0
          LD(2,L) = 0
          K(1,L) = -K(1,JD)-K(2,JD)
          K(2,L) = K(1,JD)
          K(3,L) = K(3,JD)
          LD(3,L) = KF(NCO)+LD(3,JD)
          IF ( MOD(NCH(J),2).NE.0 ) LD(3,L)=KE(NCO)+LD(3,JD)
          JD = L
          GO TO 81
890       CONTINUE
900     IC = L-1
1000  IER = 0
      HM = CI/FLOAT(IC)
      IF ( NC.NE.0 ) GO TO 1001
      DO 1003 M=2,IC
        IF ( IPH(M).GT.0 ) GO TO 1003
        K(1,M) = -K(1,M)
        K(2,M) = -K(2,M)
        K(3,M) = -K(3,M)
1003    CONTINUE
1001  RETURN
1002  IER = 1
      GO TO 1001
      END
      SUBROUTINE LOOKUP(K,N,NSCAT,IXRAY,JOB)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      INTEGER PTR,TBXPTR
      CHARACTER*4 TABNC(128),TBXC(256)
      COMMON/TABCHR/TABNC,TBXC
      COMMON/TABLES/TBX(256,10),TBD(128,10),TABN(128)
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/DC/SAVE(8,6),NSAVE
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCATX
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      IOF=0
      NS=0
      IF(K.GT.1) THEN
        DO 4320 IIPHAS=2,K
4320      IOF = IOF + NATOM(IIPHAS-1)
      END IF
      IF(K.GT.1)NS=NSAVE
      IF(JOB.EQ.2.OR.JOB.EQ.4)GOTO 70
      DO 10 I=1,N
        NS=MAX0(NSCAT,NS)
        DO 20 J=1,NS
          IF(NTYP(I+IOF).EQ.NAM(J))GOTO 30
20        CONTINUE
        DO 40 J=1,212
          IF(NTYP(I+IOF).EQ.TBXC(J))GOTO 50
40        CONTINUE
        WRITE(6,41)NTYP(I+IOF)
41      FORMAT(' SCATTERING COEFFICIENTS NOT FOUND FOR ',A4)
        STOP ' SCATTERING DATA MISSING'
30      PTR(I+IOF)=J
        GOTO 10
50      NS=NS+1
        PTR(I+IOF)=NS
        DO 60 L=1,9
60        AC(L,NS)=TBX(J,L)
        NAM(NS)=TBXC(J)
        TBXPTR=TBX(J,10)+0.5
        DFP(NS)=TBD(TBXPTR,IXRAY)
        DFPP(NS)=TBD(TBXPTR,IXRAY+5)
10      CONTINUE
      NSAVE=NS
      RETURN
70    DO 80 I=1,N
        NS=MAX0(NSCAT,NS)
        DO 90 J=1,NS
          IF(NTYP(I+IOF).EQ.NAM(J))GOTO 100
90        CONTINUE
        DO 110 J=1,85
          IF(NTYP(I+IOF).EQ.TABNC(J))GOTO 120
110       CONTINUE
        WRITE(6,111)NTYP(I+IOF)
111     FORMAT(34H SCATTERING LENGTHS NOT FOUND FOR ,A4)
        STOP ' SCATTERING DATA MISSING'
100     PTR(I+IOF)=J
        GOTO 80
120     NS=NS+1
        PTR(I+IOF)=NS
        DFP(NS)=TABN(J)
        NAM(NS)=TABNC(J)
80      CONTINUE
      NSAVE=NS
      RETURN
      END
      SUBROUTINE CELL2
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/SPG/NSPGRP,K,FILL(13)
      COMMON/CELLX/A,B,C,ALPHA,BETA,GAMMA,AL(3,3)
      EQUIVALENCE (AL(1,1),ASTAR),(AL(2,2),BSTAR),(AL(3,3),CSTAR),
     * (AL(1,2),BACOSC),(AL(1,3),CACOSB),(AL(2,3),BCCOSA)
35    FORMAT (22H0THE LAUE SYMMETRY IS ,A8)
      CHARACTER*8 LAU(14)
      DATA LAU(1),LAU(2),LAU(3),LAU(4),LAU(5),LAU(6),LAU(7),LAU(8),
     * LAU(9),LAU(10),LAU(11),LAU(12),LAU(13),LAU(14)
     *  /'1BAR','2/M','MMM','4/M','4/MMM','3BAR   R','3BAR M R','3BAR',
     *   '3BAR M 1','3BAR 1 M','6/M','6/MMM','M3','M3M'/
      SIN1(A) = SIN(A*6.28318531)
      COS1(A) = COS(A*6.28318531)
      WRITE(6,35)LAU(NSPGRP)
      IF ( K.GT.3 ) STOP 5001
      GO TO (1002,1071,1072,1073,1073,1074,1074,1075,1075,1075,1075,
     *  1075,1076,1076),NSPGRP
      CALL GOTOER
1071  IF ( K.NE.1 ) ALPHA=90.0
      IF ( K.NE.2 ) BETA=90.0
      IF ( K.NE.3) GAMMA=90.0
      GO TO 1002
1073  B = A
1072  ALPHA = 90.0
      BETA = 90.0
      GAMMA = 90.0
      GO TO 1002
1074  B = A
      C = A
      BETA = ALPHA
      GAMMA = ALPHA
      GO TO 1002
1075  B = A
      ALPHA = 90.
      BETA = 90.0
      GAMMA = 120.0
      GO TO 1002
1076  B = A
      C = A
      GO TO 1072
1002  COSA = COS1(ALPHA/360.0)
105   COSB = COS1(BETA/360.0)
1052  COSC = COS1(GAMMA/360.0)
1053  SINA=SQRT(1.0-COSA**2)
      SINB=SQRT(1.0-COSB**2)
      SINC=SQRT(1.0-COSC**2)
      COSASR=(COSB*COSC-COSA)/(SINB*SINC)
      COSBSR=(COSA*COSC-COSB)/(SINA*SINC)
      COSCSR=(COSA*COSB-COSC)/(SINA*SINB)
      SINASR=SQRT(1.0-COSASR**2)
      SINBSR=SQRT(1.0-COSBSR**2)
      ASTAR=1.0/(A*SINC*SINBSR)
      BSTAR=1.0/(B *SINC*SINASR)
      CSTAR=1.0/(C*SINA*SINBSR)
      BCCOSA=BSTAR*CSTAR*COSASR*2.0
      CACOSB=CSTAR*ASTAR*COSBSR*2.0
      BACOSC=BSTAR*ASTAR*COSCSR*2.0
      ASTAR=ASTAR*ASTAR
      BSTAR=BSTAR*BSTAR
      CSTAR=CSTAR*CSTAR
      RETURN
      END
      FUNCTION MULT(IH,IK,IL,KXIS)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/SPG/NSPGRP,K,M(10),FILL(3)
      P = 2.0
      GO TO (220,100,110,120,130,150,180,140,170,160,170,190,200,210),
     * NSPGRP
      CALL GOTOER
100   CONTINUE
      IF ( IH ) 220, 220, 101
101   CONTINUE
      IF ( KXIS.EQ.3 ) THEN
        IF ( IL.GT.0 .AND. IH+IABS(IK).GT.0 ) P=2.0*P
      ELSE
        IF ( IK.GT.0 .AND. IH+IABS(IL).GT.0 ) P=2.0*P
      END IF
      GO TO 220
110   P = 1.0
      IF ( IH ) 112,112,111
111   P = 2.0*P
112   IF ( IK ) 114,114,113
113   P = 2.0*P
114   IF ( IL ) 220,220,115
115   P = 2.0*P
      GO TO 220
120   IF ( IK ) 220,220,121
121   P = 2.0*P
      IF ( IL ) 220,220,122
122   P = 2.0*P
      GO TO 220
130   IF ( IK ) 220,220,131
131   P = 2.0*P
      IF ( IH ) 134,134,132
132   IF ( IH-IK ) 133,134,134
133   P = 2.0*P
134   IF ( IL ) 220,220,135
135   P = 2.0*P
      GO TO 220
140   IF ( IH+IABS(IK) ) 142,142,141
141   P = 3.0*P
142   IF ( IL ) 220,220,143
143   P = 2.0*P
      GO TO 220
150   IF ( IH+IK+IL ) 151,152,151
151   P = 2.0*P
152   IF ( IH-IK ) 153,154,153
153   P = 3.0*P
      GO TO 220
154   IF ( IH-IL ) 153,220,153
160   IF ( IK ) 220,220,161
161   P = 3.0*P
      IF ( IK-IH ) 220,220,162
162   IF ( IH ) 220,220,135
170   IF ( IL ) 172,172,171
171   P = 2.0*P
172   IF ( IH ) 174,174,173
173   P = 3.0*P
      IF ( IK ) 220,220,135
174   IF ( IK ) 220,220,153
180   IF ( IH-IK ) 182,181,182
181   IF ( IH-IL ) 183,220,183
182   IF ( IK-IL ) 184,183,184
183   P = P/2.0
184   P = 3.0*P
      IF ( IH+IK+IL ) 135,220,135
190   IF ( IK ) 194,194,191
191   P = 6.0*P
      IF ( IH ) 192,194,192
192   IF ( IK-IH ) 193,194,193
193   P = 2.0*P
194   IF ( IL ) 135,220,135
200   IF ( IH-IK ) 203,201,203
201   IF ( IK-IL ) 203,202,203
202   P = 4.0*P
      GO TO 220
203   P = 3.0*P
      IF ( IK ) 205,205,204
204   P = 2.0*P
205   IF ( IH ) 220,220,135
210   IF ( IH ) 211,214,211
211   P = 4.0*P
      IF ( IH-IL ) 212,220,212
212   P = 3.0*P
      IF ( IH-IK ) 213,220,213
213   IF ( IK-IL ) 135,220,135
214   P = 3.0*P
      IF ( IK ) 215,220,215
215   P = 2.0*P
      IF ( IK-IL ) 135,220,135
220   MULT=P
      RETURN
      END
      BLOCK DATA FTABLE
      CHARACTER*4 TABNC(128),TBXC(256)
      COMMON/TABCHR/TABNC,TBXC
      COMMON/TABLES/TBX(256,10),TBD(128,10),TABN(128)
      DATA TABNC(1),TABN(1)/'H',-0.372/
      DATA TABNC(2),TABN(2)/'HE',0.3/
      DATA TABNC(3),TABN(3)/'LI',-0.194/
      DATA TABNC(4),TABN(4)/'BE',0.774/
      DATA TABNC(5),TABN(5)/'B',0.54/
      DATA TABNC(6),TABN(6)/'C',0.663/
      DATA TABNC(7),TABN(7)/'N',0.94/
      DATA TABNC(8),TABN(8)/'O',0.575/
      DATA TABNC(9),TABN(9)/'F',0.57/
      DATA TABNC(10),TABN(10)/'NE',0.46/
      DATA TABNC(11),TABN(11)/'NA',0.351/
      DATA TABNC(12),TABN(12)/'MG',0.52/
      DATA TABNC(13),TABN(13)/'AL',0.345/
      DATA TABNC(14),TABN(14)/'SI',0.415/
      DATA TABNC(15),TABN(15)/'P',0.51/
      DATA TABNC(16),TABN(16)/'S',0.285/
      DATA TABNC(17),TABN(17)/'CL',0.958/
      DATA TABNC(18),TABN(18)/'AR',0.20/
      DATA TABNC(19),TABN(19)/'K',0.37/
      DATA TABNC(20),TABN(20)/'CA',0.47/
      DATA TABNC(21),TABN(21)/'SC',1.18/
      DATA TABNC(22),TABN(22)/'TI',-0.33/
      DATA TABNC(23),TABN(23)/'V',-0.05/
      DATA TABNC(24),TABN(24)/'CR',0.352/
      DATA TABNC(25),TABN(25)/'MN',-0.36/
      DATA TABNC(26),TABN(26)/'FE',0.95/
      DATA TABNC(27),TABN(27)/'CO',0.25/
      DATA TABNC(28),TABN(28)/'NI',1.03/
      DATA TABNC(29),TABN(29)/'CU',0.76/
      DATA TABNC(30),TABN(30)/'ZN',0.57/
      DATA TABNC(31),TABN(31)/'GA',0.72/
      DATA TABNC(32),TABN(32)/'GE',0.84/
      DATA TABNC(33),TABN(33)/'AS',0.64/
      DATA TABNC(34),TABN(34)/'SE',0.80/
      DATA TABNC(35),TABN(35)/'BR',0.68/
      DATA TABNC(36),TABN(36)/'KR',0.74/
      DATA TABNC(37),TABN(37)/'RB',0.70/
      DATA TABNC(38),TABN(38)/'SR',0.69/
      DATA TABNC(39),TABN(39)/'Y',0.79/
      DATA TABNC(40),TABN(40)/'ZR',0.69/
      DATA TABNC(41),TABN(41)/'NB',0.71/
      DATA TABNC(42),TABN(42)/'MO',0.66/
      DATA TABNC(43),TABN(43)/'TC',0.68/
      DATA TABNC(44),TABN(44)/'RU',0.73/
      DATA TABNC(45),TABN(45)/'RH',0.59/
      DATA TABNC(46),TABN(46)/'PD',0.60/
      DATA TABNC(47),TABN(47)/'AG',0.61/
      DATA TABNC(48),TABN(48)/'CD',0.37/
      DATA TABNC(49),TABN(49)/'IN',0.39/
      DATA TABNC(50),TABN(50)/'SN',0.61/
      DATA TABNC(51),TABN(51)/'SB',0.56/
      DATA TABNC(52),TABN(52)/'TE',0.54/
      DATA TABNC(53),TABN(53)/'I',0.52/
      DATA TABNC(54),TABN(54)/'XE',0.47/
      DATA TABNC(55),TABN(55)/'CS',0.55/
      DATA TABNC(56),TABN(56)/'BA',0.52/
      DATA TABNC(57),TABN(57)/'LA',0.83/
      DATA TABNC(58),TABN(58)/'CE',0.55/
      DATA TABNC(59),TABN(59)/'PR',0.44/
      DATA TABNC(60),TABN(60)/'ND',0.72/
      DATA TABNC(61),TABN(61)/'EU',0.55/
      DATA TABNC(62),TABN(62)/'GD',1.5/
      DATA TABNC(63),TABN(63)/'TB',0.76/
      DATA TABNC(64),TABN(64)/'DY',1.69/
      DATA TABNC(65),TABN(65)/'HO',0.85/
      DATA TABNC(66),TABN(66)/'ER',0.79/
      DATA TABNC(67),TABN(67)/'TM',0.69/
      DATA TABNC(68),TABN(68)/'YB',1.26/
      DATA TABNC(69),TABN(69)/'LU',0.73/
      DATA TABNC(70),TABN(70)/'HF',0.78/
      DATA TABNC(71),TABN(71)/'TA',0.70/
      DATA TABNC(72),TABN(72)/'W',0.48/
      DATA TABNC(73),TABN(73)/'RE',0.92/
      DATA TABNC(74),TABN(74)/'OS',1.07/
      DATA TABNC(75),TABN(75)/'IR',1.06/
      DATA TABNC(76),TABN(76)/'PT',0.95/
      DATA TABNC(77),TABN(77)/'AU',0.76/
      DATA TABNC(78),TABN(78)/'HG',1.27/
      DATA TABNC(79),TABN(79)/'TL',0.89/
      DATA TABNC(80),TABN(80)/'PB',0.94/
      DATA TABNC(81),TABN(81)/'BI',0.85/
      DATA TABNC(82),TABN(82)/'TH',0.99/
      DATA TABNC(83),TABN(83)/'U',0.84/
      DATA TABNC(84),TABN(84)/'NP',1.055/
      DATA TABNC(85),TABN(85)/'PU',0.75/
      DATA TBD(  2, 1),TBD(  2, 2),TBD(  2, 3),TBD(  2, 4),TBD(  2, 5)
     *     /   .002    ,   .002    ,   .001    ,  -.000    ,  -.000    /
      DATA TBD(  2, 6),TBD(  2, 7),TBD(  2, 8),TBD(  2, 9),TBD(  2,10)
     *     /   .001    ,   .001    ,   .000    ,   .000    ,   .000    /
      DATA TBD(  3, 1),TBD(  3, 2),TBD(  3, 3),TBD(  3, 4),TBD(  3, 5)
     *     /   .008    ,   .005    ,   .003    ,  -.000    ,  -.001    /
      DATA TBD(  3, 6),TBD(  3, 7),TBD(  3, 8),TBD(  3, 9),TBD(  3,10)
     *     /   .003    ,   .002    ,   .001    ,   .000    ,   .000    /
      DATA TBD(  4, 1),TBD(  4, 2),TBD(  4, 3),TBD(  4, 4),TBD(  4, 5)
     *     /   .018    ,   .013    ,   .008    ,   .000    ,  -.000    /
      DATA TBD(  4, 6),TBD(  4, 7),TBD(  4, 8),TBD(  4, 9),TBD(  4,10)
     *     /   .009    ,   .007    ,   .004    ,   .001    ,   .000    /
      DATA TBD(  5, 1),TBD(  5, 2),TBD(  5, 3),TBD(  5, 4),TBD(  5, 5)
     *     /   .035    ,   .026    ,   .017    ,   .002    ,   .000    /
      DATA TBD(  5, 6),TBD(  5, 7),TBD(  5, 8),TBD(  5, 9),TBD(  5,10)
     *     /   .021    ,   .015    ,   .009    ,   .002    ,   .001    /
      DATA TBD(  6, 1),TBD(  6, 2),TBD(  6, 3),TBD(  6, 4),TBD(  6, 5)
     *     /   .059    ,   .044    ,   .029    ,   .004    ,   .001    /
      DATA TBD(  6, 6),TBD(  6, 7),TBD(  6, 8),TBD(  6, 9),TBD(  6,10)
     *     /   .042    ,   .029    ,   .018    ,   .003    ,   .002    /
      DATA TBD(  7, 1),TBD(  7, 2),TBD(  7, 3),TBD(  7, 4),TBD(  7, 5)
     *     /   .090    ,   .069    ,   .047    ,   .008    ,   .003    /
      DATA TBD(  7, 6),TBD(  7, 7),TBD(  7, 8),TBD(  7, 9),TBD(  7,10)
     *     /   .073    ,   .052    ,   .032    ,   .006    ,   .004    /
      DATA TBD(  8, 1),TBD(  8, 2),TBD(  8, 3),TBD(  8, 4),TBD(  8, 5)
     *     /   .129    ,   .100    ,   .069    ,   .014    ,   .006    /
      DATA TBD(  8, 6),TBD(  8, 7),TBD(  8, 8),TBD(  8, 9),TBD(  8,10)
     *     /   .119    ,   .085    ,   .053    ,   .010    ,   .006    /
      DATA TBD(  9, 1),TBD(  9, 2),TBD(  9, 3),TBD(  9, 4),TBD(  9, 5)
     *     /   .174    ,   .138    ,   .097    ,   .021    ,   .011    /
      DATA TBD(  9, 6),TBD(  9, 7),TBD(  9, 8),TBD(  9, 9),TBD(  9,10)
     *     /   .184    ,   .132    ,   .083    ,   .016    ,   .010    /
      DATA TBD( 10, 1),TBD( 10, 2),TBD( 10, 3),TBD( 10, 4),TBD( 10, 5)
     *     /   .223    ,   .180    ,   .129    ,   .030    ,   .016    /
      DATA TBD( 10, 6),TBD( 10, 7),TBD( 10, 8),TBD( 10, 9),TBD( 10,10)
     *     /   .270    ,   .195    ,   .124    ,   .025    ,   .015    /
      DATA TBD( 11, 1),TBD( 11, 2),TBD( 11, 3),TBD( 11, 4),TBD( 11, 5)
     *     /   .272    ,   .224    ,   .165    ,   .042    ,   .023    /
      DATA TBD( 11, 6),TBD( 11, 7),TBD( 11, 8),TBD( 11, 9),TBD( 11,10)
     *     /   .381    ,   .277    ,   .177    ,   .036    ,   .022    /
      DATA TBD( 12, 1),TBD( 12, 2),TBD( 12, 3),TBD( 12, 4),TBD( 12, 5)
     *     /   .318    ,   .269    ,   .204    ,   .056    ,   .032    /
      DATA TBD( 12, 6),TBD( 12, 7),TBD( 12, 8),TBD( 12, 9),TBD( 12,10)
     *     /   .522    ,   .381    ,   .246    ,   .052    ,   .031    /
      DATA TBD( 13, 1),TBD( 13, 2),TBD( 13, 3),TBD( 13, 4),TBD( 13, 5)
     *     /   .355    ,   .311    ,   .244    ,   .072    ,   .042    /
      DATA TBD( 13, 6),TBD( 13, 7),TBD( 13, 8),TBD( 13, 9),TBD( 13,10)
     *     /   .693    ,   .509    ,   .330    ,   .071    ,   .043    /
      DATA TBD( 14, 1),TBD( 14, 2),TBD( 14, 3),TBD( 14, 4),TBD( 14, 5)
     *     /   .377    ,   .347    ,   .283    ,   .090    ,   .055    /
      DATA TBD( 14, 6),TBD( 14, 7),TBD( 14, 8),TBD( 14, 9),TBD( 14,10)
     *     /   .900    ,   .664    ,   .434    ,   .095    ,   .058    /
      DATA TBD( 15, 1),TBD( 15, 2),TBD( 15, 3),TBD( 15, 4),TBD( 15, 5)
     *     /   .374    ,   .370    ,   .319    ,   .110    ,   .068    /
      DATA TBD( 15, 6),TBD( 15, 7),TBD( 15, 8),TBD( 15, 9),TBD( 15,10)
     *     /  1.142    ,   .847    ,   .557    ,   .124    ,   .076    /
      DATA TBD( 16, 1),TBD( 16, 2),TBD( 16, 3),TBD( 16, 4),TBD( 16, 5)
     *     /   .335    ,   .375    ,   .348    ,   .132    ,   .084    /
      DATA TBD( 16, 6),TBD( 16, 7),TBD( 16, 8),TBD( 16, 9),TBD( 16,10)
     *     /  1.423    ,  1.061    ,   .702    ,   .159    ,   .099    /
      DATA TBD( 17, 1),TBD( 17, 2),TBD( 17, 3),TBD( 17, 4),TBD( 17, 5)
     *     /   .243    ,   .352    ,   .366    ,   .155    ,   .101    /
      DATA TBD( 17, 6),TBD( 17, 7),TBD( 17, 8),TBD( 17, 9),TBD( 17,10)
     *     /  1.747    ,  1.309    ,   .872    ,   .201    ,   .125    /
      DATA TBD( 18, 1),TBD( 18, 2),TBD( 18, 3),TBD( 18, 4),TBD( 18, 5)
     *     /   .070    ,   .286    ,   .365    ,   .179    ,   .118    /
      DATA TBD( 18, 6),TBD( 18, 7),TBD( 18, 8),TBD( 18, 9),TBD( 18,10)
     *     /  2.110    ,  1.589    ,  1.066    ,   .250    ,   .156    /
      DATA TBD( 19, 1),TBD( 19, 2),TBD( 19, 3),TBD( 19, 4),TBD( 19, 5)
     *     /  -.221    ,   .163    ,   .341    ,   .203    ,   .137    /
      DATA TBD( 19, 6),TBD( 19, 7),TBD( 19, 8),TBD( 19, 9),TBD( 19,10)
     *     /  2.514    ,  1.904    ,  1.286    ,   .306    ,   .193    /
      DATA TBD( 20, 1),TBD( 20, 2),TBD( 20, 3),TBD( 20, 4),TBD( 20, 5)
     *     /  -.717    ,  -.038    ,   .285    ,   .226    ,   .156    /
      DATA TBD( 20, 6),TBD( 20, 7),TBD( 20, 8),TBD( 20, 9),TBD( 20,10)
     *     /  2.968    ,  2.256    ,  1.533    ,   .372    ,   .235    /
      DATA TBD( 21, 1),TBD( 21, 2),TBD( 21, 3),TBD( 21, 4),TBD( 21, 5)
     *     / -1.683    ,  -.357    ,   .189    ,   .248    ,   .175    /
      DATA TBD( 21, 6),TBD( 21, 7),TBD( 21, 8),TBD( 21, 9),TBD( 21,10)
     *     /  3.470    ,  2.643    ,  1.807    ,   .446    ,   .283    /
      DATA TBD( 22, 1),TBD( 22, 2),TBD( 22, 3),TBD( 22, 4),TBD( 22, 5)
     *     / -3.841    ,  -.896    ,   .035    ,   .267    ,   .194    /
      DATA TBD( 22, 6),TBD( 22, 7),TBD( 22, 8),TBD( 22, 9),TBD( 22,10)
     *     /   .459    ,  3.070    ,  2.110    ,   .530    ,   .338    /
      DATA TBD( 23, 1),TBD( 23, 2),TBD( 23, 3),TBD( 23, 4),TBD( 23, 5)
     *     / -2.161    , -1.973    ,  -.198    ,   .284    ,   .213    /
      DATA TBD( 23, 6),TBD( 23, 7),TBD( 23, 8),TBD( 23, 9),TBD( 23,10)
     *     /   .548    ,  3.533    ,  2.443    ,   .624    ,   .399    /
      DATA TBD( 24, 1),TBD( 24, 2),TBD( 24, 3),TBD( 24, 4),TBD( 24, 5)
     *     / -1.639    , -3.367    ,  -.568    ,   .295    ,   .229    /
      DATA TBD( 24, 6),TBD( 24, 7),TBD( 24, 8),TBD( 24, 9),TBD( 24,10)
     *     /   .650    ,   .481    ,  2.808    ,   .729    ,   .468    /
      DATA TBD( 25, 1),TBD( 25, 2),TBD( 25, 3),TBD( 25, 4),TBD( 25, 5)
     *     / -1.339    , -2.095    , -1.179    ,   .301    ,   .244    /
      DATA TBD( 25, 6),TBD( 25, 7),TBD( 25, 8),TBD( 25, 9),TBD( 25,10)
     *     /   .764    ,   .566    ,  3.204    ,   .845    ,   .545    /
      DATA TBD( 26, 1),TBD( 26, 2),TBD( 26, 3),TBD( 26, 4),TBD( 26, 5)
     *     / -1.124    , -1.623    , -2.464    ,   .299    ,   .256    /
      DATA TBD( 26, 6),TBD( 26, 7),TBD( 26, 8),TBD( 26, 9),TBD( 26,10)
     *     /   .893    ,   .662    ,  3.608    ,   .973    ,   .630    /
      DATA TBD( 27, 1),TBD( 27, 2),TBD( 27, 3),TBD( 27, 4),TBD( 27, 5)
     *     /  -.956    , -1.343    , -2.956    ,   .285    ,   .261    /
      DATA TBD( 27, 6),TBD( 27, 7),TBD( 27, 8),TBD( 27, 9),TBD( 27,10)
     *     /  1.036    ,   .769    ,   .509    ,  1.113    ,   .724    /
      DATA TBD( 28, 1),TBD( 28, 2),TBD( 28, 3),TBD( 28, 4),TBD( 28, 5)
     *     /  -.795    , -1.129    , -2.019    ,   .263    ,   .265    /
      DATA TBD( 28, 6),TBD( 28, 7),TBD( 28, 8),TBD( 28, 9),TBD( 28,10)
     *     /  1.196    ,   .888    ,   .589    ,  1.266    ,   .826    /
      DATA TBD( 29, 1),TBD( 29, 2),TBD( 29, 3),TBD( 29, 4),TBD( 29, 5)
     *     /  -.684    ,  -.978    , -1.612    ,   .222    ,   .260    /
      DATA TBD( 29, 6),TBD( 29, 7),TBD( 29, 8),TBD( 29, 9),TBD( 29,10)
     *     /  1.373    ,  1.021    ,   .678    ,  1.431    ,   .938    /
      DATA TBD( 30, 1),TBD( 30, 2),TBD( 30, 3),TBD( 30, 4),TBD( 30, 5)
     *     /  -.570    ,  -.841    , -1.354    ,   .163    ,   .249    /
      DATA TBD( 30, 6),TBD( 30, 7),TBD( 30, 8),TBD( 30, 9),TBD( 30,10)
     *     /  1.569    ,  1.168    ,   .777    ,  1.609    ,  1.059    /
      DATA TBD( 31, 1),TBD( 31, 2),TBD( 31, 3),TBD( 31, 4),TBD( 31, 5)
     *     /  -.462    ,  -.717    , -1.163    ,   .081    ,   .228    /
      DATA TBD( 31, 6),TBD( 31, 7),TBD( 31, 8),TBD( 31, 9),TBD( 31,10)
     *     /  1.786    ,  1.331    ,   .886    ,  1.801    ,  1.190    /
      DATA TBD( 32, 1),TBD( 32, 2),TBD( 32, 3),TBD( 32, 4),TBD( 32, 5)
     *     /  -.365    ,  -.607    , -1.011    ,  -.030    ,   .196    /
      DATA TBD( 32, 6),TBD( 32, 7),TBD( 32, 8),TBD( 32, 9),TBD( 32,10)
     *     /  2.022    ,  1.508    ,  1.006    ,  2.007    ,  1.332    /
      DATA TBD( 33, 1),TBD( 33, 2),TBD( 33, 3),TBD( 33, 4),TBD( 33, 5)
     *     /  -.273    ,  -.503    ,  -.879    ,  -.178    ,   .152    /
      DATA TBD( 33, 6),TBD( 33, 7),TBD( 33, 8),TBD( 33, 9),TBD( 33,10)
     *     /  2.283    ,  1.704    ,  1.139    ,  2.223    ,  1.481    /
      DATA TBD( 34, 1),TBD( 34, 2),TBD( 34, 3),TBD( 34, 4),TBD( 34, 5)
     *     /  -.198    ,  -.413    ,  -.767    ,  -.374    ,   .090    /
      DATA TBD( 34, 6),TBD( 34, 7),TBD( 34, 8),TBD( 34, 9),TBD( 34,10)
     *     /  2.563    ,  1.916    ,  1.283    ,  2.456    ,  1.643    /
      DATA TBD( 35, 1),TBD( 35, 2),TBD( 35, 3),TBD( 35, 4),TBD( 35, 5)
     *     /  -.130    ,  -.328    ,  -.665    ,  -.652    ,   .008    /
      DATA TBD( 35, 6),TBD( 35, 7),TBD( 35, 8),TBD( 35, 9),TBD( 35,10)
     *     /  2.872    ,  2.149    ,  1.439    ,  2.713    ,  1.820    /
      DATA TBD( 36, 1),TBD( 36, 2),TBD( 36, 3),TBD( 36, 4),TBD( 36, 5)
     *     /  -.082    ,  -.256    ,  -.574    , -1.044    ,  -.099    /
      DATA TBD( 36, 6),TBD( 36, 7),TBD( 36, 8),TBD( 36, 9),TBD( 36,10)
     *     /  3.201    ,  2.398    ,  1.608    ,  2.973    ,  2.003    /
      DATA TBD( 37, 1),TBD( 37, 2),TBD( 37, 3),TBD( 37, 4),TBD( 37, 5)
     *     /  -.012    ,  -.161    ,  -.465    , -1.657    ,  -.230    /
      DATA TBD( 37, 6),TBD( 37, 7),TBD( 37, 8),TBD( 37, 9),TBD( 37,10)
     *     /  3.608    ,  2.709    ,  1.820    ,  3.264    ,  2.203    /
      DATA TBD( 38, 1),TBD( 38, 2),TBD( 38, 3),TBD( 38, 4),TBD( 38, 5)
     *     /   .006    ,  -.106    ,  -.386    , -2.951    ,  -.406    /
      DATA TBD( 38, 6),TBD( 38, 7),TBD( 38, 8),TBD( 38, 9),TBD( 38,10)
     *     /  4.002    ,  3.009    ,  2.025    ,  3.542    ,  2.411    /
      DATA TBD( 39, 1),TBD( 39, 2),TBD( 39, 3),TBD( 39, 4),TBD( 39, 5)
     *     /   .007    ,  -.061    ,  -.314    , -2.965    ,  -.639    /
      DATA TBD( 39, 6),TBD( 39, 7),TBD( 39, 8),TBD( 39, 9),TBD( 39,10)
     *     /  4.422    ,  3.329    ,  2.245    ,   .560    ,  2.630    /
      DATA TBD( 40, 1),TBD( 40, 2),TBD( 40, 3),TBD( 40, 4),TBD( 40, 5)
     *     /  -.013    ,  -.028    ,  -.248    , -2.197    ,  -.957    /
      DATA TBD( 40, 6),TBD( 40, 7),TBD( 40, 8),TBD( 40, 9),TBD( 40,10)
     *     /  4.876    ,  3.676    ,  2.482    ,   .621    ,  2.860    /
      DATA TBD( 41, 1),TBD( 41, 2),TBD( 41, 3),TBD( 41, 4),TBD( 41, 5)
     *     /  -.063    ,  -.012    ,  -.191    , -1.825    , -1.416    /
      DATA TBD( 41, 6),TBD( 41, 7),TBD( 41, 8),TBD( 41, 9),TBD( 41,10)
     *     /  5.353    ,  4.043    ,  2.735    ,   .688    ,  3.103    /
      DATA TBD( 42, 1),TBD( 42, 2),TBD( 42, 3),TBD( 42, 4),TBD( 42, 5)
     *     /  -.153    ,  -.017    ,  -.145    , -1.590    , -2.205    /
      DATA TBD( 42, 6),TBD( 42, 7),TBD( 42, 8),TBD( 42, 9),TBD( 42,10)
     *     /  5.862    ,  4.434    ,  3.005    ,   .759    ,  3.353    /
      DATA TBD( 43, 1),TBD( 43, 2),TBD( 43, 3),TBD( 43, 4),TBD( 43, 5)
     *     /  -.270    ,  -.039    ,  -.105    , -1.420    , -5.524    /
      DATA TBD( 43, 6),TBD( 43, 7),TBD( 43, 8),TBD( 43, 9),TBD( 43,10)
     *     /  6.406    ,  4.854    ,  3.296    ,   .836    ,  3.651    /
      DATA TBD( 44, 1),TBD( 44, 2),TBD( 44, 3),TBD( 44, 4),TBD( 44, 5)
     *     /  -.424    ,  -.083    ,  -.077    , -1.287    , -2.649    /
      DATA TBD( 44, 6),TBD( 44, 7),TBD( 44, 8),TBD( 44, 9),TBD( 44,10)
     *     /  6.984    ,  5.300    ,  3.605    ,   .919    ,   .596    /
      DATA TBD( 45, 1),TBD( 45, 2),TBD( 45, 3),TBD( 45, 4),TBD( 45, 5)
     *     /  -.639    ,  -.157    ,  -.059    , -1.177    , -2.128    /
      DATA TBD( 45, 6),TBD( 45, 7),TBD( 45, 8),TBD( 45, 9),TBD( 45,10)
     *     /  7.594    ,  5.773    ,  3.934    ,  1.007    ,   .654    /
      DATA TBD( 46, 1),TBD( 46, 2),TBD( 46, 3),TBD( 46, 4),TBD( 46, 5)
     *     /  -.924    ,  -.259    ,  -.060    , -1.085    , -1.834    /
      DATA TBD( 46, 6),TBD( 46, 7),TBD( 46, 8),TBD( 46, 9),TBD( 46,10)
     *     /  8.235    ,  6.271    ,  4.282    ,  1.101    ,   .717    /
      DATA TBD( 47, 1),TBD( 47, 2),TBD( 47, 3),TBD( 47, 4),TBD( 47, 5)
     *     / -1.303    ,  -.416    ,  -.079    , -1.005    , -1.637    /
      DATA TBD( 47, 6),TBD( 47, 7),TBD( 47, 8),TBD( 47, 9),TBD( 47,10)
     *     /  8.912    ,  6.800    ,  4.653    ,  1.202    ,   .783    /
      DATA TBD( 48, 1),TBD( 48, 2),TBD( 48, 3),TBD( 48, 4),TBD( 48, 5)
     *     / -1.788    ,  -.626    ,  -.126    ,  -.936    , -1.493    /
      DATA TBD( 48, 6),TBD( 48, 7),TBD( 48, 8),TBD( 48, 9),TBD( 48,10)
     *     /  9.627    ,  7.356    ,  5.045    ,  1.310    ,   .854    /
      DATA TBD( 49, 1),TBD( 49, 2),TBD( 49, 3),TBD( 49, 4),TBD( 49, 5)
     *     / -2.401    ,  -.888    ,  -.194    ,  -.873    , -1.378    /
      DATA TBD( 49, 6),TBD( 49, 7),TBD( 49, 8),TBD( 49, 9),TBD( 49,10)
     *     / 10.380    ,  7.943    ,  5.459    ,  1.424    ,   .930    /
      DATA TBD( 50, 1),TBD( 50, 2),TBD( 50, 3),TBD( 50, 4),TBD( 50, 5)
     *     / -3.194    , -1.214    ,  -.287    ,  -.816    , -1.284    /
      DATA TBD( 50, 6),TBD( 50, 7),TBD( 50, 8),TBD( 50, 9),TBD( 50,10)
     *     / 11.166    ,  8.557    ,  5.894    ,  1.546    ,  1.010    /
      DATA TBD( 51, 1),TBD( 51, 2),TBD( 51, 3),TBD( 51, 4),TBD( 51, 5)
     *     / -4.267    , -1.630    ,  -.418    ,  -.772    , -1.212    /
      DATA TBD( 51, 6),TBD( 51, 7),TBD( 51, 8),TBD( 51, 9),TBD( 51,10)
     *     / 11.995    ,  9.203    ,  6.352    ,  1.675    ,  1.096    /
      DATA TBD( 52, 1),TBD( 52, 2),TBD( 52, 3),TBD( 52, 4),TBD( 52, 5)
     *     / -5.852    , -2.147    ,  -.579    ,  -.726    , -1.144    /
      DATA TBD( 52, 6),TBD( 52, 7),TBD( 52, 8),TBD( 52, 9),TBD( 52,10)
     *     / 12.850    ,  9.885    ,  6.835    ,  1.812    ,  1.187    /
      DATA TBD( 53, 1),TBD( 53, 2),TBD( 53, 3),TBD( 53, 4),TBD( 53, 5)
     *     / -8.133    , -2.812    ,  -.783    ,  -.684    , -1.084    /
      DATA TBD( 53, 6),TBD( 53, 7),TBD( 53, 8),TBD( 53, 9),TBD( 53,10)
     *     / 11.933    , 10.608    ,  7.348    ,  1.958    ,  1.284    /
      DATA TBD( 54, 1),TBD( 54, 2),TBD( 54, 3),TBD( 54, 4),TBD( 54, 5)
     *     / 10.742    , -3.652    , -1.022    ,  -.644    , -1.029    /
      DATA TBD( 54, 6),TBD( 54, 7),TBD( 54, 8),TBD( 54, 9),TBD( 54,10)
     *     / 12.919    , 11.382    ,  7.904    ,  2.119    ,  1.391    /
      DATA TBD( 55, 1),TBD( 55, 2),TBD( 55, 3),TBD( 55, 4),TBD( 55, 5)
     *     / 11.460    , -4.832    , -1.334    ,  -.613    ,  -.983    /
      DATA TBD( 55, 6),TBD( 55, 7),TBD( 55, 8),TBD( 55, 9),TBD( 55,10)
     *     /  9.981    , 12.164    ,  8.460    ,  2.282    ,  1.500    /
      DATA TBD( 56, 1),TBD( 56, 2),TBD( 56, 3),TBD( 56, 4),TBD( 56, 5)
     *     / 12.135    , -6.683    , -1.716    ,  -.588    ,  -.942    /
      DATA TBD( 56, 6),TBD( 56, 7),TBD( 56, 8),TBD( 56, 9),TBD( 56,10)
     *     /  3.565    , 12.937    ,  9.036    ,  2.452    ,  1.615    /
      DATA TBD( 57, 1),TBD( 57, 2),TBD( 57, 3),TBD( 57, 4),TBD( 57, 5)
     *     / -9.574    , -8.388    , -2.170    ,  -.564    ,  -.904    /
      DATA TBD( 57, 6),TBD( 57, 7),TBD( 57, 8),TBD( 57, 9),TBD( 57,10)
     *     /  3.843    , 11.953    ,  9.648    ,  2.632    ,  1.735    /
      DATA TBD( 58, 1),TBD( 58, 2),TBD( 58, 3),TBD( 58, 4),TBD( 58, 5)
     *     / -7.817    , 12.457    , -2.939    ,  -.530    ,  -.859    /
      DATA TBD( 58, 6),TBD( 58, 7),TBD( 58, 8),TBD( 58, 9),TBD( 58,10)
     *     /  4.130    ,  6.285    , 10.535    ,  2.845    ,  1.873    /
      DATA TBD( 59, 1),TBD( 59, 2),TBD( 59, 3),TBD( 59, 4),TBD( 59, 5)
     *     / -7.486    , 11.016    , -3.431    ,  -.535    ,  -.842    /
      DATA TBD( 59, 6),TBD( 59, 7),TBD( 59, 8),TBD( 59, 9),TBD( 59,10)
     *     /  4.427    ,  9.874    , 10.933    ,  3.018    ,  1.995    /
      DATA TBD( 60, 1),TBD( 60, 2),TBD( 60, 3),TBD( 60, 4),TBD( 60, 5)
     *     / -6.891    , 12.122    , -4.357    ,  -.530    ,  -.818    /
      DATA TBD( 60, 6),TBD( 60, 7),TBD( 60, 8),TBD( 60, 9),TBD( 60,10)
     *     /  4.741    ,  3.627    , 11.614    ,  3.225    ,  2.135    /
      DATA TBD( 61, 1),TBD( 61, 2),TBD( 61, 3),TBD( 61, 4),TBD( 61, 5)
     *     / -6.429    , -9.616    , -5.696    ,  -.533    ,  -.798    /
      DATA TBD( 61, 6),TBD( 61, 7),TBD( 61, 8),TBD( 61, 9),TBD( 61,10)
     *     /  5.073    ,  3.883    , 12.320    ,  3.442    ,  2.281    /
      DATA TBD( 62, 1),TBD( 62, 2),TBD( 62, 3),TBD( 62, 4),TBD( 62, 5)
     *     / -6.050    , -8.352    , -7.718    ,  -.542    ,  -.782    /
      DATA TBD( 62, 6),TBD( 62, 7),TBD( 62, 8),TBD( 62, 9),TBD( 62,10)
     *     /  5.416    ,  4.149    , 11.276    ,  3.669    ,  2.435    /
      DATA TBD( 63, 1),TBD( 63, 2),TBD( 63, 3),TBD( 63, 4),TBD( 63, 5)
     *     / -5.779    , -7.565    , -9.242    ,  -.564    ,  -.774    /
      DATA TBD( 63, 6),TBD( 63, 7),TBD( 63, 8),TBD( 63, 9),TBD( 63,10)
     *     /  5.773    ,  4.427    , 11.946    ,  3.904    ,  2.595    /
      DATA TBD( 64, 1),TBD( 64, 2),TBD( 64, 3),TBD( 64, 4),TBD( 64, 5)
     *     / -5.525    , -6.980    , -9.498    ,  -.591    ,  -.767    /
      DATA TBD( 64, 6),TBD( 64, 7),TBD( 64, 8),TBD( 64, 9),TBD( 64,10)
     *     /  6.153    ,  4.721    ,  9.242    ,  4.151    ,  2.764    /
      DATA TBD( 65, 1),TBD( 65, 2),TBD( 65, 3),TBD( 65, 4),TBD( 65, 5)
     *     / -5.250    , -6.492    , 10.423    ,  -.619    ,  -.761    /
      DATA TBD( 65, 6),TBD( 65, 7),TBD( 65, 8),TBD( 65, 9),TBD( 65,10)
     *     /  6.549    ,  5.026    ,  9.748    ,  4.410    ,  2.940    /
      DATA TBD( 66, 1),TBD( 66, 2),TBD( 66, 3),TBD( 66, 4),TBD( 66, 5)
     *     / -5.040    , -6.112    , 12.255    ,  -.666    ,  -.765    /
      DATA TBD( 66, 6),TBD( 66, 7),TBD( 66, 8),TBD( 66, 9),TBD( 66,10)
     *     /  6.958    ,  5.343    ,  3.704    ,  4.678    ,  3.124    /
      DATA TBD( 67, 1),TBD( 67, 2),TBD( 67, 3),TBD( 67, 4),TBD( 67, 5)
     *     / -4.878    , -5.810    , -9.733    ,  -.723    ,  -.773    /
      DATA TBD( 67, 6),TBD( 67, 7),TBD( 67, 8),TBD( 67, 9),TBD( 67,10)
     *     /  7.387    ,  5.675    ,  3.937    ,  4.958    ,  3.316    /
      DATA TBD( 68, 1),TBD( 68, 2),TBD( 68, 3),TBD( 68, 4),TBD( 68, 5)
     *     / -4.753    , -5.565    , -8.488    ,  -.795    ,  -.790    /
      DATA TBD( 68, 6),TBD( 68, 7),TBD( 68, 8),TBD( 68, 9),TBD( 68,10)
     *     /  7.833    ,  6.022    ,  4.181    ,  5.248    ,  3.515    /
      DATA TBD( 69, 1),TBD( 69, 2),TBD( 69, 3),TBD( 69, 4),TBD( 69, 5)
     *     / -4.652    , -5.361    , -7.701    ,  -.884    ,  -.815    /
      DATA TBD( 69, 6),TBD( 69, 7),TBD( 69, 8),TBD( 69, 9),TBD( 69,10)
     *     /  8.291    ,  6.378    ,  4.432    ,  5.548    ,  3.723    /
      DATA TBD( 70, 1),TBD( 70, 2),TBD( 70, 3),TBD( 70, 4),TBD( 70, 5)
     *     / -4.580    , -5.190    , -7.133    ,  -.988    ,  -.847    /
      DATA TBD( 70, 6),TBD( 70, 7),TBD( 70, 8),TBD( 70, 9),TBD( 70,10)
     *     /  8.759    ,  6.745    ,  4.693    ,  5.858    ,  3.937    /
      DATA TBD( 71, 1),TBD( 71, 2),TBD( 71, 3),TBD( 71, 4),TBD( 71, 5)
     *     / -4.592    , -5.088    , -6.715    , -1.118    ,  -.890    /
      DATA TBD( 71, 6),TBD( 71, 7),TBD( 71, 8),TBD( 71, 9),TBD( 71,10)
     *     /  9.277    ,  7.148    ,  4.977    ,  6.185    ,  4.164    /
      DATA TBD( 72, 1),TBD( 72, 2),TBD( 72, 3),TBD( 72, 4),TBD( 72, 5)
     *     / -4.540    , -4.948    , -6.351    , -1.258    ,  -.937    /
      DATA TBD( 72, 6),TBD( 72, 7),TBD( 72, 8),TBD( 72, 9),TBD( 72,10)
     *     /  9.811    ,  7.565    ,  5.271    ,  6.523    ,  4.399    /
      DATA TBD( 73, 1),TBD( 73, 2),TBD( 73, 3),TBD( 73, 4),TBD( 73, 5)
     *     / -4.499    , -4.823    , -6.048    , -1.421    ,  -.993    /
      DATA TBD( 73, 6),TBD( 73, 7),TBD( 73, 8),TBD( 73, 9),TBD( 73,10)
     *     / 10.364    ,  7.996    ,  5.577    ,  6.872    ,  4.643    /
      DATA TBD( 74, 1),TBD( 74, 2),TBD( 74, 3),TBD( 74, 4),TBD( 74, 5)
     *     / -4.483    , -4.719    , -5.790    , -1.598    , -1.048    /
      DATA TBD( 74, 6),TBD( 74, 7),TBD( 74, 8),TBD( 74, 9),TBD( 74,10)
     *     / 10.929    ,  8.439    ,  5.891    ,  7.232    ,  4.894    /
      DATA TBD( 75, 1),TBD( 75, 2),TBD( 75, 3),TBD( 75, 4),TBD( 75, 5)
     *     / -4.503    , -4.647    , -5.581    , -1.816    , -1.127    /
      DATA TBD( 75, 6),TBD( 75, 7),TBD( 75, 8),TBD( 75, 9),TBD( 75,10)
     *     / 11.520    ,  8.903    ,  6.221    ,  7.605    ,  5.156    /
      DATA TBD( 76, 1),TBD( 76, 2),TBD( 76, 3),TBD( 76, 4),TBD( 76, 5)
     *     / -4.527    , -4.578    , -5.391    , -2.066    , -1.216    /
      DATA TBD( 76, 6),TBD( 76, 7),TBD( 76, 8),TBD( 76, 9),TBD( 76,10)
     *     / 12.140    ,  9.389    ,  6.566    ,  7.990    ,  5.427    /
      DATA TBD( 77, 1),TBD( 77, 2),TBD( 77, 3),TBD( 77, 4),TBD( 77, 5)
     *     / -4.584    , -4.535    , -5.233    , -2.352    , -1.319    /
      DATA TBD( 77, 6),TBD( 77, 7),TBD( 77, 8),TBD( 77, 9),TBD( 77,10)
     *     / 12.787    ,  9.895    ,  6.925    ,  8.388    ,  5.708    /
      DATA TBD( 78, 1),TBD( 78, 2),TBD( 78, 3),TBD( 78, 4),TBD( 78, 5)
     *     / -4.668    , -4.510    , -5.096    , -2.688    , -1.438    /
      DATA TBD( 78, 6),TBD( 78, 7),TBD( 78, 8),TBD( 78, 9),TBD( 78,10)
     *     / 13.451    , 10.418    ,  7.297    ,  8.798    ,  5.998    /
      DATA TBD( 79, 1),TBD( 79, 2),TBD( 79, 3),TBD( 79, 4),TBD( 79, 5)
     *     / -4.803    , -4.523    , -4.990    , -3.084    , -1.576    /
      DATA TBD( 79, 6),TBD( 79, 7),TBD( 79, 8),TBD( 79, 9),TBD( 79,10)
     *     / 14.143    , 10.963    ,  7.686    ,  9.223    ,  6.299    /
      DATA TBD( 80, 1),TBD( 80, 2),TBD( 80, 3),TBD( 80, 4),TBD( 80, 5)
     *     / -4.945    , -4.532    , -4.883    , -3.556    , -1.730    /
      DATA TBD( 80, 6),TBD( 80, 7),TBD( 80, 8),TBD( 80, 9),TBD( 80,10)
     *     / 14.860    , 11.528    ,  8.089    ,  9.659    ,  6.610    /
      DATA TBD( 81, 1),TBD( 81, 2),TBD( 81, 3),TBD( 81, 4),TBD( 81, 5)
     *     / -5.161    , -4.596    , -4.818    , -4.133    , -1.910    /
      DATA TBD( 81, 6),TBD( 81, 7),TBD( 81, 8),TBD( 81, 9),TBD( 81,10)
     *     / 15.595    , 12.108    ,  8.505    , 10.102    ,  6.930    /
      DATA TBD( 82, 1),TBD( 82, 2),TBD( 82, 3),TBD( 82, 4),TBD( 82, 5)
     *     / -5.420    , -4.688    , -4.776    , -4.861    , -2.116    /
      DATA TBD( 82, 6),TBD( 82, 7),TBD( 82, 8),TBD( 82, 9),TBD( 82,10)
     *     / 16.341    , 12.700    ,  8.930    , 10.559    ,  7.258    /
      DATA TBD( 83, 1),TBD( 83, 2),TBD( 83, 3),TBD( 83, 4),TBD( 83, 5)
     *     / -5.742    , -4.817    , -4.756    , -5.924    , -2.353    /
      DATA TBD( 83, 6),TBD( 83, 7),TBD( 83, 8),TBD( 83, 9),TBD( 83,10)
     *     / 17.139    , 13.331    ,  9.383    , 11.042    ,  7.600    /
      DATA TBD( 84, 1),TBD( 84, 2),TBD( 84, 3),TBD( 84, 4),TBD( 84, 5)
     *     / -6.132    , -4.992    , -4.772    , -7.444    , -2.630    /
      DATA TBD( 84, 6),TBD( 84, 7),TBD( 84, 8),TBD( 84, 9),TBD( 84,10)
     *     / 17.942    , 13.969    ,  9.843    ,  9.961    ,  7.949    /
      DATA TBD( 85, 1),TBD( 85, 2),TBD( 85, 3),TBD( 85, 4),TBD( 85, 5)
     *     / -6.545    , -5.173    , -4.787    , -8.862    , -2.932    /
      DATA TBD( 85, 6),TBD( 85, 7),TBD( 85, 8),TBD( 85, 9),TBD( 85,10)
     *     / 18.775    , 14.629    , 10.317    , 10.403    ,  8.307    /
      DATA TBD( 86, 1),TBD( 86, 2),TBD( 86, 3),TBD( 86, 4),TBD( 86, 5)
     *     / -7.052    , -5.402    , -4.833    , -7.912    , -3.285    /
      DATA TBD( 86, 6),TBD( 86, 7),TBD( 86, 8),TBD( 86, 9),TBD( 86,10)
     *     / 19.615    , 15.299    , 10.803    ,  7.754    ,  8.674    /
      DATA TBD( 87, 1),TBD( 87, 2),TBD( 87, 3),TBD( 87, 4),TBD( 87, 5)
     *     / -7.614    , -5.659    , -4.898    , -7.620    , -3.702    /
      DATA TBD( 87, 6),TBD( 87, 7),TBD( 87, 8),TBD( 87, 9),TBD( 87,10)
     *     / 20.461    , 15.977    , 11.296    ,  8.105    ,  9.047    /
      DATA TBD( 88, 1),TBD( 88, 2),TBD( 88, 3),TBD( 88, 4),TBD( 88, 5)
     *     / -8.318    , -5.976    , -4.994    , -7.725    , -4.192    /
      DATA TBD( 88, 6),TBD( 88, 7),TBD( 88, 8),TBD( 88, 9),TBD( 88,10)
     *     / 21.327    , 16.668    , 11.799    ,  8.472    ,  9.428    /
      DATA TBD( 89, 1),TBD( 89, 2),TBD( 89, 3),TBD( 89, 4),TBD( 89, 5)
     *     / -9.150    , -6.313    , -5.091    , -8.127    , -4.784    /
      DATA TBD( 89, 6),TBD( 89, 7),TBD( 89, 8),TBD( 89, 9),TBD( 89,10)
     *     / 22.240    , 17.397    , 12.330    ,  8.870    ,  9.819    /
      DATA TBD( 90, 1),TBD( 90, 2),TBD( 90, 3),TBD( 90, 4),TBD( 90, 5)
     *     / 10.382    , -6.695    , -5.216    , -8.960    , -5.555    /
      DATA TBD( 90, 6),TBD( 90, 7),TBD( 90, 8),TBD( 90, 9),TBD( 90,10)
     *     / 23.161    , 18.140    , 12.868    ,  9.284    , 10.227    /
      DATA TBD( 91, 1),TBD( 91, 2),TBD( 91, 3),TBD( 91, 4),TBD( 91, 5)
     *     / 10.930    , -7.126    , -5.359    , 10.673    , -6.735    /
      DATA TBD( 91, 6),TBD( 91, 7),TBD( 91, 8),TBD( 91, 9),TBD( 91,10)
     *     / 23.121    , 18.879    , 13.409    ,  9.654    , 10.637    /
      DATA TBD( 92, 1),TBD( 92, 2),TBD( 92, 3),TBD( 92, 4),TBD( 92, 5)
     *     / 12.152    , -7.624    , -5.529    , 11.158    , -7.842    /
      DATA TBD( 92, 6),TBD( 92, 7),TBD( 92, 8),TBD( 92, 9),TBD( 92,10)
     *     / 24.097    , 19.642    , 13.967    ,  4.148    ,  9.570    /
      DATA TBD( 93, 1),TBD( 93, 2),TBD( 93, 3),TBD( 93, 4),TBD( 93, 5)
     *     / 12.280    , -8.187    , -5.712    , -9.725    , -8.473    /
      DATA TBD( 93, 6),TBD( 93, 7),TBD( 93, 8),TBD( 93, 9),TBD( 93,10)
     *     / 23.658    , 20.425    , 14.536    ,  4.330    ,  6.999    /
      DATA TBD( 94, 1),TBD( 94, 2),TBD( 94, 3),TBD( 94, 4),TBD( 94, 5)
     *     / 12.771    , -8.872    , -5.930    , -8.926    , -7.701    /
      DATA TBD( 94, 6),TBD( 94, 7),TBD( 94, 8),TBD( 94, 9),TBD( 94,10)
     *     / 24.607    , 21.173    , 15.087    ,  4.511    ,  7.296    /
      DATA TBD( 95, 1),TBD( 95, 2),TBD( 95, 3),TBD( 95, 4),TBD( 95, 5)
     *     / 13.513    , -9.743    , -6.176    , -8.416    , -7.388    /
      DATA TBD( 95, 6),TBD( 95, 7),TBD( 95, 8),TBD( 95, 9),TBD( 95,10)
     *     / 25.540    , 21.896    , 15.634    ,  4.697    ,  7.589    /
      DATA TBD( 96, 1),TBD( 96, 2),TBD( 96, 3),TBD( 96, 4),TBD( 96, 5)
     *     / 14.827    , 10.539    , -6.498    , -7.990    , -7.485    /
      DATA TBD( 96, 6),TBD( 96, 7),TBD( 96, 8),TBD( 96, 9),TBD( 96,10)
     *     / 26.801    , 21.942    , 16.317    ,  4.908    ,  7.931    /
      DATA TBD( 97, 1),TBD( 97, 2),TBD( 97, 3),TBD( 97, 4),TBD( 97, 5)
     *     / 16.272    , 11.641    , -6.798    , -7.683    , -7.638    /
      DATA TBD( 97, 6),TBD( 97, 7),TBD( 97, 8),TBD( 97, 9),TBD( 97,10)
     *     / 27.898    , 22.785    , 16.930    ,  5.107    ,  8.246    /
      DATA TBXC( 1),TBX(  1,1),TBX(  1,2),TBX(  1,3),TBX(  1,4)
     *    /'H   '   ,.493002   ,10.5109   ,.322912   ,26.1257   /
      DATA TBX(  1,5),TBX(  1,6),TBX(  1,7),TBX(  1,8),TBX(  1,9)
     *    / .140191   ,3.14236   ,.040810   ,57.7997   ,.003038   /
      DATA TBX(  1,10)/1./
      DATA TBXC(  2),TBX(  2,1),TBX(  2,2),TBX(  2,3),TBX(  2,4)
     *    /'H   '   ,.489918   ,20.6593   ,.262003   ,7.74039   /
      DATA TBX(  2,5),TBX(  2,6),TBX(  2,7),TBX(  2,8),TBX(  2,9)
     *    / .196767   ,49.5519   ,.049879   ,2.20159   ,.001305   /
      DATA TBX(  2,10)/1./
      DATA TBXC(  3),TBX(  3,1),TBX(  3,2),TBX(  3,3),TBX(  3,4)
     *    /'H-1 '   ,.897661   ,53.1368   ,.565616   ,15.1870   /
      DATA TBX(  3,5),TBX(  3,6),TBX(  3,7),TBX(  3,8),TBX(  3,9)
     *    / .415815   ,186.576   ,.116973   ,3.56709   ,.002389   /
      DATA TBX(  3,10)/1./
      DATA TBXC(  4),TBX(  4,1),TBX(  4,2),TBX(  4,3),TBX(  4,4)
     *    /'HE  '   ,  .8734   , 9.1037   ,  .6309   , 3.3568   /
      DATA TBX(  4,5),TBX(  4,6),TBX(  4,7),TBX(  4,8),TBX(  4,9)
     *    /   .3112   ,22.9276   ,  .1780   ,  .9821   ,  .0064   /
      DATA TBX(  4,10)/1./
      DATA TBXC(  5),TBX(  5,1),TBX(  5,2),TBX(  5,3),TBX(  5,4)
     *    /'LI  '   , 1.1282   , 3.9546   ,  .7508   , 1.0524   /
      DATA TBX(  5,5),TBX(  5,6),TBX(  5,7),TBX(  5,8),TBX(  5,9)
     *    /   .6175   ,85.3905   ,  .4653   ,168.261   ,  .0377   /
      DATA TBX(  5,10)/2./
      DATA TBXC(  6),TBX(  6,1),TBX(  6,2),TBX(  6,3),TBX(  6,4)
     *    /'LI+1'   ,  .6968   , 4.6237   ,  .7888   , 1.9557   /
      DATA TBX(  6,5),TBX(  6,6),TBX(  6,7),TBX(  6,8),TBX(  6,9)
     *    /   .3414   ,  .6316   ,  .1563   ,10.0953   ,  .0167   /
      DATA TBX(  6,10)/2./
      DATA TBXC(  7),TBX(  7,1),TBX(  7,2),TBX(  7,3),TBX(  7,4)
     *    /'BE  '   , 1.5919   ,43.6427   , 1.1278   , 1.8623   /
      DATA TBX(  7,5),TBX(  7,6),TBX(  7,7),TBX(  7,8),TBX(  7,9)
     *    /   .5391   ,103.483   ,  .7029   ,  .5420   ,  .0385   /
      DATA TBX(  7,10)/3./
      DATA TBXC(  8),TBX(  8,1),TBX(  8,2),TBX(  8,3),TBX(  8,4)
     *    /'BE+2'   , 6.2603   ,  .0027   ,  .8849   ,  .8313   /
      DATA TBX(  8,5),TBX(  8,6),TBX(  8,7),TBX(  8,8),TBX(  8,9)
     *    /   .7993   , 2.2758   ,  .1647   , 5.1146   ,-6.1092   /
      DATA TBX(  8,10)/3./
      DATA TBXC(  9),TBX(  9,1),TBX(  9,2),TBX(  9,3),TBX(  9,4)
     *    /'B   '   , 2.0545   ,23.2185   , 1.3326   , 1.0210   /
      DATA TBX(  9,5),TBX(  9,6),TBX(  9,7),TBX(  9,8),TBX(  9,9)
     *    /  1.0979   ,60.3498   ,  .7068   ,  .1403   , -.1932   /
      DATA TBX(  9,10)/4./
      DATA TBXC( 10),TBX( 10,1),TBX( 10,2),TBX( 10,3),TBX( 10,4)
     *    /'C   '   , 2.3100   ,20.8439   , 1.0200   ,10.2075   /
      DATA TBX( 10,5),TBX( 10,6),TBX( 10,7),TBX( 10,8),TBX( 10,9)
     *    /  1.5886   ,  .5687   ,  .8650   ,51.6512   ,  .2156   /
      DATA TBX( 10,10)/5./
      DATA TBXC( 11),TBX( 11,1),TBX( 11,2),TBX( 11,3),TBX( 11,4)
     *    /'CVAL'   ,2.26069   ,22.6907   ,1.56165   ,.656665   /
      DATA TBX( 11,5),TBX( 11,6),TBX( 11,7),TBX( 11,8),TBX( 11,9)
     *    / 1.05075   ,9.75618   ,.839259   ,55.5949   ,.286977   /
      DATA TBX( 11,10)/5./
      DATA TBXC( 12),TBX( 12,1),TBX( 12,2),TBX( 12,3),TBX( 12,4)
     *    /'N   '   ,12.2126   ,  .0057   , 3.1322   , 9.8933   /
      DATA TBX( 12,5),TBX( 12,6),TBX( 12,7),TBX( 12,8),TBX( 12,9)
     *    /  2.0125   ,28.9975   , 1.1663   ,  .5826   ,-11.529   /
      DATA TBX( 12,10)/6./
      DATA TBXC( 13),TBX( 13,1),TBX( 13,2),TBX( 13,3),TBX( 13,4)
     *    /'O   '   , 3.0485   ,13.2771   , 2.2868   , 5.7011   /
      DATA TBX( 13,5),TBX( 13,6),TBX( 13,7),TBX( 13,8),TBX( 13,9)
     *    /  1.5463   ,  .3239   ,  .8670   ,32.9089   ,  .2508   /
      DATA TBX( 13,10)/7./
      DATA TBXC( 14),TBX( 14,1),TBX( 14,2),TBX( 14,3),TBX( 14,4)
     *    /'O-1 '   ,4.19160   ,12.8573   ,1.63969   ,4.17236   /
      DATA TBX( 14,5),TBX( 14,6),TBX( 14,7),TBX( 14,8),TBX( 14,9)
     *    / 1.52673   ,47.0179   ,-20.307   ,-.01404   ,21.9412   /
      DATA TBX( 14,10)/7./
      DATA TBXC( 15),TBX( 15,1),TBX( 15,2),TBX( 15,3),TBX( 15,4)
     *    /'F   '   , 3.5392   ,10.2825   , 2.6412   , 4.2944   /
      DATA TBX( 15,5),TBX( 15,6),TBX( 15,7),TBX( 15,8),TBX( 15,9)
     *    /  1.5170   ,  .2615   , 1.0243   ,26.1476   ,  .2776   /
      DATA TBX( 15,10)/8./
      DATA TBXC( 16),TBX( 16,1),TBX( 16,2),TBX( 16,3),TBX( 16,4)
     *    /'F-1 '   ,3.63220   ,5.27756   ,3.51057   ,14.7353   /
      DATA TBX( 16,5),TBX( 16,6),TBX( 16,7),TBX( 16,8),TBX( 16,9)
     *    / 1.26064   ,.442258   ,.940706   ,47.3437   ,.653396   /
      DATA TBX( 16,10)/8./
      DATA TBXC( 17),TBX( 17,1),TBX( 17,2),TBX( 17,3),TBX( 17,4)
     *    /'NE  '   , 3.9553   , 8.4042   , 3.1125   , 3.4262   /
      DATA TBX( 17,5),TBX( 17,6),TBX( 17,7),TBX( 17,8),TBX( 17,9)
     *    /  1.4546   ,  .2306   , 1.1251   ,21.7184   ,  .3515   /
      DATA TBX( 17,10)/9./
      DATA TBXC( 18),TBX( 18,1),TBX( 18,2),TBX( 18,3),TBX( 18,4)
     *    /'NA  '   , 4.7626   , 3.2850   , 3.1736   , 8.8422   /
      DATA TBX( 18,5),TBX( 18,6),TBX( 18,7),TBX( 18,8),TBX( 18,9)
     *    /  1.2674   ,  .3136   , 1.1128   ,129.424   ,  .6760   /
      DATA TBX( 18,10)/10./
      DATA TBXC( 19),TBX( 19,1),TBX( 19,2),TBX( 19,3),TBX( 19,4)
     *    /'NA+1'   , 3.2565   , 2.6671   , 3.9362   , 6.1153   /
      DATA TBX( 19,5),TBX( 19,6),TBX( 19,7),TBX( 19,8),TBX( 19,9)
     *    /  1.3998   ,  .2001   , 1.0032   ,14.0390   ,  .4040   /
      DATA TBX( 19,10)/10./
      DATA TBXC( 20),TBX( 20,1),TBX( 20,2),TBX( 20,3),TBX( 20,4)
     *    /'MG  '   , 5.4204   , 2.8275   , 2.1735   ,79.2611   /
      DATA TBX( 20,5),TBX( 20,6),TBX( 20,7),TBX( 20,8),TBX( 20,9)
     *    /  1.2269   ,  .3808   , 2.3073   , 7.1937   ,  .8584   /
      DATA TBX( 20,10)/11./
      DATA TBXC( 21),TBX( 21,1),TBX( 21,2),TBX( 21,3),TBX( 21,4)
     *    /'MG+2'   , 3.4988   , 2.1676   , 3.8378   , 4.7542   /
      DATA TBX( 21,5),TBX( 21,6),TBX( 21,7),TBX( 21,8),TBX( 21,9)
     *    /  1.3284   ,  .1850   ,  .8497   ,10.1411   ,  .4853   /
      DATA TBX( 21,10)/11./
      DATA TBXC( 22),TBX( 22,1),TBX( 22,2),TBX( 22,3),TBX( 22,4)
     *    /'AL  '   , 6.4202   , 3.0387   , 1.9002   ,  .7426   /
      DATA TBX( 22,5),TBX( 22,6),TBX( 22,7),TBX( 22,8),TBX( 22,9)
     *    /  1.5936   ,31.5472   , 1.9646   ,85.0886   , 1.1151   /
      DATA TBX( 22,10)/12./
      DATA TBXC( 23),TBX( 23,1),TBX( 23,2),TBX( 23,3),TBX( 23,4)
     *    /'AL+3'   ,4.17448   ,1.93816   ,3.38760   ,4.14553   /
      DATA TBX( 23,5),TBX( 23,6),TBX( 23,7),TBX( 23,8),TBX( 23,9)
     *    / 1.20296   ,.228753   ,.528137   ,8.28524   ,.706786   /
      DATA TBX( 23,10)/12./
      DATA TBXC( 24),TBX( 24,1),TBX( 24,2),TBX( 24,3),TBX( 24,4)
     *    /'SI  '   , 6.2915   , 2.4386   , 3.0353   ,32.3337   /
      DATA TBX( 24,5),TBX( 24,6),TBX( 24,7),TBX( 24,8),TBX( 24,9)
     *    /  1.9891   ,  .6785   , 1.5410   ,81.6937   , 1.1407   /
      DATA TBX( 24,10)/13./
      DATA TBXC( 25),TBX( 25,1),TBX( 25,2),TBX( 25,3),TBX( 25,4)
     *    /'SIV '   ,5.66269   ,2.66520   ,3.07164   ,38.6634   /
      DATA TBX( 25,5),TBX( 25,6),TBX( 25,7),TBX( 25,8),TBX( 25,9)
     *    / 2.62446   ,.916946   ,1.39320   ,93.5458   ,1.24707   /
      DATA TBX( 25,10)/13./
      DATA TBXC( 26),TBX( 26,1),TBX( 26,2),TBX( 26,3),TBX( 26,4)
     *    /'SI+4'   ,4.43918   ,1.64167   ,3.20345   ,3.43757   /
      DATA TBX( 26,5),TBX( 26,6),TBX( 26,7),TBX( 26,8),TBX( 26,9)
     *    / 1.19453   ,.214900   ,.416530   ,6.65365   ,.746297   /
      DATA TBX( 26,10)/13./
      DATA TBXC( 27),TBX( 27,1),TBX( 27,2),TBX( 27,3),TBX( 27,4)
     *    /'S   '   , 6.9053   , 1.4679   , 5.2034   ,22.2151   /
      DATA TBX( 27,5),TBX( 27,6),TBX( 27,7),TBX( 27,8),TBX( 27,9)
     *    /  1.4379   ,  .2536   , 1.5863   ,56.1720   ,  .8669   /
      DATA TBX( 27,10)/15./
      DATA TBXC( 28),TBX( 28,1),TBX( 28,2),TBX( 28,3),TBX( 28,4)
     *    /'P   '   , 6.4345   , 1.9067   , 4.1791   ,27.1570   /
      DATA TBX( 28,5),TBX( 28,6),TBX( 28,7),TBX( 28,8),TBX( 28,9)
     *    /  1.7800   ,  .5260   , 1.4908   ,68.1645   , 1.1149   /
      DATA TBX( 28,10)/14./
      DATA TBXC( 29),TBX( 29,1),TBX( 29,2),TBX( 29,3),TBX( 29,4)
     *    /'CL  '   ,11.4604   ,  .0104   , 7.1964   , 1.1662   /
      DATA TBX( 29,5),TBX( 29,6),TBX( 29,7),TBX( 29,8),TBX( 29,9)
     *    /  6.2556   ,18.5194   , 1.6455   ,47.7784   ,-9.5574   /
      DATA TBX( 29,10)/16./
      DATA TBXC( 30),TBX( 30,1),TBX( 30,2),TBX( 30,3),TBX( 30,4)
     *    /'CL-1'   ,18.2915   ,  .0066   , 7.2084   , 1.1717   /
      DATA TBX( 30,5),TBX( 30,6),TBX( 30,7),TBX( 30,8),TBX( 30,9)
     *    /  6.5337   ,19.5424   , 2.3386   ,60.4486   ,-16.378   /
      DATA TBX( 30,10)/16./
      DATA TBXC( 31),TBX( 31,1),TBX( 31,2),TBX( 31,3),TBX( 31,4)
     *    /'AR  '   , 7.4845   ,  .9072   , 6.7723   ,14.8407   /
      DATA TBX( 31,5),TBX( 31,6),TBX( 31,7),TBX( 31,8),TBX( 31,9)
     *    /   .6539   ,43.8983   , 1.6442   ,33.3929   , 1.4445   /
      DATA TBX( 31,10)/17./
      DATA TBXC( 32),TBX( 32,1),TBX( 32,2),TBX( 32,3),TBX( 32,4)
     *    /'K   '   , 8.2186   ,12.7949   , 7.4398   ,  .7748   /
      DATA TBX( 32,5),TBX( 32,6),TBX( 32,7),TBX( 32,8),TBX( 32,9)
     *    /  1.0519   ,213.187   ,  .8659   ,41.6841   , 1.4228   /
      DATA TBX( 32,10)/18./
      DATA TBXC( 33),TBX( 33,1),TBX( 33,2),TBX( 33,3),TBX( 33,4)
     *    /'K+1 '   , 7.9578   ,12.6331   , 7.4917   ,  .7674   /
      DATA TBX( 33,5),TBX( 33,6),TBX( 33,7),TBX( 33,8),TBX( 33,9)
     *    /  6.3590   , -.0020   , 1.1915   ,31.9128   ,-4.9978   /
      DATA TBX( 33,10)/18./
      DATA TBXC( 34),TBX( 34,1),TBX( 34,2),TBX( 34,3),TBX( 34,4)
     *    /'CA  '   , 8.6266   ,10.4421   , 7.3873   ,  .6599   /
      DATA TBX( 34,5),TBX( 34,6),TBX( 34,7),TBX( 34,8),TBX( 34,9)
     *    /  1.5899   ,85.7484   , 1.0211   ,178.437   , 1.3751   /
      DATA TBX( 34,10)/19./
      DATA TBXC( 35),TBX( 35,1),TBX( 35,2),TBX( 35,3),TBX( 35,4)
     *    /'CA+2'   ,15.6348   , -.0074   , 7.9518   ,  .6089   /
      DATA TBX( 35,5),TBX( 35,6),TBX( 35,7),TBX( 35,8),TBX( 35,9)
     *    /  8.4372   ,10.3116   ,  .8537   ,25.9905   ,-14.875   /
      DATA TBX( 35,10)/19./
      DATA TBXC( 36),TBX( 36,1),TBX( 36,2),TBX( 36,3),TBX( 36,4)
     *    /'SC  '   , 9.1890   , 9.0213   , 7.3679   ,  .5729   /
      DATA TBX( 36,5),TBX( 36,6),TBX( 36,7),TBX( 36,8),TBX( 36,9)
     *    /  1.6409   ,136.108   , 1.4680   ,51.3531   , 1.3329   /
      DATA TBX( 36,10)/20./
      DATA TBXC( 37),TBX( 37,1),TBX( 37,2),TBX( 37,3),TBX( 37,4)
     *    /'SC+3'   ,13.4008   ,.298540   ,8.02730   ,7.96290   /
      DATA TBX( 37,5),TBX( 37,6),TBX( 37,7),TBX( 37,8),TBX( 37,9)
     *    / 1.65943   ,-.28604   ,1.57936   ,16.0662   ,-6.6667   /
      DATA TBX( 37,10)/20./
      DATA TBXC( 38),TBX( 38,1),TBX( 38,2),TBX( 38,3),TBX( 38,4)
     *    /'TI  '   , 9.7595   , 7.8508   , 7.3558   ,  .5000   /
      DATA TBX( 38,5),TBX( 38,6),TBX( 38,7),TBX( 38,8),TBX( 38,9)
     *    /  1.6991   ,35.6338   , 1.9021   ,116.105   , 1.2807   /
      DATA TBX( 38,10)/21./
      DATA TBXC( 39),TBX( 39,1),TBX( 39,2),TBX( 39,3),TBX( 39,4)
     *    /'TI+2'   ,9.11423   ,7.52430   ,7.62174   ,.457585   /
      DATA TBX( 39,5),TBX( 39,6),TBX( 39,7),TBX( 39,8),TBX( 39,9)
     *    / 2.27930   ,19.5361   ,.087899   ,61.6558   ,.897155   /
      DATA TBX( 39,10)/21./
      DATA TBXC( 40),TBX( 40,1),TBX( 40,2),TBX( 40,3),TBX( 40,4)
     *    /'TI+3'   ,17.7344   ,.220610   ,8.73816   ,7.04716   /
      DATA TBX( 40,5),TBX( 40,6),TBX( 40,7),TBX( 40,8),TBX( 40,9)
     *    / 5.25691   ,-.15762   ,1.92134   ,15.9768   ,-14.652   /
      DATA TBX( 40,10)/21./
      DATA TBXC( 41),TBX( 41,1),TBX( 41,2),TBX( 41,3),TBX( 41,4)
     *    /'TI+4'   ,19.5114   ,.178847   ,8.23473   ,6.67018   /
      DATA TBX( 41,5),TBX( 41,6),TBX( 41,7),TBX( 41,8),TBX( 41,9)
     *    / 2.01341   ,-.29263   ,1.52080   ,12.9464   ,-13.280   /
      DATA TBX( 41,10)/21./
      DATA TBXC( 42),TBX( 42,1),TBX( 42,2),TBX( 42,3),TBX( 42,4)
     *    /'V   '   ,10.2971   , 6.8657   , 7.3511   ,  .4385   /
      DATA TBX( 42,5),TBX( 42,6),TBX( 42,7),TBX( 42,8),TBX( 42,9)
     *    /  2.0703   ,26.8938   , 2.0571   ,102.478   , 1.2199   /
      DATA TBX( 42,10)/22./
      DATA TBXC( 43),TBX( 43,1),TBX( 43,2),TBX( 43,3),TBX( 43,4)
     *    /'V+2 '   ,10.1060   , 6.8818   , 7.3541   ,  .4409   /
      DATA TBX( 43,5),TBX( 43,6),TBX( 43,7),TBX( 43,8),TBX( 43,9)
     *    /  2.2884   ,20.3004   ,  .0223   ,115.122   , 1.2298   /
      DATA TBX( 43,10)/22./
      DATA TBXC( 44),TBX( 44,1),TBX( 44,2),TBX( 44,3),TBX( 44,4)
     *    /'V+3 '   ,9.43141   ,6.39535   ,7.74190   ,.383349   /
      DATA TBX( 44,5),TBX( 44,6),TBX( 44,7),TBX( 44,8),TBX( 44,9)
     *    / 2.15343   ,15.1908   ,.016865   ,63.9690   ,.656565   /
      DATA TBX( 44,10)/22./
      DATA TBXC( 45),TBX( 45,1),TBX( 45,2),TBX( 45,3),TBX( 45,4)
     *    /'V+5 '   ,15.6887   ,.679003   ,8.14208   ,5.40135   /
      DATA TBX( 45,5),TBX( 45,6),TBX( 45,7),TBX( 45,8),TBX( 45,9)
     *    / 2.03081   ,9.97278   ,-9.5760   ,.940464   ,1.71430   /
      DATA TBX( 45,10)/22./
      DATA TBXC( 46),TBX( 46,1),TBX( 46,2),TBX( 46,3),TBX( 46,4)
     *    /'CR  '   ,10.6406   , 6.1038   , 7.3537   ,  .3920   /
      DATA TBX( 46,5),TBX( 46,6),TBX( 46,7),TBX( 46,8),TBX( 46,9)
     *    /  3.3240   ,20.2626   , 1.4922   ,98.7399   , 1.1832   /
      DATA TBX( 46,10)/23./
      DATA TBXC( 47),TBX( 47,1),TBX( 47,2),TBX( 47,3),TBX( 47,4)
     *    /'CR+2'   ,9.54034   ,5.66078   ,7.75090   ,.344261   /
      DATA TBX( 47,5),TBX( 47,6),TBX( 47,7),TBX( 47,8),TBX( 47,9)
     *    / 3.58274   ,13.3075   ,.509107   ,32.4224   ,.616898   /
      DATA TBX( 47,10)/23./
      DATA TBXC( 48),TBX( 48,1),TBX( 48,2),TBX( 48,3),TBX( 48,4)
     *    /'CR+3'   ,9.68090   ,5.59463   ,7.81136   ,.334393   /
      DATA TBX( 48,5),TBX( 48,6),TBX( 48,7),TBX( 48,8),TBX( 48,9)
     *    / 2.87603   ,12.8288   ,.113575   ,32.8761   ,.518275   /
      DATA TBX( 48,10)/23./
      DATA TBXC( 49),TBX( 49,1),TBX( 49,2),TBX( 49,3),TBX( 49,4)
     *    /'MN  '   ,11.2819   , 5.3409   , 7.3573   ,  .3432   /
      DATA TBX( 49,5),TBX( 49,6),TBX( 49,7),TBX( 49,8),TBX( 49,9)
     *    /  3.0193   ,17.8674   , 2.2441   ,83.7543   , 1.0896   /
      DATA TBX( 49,10)/24./
      DATA TBXC( 50),TBX( 50,1),TBX( 50,2),TBX( 50,3),TBX( 50,4)
     *    /'MN+2'   ,10.8061   , 5.2796   , 7.3620   ,  .3435   /
      DATA TBX( 50,5),TBX( 50,6),TBX( 50,7),TBX( 50,8),TBX( 50,9)
     *    /  3.5268   ,14.3430   ,  .2184   ,41.3235   , 1.0874   /
      DATA TBX( 50,10)/24./
      DATA TBXC( 51),TBX( 51,1),TBX( 51,2),TBX( 51,3),TBX( 51,4)
     *    /'MN+3'   ,9.84521   ,4.91797   ,7.87194   ,.294393   /
      DATA TBX( 51,5),TBX( 51,6),TBX( 51,7),TBX( 51,8),TBX( 51,9)
     *    / 3.56531   ,10.8171   ,.323613   ,24.1281   ,.393974   /
      DATA TBX( 51,10)/24./
      DATA TBXC( 52),TBX( 52,1),TBX( 52,2),TBX( 52,3),TBX( 52,4)
     *    /'MN+4'   ,9.96253   ,4.84850   ,7.97057   ,.283303   /
      DATA TBX( 52,5),TBX( 52,6),TBX( 52,7),TBX( 52,8),TBX( 52,9)
     *    / 2.76067   ,10.4852   ,.054447   ,27.5730   ,.251877   /
      DATA TBX( 52,10)/24./
      DATA TBXC( 53),TBX( 53,1),TBX( 53,2),TBX( 53,3),TBX( 53,4)
     *    /'FE  '   ,11.7695   , 4.7611   , 7.3573   ,  .3072   /
      DATA TBX( 53,5),TBX( 53,6),TBX( 53,7),TBX( 53,8),TBX( 53,9)
     *    /  3.5222   ,15.3535   , 2.3045   ,76.8805   , 1.0369   /
      DATA TBX( 53,10)/25./
      DATA TBXC( 54),TBX( 54,1),TBX( 54,2),TBX( 54,3),TBX( 54,4)
     *    /'FE+2'   ,11.0424   , 4.6538   , 7.3740   ,  .3053   /
      DATA TBX( 54,5),TBX( 54,6),TBX( 54,7),TBX( 54,8),TBX( 54,9)
     *    /  4.1346   ,12.0546   ,  .4399   ,31.2809   , 1.0097   /
      DATA TBX( 54,10)/25./
      DATA TBXC( 55),TBX( 55,1),TBX( 55,2),TBX( 55,3),TBX( 55,4)
     *    /'FE+3'   ,11.1764   , 4.6147   , 7.3863   ,  .3005   /
      DATA TBX( 55,5),TBX( 55,6),TBX( 55,7),TBX( 55,8),TBX( 55,9)
     *    /  3.3948   ,11.6729   ,  .0724   ,38.5566   ,  .9707   /
      DATA TBX( 55,10)/25./
      DATA TBXC( 56),TBX( 56,1),TBX( 56,2),TBX( 56,3),TBX( 56,4)
     *    /'CO  '   ,12.2841   , 4.2791   , 7.3409   ,  .2784   /
      DATA TBX( 56,5),TBX( 56,6),TBX( 56,7),TBX( 56,8),TBX( 56,9)
     *    /  4.0034   ,13.5359   , 2.3488   ,71.1692   , 1.0118   /
      DATA TBX( 56,10)/26./
      DATA TBXC( 57),TBX( 57,1),TBX( 57,2),TBX( 57,3),TBX( 57,4)
     *    /'CO+2'   ,11.2296   , 4.1231   , 7.3883   ,  .2726   /
      DATA TBX( 57,5),TBX( 57,6),TBX( 57,7),TBX( 57,8),TBX( 57,9)
     *    /  4.7393   ,10.2443   ,  .7108   ,25.6466   ,  .9324   /
      DATA TBX( 57,10)/26./
      DATA TBXC( 58),TBX( 58,1),TBX( 58,2),TBX( 58,3),TBX( 58,4)
     *    /'CO+3'   ,10.3380   ,3.90969   ,7.88173   ,.238668   /
      DATA TBX( 58,5),TBX( 58,6),TBX( 58,7),TBX( 58,8),TBX( 58,9)
     *    / 4.76795   ,8.35583   ,.725591   ,18.3491   ,.286667   /
      DATA TBX( 58,10)/26./
      DATA TBXC( 59),TBX( 59,1),TBX( 59,2),TBX( 59,3),TBX( 59,4)
     *    /'NI  '   ,12.8376   , 3.8785   , 7.2920   ,  .2565   /
      DATA TBX( 59,5),TBX( 59,6),TBX( 59,7),TBX( 59,8),TBX( 59,9)
     *    /  4.4438   ,12.1763   , 2.3800   ,66.3421   , 1.0341   /
      DATA TBX( 59,10)/27./
      DATA TBXC( 60),TBX( 60,1),TBX( 60,2),TBX( 60,3),TBX( 60,4)
     *    /'NI+2'   ,11.4166   , 3.6766   , 7.4005   ,  .2449   /
      DATA TBX( 60,5),TBX( 60,6),TBX( 60,7),TBX( 60,8),TBX( 60,9)
     *    /  5.3442   , 8.8730   ,  .9773   ,22.1626   ,  .8614   /
      DATA TBX( 60,10)/27./
      DATA TBXC( 61),TBX( 61,1),TBX( 61,2),TBX( 61,3),TBX( 61,4)
     *    /'NI+3'   ,10.7806   ,3.54770   ,7.75868   ,.223140   /
      DATA TBX( 61,5),TBX( 61,6),TBX( 61,7),TBX( 61,8),TBX( 61,9)
     *    / 5.22746   ,7.64468   ,.847114   ,16.9673   ,.386044   /
      DATA TBX( 61,10)/27./
      DATA TBXC( 62),TBX( 62,1),TBX( 62,2),TBX( 62,3),TBX( 62,4)
     *    /'CU  '   ,13.3380   , 3.5828   , 7.1676   ,  .2470   /
      DATA TBX( 62,5),TBX( 62,6),TBX( 62,7),TBX( 62,8),TBX( 62,9)
     *    /  5.6158   ,11.3966   , 1.6735   ,64.8126   , 1.1910   /
      DATA TBX( 62,10)/28./
      DATA TBXC( 63),TBX( 63,1),TBX( 63,2),TBX( 63,3),TBX( 63,4)
     *    /'CU+1'   ,11.9475   , 3.3669   , 7.3573   ,  .2274   /
      DATA TBX( 63,5),TBX( 63,6),TBX( 63,7),TBX( 63,8),TBX( 63,9)
     *    /  6.2455   , 8.6625   , 1.5578   ,25.8487   ,  .8900   /
      DATA TBX( 63,10)/28./
      DATA TBXC( 64),TBX( 64,1),TBX( 64,2),TBX( 64,3),TBX( 64,4)
     *    /'CU+2'   ,11.8168   ,3.37484   ,7.11181   ,.244078   /
      DATA TBX( 64,5),TBX( 64,6),TBX( 64,7),TBX( 64,8),TBX( 64,9)
     *    / 5.78135   ,7.98760   ,1.14523   ,19.8970   ,1.14431   /
      DATA TBX( 64,10)/28./
      DATA TBXC( 65),TBX( 65,1),TBX( 65,2),TBX( 65,3),TBX( 65,4)
     *    /'ZN  '   ,14.0743   , 3.2655   , 7.0318   ,  .2333   /
      DATA TBX( 65,5),TBX( 65,6),TBX( 65,7),TBX( 65,8),TBX( 65,9)
     *    /  5.1652   ,10.3163   , 2.4100   ,58.7097   , 1.3041   /
      DATA TBX( 65,10)/29./
      DATA TBXC( 66),TBX( 66,1),TBX( 66,2),TBX( 66,3),TBX( 66,4)
     *    /'ZN+2'   ,11.9719   , 2.9946   , 7.3862   ,  .2031   /
      DATA TBX( 66,5),TBX( 66,6),TBX( 66,7),TBX( 66,8),TBX( 66,9)
     *    /  6.4668   , 7.0826   , 1.3940   ,18.0995   ,  .7807   /
      DATA TBX( 66,10)/29./
      DATA TBXC( 67),TBX( 67,1),TBX( 67,2),TBX( 67,3),TBX( 67,4)
     *    /'GA  '   ,15.2354   , 3.0669   , 6.7006   ,  .2412   /
      DATA TBX( 67,5),TBX( 67,6),TBX( 67,7),TBX( 67,8),TBX( 67,9)
     *    /  4.3591   ,10.7805   , 2.9623   ,61.4135   , 1.7189   /
      DATA TBX( 67,10)/30./
      DATA TBXC( 68),TBX( 68,1),TBX( 68,2),TBX( 68,3),TBX( 68,4)
     *    /'GA+3'   ,12.6920   ,2.81262   ,6.69883   ,.227890   /
      DATA TBX( 68,5),TBX( 68,6),TBX( 68,7),TBX( 68,8),TBX( 68,9)
     *    / 6.06692   ,6.36441   ,1.00660   ,14.4122   ,1.53545   /
      DATA TBX( 68,10)/30./
      DATA TBXC( 69),TBX( 69,1),TBX( 69,2),TBX( 69,3),TBX( 69,4)
     *    /'GE  '   ,16.0816   , 2.8509   , 6.3747   ,  .2516   /
      DATA TBX( 69,5),TBX( 69,6),TBX( 69,7),TBX( 69,8),TBX( 69,9)
     *    /  3.7068   ,11.4468   , 3.6830   ,54.7625   , 2.1313   /
      DATA TBX( 69,10)/31./
      DATA TBXC( 70),TBX( 70,1),TBX( 70,2),TBX( 70,3),TBX( 70,4)
     *    /'GE+4'   ,12.9172   ,2.53718   ,6.70003   ,.205855   /
      DATA TBX( 70,5),TBX( 70,6),TBX( 70,7),TBX( 70,8),TBX( 70,9)
     *    / 6.06791   ,5.47913   ,.859041   ,11.6030   ,1.45572   /
      DATA TBX( 70,10)/31./
      DATA TBXC( 71),TBX( 71,1),TBX( 71,2),TBX( 71,3),TBX( 71,4)
     *    /'AS  '   ,16.6723   , 2.6345   , 6.0701   ,  .2647   /
      DATA TBX( 71,5),TBX( 71,6),TBX( 71,7),TBX( 71,8),TBX( 71,9)
     *    /  3.4313   ,12.9479   , 4.2779   ,47.7972   , 2.5310   /
      DATA TBX( 71,10)/32./
      DATA TBXC( 72),TBX( 72,1),TBX( 72,2),TBX( 72,3),TBX( 72,4)
     *    /'SE  '   ,17.0006   , 2.4098   , 5.8196   ,  .2726   /
      DATA TBX( 72,5),TBX( 72,6),TBX( 72,7),TBX( 72,8),TBX( 72,9)
     *    /  3.9731   ,15.2372   , 4.3543   ,43.8163   , 2.8409   /
      DATA TBX( 72,10)/33./
      DATA TBXC( 73),TBX( 73,1),TBX( 73,2),TBX( 73,3),TBX( 73,4)
     *    /'BR  '   ,17.1789   , 2.1723   , 5.2358   ,16.5796   /
      DATA TBX( 73,5),TBX( 73,6),TBX( 73,7),TBX( 73,8),TBX( 73,9)
     *    /  5.6377   ,  .2609   , 3.9851   ,41.4328   , 2.9557   /
      DATA TBX( 73,10)/34./
      DATA TBXC( 74),TBX( 74,1),TBX( 74,2),TBX( 74,3),TBX( 74,4)
     *    /'BR-1'   ,17.1718   , 2.2059   , 6.3338   ,19.3345   /
      DATA TBX( 74,5),TBX( 74,6),TBX( 74,7),TBX( 74,8),TBX( 74,9)
     *    /  5.5754   ,  .2871   , 3.7272   ,58.1535   , 3.1776   /
      DATA TBX( 74,10)/34./
      DATA TBXC( 75),TBX( 75,1),TBX( 75,2),TBX( 75,3),TBX( 75,4)
     *    /'KR  '   ,17.3555   , 1.9384   , 6.7286   ,16.5623   /
      DATA TBX( 75,5),TBX( 75,6),TBX( 75,7),TBX( 75,8),TBX( 75,9)
     *    /  5.5493   ,  .2261   , 3.5375   ,39.3972   , 2.8250   /
      DATA TBX( 75,10)/35./
      DATA TBXC( 76),TBX( 76,1),TBX( 76,2),TBX( 76,3),TBX( 76,4)
     *    /'RB  '   ,17.1784   , 1.7888   , 9.6435   ,17.3151   /
      DATA TBX( 76,5),TBX( 76,6),TBX( 76,7),TBX( 76,8),TBX( 76,9)
     *    /  5.1399   ,  .2748   , 1.5292   ,164.934   , 3.4873   /
      DATA TBX( 76,10)/36./
      DATA TBXC( 77),TBX( 77,1),TBX( 77,2),TBX( 77,3),TBX( 77,4)
     *    /'RB+1'   ,17.5816   , 1.7139   , 7.6598   ,14.7957   /
      DATA TBX( 77,5),TBX( 77,6),TBX( 77,7),TBX( 77,8),TBX( 77,9)
     *    /  5.8981   ,  .1603   , 2.7817   ,31.2087   , 2.0782   /
      DATA TBX( 77,10)/36./
      DATA TBXC( 78),TBX( 78,1),TBX( 78,2),TBX( 78,3),TBX( 78,4)
     *    /'SR  '   ,17.5663   , 1.5564   , 9.8184   ,14.0988   /
      DATA TBX( 78,5),TBX( 78,6),TBX( 78,7),TBX( 78,8),TBX( 78,9)
     *    /  5.4220   ,  .1664   , 2.6694   ,132.376   , 2.5064   /
      DATA TBX( 78,10)/37./
      DATA TBXC( 79),TBX( 79,1),TBX( 79,2),TBX( 79,3),TBX( 79,4)
     *    /'SR+2'   ,18.0874   , 1.4907   , 8.1373   ,12.6963   /
      DATA TBX( 79,5),TBX( 79,6),TBX( 79,7),TBX( 79,8),TBX( 79,9)
     *    /  2.5654   ,24.5651   ,-34.193   , -.0138   ,41.4025   /
      DATA TBX( 79,10)/37./
      DATA TBXC( 80),TBX( 80,1),TBX( 80,2),TBX( 80,3),TBX( 80,4)
     *    /'Y   '   ,17.7760   ,1.40290   ,10.2946   ,12.8006   /
      DATA TBX( 80,5),TBX( 80,6),TBX( 80,7),TBX( 80,8),TBX( 80,9)
     *    / 5.72629   ,.125599   ,3.26588   ,104.354   ,1.91213   /
      DATA TBX( 80,10)/38./
      DATA TBXC( 81),TBX( 81,1),TBX( 81,2),TBX( 81,3),TBX( 81,4)
     *    /'Y+3 '   ,17.9268   ,1.35417   ,9.15310   ,11.2145   /
      DATA TBX( 81,5),TBX( 81,6),TBX( 81,7),TBX( 81,8),TBX( 81,9)
     *    / 1.76795   ,22.6599   ,-33.108   ,-.01319   ,40.2602   /
      DATA TBX( 81,10)/38./
      DATA TBXC( 82),TBX( 82,1),TBX( 82,2),TBX( 82,3),TBX( 82,4)
     *    /'ZR  '   ,17.8765   ,1.27618   ,10.9480   ,11.9160   /
      DATA TBX( 82,5),TBX( 82,6),TBX( 82,7),TBX( 82,8),TBX( 82,9)
     *    / 5.41732   ,.117622   ,3.65721   ,87.6627   ,2.06929   /
      DATA TBX( 82,10)/39./
      DATA TBXC( 83),TBX( 83,1),TBX( 83,2),TBX( 83,3),TBX( 83,4)
     *    /'ZR+4'   ,18.1668   ,1.21480   ,10.0562   ,10.1483   /
      DATA TBX( 83,5),TBX( 83,6),TBX( 83,7),TBX( 83,8),TBX( 83,9)
     *    / 1.01118   ,21.6054   ,-2.6479   ,-.10276   ,9.41454   /
      DATA TBX( 83,10)/39./
      DATA TBXC( 84),TBX( 84,1),TBX( 84,2),TBX( 84,3),TBX( 84,4)
     *    /'NB  '   ,17.6142   ,1.18865   ,12.0144   ,11.7660   /
      DATA TBX( 84,5),TBX( 84,6),TBX( 84,7),TBX( 84,8),TBX( 84,9)
     *    / 4.04183   ,.204785   ,3.53346   ,69.7957   ,3.75591   /
      DATA TBX( 84,10)/40./
      DATA TBXC( 85),TBX( 85,1),TBX( 85,2),TBX( 85,3),TBX( 85,4)
     *    /'NB+3'   ,19.8812   ,.019175   ,18.0653   ,1.13305   /
      DATA TBX( 85,5),TBX( 85,6),TBX( 85,7),TBX( 85,8),TBX( 85,9)
     *    / 11.0177   ,10.1621   ,1.94715   ,28.3389   ,-12.912   /
      DATA TBX( 85,10)/40./
      DATA TBXC( 86),TBX( 86,1),TBX( 86,2),TBX( 86,3),TBX( 86,4)
     *    /'NB+5'   ,17.9163   ,1.12446   ,13.3417   ,.028781   /
      DATA TBX( 86,5),TBX( 86,6),TBX( 86,7),TBX( 86,8),TBX( 86,9)
     *    / 10.7990   ,9.28206   ,.337905   ,25.7228   ,-6.3934   /
      DATA TBX( 86,10)/40./
      DATA TBXC( 87),TBX( 87,1),TBX( 87,2),TBX( 87,3),TBX( 87,4)
     *    /'MO  '   , 3.7025   ,  .2772   ,17.2356   , 1.0958   /
      DATA TBX( 87,5),TBX( 87,6),TBX( 87,7),TBX( 87,8),TBX( 87,9)
     *    / 12.8876   ,11.0040   , 3.7429   ,61.6584   , 4.3875   /
      DATA TBX( 87,10)/41./
      DATA TBXC( 88),TBX( 88,1),TBX( 88,2),TBX( 88,3),TBX( 88,4)
     *    /'MO+3'   ,21.1664   ,.014734   ,18.2017   ,1.03031   /
      DATA TBX( 88,5),TBX( 88,6),TBX( 88,7),TBX( 88,8),TBX( 88,9)
     *    / 11.7423   ,9.53659   ,2.30951   ,26.6307   ,-14.421   /
      DATA TBX( 88,10)/41./
      DATA TBXC( 89),TBX( 89,1),TBX( 89,2),TBX( 89,3),TBX( 89,4)
     *    /'MO+5'   ,21.0149   ,.014345   ,18.0992   ,1.02238   /
      DATA TBX( 89,5),TBX( 89,6),TBX( 89,7),TBX( 89,8),TBX( 89,9)
     *    / 11.4632   ,8.78809   ,.740625   ,23.3452   ,-14.316   /
      DATA TBX( 89,10)/41./
      DATA TBXC( 90),TBX( 90,1),TBX( 90,2),TBX( 90,3),TBX( 90,4)
     *    /'MO+6'   ,17.8871   ,1.03649   ,11.1750   ,8.48061   /
      DATA TBX( 90,5),TBX( 90,6),TBX( 90,7),TBX( 90,8),TBX( 90,9)
     *    / 6.57891   ,.058881   ,.0000   ,.0000    ,.344941   /
      DATA TBX( 90,10)/41./
      DATA TBXC( 91),TBX( 91,1),TBX( 91,2),TBX( 91,3),TBX( 91,4)
     *    /'TC  '   ,19.1301   ,.864132   ,11.0948   ,8.14487   /
      DATA TBX( 91,5),TBX( 91,6),TBX( 91,7),TBX( 91,8),TBX( 91,9)
     *    / 4.64901   ,21.5707   ,2.71263   ,86.8472   ,5.40428   /
      DATA TBX( 91,10)/42./
      DATA TBXC( 92),TBX( 92,1),TBX( 92,2),TBX( 92,3),TBX( 92,4)
     *    /'RU  '   ,19.2674   ,.808520   ,12.9182   ,8.43467   /
      DATA TBX( 92,5),TBX( 92,6),TBX( 92,7),TBX( 92,8),TBX( 92,9)
     *    / 4.86337   ,24.7997   ,1.56756   ,94.2928   ,5.37874   /
      DATA TBX( 92,10)/43./
      DATA TBXC( 93),TBX( 93,1),TBX( 93,2),TBX( 93,3),TBX( 93,4)
     *    /'RU+3'   ,18.5638   ,.847329   ,13.2885   ,8.37164   /
      DATA TBX( 93,5),TBX( 93,6),TBX( 93,7),TBX( 93,8),TBX( 93,9)
     *    / 9.32602   ,.017662   ,3.00964   ,22.8870   ,-3.1892   /
      DATA TBX( 93,10)/43./
      DATA TBXC( 94),TBX( 94,1),TBX( 94,2),TBX( 94,3),TBX( 94,4)
     *    /'RU+4'   ,18.5003   ,.844582   ,13.1787   ,8.12534   /
      DATA TBX( 94,5),TBX( 94,6),TBX( 94,7),TBX( 94,8),TBX( 94,9)
     *    / 4.71304   ,.036495   ,2.18535   ,20.8504   ,1.42357   /
      DATA TBX( 94,10)/43./
      DATA TBXC( 95),TBX( 95,1),TBX( 95,2),TBX( 95,3),TBX( 95,4)
     *    /'RH  '   ,19.2957   ,.751536   ,14.3501   ,8.21758   /
      DATA TBX( 95,5),TBX( 95,6),TBX( 95,7),TBX( 95,8),TBX( 95,9)
     *    / 4.73425   ,25.8749   ,1.28918   ,98.6062   ,5.32800   /
      DATA TBX( 95,10)/44./
      DATA TBXC( 96),TBX( 96,1),TBX( 96,2),TBX( 96,3),TBX( 96,4)
     *    /'RH+3'   ,18.8785   ,.764252   ,14.1259   ,7.84438   /
      DATA TBX( 96,5),TBX( 96,6),TBX( 96,7),TBX( 96,8),TBX( 96,9)
     *    / 3.32515   ,21.2487   ,-6.1989   ,-.01036   ,11.8678   /
      DATA TBX( 96,10)/44./
      DATA TBXC( 97),TBX( 97,1),TBX( 97,2),TBX( 97,3),TBX( 97,4)
     *    /'RH+4'   ,18.8545   ,.760825   ,13.9806   ,7.62436   /
      DATA TBX( 97,5),TBX( 97,6),TBX( 97,7),TBX( 97,8),TBX( 97,9)
     *    / 2.53464   ,19.3317   ,-5.6526   ,-.01020   ,11.2835   /
      DATA TBX( 97,10)/44./
      DATA TBXC( 98),TBX( 98,1),TBX( 98,2),TBX( 98,3),TBX( 98,4)
     *    /'PD  '   ,19.3319   ,.698655   ,15.5017   ,7.98929   /
      DATA TBX( 98,5),TBX( 98,6),TBX( 98,7),TBX( 98,8),TBX( 98,9)
     *    / 5.29537   ,25.2052   ,.605844   ,76.8986   ,5.26593   /
      DATA TBX( 98,10)/45./
      DATA TBXC( 99),TBX( 99,1),TBX( 99,2),TBX( 99,3),TBX( 99,4)
     *    /'PD+2'   ,19.1701   ,.696219   ,15.2096   ,7.55573   /
      DATA TBX( 99,5),TBX( 99,6),TBX( 99,7),TBX( 99,8),TBX( 99,9)
     *    / 4.32234   ,22.5057   ,.0000   ,.0000   ,5.29160   /
      DATA TBX( 99,10)/45./
      DATA TBXC(100),TBX(100,1),TBX(100,2),TBX(100,3),TBX(100,4)
     *    /'PD+4'   ,19.2493   ,.683839   ,14.7900   ,7.14833   /
      DATA TBX(100,5),TBX(100,6),TBX(100,7),TBX(100,8),TBX(100,9)
     *    / 2.89289   ,17.9144   ,-7.9492   ,.005127   ,13.0174   /
      DATA TBX(100,10)/45./
      DATA TBXC(101),TBX(101,1),TBX(101,2),TBX(101,3),TBX(101,4)
     *    /'AG  '   ,19.2808   ,  .6446   ,16.6885   , 7.4726   /
      DATA TBX(101,5),TBX(101,6),TBX(101,7),TBX(101,8),TBX(101,9)
     *    /  4.8045   ,24.6605   , 1.0463   ,99.8156   , 5.1790   /
      DATA TBX(101,10)/46./
      DATA TBXC(102),TBX(102,1),TBX(102,2),TBX(102,3),TBX(102,4)
     *    /'AG+1'   ,19.1812   ,.646179   ,15.9719   ,7.19123   /
      DATA TBX(102,5),TBX(102,6),TBX(102,7),TBX(102,8),TBX(102,9)
     *    / 5.27475   ,21.7326   ,.357534   ,66.1147   ,5.21572   /
      DATA TBX(102,10)/46./
      DATA TBXC(103),TBX(103,1),TBX(103,2),TBX(103,3),TBX(103,4)
     *    /'AG+2'   ,19.1643   ,.645643   ,16.2456   ,7.18544   /
      DATA TBX(103,5),TBX(103,6),TBX(103,7),TBX(103,8),TBX(103,9)
     *    / 4.37090   ,21.4072   ,.0000   ,.0000   ,5.21404   /
      DATA TBX(103,10)/46./
      DATA TBXC(104),TBX(104,1),TBX(104,2),TBX(104,3),TBX(104,4)
     *    /'CD  '   ,19.2214   ,  .5946   ,17.6444   , 6.9089   /
      DATA TBX(104,5),TBX(104,6),TBX(104,7),TBX(104,8),TBX(104,9)
     *    /  4.4610   ,24.7008   , 1.6029   ,87.4825   , 5.0694   /
      DATA TBX(104,10)/47./
      DATA TBXC(105),TBX(105,1),TBX(105,2),TBX(105,3),TBX(105,4)
     *    /'CD+2'   ,19.1514   ,.597922   ,17.2535   ,6.80639   /
      DATA TBX(105,5),TBX(105,6),TBX(105,7),TBX(105,8),TBX(105,9)
     *    / 4.47128   ,20.2521   ,.0000   ,.0000   ,5.11937   /
      DATA TBX(105,10)/47./
      DATA TBXC(106),TBX(106,1),TBX(106,2),TBX(106,3),TBX(106,4)
     *    /'IN  '   ,19.1624   ,  .5476   ,18.5596   , 6.3776   /
      DATA TBX(106,5),TBX(106,6),TBX(106,7),TBX(106,8),TBX(106,9)
     *    /  4.2948   ,25.8499   , 2.0396   ,92.8029   , 4.9391   /
      DATA TBX(106,10)/48./
      DATA TBXC(107),TBX(107,1),TBX(107,2),TBX(107,3),TBX(107,4)
     *    /'IN+3'   ,19.1045   ,.551522   ,18.1108   ,6.32470   /
      DATA TBX(107,5),TBX(107,6),TBX(107,7),TBX(107,8),TBX(107,9)
     *    / 3.78897   ,17.3595   ,.0000   ,.0000   ,4.99635   /
      DATA TBX(107,10)/48./
      DATA TBXC(108),TBX(108,1),TBX(108,2),TBX(108,3),TBX(108,4)
     *    /'SN  '   ,19.1889   , 5.8303   ,19.1005   ,  .5031   /
      DATA TBX(108,5),TBX(108,6),TBX(108,7),TBX(108,8),TBX(108,9)
     *    /  4.4585   ,26.8909   , 2.4663   ,83.9571   , 4.7821   /
      DATA TBX(108,10)/49./
      DATA TBXC(109),TBX(109,1),TBX(109,2),TBX(109,3),TBX(109,4)
     *    /'SN+2'   ,19.1094   ,  .5036   ,19.0548   , 5.8378   /
      DATA TBX(109,5),TBX(109,6),TBX(109,7),TBX(109,8),TBX(109,9)
     *    /  4.5648   ,23.3752   ,  .4870   ,62.2061   , 4.7861   /
      DATA TBX(109,10)/49./
      DATA TBXC(110),TBX(110,1),TBX(110,2),TBX(110,3),TBX(110,4)
     *    /'SN+4'   ,18.9333   , 5.7640   ,19.7131   ,  .4655   /
      DATA TBX(110,5),TBX(110,6),TBX(110,7),TBX(110,8),TBX(110,9)
     *    /  3.4182   ,14.0049   ,  .0193   , -.7583   , 3.9182   /
      DATA TBX(110,10)/49./
      DATA TBXC(111),TBX(111,1),TBX(111,2),TBX(111,3),TBX(111,4)
     *    /'SB  '   ,19.6418   , 5.3034   ,19.0455   ,  .4607   /
      DATA TBX(111,5),TBX(111,6),TBX(111,7),TBX(111,8),TBX(111,9)
     *    /  5.0371   ,27.9074   , 2.6827   ,75.2825   , 4.5909   /
      DATA TBX(111,10)/50./
      DATA TBXC(112),TBX(112,1),TBX(112,2),TBX(112,3),TBX(112,4)
     *    /'SB+3'   ,18.9755   ,.467196   ,18.9330   ,5.22126   /
      DATA TBX(112,5),TBX(112,6),TBX(112,7),TBX(112,8),TBX(112,9)
     *    / 5.10789   ,19.5902   ,.288753   ,55.5113   ,4.69626   /
      DATA TBX(112,10)/50./
      DATA TBXC(113),TBX(113,1),TBX(113,2),TBX(113,3),TBX(113,4)
     *    /'SB+5'   ,19.8685   ,5.44853   ,19.0302   ,.467973   /
      DATA TBX(113,5),TBX(113,6),TBX(113,7),TBX(113,8),TBX(113,9)
     *    / 2.41253   ,14.1259   ,.0000   ,.0000   ,4.69263   /
      DATA TBX(113,10)/50./
      DATA TBXC(114),TBX(114,1),TBX(114,2),TBX(114,3),TBX(114,4)
     *    /'TE  '   ,19.9644   ,4.81742   ,19.0138   ,.420885   /
      DATA TBX(114,5),TBX(114,6),TBX(114,7),TBX(114,8),TBX(114,9)
     *    / 6.14487   ,28.5284   ,2.52390   ,70.8403   ,4.35200   /
      DATA TBX(114,10)/51./
      DATA TBXC(115),TBX(115,1),TBX(115,2),TBX(115,3),TBX(115,4)
     *    /'I   '   ,20.1472   , 4.3470   ,18.9949   ,  .3814   /
      DATA TBX(115,5),TBX(115,6),TBX(115,7),TBX(115,8),TBX(115,9)
     *    /  7.5138   ,27.7660   , 2.2735   ,66.8776   , 4.0712   /
      DATA TBX(115,10)/52./
      DATA TBXC(116),TBX(116,1),TBX(116,2),TBX(116,3),TBX(116,4)
     *    /'I-1 '   ,20.2332   , 4.3579   ,18.9970   ,  .3815   /
      DATA TBX(116,5),TBX(116,6),TBX(116,7),TBX(116,8),TBX(116,9)
     *    /  7.8069   ,29.5259   , 2.8868   ,84.9304   , 4.0714   /
      DATA TBX(116,10)/52./
      DATA TBXC(117),TBX(117,1),TBX(117,2),TBX(117,3),TBX(117,4)
     *    /'XE  '   ,20.2933   , 3.9282   ,19.0298   ,  .3440   /
      DATA TBX(117,5),TBX(117,6),TBX(117,7),TBX(117,8),TBX(117,9)
     *    /  8.9767   ,26.4659   , 1.9900   ,64.2658   , 3.7118   /
      DATA TBX(117,10)/53./
      DATA TBXC(118),TBX(118,1),TBX(118,2),TBX(118,3),TBX(118,4)
     *    /'CS  '   ,20.3892   , 3.5690   ,19.1062   ,  .3107   /
      DATA TBX(118,5),TBX(118,6),TBX(118,7),TBX(118,8),TBX(118,9)
     *    / 10.6620   ,24.3879   , 1.4953   ,213.904   , 3.3352   /
      DATA TBX(118,10)/54./
      DATA TBXC(119),TBX(119,1),TBX(119,2),TBX(119,3),TBX(119,4)
     *    /'CS+1'   ,20.3524   , 3.5520   ,19.1278   ,  .3086   /
      DATA TBX(119,5),TBX(119,6),TBX(119,7),TBX(119,8),TBX(119,9)
     *    / 10.2821   ,23.7128   ,  .9615   ,59.4565   , 3.2791   /
      DATA TBX(119,10)/54./
      DATA TBXC(120),TBX(120,1),TBX(120,2),TBX(120,3),TBX(120,4)
     *    /'BA  '   ,20.3361   , 3.2160   ,19.2970   ,  .2756   /
      DATA TBX(120,5),TBX(120,6),TBX(120,7),TBX(120,8),TBX(120,9)
     *    / 10.8880   ,20.2073   , 2.6959   ,167.202   , 2.7731   /
      DATA TBX(120,10)/55./
      DATA TBXC(121),TBX(121,1),TBX(121,2),TBX(121,3),TBX(121,4)
     *    /'BA+2'   ,20.1807   ,3.21367   ,19.1136   ,.283310   /
      DATA TBX(121,5),TBX(121,6),TBX(121,7),TBX(121,8),TBX(121,9)
     *    / 10.9054   ,20.0558   ,.773634   ,51.7460   ,3.02902   /
      DATA TBX(121,10)/55./
      DATA TBXC(122),TBX(122,1),TBX(122,2),TBX(122,3),TBX(122,4)
     *    /'LA  '   ,20.5780   ,2.94817   ,19.5990   ,.244475   /
      DATA TBX(122,5),TBX(122,6),TBX(122,7),TBX(122,8),TBX(122,9)
     *    / 11.3727   ,18.7726   ,3.28719   ,133.124   ,2.14678   /
      DATA TBX(122,10)/56./
      DATA TBXC(123),TBX(123,1),TBX(123,2),TBX(123,3),TBX(123,4)
     *    /'LA+3'   ,20.2489   ,2.92070   ,19.3763   ,.250698   /
      DATA TBX(123,5),TBX(123,6),TBX(123,7),TBX(123,8),TBX(123,9)
     *    / 11.6323   ,17.8211   ,.336048   ,54.9453   ,2.40860   /
      DATA TBX(123,10)/56./
      DATA TBXC(124),TBX(124,1),TBX(124,2),TBX(124,3),TBX(124,4)
     *    /'CE  '   ,21.1671   ,2.81219   ,19.7695   ,.226836   /
      DATA TBX(124,5),TBX(124,6),TBX(124,7),TBX(124,8),TBX(124,9)
     *    / 11.8513   ,17.6083   ,3.33049   ,127.113   ,1.86264   /
      DATA TBX(124,10)/57./
      DATA TBXC(125),TBX(125,1),TBX(125,2),TBX(125,3),TBX(125,4)
     *    /'CE+3'   ,20.8036   ,2.77691   ,19.5590   ,.231540   /
      DATA TBX(125,5),TBX(125,6),TBX(125,7),TBX(125,8),TBX(125,9)
     *    / 11.9369   ,16.5408   ,.612376   ,43.1692   ,2.09013   /
      DATA TBX(125,10)/57./
      DATA TBXC(126),TBX(126,1),TBX(126,2),TBX(126,3),TBX(126,4)
     *    /'CE+4'   ,20.3235   ,2.65941   ,19.8186   ,.218850   /
      DATA TBX(126,5),TBX(126,6),TBX(126,7),TBX(126,8),TBX(126,9)
     *    / 12.1233   ,15.7992   ,.144583   ,62.2355   ,1.59180   /
      DATA TBX(126,10)/57./
      DATA TBXC(127),TBX(127,1),TBX(127,2),TBX(127,3),TBX(127,4)
     *    /'PR  '   ,22.0440   ,2.77393   ,19.6697   ,.222087   /
      DATA TBX(127,5),TBX(127,6),TBX(127,7),TBX(127,8),TBX(127,9)
     *    / 12.3856   ,16.7669   ,2.82428   ,143.644   ,2.05830   /
      DATA TBX(127,10)/58./
      DATA TBXC(128),TBX(128,1),TBX(128,2),TBX(128,3),TBX(128,4)
     *    /'PR+3'   ,21.3727   ,2.64520   ,19.7491   ,.214299   /
      DATA TBX(128,5),TBX(128,6),TBX(128,7),TBX(128,8),TBX(128,9)
     *    / 12.1329   ,15.3230   ,.975180   ,36.4065   ,1.77132   /
      DATA TBX(128,10)/58./
      DATA TBXC(129),TBX(129,1),TBX(129,2),TBX(129,3),TBX(129,4)
     *    /'PR+4'   ,20.9413   ,2.54467   ,20.0539   ,.202481   /
      DATA TBX(129,5),TBX(129,6),TBX(129,7),TBX(129,8),TBX(129,9)
     *    / 12.4668   ,14.8137   ,.296689   ,45.4643   ,1.24285   /
      DATA TBX(129,10)/58./
      DATA TBXC(130),TBX(130,1),TBX(130,2),TBX(130,3),TBX(130,4)
     *    /'ND  '   ,22.6845   ,2.66248   ,19.6847   ,.210628   /
      DATA TBX(130,5),TBX(130,6),TBX(130,7),TBX(130,8),TBX(130,9)
     *    / 12.7740   ,15.8850   ,2.85137   ,137.903   ,1.98486   /
      DATA TBX(130,10)/59./
      DATA TBXC(131),TBX(131,1),TBX(131,2),TBX(131,3),TBX(131,4)
     *    /'ND+3'   ,21.9610   ,2.52722   ,19.9339   ,.199237   /
      DATA TBX(131,5),TBX(131,6),TBX(131,7),TBX(131,8),TBX(131,9)
     *    / 12.1200   ,14.1783   ,1.51031   ,30.8717   ,1.47588   /
      DATA TBX(131,10)/59./
      DATA TBXC(132),TBX(132,1),TBX(132,2),TBX(132,3),TBX(132,4)
     *    /'PM  '   ,23.3405   ,2.56270   ,19.6095   ,.202088   /
      DATA TBX(132,5),TBX(132,6),TBX(132,7),TBX(132,8),TBX(132,9)
     *    / 13.1235   ,15.1009   ,2.87516   ,132.721   ,2.02876   /
      DATA TBX(132,10)/60./
      DATA TBXC(133),TBX(133,1),TBX(133,2),TBX(133,3),TBX(133,4)
     *    /'PM+3'   ,22.5527   ,2.41740   ,20.1108   ,.185769   /
      DATA TBX(133,5),TBX(133,6),TBX(133,7),TBX(133,8),TBX(133,9)
     *    / 12.0671   ,13.1275   ,2.07492   ,27.4491   ,1.19499   /
      DATA TBX(133,10)/60./
      DATA TBXC(134),TBX(134,1),TBX(134,2),TBX(134,3),TBX(134,4)
     *    /'SM  '   ,24.0042   ,2.47274   ,19.4258   ,.196451   /
      DATA TBX(134,5),TBX(134,6),TBX(134,7),TBX(134,8),TBX(134,9)
     *    / 13.4396   ,14.3996   ,2.89604   ,128.007   ,2.20963   /
      DATA TBX(134,10)/61./
      DATA TBXC(135),TBX(135,1),TBX(135,2),TBX(135,3),TBX(135,4)
     *    /'SM+3'   ,23.1504   ,2.31641   ,20.2599   ,.174081   /
      DATA TBX(135,5),TBX(135,6),TBX(135,7),TBX(135,8),TBX(135,9)
     *    / 11.9202   ,12.1571   ,2.71488   ,24.8242   ,.954586   /
      DATA TBX(135,10)/61./
      DATA TBXC(136),TBX(136,1),TBX(136,2),TBX(136,3),TBX(136,4)
     *    /'EU  '   ,24.6274   , 2.3879   ,19.0886   ,  .1942   /
      DATA TBX(136,5),TBX(136,6),TBX(136,7),TBX(136,8),TBX(136,9)
     *    / 13.7603   ,13.7546   , 2.9227   ,123.174   , 2.5745   /
      DATA TBX(136,10)/62./
      DATA TBXC(137),TBX(137,1),TBX(137,2),TBX(137,3),TBX(137,4)
     *    /'EU+2'   ,24.0063   ,2.27783   ,19.9504   ,.173530   /
      DATA TBX(137,5),TBX(137,6),TBX(137,7),TBX(137,8),TBX(137,9)
     *    / 11.8034   ,11.6096   ,3.87243   ,26.5156   ,1.36389   /
      DATA TBX(137,10)/62./
      DATA TBXC(138),TBX(138,1),TBX(138,2),TBX(138,3),TBX(138,4)
     *    /'EU+3'   ,23.7497   ,2.22258   ,20.3745   ,.163940   /
      DATA TBX(138,5),TBX(138,6),TBX(138,7),TBX(138,8),TBX(138,9)
     *    / 11.8509   ,11.3110   ,3.26503   ,22.9966   ,.759344   /
      DATA TBX(138,10)/62./
      DATA TBXC(139),TBX(139,1),TBX(139,2),TBX(139,3),TBX(139,4)
     *    /'GD  '   ,25.0709   ,2.25341   ,19.0798   ,.181951   /
      DATA TBX(139,5),TBX(139,6),TBX(139,7),TBX(139,8),TBX(139,9)
     *    / 13.8518   ,12.9331   ,3.54545   ,101.398   ,2.41960   /
      DATA TBX(139,10)/63./
      DATA TBXC(140),TBX(140,1),TBX(140,2),TBX(140,3),TBX(140,4)
     *    /'GD+3'   ,24.3466   ,2.13553   ,20.4208   ,.155525   /
      DATA TBX(140,5),TBX(140,6),TBX(140,7),TBX(140,8),TBX(140,9)
     *    / 11.8708   ,10.5782   ,3.71490   ,21.7029   ,.645089   /
      DATA TBX(140,10)/63./
      DATA TBXC(141),TBX(141,1),TBX(141,2),TBX(141,3),TBX(141,4)
     *    /'TB  '   ,25.8976   ,2.24256   ,18.2185   ,.196143   /
      DATA TBX(141,5),TBX(141,6),TBX(141,7),TBX(141,8),TBX(141,9)
     *    / 14.3167   ,12.6648   ,2.95354   ,115.362   ,3.58324   /
      DATA TBX(141,10)/64./
      DATA TBXC(142),TBX(142,1),TBX(142,2),TBX(142,3),TBX(142,4)
     *    /'TB+3'   ,24.9559   ,2.05601   ,20.3271   ,.149525   /
      DATA TBX(142,5),TBX(142,6),TBX(142,7),TBX(142,8),TBX(142,9)
     *    / 12.2471   ,10.0499   ,3.77300   ,21.2773   ,.691967   /
      DATA TBX(142,10)/64./
      DATA TBXC(143),TBX(143,1),TBX(143,2),TBX(143,3),TBX(143,4)
     *    /'DY  '   ,26.5070   ,2.18020   ,17.6383   ,.202172   /
      DATA TBX(143,5),TBX(143,6),TBX(143,7),TBX(143,8),TBX(143,9)
     *    / 14.5596   ,12.1899   ,2.96577   ,111.874   ,4.29728   /
      DATA TBX(143,10)/65./
      DATA TBXC(144),TBX(144,1),TBX(144,2),TBX(144,3),TBX(144,4)
     *    /'DY+3'   ,25.5395   ,1.98040   ,20.2861   ,.143384   /
      DATA TBX(144,5),TBX(144,6),TBX(144,7),TBX(144,8),TBX(144,9)
     *    / 11.9812   ,9.34972   ,4.50073   ,19.5810   ,.689690   /
      DATA TBX(144,10)/65./
      DATA TBXC(145),TBX(145,1),TBX(145,2),TBX(145,3),TBX(145,4)
     *    /'HO  '   ,26.9049   ,2.07051   ,17.2940   ,.197940   /
      DATA TBX(145,5),TBX(145,6),TBX(145,7),TBX(145,8),TBX(145,9)
     *    / 14.5583   ,11.4407   ,3.63837   ,92.6566   ,4.56796   /
      DATA TBX(145,10)/66./
      DATA TBXC(146),TBX(146,1),TBX(146,2),TBX(146,3),TBX(146,4)
     *    /'HO+3'   ,26.1296   ,1.91072   ,20.0994   ,.139358   /
      DATA TBX(146,5),TBX(146,6),TBX(146,7),TBX(146,8),TBX(146,9)
     *    / 11.9788   ,8.80018   ,4.93676   ,18.5908   ,.852795   /
      DATA TBX(146,10)/66./
      DATA TBXC(147),TBX(147,1),TBX(147,2),TBX(147,3),TBX(147,4)
     *    /'ER  '   ,27.6563   ,2.07356   ,16.4285   ,.223545   /
      DATA TBX(147,5),TBX(147,6),TBX(147,7),TBX(147,8),TBX(147,9)
     *    / 14.9779   ,11.3604   ,2.98233   ,105.703   ,5.92046   /
      DATA TBX(147,10)/67./
      DATA TBXC(148),TBX(148,1),TBX(148,2),TBX(148,3),TBX(148,4)
     *    /'ER+3'   ,26.7220   ,1.84659   ,19.7748   ,.137290   /
      DATA TBX(148,5),TBX(148,6),TBX(148,7),TBX(148,8),TBX(148,9)
     *    / 12.1506   ,8.36225   ,5.17379   ,17.8974   ,1.17613   /
      DATA TBX(148,10)/67./
      DATA TBXC(149),TBX(149,1),TBX(149,2),TBX(149,3),TBX(149,4)
     *    /'TM  '   ,28.1819   ,2.02859   ,15.8851   ,.238849   /
      DATA TBX(149,5),TBX(149,6),TBX(149,7),TBX(149,8),TBX(149,9)
     *    / 15.1542   ,10.9975   ,2.98706   ,102.961   ,6.75621   /
      DATA TBX(149,10)/68./
      DATA TBXC(150),TBX(150,1),TBX(150,2),TBX(150,3),TBX(150,4)
     *    /'TM+3'   ,27.3083   ,1.78711   ,19.3320   ,.136974   /
      DATA TBX(150,5),TBX(150,6),TBX(150,7),TBX(150,8),TBX(150,9)
     *    / 12.3339   ,7.96778   ,5.38348   ,17.2922   ,1.63929   /
      DATA TBX(150,10)/68./
      DATA TBXC(151),TBX(151,1),TBX(151,2),TBX(151,3),TBX(151,4)
     *    /'YB  '   ,28.6641   ,1.98890   ,15.4345   ,.257119   /
      DATA TBX(151,5),TBX(151,6),TBX(151,7),TBX(151,8),TBX(151,9)
     *    / 15.3087   ,10.6647   ,2.98963   ,100.417   ,7.56672   /
      DATA TBX(151,10)/69./
      DATA TBXC(152),TBX(152,1),TBX(152,2),TBX(152,3),TBX(152,4)
     *    /'YB+2'   ,28.1209   ,1.78503   ,17.6817   ,.159970   /
      DATA TBX(152,5),TBX(152,6),TBX(152,7),TBX(152,8),TBX(152,9)
     *    / 13.3335   ,8.18304   ,5.14657   ,20.3900   ,3.70983   /
      DATA TBX(152,10)/69./
      DATA TBXC(153),TBX(153,1),TBX(153,2),TBX(153,3),TBX(153,4)
     *    /'YB+3'   ,27.8917   ,1.73272   ,18.7614   ,.138790   /
      DATA TBX(153,5),TBX(153,6),TBX(153,7),TBX(153,8),TBX(153,9)
     *    / 12.6072   ,7.64412   ,5.47647   ,16.8153   ,2.26001   /
      DATA TBX(153,10)/69./
      DATA TBXC(154),TBX(154,1),TBX(154,2),TBX(154,3),TBX(154,4)
     *    /'LU  '   ,28.9476   ,1.90182   ,15.2208   ,9.98519   /
      DATA TBX(154,5),TBX(154,6),TBX(154,7),TBX(154,8),TBX(154,9)
     *    / 15.1000   ,.261033   ,3.71601   ,84.3298   ,7.97628   /
      DATA TBX(154,10)/70./
      DATA TBXC(155),TBX(155,1),TBX(155,2),TBX(155,3),TBX(155,4)
     *    /'LU+3'   ,28.4628   ,1.68216   ,18.1210   ,.142292   /
      DATA TBX(155,5),TBX(155,6),TBX(155,7),TBX(155,8),TBX(155,9)
     *    / 12.8429   ,7.33727   ,5.59415   ,16.3535   ,2.97573   /
      DATA TBX(155,10)/70./
      DATA TBXC(156),TBX(156,1),TBX(156,2),TBX(156,3),TBX(156,4)
     *    /'HF  '   ,29.1440   ,1.83262   ,15.1726   ,9.59990   /
      DATA TBX(156,5),TBX(156,6),TBX(156,7),TBX(156,8),TBX(156,9)
     *    / 14.7586   ,.275116   ,4.30013   ,72.0290   ,8.58154   /
      DATA TBX(156,10)/71./
      DATA TBXC(157),TBX(157,1),TBX(157,2),TBX(157,3),TBX(157,4)
     *    /'HF+4'   ,28.8131   ,1.59136   ,18.4601   ,.128903   /
      DATA TBX(157,5),TBX(157,6),TBX(157,7),TBX(157,8),TBX(157,9)
     *    / 12.7285   ,6.76232   ,5.59927   ,14.0366   ,2.39699   /
      DATA TBX(157,10)/71./
      DATA TBXC(158),TBX(158,1),TBX(158,2),TBX(158,3),TBX(158,4)
     *    /'TA  '   ,29.2024   ,1.77333   ,15.2293   ,9.37046   /
      DATA TBX(158,5),TBX(158,6),TBX(158,7),TBX(158,8),TBX(158,9)
     *    / 14.5135   ,.295977   ,4.76492   ,63.3644   ,9.24354   /
      DATA TBX(158,10)/72./
      DATA TBXC(159),TBX(159,1),TBX(159,2),TBX(159,3),TBX(159,4)
     *    /'TA+5'   ,29.1587   ,1.50711   ,18.8407   ,.116741   /
      DATA TBX(159,5),TBX(159,6),TBX(159,7),TBX(159,8),TBX(159,9)
     *    / 12.8268   ,6.31524   ,5.38695   ,12.4244   ,1.78555   /
      DATA TBX(159,10)/72./
      DATA TBXC(160),TBX(160,1),TBX(160,2),TBX(160,3),TBX(160,4)
     *    /'W   '   ,29.0818   ,1.72029   ,15.4300   ,9.22590   /
      DATA TBX(160,5),TBX(160,6),TBX(160,7),TBX(160,8),TBX(160,9)
     *    / 14.4327   ,.321703   ,5.11982   ,57.0560   ,9.88750   /
      DATA TBX(160,10)/73./
      DATA TBXC(161),TBX(161,1),TBX(161,2),TBX(161,3),TBX(161,4)
     *    /'W+6 '   ,29.4936   ,1.42755   ,19.3763   ,.104621   /
      DATA TBX(161,5),TBX(161,6),TBX(161,7),TBX(161,8),TBX(161,9)
     *    / 13.0544   ,5.93667   ,5.06412   ,11.1972   ,1.01074   /
      DATA TBX(161,10)/73./
      DATA TBXC(162),TBX(162,1),TBX(162,2),TBX(162,3),TBX(162,4)
     *    /'RE  '   ,28.7621   ,1.67191   ,15.7189   ,9.09227   /
      DATA TBX(162,5),TBX(162,6),TBX(162,7),TBX(162,8),TBX(162,9)
     *    / 14.5564   ,.350500   ,5.44174   ,52.0861   ,10.4720   /
      DATA TBX(162,10)/74./
      DATA TBXC(163),TBX(163,1),TBX(163,2),TBX(163,3),TBX(163,4)
     *    /'OS  '   ,28.1894   ,1.62903   ,16.1550   ,8.97948   /
      DATA TBX(163,5),TBX(163,6),TBX(163,7),TBX(163,8),TBX(163,9)
     *    / 14.9305   ,.382661   ,5.67589   ,48.1647   ,11.0005   /
      DATA TBX(163,10)/75./
      DATA TBXC(164),TBX(164,1),TBX(164,2),TBX(164,3),TBX(164,4)
     *    /'OS+4'   ,30.4190   ,1.37113   ,15.2637   ,6.84706   /
      DATA TBX(164,5),TBX(164,6),TBX(164,7),TBX(164,8),TBX(164,9)
     *    / 14.7458   ,.165191   ,5.06795   ,18.0030   ,6.49804   /
      DATA TBX(164,10)/75./
      DATA TBXC(165),TBX(165,1),TBX(165,2),TBX(165,3),TBX(165,4)
     *    /'IR  '   ,27.3049   ,1.59279   ,16.7296   ,8.86553   /
      DATA TBX(165,5),TBX(165,6),TBX(165,7),TBX(165,8),TBX(165,9)
     *    / 15.6115   ,.417916   ,5.83377   ,45.0011   ,11.4722   /
      DATA TBX(165,10)/76./
      DATA TBXC(166),TBX(166,1),TBX(166,2),TBX(166,3),TBX(166,4)
     *    /'IR+3'   ,30.4156   ,1.34323   ,15.8620   ,7.10909   /
      DATA TBX(166,5),TBX(166,6),TBX(166,7),TBX(166,8),TBX(166,9)
     *    / 13.6145   ,.204633   ,5.82008   ,20.3254   ,8.27903   /
      DATA TBX(166,10)/76./
      DATA TBXC(167),TBX(167,1),TBX(167,2),TBX(167,3),TBX(167,4)
     *    /'IR+4'   ,30.7058   ,1.30923   ,15.5512   ,6.71983   /
      DATA TBX(167,5),TBX(167,6),TBX(167,7),TBX(167,8),TBX(167,9)
     *    / 14.2326   ,.167252   ,5.53672   ,17.4911   ,6.96824   /
      DATA TBX(167,10)/76./
      DATA TBXC(168),TBX(168,1),TBX(168,2),TBX(168,3),TBX(168,4)
     *    /'PT  '   ,27.0059   ,1.51293   ,17.7639   ,8.81174   /
      DATA TBX(168,5),TBX(168,6),TBX(168,7),TBX(168,8),TBX(168,9)
     *    / 15.7131   ,.424593   ,5.78370   ,38.6103   ,11.6883   /
      DATA TBX(168,10)/77./
      DATA TBXC(169),TBX(169,1),TBX(169,2),TBX(169,3),TBX(169,4)
     *    /'PT+2'   ,29.8429   ,1.32927   ,16.7224   ,7.38979   /
      DATA TBX(169,5),TBX(169,6),TBX(169,7),TBX(169,8),TBX(169,9)
     *    / 13.2153   ,.263297   ,6.35234   ,22.9426   ,9.85329   /
      DATA TBX(169,10)/77./
      DATA TBXC(170),TBX(170,1),TBX(170,2),TBX(170,3),TBX(170,4)
     *    /'PT+4'   ,30.9612   ,1.24813   ,15.9829   ,6.60834   /
      DATA TBX(170,5),TBX(170,6),TBX(170,7),TBX(170,8),TBX(170,9)
     *    / 13.7348   ,.168640   ,5.92034   ,16.9392   ,7.39534   /
      DATA TBX(170,10)/77./
      DATA TBXC(171),TBX(171,1),TBX(171,2),TBX(171,3),TBX(171,4)
     *    /'AU  '   ,16.8819   ,  .4611   ,18.5913   , 8.6216   /
      DATA TBX(171,5),TBX(171,6),TBX(171,7),TBX(171,8),TBX(171,9)
     *    / 25.5582   , 1.4826   , 5.8600   ,36.3956   ,12.0658   /
      DATA TBX(171,10)/78./
      DATA TBXC(172),TBX(172,1),TBX(172,2),TBX(172,3),TBX(172,4)
     *    /'AU+1'   ,28.0109   ,1.35321   ,17.8204   ,7.73950   /
      DATA TBX(172,5),TBX(172,6),TBX(172,7),TBX(172,8),TBX(172,9)
     *    / 14.3359   ,.356752   ,6.58077   ,26.4043   ,11.2299   /
      DATA TBX(172,10)/78./
      DATA TBXC(173),TBX(173,1),TBX(173,2),TBX(173,3),TBX(173,4)
     *    /'AU+3'   ,30.6886   ,1.21990   ,16.9029   ,6.82872   /
      DATA TBX(173,5),TBX(173,6),TBX(173,7),TBX(173,8),TBX(173,9)
     *    / 12.7801   ,.212867   ,6.52354   ,18.6590   ,9.09680   /
      DATA TBX(173,10)/78./
      DATA TBXC(174),TBX(174,1),TBX(174,2),TBX(174,3),TBX(174,4)
     *    /'HG  '   ,20.6809   ,  .5450   ,19.0417   , 8.4484   /
      DATA TBX(174,5),TBX(174,6),TBX(174,7),TBX(174,8),TBX(174,9)
     *    / 21.6575   , 1.5729   , 5.9676   ,38.3246   ,12.6089   /
      DATA TBX(174,10)/79./
      DATA TBXC(175),TBX(175,1),TBX(175,2),TBX(175,3),TBX(175,4)
     *    /'HG+1'   ,25.0853   ,1.39507   ,18.4973   ,7.65105   /
      DATA TBX(175,5),TBX(175,6),TBX(175,7),TBX(175,8),TBX(175,9)
     *    / 16.8883   ,.443378   ,6.48216   ,28.2262   ,12.0205   /
      DATA TBX(175,10)/79./
      DATA TBXC(176),TBX(176,1),TBX(176,2),TBX(176,3),TBX(176,4)
     *    /'HG+2'   ,29.5641   ,1.21152   ,18.0600   ,7.05639   /
      DATA TBX(176,5),TBX(176,6),TBX(176,7),TBX(176,8),TBX(176,9)
     *    / 12.8374   ,.284738   ,6.89912   ,20.7482   ,10.6268   /
      DATA TBX(176,10)/79./
      DATA TBXC(177),TBX(177,1),TBX(177,2),TBX(177,3),TBX(177,4)
     *    /'TL  '   ,27.5446   ,.655150   ,19.1584   ,8.70751   /
      DATA TBX(177,5),TBX(177,6),TBX(177,7),TBX(177,8),TBX(177,9)
     *    / 15.5380   ,1.96347   ,5.52593   ,45.8149   ,13.1746   /
      DATA TBX(177,10)/80./
      DATA TBXC(178),TBX(178,1),TBX(178,2),TBX(178,3),TBX(178,4)
     *    /'TL+1'   ,21.3985   ,1.47110   ,20.4723   ,.517394   /
      DATA TBX(178,5),TBX(178,6),TBX(178,7),TBX(178,8),TBX(178,9)
     *    / 18.7478   ,7.43463   ,6.82847   ,28.8482   ,12.5258   /
      DATA TBX(178,10)/80./
      DATA TBXC(179),TBX(179,1),TBX(179,2),TBX(179,3),TBX(179,4)
     *    /'TL+3'   ,30.8695   ,1.10080   ,18.3841   ,6.53852   /
      DATA TBX(179,5),TBX(179,6),TBX(179,7),TBX(179,8),TBX(179,9)
     *    / 11.9328   ,.219074   ,7.00574   ,17.2114   ,9.80270   /
      DATA TBX(179,10)/80./
      DATA TBXC(180),TBX(180,1),TBX(180,2),TBX(180,3),TBX(180,4)
     *    /'PB  '   ,31.0617   ,  .6902   ,13.0637   , 2.3576   /
      DATA TBX(180,5),TBX(180,6),TBX(180,7),TBX(180,8),TBX(180,9)
     *    / 18.4420   , 8.6180   , 5.9696   ,47.2579   ,13.4118   /
      DATA TBX(180,10)/81./
      DATA TBXC(181),TBX(181,1),TBX(181,2),TBX(181,3),TBX(181,4)
     *    /'PB+2'   ,21.7886   ,1.33660   ,19.5682   ,.488383   /
      DATA TBX(181,5),TBX(181,6),TBX(181,7),TBX(181,8),TBX(181,9)
     *    / 19.1406   ,6.77270   ,7.01107   ,23.8132   ,12.4734   /
      DATA TBX(181,10)/81./
      DATA TBXC(182),TBX(182,1),TBX(182,2),TBX(182,3),TBX(182,4)
     *    /'PB+4'   ,32.1244   ,1.00566   ,18.8003   ,6.10926   /
      DATA TBX(182,5),TBX(182,6),TBX(182,7),TBX(182,8),TBX(182,9)
     *    / 12.0175   ,.147041   ,6.96886   ,14.7140   ,8.08428   /
      DATA TBX(182,10)/81./
      DATA TBXC(183),TBX(183,1),TBX(183,2),TBX(183,3),TBX(183,4)
     *    /'BI  '   ,33.3689   ,  .7040   ,12.9510   , 2.9238   /
      DATA TBX(183,5),TBX(183,6),TBX(183,7),TBX(183,8),TBX(183,9)
     *    / 16.5877   , 8.7937   , 6.4692   ,48.0093   ,13.5782   /
      DATA TBX(183,10)/82./
      DATA TBXC(184),TBX(184,1),TBX(184,2),TBX(184,3),TBX(184,4)
     *    /'BI+3'   ,21.8053   ,1.23560   ,19.5026   ,6.24149   /
      DATA TBX(184,5),TBX(184,6),TBX(184,7),TBX(184,8),TBX(184,9)
     *    / 19.1053   ,.469999   ,7.10295   ,20.3185   ,12.4711   /
      DATA TBX(184,10)/82./
      DATA TBXC(185),TBX(185,1),TBX(185,2),TBX(185,3),TBX(185,4)
     *    /'BI+5'   ,33.5364   ,.916540   ,25.0946   ,.039042   /
      DATA TBX(185,5),TBX(185,6),TBX(185,7),TBX(185,8),TBX(185,9)
     *    / 19.2497   ,5.71414   ,6.91555   ,12.8285   ,-6.7994   /
      DATA TBX(185,10)/82./
      DATA TBXC(186),TBX(186,1),TBX(186,2),TBX(186,3),TBX(186,4)
     *    /'PO  '   ,34.6726   ,.700999   ,15.4733   ,3.55078   /
      DATA TBX(186,5),TBX(186,6),TBX(186,7),TBX(186,8),TBX(186,9)
     *    / 13.1138   ,9.55642   ,7.02588   ,47.0045   ,13.6770   /
      DATA TBX(186,10)/83./
      DATA TBXC(187),TBX(187,1),TBX(187,2),TBX(187,3),TBX(187,4)
     *    /'AT  '   ,35.3163   ,.685870   ,19.0211   ,3.97458   /
      DATA TBX(187,5),TBX(187,6),TBX(187,7),TBX(187,8),TBX(187,9)
     *    / 9.49887   ,11.3824   ,7.42518   ,45.4715   ,13.7108   /
      DATA TBX(187,10)/84./
      DATA TBXC(188),TBX(188,1),TBX(188,2),TBX(188,3),TBX(188,4)
     *    /'RN  '   ,35.5631   ,  .6631   ,21.2816   , 4.0691   /
      DATA TBX(188,5),TBX(188,6),TBX(188,7),TBX(188,8),TBX(188,9)
     *    /  8.0037   ,14.0422   , 7.4433   ,44.2473   ,13.6905   /
      DATA TBX(188,10)/85./
      DATA TBXC(189),TBX(189,1),TBX(189,2),TBX(189,3),TBX(189,4)
     *    /'FR  '   ,35.9299   ,.646453   ,23.0547   ,4.17619   /
      DATA TBX(189,5),TBX(189,6),TBX(189,7),TBX(189,8),TBX(189,9)
     *    / 12.1439   ,23.1052   ,2.11253   ,150.645   ,13.7247   /
      DATA TBX(189,10)/86./
      DATA TBXC(190),TBX(190,1),TBX(190,2),TBX(190,3),TBX(190,4)
     *    /'RA  '   ,35.7630   ,.616341   ,22.9064   ,3.87135   /
      DATA TBX(190,5),TBX(190,6),TBX(190,7),TBX(190,8),TBX(190,9)
     *    / 12.4739   ,19.9887   ,3.21097   ,142.325   ,13.6211   /
      DATA TBX(190,10)/87./
      DATA TBXC(191),TBX(191,1),TBX(191,2),TBX(191,3),TBX(191,4)
     *    /'RA+2'   ,35.2150   ,.604909   ,21.6700   ,3.57670   /
      DATA TBX(191,5),TBX(191,6),TBX(191,7),TBX(191,8),TBX(191,9)
     *    / 7.91342   ,12.6010   ,7.65078   ,29.8436   ,13.5431   /
      DATA TBX(191,10)/87./
      DATA TBXC(192),TBX(192,1),TBX(192,2),TBX(192,3),TBX(192,4)
     *    /'AC  '   ,35.6597   ,.589092   ,23.1032   ,3.65155   /
      DATA TBX(192,5),TBX(192,6),TBX(192,7),TBX(192,8),TBX(192,9)
     *    / 12.5977   ,18.5990   ,4.08655   ,117.020   ,13.5266   /
      DATA TBX(192,10)/88./
      DATA TBXC(193),TBX(193,1),TBX(193,2),TBX(193,3),TBX(193,4)
     *    /'AC+3'   ,35.1736   ,.579689   ,22.1112   ,3.41437   /
      DATA TBX(193,5),TBX(193,6),TBX(193,7),TBX(193,8),TBX(193,9)
     *    / 8.19216   ,12.9187   ,7.05545   ,25.9443   ,13.4637   /
      DATA TBX(193,10)/88./
      DATA TBXC(194),TBX(194,1),TBX(194,2),TBX(194,3),TBX(194,4)
     *    /'TH  '   ,35.5645   ,.563359   ,23.4219   ,3.46204   /
      DATA TBX(194,5),TBX(194,6),TBX(194,7),TBX(194,8),TBX(194,9)
     *    / 12.7473   ,17.8309   ,4.80703   ,99.1722   ,13.4314   /
      DATA TBX(194,10)/89./
      DATA TBXC(195),TBX(195,1),TBX(195,2),TBX(195,3),TBX(195,4)
     *    /'TH+4'   ,35.1007   ,.555054   ,22.4418   ,3.24498   /
      DATA TBX(195,5),TBX(195,6),TBX(195,7),TBX(195,8),TBX(195,9)
     *    / 9.78554   ,13.4661   ,5.29444   ,23.9533   ,13.3760   /
      DATA TBX(195,10)/89./
      DATA TBXC(196),TBX(196,1),TBX(196,2),TBX(196,3),TBX(196,4)
     *    /'PA  '   ,35.8847   ,.547751   ,23.2948   ,3.41519   /
      DATA TBX(196,5),TBX(196,6),TBX(196,7),TBX(196,8),TBX(196,9)
     *    / 14.1891   ,16.9235   ,4.17287   ,105.251   ,13.4287   /
      DATA TBX(196,10)/90./
      DATA TBXC(197),TBX(197,1),TBX(197,2),TBX(197,3),TBX(197,4)
     *    /'U   '   ,36.0228   ,  .5293   ,23.4128   , 3.3253   /
      DATA TBX(197,5),TBX(197,6),TBX(197,7),TBX(197,8),TBX(197,9)
     *    / 14.9491   ,16.0927   , 4.1880   ,100.613   ,13.3966   /
      DATA TBX(197,10)/91./
      DATA TBXC(198),TBX(198,1),TBX(198,2),TBX(198,3),TBX(198,4)
     *    /'U+3 '  ,35.5747   ,.520480   ,22.5259   ,3.12293   /
      DATA TBX(198,5),TBX(198,6),TBX(198,7),TBX(198,8),TBX(198,9)
     *    / 12.2165   ,12.7148   ,5.37073   ,26.3394   ,13.3092   /
      DATA TBX(198,10)/91./
      DATA TBXC(199),TBX(199,1),TBX(199,2),TBX(199,3),TBX(199,4)
     *    /'U+4 '  ,35.3715   ,.516598   ,22.5326   ,3.05053   /
      DATA TBX(199,5),TBX(199,6),TBX(199,7),TBX(199,8),TBX(199,9)
     *    / 12.0291   ,12.5723   ,4.79840   ,23.4582   ,13.2671   /
      DATA TBX(199,10)/91./
      DATA TBXC(200),TBX(200,1),TBX(200,2),TBX(200,3),TBX(200,4)
     *    /'U+6 '  ,34.8509   ,.507079   ,22.7584   ,2.89030   /
      DATA TBX(200,5),TBX(200,6),TBX(200,7),TBX(200,8),TBX(200,9)
     *    / 14.0099   ,13.1767   ,1.21457   ,25.2017   ,13.1665   /
      DATA TBX(200,10)/91./
      DATA TBXC(201),TBX(201,1),TBX(201,2),TBX(201,3),TBX(201,4)
     *    /'NP  '   ,36.1874   ,.511929   ,23.5964   ,3.25396   /
      DATA TBX(201,5),TBX(201,6),TBX(201,7),TBX(201,8),TBX(201,9)
     *    / 15.6402   ,15.3622   ,4.18550   ,97.4908   ,13.3573   /
      DATA TBX(201,10)/92./
      DATA TBXC(202),TBX(202,1),TBX(202,2),TBX(202,3),TBX(202,4)
     *    /'NP+3'   ,35.7074   ,.502322   ,22.6130   ,3.03807   /
      DATA TBX(202,5),TBX(202,6),TBX(202,7),TBX(202,8),TBX(202,9)
     *    / 12.9898   ,12.1449   ,5.43227   ,25.4928   ,13.2544   /
      DATA TBX(202,10)/92./
      DATA TBXC(203),TBX(203,1),TBX(203,2),TBX(203,3),TBX(203,4)
     *    /'NP+4'   ,35.5103   ,.498626   ,22.5787   ,2.96627   /
      DATA TBX(203,5),TBX(203,6),TBX(203,7),TBX(203,8),TBX(203,9)
     *    / 12.7766   ,11.9484   ,4.92159   ,22.7502   ,13.2116   /
      DATA TBX(203,10)/92./
      DATA TBXC(204),TBX(204,1),TBX(204,2),TBX(204,3),TBX(204,4)
     *    /'NP+6'   ,35.0136   ,.489810   ,22.7286   ,2.81099   /
      DATA TBX(204,5),TBX(204,6),TBX(204,7),TBX(204,8),TBX(204,9)
     *    / 14.3884   ,12.3300   ,1.75669   ,22.6581   ,13.1130   /
      DATA TBX(204,10)/92./
      DATA TBXC(205),TBX(205,1),TBX(205,2),TBX(205,3),TBX(205,4)
     *    /'PU  '   ,36.5254   ,.499384   ,23.8083   ,3.26371   /
      DATA TBX(205,5),TBX(205,6),TBX(205,7),TBX(205,8),TBX(205,9)
     *    / 16.7707   ,14.9455   ,3.47947   ,105.980   ,13.3812   /
      DATA TBX(205,10)/93./
      DATA TBXC(206),TBX(206,1),TBX(206,2),TBX(206,3),TBX(206,4)
     *    /'PU+3'   ,35.8400   ,.484938   ,22.7169   ,2.96118   /
      DATA TBX(206,5),TBX(206,6),TBX(206,7),TBX(206,8),TBX(206,9)
     *    / 13.5807   ,11.5331   ,5.66016   ,24.3992   ,13.1991   /
      DATA TBX(206,10)/93./
      DATA TBXC(207),TBX(207,1),TBX(207,2),TBX(207,3),TBX(207,4)
     *    /'PU+4'   ,35.6493   ,.481422   ,22.6460   ,2.89020   /
      DATA TBX(207,5),TBX(207,6),TBX(207,7),TBX(207,8),TBX(207,9)
     *    / 13.3595   ,11.3160   ,5.18831   ,21.8301   ,13.1555   /
      DATA TBX(207,10)/93./
      DATA TBXC(208),TBX(208,1),TBX(208,2),TBX(208,3),TBX(208,4)
     *    /'PU+6'   ,35.1736   ,.473204   ,22.7181   ,2.73848   /
      DATA TBX(208,5),TBX(208,6),TBX(208,7),TBX(208,8),TBX(208,9)
     *    / 14.7635   ,11.5530   ,2.28678   ,20.9303   ,13.0582   /
      DATA TBX(208,10)/93./
      DATA TBXC(209),TBX(209,1),TBX(209,2),TBX(209,3),TBX(209,4)
     *    /'AM  '   ,36.6706   ,.483629   ,24.0992   ,3.20647   /
      DATA TBX(209,5),TBX(209,6),TBX(209,7),TBX(209,8),TBX(209,9)
     *    / 17.3415   ,14.3136   ,3.49331   ,102.273   ,13.3592   /
      DATA TBX(209,10)/94./
      DATA TBXC(210),TBX(210,1),TBX(210,2),TBX(210,3),TBX(210,4)
     *    /'CM  '   ,36.6488   ,.465154   ,24.4096   ,3.08997   /
      DATA TBX(210,5),TBX(210,6),TBX(210,7),TBX(210,8),TBX(210,9)
     *    / 17.3990   ,13.4346   ,4.21665   ,88.4834   ,13.2887   /
      DATA TBX(210,10)/95./
      DATA TBXC(211),TBX(211,1),TBX(211,2),TBX(211,3),TBX(211,4)
     *    /'BK  '   ,36.7881   ,.451018   ,24.7736   ,3.04619   /
      DATA TBX(211,5),TBX(211,6),TBX(211,7),TBX(211,8),TBX(211,9)
     *    / 17.8919   ,12.8946   ,4.23284   ,86.0030   ,13.2754   /
      DATA TBX(211,10)/96./
      DATA TBXC(212),TBX(212,1),TBX(212,2),TBX(212,3),TBX(212,4)
     *    /'CF  '   ,36.9185   ,.437533   ,25.1995   ,3.00775   /
      DATA TBX(212,5),TBX(212,6),TBX(212,7),TBX(212,8),TBX(212,9)
     *    / 18.3317   ,12.4044   ,4.24391   ,83.7881   ,13.2674   /
      DATA TBX(212,10)/97./
      END
***vax modification
      subroutine gotoer(nsub,line)
      common/vax/ lvax
      logical lvax
      character*7 subrs
      dimension subrs(9)
      data subrs /'   SPGP',' REFGEN','  CURVE','   RTMT',' OPERTR',
     *' SYMOPR','SYMTRY2','  CELL2','   MULT'/
      if(lvax)then
        write(6,1000) subrs(nsub),line
        call exit
      else
        write (6,10)
      endif
 10    format(1x,'subroutine gotoer was called')
 1000  format(//,' Variable overflow called by subroutine:',
     * a7,/,' at subroutine line number:', i7)
      stop
      end
***vax
      SUBROUTINE SORT(IPHASE)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),MLT(IRS),ICX(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      DIMENSION L(IRS),TEMP(IRS),ITEMP(IRS),mtemp(irs)
      EQUIVALENCE (ITEMP(1),TEMP(1))
      IOF=0
      IF(IPHASE.GE.2.AND.IPHASE.NE.1000) THEN
        DO 4100 IIPHAS=2,IPHASE
4100      IOF = IOF + ICX(IIPHAS-1)
      END IF
      IF (IPHASE.EQ.1000) THEN
        IC=0
        DO 4101 IIPHAS=1,8
4101      IC  = IC  + ICX(IIPHAS)
      ELSE
        IC=ICX(IPHASE)
      END IF
      DO 2 I=1,IC
2       L(I)=I
      M=IC-1
      DO 15 LL=1,5000
        K=0
        DO 10 J=1,2
          DO 10 I=J,M,2
            INP=L(I)+IOF
            INP1=L(I+1)+IOF
            R=REFS(INP1,2)-REFS(INP,2)
            IF(R) 20,10,10
20          IZ=L(I)
            L(I)=L(I+1)
            L(I+1)=IZ
            K=K+1
10          CONTINUE
        IF(K.EQ.0) GO TO 5
15      CONTINUE
5     DO 30 I=1,IC
        ITEMP(I)=IREFS(I+IOF)
        mtemp(i)=mm(i+iof)
30    continue
      DO 31 I=1,IC
        LX=L(I)
        IREFS(I+IOF)=ITEMP(LX)
        mm(i+iof)=mtemp(lx)
31      CONTINUE
      DO 33 J=1,3
        DO 32 I=1,IC
32        TEMP(I)=REFS(I+IOF,J)
        DO 33 I=1,IC
          LX=L(I)
33        REFS(I+IOF,J)=TEMP(LX)
      DO 34 I=1,IC
34      ITEMP(I)=MLT(I+IOF)
      DO 35 I=1,IC
        LX=L(I)
35      MLT(I+IOF)=ITEMP(LX)
      IF (NPROF.EQ.8) THEN
        DO 40 I=1,IC
40        TEMP(I)=HALFL(I+IOF)
        DO 41 I=1,IC
          LX=L(I)
41        HALFL(I+IOF)=TEMP(LX)
        DO 50 I=1,IC
50        TEMP(I)=HALFG(I+IOF)
        DO 51 I=1,IC
          LX=L(I)
51        HALFG(I+IOF)=TEMP(LX)
        DO 60 I=1,IC
60        TEMP(I)=GAM(I+IOF)
        DO 61 I=1,IC
          LX=L(I)
61        GAM(I+IOF)=TEMP(LX)
      END IF
      RETURN
      END
*** subroutine exput goes here ***
      SUBROUTINE EXPUT
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      REAL LAMDA
      INTEGER PTR
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      COMMON/ALLP/FINAL(8*MSZ,2),ILOC
      CHARACTER SYMB(8,20)*1,ISPACE*1,IDOT*1,ISTAR*1,IPLUS*1,IMINUS*1
     * ,IBAR*1
      CHARACTER TITLE*70,PHSNM(8)*70
      CHARACTER*1 IOUT(150)
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/PRFX/DELT,TL,GAM1,GAM2,PRFDER,K
      COMMON /PVII/ TF1(8),TF2(8),TF4(8),TF6(8),TF8(8),TF9(8),C4(8)
***vax***mod 
      common/vax/ lvax
      logical lvax
      COMMON/QFILES/ QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
      CHARACTER*40   QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
***vax
***mod
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      character ssgrp*1,qmodbc*20,qmodac*10
      logical lqmod
***mod
      DIMENSION DEL(10),KI(10),DUMMY(2*MSZ+1)
C     DIMENSION RJAC(MSZ,MSZ)
C     EQUIVALENCE (RJAC(1,1),KR(1))
C     DIMENSION LABEL(12),KS(50)
      DIMENSION LABEL(12)
      LOGICAL VERT
      DATA ISPACE,IDOT,ISTAR,IPLUS,IMINUS,IBAR/' ','.','*','+','0','-'/
      IF(NXT.EQ.0.OR.JOBTYP.GE.3) NPROF=NPROF-1
      RAD = 45./ATAN(1.)
      ZER=GLB(1)
      IF(IPL.NE.0)READ(5,19,END=10000)ISCALE,IDIF
19    FORMAT(BZ,2I8)
10000 IF(IPL2.NE.0)READ(5,17,END=10001)IFY,IFYC,IFM,IFD,IFB,EXPAND
10001 IF(JOBTYP.GT.2)IFY=0
      IF(JOBTYP.GT.2)IFD=0
17    FORMAT(BZ,5I1,3X,F8.0)
      IF(NXT.NE.0.AND.JOBTYP.LT.3)CALL REWRIT(ISCALE,IDIF,IFY,IFYC
     * ,IFM,IFD,IFB,EXPAND)
      IF(JOBTYP.GT.2)GOTO 37
      WRITE(6,10)
10    FORMAT(42H0AVERAGE INTENSITY DIFFERENCE FOR PATTERN,,/,
     * 37H0GIVEN FOR BLOCKS OF 20 OBSERVATIONS.)
      DO 15 I=1,NPTS,200
        DO 14 J=1,10
          J20=20*(J-1)
          DEL(J)=0
          DO 13 K=1,20
            J20IK=J20+I+K-1
13          DEL(J)=DEL(J)+Y(J20IK)-BK(J20IK)-YC(J20IK)
          KI(J)=J+I/20
          DEL(J)=DEL(J)/20.
          IF(KI(J)*20.GE.NPTS)GOTO 15
14        CONTINUE
        J=10
15      WRITE(6,20)(KI(JJ),DEL(JJ),JJ=1,J)
***** modified to eliminate output conversion error
20    FORMAT(10(1x,I4,2X,F6.1))
*****
37    DO 47 I=1,NPTS
        YC(I)=YC(I)+BK(I)
47      IF(JOBTYP.GT.2)Y(I)=YC(I)
      IF(IPC.EQ.0)GOTO 36
      DO 400 K=1,NPHASE
        IF (MOD(K,2).EQ.1) ILOC = ILOC + 1
C       GAM1=PAR(K,17)
        WRITE (6,4289) K,PHSNM(K)
4289    FORMAT (/'1PHASE NO. = ',I3,5X,'PHASE NAME ',A70)
        T2OBS=0.
        TDOBS=0.
        RFNMR=0.
        RFDNR=0.
        ICZ=0
        DO 4300 IIPHAS=1,NPHASE
4300      ICZ = ICZ + IC(IIPHAS)
        IXX=0
***vax
        if(lvax)then
          open(9,file=qpltfn,status='new',form='formatted',
     *       carriagecontrol='list')
        else
          OPEN(9,FILE='PLOTINFO',status='new')
        endif
***vax
        WRITE(9,'(A70)') TITLE
        WRITE(9,8730) ICZ
8730    FORMAT (1X,' NO. OF REFLECTIONSZ',2X,I4,/,1X,'BRAGG POSITIONSZ')
        DO 481 IX=1,ICZ
          IF(K.NE.IREFS(IX)/256/256/256/8)GOTO 481
          SHIFT = GLB(10) * COS(REFS(IX,2)/2./57.2958)
     *               + GLB(11) * SIN(REFS(IX,2)/57.2958)
          IXX=IXX+1
          DO 485 J=1,NEXCRG
            IF((REFS(IX,2)+SHIFT+ZER).GE.(ALOW(J)-WDT*REFS(IX,1))
     *                                   .AND.
     *                    (REFS(IX,2)+SHIFT+ZER).LE.(AHIGH(J)+WDT*REFS(I
     *       X,1))) GOTO 481
485         CONTINUE
          IRL=MOD(IREFS(IX),256)-128
          IRK=MOD(IREFS(IX)/256,256)-128
          IRH=MOD(IREFS(IX)/256/256,256)-128
          IRC=MOD(IREFS(IX)/256/256/256,8)
          irm=mm(ix)
          RMIN=REFS(IX,2)+ZER-WDT*REFS(IX,1)
          RMAX=REFS(IX,2)+ZER+WDT*REFS(IX,1)
          MIN=(RMIN-THMIN)/STEP+1.5
          MAX=(RMAX-THMIN)/STEP+1.5
          MIN=MAX0(MIN,1)
          MIN=MIN0(MIN,NPTS)
          MAX=MIN0(MAX,NPTS)
C     PATCH TO CALCULATE R-BRAGG
          TL=REFS(IX,1)
          VERT=REFS(IX,2).LE.RLIM
        IF (NPROF+1.EQ.6) GAM1 = PAR(K,17) + PAR(K,18) * REFS(IX,2)
        IF (NPROF+1.EQ.7) GAM1 = PAR(K,17) + PAR(K,18) / REFS(IX,2)
     !                           + PAR(K,19)/REFS(IX,2)/REFS(IX,2)
      IF (NPROF+1.EQ.7) CALL PRSVII
          IF(NPROF.EQ.7) THEN
            GAM1 = GAM(IX)
            TLG = HALFG(IX)
            TLL = HALFL(IX)
          END IF
          BB=TL*TL
          TIOBS =0.
          TIC=0.
          FF(IX)=FF(IX)*REFS(IX,3)*PAR(K,1)
          DO 410 IS=MIN,MAX
            TH=THMIN+FLOAT(IS-1)*STEP
            IF(NEXCRG.GT.0) THEN
              DO 1450 IEXC=1,NEXCRG
                IF (TH.GE.ALOW(IEXC).AND.TH.LE.AHIGH(IEXC)) GO TO 410
1450            CONTINUE
            END IF
            TH2 = 0.5*TH/RAD
            DELTA=TH-REFS(IX,2)-ZER-SHIFT
            DELT=DELTA*DELTA
C     NEXT LINE IS NECESSEARY FOR 2 PHASES WITH VERY DIFFERENT FWHM.
            IF (DELT/BB.GT.WDT*WDT) GO TO 410
            IF(.NOT.VERT)GOTO 4
            YX=DELT*SIGN(1.,DELTA)
            Z=1.-PAR(K,14)*YX/TAN(TH2)
            IF(Z.LE.0.)Z=.0001
            GOTO 5
4           Z=1.
5           OMEGA= Z*PROFIL(NPROF+1,DELT/BB)
            TIC   = TIC + OMEGA
            TIOBS = TIOBS + OMEGA*(Y(IS)-BK(IS))/AMAX1((YC(IS)-BK(IS)),1
     *       .)
410         CONTINUE
          TIC = TIC*FF(IX)/TL
          TIOBS = TIOBS*FF(IX)/TL
          T2OBS = T2OBS+TIOBS
          TDOBS = TDOBS + ABS(TIOBS-TIC)
C
         IF (IPC.EQ.2) THEN
          TFCAL = SQRT(ABS(TIC/REFS(IX,3)/PAR(K,1)))
          TFOBS = SQRT(ABS(TIOBS/REFS(IX,3)/PAR(K,1)))
          RFNMR = RFNMR + ABS(TFOBS-TFCAL)
          RFDNR = RFDNR + ABS(TFOBS)
         END IF
C
          IF (NPROF.EQ.7) GO TO 9222
          IF(MOD(IXX-1,60).EQ.0) THEN
            if(lqmod(k))then
              IF(IPC.EQ.1) WRITE(6,582)
              IF(IPC.EQ.2) WRITE(6,8582)
            else
              IF(IPC.EQ.1) WRITE(6,482)
              IF(IPC.EQ.2) WRITE(6,8482)
            endif
          END IF
482     FORMAT(32H0NO.  CODE    H   K   L   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS /)
8482    FORMAT(32H0NO.  CODE    H   K   L   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS ,8X,'FCALC',6X,'FOBS'/)
582     FORMAT(37H  NO.  CODE    H   K   L   M   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS /)
8582    FORMAT(37H  NO.  CODE    H   K   L   M   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS ,8X,'FCALC',6X,'FOBS'/)
          HW=REFS(IX,1)
      if(lqmod(k))then
        IF (IPC.EQ.1) THEN
            WRITE(6,570)IXX,IRC,IRH,IRK,IRL,irm,HW,REFS(IX,2),TIC
     *         ,TIOBS
        ELSE
            WRITE(6,570)IXX,IRC,IRH,IRK,IRL,irm,HW,REFS(IX,2),TIC
     *         ,TIOBS,TFCAL,TFOBS
        END IF
      else
        IF (IPC.EQ.1) THEN
            WRITE(6,470)IXX,IRC,IRH,IRK,IRL,HW,REFS(IX,2),TIC
     *         ,TIOBS
        ELSE
            WRITE(6,470)IXX,IRC,IRH,IRK,IRL,HW,REFS(IX,2),TIC
     *         ,TIOBS,TFCAL,TFOBS
        END IF
      endif
      WRITE (9,8147) REFS(IX,2)
          GO TO 481
9222      CONTINUE
          IF(MOD(IXX-1,60).EQ.0) THEN
            if(lqmod(k))then
              IF (IPC.EQ.1) WRITE(6,9582)
              IF (IPC.EQ.2) WRITE(6,19582)
            else
              IF (IPC.EQ.1) WRITE(6,9482)
              IF (IPC.EQ.2) WRITE(6,19482)
            endif
          END IF
9482    FORMAT(32H0NO.  CODE    H   K   L   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS ,6X,' HG      HL      ETA   ')
19482   FORMAT(32H0NO.  CODE    H   K   L   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS ,6X,' HG      HL      ETA   '
     *, ' FCALC       FOBS')
9582    FORMAT(37H  NO.  CODE    H   K   L   M   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS ,6X,' HG      HL      ETA   ')
19582   FORMAT(37H CODE    H   K   L   M   HW     ,
     *     16HPOSN      ICALC ,4X,5HIOBS ,6X,' HG      HL      ETA   '
     *, ' FCALC       FOBS')
          HW=REFS(IX,1)
      if(lqmod(k))then
        IF (IPC.EQ.1) THEN
            WRITE(6,9570)IXX,IRC,IRH,IRK,IRL,irm,HW,REFS(IX,2),TIC
     *         ,TIOBS,TLG,TLL,GAM1
        ELSE
            WRITE(6,9570)IXX,IRC,IRH,IRK,IRL,irm,HW,REFS(IX,2),TIC
     *         ,TIOBS,TLG,TLL,GAM1,TFCAL,TFOBS
        END IF
      else
        IF (IPC.EQ.1) THEN
            WRITE(6,9470)IXX,IRC,IRH,IRK,IRL,HW,REFS(IX,2),TIC
     *         ,TIOBS,TLG,TLL,GAM1
        ELSE
            WRITE(6,9470)IXX,IRC,IRH,IRK,IRL,HW,REFS(IX,2),TIC
     *         ,TIOBS,TLG,TLL,GAM1,TFCAL,TFOBS
        END IF
      endif
      WRITE (9,8147) REFS(IX,2)
8147  FORMAT (1X,F8.3)
481       CONTINUE
470     FORMAT(1X,2I4,3X,3I4,2F8.3,2F10.0,2F10.0)
570     FORMAT(1X,2I4,3X,4I4,2F8.3,2F10.0,2F10.0)
9470    FORMAT(1X,2I4,3X,3I4,2F8.3,2F10.0,3F8.3,2F10.0)
9570    FORMAT(1X,2I4,3X,4I4,2F8.3,2F10.0,3F8.3,2F10.0)
        TDOBS=100.*TDOBS/T2OBS
        WRITE(6,483)TDOBS
      IF (IPC.EQ.2)  WRITE(6,10483) 100.*RFNMR/RFDNR
483     FORMAT(26H0 DERIVED BRAGG R-FACTOR = ,F8.2)
10483   FORMAT(  '0 DERIVED R-F            = ',F8.2)
        FINAL(ILOC,2-MOD(K,2)) = TDOBS
400     CONTINUE
36    CONTINUE

      WRITE (9,8476) NPTS, THMIN, STEP
8476  FORMAT (1X,'NPTSZ',I5,/, 1X, 'THMINZ',F8.3,/,1X,'STEPZ',F8.3,/,
     *1X,4HYOBS,4X,6HYCALCZ)

      DO 31 I=1,NPTS
        BK(I)=THMIN+FLOAT(I-1)*STEP
31    WRITE(9,8477)Y(I),YC(I)
8477  FORMAT (1X,2F8.0)
      CLOSE (9)

      IF(IOT.EQ.0)GOTO 30
      NP=NPTS/240
      WRITE(6,101)(((BK(240*N-300+60*I+J),Y(240*N-300+60*I+J),YC(
     * 240*N-300+60*I+J),VAR(240*N-300+60*I+J),I=1,4),J=1,60),N=1,NP)
101   FORMAT((2H1 ,4(6H2THETA,3X,4HYOBS,4X,5HYCALC,1X,8HVARIANCE,1X),/,
     *  60(4(1X,F7.3,3F8.0),/)))
      NPTS2=NPTS-NP*240
      IF(NPTS2.EQ.0)GOTO 30
      NCOL=NPTS2/60
      WRITE(6,103)
103   FORMAT(2H1 ,4(6H2THETA,3X,4HYOBS,4X,5HYCALC,1X,8HVARIANCE,1X))
      NLINES=NPTS2-NCOL*60
      IF(NLINES.EQ.0)GOTO 33
      NCOL1=NCOL+1
      NP=240*NP-60
      DO 34 J=1,NLINES
34      WRITE(6,102)(BK(NP+60*I+J),Y(NP+60*I+J),YC(NP+60*I+J),
     *      VAR(NP+60*I+J),I=1,NCOL1)
102   FORMAT(4(1X,F7.3,3F8.0))
      NP=NP+NLINES
      NLINES=60-NLINES
33    DO 35 J=1,NLINES
35      WRITE(6,102)(BK(NP+60*I+J),Y(NP+60*I+J),YC(NP+60*I+J),
     *      VAR(NP+60*I+J),I=1,NCOL)
30    IF(IPL.EQ.0)GOTO 45
      DO210I=1,12
210     LABEL(I)=10*I*ISCALE
      WRITE(6,100) TITLE,LABEL
100   FORMAT(1H1,30X,A70//1X,12I10)
      DO11I=1,12
11      LABEL(I)=-60*IDIF+10*I*IDIF
      WRITE(6,203) LABEL
203   FORMAT(1H ,12I10)
      DO 60 I=1,NPTS
1       DO 3 J=1,120
3         IOUT(J)=ISPACE
        IOUT(1)=IDOT
        IOUT(61)=IDOT
        IOUT(120)=IDOT
200     IY=INT(Y(I))/ISCALE+2
        IY=MAX0(MIN0(IY,120),2)
        IOUT(IY-1)=IBAR
        IOUT(IY)=IPLUS
        IF(IY.LE.119)IOUT(IY+1)=IBAR
        IY=INT(YC(I))/ISCALE+2
        IY=MAX0(MIN0(IY,120),2)
        IOUT(IY)=IMINUS
        IY=INT(Y(I)-YC(I))/IDIF+61
        IY=MAX0(MIN0(IY,120),2)
        IOUT(IY)=ISTAR
        IF(MOD(I-1,10).NE.0) GOTO 55
        TLABEL=THMIN+STEP*FLOAT(I-1)
        WRITE(6,104)(IOUT(J),J=1,113),TLABEL,IOUT(120)
104     FORMAT(1X,113A1,F6.2,A1)
        GO TO 60
55      WRITE(6,201) (IOUT(J),J=1,120)
201     FORMAT(1X,120A1)
60      CONTINUE
45    IF(JOBTYP.LT.3)GOTO 72
      REWIND 4
      WRITE(4,70)THMIN,STEP,THMAX
70    FORMAT(3F8.4)
      WRITE(4,71)(YC(I),I=1,NPTS)
71    FORMAT(8(F7.0,1X))
***vax modification
*72      IF(IPL2.NE.0)CALL CALPLT(IFY,IFYC,IFM,IFD,IFB,EXPAND,ZER)
***vax
72    IF(IPLST.NE.0.AND.MAXS.NE.0) THEN
        INUMB = ICYRUN + 1
        NPAGES = MAXS/12
        IF (MOD(MAXS,12).NE.0) NPAGES = NPAGES+1
C     LIST PARAMETERS IN EACH CYCLE
        WRITE (6,2002)
2002    FORMAT ('1PARAMETERS IN EACH CYCLE')
        DO 7924 J=1,NPAGES
        REWIND 8
          ISTART = 1 + (J-1)*12
          IFINIS  = MIN0(MAXS,12 + (J-1)*12)
          WRITE (6,2001) (L,L=ISTART,IFINIS)
2001      FORMAT ('0CYCLE',12(3X,I2,5X))
          DO 7924 K=1,INUMB
            READ  (8,ERR=99992) (DUMMY(I),I=1,2*MAXS+4)
7924        WRITE (6,2000,ERR=99990) K-1,(DUMMY(I),I=ISTART,IFINIS)
2000    FORMAT (1X,I2,')',2X,12E10.4)
C     LIST R-VALUES  IN EACH CYCLE
        REWIND 8
        WRITE (6,2012)
2012    FORMAT ('1R-VALUE VARIATION WITH CYCLE')
        WRITE (6,2011)
2011    FORMAT ('0CYCLE',4X,'R-P',5X,'R-WP',2X,'    S   ',3X,'D-W D')
        DO 7944 K=1,INUMB
          READ  (8,ERR=99992) (DUMMY(I),I=1,2*MAXS+4)
7944      WRITE (6,2010,ERR=99990) K-1,(DUMMY(I),I=2*MAXS+1,2*MAXS+4)
2010    FORMAT (1X,I2,')',2X, 4F8.2)
C     LIST PARAMETER SHIFTS IN EACH CYCLE
        IF (INUMB.EQ.1) GO TO 88880
        WRITE (6,2022)
2022    FORMAT ('1APPLIED PARAMETER SHIFT IN EACH CYCLE')
        DO 7964 J=1,NPAGES
        REWIND 8
          ISTART = 1 + MAXS+ (J-1)*12
          IFINIS = MIN0(2*MAXS,12 + MAXS+ (J-1)*12)
          WRITE (6,2021) (L,L=ISTART-MAXS,IFINIS-MAXS)
2021      FORMAT ('0CYCLE',12(3X,I2,5X))
          DO 7964 K=1,INUMB-1
            READ  (8,ERR=99992) (DUMMY(I),I=1,2*MAXS+4)
            IF (K.EQ.1) GO TO 7964
7964        WRITE (6,2020,ERR=99990) K,(DUMMY(I),I=ISTART,IFINIS)
2020    FORMAT (1X,I2,')',2X,12E10.4)
      END IF
88880 CONTINUE
C     CODE FOR PRINTING PARAMETERS AND STD. DEV. IN THE FINAL CYCLE
      IF (IPLST.EQ.2) THEN
      WRITE (6,5000) TITLE
5000  FORMAT ('1PARAMETERS AND STANDARD DEVIATIONS IN THE FINAL CYCLE'
     ! ,' FOR DATA BASE ',/,' " ',A70,' " ')
      WRITE (6,7445,ERR=99991) ((FINAL(I,J),J=1,2),I=1,ILOC)
 7445 FORMAT (12(1X,E10.4))
      END IF
      RETURN
99990 STOP 'ERROR IN WRITING TO FILE 6 IN SUBROUTINE EXPUT'
99991 STOP 'ERROR WRITING PARAMS,ST.DEV. IN SUBROUTINE EXPUT'
99992 STOP 'ERROR IN READING FROM UNIT 8 IN SUBROUTINE EXPUT'
      END
*****
*** subroutine rewrit goes here ***
      SUBROUTINE REWRIT(ISCALE,IDIF,IFY,IFYC,IFM,IFD,IFB,EXPAND)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      REAL LAMDA
      INTEGER PTR
      COMMON/DC/SAVE(8,6),NSAVE
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
***mod
      CHARACTER*40   QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
      COMMON/QFILES/ QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
      common/vax/ lvax                      
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      character ssgrp*1,qmodbc*20,qmodac*10 
      logical lvax,lqmod
***mod
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
***** mod 4-3-91 dpm
      close(unit=5)
      open(unit=5,file=qnewfn,status='new',carriagecontrol='list')
*      REWIND 5
*****
      WRITE(5,1)TITLE
1     FORMAT(A70)
      JOBTYP=JOBTYP-1
      NPROF=NPROF-1
      INSTRM = INSTRM-1
      WRITE(5,2)JOBTYP,NPROF,NPHASE,NBCKGD,NEXCRG,NSCAT,INSTRM,IPREF
2     FORMAT(9I4)
      WRITE(5,14)IOT,IPL,IPC,MAT,NXT,LST1,LST2,LST3,IPL1,IPL2,IPLST
14    FORMAT(11I1)
      WRITE(5,23)LAMDA,RATIO(2),BKPOS,WDT,CTHM,TMV,RLIM
23    FORMAT(8F8.4)
      WRITE(5,30)MCYCLE,EPS,RELAX
30    FORMAT(1I4,5F4.2)
      IF(NBCKGD.LT.2)GOTO 120
      WRITE(5,34)(POS(I),BCK(I),I=1,NBCKGD)
34    FORMAT(2F8.2)
120   IF(NEXCRG.LE.0)GOTO 122
      WRITE(5,34)(ALOW(I),AHIGH(I),I=1,NEXCRG)
122   IF(NSCAT.LE.0)GOTO 124
      DO 125 I=1,NSCAT
        WRITE(5,38)NAM(I),DFP(I),DFPP(I)
38      FORMAT(A4,2F8.4)
126     IF(JOBTYP.EQ.0)WRITE(5,39)(AC(J,I),J=1,9)
39      FORMAT(9F8.5)
125     CONTINUE
124   CONTINUE
      WRITE(5,43)MAXS
43    FORMAT(I8)
      N=0
      DO 4310 IIPHAS=1,NPHASE
4310    N=N+NATOM(IIPHAS)
      DO 84 I=1,N
***mod
        DO 84 J=1,17
84        A(I,J)=SIGN(1.,A(I,J))*(FLOAT(10*LP(I,J))+ABS(A(I,J)))
      DO 87 I=1,NPHASE
        DO 88 J=1,6
88        PAR(I,J+5)=SAVE(I,J)
        DO 87 J=1,20
87        APAR(I,J)=SIGN(1.,APAR(I,J))*(FLOAT(10*LPAR(I,J))+ABS(APAR(I,J
     *     )))
      DO 89 J=1,11
89      AGLB(J)=SIGN(1.,AGLB(J))*(FLOAT(10*LGLB(J))+ABS(AGLB(J)))
      IF(NPROF.EQ.7) THEN
        GLB(8) = 0.0
        AGLB(8) = 0.0
      END IF
      WRITE(5,45)GLB(1),AGLB(1),(GLB(J),AGLB(J),J=9,11)
45    FORMAT(2F8.4,16X,6F8.4)
      IF(NBCKGD.EQ.0)WRITE(5,46)(GLB(J),J=2,7),(AGLB(J),J=2,7)
46    FORMAT(6G12.6,/,6F12.6)
477   DO 81 K=1,NPHASE
        IOF=0
        IF(K.GT.1) THEN
          DO 4311 IIPHAS=2,K
4311        IOF = IOF + NATOM (IIPHAS-1)
        END IF
        WRITE(5,465)PHSNM(K)
465     FORMAT(A70)
        WRITE(5,48)NATOM(K),NEQC(K),NINEQC(K),(PREF(K,I),I=1,3)
48      FORMAT(3I4,3F4.2)
        N=NATOM(K)
        WRITE(5,460)(SYMB(K,I),I=1,20)
460     FORMAT(20A1)
        if(lqmod(k))then
          write(5,665)(ATEXT(I+IOF),NTYP(I+IOF),     
     *      (XL(I+IOF,J),J=1, 5), (A(I+IOF,J),J=1, 5),        
     *         (XL(I+IOF,J),J=6,11), (A(I+IOF,J),J=6,11),     
     *            (xl(i+iof,j),j=12,17), (a(i+iof,j),j=12,17),
     *               I=1,N)                                   
        else
          WRITE(5,65)(ATEXT(I+IOF),NTYP(I+IOF),
     *     (XL(I+IOF,J),J=1, 5),(A(I+IOF,J),J=1, 5),
     *        (XL(I+IOF,J),J=6,11),(A(I+IOF,J),J=6,11),
     *            I=1,N)
        endif
65      FORMAT(2A4,8X,5F8.5,/,16X,5F8.2,/,6F8.5,/,6F8.2)
665     FORMAT(2A4,8X,5F8.5,/,16X,5F8.2,/,6F8.5,/,6F8.2,/
     *   ,6F8.5,/,6F8.2)                                    
        if(lqmod(k))write(5,172)(qmodic(k,j),j=1,3)
172     format(3f8.4)                             
***mod
        WRITE(5,50) PAR(K,1),PAR(K,2),
     *                 APAR(K,1),APAR(K,2),
     *PAR(K,3),PAR(K, 4),PAR(K,5),PAR(K,20),PAR(K,15),PAR(K,16),
     *APAR(K,3),APAR(K, 4),APAR(K,5),APAR(K,20),APAR(K,15),APAR(K,16),
     *               (PAR(K,I),I=6,11), (APAR(K,I),I=6,11),
     *        PAR(K,12),PAR(K,13),PAR(K,14),
     *          APAR(K,12),APAR(K,13),APAR(K,14),
     *           PAR(K,17),PAR(K,18),PAR(K,19),
     *            APAR(K,17),APAR(K,18),APAR(K,19)
50      FORMAT(G8.3,F8.4,40X,'SCALE, OVERALL B',/
     *     ,2F8.2,/,
     *        6F8.5,16X,'U V W Z X Y',/,6F8.2,/,
     *           6F8.4,8X,'CELL PARAMETERS',/,6F8.2,/,
     *               3F8.5,32X,'PREF1 PREF2 ASYMMETRY',/,3F8.2,/,
     * 3G8.3,32X,'NA,NB,NC MIXING PARAMS',/,3F8.2)
81      CONTINUE
      IF(IPL.NE.0)WRITE(5,191)ISCALE,IDIF
191   FORMAT(2I8)
      IF(IPL2.NE.0)WRITE(5,171)IFY,IFYC,IFM,IFD,IFB,EXPAND
      IF(IPL2.EQ.0)WRITE(5,171)  2,   1,  1,  1,0,0.95
171   FORMAT(5I1,3X,F8.4)
151   RETURN
      END
      SUBROUTINE SUMMAT(IPM)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      REAL LAMDA
      INTEGER PTR
      COMMON/F1/RJAC(MSZ,MSZ),V1(MSZ)
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
C     COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      COMMON/G3/COND,IORD1,IORD2,TH,NUM
      COMMON/G4/TANN(NOV),DERSTO(NOV,MSZ)
      COMMON /PVII/ TF1(8),TF2(8),TF4(8),TF6(8),TF8(8),TF9(8),C4(8)
      COMMON/PRFX/DELT,TL,GAM1,GAM2,PRFDER,IPH
      DIMENSION DERIV(MSZ)
      LOGICAL VERT
      DO 2 J=1,MSZ
2       DERIV(J)=0.
      YCALC=0.
      IL=0
      GAM1=GLB(8)
      GAM2=GLB(9)
C-----CALCULATE THE CONTRIBUTION OF THE REFLECTIONS ORD1 TO ORD2 TO THE
C-----DERIVATIVES W.R.T. THE PROFILE INTENSITY YOBS
      IF(IORD1.EQ.0)GOTO 12
      DO 33 I=IORD1,IORD2
        IPH=IREFS(I)/256/256/256/8
        IF (NPROF.EQ.6) GAM1 = PAR(IPH,17) + PAR(IPH,18) * REFS(I,2)
        IF (NPROF.EQ.7) GAM1 = PAR(IPH,17) + PAR(IPH,18) / REFS(I,2)
     !                              + PAR(IPH,19)/REFS(I,2)/REFS(I,2)
        IF (NPROF.EQ.7) CALL PRSVII
        IL=IL+1
        J=MOD(I,NOV)+1
        VERT=REFS(I,2).LE.RLIM
        SHIFT = GLB(10) * COS(REFS(I,2)/2./57.2958)
     *           + GLB(11) * SIN(REFS(I,2)/57.2958)
        DELTA=TH-REFS(I,2)-GLB(1)-SHIFT
        DELT=DELTA*DELTA
        TL=REFS(I,1)
        IF(NPROF.EQ.8) THEN
          TLL = HALFL(I)
          GAM1 = GAM(I)
          TLR = TLL/TL
        END IF
        BB=TL*TL
C     NEXT LINE IS NECESSEARY FOR 2 PHASES WITH VERY DIFFERENT FWHM.
        IF (DELT/BB.GT.WDT*WDT) GO TO 33
        IF(.NOT.VERT)GOTO 4
        YX=DELT*SIGN(1.,DELTA)
        Z=1.-PAR(IPH,14)*YX/TANN(J)
        IF(Z.LE.0.)Z=.0001
        GOTO 5
4       Z=1.
5     PRTEMP = PROFIL(NPROF,DELT/BB)
        OMEGA=REFS(I,3)*Z*PRTEMP*PAR(IPH,1)/TL
        YCALC=YCALC+OMEGA*FF(I)
        IF(JOBTYP.GT.2)GOTO 33
        X=PRFDER*2.*DELT/BB-1.
        DO 3 K=1,MAXS
          DER=1.
          DO 6 M=3,5
            IF(LPAR(IPH,M).EQ.K)DER=X/TL/2.
6           CONTINUE
          IF (LPAR(IPH,20).EQ.K) DER=X/TL/2.
          X1=0.
          IF(VERT)X1=PAR(IPH,14)*SIGN(1.,DELTA)*BB/TANN(J)/Z
          IF(LGLB(1).EQ.K)DER=DELTA*(PRFDER+X1)
          IF(LGLB(10).EQ.K)DER=DELTA*(PRFDER+X1)
          IF(LGLB(11).EQ.K)DER=DELTA*(PRFDER+X1)
          IF((LPAR(IPH,14).EQ.K).AND.VERT)DER=YX/Z
          IF (NPROF.EQ.8) GO TO 8
C
          IF(NPROF.EQ.6) THEN
            KRP1=LPAR(IPH,17)
            IF(K.EQ.KRP1)DER=(.636619772/(1.+4.*DELT/BB)-
     *             .939437279*EXP(-2.772588722*DELT/BB))/PRTEMP
            KRP1=LPAR(IPH,18)
            IF(K.EQ.KRP1)DER=(.636619772/(1.+4.*DELT/BB)-
     *             .939437279*EXP(-2.772588722*DELT/BB))/PRTEMP
          END IF
C
      IF (NPROF.EQ.7) THEN
            KRP1=LPAR(IPH,17)
            IF(K.EQ.KRP1)
     *      DER=-ALOG(1.+TF9(IPH)*DELT/BB)
     *          +TF4(IPH)*(DELT/BB)/(1.+TF9(IPH)*DELT/BB)
     !            +TF8(IPH)
            KRP1=LPAR(IPH,18)
            IF(K.EQ.KRP1)
     *      DER=-ALOG(1.+TF9(IPH)*DELT/BB)
     *           +TF4(IPH)*(DELT/BB)/(1.+TF9(IPH)*DELT/BB)
     !            +TF8(IPH)
            KRP1=LPAR(IPH,19)
            IF(K.EQ.KRP1)
     *      DER=-ALOG(1.+TF9(IPH)*DELT/BB)
     *           +TF4(IPH)*(DELT/BB)/(1.+TF9(IPH)*DELT/BB)
     !            +TF8(IPH)
      END IF
C
          IF(NPROF.EQ.5) THEN
          KRP1=LGLB(8)
          KRP2=LGLB(9)
          YZ=2.*2.772588722*DELT/BB
          YZ1=SIGN(SQRT(YZ),DELTA)
          IF(K.EQ.KRP1)DER=EXP(-.5*YZ)*((YZ1*(YZ-3.)/6.
     *         +GAM1/36.*(YZ*(YZ*(YZ-15.)+45.)-15.)))
          IF(K.EQ.KRP2)DER=EXP(-.5*YZ)/24.*(YZ*(YZ-6.)+3.)
      END IF
8         DO 7 M=6,11
            IF(LPAR(IPH,M).EQ.K)DER=(PRFDER+X1)*DELTA
7           CONTINUE
3         DERIV(K)=DERSTO(J,K)*DER*OMEGA+DERIV(K)
        IF(NPROF.EQ.8) THEN
          OMEGA8 = Z*PAR(IPH,1)*REFS(I,3)/TL
          DO 1000 K=1,MAXS
            DO 1001 M=3,5
              IF (LPAR(IPH,M).NE.K) GO TO 1001
              DERIV(K) = DERIV(K)+ OMEGA8*DERSTO(J,K)/2.*
     *                  (.939437279*EXP(-2.772588722*DELT/BB) -
     *                            .636619772/(1.+4.*DELT/BB)) *
     *                                  (1.36603*TLR/TL-.95438*TLR*TLR/T
     *         L+.33348*TLR**3./TL)
1001          CONTINUE
              IF (LPAR(IPH,20).EQ.K)
     *        DERIV(K) = DERIV(K)+ OMEGA8*DERSTO(J,K)/2.*
     *                  (.939437279*EXP(-2.772588722*DELT/BB) -
     *                            .636619772/(1.+4.*DELT/BB)) *
     *                                  (1.36603*TLR/TL-.95438*TLR*TLR/T
     *         L+.33348*TLR**3./TL)
            IF (LPAR(IPH,15).NE.K) GO TO 1002
            DERIV(K) = DERIV(K)+ OMEGA8*
     *              (.939437279*EXP(-2.772588722*DELT/BB) -
     *                      .636619772/(1.+4.*DELT/BB)) *
     *                          ((1.36603*TLR/TL-.95438*TLR*TLR/TL+.3334
     *       8*TLR**3./TL)*            DERSTO(J,K)/2. - FF(I)*TANN(J)*
     *                                        (1.36603/TL-.95438*TLR/TL+
     *       .33348*TLR*TLR/TL))
1002        CONTINUE
            IF (LPAR(IPH,16).NE.K) GO TO 1003
            DERIV(K) = DERIV(K)+ OMEGA8*
     *              (.939437279*EXP(-2.772588722*DELT/BB) -
     *                      .636619772/(1.+4.*DELT/BB)) *
     *                          ((1.36603*TLR/TL-.95438*TLR*TLR/TL+.3334
     *       8*TLR**3./TL)*            DERSTO(J,K)/2. - FF(I)*SQRT(1+TAN
     *       N(J)*TANN(J))*                   (1.36603/TL-.95438*TLR/TL+
     *       .33348*TLR*TLR/TL))
1003        CONTINUE
1000        CONTINUE
        END IF
33      CONTINUE
C-----FORM SUMS
12    IF(NBCKGD.NE.0)GOTO 11
      DO 10 I=2,7
        IF(LGLB(I).EQ.0.)GOTO 10
        KM=LGLB(I)
        IF(I.EQ.2)DERIV(KM)=DERIV(KM)+1.
        IF(I.EQ.2)GOTO 10
        DERIV(KM)=DERIV(KM)+((THMIN+FLOAT(IPM-1)*STEP)/BKPOS-1.)**(I-2)
10      CONTINUE
11    YC(IPM)=YCALC
      IF (JOBTYP.GT.2) GOTO 20
      DELTA=Y(IPM)-BK(IPM)-YCALC
      DO 9 J=1,MAXS
        X=DERIV(J)/(VAR(IPM))
        V1(J)=V1(J)+DELTA*X
        DO 9 K=J,MAXS
9         RJAC(J,K)=RJAC(J,K)+X*DERIV(K)
20    RETURN
      END
      SUBROUTINE REFGEN(IPHASE,ZERO,DISP,TRANSP,PREF,PREFOR)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/HKLCTL/KZ(3,24),AZ(24),NCN(70),ICQ,N1,IER,HN
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),MLT(IRS),ICX(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS)
      REAL LAMDA
      INTEGER H1,H2,H3
      LOGICAL ORH1,ORH2,ORH3
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/SPG/NSPGRP,K,M(10),FILL(3)
      COMMON/CELLX/A,B,C,ALPHA,BETA,GAMMA,AL(3,3)
      DIMENSION PREF(8,3)
      EQUIVALENCE (AL(1,1),ASTAR),(AL(2,2),BSTAR),(AL(3,3),CSTAR),
     * (AL(1,2),BACOSC),(AL(1,3),CACOSB),(AL(2,3),BCCOSA)
      CHARACTER*8 LAU(14)
      DATA LAU(1),LAU(2),LAU(3),LAU(4),LAU(5),LAU(6),LAU(7),LAU(8),
     * LAU(9),LAU(10),LAU(11),LAU(12),LAU(13),LAU(14)
     *  /'1BAR','2/M','MMM','4/M','4/MMM','3BAR   R','3BAR M R','3BAR',
     *   '3BAR M 1','3BAR 1 M','6/M','6/MMM','M3','M3M'/
      SIN1(A)=SIN(A*6.28318531)
      RAD=3.14159265359/360.0
      IF ( K.GT.3 ) STOP 5001
      KXIS=K
      K=1
1002  N = 0
      J = 0
      I2D = 0
      I3D = 0
      I1D = 1
      I12D = 1
      I13D = 1
      I123D = 1
      I23D = 1
      I2DEL = 1
      I3DEL = 1
      DO 8000 I=1,8
        IF ( M(I).EQ.0 ) GO TO 9000
        IF ( M(I)-8192 ) 8002,8001,8000
8001    I3DEL = 3
        I1D = 2
        I123D = 3
        GO TO 9000
8002    IF ( M(I)-576 ) 8004,8003,8004
8003    I3DEL = 2
        I23D = 2
        GO TO 8000
8004    IF ( M(I)-516 ) 8008,8009,8008
8009    I3DEL = 2
        I13D = 2
        GO TO 8000
8008    IF ( M(I)-68 ) 8012,8013,8012
8012    IF ( M(I)-580 ) 8015,8016,8015
8013    I2DEL = 2
        I12D = 2
        GO TO 8000
8016    I123D = 2
        I3DEL = 2
8015    CONTINUE
8000    CONTINUE
9000  N=J-1
97    TMIN = (SIN1(THMIN/720.0)/LAMDA(1))**2
      IC = 0
      IF (IPHASE.GE.2) THEN
        DO 4100 IIPHAS=2,IPHASE
4100      IC = IC+ICX(IIPHAS-1)
      END IF
C     IF(IPHASE.EQ.2)IC=ICX(1)
      SMAX = (SIN1(THMAX/720.0)/LAMDA(1))**2
      IF(LAMDA(2).GT.LAMDA(1))TMIN=TMIN*(LAMDA(1)/LAMDA(2))**2
      IF(LAMDA(2).GT.0..AND.LAMDA(2).LT.LAMDA(1))SMAX=SMAX*
     * (LAMDA(1)/LAMDA(2))**2
      CALL OP1
      WRITE(6,36)LAU(NSPGRP)
36    FORMAT(15H LAUE SYMMETRY ,A8,33H WILL BE USED TO GENERATE INDICES)
      I1MAX=A*2.0*SQRT(SMAX)
      IF ( KXIS.LT.3 ) THEN
        I2MAX=B*2.0*SQRT(SMAX)
        I3MAX=C*2.0*SQRT(SMAX)
      ELSE
        I2MAX = 2.0*C*SQRT(SMAX)
        I3MAX = 2.0*B*SQRT(SMAX)
      END IF
      L1 = NSPGRP
      IF ( L1.GE.13.AND.M(1).EQ.580 ) L1=L1+2
      IF ( I12D+I13D+I23D.NE.5 ) GO TO 2131
      I12D = 2
      I13D = 1
      I23D = 2
      I2DEL = 2
      I3DEL = 2
2131  IF ( L1.EQ.6 ) I2D=1
      IF ( L1.EQ.7 ) I2D=2
      I3D = I2D
      I1 = -1
2200  I1 = 1+I1
      IF ( I1-I1MAX ) 2201,2201,2303
2201  H1 = I1
      IF ( I2D.GT.0 ) I2MAX=I1
      GO TO (2203,2204,2204,2205,2206,2208,2209,2207,2204,2206,2204,
     *  2206,2206,2206,2206,2206),L1
      CALL GOTOER
2203  I2= -MIN0(I2MAX,I1*I2MAX)
      GO TO 2210
2204  I2 = 0
      GO TO 2210
2205  I2= MIN0(I1,1)
      GO TO 2210
2206  I2 = I1
      GO TO 2210
2207  I2= MIN0(-I1+1,0)
      GO TO 2210
2208  I2 = -2*I1
      GO TO 2210
2209  I2 = -I1/2
2210  I2= I2DEL*(I2/I2DEL)+MOD(I1,I12D)
      GO TO 2221
2220  I2 = I2DEL+I2
2221  H2 = I2
      IF ( I2-I2MAX ) 2222,2222,2200
2222  GO TO (2223,2223,2224,2224,2224,2225,2225,2224,2224,2223,2224,
     *  2224,2226,2227,2236,2235),L1
      CALL GOTOER
2223  I3= -MIN0(I3MAX,(I1+IABS(I2))*I3MAX)
C2223 I3= -MIN0(I3MAX,I1*I3MAX)  (ALLEN MADE THIS CHANGE,REVERTED LATER)
      GO TO 2228
2224  I3 = 0
      GO TO 2228
2225  I3 = -I1-I2
      GO TO 2228
2226  I3= MIN0(I2,I1+I3DEL)
      GO TO 2228
2227  I3 = I2
2228  I3= I3DEL*(I3/I3DEL)+MOD(MOD(I1+I1D*I2,I123D)+I123D,I123D) +MOD(I1
     * ,I13D)+MOD(I2,I23D)
      IF ( I3D-1 ) 2232,2229,2231
2229  I3MAX = I1
      IF ( I2-I1 ) 2230,2232,2230
2230  I3MAX = I3MAX-1
      GO TO 2232
2231  I3MAX = I2
      GO TO 2232
2235  I3= I2+MOD(I1,2)
      GO TO 2232
2236  I3 = I1+2-MOD(I2,2)
      IF ( I1.EQ.I2.AND.MOD(I1,2).EQ.0 ) I3=I1
      GO TO 2232
2233  I3 = I3DEL+I3
2232  H3 = I3
      IF ( KXIS.NE.3 ) GO TO 2240
      H3 = I2
      H2 = I3
2240  CONTINUE
      IF ( I3-I3MAX ) 113,113,2220
113   SQ=FLOAT(H1*H1)*ASTAR+FLOAT(H2*H2)*BSTAR+FLOAT(H3*H3)*CSTAR
     * +FLOAT(H1*H2)*BACOSC+FLOAT(H1*H3)*CACOSB+FLOAT(H2*H3)*BCCOSA
      SQ=SQ/4.
2234  IF ( SQ-SMAX ) 3000,3000,2233
2303  ICX(IPHASE)=IC
      IF (IPHASE.GE.2) THEN
        DO 4101 IIPHAS=2,IPHASE
4101      ICX(IPHASE) = ICX(IPHASE)-ICX(IIPHAS-1)
      END IF
C     IF(IPHASE.EQ.2)ICX(IPHASE)=IC-ICX(1)
      CALL SORT(IPHASE)
      RETURN
3000  IF ( SQ - TMIN ) 2233,3117,3117
3117  IF ( IC.GT.IRS-2 ) GO TO 6001
C     NEXT IF BLOCK FOR PHASE WITH DISTINCT ORIENTATION ALONG PREF(K,I)
      IF (PREFOR.GT.99.) THEN
C
        ORH1 = IFIX(PREF(IPHASE,1)).EQ.H1
        IF (.NOT.(ORH1).AND.H1.NE.0.AND.IFIX(PREF(IPHASE,1)).NE.0)
     *        ORH1 = MOD(H1,IFIX(PREF(IPHASE,1))).EQ.0
        IF (.NOT.ORH1) GO TO 2233
C
        ORH2 = IFIX(PREF(IPHASE,2)).EQ.H2
        IF (.NOT.(ORH2).AND.H2.NE.0.AND.IFIX(PREF(IPHASE,2)).NE.0)
     *        ORH2 = MOD(H2,IFIX(PREF(IPHASE,2))).EQ.0
        IF (.NOT.ORH2) GO TO 2233
C
        ORH3 = IFIX(PREF(IPHASE,3)).EQ.H3
        IF (.NOT.(ORH3).AND.H3.NE.0.AND.IFIX(PREF(IPHASE,3)).NE.0)
     *        ORH3 = MOD(H3,IFIX(PREF(IPHASE,3))).EQ.0
        IF (.NOT.ORH3) GO TO 2233
        IORDR1=0
        IORDR2=0
        IORDR3=0
        IF (H1.NE.0) IORDR1 = INT(H1/IFIX(PREF(IPHASE,1)))
        IF (H2.NE.0) IORDR2 = INT(H2/IFIX(PREF(IPHASE,2)))
        IF (H3.NE.0) IORDR3 = INT(H3/IFIX(PREF(IPHASE,3)))
        IF (IORDR1.EQ.IORDR2.AND.IORDR2.EQ.IORDR3) GO TO 9257
        IF (IORDR1.EQ.0.AND.(IORDR2.EQ.IORDR3)) GO TO 9257
        IF (IORDR2.EQ.0.AND.(IORDR3.EQ.IORDR1)) GO TO 9257
        IF (IORDR3.EQ.0.AND.(IORDR1.EQ.IORDR2)) GO TO 9257
        IF (IORDR1.EQ.0.AND.IORDR2.EQ.0) GO TO 9257
        IF (IORDR2.EQ.0.AND.IORDR3.EQ.0) GO TO 9257
        IF (IORDR3.EQ.0.AND.IORDR1.EQ.0) GO TO 9257
      END IF
9257  CONTINUE
C     SEPARATE PHASE FOR ORIENTATION COMPLETE
      KZ(1,1)=H1
      KZ(2,1)=H2
      KZ(3,1)=H3
      AZ(1)=0.0
      IER=0
      CALL SMTRY2
      IF(IER.NE.0)GOTO 2233
      LXN=2
      IF(LAMDA(2).EQ.0..OR.LAMDA(2).EQ.LAMDA(1))LXN=1
      DO 3118 LX1=1,LXN
        SQH=SQ*LAMDA(LX1)*LAMDA(LX1)
        TAN2=SQH/(1.-SQH)
        IF(SQH.GE.1.)GOTO 3118
        TANX=SQRT(TAN2)
C     SHIFT DUE TO SAMPLE DISPLACEMENT AND TRANSPARENCY
        SHIFT =  DISP*SQRT(1-SQH)+TRANSP*SQRT(1.-(1.-2.*SQH)*(1.-2.*SQH)
     *   )
        POS=ATAN(TANX)/RAD+ ZERO + SHIFT
        IF(POS.GT.THMAX.OR.POS.LT.THMIN)GOTO 3118
        IC=IC+1
        XABS=1.0
        IF(TMV.LE.0.000001)XABS=1.
        PLOR=1./(2.*SQH*SQRT(1.-SQH))*XABS
        IF (INSTRM.EQ.2) THEN
          PLOR = PLOR * (0.95+0.05*(1.-2.*SQH)*(1.-2.*SQH))
          GO TO 4000
        END IF
        IF(JOBTYP.EQ.3)PLOR=PLOR*(1.+(1.-2.*SQH)*(1.-2.*SQH)*CTHM)
        IF(JOBTYP.EQ.1)PLOR=PLOR*(1.+(1.-2.*SQH)*(1.-2.*SQH)*CTHM)
4000    CONTINUE
        IREFS(IC)=256*(256*(256*(8*IPHASE+LX1)+128+H1)+128+H2)+128+H3
        MLT(IC)=MULT(H1,H2,H3,KXIS)
C
C------CALCULATE HALFWIDTH FOR PSEUDOVOIGT WITH GAUSS AND LORENTZ
        IF (NPROF.EQ.8) THEN
          HALFG(IC) =    (U*TAN2+V*TANX+W+ZZZ*(1+TAN2))
          IF (HALFG(IC).GT.0.) THEN
            HALFG(IC) = SQRT(HALFG(IC))
          ELSE
            WRITE (6,3456) POS,IPHASE
            WRITE (7,3456) POS,IPHASE
            STOP 'SQUARE OF FWHM IS NEGATIVE'
3456        FORMAT (3X,'SQUARE OF FWHM NEGATIVE AT TWO-THETA',F8.3,
     *             'FOR PHASE NO. ',I4)
          END IF
          HALFL(IC) = ULOR*TANX+VLOR/SQRT(1.-SQH)
          REFS(IC,1) = (HALFG(IC)**5.+2.69269*HALFG(IC)**4.*HALFL(IC)+
     *         2.42843*HALFG(IC)**3.*HALFL(IC)**2.+
     *              4.47163*HALFG(IC)**2.*HALFL(IC)**3. +
     *                   0.07842*HALFG(IC)*HALFL(IC)**4. + HALFL(IC)**5.
     *     )**0.2
          TLR = HALFL(IC)/REFS(IC,1)
          GAM(IC) = 1.36603*TLR-0.47719*TLR*TLR+0.11116*TLR**3.
          GO TO 7000
        END IF
        REFS(IC,1)=    (U*TAN2+V*TANX+W+ZZZ*(1+TAN2))
        IF (REFS(IC,1 ).GT.0.) THEN
          REFS(IC,1)= SQRT(REFS(IC,1))
        ELSE
          WRITE (6,3456) POS,IPHASE
          WRITE (7,3456) POS,IPHASE
          STOP 'SQUARE OF FWHM IS NEGATIVE'
        END IF
7000    REFS(IC,2)=POS
        REFS(IC,3)=PLOR
3118    CONTINUE
      GOTO 2233
6001  WRITE(6,24) IRS
      WRITE(7,24) IRS
24    FORMAT (//'TOO MANY REFLECTIONS, INCREASE *IRS* IN THE PARAMETER
     *  STATEMENT IN THE SOURCE CODE ')
      STOP
C     GO TO 2303
      END
*** subroutine inptr goes here ***
      SUBROUTINE INPTR
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      REAL LAMDA
      INTEGER PTR
      COMMON/DC/SAVE(8,6),NSAVE
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      CHARACTER*56 DATAID
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      CHARACTER SYMB(8,20)*1,SPG(20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/SPG/NSP(2),NCONT(10),FILL(3)
      COMMON/BLNK1/NJNK(22),FILL2(751)
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*5 DATE
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/CELLX/AA,B,C,ALPHA,BETA,GAMMA,AL(3,3)
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
***vax***mod
      common/vax/ lvax
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      character ssgrp*1,qmodbc*20,qmodac*10
      logical lvax,lqmod
***vax***mod
      DIMENSION XRYZ(5),BACK(6),FBACK(6),MLTT(IRS)
      EQUIVALENCE (MLTT(1),FF(1)),(GLB(1),ZER),(GLB(2),BACK(1))
      EQUIVALENCE (GLB(8),GAM1),(GLB(9),GAM2)
      EQUIVALENCE (GLB(10),DISP),(GLB(11),TRANSP)
      EQUIVALENCE (AGLB(1),FLGZER),(AGLB(2),FBACK(1))
      EQUIVALENCE (AGLB(8),FLGAM1),(AGLB(9),FLGAM2)
      EQUIVALENCE (AGLB(10),FLDISP),(AGLB(11),FLTRNS)
      DATA XRYZ(1),XRYZ(2),XRYZ(3),XRYZ(4),XRYZ(5)
     * /2.28962,1.93597,1.54051,0.70926,0.556363/
***vax get filenames and open the files
      if(lvax)call setio
***vax
      READ(5,1,END=99999)TITLE
1001  FORMAT(1X,A70)
1     FORMAT(BZ,A70)
      READ(5,2,END=99999)JOBTYP,NPROF,NPHASE,NBCKGD,NEXCRG,NSCAT,INSTRM
     *                   ,IPREF
2     FORMAT(BZ,9I4)
      IF(NPHASE.EQ.0)NPHASE=1
      INSTRM=INSTRM+1
      JOBTYP=JOBTYP+1
      NPROF=NPROF+1
      WRITE(6,3)
3     FORMAT(1HN,/,'1RIETVELD ANALYSIS PROGRAM VERSION DBWS-9006,
     * RELEASE 21.11.90')
      WRITE(6,1001)TITLE

      WRITE(*,3)
      WRITE(*,1001)TITLE

      IF(JOBTYP.EQ.1)WRITE(6,4)
4     FORMAT(15H FOR X-RAY DATA )
      IF(JOBTYP.EQ.1.AND.INSTRM.EQ.2) WRITE (6,9490)
9490  FORMAT (40H COLLECTED IN SYNCHROTRON AT NSLS OR SRS)
      IF(JOBTYP.EQ.2)WRITE(6,5)
      IF(JOBTYP.EQ.2.AND.INSTRM.EQ.2) WRITE (6,9493)
9493  FORMAT(1X,37H VARYING NO. OF COUNTERS AT EACH STEP )
      IF(JOBTYP.EQ.3)WRITE(6,6)
6     FORMAT(25H PATTERN CALCULATION,XRAY  )
      IF(JOBTYP.EQ.4)WRITE(6,7)
7     FORMAT(28H PATTERN CALCULATION,NEUTRON  )
      IF(JOBTYP.LT.1.OR.JOBTYP.GT.4)STOP 7777
5     FORMAT(43H FOR NEUTRON DATA, NUCLEAR INTENSITIES ONLY )
      WRITE(6,9)NPHASE,NEXCRG,NSCAT
9     FORMAT(19H NUMBER OF PHASES=  ,I4,/,
     * 29H NUMBER OF EXCLUDED REGIONS=  ,I4,/,
     *  28H NUMBER OF SCATTERING SETS=  ,I4)
      IF(NBCKGD-1)110,111,112
110   WRITE(6,10)
10    FORMAT(27H BACKGROUND TO BE REFINED   )
      GOTO 113
111   WRITE(6,11)
11    FORMAT(37H BACKGROUND DATA TO BE READ FROM FILE )
      GOTO 113
112   WRITE(6,12)NBCKGD
12    FORMAT(39H BACKGROUND CORRECTION BY INTERPOLATION  ,
     * 12HBETWEEN THE  ,I4,12HPOINTS GIVEN )
C113   WRITE(6,13) NPROF-1
C13    FORMAT(5H THE  ,I4,32HTH PROFILE FUNCTION WAS SELECTED )
113   CONTINUE
      IF(NPROF-1.EQ.0) THEN
       WRITE(6,14001) NPROF-1
14001  FORMAT (' GAUSSIAN PROFILE, NPROF = ',I4)
       ELSE IF(NPROF-1.EQ.1) THEN
       WRITE(6,14002)NPROF-1
14002  FORMAT (' LORENTZIAN (CAUCHY) PROFILE , NPROF = ',I4)
       ELSE IF(NPROF-1.EQ.2) THEN
       WRITE(6,14003) NPROF-1
14003  FORMAT       (' MOD 1 LORENTZIAN PROFILE , NPROF = ',I4)
       ELSE IF(NPROF-1.EQ.3) THEN
       WRITE(6,14004) NPROF-1
14004  FORMAT (' MOD 2 LORENTZIAN PROFILE , NPROF = ',I4)
       ELSE IF(NPROF-1.EQ.4) THEN
       WRITE(6,14005) NPROF-1
14005  FORMAT (' THIS CHOICE NOT AVAILABLE ',I4)
       STOP
       ELSE IF(NPROF-1.EQ.5) THEN
       WRITE(6,14006) NPROF-1
14006  FORMAT (' PSEUDO-VOIGT (PV) PROFILE , NPROF = ',I4)
       ELSE IF(NPROF-1.EQ.6) THEN
       WRITE(6,14007) NPROF-1
14007  FORMAT (' PEARSON VII PROFILE , NPROF = ',I4)
       ELSE IF(NPROF-1.EQ.7) THEN
       WRITE(6,14008)NPROF-1
14008  FORMAT (' THOMPSON-COX-HASTINGS (PV) PROFILE , NPROF = ',I4)
      END IF

      IF (IPREF.EQ.0) THEN
         WRITE(6,7445)
      ELSE
         WRITE(6,7446)
      ENDIF
7445  FORMAT (1X,'IPREF=0, UDA-RIETVELD PREFERRED ORIENTATION FUNCTION')
7446  FORMAT(1X,'IPREF=1,MARCH-DOLLASE PREFERRED ORIENTATION FUNCTION')



      READ(5,14,END=99999)IOT,IPL,IPC,MAT,NXT,LST1,LST2,LST3,IPL1,IPL2
     * ,IPLST
14    FORMAT(BZ,11I1)
      IF(IOT.NE.0)WRITE(6,15)
15    FORMAT(46H OUTPUT OBSERVED AND CALCULATED INTENSITIES ON,
     * 11H LAST CYCLE )
      IF(IPL.NE.0)WRITE(6,16)
16    FORMAT(27H GENERATE LINE PRINTER PLOT )
***vax modification
      if(lvax)then
        IF(IPL2.NE.0)WRITE(6,117)
        ipl2 = 0
      else
        IF(IPL2.NE.0)WRITE(6,17)
      endif
17    FORMAT(22H GENERATE CALCOMP PLOT )
117   FORMAT(' CALCOMP PLOT NOT AVAILABLE')
***vax
      IF(IPLST.EQ.1)WRITE(6,717)
717   FORMAT(24H GENERATE PARAMETER LIST )
      IF(IPLST.EQ.2)WRITE(6,718)
718   FORMAT(24H GENERATE PARAMETER LIST,/,
     !' GENERATE PARAMETERS AND STD.DEV. IN FINAL CYCLE FOR DATA BASE')
      IF(IPC.NE.0)WRITE(6,18)
18    FORMAT(25H OUTPUT STRUCTURE FACTORS )
      IF(MAT.NE.0.AND.JOBTYP.LT.3)WRITE(6,19)
19    FORMAT(26H OUTPUT CORRELATION MATRIX )
      IF(NXT.NE.0.AND.JOBTYP.LT.3)WRITE(6,20)
20    FORMAT(24H GENERATE NEW INPUT FILE )
      IF(LST1.NE.0)WRITE(6,21)
21    FORMAT(22H PRINT REFLECTION LIST )
      IF(NPHASE.EQ.1)LST3=0
      IF(LST3.NE.0)WRITE(6,8)
8     FORMAT(29H PRINT MERGED REFLECTION LIST     )
      IF(LST2.NE.0)WRITE(6,22)
22    FORMAT(21H PRINT CORRECTED DATA )
      READ(5,23,END=99999)LAMDA,RATIO(2),BKPOS,WDT,CTHM,TMV,RLIM
23    FORMAT(BZ,8F8.0)
      WRITE(6,24)LAMDA
24    FORMAT(14H WAVELENGTHS=  ,2F8.4)
      RATIO(1)=1.
      WRITE(6,223)RATIO(2)
223   FORMAT(23H ALPHA2:ALPHA1 RATIO =  ,F8.4)
      DO 109 IX=1,5
        IF(LAMDA(1)+0.1.GT.XRYZ(IX))GOTO 119
109     CONTINUE
119   IXRAY=IX
      WRITE(6,26) WDT
26    FORMAT(23H BASE OF PEAK = 2.0*HW*,F8.2)
      WRITE(6,27)CTHM
27    FORMAT(27H MONOCHROMATOR CORRECTION =,F8.4)
      WRITE(6,28)TMV
28    FORMAT(28H ABSORPTION CORRECTION=-0.1*,F8.4,11H*SIN 2THETA)
      WRITE(6,29)RLIM
29    FORMAT(43H ASYMMETRY CORRECTION FOR ANGLES LESS THAN ,F8.3,
     * 8H DEGREES )
      READ(5,30,END=99999)MCYCLE,EPS,RELAX,THMIN,STEP,THMAX
30    FORMAT(BZ,1I4,5F4.0,3F8.0)
      IF(JOBTYP.GT.2)MCYCLE=1
      ICYRUN = MCYCLE
      WRITE(6,31)MCYCLE
31    FORMAT(20H NUMBER OF CYCLES =  ,I4)
      WRITE(6,32)RELAX
32    FORMAT(19H RELAXATION FACTORS,/,17H FOR COORDINATES=,F5.2,
     * /,36H FOR ANISOTRPIC TEMPERATURE FACTORS= ,F5.2,/,
     *  26H FOR HALFWIDTH PARAMETERS= ,F5.2,/,
     *   23H FOR LATTICE CONSTANTS= ,F5.2)
      WRITE(6,33)EPS
33    FORMAT(11H EPS-VALUE=,F6.1)
      IF(NBCKGD.LT.2)GOTO 120
      READ(5,34,END=99999)(POS(I),BCK(I),I=1,NBCKGD)
34    FORMAT(BZ,2F8.2)
      WRITE(6,35)(POS(I),BCK(I),I=1,NBCKGD)
35    FORMAT(12H BACKGROUND ,/,9H POSITION,4X,9HINTENSITY,/,
     * 20(2F9.4,/))
120   IF(NEXCRG.LE.0)GOTO 122
      READ(5,34,END=99999)(ALOW(I),AHIGH(I),I=1,NEXCRG)
      WRITE(6,37)(ALOW(I),AHIGH(I),I=1,NEXCRG)
37    FORMAT(18H EXCLUDED REGIONS /5H FROM,5X,2HTO/,20(2F9.4,/))
122   IF(NSCAT.LE.0)GOTO 124
      DO 125 I=1,NSCAT
        READ(5,38,END=99999)NAM(I),DFP(I),DFPP(I)
38      FORMAT(BZ,A4,2F8.0)
        IF(JOBTYP.EQ.2.OR.JOBTYP.EQ.4)GOTO 125
        K=0
126     READ(5,39,END=99999)(AC(J,I),J=1,9)
39      FORMAT(BZ,9F8.0)
        IF(AC(1,I).EQ.-100.)CALL COEF(I,K)
        IF(AC(3,I).NE.0.)GOTO 125
        K=K+1
        POSI(K)=AC(1,I)
        SCAT(K)=AC(2,I)
        IF(K.LE.29)GOTO126
        WRITE(6,40)
40      FORMAT(34H TOO MANY SCATTERING TABLE ENTRIES )
        STOP 7700
125     CONTINUE
      IF(JOBTYP.EQ.1.OR.JOBTYP.EQ.3)GOTO 129
      WRITE(6,422)
422   FORMAT(19H SCATTERING LENGTHS)
      WRITE(6,423)(NAM(I),DFP(I),I=1,NSCAT)
423   FORMAT(5H FOR ,A4,5H     ,F10.6)
      DO 424 I=1,NSCAT
        DO 425 J=1,9
425       AC(J,I)=0.
424     DFPP(I)=0.
      GOTO 124
129   WRITE(6,42)
42    FORMAT(12H FORMFACTORS )
      WRITE(6,41)(NAM(I),DFP(I),DFPP(I),(AC(J,I),J=1,9),I=1,NSCAT)
41    FORMAT(5H FOR ,A4,5H DFP=,F10.6,6H DFPP=,F10.6,/,
     * 14H COEFFICIENTS= ,9F10.6)
124   CONTINUE
      READ(5,43,END=99999)MAXS
43    FORMAT(BZ,I8)
C     CHECK DIMENSIONING FOR SOME EQUIVALENCED ARRAYS
      IF (IDSZ.LT.MSZ*MAXS) THEN
        WRITE (6,7989) IDSZ, MSZ,MAXS
        WRITE (7,7989) IDSZ, MSZ,MAXS
7989    FORMAT ('CHANGE IDSZ OR MSZ SO THAT IDSZ IS EQUAL TO OR GREATER'
     *   , ' THAN MSZ*MAXS',/,
     *        'IDSZ, MAXIMUM NO. OF DATA POINTS = ',I6,/,
     *           'MSZ,  MATRIX SIZE                = ',I6,/,
     *              'MAXS, NO. OF PARAMETERS VARIED   = ',I6,/,
     *                 '*** JUST A DIMENSIONING ERROR ***'/)
        STOP 'IDSZ IS LESS THAN MSZ*MAXS'
      END IF
C
      IF(JOBTYP.GT.2)MAXS=0
      WRITE(6,44)MAXS
44    FORMAT(29H NUMBER OF PARAMETERS VARIED= ,I5)
      READ(5,45,END=99999)ZER,FLGZER,GAM2,FLGAM2
     *                    ,DISP,FLDISP,TRANSP,FLTRNS
45    FORMAT(BZ,2F8.0,16X,6F8.0)
      WRITE(6,46)ZER,FLGZER
46    FORMAT(32H GLOBAL PARAMETERS AND CODEWORDS ,/,
     * 11H ZEROPOINT= ,2F8.2)
      IF(NBCKGD.NE.0)GOTO 49
      READ(5,51,END=99999)BACK,FBACK
51    FORMAT(BZ,6G12.6)
      WRITE(6,52)BKPOS,BACK,FBACK
52    FORMAT(36H BACKGROUND PARAMETERS AND CODEWORDS,/
     * ' ORIGIN OF BACKGROUND POLYNOMIAL AT TWO-THETA = ',F8.3,'DEGREES'
     *   ,/,6G12.6,/,6F12.2)
49    IF(NPROF.EQ.5)WRITE(6,461)GAM1,FLGAM1,GAM2,FLGAM2
461   FORMAT(10H SKEWNESS=,2F8.2,/,8H EXCESS=,2F8.2)
C     IF(NPROF.EQ.6)WRITE(6,462)GAM1,FLGAM1
C 462 FORMAT(6H  ETA=,2F8.2)
C     IF(NPROF.EQ.7)WRITE(6,463)GAM1,FLGAM1
C 463 FORMAT(11H PEARSON-M=,2F8.2)
      WRITE (6,7100) DISP,FLDISP,TRANSP,FLTRNS
7100  FORMAT (1X,'DISPLACEMENT PEAKSHIFT PARAMETER AND CODEWORD',2F8.2
     * ,/,' TRANSPARENCY PEAKSHIFT PARAMETER AND CODEWORD',2F8.2)
      IF(JOBTYP.GT.2)GOTO 483
      IF(JOBTYP.EQ.1.AND.INSTRM.EQ.2) GOTO 501
      IF(JOBTYP.EQ.2.AND.INSTRM.EQ.2) GOTO 601
      READ(4,471,END=99998)THMIN,STEP,THMAX,DATAID
471   FORMAT(BZ,3F8.2,A56)
      WRITE (6,7967) DATAID
7967  FORMAT (5X,'DATA ID ',A56)
      NPTS=(THMAX-THMIN)/STEP+1.5
      IF (NPTS.GT.IDSZ) THEN
        WRITE(6,1000) IDSZ,NPTS
        WRITE (7,1000) IDSZ,NPTS
1000    FORMAT(1X,'PROGRAM CAN HANDLE ',I5,'POINTS',/,
     *      1X,I5,' POINTS WERE INPUT',/,
     *        ' INCREASE IDSZ IN PARAMETER STATEMENT')
        STOP ' TOO MANY DATA POINTS '
      ENDIF
      READ(4,472,END=99998)(Y(I),I=1,NPTS)
472   FORMAT(BZ,8(F7.0,1X))
      DO 4484 I=1,NPTS
4484    VAR(I) = Y(I)
      GOTO 484
C
C       READ DATA FROM SYNCHROTRON SOURCE AND CORRECT DATA FOR DEAD TIME,
C      CALCULATE VARIANCE FOR EACH OF THE DATA POINTS
C     DATE IS OCT85,FEB86,AUG86,SRS83,SRS91
C     NRANGE IS THE NO OF BLOCKS IN WHICH THE DATA ARE GIVEN
C     OFSTI0 - DARK BEAM CURRENT, READING WITH NO ELECTRONS IN THE CHAMBER
C     OFSTI1 - DETECTOR DARK BEAM CURRENT
C     CHMBRI - ALL CURRENTS ARE  NORMALISED TO CHMBRI
501   READ (4,796) DATE,DATAID
796   FORMAT(A5,A56)
      WRITE (6,7967) DATAID
      READ (4,502,END=99998) NRANGE,CHMBRI,TAUK
502   FORMAT (BZ,I8, F8.0,G10.0)
C
C     NPTS IS THE COUNTER FOR TOTAL NO OF POINTS IN ALL THE RANGES
      NPTS = 0
      DO 530 J=1,NRANGE
C     READ INFORMATION ABOUT EACH RANGE
        READ (4,500,END=99998) ANGMIN,STEP,ANGMAX,STPTIM,OFSTI0,OFSTI1
500     FORMAT (BZ,6F8.0)
C
        IPTS= (ANGMAX-ANGMIN)/STEP +1.5
C     FIND MAXIMUM AND MINIMUM TWO THETA IN ALL RANGES
        IF (J.EQ.1) THMIN = ANGMIN
        IF (J.EQ.NRANGE) THMAX = ANGMAX
C
        IF (J.GT.1) THEN
          READ (4,510)
          IPTS = IPTS - 1
        END IF
        IF (NPTS+IPTS.GT.IDSZ) THEN
          WRITE(6,1000) IDSZ,NPTS+IPTS
          WRITE (7,1000) IDSZ,NPTS+IPTS
          STOP ' TOO MANY DATA POINTS '
        ENDIF
C     VAR(I) IS USED FOR TWO QUANTITIES, JUST TO SAVE SOME SPACE.
        IF (DATE.EQ.'OCT85') THEN
          READ (4,510,END=99998) (Y(I+NPTS),VAR(I+NPTS),I=1,IPTS)
        ELSE IF (DATE.EQ.'FEB86') THEN
          READ (4,511,END=99998) (Y(I+NPTS),VAR(I+NPTS),I=1,IPTS)
        ELSE IF (DATE.EQ.'AUG86') THEN
          READ (4,512,END=99998) (VAR(I+NPTS),Y(I+NPTS),I=1,IPTS)
        ELSE IF (DATE.EQ.'SRS83') THEN
          READ (4,513,END=99998) (VAR(I+NPTS),Y(I+NPTS),I=1,IPTS)
        ELSE IF (DATE.EQ.'SRS91') THEN
          READ (4,514,END=99998) (VAR(I+NPTS),Y(I+NPTS),I=1,IPTS)
        ELSE
          WRITE (6,513)
        END IF
510     FORMAT (BZ,24X,F7.0,1X,F7.0)
C     USE THIS FOR DATA TAKEN IN FEB 86
511     FORMAT (BZ,24X,F7.0,1X,F7.0)
C     USE THIS FOR DATA TAKEN IN AUG 86
512     FORMAT (BZ,51X,F10.0,1X,F10.0)
C     USE THIS FOR DATA TAKEN ON THE SRS AT 8.3 IN FALL 1989
513     FORMAT (BZ,37X,F9.0,1X,F9.0)
C     USE THIS FOR DATA TAKEN ON THE SRS AT 9.1 IN FALL 1989
514     FORMAT (BZ,29X,F9.0,10X,F9.0)
515     FORMAT (5X,'WHEN AND WHERE WERE THESE DATA TAKEN. OCT85,FEB86,AUG86,
     *  SRS83,SRS91')
C     TAUK = 2.4621E-6
        DO 520 I=NPTS+1,IPTS+NPTS
          Y(I) = Y(I)/STPTIM
          FLEET1 = VAR(I)-OFSTI0
          FLEET2= FLEET1/CHMBRI
          FLEET2= (FLEET2*STPTIM*(1-TAUK*Y(I)))**2.
          VAR(I) = (STPTIM*Y(I))/FLEET2
          Y(I) = (Y(I)/(1-TAUK*Y(I))-OFSTI1)*CHMBRI/FLEET1
          IF (ABS(Y(I)).LT.0.01) Y(I)=1.
520       CONTINUE
530     NPTS=NPTS+IPTS
      GOTO 484
C       ENDS SYNCHROTRON DATA MODIFICATION
C     BEGIN VARIANCE CALCULATION FOR VARYING NO. OF COUNTERS AT EACH STEP
601   READ (4,471,END=99998) THMIN,STEP,THMAX,DATAID
      WRITE (6,7967) DATAID
      NPTS = (THMAX-THMIN)/STEP+1.5
      IF (NPTS.GT.IDSZ) THEN
        WRITE(6,1000) IDSZ,NPTS
        WRITE (7,1000) IDSZ,NPTS
        STOP ' TOO MANY DATA POINTS '
      ENDIF
      READ (4,602,END=99998) (VAR(I),Y(I),I=1,NPTS)
602   FORMAT (10(F2.0,F6.0))
      DO 603 I=1,NPTS
603     VAR(I)=Y(I)/VAR(I)
      GO TO 484
C
483   NPTS=(THMAX-THMIN)/STEP+1.5
      IF (NPTS.GT.IDSZ) THEN
        WRITE(6,1000) IDSZ,NPTS
        WRITE (7,1000) IDSZ,NPTS
        STOP ' TOO MANY DATA POINTS '
      ENDIF
484   IF(NBCKGD-1)474,475,476
474   TH=THMIN-STEP
      DO 473 I=1,NPTS
        TH=TH+STEP
        THX=TH/BKPOS-1.
        BK(I)=BACK(1)
        DO 473 J=2,6
473       BK(I)=BK(I)+BACK(J)*THX**(J-1)
      GOTO 477
475   READ(3,472,END=99997)(BK(I),I=1,NPTS)
      GOTO 477
476   DIFB=POS(1)-THMIN
      IF(DIFB)4760,4761,4761
4761  NBX=DIFB/STEP+2.5
      DO 4762 I=1,NBX
4762    BK(I)=BCK(1)
      NXX=1
      GOTO 4764
4760  NBX=(POS(2)-THMIN)/STEP+1.5
      BK(1)=BCK(1)-DIFB/(POS(2)-POS(1))*(BCK(2)-BCK(1))
      BSTEP=STEP/(POS(2)-POS(1))*(BCK(2)-BCK(1))
      DO 4763 I=2,NBX
4763    BK(I)=BK(I-1)+BSTEP
      NXX=2
4764  NBC=NBCKGD-1
      IF(POS(NBCKGD).GE.THMAX)GOTO 4767
      POS(NBCKGD+1)=THMAX
      BCK(NBCKGD+1)=BCK(NBCKGD)
      NBC=NBC+1
4767  DO 4765 J=NXX,NBC
        BSTEP=STEP*(BCK(J+1)-BCK(J))/(POS(J+1)-POS(J))
        NINC=(POS(J+1)-POS(J))/STEP+1.5
        N2X=MIN0(NPTS,NBX+NINC)
        DO 4766 I=NBX,N2X
4766      BK(I)=BK(I-1)+BSTEP
        NBX=N2X
        IF(NBX.EQ.NPTS)GOTO 477
4765    CONTINUE
477   CONTINUE
      DO 4100 K=1,NPHASE
4100    IC(K)=0
      DO 81 K=1,NPHASE
        READ(5,465,END=99999)PHSNM(K)
465     FORMAT(BZ,A70)
        WRITE(6,47)K,PHSNM(K)
47      FORMAT(7H1PHASE  ,I2,/,1X,A70)
        READ(5,48,END=99999)NATOM(K),NEQC(K),NINEQC(K),(PREF(K,I),I=1,3)
        N=NATOM(K)
        WRITE(6,480)N,NEQC(K),NINEQC(K),(PREF(K,I),I=1,3)
480     FORMAT(18H NUMBER OF ATOMS= ,I4,/,20H NUMBER OF EQUALITY ,
     *     13HCONSTRAINTS= ,I4,34H NUMBER OF INEQUALITY CONSTRAINTS= ,I4
     *   ,    31H PREFERRED ORIENTATION VECTOR=  ,3F8.4)
48      FORMAT(BZ,3I4,3F4.0)
        READ(5,460,END=99999)(SYMB(K,I),I=1,20)
460     FORMAT(BZ,20A1)
***mod if mod struc then get 3d space group out of superspace group***
***    also indicate if modulated phase or not ***********************
        if(symb(k,2).eq.':')lqmod(k) = .true.
        if(lqmod(k))then
          do i=1,20
            ssgrp(k,i) = ' '
            spg(i) = ' '
          enddo
          ssgrp(k,1) = symb(k,1)
          ssgrp(k,2) = ' '
          jq = 2
          do i=3,20
            if(symb(k,i).eq.':')goto 134
            spg(i-2) = symb(k,i)
          enddo
134       spg(i-2) = ' '
          do j=i+1,20
            jq = jq + 1
            ssgrp(k,jq) = symb(k,j)
          enddo
*          write(*,132)(symb(k,j),j=1,20),(spg(j),j=1,20),
*     *      (ssgrp(k,j),j=1,20)
*132       format(' A phase with a modulated structure has been found',/,
*     *    ' The Superspace group    ',20a1,' has been separated into',/,
*     *    ' the basis space group   ',20a1,' and',/,
*     *    ' the extended operations ',20a1)      
        else
          DO 135 I=1,20
135         SPG(I)=SYMB(K,I)
        endif
        CALL SPGP(SPG)
        if(lqmod(k))call ssgroup(k)
*        if(lqmod(k))write(*,136)(qmodrc(k,i),i=1,3)
*136     format(' The rational coefficients of the modulation vector',/
*     *  ,' are:',3f6.3)
***mod
C-----READ AND PRINT FOR EACH ATOM
        IOF=0
        IF(K.GT.1) THEN
          DO 4325 IIPHAS=2,K
4325        IOF = IOF + NATOM(IIPHAS-1)
        END IF
        WRITE(6,57)
***mod
        if(lqmod(k))then
          READ(5,665,END=99999)(ATEXT(I+IOF),NTYP(I+IOF),
     *      (XL(I+IOF,J),J=1, 5), (A(I+IOF,J),J=1, 5),
     *         (XL(I+IOF,J),J=6,11), (A(I+IOF,J),J=6,11),
     *            (xl(i+iof,j),j=12,17), (a(i+iof,j),j=12,17),
     *               I=1,N)
        else
          READ(5,65,END=99999)(ATEXT(I+IOF),NTYP(I+IOF),
     *      (XL(I+IOF,J),J=1, 5), (A(I+IOF,J),J=1, 5),
     *         (XL(I+IOF,J),J=6,11), (A(I+IOF,J),J=6,11),
     *               I=1,N)
        endif
665     FORMAT(BZ,2A4,8X,5F8.5,/,16X,5F8.2,/,6F8.5,/,6F8.2,/
     *   ,6F8.5,/,6F8.2)
65      FORMAT(BZ,2A4,8X,5F8.5,/,16X,5F8.2,/,6F8.5,/,6F8.2)
        if(lqmod(k))then
          WRITE(6,171)(ATEXT(I+IOF),NTYP(I+IOF),
     *      (XL(I+IOF,J),J=1,17),I=1,N)
        else
          WRITE(6,170)(ATEXT(I+IOF),NTYP(I+IOF),
     *      (XL(I+IOF,J),J=1,11),I=1,N)
        endif
170     FORMAT(1X,A4,1X,A4,12X,5F10.5/22X,6F10.5)
171     FORMAT(1X,A4,1X,A4,12X,5F10.5/22X,6F10.5/22X,6F10.5)
        if(lqmod(k))read(5,172)(qmodic(k,j),j=1,3)
172     format(3f8.4)
***mod
        READ(5,50,END=99999) PAR(K,1),PAR(K,2),
     *                          APAR(K,1),APAR(K,2),
     * PAR(K,3),PAR(K, 4),PAR(K,5),PAR(K,20),PAR(K,15),PAR(K,16),
     * APAR(K,3),APAR(K, 4),APAR(K,5),APAR(K,20),APAR(K,15),APAR(K,16),
     *               (PAR(K,I),I=6,11), (APAR(K,I),I=6,11),
     *                  PAR(K,12),PAR(K,13),PAR(K,14),
     *                     APAR(K,12),APAR(K,13),APAR(K,14),
     *                  PAR(K,17),PAR(K,18),PAR(K,19),
     *                     APAR(K,17),APAR(K,18),APAR(K,19)
50      FORMAT(BZ,G8.2,F8.0,/,2F8.2,/6F8.0,/,6F8.2,/,6F8.0,/,6F8.2,
     *   /, 3F8.0,/,3F8.2,/,3G8.3,/3F8.2)
        IF(NPROF.NE.8) THEN
           PAR(K,20)=0.
          APAR(K,20)=0.
        END IF
***mod
        if(lqmod(k))write(6,173)(qmodic(k,j),j=1,3)
173     format(' The modulation vector irrational coefficients are:',/
     * ,10x,3f8.4)
***mod
       WRITE(6,66) PAR(K,1),PAR(K,2),
     * PAR(K,3),PAR(K, 4),PAR(K,5),PAR(K,20),PAR(K,15),PAR(K,16),
     *         (PAR(K,I),I=6,11),
     *   PAR(K,12),PAR(K,13),PAR(K,14),PAR(K,17),PAR(K,18),PAR(K,19)
66      FORMAT(' OVERALL SCALE FACTOR=',G12.6,/,
     *         ' OVERALL TEMP. FACTOR=',
     *           F12.5,/,' HALFWIDTH PARAMETERS=',6F12.4,/,' DIRECT CELL
     * PARAMETERS=',6F9.4,/,' PREFERRED ORIENTATION PARAMETERS=',2F7.3,/
     *   ,          ' ASYMMETRY PARAMETER=',F8.6,/,
     * ' MIXING PARAMETERS = ',3G8.3)
        AA=PAR(K,6)
        B=PAR(K,7)
        C=PAR(K,8)
        ALPHA=PAR(K,9)
        BETA=PAR(K,10)
        GAMMA=PAR(K,11)
        CALL CELL2
        DO 72 I=1,6
72        SAVE(K,I)=PAR(K,I+5)
        DO 73 I=1,3
73        PAR(K,I+5)=AL(I,I)
        PAR(K,9)=AL(2,3)
        PAR(K,10)=AL(1,3)
        PAR(K,11)=AL(1,2)
C-----PRINT CODEWORDS FOR ATOMIC PARAMETERS
***mod
        if(lqmod(k))then
          WRITE(6,821)
          WRITE(6,851)(ATEXT(I+IOF),(A(I+IOF,J),J=1,17),I=1,N)
        else
          WRITE(6,82)
          WRITE(6,85)(ATEXT(I+IOF),(A(I+IOF,J),J=1,11),I=1,N)
        endif
85      FORMAT(1X,A4,17X,5F10.2/22X,6F10.2)
851     FORMAT(1X,A4,17X,5F10.2/22X,6F10.2/22X,6F10.2)
***mod
        DO 83 I=1,N
          DO 84 J=1,17
            X=A(I+IOF,J)
            IYY=INT(ABS(X)/10.)
            IF(IYY.GT.MSZ) GO TO 99996
            LP(I+IOF,J)=IYY
84          A(I+IOF,J)=(ABS(X)-10.*FLOAT(IYY))*SIGN(1.,X)
83        CONTINUE
C-----PRINT CODEWORDS FOR PROFILE PARAMETERS
       WRITE(6,89)  APAR(K,1),APAR(K,2),
     * APAR(K,3),APAR(K, 4),APAR(K,5),APAR(K,20),APAR(K,15),APAR(K,16),
     *         (APAR(K,I),I=6,11),
     * APAR(K,12),APAR(K,13),APAR(K,14),APAR(K,17),APAR(K,18),APAR(K,19)
89      FORMAT(' OVERALL SCALE FACTOR=',F8.2,/,
     *        ' OVERALL TEMP. FACTOR=',F8.2,/,
     *           ' HALFWIDTH PARAMETERS=',6F8.2,/,
     *              ' CELL CONSTANTS=',6F8.2,/,
     *                 ' PREFERRED ORIENTATION PARAMETERS=',2F8.2,/,
     *                    ' ASYMMETRY PARAMETER=',F8.2,/,
     *      ' MIXING PARAMETERS = ',3F8.2,/)
        DO 87 I=1,20
          X=APAR(K,I)
          IYY=INT(ABS(X)/10.)
          LPAR(K,I)=IYY
87        APAR(K,I)=(ABS(X)-10.*FLOAT(IYY))*SIGN(1.,X)
151     CALL LOOKUP(K,NATOM(K),NSCAT,IXRAY,JOBTYP)
        U=PAR(K,3)
        V=PAR(K,4)
        W=PAR(K,5)
        ZZZ = PAR(K,20)
        IF (NPROF.EQ.8) THEN
          ULOR=PAR(K,15)
          VLOR=PAR(K,16)
        END IF
        if(lqmod(k))then
          CALL REFGENM(K,ZER,DISP,TRANSP,PREF,PAR(K,12))
        else
          CALL REFGEN(K,ZER,DISP,TRANSP,PREF,PAR(K,12))
        endif
        CALL RTMT(IPL1,K)
        ICY=1
        ICZ=0
        DO 4101 IIPHAS=1,K
4101      ICZ = ICZ + IC(IIPHAS)
        IF(K.GE.2) ICY=1+ICZ-IC(K)
        IF(LST1.NE.1)GOTO 479
        IXDEL=0
        DO 481 IXX=ICY,ICZ
          IX=IXX-IXDEL
          IRL=MOD(IREFS(IXX),256)-128
          IRK=MOD(IREFS(IXX)/256,256)-128
          IRH=MOD(IREFS(IXX)/256/256,256)-128
          IRC=MOD(IREFS(IXX)/256/256/256,8)
          if(lqmod(k))irm=mm(ixx)
          IF (NPROF.EQ.8) THEN
            if(lqmod(k))then
              IF(MOD(IX-1,60).EQ.0)WRITE(6,7483)
              WRITE(6,7471)IX,IRC,IRH,IRK,IRL,irm,MLTT(IXX),
     *         (REFS(IXX,JX),JX=1,3),HALFL(IXX),HALFG(IXX),GAM(IXX)
            else
              IF(MOD(IX-1,60).EQ.0)WRITE(6,7482)
              WRITE(6,7470)IX,IRC,IRH,IRK,IRL,MLTT(IXX),
     *         (REFS(IXX,JX),JX=1,3),HALFL(IXX),HALFG(IXX),GAM(IXX)
            endif
7482        FORMAT(38H1NO.  CODE    H   K   L  MULT   HW     ,
     *            16HPOSN      FACTOR,'       HWL       HWG     ETA '/)
7470        FORMAT(1X,2I4,3X,3I4,I6,2F8.3,F10.6,3F8.3)
7483        FORMAT(43H1 NO.  CODE    H   K   L   M   MULT   HW     ,
     *            16HPOSN      FACTOR,'       HWL       HWG     ETA '/)
7471        FORMAT(1X,2I4,3X,4I4,I6,2F8.3,1x,F10.6,3F8.3)
            GO TO 481
          END IF
          if(lqmod(k))then
            IF(MOD(IX-1,60).EQ.0)WRITE(6,1482)
            WRITE(6,1470)IX,IRC,IRH,IRK,IRL,irm,MLTT(IXX),
     *      (REFS(IXX,JX),JX=1,3)
          else
            IF(MOD(IX-1,60).EQ.0)WRITE(6,482)
            WRITE(6,470)IX,IRC,IRH,IRK,IRL,MLTT(IXX),
     *       (REFS(IXX,JX),JX=1,3)
          endif
482       FORMAT(38H1 NO.  CODE    H   K   L  MULT   HW     ,
     *         16HPOSN      FACTOR/)
1482       FORMAT(43H1 NO.  CODE    H   K   L   M   MULT   HW     ,
     *         16H  POSN    FACTOR/)
481     CONTINUE
470     FORMAT(1X,2I4,3X,3I4,I6,2F8.3,F10.6)
1470    FORMAT(1X,2I4,3X,4I4,I6,2F8.3,1x,F10.6)
479     DO 499 IX=ICY,ICZ
499       REFS(IX,3)=REFS(IX,3)*FLOAT(MLTT(IX))
81      CONTINUE
      DO 88 I=1,11
        X=AGLB(I)
        IYY=INT(ABS(X)/10.)
        LGLB(I)=IYY
88      AGLB(I)=(ABS(X)-10.*FLOAT(IYY))*SIGN(1.,X)
57    FORMAT(/25H ***INITIAL PARAMETERS***/23H ATOM  NTYP            ,6X
     * ,1HX,9X,1HY,9X,1HZ,9X,1HB,9X,1HN,/,27X,3HB11
     *  ,7X,3HB22,7X,3HB33,7X,3HB12,7X,3HB13,7X,3HB23/,27X,3HUxx
     *  ,7X,3HUxy,7X,3HUxz,7X,3HUyx,7X,3HUyy,7X,3HUyz)
67    FORMAT(BZ,4F8.2)
76    FORMAT(16H CELL CONSTANTS=,6F12.8)
77    FORMAT(BZ,2F8.4)
82    FORMAT(26H0***CODING OF VARIABLES***/5H ATOM,24X,1HX,9X,1HY,9X,1HZ
     * ,9X,1HB,9X,1HN,/28X,3HB11,7X,3HB22,7X,
     *   3HB33,7X,3HB12,7X,3HB13,7X,3HB23)
821   FORMAT(26H0***CODING OF VARIABLES***/5H ATOM,24X,1HX,9X,1HY,9X,1HZ
     * ,9X,1HB,9X,1HN,/28X,3HB11,7X,3HB22,7X,
     *   3HB33,7X,3HB12,7X,3HB13,7X,3HB23/28X,3HUxx,7X,3HUxy,7X,
     *   3HUxz,7X,3HUyx,7X,3HUyy,7X,3HUyz)
86    FORMAT(BZ,8F8.2)
      IF (JOBTYP.GT.2) RETURN
      NATOMS = 0
      DO 7150 K=1,NPHASE
7150    NATOMS = NATOMS + NATOM(K)
C     COUNT NO. OF USES OF SAME LOCATION IN NORMAL MATRIX
      DO 17200 I=1,MAXS
      LCOUNT = 0
        DO 17201 J =1,11
          IF (I.EQ.LGLB(J)) LCOUNT = LCOUNT + 1
17201      CONTINUE
        DO 17202 K=1,NPHASE
          DO 17202 J=1,20
            IF(I.EQ.LPAR(K,J))  LCOUNT = LCOUNT + 1
17202        CONTINUE
        DO 17203 K=1,NATOMS
          DO 17203 J=1,11
            IF(I.EQ.LP(K,J)) LCOUNT = LCOUNT + 1
17203        CONTINUE
      IF (LCOUNT.GE.2)   WRITE (6,17204) I, LCOUNT
17204 FORMAT ('0******* CODEWORD ',I3,' IS USED ',I3,' TIMES **')
17200    CONTINUE
C     END COUNT NO. OF USES OF SAME LOCATION IN NORMAL MATRIX
C     CHECK FOR HOLES IN THE NORMAL MATRIX
      ISTOP=0
      DO 7200 I=1,MAXS
C
        DO 7201 J =1,11
          IF (I.EQ.LGLB(J)) GO TO 7200
7201      CONTINUE
C
        DO 7202 K=1,NPHASE
          DO 7202 J=1,20
            IF(I.EQ.LPAR(K,J)) GO TO 7200
7202        CONTINUE
C
        DO 7203 K=1,NATOMS
          DO 7203 J=1,11
            IF(I.EQ.LP(K,J)) GO TO 7200
7203        CONTINUE
        WRITE (7,7204) I
        WRITE (6,7204) I
7204    FORMAT (5X,'***** HOLE IN THE MATRIX ******. ELEMENT ',I3,1X,
     *     'IN THE NORMAL MATRIX IS MISSING')
        ISTOP = 1
7200    CONTINUE
      IF (ISTOP.EQ.1) STOP 'HOLE IN THE MATRIX'
C     END CHECKING FOR HOLE IN THE NORMAL MATRIX
C     CHECK FOR NON-ZERO COUNTS AT ALL POINTS
      DO 5678 I=1,NPTS
        IF (VAR(I).LE.1.0E-6) THEN
          ANGLEP = THMIN + FLOAT(I-1) * STEP
          WRITE (6,5679) I,ANGLEP
          WRITE (7,5679) I,ANGLEP
5679      FORMAT (5X,'ZERO COUNTS AT STEP NO.',I7,'  AT TWO THETA ',F8.3
     *     )
          STOP '*** ZERO COUNTS IN DATA FILE AT A STEP ***'
        ENDIF
5678    CONTINUE
      RETURN
99999 STOP 'END OF FILE TAPE5'
99998 STOP 'END OF FILE TAPE4'
99997 STOP 'END OF FILE TAPE3'
99996 STOP 'MATRIX SIZE IS TOO SMALL'
      END
C--  SETIO - SETUP FILE I/O NAMES AND OPEN FILES
C-  From Rietveld version 890911 modification of DBW 3.2 by S. A. Howard
*   modified to facilitate multi user vax operation of DBWS-9006
*   by D. P. Matheis 1991
*
      SUBROUTINE SETIO
C-
C-  FILE NAMES
      CHARACTER*40   QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
      COMMON/QFILES/ QDCFFN,QPTNFN,QPLTFN,QBKGFN,QLSTFN,QNEWFN,QINSFN
C-                                                                   
      CHARACTER QFMT1S*36,QFMT2S*39,QFMT3S*33,QFMT4S*35,QFMT5S*37
      CHARACTER QFMT6S*34
      CHARACTER QFMT1N*2,QFMT2N*2,QFMT3N*2,QFMT4N*2,QFMT5N*2,QFMT6N*2
      CHARACTER QFILE1*40
      EQUIVALENCE ( QFMT1S(26:27), QFMT1N(1:2) )
      EQUIVALENCE ( QFMT2S(29:30), QFMT2N(1:2) )
      EQUIVALENCE ( QFMT3S(23:24), QFMT3N(1:2) )
      EQUIVALENCE ( QFMT4S(26:27), QFMT4N(1:2) )
      EQUIVALENCE ( QFMT5S(28:29), QFMT5N(1:2) )
      EQUIVALENCE ( QFMT6S(25:26), QFMT6N(1:2) )
      DATA QFMT1S/'('' Pattern file name <'',A##,''> ? '')'/
      DATA QFMT2S/'('' Background file name <'',A##,''> ? '')'/
      DATA QFMT3S/'('' Plot file name <'',A##,''> ? '')'/
      DATA QFMT4S/'('' Listing file name <'',A##,''> ? '')'/
      DATA QFMT5S/'('' New input file name <'',A##,''> ? '')'/
      DATA QFMT6S/'('' Status file name <'',A##,''> ? '')'/
      iotto = 6
C-
C-  GET THE NAME OF THE FILE CONTAINING THE CONTROL PARAMETERS
C-
1000  WRITE(IOTTO,1020)
1020  FORMAT(/,' Control file name <EXIT> ? ')
      READ(5,1030) QDCFFN
1030  FORMAT(A40)
      IF( QDCFFN.EQ.' ' .OR. QDCFFN.EQ.'/' ) THEN
        WRITE(IOTTO,1035)
1035    FORMAT(/,' -NO CONTROL FILE NAME; EXECUTION TERMINATED')
        STOP '-NO CONTROL FILE NAME; EXECUTION TERMINATED'
      ENDIF
C-
C-  DETERMINE FILE NAME POINTERS
1100  DO 1110 NEND=40,1,-1
1110  IF(QDCFFN(NEND:NEND).EQ.'.') GO TO 1120
      DO 1130 NEND=40,1,-1
1130  IF(QDCFFN(NEND:NEND).NE.' ') GO TO 1140
      STOP '--SETIO:  BLANK CONTROL FILE NAME; ABORT'
1140  NEND = NEND + 1
1120  NENDP3 = NEND + 3
C-
C-  OPEN THE CONTROL DATA FILE NOW
CVAX
      OPEN(UNIT=5,FILE=QDCFFN,STATUS='OLD',ERR=1040)
CVAX
      GO TO 2000
1040  WRITE(IOTTO,1045)
1045  FORMAT(' --SETIO: CONTROL FILE IS BUSY OR NOT THERE; ABORT.')
      STOP '--SETIO: CONTROL FILE IS BUSY OR NOT THERE; ABORT'
C-
C-  PATTERN FILE NAME
C-
2000  QPTNFN = QDCFFN
      QPTNFN(NEND:) = '.XDB'
      WRITE(QFMT1N,2010) NENDP3
2010  FORMAT(I2)
      WRITE(IOTTO,QFMT1S) QPTNFN(1:NENDP3)
      READ(*,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QPTNFN = QFILE1
C-
C-  BACKGROUND FILE NAME
C-
*3000  QBKGFN = QDCFFN
*      QBKGFN(NEND:) = '.BKG'
*      WRITE(QFMT2N,2010) NENDP3
*      WRITE(IOTTO,QFMT2S) QBKGFN(1:NENDP3)
*      READ(5,1030) QFILE1
*      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QBKGFN = QFILE1
C-
C-  PLOT FILE NAME
C-
4000  QPLTFN = QDCFFN
      QPLTFN(NEND:) = '.PLT'
      WRITE(QFMT3N,2010) NENDP3
      WRITE(IOTTO,QFMT3S) QPLTFN(1:NENDP3)
      READ(*,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QPLTFN = QFILE1
C-
C-  LISTING FILE NAME
C-
5000  qlstfn = qdcffn
      qlstfn(nend:) = '.lis'
      write(qfmt4n,2010) nendp3
      WRITE(IOTTO,qfmt4s)qlstfn(1:nendp3)
      write(iotto,5002)
5002  FORMAT(' Or type TERMINAL to list to screen.')
      READ(*,1030) qfile1
      if(qfile1(1:1).ne.' '.and.qfile1(1:1).ne.'/')qlstfn = qfile1
C-
C-  NEW CONTROL DATA FILE NAME
C-
6000  QNEWFN = QDCFFN
      QNEWFN(NEND:) = '.NEW'
      WRITE(QFMT5N,2010) NENDP3
      WRITE(IOTTO,QFMT5S) QNEWFN(1:NENDP3)
      READ(*,1030) QFILE1
      IF( QFILE1(1:1).NE.' ' .AND. QFILE1(1:1).NE.'/' ) QNEWFN = QFILE1
C-
C- OPEN THE LISTING FILE NOW
C-
CVAX
      IF(QLSTFN.NE.'TERMINAL'.and.qlstfn.ne.'terminal') THEN
        IOTTO = 6
        OPEN(UNIT=IOTTO,FILE=QLSTFN,STATUS='NEW',CARRIAGECONTROL='LIST',
     1       ERR=5010)
      ENDIF
CVAX
      GO TO 6001
5010  IOTTO = 6
      WRITE(IOTTO,5020)
5020  FORMAT(' --SETIO: UNABLE TO OPEN LISTING FILE; ABORT.')
      STOP '--SETIO: UNABLE TO OPEN LISTING FILE; ABORT'
C-
*
*     open the raw data (pattern) file
6001  open(unit=4,file=qptnfn,status='old',err=6010)
      goto 9000
6010  print*,' --SETIO: UNABLE TO OPEN PATTERN FILE; ABORT.'
      STOP '--SETIO: UNABLE TO OPEN PATTERN FILE; ABORT'
*
9000  RETURN
      END
*** subroutine calcul goes here ***
      SUBROUTINE CALCUL(NN)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      REAL LAMDA
      INTEGER PTR
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,SBX,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      COMMON/RTMTX/IVEC(8,192),MLT(8),ICET(8)
      COMMON/G4/TANN(NOV),DERSTO(NOV,MSZ)
      DIMENSION HNN(3),XI(14)
      DIMENSION DERIV(MSZ),SNX(NATS),SINTL(NOV),SA(NATS),SB(NATS)
      DIMENSION TEMP(NATS),SNEX(NATS),T(3),SUMAX(NATS,9),SUMBX(NATS,9)
      DIMENSION H(3),AL(3,3),SM(3,3)
      LOGICAL VERT,PAC
      PI=360./3.14159265359
      IPH=IREFS(NN)/256/256/256/8
      IOF=0
      IF(IPH.GT.1)THEN
      DO 4340 IIPHAS=2,IPH
4340  IOF=IOF + NATOM(IIPHAS-1)
      ENDIF
      IRL=MLT(IPH)
      N=NATOM(IPH)
      ICENT=ICET(IPH)
C-----ZEROIZE THE DERIVATIVES OF THIS REFLECTION W.R.T. TO PARAMETERS
      NX=0
      DO 4310 IIPHAS=1,NPHASE
4310    NX=NX+NATOM(IIPHAS)
      DO 12 I=1,MSZ
12      DERIV(I)=0.
      DO 21 I=1,NX
        DO 21 J=1,9
          SUMBX(I,J)=0.
21        SUMAX(I,J)=0.
      CV=0.
      DV=0.
      AV=0.
      BV=0.
      PAC=PAR(IPH,12).NE.0.0.OR.LPAR(IPH,12).NE.0
     * .OR.PAR(IPH,13).NE.0.0.OR.LPAR(IPH,13).NE.0
      DO 303 I=1,3
303     AL(I,I)=PAR(IPH,I+5)
      AL(2,3)=PAR(IPH,9)
      AL(1,3)=PAR(IPH,10)
      AL(1,2)=PAR(IPH,11)
      AH=PAR(IPH,3)
      BH=PAR(IPH,4)
      CH=PAR(IPH,5)
      IF (NPROF.EQ.8) THEN
        DH=PAR(IPH,20)
        AH2=PAR(IPH,15)
        BH2=PAR(IPH,16)
      END IF
      B1=PAR(IPH,12)
      B2=PAR(IPH,13)
      NM=MOD(NN,NOV)+1
      ICX=MOD(IREFS(NN)/256/256/256,8)
      SLABDA=LAMDA(ICX)*LAMDA(ICX)/4.
      N=NATOM(IPH)
      FF(NN)=0.
      PAKNN=0.
      PRECOR=1.
      TR=0.
      HNN(3)=MOD(IREFS(NN),256)-128
      HNN(2)=MOD(IREFS(NN)/256,256)-128
      HNN(1)=MOD(IREFS(NN)/256/256,256)-128
      DO 1 I=1,3
1       H(I)=HNN(I)
C-----CALCULATION OF TEMP.FACTOR,POSITION AND HALFWIDTH
      SS=0.
      DO 2 I=1,3
        DO 2 J=I,3
2         SS=AL(I,J)*HNN(I)*HNN(J)+SS
      IF(.NOT.PAC)GOTO 13
      TT=0.
      DO 16 I=1,3
        DO 16 J=I,3
16        TT=TT+AL(I,J)*PREF(IPH,I)*PREF(IPH,J)
      PAK=0.
      DO 33 I=1,3
        DO 33 J=I,3
33        PAK=AL(I,J)*(PREF(IPH,I)*HNN(J)+PREF(IPH,J)*HNN(I))/2.+PAK
      PAK=PAK*PAK/(TT*SS)
      PAKNN=1.57079633268**2
      IF(PAK.NE.0)PAKNN=ATAN(SQRT(ABS((1.-PAK)/PAK)))**2
      IF (IPREF.EQ.0) THEN
          PREXP=EXP(B1*PAKNN)
          PRECOR=B2+(1.-B2)*PREXP
      ELSE
          PREXP= B1*B1*PAK + (1.-PAK)/B1
          PRECOR=1./PREXP**1.5
      END IF
13    SINTL(NM)=SQRT(SS)
      SSNN=0.25*SS
      TAV=EXP(-2.*PAR(IPH,2)*SSNN)*PRECOR
      SINTH=SLABDA*SS
      COSTH=1.-SINTH
      TANTH=SQRT(SINTH/COSTH)
      TANN(NM)=TANTH
      REFS(NN,2)=ATAN(TANTH)*PI
      HALFG(NN) =     (AH*TANTH*TANTH+BH*TANTH+CH+DH/COSTH)
      IF (HALFG(NN).GT.0.) THEN
        HALFG(NN) = SQRT(HALFG(NN))
      ELSE
        WRITE (6,3456) REFS(NN,2),IPH
        WRITE (7,3456) REFS(NN,2),IPH
        STOP 'SQUARE OF FWHM IS NEGATIVE'
3456    FORMAT (3X,'SQUARE OF FWHM NEGATIVE AT TWO-THETA',F8.3,
     *     'FOR PHASE NO. ',I4)
      END IF
      IF (NPROF.EQ.8) THEN
        HALFL(NN) = AH2*TANTH+BH2*SQRT(1.+TANTH*TANTH)
        BB = (HALFG(NN)**5.+2.69269*HALFG(NN)**4.*HALFL(NN)+
     *     2.42843*HALFG(NN)**3.*HALFL(NN)**2.+
     *        4.47163*HALFG(NN)**2.*HALFL(NN)**3. +
     *           0.07842*HALFG(NN)*HALFL(NN)**4. + HALFL(NN)**5.)**0.2
        TLR = HALFL(NN)/BB
        GAM(NN) = 1.36603*TLR-0.47719*TLR*TLR+0.11116*TLR**3.
      ELSE
        BB = HALFG(NN)
      END IF
C     IF(LEGVAR(BB).EQ.-1)BB=STEP/4.
      TL=BB
      REFS(NN,1)=BB
      BB=BB*BB
C-----VERT=.TRUE. IF ASYMMETRY CORRECTION IS TO BE CALCULATED
      VERT=.FALSE.
      IF(REFS(NN,2).LE.RLIM)VERT=.TRUE.
C-----CALCULATION OF COS(H.X),SIN(H.X) AND TEMP. FACTOR FOR EACH ATOM
3     DO 8 I=1,N
        SNXI=0.
        SAI=0.
        SBI=0.
        DO 9 J=1,11
9         XI(J)=XL(I+IOF,J)
        DO 10 IR=1,IRL
          DO 301 J=1,3
            IV=IVEC(IPH,IR)/32768/32**(3-J)
            IV=MOD(IV,32)
            SM(J,1)=IV/9-1
            SM(J,2)=MOD(IV/3,3)-1
            SM(J,3)=MOD(IV,3)-1
301         T(J)=FLOAT(MOD(IVEC(IPH,IR)/32**(3-J),32)-16)/12.0
          X=0.
          DO 6 II=1,3
            YY=0.
            X=T(II)*HNN(II)+X
            DO 7 J=1,3
7             YY=SM(J,II)*HNN(J)+YY
6           H(II)=YY
          TR=X
          ARG=TR
          DO 11 J=1,3
11          ARG=H(J)*XI(J)+ARG
          ARG=6.28318530718*ARG
          ARG2=H(1)*H(1)*XI(6)+H(2)*H(2)*XI(7)+
     *        H(3)*H(3)*XI(8)+2.*H(1)*H(2)*XI(9)+2.*
     *              H(1)*H(3)*XI(10)+2.*H(2)*H(3)*XI(11)
          EXPARG=EXP(-ARG2)
          COSA=COS(ARG)*EXPARG
          SINA=SIN(ARG)*EXPARG
          SAI=SAI+COSA
          IF(ICENT.EQ.1)SBI=SINA+SBI
          DO 14 JJ=1,3
            SUMAX(I,JJ)=SUMAX(I,JJ)+H(JJ)*SINA
14          IF(ICENT.EQ.1)SUMBX(I,JJ)=SUMBX(I,JJ)+H(JJ)*COSA
          SUMAX(I,4)=SUMAX(I,4)+H(1)*H(1)*COSA
          SUMAX(I,5)=SUMAX(I,5)+H(2)*H(2)*COSA
          SUMAX(I,6)=SUMAX(I,6)+H(3)*H(3)*COSA
          SUMAX(I,7)=SUMAX(I,7)+H(1)*H(2)*COSA
          SUMAX(I,8)=SUMAX(I,8)+H(1)*H(3)*COSA
          SUMAX(I,9)=SUMAX(I,9)+H(2)*H(3)*COSA
          IF(ICENT.NE.1)GOTO 10
          SUMBX(I,4)=SUMBX(I,4)+H(1)*H(1)*SINA
          SUMBX(I,5)=SUMBX(I,5)+H(2)*H(2)*SINA
          SUMBX(I,6)=SUMBX(I,6)+H(3)*H(3)*SINA
          SUMBX(I,7)=SUMBX(I,7)+H(1)*H(2)*SINA
          SUMBX(I,8)=SUMBX(I,8)+H(1)*H(3)*SINA
          SUMBX(I,9)=SUMBX(I,9)+H(2)*H(3)*SINA
10        CONTINUE
        TEMP(I)=EXP(-XL(I+IOF,4)*SSNN)
        SA(I)=SAI
        SB(I)=SBI
        NI=PTR(I+IOF)
        BNI=DFPP(NI)
        FFX=DFP(NI)
        AC(10,NI)=0.
        DO 302 II=1,9,2
302       FFX=FFX+AC(II,NI)*EXP(-AC(II+1,NI)*SSNN)
        SNEXI=FFX*XL(I+IOF,5)*TEMP(I)
        SNXI=BNI*XL(I+IOF,5)*TEMP(I)
C-----CALCULATE A AND B OF F
        AV=SNEXI*SAI+AV
        BV=SNEXI*SBI+BV
        SNEX(I)=2.*SNEXI*TAV*RATIO(ICX)
        SNX(I)=2.*SNXI*TAV*RATIO(ICX)
        CV=CV+SNXI*SAI
        DV=DV+SNXI*SBI
8       CONTINUE
      FNN=RATIO(ICX)*(CV*CV+AV*AV+DV*DV+BV*BV)*TAV
120   FF(NN)=FNN
      IF(MAXS.EQ.0)RETURN
C-----CALCULATE DERIVATIVES
      DO 17 I=1,N
        SNEXI=SNEX(I)
        SNXI=SNX(I)
        SAI=SA(I)
        SBI=SB(I)
        DO 22 J=1,11
          K=LP(I+IOF,J)
          IF(K.EQ.0) GOTO22
          IF(J.GT.5) GOTO 221
          IF(J.GT.3)GOTO 29
          SUMA=SUMAX(I,J)
          SUMB=SUMBX(I,J)
          DER=-((AV*SUMA-BV*SUMB)*SNEXI+(CV*SUMA-DV*SUMB)*SNXI)*6.283185
     *     3071
          GOTO 26
29        IF(J.GT.4)GOTO 31
          DER=-((SAI*AV+SBI*BV)*SNEXI+(SAI*CV+SBI*DV)*SNXI)*SSNN
          GOTO 26
31        DER=((SAI*AV+SBI*BV)*SNEXI+(SAI*CV+SBI*DV)*SNXI)/XL(I+IOF,5)
          GOTO 26
221       SUMA=SUMAX(I,J-2)
          SUMB=SUMBX(I,J-2)
          DER=-((AV*SUMA+BV*SUMB)*SNEXI+(CV*SUMA+DV*SUMB)*SNXI)
          IF(J.GE.9)DER=2.*DER
26        DERIV(K) = SIGN(1.,A(I+IOF,J))*DER+DERIV(K)
22        CONTINUE
17      CONTINUE
C-----CALCULATE DERIVATIVES
      K=LPAR(IPH,12)
      IF (IPREF.EQ.0) THEN
        IF(K.NE.0)DERIV(K)=DERIV(K)+ PAKNN*(1.-B2)*PREXP
     *                      *FNN/PRECOR
      ELSE
        IF(K.NE.0)DERIV(K)=DERIV(K)-1.5/PREXP**2.5 *( 2.*B1*PAK -
     *                      (1.-PAK)/B1/B1 )*FNN/PRECOR
      ENDIF

      K=LPAR(IPH,13)
      IF (IPREF.EQ.0) THEN
        IF(K.NE.0)DERIV(K)=DERIV(K)+(1.-PREXP)*FNN/PRECOR
      ELSE
        IF (K.NE.0) THEN
           WRITE (6,7607)
           STOP
        ENDIF
      ENDIF
7607    FORMAT (1X,'G2 IS NOT A REFINABLE PARAMETER FOR IPREF = 1')
      K=LPAR(IPH,2)
      IF(K.NE.0)DERIV(K)=DERIV(K)-2.*SSNN*FNN
      K=LPAR(IPH,1)
      IF(K.NE.0)DERIV(K)=DERIV(K)+FNN/PAR(IPH,1)
C     DO 15 J=8,9
      K=LGLB(8)
      IF(K.NE.0.AND.(NPROF.EQ.6.OR.NPROF.EQ.7))DERIV(K)=DERIV(K)+FNN
      K=LGLB(9)
      IF(K.NE.0.AND.NPROF.EQ.5) DERIV(K)=DERIV(K)+FNN
C  15 CONTINUE
      SINTH=FNN*PI*SLABDA/(SQRT(SINTH*COSTH)*BB)
      SS=FNN/TL
      X=TANTH*TANTH
      IF (NPROF.EQ.8) GO TO 9211
      DO 78 J=3,5
        K=LPAR(IPH,J)
        IF(K.EQ.0)GOTO 78
        DERIV(K)=X*SS+DERIV(K)
78      X=X/TANTH
9211  CONTINUE
      IF (NPROF.EQ.8) THEN
        TL = REFS(NN,1)
        TLG = HALFG(NN)
        TLL = HALFL(NN)
        DHDHG = 0.2/TL**4.*(5.*TLG**4.+10.77076*TLG**3.*TLL+
     *        7.28529*TLG*TLG*TLL*TLL+8.94326*TLG*TLL**3.
     *         + 0.07842*TLL**4.)
        DHDHL = 0.2/TL**4.*(2.69269*TLG**4.+ 4.85686*TLG**3.*TLL
     *      +13.41489*TLG*TLG*TLL*TLL + 0.31368*TLG*TLL**3.+5.*TLL**4.)
        DO 9078 J=3,5
          K=LPAR(IPH,J)
          IF(K.EQ.0)GOTO 9078
          DERIV(K)=DHDHG*X*SS+DERIV(K)
9078      X=X/TANTH
        K=LPAR(IPH,20)
        IF  (K.NE.0) DERIV(K)=DHDHG*SS/COSTH  + DERIV(K)
        K = LPAR(IPH,15)
        IF (K.EQ.0) GO TO 9213
        DERIV(K) = 2.*FNN*DHDHL*TANTH + DERIV(K)
9213    CONTINUE
        K = LPAR(IPH,16)
        IF (K.EQ.0) GO TO 9214
        DERIV(K) = 2.*FNN*DHDHL/SQRT(COSTH) + DERIV(K)
9214    CONTINUE
      END IF
      K = LPAR(IPH,17)
      IF(K.NE.0.AND.(NPROF.EQ.6.OR.NPROF.EQ.7)) DERIV(K)=DERIV(K)+ FNN
      K = LPAR(IPH,18)
      IF(K.NE.0.AND.NPROF.EQ.6) DERIV(K)=DERIV(K)+ FNN * REFS(NN,2)
      IF(K.NE.0.AND.NPROF.EQ.7) DERIV(K)=DERIV(K)+ FNN / REFS(NN,2)
      K = LPAR(IPH,19)
      IF(K.NE.0.AND.NPROF.EQ.7)DERIV(K)=DERIV(K)+FNN/REFS(NN,2)
     !                                              /REFS(NN,2)
      K=LGLB(1)
      IF(K.NE.0)DERIV(K)=2.*FNN/BB+DERIV(K)
      K=LGLB(10)
      IF (K.NE.0) DERIV(K) = DERIV(K)+2.*FNN/BB*SQRT(COSTH)
      K=LGLB(11)
      IF (K.NE.0) DERIV(K) = DERIV(K)+2.*FNN/BB*SIN(REFS(NN,2)/57.2958)
      DO 79 J=1,6
        K=LPAR(IPH,J+5)
        IF(K.EQ.0)GOTO 79
        IF(J.LT.4)X=HNN(J)*HNN(J)
        IF(J.EQ.4)X=HNN(2)*HNN(3)
        IF(J.EQ.5)X=HNN(1)*HNN(3)
        IF(J.EQ.6)X=HNN(1)*HNN(2)
        DERIV(K)=X*SINTH+DERIV(K)
79      CONTINUE
      K=LPAR(IPH,14)
      IF((K.NE.0).AND.VERT)DERIV(K)=-FNN/TANTH+DERIV(K)
C-----STORE DERIVATIVES FOR LIMO REFLECTIONS AT A TIME
      DO 80 I=1,MAXS
80      DERSTO(NM,I)=DERIV(I)
48    RETURN
      END
      FUNCTION PROFIL(N,X)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/PRFX/DELT,TL,GAM1,GAM2,PRFDER,IPH
      COMMON /PVII/ TF1(8),TF2(8),TF4(8),TF6(8),TF8(8),TF9(8),C4(8)
C     PRFDER = -(D(PROFIL)/DX)/PROFIL
      GOTO(10,20,30,40,50,60,70,80),N
      STOP 'ILLEGAL PROFILE FUNCTION REQUEST'
10    PROFIL=.939437279*EXP(-2.772588722*X)
      PRFDER=2.772588722
      RETURN
20    PROFIL=.636619772/(1.+4.*X)
      PRFDER=4./(1.+4.*X)
      RETURN
30    PROFIL=.819449653/(1.+1.656854248*X)**2.
      PRFDER=3.313708496/(1.+1.656854248*X)
      RETURN
40    PROFIL=.766420937/(1.+2.349604208*X)**1.5
      PRFDER=3.5244063/(1.+2.349604208*X)
      RETURN
50    Y=2.*2.772588722*X
      Y1=SIGN(SQRT(Y),DELT)
      PROFIL=EXP(-.5*Y)*(1.+GAM1/6.*Y1*(Y-3.)+GAM2/24.*
     * (Y*(Y-6.)+3.)+(GAM1*GAM1/72.)*(Y*(Y*(Y-15.)+45.)-15.))
      PRFDER=EXP(-.5*Y)*(.5+GAM1/12.*Y1*(Y-6.+3./Y)+GAM2/48.*
     * (Y*(Y-8.)+9.)+GAM1*GAM1/144.*(Y*(Y*(Y-18.)+75.)-60.))/PROFIL
      PRFDER=2.*2.772588722*PRFDER
      RETURN
60    PROFIL=GAM1*.636619772/(1.+4.*X)+
     * (1-GAM1)*.939437279*EXP(-2.772588722*X)
      PRFDER=(GAM1*2.546479088/(1.+4.*X)**2+(1-GAM1)*2.6046732048*
     * EXP(-2.772588722*X))/PROFIL
      RETURN
70    PROFIL=C4(IPH)/(1.+4.*(2**(1./GAM1)-1)*X)**GAM1
      PRFDER=TF6(IPH)*GAM1/(1.+4.*(2**(1./GAM1)-1)*X)
      RETURN
80    PROFIL=GAM1*.636619772/(1.+4.*X)+
     * (1-GAM1)*.939437279*EXP(-2.772588722*X)
      PRFDER=(GAM1*2.546479088/(1.+4.*X)**2+(1-GAM1)*2.6046732048*
     * EXP(-2.772588722*X))/PROFIL
      RETURN
      END
      SUBROUTINE  PRSVII
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
C     CALCULATES THE COEFFICIENT C4 AND ITS DERIVATIVE WRT T FOR PHASE K
C     THIS SUBROUTINE OBTAINED FROM IMMIRZI'S CODE
C     RGD = GAMMA(T)/GAMMA(T-0.5)
C     DGD = D(RGD)/D(T)
C     COMMON/PRFX/DELT,TL,GAM1,GAM2,PRFDER,IPH
      COMMON/PRFX/DELT,TL,T,GAM2,PRFDER,IPH
      COMMON /PVII/ TF1(8),TF2(8),TF4(8),TF6(8),TF8(8),TF9(8),C4(8)
      DIMENSION  RGD(52),DGD(52)
      DATA  RGD/   .156535,  .183771,  .209926,  .235089,  .259339,
     1   .282749,  .305380,  .327289,  .348527,  .369141,  .389170,
     2   .408654,  .427625,  .446115,  .464153,  .481764,  .498972,
     3   .515799,  .532265,  .548390,  .564190,  .579680,  .594877,
     4   .609794,  .624443,  .638837,  .652986,  .666902,  .680594,
     5   .694071,  .707342,  .720415,  .733297,  .754996,  .758519,
     6   .770871,  .783059,  .795089,  .806966,  .818696,  .830282,
     7   .841731,  .853045,  .864230,  .875290,  .886227,  .897046,
     8   .907750,  .918344,  .928828,  .939207,  .949484/
      DATA  DGD/  1.390576, 1.334036, 1.282282, 1.234747, 1.190975,
     1  1.150537, 1.113079, 1.078304, 1.045950, 1.015831,  .987556,
     2   .961144,  .936314,  .913013,  .891052,  .870228,  .850726,
     3   .832193,  .814684,  .798032,  .782274,  .767112,  .752807,
     4   .739098,  .726022,  .713542,  .701621,  .690110,  .679232,
     5   .668690,  .658669,  .648871,  .639521,  .630580,  .621825,
     6   .613555,  .605434,  .597760,  .590086,  .582896,  .575967,
     7   .569075,  .562482,  .555962,  .549890,  .543743,  .538044,
     8   .532381,  .526905,  .521578,  .516400,  .511296/
      DATA  PIG/3.1415926/, AL2/0.6931472/
      IF (T.LT.0.6) THEN
      WRITE (6,2)  T
2     FORMAT (//,' UNACCEPTABLE T VALUE IN CALCULATING PEARSON VII'
     *,' FUNCTION ',F6.2,//)
      STOP
      END IF
      IT=IFIX(T-0.6)
      FT=T-FLOAT(IT)
      N1=(FT-0.6)/0.02+1.0001
      DG=DGD(N1)+(DGD(N1+1)-DGD(N1))*(FT-0.58-0.02*FLOAT(N1))/0.02
      RG=RGD(N1)+(RGD(N1+1)-RGD(N1))*(FT-0.58-0.02*FLOAT(N1))/0.02
      IF(IT.GT.0) THEN
      DO 4 I=1,IT
      FL1=FT+FLOAT(I-1)
      DG=DG*(FL1)/(FL1-0.5)-0.5*RG/(FL1-0.5)**2
4     RG=RG*FL1/(FL1-0.5)
      ENDIF
      TF1(IPH)=SQRT(2.0**(1.0/T)-1.0)
      C4(IPH)=2.0*RG*TF1(IPH)/SQRT(PIG)
      TF2(IPH)=AL2*2.0**(1.0/T)/(2.0*TF1(IPH)**2)
C     DC4DT(IPH)= 2./SQRT(PIG)*(TF1(IPH)*DG - RG*TF2(IPH)/T**2)
      TF4(IPH)=4.0*AL2*2.0**(1.0/T)/T
      TF6(IPH)=4.0*T*TF1(IPH)**2
      TF8(IPH)=DG/RG-TF2(IPH)/T**2
      TF9(IPH)=4.0*TF1(IPH)**2
C     TF3=360.0*TF6/PIG
      RETURN
      END
      SUBROUTINE outscr(I,R)
C THIS ROUTINE outputs cycle no and rwp to screen
      CHARACTER M1*18,M2*5
      DATA M1,M2/'  CYCLE NUMBER=',',RWP='/
      WRITE(*,'(A,I2,A,F5.1/)')M1,I,M2,R
      RETURN
      END
      SUBROUTINE OUTPTR(ICYCLE)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/DC/SAVE(8,6),NSAVE
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      COMMON/ALLP/FINAL(8*MSZ,2),ILOC
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/G3/COND,IORD1,IORD2,TH,NUM
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/G2/S1,S2,S3,S4,D1,D2,D4,R1,R2,R3
      COMMON/F1/SMM(MSZ,MSZ),V(MSZ)
      DIMENSION SY(20),SZ(20),DCSM(6,6),DCV(6),DUMMY(2*MSZ+4)
      CHARACTER*10 ID(5)
      ID(1)='SKEWNESS='
      ID(2)='  ETA   ='
      ID(3)='PEARSON-M='
      DO 8123 I=1,2*MSZ+4
8123    DUMMY(I) = 0.
C
      WRITE(6,57)R2,R3
      WRITE(7,57)R2,R3
57    FORMAT(//,
     * ' R-P        = ',F8.2,/,
     *  ' R-WP       = ',F8.2)
      IF (MAXS.EQ.0.AND.MCYCLE.EQ.1) THEN
        CALL outscr(MCYCLX,R3)
      ELSE
        CALL outscr(ICYCLE-1,R3)
      ENDIF
      CALL DISP(ICYCLE,R3)
      X=100.*SQRT((FLOAT(NUM)-FLOAT(MAXS))*1./D2)
      WRITE(6,58)X
58    FORMAT(' R-EXPECTED = ',F8.2)
      WRITE (6,66) SQRT(S2/FLOAT(NUM-MAXS)), S4/S2
66    FORMAT (
     *' S          = ',F8.2,5X,'SQRT(RESIDUAL/N-P)','GOODNESS OF FIT',/,
     *  ' D - W D    = ',F8.2,5X,'WEIGHTED DURBIN-WATSON STATISTIC D')
      I=NUM-MAXS
      WRITE(6,62)I
      WRITE(6,63)S1,D1,S3,D2,S2,COND
62    FORMAT( 5H0N-P=,8X,I8)
63    FORMAT(/,7X,'SUMYDIF', 7X,'SUMYOBS', 6X,'SUMYCALC', 6X,'SUMWYOBS'
     * ,'SQ',6X,'RESIDUAL',6X,'CONDITION',/,1X,6E14.4/)
      DUMMY(2*MSZ+1) = R2
      DUMMY(2*MSZ+2) = R3
      DUMMY(2*MSZ+3) = SQRT(S2/FLOAT(NUM))
      DUMMY(2*MSZ+4) = S4/S2
C     FINAL PARAMETERS AND R-FACTORS
      IF (IPLST.NE.0.AND.MAXS.EQ.0) THEN
        DO 410 IP=1,NPHASE
          IOF=0
          IF(IP.GT.1) THEN
            DO 44340 IIPHAS=2,IP
44340         IOF = IOF + NATOM(IIPHAS-1)
          END IF
          N=NATOM(IP)
          DO 604 I=1,N
            DO 604 J=1,5
              KM=LP(I+IOF,J)
              IF(KM.NE.0) DUMMY(KM)  =XL(I+IOF,J)
604           CONTINUE
          DO  607 I=1,N
            DO  607 J=6,11
              KM=LP(I+IOF,J)
              IF(KM.NE.0) DUMMY(KM)  =XL(I+IOF,J)
607           CONTINUE
          DO 6017 J=1,20
            KM=LPAR(IP,J)
            IF(KM.NE.0) DUMMY(KM) = PAR(IP,J)
6017        CONTINUE

        CALL DIRECT(DCSM,DCV,IP)
        DO 30030 I=1,6
          KM = LPAR(IP,I+5)
          MATCH = 0
          IF (KM.NE.0) THEN
            IF (I.GE.4) THEN
              DO 30031 MMM=1,3
              IF (KM.EQ.LPAR(IP,MMM+5)) MATCH=1
30031         CONTINUE
            ENDIF
            IF (MATCH.EQ.0) DUMMY(KM) = SAVE(IP,I)
          END IF
30030     continue

410       CONTINUE
        DO 6019 J=1,11
          IF(NPROF.EQ.8.AND.(J.EQ.8.OR.J.EQ.9)) GO TO 6019
          IF(NPROF.EQ.6.AND.J.EQ.8) GO TO 6019
          IF(NPROF.EQ.7.AND.J.EQ.8) GO TO 6019
          KM=LGLB(J)
          IF(KM.NE.0) DUMMY(KM) = GLB(J)
6019      CONTINUE
        WRITE (8,ERR=99990) (DUMMY(I),I=1,MAXSX)
     *       ,(DUMMY(I),I=MSZ+1,MSZ+MAXSX),(DUMMY(I),I=2*MSZ+1,2*MSZ+4)
        DO 9487 I=1,4
        IF (MOD(I,2).EQ.1) ILOC = ILOC + 1
9487    FINAL(ILOC,2-MOD(I,2)) = DUMMY(2*MSZ+I)
      END IF
C
      IF (MAXS.EQ.0.AND.MCYCLE.EQ.1) RETURN
C
      ILOC = 0
      DO 8127 I=1,8*MSZ
        DO 8127 J=1,2
8127      FINAL(I,J) = 0.
      WRITE(6,1)ICYCLE
      WRITE(7,111)ICYCLE
111   FORMAT(//14H CYCLE NUMBER=,I4)
1     FORMAT(1H1,120(1H+)//14H CYCLE NUMBER=,I4)
      DO 10 IP=1,NPHASE
        IOF=0
        IF(IP.GT.1) THEN
          DO 4340 IIPHAS=2,IP
4340        IOF = IOF + NATOM(IIPHAS-1)
        END IF
        WRITE(6,3)IP,PHSNM(IP)
3       FORMAT(7H0PHASE ,I2,2H: ,A70,/' NEW PARAMETERS, SHIFTS, AND ',
     *     'STANDARD DEVIATIONS='//5H ATOM,5X,1HX,6X,2HDX,5X,2HSX,6X,1HY
     *   ,6X, 2HDY,5X,2HSY,6X,1HZ,6X,2HDZ,5X,2HSZ,6X,1HB,6X,2HDB,5X,2HSB
     *   ,       6X,1HN,6X,2HDN,5X,2HSN)
        N=NATOM(IP)
        DO  4 I=1,N
          DO  5 J=1,5
            ILOC = ILOC + 1
            KM=LP(I+IOF,J)
            IF(KM.NE.0)GOTO  6
            SY(J)=0.
            SZ(J)=0.
            FINAL(ILOC,1) = XL(I+IOF,J)
            GOTO  5
6           SZ(J)=SQRT(ABS(SMM(KM,KM)))
            SY(J)=V(KM)*A(I+IOF,J)*RELAX(1)
            DUMMY(KM)  =XL(I+IOF,J)
            XL(I+IOF,J)=XL(I+IOF,J)+SY(J)
            DUMMY(KM+MSZ)  = SY(J)
            FINAL(ILOC,1) = XL(I+IOF,J)
            FINAL(ILOC,2) = SZ(J)
5           CONTINUE
4         WRITE(6,100)ATEXT(I+IOF),(XL(I+IOF,J),SY(J),SZ(J),J=1,5)
100     FORMAT(1X,A4,2X,5(3F7.4,1X))
        WRITE(6,101)
101     FORMAT(5H0ATOM,7X,3HB11,6X,4HDB11,6X,4HSB11,7X,3HB22,6X,4HDB22,
     *     6X,4HSB22,7X,3HB33,6X,4HDB33,6X,4HSB33,/,12X,3HB12,6X,4HDB12,
     *   6X,  4HSB12,7X,3HB13,6X,4HDB13,6X,4HSB13,7X,3HB23,6X,4HDB23,6X,
     *   4HSB23)
        DO  7 I=1,N
          DO  8 J=6,11
            ILOC = ILOC + 1
            KM=LP(I+IOF,J)
            IF(KM.NE.0)GOTO  9
            SY(J)=0.
            SZ(J)=0.
            FINAL(ILOC,1) = XL(I+IOF,J)
            GOTO  8
9           SZ(J)=SQRT(ABS(SMM(KM,KM)))
            SY(J)=V(KM)*A(I+IOF,J)*RELAX(2)
            DUMMY(KM)  =XL(I+IOF,J)
            XL(I+IOF,J)=XL(I+IOF,J)+SY(J)
            DUMMY(KM+MSZ)  = SY(J)
            FINAL(ILOC,1) = XL(I+IOF,J)
            FINAL(ILOC,2) = SZ(J)
8           CONTINUE
7         WRITE(6,102)ATEXT(I+IOF),(XL(I+IOF,J),SY(J),SZ(J),J=6,11)
102     FORMAT(1X,A4,9F10.6,/,5X,9F10.6)
        DO 17 J=1,20
          IF (J.EQ.12) THEN
            ILOC = ILOC + 1
            FINAL(ILOC,1) = PREF(IP,1)
            FINAL(ILOC,2) = PREF(IP,2)
            ILOC = ILOC + 1
            FINAL(ILOC,1) = PREF(IP,3)
          END IF
          ILOC = ILOC + 1
          IF (J.EQ.6) ILOC1 = ILOC
C         IF (J.EQ.11) ILOC2 = ILOC
          KM=LPAR(IP,J)
          IF(KM.NE.0)GOTO 18
          SY(J)=0.
          SZ(J)=0.
          FINAL(ILOC,1) = PAR(IP,J)
          GOTO 17
18        SZ(J)=SQRT(ABS(SMM(KM,KM)))
          SY(J)=V(KM)*APAR(IP,J)*RELAX(3)
          DUMMY(KM) = PAR(IP,J)
          PAR(IP,J)=PAR(IP,J)+SY(J)
          DUMMY(KM+MSZ)  = SY(J)
          FINAL(ILOC,1) = PAR(IP,J)
          FINAL(ILOC,2) = SZ(J)
17        CONTINUE
        CALL DIRECT(DCSM,DCV,IP)
          ILOC2=ILOC
          ILOC=ILOC1-1
        DO 30 I=1,6
          ILOC = ILOC + 1
          KM = LPAR(IP,I+5)
          MATCH=0
          SY(I+5)=DCV(I)-SAVE(IP,I)
          IF (KM.NE.0) THEN
           IF (I.GE.4) THEN
              DO 30032 MMM=1,3
              IF (KM.EQ.LPAR(IP,MMM+5)) MATCH=1
30032         CONTINUE
            ENDIF
            IF (MATCH.EQ.0) THEN
              DUMMY(KM) = SAVE(IP,I)
              DUMMY(KM+MSZ) = SY(I+5)
            END IF
          END IF
          FINAL(ILOC,1) = DCV(I)
          FINAL(ILOC,2) = DCSM(I,I)
30        SAVE(IP,I)=DCV(I)
        ILOC = ILOC2
        WRITE(6,103) PAR(IP,1),SY(1),SZ(1),
     *        (PAR(IP,I),SY(I),SZ(I),I=2,5),PAR(IP,20),SY(20),SZ(20),
     *           (DCV(I),SY(I+5),DCSM(I,I),I=1,6),(PAR(IP,I),SY(I),SZ(I)
     *   ,          I=12,19)
103     FORMAT('0OVERALL SCALE FACTOR=',3G9.3,/,
C    *     '0ETA(PSEUDO-VOIGT) M (PEARSON VII) = ',3F8.5,/,
     *        '0OVERALL TEMP. FACTOR=',3F9.4,/,
     *           '0HALFWIDTH PARAMETERS=',/,4(1X,3F10.6,/),
     *              '0CELL PARAMETERS=',/,6(3F11.6,/),
     *                 '0PREFERRED ORIENTATION PARAMETERS=',/,2(1X,3F8.5
     *   ,/),             '0ASYMMETRY PARAMETER=',/,1X,3F8.5,/,
     *                       '0LORENTZIAN HALF WIDTH PARAMS (X AND Y) ',
     *   /,2(1X,3F8.5,/),
     *         '0MIXING PARAMETERS (NA, NB, NC)  =',/,3(1X,3G10.4,/))
10      CONTINUE
      DO 19 J=1,11
        IF(NPROF.EQ.8.AND.(J.EQ.8.OR.J.EQ.9)) GO TO 19
        IF(NPROF.EQ.6.AND.J.EQ.8) GO TO 19
        IF(NPROF.EQ.7.AND.J.EQ.8) GO TO 19
        ILOC = ILOC +1
        KM=LGLB(J)
        IF(KM.NE.0)GOTO 20
        SY(J)=0.
        SZ(J)=0.
        FINAL(ILOC,1) = GLB(J)
        GOTO 19
20      SZ(J)=SQRT(ABS(SMM(KM,KM)))
        SY(J)=V(KM)*AGLB(J)*RELAX(4)
        DUMMY(KM) = GLB(J)
        GLB(J)=GLB(J)+SY(J)
        DUMMY(KM+MSZ)  = SY(J)
        FINAL(ILOC,1) = GLB(J)
        FINAL(ILOC,2) = SZ(J)
19      CONTINUE
      WRITE(6,109)GLB(1),SY(1),SZ(1)
109   FORMAT('0GLOBAL PARAMETERS',/,'0ZEROPOINT=',3F8.4)
      IF(NBCKGD.NE.0)GOTO 80
      WRITE(6,84)(GLB(J),SY(J),SZ(J),J=2,7)
84    FORMAT('0BACKGROUND PARAMETERS',/,(1X,3G12.6))
80    IF(NPROF.NE.5) GOTO 90
      WRITE(6,72)ID(NPROF-4),GLB(8),SY(8),SZ(8)
72    FORMAT(1X,A10,3F8.4)
      IF(NPROF.GT.5)GOTO 90
      WRITE(6,75)GLB(9),SY(9),SZ(9)
75    FORMAT(8H EXCESS=,3F8.4)
90    CONTINUE
      WRITE (6,181) (GLB(J),SY(J),SZ(J),J=10,11)
181   FORMAT (/' SAMPLE DISPLACEMENT (DISP)       ',3F8.4,/,
     *         ' SAMPLE TRANSPARENCY (TRANSP)     ',3F8.4)
      WRITE (8,ERR=99990) (DUMMY(I),I=1,MAXS)
     *   ,(DUMMY(I),I=MSZ+1,MSZ+MAXS),(DUMMY(I),I=2*MSZ+1,2*MSZ+4)
      RETURN
99990 STOP 'ERROR IN WRITING TO UNIT 8 IN OUTPTR'
      END
***vax modification
*      SUBROUTINE CALPLT(IFY,IFYC,IFM,IFD,IFB,EXPAN,ZER)
*      PARAMETER (IDSZ=16384 ,IRS=2048,NATS=64,MSZ=128,NOV=512)
*      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
*     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
*      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
*     * ,ULOR,VLOR
*      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
*     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
*      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
*     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
*     *  PTR(NATS),RELAX(4),RATIO(2)
*      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
*      COMMON/PARAC/ATEXT,NTYP
*      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
*     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
*      CHARACTER SYMB(8,20)*1
*      CHARACTER TITLE*70,PHSNM(8)*70
*      COMMON/CHAR/SYMB,TITLE,PHSNM
*      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
*      COMMON/PLTX/EXPAND,FACTO
*      EXPAND=EXPAN
*      CMAX=35./2.54
*      PROFZ=10./2.54
*      BACKZ= 9./2.54
*      REFLZ=8./2.54
*      DIFZ=4./2.54
*      SIZ1=.375
*      SIZ2=.375
*      CALL PLOTS(FF,512,2,00)
*      CALL FACTOR (0.6)
*      CALL PLOT(0.,-35.,-3)
*      CALL PLOT( 4.,2.,-3)
*      CALL PLOTMX(60.0)
*      X=(THMAX-THMIN) /2.54
*      CALL PLOT(X,0.,2)
*      CALL PLOT(X,CMAX,2)
*      CALL PLOT(0.,CMAX,2)
*      CALL PLOT(0.,0.,2)
*C WRITE THE TITLE ON THE PLOT
*      CALL SYMBOL(1.,CMAX+.5,.49,TITLE,0.,70)
*      IEND=INT(THMAX-THMIN)+1
*C DRAW X-AXIS TICKS MARKS AND LABEL THEM
*      DO 10 IFIX=1,IEND
*        I=IFIX-1
*        X=FLOAT(I)/2.54
*        I1=INT(THMIN)+I
*        FPN=I1
*        CALL SYMBOL(X,0.,.25,13,0.,-1)
*        X=X-SIZ2
*        IF(MOD(I1,5).EQ.0)CALL NUMBER(X,-.5,SIZ2,FPN,0.,-1)
*10      CONTINUE
*      X=((THMAX-THMIN) /2.)-(4.5)*(.25)
*      X=X/2.54
*      YY=-1.00
*      CALL SYMBOL(X,YY,SIZ1,"!<TWO THETA",0.,11)
*C TICK AND LABEL THE Y-AXIS
*      IF(IFD)40,50,40
*40    CALL SYMBOL(0.,DIFZ,.25,13,90.,-1)
*      FPN=0.
*      CALL NUMBER(-1.10,DIFZ-SIZ2/2.,SIZ2,FPN,0.,1)
*50    ITEST=IFY+IFYC
*      IF(ITEST)60,70,60
*60    DO 65 IFIX=1,11
*        I=IFIX-1
*        YY=PROFZ+FLOAT(I)*(CMAX-PROFZ)/10.
*        CALL SYMBOL(0.,YY,.25,13,90.,-1)
*        FPN=FLOAT(I)*.10
*        IF(MOD(I,5).EQ.0)CALL NUMBER(-1.10,YY-SIZ2/2.,SIZ2,FPN,0.,1)
*65      CONTINUE
*C     FIND THE MAXIMUM OF THE OBS AND CAL DATA
*      HI=Y(1)
*      DO 75 I=1,NPTS
*        IF(Y(I).GT.HI)HI=Y(I)
*        IF(YC(I).GT.HI)HI=YC(I)
*75      CONTINUE
*C SELECT SUITABLE Y-AXIS SCALING
*      IF(ITEST)80,70,80
*80    IEXPO=0
*82    IF(HI.LT.100.)GOTO 90
*      HI=HI/10.
*      IEXPO=IEXPO+1
*      GOTO 82
*90    FACTO=(CMAX-PROFZ)/(HI*10.0**IEXPO)
*C SCALE THE DATA
*      DO 95 I=1,NPTS
*        IF (IFD.EQ.2)    BK(I)=(Y(I)-YC(I))/SQRT(VAR(I))*1./2.54+DIFZ
*        Y(I)=Y(I)*FACTO*EXPAND+PROFZ
*        VAR(I)=VAR(I)*FACTO*EXPAND+PROFZ
*        YC(I)=YC(I)*FACTO*EXPAND+PROFZ
*        IF (IFD.NE.2)  BK(I)=Y(I)-YC(I)+DIFZ
*95      CONTINUE
*C     SET DIFFERENCE TO BASE-LINE FOR EXCLUDED REGIONS
*      IF(NEXCRG.GT.0) THEN
*        DO 1400 I=1,NEXCRG
*          NPTLOW = (ALOW(I)-THMIN)/STEP + 1.5
*          NPTHI  = (AHIGH(I)-THMIN)/STEP + 1.5
*          DO 1400 INEX = NPTLOW,NPTHI
*1400        BK(INEX) = DIFZ
*      END IF
*C LABEL THE Y- AXIS
*      IF(ITEST)100,70,100
*100   AHI=HI/EXPAND
*      X=0.0
*      YY=((CMAX-PROFZ)/2.-8.*SIZ1) +PROFZ
*      CALL NUMBER(X-1.5,YY,SIZ1,AHI,90.,2)
*      CALL WHERE(X,YY,DUMMY)
*      X=-1.5
*      YY=YY+SIZ1
*      CALL SYMBOL(X,YY,SIZ1," X10",90.,4)
*      CALL WHERE(X,YY,DUMMY)
*      X=X-.0625
*      YY=YY+.07
*      FEXPO=IEXPO
*      CALL NUMBER(X,YY,.2,FEXPO,90.,-1)
*      CALL WHERE(X,YY,DUMMY)
*      X=-1.5
*      YY=YY+SIZ2
*      CALL SYMBOL(X,YY,SIZ2,"!<COUNTS",90.,8)
*70    CALL PLOT(0.,PROFZ,3)
*      CALL CURVE (Y,IFY,PROFZ,VAR,0.0)
*      CALL PLOT(0.,PROFZ,3)
*      CALL CURVE(YC,IFYC,PROFZ,YC,0.)
*C
*      FLAG=1.
*      IF (IFD.EQ.2) THEN
*        CALL SYMBOL(0.,DIFZ+1./2.54,.25,13,90.,-1)
*        CALL NUMBER (-0.8,DIFZ+1./2.54-.280/2.,.280,1.0,0.,1)
*        CALL SYMBOL(0.,DIFZ-1./2.54,.25,13,90.,-1)
*        CALL NUMBER (-1.1,DIFZ-1./2.54-.280/2.,.280,-1.0,0.,1)
*        CALL PLOT (0.,DIFZ+1./2.54,3)
*        CALL PLOT ((THMAX-THMIN)/2.54,DIFZ+1./2.54,2)
*        CALL PLOT ((THMAX-THMIN)/2.54,DIFZ-1./2.54,3)
*        CALL PLOT (0.,DIFZ-1./2.54,2)
*        FLAG=2.
*      ELSE IF (IFD.EQ.1) THEN
*        CALL PLOT(0.,DIFZ,3)
*        CALL PLOT((THMAX-THMIN)/2.54,DIFZ,2)
*      END IF
*      CALL PLOT(0.,DIFZ,3)
*      CALL CURVE(BK,IFD,DIFZ,Y,FLAG)
*C     RECALCULATE BACKGROUND FOR PLOTTING
*      IF (IFB.EQ.1) THEN
*        TH=THMIN-STEP
*        DO 473 I=1,NPTS
*          TH=TH+STEP
*          THX=TH/BKPOS-1.
*          BK(I)=GLB(2)
*          DO 474 J=2,6
*474         BK(I)=BK(I)+GLB(1+J)*THX**(J-1)
*473       BK(I)=BK(I)*FACTO*EXPAND+BACKZ
*        CALL PLOT(0.,BACKZ,3)
*        CALL PLOT((THMAX-THMIN)/2.54,BACKZ,2)
*        CALL PLOT(0.,BACKZ,3)
*        CALL CURVE(BK,IFB,BACKZ,Y,1.)
*      END IF
*C PLOT REFLECTION MARKERS
*      IF(IFM)71,72,71
*71    REFLZ=REFLZ+1./2.54
*      DO 200 J=1,NPHASE
*        REFLZ=REFLZ-1./2.54
*        NREF = 0
*        DO 4100 IIPHAS=1,NPHASE
*4100      NREF = NREF + IC(IIPHAS)
*        DO 200 I=1,NREF
*          IF(J.NE.IREFS(I)/256/256/256/8)GOTO 200
*          X=(REFS(I,2)+ZER-THMIN)/2.54
*          CALL SYMBOL(X,REFLZ,.25,13,0.,-1)
*200       CONTINUE
*72    CALL PLOT(0.,0.,999)
*      RETURN
*      END
*      SUBROUTINE CURVE(Z,II,PZ,ZZ,FLAG)
*      PARAMETER (IDSZ=16384 ,IRS=2048,NATS=64,MSZ=128,NOV=512)
*      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
*     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
*      COMMON/PLTX/EXPAND,FACTO
*      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
*     * ,ULOR,VLOR
*      DIMENSION Z(IDSZ),ZZ(IDSZ)
*      IND=INT((THMAX-THMIN)/STEP+1.)
*      CMAX=35./2.54
*      I=1
*      L=1
*      IF (FLAG.EQ.2) II=1
*      II=II+1
*      ITH=THMIN
*      GOTO(200,230,210),II
*      CALL GOTOER
*210   DO 214 KFIX=1,IND
*        K=KFIX-1
*        X=FLOAT(K)*STEP
*        Y=10**6
*        IF(X.LT.THMIN-FLOAT(ITH))Y=PZ
*        X=X/2.54
*        IF(Y.EQ.PZ) CALL PLOT(X,PZ,2)
*        IF(X*2.54.LT.THMIN-FLOAT(ITH))GOTO 214
*        IF(Y.EQ.PZ)GOTO 211
*        Y=Z(I)
*        COUNT=(ZZ(I)-PZ)/(FACTO*EXPAND)
*        IF(FLAG)215,215,400
*400     COUNT=SQRT(2.)*(ZZ(I)-PZ)/(FACTO*EXPAND)
*215     IPEN=-1
*        CALL POINT(X,Y,COUNT,IPEN)
*211     I=I+1
*214     CONTINUE
*      GOTO 200
*230   DO 231 I=1,IND
*        X=FLOAT(I)*STEP
*        Y=10**6
*        IF(X.LT.THMIN-FLOAT(ITH))Y=PZ
*        IF(X.LT.THMIN-FLOAT(ITH))GOTO 227
*        Y=Z(L)
*226     L=L+1
*227     CONTINUE
*        IF(Y.GT.CMAX)Y=CMAX
*        IF(Y.LT.0.0) Y=0.0
*        X=X/2.54
*        CALL PLOT(X,Y,2)
*231     CONTINUE
*200   RETURN
*      END
*      SUBROUTINE POINT(X,Y,COUNT,IPEN)
*      PARAMETER (IDSZ=16384 ,IRS=2048,NATS=64,MSZ=128,NOV=512)
*      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
*     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
*      COMMON/PLTX/FACTO,EXPAND
*      CMAX=35./2.54
*      DIA=.1/2.54
*      HEIGHT=2.*SQRT(ABS(COUNT))
*      HEIGHT=HEIGHT*FACTO*EXPAND
*      IF(Y.GT.CMAX)Y=CMAX
*      IF(Y.LT.0.0) Y=0.0
*      CALL SYMBOL(X,Y,HEIGHT,13,0.,IPEN)
*      CALL SYMBOL(X,Y,DIA,1,0.,-1)
*      RETURN
*      END
***vax
      SUBROUTINE DISP(I,R)
C THIS ROUTINE PLACES INFORMATION IN THE JOB DAYFILE ON THE
C G.T. CYBER SYSTEM ALLOWING MONITORING THE PROGRESS OF
C SUBMITTED JOBS. DELETE THE CALL TO IT IN *OUTPTR* IF UNNEEDED.
      CHARACTER MESSAG*30,M1*18,M2*5
      DATA M1,M2/'PFSR CYCLE NUMBER=',',RWP='/
      WRITE(MESSAG,'(A,I2,A,F5.1)')M1,I,M2,R
***vax modification
*      REMARK(MESSAG)
***vax
      RETURN
      END
      SUBROUTINE REFGENM(IPHASE,ZERO,DISP,TRANSP,PREF,PREFOR)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      COMMON/HKLCTL/KZ(3,24),AZ(24),NCN(70),ICQ,N1,IER,HN
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),MLT(IRS),ICX(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      REAL LAMDA
      INTEGER H1,H2,H3,h4
      LOGICAL ORH1,ORH2,ORH3,orh4
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,BKPOS,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/SPG/NSPGRP,K,M(10),FILL(3)
      COMMON/CELLX/A,B,C,ALPHA,BETA,GAMMA,AL(3,3)
***vax***mod
      common/vax/ lvax
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
      character ssgrp*1,qmodbc*20,qmodac*10
      logical lvax,lqmod
***vax***mod
      DIMENSION PREF(8,3)
      EQUIVALENCE (AL(1,1),ASTAR),(AL(2,2),BSTAR),(AL(3,3),CSTAR),
     * (AL(1,2),BACOSC),(AL(1,3),CACOSB),(AL(2,3),BCCOSA)
      CHARACTER*8 LAU(14)
      DATA LAU(1),LAU(2),LAU(3),LAU(4),LAU(5),LAU(6),LAU(7),LAU(8),
     * LAU(9),LAU(10),LAU(11),LAU(12),LAU(13),LAU(14)
     *  /'1BAR','2/M','MMM','4/M','4/MMM','3BAR   R','3BAR M R','3BAR',
     *   '3BAR M 1','3BAR 1 M','6/M','6/MMM','M3','M3M'/
      SIN1(A)=SIN(A*6.28318531)
      RAD=3.14159265359/360.0
      IF ( K.GT.3 ) STOP 5001
      mordlim(iphase) = 2
      ex1 = 0.0
      ex2 = 0.0
      ex3 = 0.0
      ex4 = 0.0
      KXIS=K
      K=1
97    TMIN = (SIN1(THMIN/720.0)/LAMDA(1))**2
      IC = 0
      IF (IPHASE.GE.2) THEN
        DO 4100 IIPHAS=2,IPHASE
4100      IC = IC+ICX(IIPHAS-1)
      END IF
C     IF(IPHASE.EQ.2)IC=ICX(1)
      SMAX = (SIN1(THMAX/720.0)/LAMDA(1))**2
      IF(LAMDA(2).GT.LAMDA(1))TMIN=TMIN*(LAMDA(1)/LAMDA(2))**2
      IF(LAMDA(2).GT.0..AND.LAMDA(2).LT.LAMDA(1))SMAX=SMAX*
     * (LAMDA(1)/LAMDA(2))**2
      CALL OP1
*      WRITE(6,36)LAU(NSPGRP)
*36    FORMAT(15H LAUE SYMMETRY ,A8,33H WILL BE USED TO GENERATE INDICES)
      I1MAX=A*2.0*SQRT(SMAX)
      IF ( KXIS.LT.3 ) THEN
        I2MAX=B*2.0*SQRT(SMAX)
        I3MAX=C*2.0*SQRT(SMAX)
      ELSE
        I2MAX = 2.0*C*SQRT(SMAX)
        I3MAX = 2.0*B*SQRT(SMAX)
      END IF
      L1 = NSPGRP
      IF ( L1.GE.13.AND.M(1).EQ.580 ) L1=L1+2
      I1 = -1
2200  I1 = 1+I1
      IF ( I1-I1MAX ) 2201,2201,2303
2201  H1 = I1
2204  I2 = -1
2220  I2 = i2 + 1
2221  H2 = I2
      IF ( I2-I2MAX ) 2222,2222,2200
2222  i3 = -1
2233  I3 = i3 + 1
2232  H3 = I3
      IF ( KXIS.EQ.3 )then
        H3 = I2
        H2 = I3
      endif
      IF ( I3.gt.I3MAX ) goto 2220
      mstart = -1 * mordlim(iphase) - 1
      if(qmodic(iphase,1).ne.0.0)then
        if(h1.ne.0)then
          i4new = mstart
        else
          i4new = -1
        endif
      endif
      if(qmodic(iphase,2).ne.0.0)then
        if(h2.ne.0)then
          i4new = mstart
        else
          i4new = -1
        endif
      endif
      if(qmodic(iphase,3).ne.0.0)then
        if(h3.ne.0)then
          i4new = mstart
        else
          i4new = -1
        endif
      endif
      i4 = i4new
2244  i4 = i4 + 1
      h4 = i4
      if(h4.gt.mordlim(iphase))goto 2233
      if(h1.eq.0.and.h2.eq.0.and.h3.eq.0)goto 2233
      extn = ex1*h1 + ex2*h2 + ex3*h3 + ex4*h4
      if(mod(int(extn),2).ne.0)then
*        write(*,332)h1,h2,h3,h4
        goto 2244
      endif
*332   format('****** Reflection ',4i4,' was rejected *******')
* modify multiplicity for satellite reflections
*
      modmult = 1
      if(h4.ne.0.0)then
        if(qmodic(iphase,1).ne.0.0.and.h1.eq.0.0)then              
          modmult = 2                
        endif                          
        if(qmodic(iphase,2).ne.0.0.and.h2.eq.0.0)then              
          modmult = 2                
        endif                          
        if(qmodic(iphase,3).ne.0.0.and.h3.eq.0.0)then              
          modmult = 2                
        endif                          
      endif
* calculate d-star-squared
*
113   hm1 = real(h1)+real(h4)*qmodic(iphase,1)
      hm2 = real(h2)+real(h4)*qmodic(iphase,2)
      hm3 = real(h3)+real(h4)*qmodic(iphase,3)
      SQ= (hm1**2)*astar + (hm2**2)*bstar + (hm3**2)*cstar
     *  + hm1*hm2*bacosc + hm1*hm3*cacosb + hm2*hm3*bccosa
*      write(*,333)h1,h2,h3,h4,sq
*333    format(' reflection generated as',4i4,' with d-star-squared '
*     * ,f8.4)
      SQ=SQ/4.
      if(lqmod(iphase))then
         IF ( SQ-SMAX ) 3000,3000,2244
      else
         IF ( SQ-SMAX ) 3000,3000,2233
      endif
2303  ICX(IPHASE)=IC
      IF (IPHASE.GE.2) THEN
        DO 4101 IIPHAS=2,IPHASE
4101      ICX(IPHASE) = ICX(IPHASE)-ICX(IIPHAS-1)
      END IF
C     IF(IPHASE.EQ.2)ICX(IPHASE)=IC-ICX(1)
      CALL SORT(IPHASE)
      RETURN
3000  if(lqmod(iphase))then
         IF ( SQ - TMIN ) 2244,3117,3117
      else
         IF ( SQ - TMIN ) 2233,3117,3117
      endif
3117  IF ( IC.GT.IRS-2 ) GO TO 6001
C     NEXT IF BLOCK FOR PHASE WITH DISTINCT ORIENTATION ALONG PREF(K,I)
      IF (PREFOR.GT.99.) THEN
C
        ORH1 = IFIX(PREF(IPHASE,1)).EQ.H1
        IF (.NOT.(ORH1).AND.H1.NE.0.AND.IFIX(PREF(IPHASE,1)).NE.0)
     *        ORH1 = MOD(H1,IFIX(PREF(IPHASE,1))).EQ.0
        IF (.NOT.ORH1) GO TO 2233
C
        ORH2 = IFIX(PREF(IPHASE,2)).EQ.H2
        IF (.NOT.(ORH2).AND.H2.NE.0.AND.IFIX(PREF(IPHASE,2)).NE.0)
     *        ORH2 = MOD(H2,IFIX(PREF(IPHASE,2))).EQ.0
        IF (.NOT.ORH2) GO TO 2233
C
        ORH3 = IFIX(PREF(IPHASE,3)).EQ.H3
        IF (.NOT.(ORH3).AND.H3.NE.0.AND.IFIX(PREF(IPHASE,3)).NE.0)
     *        ORH3 = MOD(H3,IFIX(PREF(IPHASE,3))).EQ.0
        IF (.NOT.ORH3) GO TO 2233
        IORDR1=0
        IORDR2=0
        IORDR3=0
        IF (H1.NE.0) IORDR1 = INT(H1/IFIX(PREF(IPHASE,1)))
        IF (H2.NE.0) IORDR2 = INT(H2/IFIX(PREF(IPHASE,2)))
        IF (H3.NE.0) IORDR3 = INT(H3/IFIX(PREF(IPHASE,3)))
        IF (IORDR1.EQ.IORDR2.AND.IORDR2.EQ.IORDR3) GO TO 9257
        IF (IORDR1.EQ.0.AND.(IORDR2.EQ.IORDR3)) GO TO 9257
        IF (IORDR2.EQ.0.AND.(IORDR3.EQ.IORDR1)) GO TO 9257
        IF (IORDR3.EQ.0.AND.(IORDR1.EQ.IORDR2)) GO TO 9257
        IF (IORDR1.EQ.0.AND.IORDR2.EQ.0) GO TO 9257
        IF (IORDR2.EQ.0.AND.IORDR3.EQ.0) GO TO 9257
        IF (IORDR3.EQ.0.AND.IORDR1.EQ.0) GO TO 9257
      END IF
9257  CONTINUE
C     SEPARATE PHASE FOR ORIENTATION COMPLETE
      KZ(1,1)=H1
      KZ(2,1)=H2
      KZ(3,1)=H3
      AZ(1)=0.0
      IER=0
*      CALL SMTRY2
      if(lqmod(iphase))then
        IF(IER.NE.0)GOTO 2244
      else
        IF(IER.NE.0)GOTO 2233
      endif
      LXN=2
      IF(LAMDA(2).EQ.0..OR.LAMDA(2).EQ.LAMDA(1))LXN=1
      DO 3118 LX1=1,LXN
        SQH=SQ*LAMDA(LX1)*LAMDA(LX1)
        TAN2=SQH/(1.-SQH)
        IF(SQH.GE.1.)GOTO 3118
        TANX=SQRT(TAN2)
C     SHIFT DUE TO SAMPLE DISPLACEMENT AND TRANSPARENCY
        SHIFT =  DISP*SQRT(1-SQH)+TRANSP*SQRT(1.-(1.-2.*SQH)*(1.-2.*SQH)
     *   )
        POS=ATAN(TANX)/RAD+ ZERO + SHIFT
        IF(POS.GT.THMAX.OR.POS.LT.THMIN)GOTO 3118
        IC=IC+1
        XABS=1.0
        IF(TMV.LE.0.000001)XABS=1.
        PLOR=1./(2.*SQH*SQRT(1.-SQH))*XABS
        IF (INSTRM.EQ.2) THEN
          PLOR = PLOR * (0.95+0.05*(1.-2.*SQH)*(1.-2.*SQH))
          GO TO 4000
        END IF
        IF(JOBTYP.EQ.3)PLOR=PLOR*(1.+(1.-2.*SQH)*(1.-2.*SQH)*CTHM)
        IF(JOBTYP.EQ.1)PLOR=PLOR*(1.+(1.-2.*SQH)*(1.-2.*SQH)*CTHM)
4000    CONTINUE
        IREFS(IC)=256*(256*(256*(8*IPHASE+LX1)+128+H1)+128+H2)+128+H3
        mm(ic) = h4
        MLT(IC)=MULT(H1,H2,H3,KXIS)*modmult
*        write(*,334)h1,h2,h3,h4
*334     format(' reflection stored as   ',4i4)
C
C------CALCULATE HALFWIDTH FOR PSEUDOVOIGT WITH GAUSS AND LORENTZ
        IF (NPROF.EQ.8) THEN
          HALFG(IC) =    (U*TAN2+V*TANX+W+ZZZ*(1+TAN2))
          IF (HALFG(IC).GT.0.) THEN
            HALFG(IC) = SQRT(HALFG(IC))
          ELSE
            WRITE (6,3456) POS,IPHASE
            WRITE (7,3456) POS,IPHASE
            STOP 'SQUARE OF FWHM IS NEGATIVE'
3456        FORMAT (3X,'SQUARE OF FWHM NEGATIVE AT TWO-THETA',F8.3,
     *             'FOR PHASE NO. ',I4)
          END IF
          HALFL(IC) = ULOR*TANX+VLOR/SQRT(1.-SQH)
          REFS(IC,1) = (HALFG(IC)**5.+2.69269*HALFG(IC)**4.*HALFL(IC)+
     *         2.42843*HALFG(IC)**3.*HALFL(IC)**2.+
     *              4.47163*HALFG(IC)**2.*HALFL(IC)**3. +
     *                   0.07842*HALFG(IC)*HALFL(IC)**4. + HALFL(IC)**5.
     *     )**0.2
          TLR = HALFL(IC)/REFS(IC,1)
          GAM(IC) = 1.36603*TLR-0.47719*TLR*TLR+0.11116*TLR**3.
          GO TO 7000
        END IF
        REFS(IC,1)=    (U*TAN2+V*TANX+W+ZZZ*(1+TAN2))
        IF (REFS(IC,1 ).GT.0.) THEN
          REFS(IC,1)= SQRT(REFS(IC,1))
        ELSE
          WRITE (6,3456) POS,IPHASE
          WRITE (7,3456) POS,IPHASE
          STOP 'SQUARE OF FWHM IS NEGATIVE'
        END IF
7000    REFS(IC,2)=POS
        REFS(IC,3)=PLOR
3118    CONTINUE
      if(lqmod(iphase))then
        GOTO 2244
      else
        GOTO 2233
      endif
6001  WRITE(6,24) IRS
      WRITE(7,24) IRS
24    FORMAT (//'TOO MANY REFLECTIONS, INCREASE *IRS* IN THE PARAMETER
     *  STATEMENT IN THE SOURCE CODE ')
      STOP
C     GO TO 2303
      END
      SUBROUTINE calmod(NN)
      PARAMETER (idsz=16384 ,irs=2048,NATS=64,msz=128 ,nov=512)
      REAL LAMDA
      INTEGER PTR
      COMMON/REFLS/IREFS(IRS),REFS(IRS,3),FF(IRS),IC(8)
     *  ,HALFL(IRS),HALFG(IRS),GAM(IRS),mm(irs)
      COMMON/G1/THMIN,STEP,THMAX,U,V,W,LAMDA(2),TMV,CTHM,RLIM,SBX,WDT
     * ,ULOR,VLOR,ZZZ
      COMMON/CNTRLS/JOBTYP,NPROF,NPHASE,IOT,IPL,IPC,MAT,NXT,LST1,LST2,
     * LST3,IPL1,IPL2,IPLST,MCYCLE,EPS,MAXS,INSTRM,MAXSX,MCYCLX,ICYRUN
     * ,IPREF
      COMMON/PARAMS/GLB(16),AGLB(16),LGLB(16),PAR(8,20),APAR(8,20),
     * LPAR(8,20),XL(NATS,17),LP(NATS,17),A(NATS,17),
     *  PTR(NATS),RELAX(4),RATIO(2)
      CHARACTER*4 ATEXT(NATS),NTYP(NATS)
      COMMON/PARAC/ATEXT,NTYP
      COMMON/JNK/ALOW(30),AHIGH(30),POS(30),BCK(30),
     * NATOM(8),NEQC(8),NINEQC(8),PREF(8,3),NBCKGD,NEXCRG,NSCAT
      CHARACTER SYMB(8,20)*1
      CHARACTER TITLE*70,PHSNM(8)*70
      COMMON/CHAR/SYMB,TITLE,PHSNM
      COMMON/COEFF/AC(10,16),POSI(30),SCAT(30),DFP(16),DFPP(16)
      CHARACTER*4 NAM(16)
      COMMON/COEFC/NAM
      COMMON/DATAX/Y(IDSZ),VAR(IDSZ),YC(IDSZ),KR(IDSZ),BK(IDSZ),NPTS
      COMMON/RTMTX/IVEC(8,192),MLT(8),ICET(8)
      COMMON/G4/TANN(NOV),DERSTO(NOV,MSZ)
***mod
      logical lqmod
      common/qmpd1/ nmodon(8),mordlim(8),qmodic(8,3),qmodrc(8,3),
     *ssgrp(8,20),qmsym(4,5,100),qmodbc,qmodac,lqmod(8)
***mod
      DIMENSION HNN(3),XI(17),hmm(3),hr(3)
      DIMENSION DERIV(MSZ),SNX(NATS),SINTL(NOV),SA(NATS),SB(NATS)
      DIMENSION TEMP(NATS),SNEX(NATS),T(3),SUMAX(NATS,9),SUMBX(NATS,9)
      DIMENSION H(3),AL(3,3),SM(3,3), darg(20), dudu(20)
      LOGICAL VERT,PAC,debug
      PI=360./3.14159265359
      twopi = 6.28318530718
      IPH=IREFS(NN)/256/256/256/8
      IOF=0
      IF(IPH.GT.1)THEN
      DO 4340 IIPHAS=2,IPH
4340  IOF=IOF + NATOM(IIPHAS-1)
      ENDIF
      IRL=MLT(IPH)
      N=NATOM(IPH)
      ICENT=ICET(IPH)
C-----ZEROIZE THE DERIVATIVES OF THIS REFLECTION W.R.T. TO PARAMETERS
      NX=0
      DO 4310 IIPHAS=1,NPHASE
4310    NX=NX+NATOM(IIPHAS)
      DO 12 I=1,MSZ
12      DERIV(I)=0.
      DO 21 I=1,NX
        DO 21 J=1,9
          SUMBX(I,J)=0.
21        SUMAX(I,J)=0.
      CV=0.
      DV=0.
      AV=0.
      BV=0.
      PAC=PAR(IPH,12).NE.0.0.OR.LPAR(IPH,12).NE.0
     * .OR.PAR(IPH,13).NE.0.0.OR.LPAR(IPH,13).NE.0
* assign values of reciprocal squared latt params
*
      DO 303 I=1,3
303     AL(I,I)=PAR(IPH,I+5)
      AL(2,3)=PAR(IPH,9)
      AL(1,3)=PAR(IPH,10)
      AL(1,2)=PAR(IPH,11)
*      if(debug)write(*,1200)(al(i,i),i=1,3),al(2,3),al(1,3),al(1,2)
*1200   format(' The al(i,j) matrix values are:',6f8.4)
      AH=PAR(IPH,3)
      BH=PAR(IPH,4)
      CH=PAR(IPH,5)
      IF (NPROF.EQ.8) THEN
        DH=PAR(IPH,20)
        AH2=PAR(IPH,15)
        BH2=PAR(IPH,16)
      END IF
      B1=PAR(IPH,12)
      B2=PAR(IPH,13)
      NM=MOD(NN,NOV)+1
      ICX=MOD(IREFS(NN)/256/256/256,8)
      SLABDA=LAMDA(ICX)*LAMDA(ICX)/4.
      N=NATOM(IPH)
      FF(NN)=0.
      PAKNN=0.
      PRECOR=1.
      TR=0.
      HNN(3)=MOD(IREFS(NN),256)-128
      HNN(2)=MOD(IREFS(NN)/256,256)-128
      HNN(1)=MOD(IREFS(NN)/256/256,256)-128
      hm = mm(nn)
      if(hnn(1).eq.1.0.and.hnn(2).eq.1.0.and.hnn(3).eq.1.0)then
        debug = .true.
      else
        debug = .false.
      endif
      DO 1 I=1,3
        H(I)=HNN(I)
        hmm(i) = hnn(i) + hm*qmodic(iph,i)
1     continue
C-----CALCULATION OF TEMP.FACTOR,POSITION AND HALFWIDTH
      SS=0.
      DO 2 I=1,3
        DO 2 J=I,3
2         SS=AL(I,J)*Hmm(I)*Hmm(J)+SS
      IF(.NOT.PAC)GOTO 13
      TT=0.
      DO 16 I=1,3
        DO 16 J=I,3
16        TT=TT+AL(I,J)*PREF(IPH,I)*PREF(IPH,J)
      PAK=0.
      DO 33 I=1,3
        DO 33 J=I,3
33        PAK=AL(I,J)*(PREF(IPH,I)*hnn(J)+PREF(IPH,J)*hnn(I))/2.+PAK
      PAK=PAK*PAK/(TT*SS)
      PAKNN=1.57079633268**2
      IF(PAK.NE.0)PAKNN=ATAN(SQRT(ABS((1.-PAK)/PAK)))**2
      IF (IPREF.EQ.0) THEN
          PREXP=EXP(B1*PAKNN)
          PRECOR=B2+(1.-B2)*PREXP
      ELSE
          PREXP= B1*B1*PAK + (1.-PAK)/B1
          PRECOR=1./PREXP**1.5
      END IF
13    SINTL(NM)=SQRT(SS)
      SSNN=0.25*SS
      TAV=EXP(-2.*PAR(IPH,2)*SSNN)*PRECOR
      SINTH=SLABDA*SS
      COSTH=1.-SINTH
      TANTH=SQRT(SINTH/COSTH)
      TANN(NM)=TANTH
      REFS(NN,2)=ATAN(TANTH)*PI
      HALFG(NN) =     (AH*TANTH*TANTH+BH*TANTH+CH+DH/COSTH)
      IF (HALFG(NN).GT.0.) THEN
        HALFG(NN) = SQRT(HALFG(NN))
      ELSE
        WRITE (6,3456) REFS(NN,2),IPH
        WRITE (7,3456) REFS(NN,2),IPH
        STOP 'SQUARE OF FWHM IS NEGATIVE'
3456    FORMAT (3X,'SQUARE OF FWHM NEGATIVE AT TWO-THETA',F8.3,
     *     'FOR PHASE NO. ',I4)
      END IF
      IF (NPROF.EQ.8) THEN
        HALFL(NN) = AH2*TANTH+BH2*SQRT(1.+TANTH*TANTH)
        BB = (HALFG(NN)**5.+2.69269*HALFG(NN)**4.*HALFL(NN)+
     *     2.42843*HALFG(NN)**3.*HALFL(NN)**2.+
     *        4.47163*HALFG(NN)**2.*HALFL(NN)**3. +
     *           0.07842*HALFG(NN)*HALFL(NN)**4. + HALFL(NN)**5.)**0.2
        TLR = HALFL(NN)/BB
        GAM(NN) = 1.36603*TLR-0.47719*TLR*TLR+0.11116*TLR**3.
      ELSE
        BB = HALFG(NN)
      END IF
C     IF(LEGVAR(BB).EQ.-1)BB=STEP/4.
      TL=BB
      REFS(NN,1)=BB
      BB=BB*BB
C-----VERT=.TRUE. IF ASYMMETRY CORRECTION IS TO BE CALCULATED
      VERT=.FALSE.
      IF(REFS(NN,2).LE.RLIM)VERT=.TRUE.
C-----CALCULATION OF COS(H.X),SIN(H.X) AND TEMP. FACTOR FOR EACH ATOM
* loop over atoms
3     DO 8 I=1,N
        SNXI=0.
        SAI=0.
        SBI=0.
* put atom param's into xi array
        DO 9 J=1,17
9         XI(J)=XL(I+IOF,J)
*loop over symmetry sites/operators for this atom
* SM(i,j) is rotational operator and T(i) trans vector
        DO 10 IR=1,IRL
          DO 301 J=1,3
            IV=IVEC(IPH,IR)/32768/32**(3-J)
            IV=MOD(IV,32)
            SM(J,1)=IV/9-1
            SM(J,2)=MOD(IV/3,3)-1
            SM(J,3)=MOD(IV,3)-1
301         T(J)=FLOAT(MOD(IVEC(IPH,IR)/32**(3-J),32)-16)/12.0
*          if(debug)write(*,1201)(((sm(jj,kk),kk=1,3),t(jj)),jj=1,3)
*1201      format(' The sym matrix is:',4f8.4,/,
*     *           '                   ',4f8.4,/ ,
*     *           '                   ',4f8.4)
          X=0.
          DO 6 II=1,3
            YY=0.
            zz = 0.0
            X=T(II)*HNN(II)+X
            DO 7 J=1,3
              YY=SM(J,II)*HNN(J)+YY
              zz = zz + sm(j,ii)*hmm(j)
7           continue
            H(II)=YY
            hr(ii) = zz
6         continue
          TR=X
          ARG=TR
          ux = 0.0
          uy = 0.0
          DO 11 J=1,3
            ARG=H(J)*XI(J)+ARG
            ux = ux + hr(j)*xi(j+11)*sqrt(al(j,j))
            uy = uy + hr(j)*xi(j+14)*sqrt(al(j,j))
11        continue
          ARG=twopi*ARG
          ARG2=H(1)*H(1)*XI(6)+H(2)*H(2)*XI(7)+
     *        H(3)*H(3)*XI(8)+2.*H(1)*H(2)*XI(9)+2.*
     *              H(1)*H(3)*XI(10)+2.*H(2)*H(3)*XI(11)
          EXPARG=EXP(-ARG2)
          u = sqrt(ux**2 + uy**2)
          if(u.eq.0.0)then
            chi = 0.0
          else
            chi = atan2(ux,uy)
          endif
*          sinmchi = sin(hm*chi)
*          cosmchi = cos(hm*chi)
          arg = arg + hm*chi
          COSA=COS(ARG)*EXPARG
          SINA=SIN(ARG)*EXPARG
          call bessel(hm,twopi*u,bess,dbess) 
          aterm = COSA*bess
          bterm = SINA*bess
          SAI=SAI+aterm
          SBI=SBI+bterm
* write values for debug purposes
      if(debug.and.i.eq.1.and.ir.eq.1)write(*,1210)(int(hnn(j)),j=1,3)
     * ,int(hm)
      if(debug.and.ir.eq.1)write(*,1212)
      if(debug)write(*,1211)i,ir,aterm,bterm,chi,bess,sai,sbi
1210  format(' For Reflection',4i4)
1212  format(/,' atom  aterm   bterm    chi    bess     sai     sbi')
1211  format(1x,i2,1x,i2,6f8.4)
* calc partial derivative terms
*
* calc d_arg/d_*
*
          do jj=1,3
            darg(jj) = twopi * hnn(jj)
            darg(jj+9) = hm * uy * hmm(jj) / u**2
            darg(jj+12) = -hm * ux * hmm(jj) / u**2
            dudu(jj) = 0.0
            dudu(jj+9) = ux * hmm(jj) * sqrt(al(jj,jj)) / u
            dudu(jj+12) = uy * hmm(jj) * sqrt(al(jj,jj)) / u
          enddo
          
          DO 14 JJ=1,3
            SUMAX(I,JJ)=SUMAX(I,JJ) - darg(jj)*bterm
14          SUMBX(I,JJ)=SUMBX(I,JJ) + darg(JJ)*aterm
          SUMAX(I,4)=SUMAX(I,4)+H(1)*H(1)*aterm
          SUMAX(I,5)=SUMAX(I,5)+H(2)*H(2)*aterm
          SUMAX(I,6)=SUMAX(I,6)+H(3)*H(3)*aterm
          SUMAX(I,7)=SUMAX(I,7)+H(1)*H(2)*aterm
          SUMAX(I,8)=SUMAX(I,8)+H(1)*H(3)*aterm
          SUMAX(I,9)=SUMAX(I,9)+H(2)*H(3)*aterm
*          IF(ICENT.NE.1)GOTO 10
          SUMBX(I,4)=SUMBX(I,4)+H(1)*H(1)*bterm
          SUMBX(I,5)=SUMBX(I,5)+H(2)*H(2)*bterm
          SUMBX(I,6)=SUMBX(I,6)+H(3)*H(3)*bterm
          SUMBX(I,7)=SUMBX(I,7)+H(1)*H(2)*bterm
          SUMBX(I,8)=SUMBX(I,8)+H(1)*H(3)*bterm
          SUMBX(I,9)=SUMBX(I,9)+H(2)*H(3)*bterm
10        CONTINUE
        TEMP(I)=EXP(-XL(I+IOF,4)*SSNN)
        SA(I)=SAI
        SB(I)=SBI
        NI=PTR(I+IOF)
        BNI=DFPP(NI)
        FFX=DFP(NI)
        AC(10,NI)=0.
        DO 302 II=1,9,2
302       FFX=FFX+AC(II,NI)*EXP(-AC(II+1,NI)*SSNN)
        SNEXI=FFX*XL(I+IOF,5)*TEMP(I)
        SNXI=BNI*XL(I+IOF,5)*TEMP(I)
C-----CALCULATE A AND B OF F
        AV=SNEXI*SAI+AV
        BV=SNEXI*SBI+BV
        SNEX(I)=2.*SNEXI*TAV*RATIO(ICX)
        SNX(I)=2.*SNXI*TAV*RATIO(ICX)
        CV=CV+SNXI*SAI
        DV=DV+SNXI*SBI
8       CONTINUE
      FNN=RATIO(ICX)*(CV*CV+AV*AV+DV*DV+BV*BV)*TAV
120   FF(NN)=FNN
      if(debug)write(*,1205)fnn
1205   format(' Structure Factor squared:',f10.2)
*if only calc pattern then don't calc deriv's
*
      IF(MAXS.EQ.0)RETURN
C-----CALCULATE DERIVATIVES
      DO 17 I=1,N
        SNEXI=SNEX(I)
        SNXI=SNX(I)
        SAI=SA(I)
        SBI=SB(I)
        DO 22 J=1,11
          K=LP(I+IOF,J)
          IF(K.EQ.0) GOTO22
          IF(J.GT.5) GOTO 221
          IF(J.GT.3)GOTO 29
          SUMA=SUMAX(I,J)
          SUMB=SUMBX(I,J)
          DER=-((AV*SUMA-BV*SUMB)*SNEXI+(CV*SUMA-DV*SUMB)*SNXI)*twopi
          GOTO 26
29        IF(J.GT.4)GOTO 31
          DER=-((SAI*AV+SBI*BV)*SNEXI+(SAI*CV+SBI*DV)*SNXI)*SSNN
          GOTO 26
31        DER=((SAI*AV+SBI*BV)*SNEXI+(SAI*CV+SBI*DV)*SNXI)/XL(I+IOF,5)
          GOTO 26
221       SUMA=SUMAX(I,J-2)
          SUMB=SUMBX(I,J-2)
          DER=-((AV*SUMA+BV*SUMB)*SNEXI+(CV*SUMA+DV*SUMB)*SNXI)
          IF(J.GE.9)DER=2.*DER
26        DERIV(K) = SIGN(1.,A(I+IOF,J))*DER+DERIV(K)
22        CONTINUE
17      CONTINUE
C-----CALCULATE DERIVATIVES
      K=LPAR(IPH,12)
      IF (IPREF.EQ.0) THEN
        IF(K.NE.0)DERIV(K)=DERIV(K)+ PAKNN*(1.-B2)*PREXP
     *                      *FNN/PRECOR
      ELSE
        IF(K.NE.0)DERIV(K)=DERIV(K)-1.5/PREXP**2.5 *( 2.*B1*PAK -
     *                      (1.-PAK)/B1/B1 )*FNN/PRECOR
      ENDIF

      K=LPAR(IPH,13)
      IF (IPREF.EQ.0) THEN
        IF(K.NE.0)DERIV(K)=DERIV(K)+(1.-PREXP)*FNN/PRECOR
      ELSE
        IF (K.NE.0) THEN
           WRITE (6,7607)
           STOP
        ENDIF
      ENDIF
7607    FORMAT (1X,'G2 IS NOT A REFINABLE PARAMETER FOR IPREF = 1')
      K=LPAR(IPH,2)
      IF(K.NE.0)DERIV(K)=DERIV(K)-2.*SSNN*FNN
      K=LPAR(IPH,1)
      IF(K.NE.0)DERIV(K)=DERIV(K)+FNN/PAR(IPH,1)
C     DO 15 J=8,9
      K=LGLB(8)
      IF(K.NE.0.AND.(NPROF.EQ.6.OR.NPROF.EQ.7))DERIV(K)=DERIV(K)+FNN
      K=LGLB(9)
      IF(K.NE.0.AND.NPROF.EQ.5) DERIV(K)=DERIV(K)+FNN
C  15 CONTINUE
      SINTH=FNN*PI*SLABDA/(SQRT(SINTH*COSTH)*BB)
      SS=FNN/TL
      X=TANTH*TANTH
      IF (NPROF.EQ.8) GO TO 9211
      DO 78 J=3,5
        K=LPAR(IPH,J)
        IF(K.EQ.0)GOTO 78
        DERIV(K)=X*SS+DERIV(K)
78      X=X/TANTH
9211  CONTINUE
      IF (NPROF.EQ.8) THEN
        TL = REFS(NN,1)
        TLG = HALFG(NN)
        TLL = HALFL(NN)
        DHDHG = 0.2/TL**4.*(5.*TLG**4.+10.77076*TLG**3.*TLL+
     *        7.28529*TLG*TLG*TLL*TLL+8.94326*TLG*TLL**3.
     *         + 0.07842*TLL**4.)
        DHDHL = 0.2/TL**4.*(2.69269*TLG**4.+ 4.85686*TLG**3.*TLL
     *      +13.41489*TLG*TLG*TLL*TLL + 0.31368*TLG*TLL**3.+5.*TLL**4.)
        DO 9078 J=3,5
          K=LPAR(IPH,J)
          IF(K.EQ.0)GOTO 9078
          DERIV(K)=DHDHG*X*SS+DERIV(K)
9078      X=X/TANTH
        K=LPAR(IPH,20)
        IF  (K.NE.0) DERIV(K)=DHDHG*SS/COSTH  + DERIV(K)
        K = LPAR(IPH,15)
        IF (K.EQ.0) GO TO 9213
        DERIV(K) = 2.*FNN*DHDHL*TANTH + DERIV(K)
9213    CONTINUE
        K = LPAR(IPH,16)
        IF (K.EQ.0) GO TO 9214
        DERIV(K) = 2.*FNN*DHDHL/SQRT(COSTH) + DERIV(K)
9214    CONTINUE
      END IF
      K = LPAR(IPH,17)
      IF(K.NE.0.AND.(NPROF.EQ.6.OR.NPROF.EQ.7)) DERIV(K)=DERIV(K)+ FNN
      K = LPAR(IPH,18)
      IF(K.NE.0.AND.NPROF.EQ.6) DERIV(K)=DERIV(K)+ FNN * REFS(NN,2)
      IF(K.NE.0.AND.NPROF.EQ.7) DERIV(K)=DERIV(K)+ FNN / REFS(NN,2)
      K = LPAR(IPH,19)
      IF(K.NE.0.AND.NPROF.EQ.7)DERIV(K)=DERIV(K)+FNN/REFS(NN,2)
     !                                              /REFS(NN,2)
      K=LGLB(1)
      IF(K.NE.0)DERIV(K)=2.*FNN/BB+DERIV(K)
      K=LGLB(10)
      IF (K.NE.0) DERIV(K) = DERIV(K)+2.*FNN/BB*SQRT(COSTH)
      K=LGLB(11)
      IF (K.NE.0) DERIV(K) = DERIV(K)+2.*FNN/BB*SIN(REFS(NN,2)/57.2958)
      DO 79 J=1,6
        K=LPAR(IPH,J+5)
        IF(K.EQ.0)GOTO 79
        IF(J.LT.4)X=hmm(J)*hmm(J)
        IF(J.EQ.4)X=hmm(2)*hmm(3)
        IF(J.EQ.5)X=hmm(1)*hmm(3)
        IF(J.EQ.6)X=hmm(1)*hmm(2)
        DERIV(K)=X*SINTH+DERIV(K)
79      CONTINUE
      K=LPAR(IPH,14)
      IF((K.NE.0).AND.VERT)DERIV(K)=-FNN/TANTH+DERIV(K)
C-----STORE DERIVATIVES FOR LIMO REFLECTIONS AT A TIME
      DO 80 I=1,MAXS
80      DERSTO(NM,I)=DERIV(I)
48    RETURN
      END
*
* subroutine to calculate a bessel function value and its derivative
      subroutine bessel(hm,x,bess,dbess)
*
      double precision sterm, sum, dterm, dsum, coef, dcoef
*
      m = int(hm)
      if(m.lt.0)then
        neg = 1
        m = abs(m)
      else
        neg = 0
      endif
* calculate the coefficient part of the bessel function
*
      coef = 1.0
      dcoef = real(m)
      do i=0,m-1
        coef = coef * ( x / ( 2.0 * real(m-i) ) )
        if(i.eq.0)then
          dcoef = dcoef * ( 1 / ( 2.0 * real(m-i) ) )
        else
          dcoef = dcoef * ( x / ( 2.0 * real(m-i) ) )
        endif
      enddo
*
* calculate the sum part of the function
      sum = 1.0
      dsum = 0.0
      do i=1,25
        sterm = 1.0
        dterm = 2.0 * real(i)
        do k=1,i
          sterm = sterm * (((x*x)*(-1))/(4 * (i-k+1) * (m+k) ))
          if(k.eq.1)then
            dterm = dterm * (((x)*(-1))/(4 * (i-k+1) * (m+k) ))
          else
            dterm = dterm * (((x*x)*(-1))/(4 * (i-k+1) * (m+k) ))
          endif
        enddo
        sum = sum + sterm
        dsum = dsum + dterm
        if(abs(sterm).lt.0.0000001)goto 110
      enddo
* multiply the coefficient and sum parts
 110  bess = coef * sum
      dbess = coef * dsum + dcoef * sum
      if(neg.eq.1)then
        bess = bess * (-1)**m
        dbess = dbess * (-1)**m
      endif
      return
      end

