From:	AUVAX::SE%"BROWN@nflett.UU.SE" 27-MAR-1989 04:06
To:	SNYDER@CERAMICS.BITNET
Subj:	3 of 4

Received: From SEMAX51(MAILER) by CERAMICS with Jnet id 8131
          for SNYDER@CERAMICS; Mon, 27 Mar 89 04:03 EDT
Date: Mon, 27 Mar 89 10:56 +0100
From: BROWN@nflett.UU.SE
Subject: 3 of 4
To: SNYDER@CERAMICS.BITNET
X-VMS-To: BMC1::IN%"SNYDER@CERAMICS"
 
      PROGRAM LPX2
C
C-----******************************************************************
C-----*                                                                *
C-----*                                                                *
C-----*              P  U  L  V  E  R  I  X                            *
C-----*                                                                *
C-----*                                                                *
C-----******************************************************************
C-----*                                                                *
C-----* ROUTINE TO CALCULATE THEORETICAL POWDER PATTERNS               *
C-----* USING THE DATA FILE PREPARED BY  L  A  Z  Y                    *
C-----*                                                                *
C-----* AUTHORS                                                        *
C-----* K.YVON, W.JEITSCHKO  AND E.PARTHE                              *
C-----*                                                                *
C-----* ADDRESS                                                        *
C-----* LABORATOIRE DE CRISTALLOGRAPHIE AUX RAYONS X                   *
C-----* UNIVERSITY OF GENEVA                                           *
C-----* 24 QUAI ERNEST ANSERMET , CH 1211 GENEVE, SWITZERLAND          *
C-----* TEL  022 219355                                                *
C-----*                                                                *
C-----******************************************************************
C-----*                                                                *
C-----* R E M A R K S    FOR ADAPTING THE PROGRAM                      *
C-----*                                                                *
C-----* THIS IS THE IBM 370/165 VERSION. IF YOU HAVE A CDC-COMPUTER    *
C-----* REPLACE ALL CARDS THAT ARE FOLLOWED  BY A CARD MARKED C-CDC    *
C-----*                                                                *
C-----* THE FOLLOWING PARAMETERS CAN BE CHANGED IN THE BEGINNING OF    *
C-----* THE SOURCE DECK , THE ACTUAL VALUES GIVEN TO THESE             *
C-----* PARAMETERS ARE IN PARENTHESES                                  *
C-----*                                                                *
C-----* ILU        INPUT UNIT FROM  L A Z Y   (11)                     *
C-----* IPR        LINE PRINTER (6)                                    *
C       IMU        OUTPUT UNIT FOR MULTI FILE (TO CPDF)
C-----*                                                                *
C-----* LIMIT1     LIMIT ON NUMBER OF REFLECTIONS  (2000)              *
C-----*            DIMENSIONS TO BE CHANGED                            *
C-----*            Q,YH,YK,YL,THETA,SUMA,SUMB,VINT,STRU,FPLG,FMUL,     *
C-----*            AX,AY,BX,BY,IDE                                     *
C-----*                                                                *
C-----* LIMIT2     LIMITATION ON DIFFERENT KINDS OF ATOMS (8)          *
C-----*            DIMENSIONS TO BE CHANGED                            *
C-----*            NA,X,Y,Z,FNEUT,BTEMP,ELEMT,FOCCU,DELFR,DELFI,       *
C-----*            FMULT,FA,FB,FC,IDE                                  *
C-----*                                                                *
C-----* LIMIT3     LIMIT ON NUMBER OF ATOMS OF ONE KIND   (50)         *
C-----*            DIMENSIONS TO BE CHANGED                            *
C-----*            X,Y,Z,BTEMP,FOCCU,FMULT,IDE                         *
C-----*                                                                *
C-----* LIMIT4     LIMIT ON NUMBER OF EQUIVALENT POINTPOSITIONS (24)   *
C-----*            DIMENSIONS TO BE CHANGED    TS, FS                  *
C-----*                                                                *
C-----* DG1        D-SPACING OF REFLECTING PLANES OF MONOCHROMATOR     *
C-----*            IN GUINIER CAMERA 1 (3.343)   QUARZ (101)           *
C-----*                                                                *
C-----* DG2        D-SPACING OF REFLECTING PLANES OF MONOCHROMATOR     *
C-----*            IN GUINIER CAMERA 2 (3.343)   QUARZ (101)           *
C-----*                                                                *
C-----* DM1        DIAMETER OF GUINIER CAMERA 1 IN MM (114.6)          *
C-----* BG1        ANGLE BETWEEN NORMAL TO THE SPECIMEN AND INCIDENT   *
C-----*            BEAM FOR CAMERA 1 (30 DEGREES)                      *
C-----* DG4        D-SPACING OF REFLECTING PLANES OF MONOCHROMATOR     *
C-----*            IN SYNCHRTOTRON (HASYLAB) (2.237) QUARTZ (111)      *
C-----* DM4        ANGLE BETWEEN NORMAL TO THE SPECIMEN AND INCIDENT   *
C-----*            BEAM FOR SYNCHROTRON (HASYLAB) (45 DEGREES)         *
C-----*                                                                *
C-----* DM2        DIAMETER OF GUINIER CAMERA 2 IN MM (100.0)          *
C-----* BG2        ANGLE BETWEEN NORMAL TO THE SPECIMEN AND INCIDENT   *
C-----*            BEAM FOR CAMERA 2 (30 DEGREES)                      *
C-----* GUINIER CAMERA 1  CORRESPONDS TO THE GUINIER CAMERAS WITH      *
C-----* PSI = 30 DEGREES IE, DE WOLFF (NONIUS) OR HAEGG CAMERAS        *
C-----* GUINIER CAMERA 2  CORRESPONDS TO GUINIER CAMERAS WITH PSI = 45 *
C-----* ACCORDING TO JAGODZINSKI EG HUBER CAMERAS                      *
C-----*                                                                *
C-----******************************************************************
      DOUBLE PRECISION PI2,ARG,SMA,SMB,SUMA,SUMB,STRU,PRPINT
      DIMENSION Q(2000), YH(2000), YK(2000), YL(2000), THETA(2000), SUMA
     1(2000), SUMB(2000), VINT(2000), NA(8), X(50,8), Y(50,8), Z(50,8),
     2FNEUT(8), BTEMP(50,8), ELEMT(8), IPLA(100), COMPND(19), SP(1900),
     3W(900), FOCCU(50,8), STRU(2000), FPLG(2000), FMUL(2000), DELFR(8),
     4DELFI(8), FMULT(50,8), IDT(9), IDL(30), TS(3,24), FS(3,3,24), FA(4
     5,8), FB(4,8), FC(8), AX(2000), AY(2000), BX(2000), BY(2000), IDE(5
     60,8), ITIT(13), NT(36), JB(21), L1(7), L2(7), L3(4), L4(2), L5(2),
     7 L6(2)
      COMMON /UNITS/ IPR,IMU
      COMMON /EQUIV/ TS,FS,NS,ISYMCE,IBRAVL
      CHARACTER*15 MUFIL,LISTB,LPX12
      DATA ITIT(1)/' FOL'/,ITIT(2)/'LOWS'/,ITIT(3)/' OMI'/,ITIT(4)/'TTED
     1'/,ITIT(5)/' MM'/,ITIT(6)/'   '/,ITIT(7)/'2TH'/,ITIT(8)/'ETA'/,ITI
     2T(9)/' NOT'/,ITIT(10)/'LOW '/,ITIT(11)/'HIGH'/,ITIT(12)/'NO'/,ITIT
     3(13)/' A'/
      DATA JB(1)/'PRIM'/,JB(2)/'ITIV'/,JB(3)/'E   '/,JB(4)/'BODY'/,JB(5)
     1/' CEN'/,JB(6)/'TRED'/,JB(7)/'RHOM'/,JB(8)/'BOHE'/,JB(9)/'DRAL'/,J
     2B(10)/'FACE'/,JB(11)/' CEN'/,JB(12)/'TRED'/,JB(13)/'A -C'/,JB(14)/
     3'ENTR'/,JB(15)/'ED  '/,JB(16)/'B -C'/,JB(17)/'ENTR'/,JB(18)/'ED  '
     4/,JB(19)/'C -C'/,JB(20)/'ENTR'/,JB(21)/'ED  '/
      DATA L1(1)/'NONE'/,L1(2)/'H+K+'/,L1(3)/'-H+K'/,L1(4)/'H,K,'/,L1(5)
     1/'K+L='/,L1(6)/'H+L='/,L1(7)/'H+K='/,L2(1)/'    '/,L2(2)/'L=2N'/,L
     22(3)/'+L=3'/,L2(4)/'L AL'/,L2(5)/'2N+1'/,L2(6)/'2N+1'/,L2(7)/'2N+1
     3'/,L3(1)/'    '/,L3(2)/'    '/,L3(3)/'N   '/,L3(4)/'L EV'/,L4(1)/'
     4    '/,L4(2)/'EN O'/,L5(1)/'    '/,L5(2)/'R OD'/,L6(1)/'    '/,L6(
     52)/'D   '/,L7/'WITH'/
      DATA ISTA/'*'/,IBLNK/' '/
      DATA IDT(1)/'1'/,IDT(2)/'2'/,IDT(3)/'3'/,IDT(4)/'4'/,IDT(5)/'5'/,I
     1DT(6)/'6'/,IDT(7)/'7'/,IDT(8)/'8'/,IDT(9)/'9'/
      DATA IDL(1)/' DEB'/,IDL(2)/'YE S'/,IDL(3)/'CHER'/,IDL(4)/'RER '/,I
     1DL(5)/'    '/,IDL(6)/'SPEC'/,IDL(7)/'IAL '/,IDL(8)/'WITH'/,IDL(9)/
     2' LP='/,IDL(10)/'1   '/,IDL(11)/' NEU'/,IDL(12)/'TRON'/,IDL(13)/'
     3DIF'/,IDL(14)/'FRAC'/,IDL(15)/'TION'/,IDL(16)/'    '/,IDL(17)/' GU
     4I'/,IDL(18)/'NIER'/,IDL(19)/' CAM'/,IDL(20)/'ERA '/,IDL(21)/' GUI'
     5/,IDL(22)/'NIER'/,IDL(23)/' CAM'/,IDL(24)/'ERA '/,IDL(25)/'    '/,
     6IDL(26)/' SYN'/,IDL(27)/'CHRO'/,IDL(28)/'TRON'/,IDL(29)/' HAS'/,
     7IDL(30)/'YLAB'/
C-----
      OPEN ( 6,FILE = 'PULVX.OUT',STATUS = 'NEW')
      OPEN (11,FILE = 'PULVX.INP',STATUS = 'OLD',FORM = 'UNFORMATTED')
C     OPEN (12,FILE = 'LPLOT.INP',STATUS = 'OLD',FORM = 'FORMATTED')
      OPEN (16,FILE = 'RTVPR.INP',STATUS = 'NEW',CARRIAGECONTROL='LIST')
      OPEN (17,FILE = 'RTVRF.INP',STATUS = 'NEW',CARRIAGECONTROL='LIST')
      OPEN (18,FILE = 'LPLOT.PLT',STATUS = 'NEW',CARRIAGECONTROL='LIST')
C
C     VERSION JAN. 27, 1989
C     STUDSVIK
C
C-----CHANGE THE FOLLOWING PARAMETERS IF NECESSARY
C-----
C     IPR="LISTB-FILE" PRINTER OUTPUT-FILE
      IPR=6
C     ILU="LPX12-TEMPORARY FILE, FROM LPX1"
      ILU=11
C
C
C     END OF VAX ADAPT.
      LIMIT1=2000
      LIMIT2=8
      LIMIT3=50
      LIMIT4=24
      DG1=3.343
      DG2=3.343
      DG4=2.237
      DM1=114.59156
      DM2=100.0
      DM3=79.88
      DM4=DM1
      BG1=30.
      BG2=30.
      BG4=45.
C-----
C-----END OF PARAMETERS
C-----
      NFI=0
      PI2=6.283185307179586D0
      E=2.7182818
      FRTD=4./3.
C-----READ INPUT FROM BINARY DATA FILE ILU
C-----READ NUMBER OF FILES ON ILU
      READ (ILU) NFIL
      WRITE (*,138)
 1    NFI=NFI+1
      WRITE (IPR,141)
      IF (NFI.LE.NFIL) GO TO 2
      WRITE (*,139)
      GO TO 137
 2    READ (ILU) (COMPND(I),I=1,19),A,B,C,ALPHA,BETA,GAMMA,WL,(NT(I),I=1
     1,36),IGROUP,INADD,INOLD
      IF (A.GT.0.) GO TO 3
      WRITE (IPR,140) NFI
      GO TO 1
 3    READ (ILU) ISYSTM,ISYMCE,IBRAVL,NS,TL,TH,NORM,IMAGE,ANO,KODLP,NCOM
     1PO,(NA(I),I=1,8),IHOO,IOKO,IOOL,IHHL,IHOL,IHKO,IOKL,LAUE
      IF (NS.GT.LIMIT4) GO TO 136
      IF (NCOMPO.GT.LIMIT2) GO TO 134
      READ (ILU) ((TS(I,II),(FS(K,I,II),K=1,3),I=1,3),II=1,NS)
      DO 4 M=1,NCOMPO
      NL=NA(M)
      IF (NL.GT.LIMIT3) GO TO 135
      READ (ILU) DELFR(M),DELFI(M)
      READ (ILU) ELEMT(M),(FA(I,M),FB(I,M),I=1,4),FC(M),FNEUT(M)
      READ (ILU) (ELEMT(M),IDE(I,M),X(I,M),Y(I,M),Z(I,M),FMULT(I,M),FOCC
     1U(I,M),BTEMP(I,M),I=1,NL)
 4    CONTINUE
      WRITE (IPR,142) NFI
C-----PRINT FIRST LINE OF TITLE
C-----SET VARIABLES BACK TO ORIGINAL VALUE
      VMXINT=0
      NLINE=0
      N=0
      ICON=0
      DUM=1.
      BGUIN=BG1
C-----
      DGU=DG1
C-----WINDOW OVERLAP FOR SUMMING INTENSITIES = 0.06 DEG 2*THETA
      WIN=0.03
C-----
      K=KODLP+1
      GO TO (7,7,7,5,6,300), K
C-----SYNCHROTRON GEOMETRY
 300  AGUIN=1.
      DURCHM=DM4
      DGU=DG4
      BGUIN=BG4
      GO TO 350
C-----GUINIER NONIUS/HAEGG GEOMETRY: PSI=30
 5    DURCHM=DM1
      BGUIN=BG1
      DGU=DG1
      GO TO 7
C-----GUINIER JAGODZINSKI (HUBER CAMERA) GEOMETRY: PSI=45
 6    DURCHM=DM1
      BGUIN=BG4
      DGU=DG2
C-----CALCULATE CORRECTION TERM FOR LP FACTOR
 7    AGUIN=(1-WL*WL/(2.*DGU*DGU))**2.
C-----MULTIPLICITY FOR BRAVAIS LATTICE
 350  FBRA=IBRAVL
      IF (FBRA.GT.4.) FBRA=2.
C-----MULTIPLIER IF CENTER OF SYMMETRY AT ORIGIN
      IF (ISYMCE.NE.0) DUM=2.
C-----CALCULATE SIN**2 THETA LIMITS
      SH=TH*PI2/360.
      SL=TL*PI2/360.
      SL=(SIN(SL))**2.
      SH=(SIN(SH))**2.
C-----PRINT TITLE
      WRITE (IPR,165) COMPND
      WLSQ4=WL**2/4.
      ASTAR=WLSQ4/A**2
      IF ((ISYSTM.EQ.1).OR.(ISYSTM.EQ.2).OR.(ISYSTM.EQ.7)) BSTAR=WLSQ4/B
     1**2
      IF (ISYSTM.NE.5) CSTAR=WLSQ4/C**2
      BET=BETA*PI2/360.
      SINB2=(SIN(BET))**2
      COSB=COS(BET)
C-----TRICLINIC CASE
      IF (ISYSTM.NE.7) GO TO 8
      ALPH=ALPHA*PI2/360.
      GAMM=GAMMA*PI2/360.
      SV=(ALPH+BET+GAMM)/2.
      VOL=2.*A*B*C*SQRT(SIN(SV)*SIN(SV-ALPH)*SIN(SV-BET)*SIN(SV-GAMM))
      AST=(B*C*SIN(ALPH))/VOL
      BST=(A*C*SIN(BET))/VOL
      CST=(A*B*SIN(GAMM))/VOL
      COAST=(COSB*COS(GAMM)-COS(ALPH))/(SIN(BET)*SIN(GAMM))
      COBST=(COS(GAMM)*COS(ALPH)-COSB)/(SIN(GAMM)*SIN(ALPH))
      COGST=(COS(ALPH)*COSB-COS(GAMM))/(SIN(ALPH)*SIN(BET))
C-----START LOOP TO FIND HKL LIMITS FOR GIVEN SL AND SH LIMITS
 8    ZH=0.
      ZK=0.
      ZL=0.
 9    ZH=ZH+1.
      GO TO (10,15,16,21,22,23,24), ISYSTM
C-----MONOCLINIC
 10   ZHTEST=(2.0*A*SQRT(SH))/WL
      IF (ZH.LE.ZHTEST) GO TO 13
      ZH=0.
      ZK=ZK+1.
      ZKTEST=(2.0*B*SQRT(SH))/WL
      IF (ZK.LE.ZKTEST) GO TO 10
      ZK=0.
      IF (ICON.EQ.0) GO TO 11
      ZL=ZL-1.
      GO TO 12
 11   ZL=ZL+1.
 12   ZLTEST=(2.0*C*SQRT(SH))/WL
      IF (ABS(ZL).LE.ZLTEST) GO TO 10
      IF (ICON.EQ.1) GO TO 14
      ICON=1
      GO TO 8
 13   ATEST=ASTAR*ZH**2/SINB2+BSTAR*ZK**2+CSTAR*ZL**2/SINB2-WLSQ4*2.*ZH*
     1ZL*COSB/(A*C*SINB2)
      IF (ATEST.GT.SH) GO TO 9
      IF ((ICON.EQ.0).OR.((ZH.GT.0.9).AND.(ZL.LT.(-0.9)))) GO TO 31
      GO TO 9
 14   WRITE (IPR,187)
      WRITE (IPR,168) A,B,C,BETA,WL
      GO TO 73
C-----ORTHORHOMBIC
 15   ATEST=ASTAR*ZH**2+BSTAR*ZK**2+CSTAR*ZL**2
      IF (ATEST.LE.SH) GO TO 31
      ZH=0.
      ZK=ZK+1.
      BTEST=BSTAR*ZK**2+CSTAR*ZL**2
      IF (BTEST.LE.SH) GO TO 15
      ZK=0.
      ZL=ZL+1.
      CTEST=CSTAR*ZL**2
      IF (CTEST.LE.SH) GO TO 15
      WRITE (IPR,189)
      WRITE (IPR,169) A,B,C,WL
      GO TO 73
C-----TRIGONAL
 16   ATEST=FRTD*ASTAR*(ZH**2+ZH*ZK+ZK**2)+CSTAR*ZL**2
      IF ((ZH.EQ.0.).AND.(ZL.EQ.0.)) GO TO 9
      IF (ATEST.LE.SH) GO TO 19
      ZH=0.
      ZK=ZK+1.
      BTEST=FRTD*ASTAR*ZK**2+CSTAR*ZL**2
      IF (BTEST.LE.SH) GO TO 16
      ZK=0.
      IF (ICON.EQ.0) GO TO 17
      ZL=ZL-1.
      GO TO 18
 17   ZL=ZL+1.
 18   CTEST=CSTAR*ZL**2
      IF (CTEST.LE.SH) GO TO 16
      IF (ICON.EQ.1) GO TO 20
      ICON=1
      GO TO 8
 19   IF ((ICON.EQ.0).OR.((ZL.LT.(-0.9)).AND.((ZH.NE.0.).AND.(ZK.NE.0.))
     1)) GO TO 31
      GO TO 9
 20   WRITE (IPR,190)
      GO TO 72
C-----TETRAGONAL
 21   ATEST=ASTAR*(ZH**2+ZK**2)+CSTAR*ZL**2
      IF (ATEST.LE.SH) GO TO 31
      ZH=ZK+1.
      ZK=ZH
      BTEST=ASTAR*2.*ZH**2+CSTAR*ZL**2
      IF (BTEST.LE.SH) GO TO 21
      ZH=0.
      ZK=0.
      ZL=ZL+1.
      CTEST=CSTAR*ZL**2
      IF (CTEST.LE.SH) GO TO 21
      WRITE (IPR,191)
      GO TO 72
C-----CUBIC
 22   ATEST=ASTAR*(ZH**2+ZK**2+ZL**2)
      IF (ATEST.LE.SH) GO TO 31
      ZH=ZK+1.
      ZK=ZH
      BTEST=ASTAR*(2.*ZH**2+ZL**2)
      IF (BTEST.LE.SH) GO TO 22
      ZH=ZL+1.
      ZK=ZH
      ZL=ZH
      CTEST=ASTAR*3.*ZH**2
      IF (CTEST.LE.SH) GO TO 22
      WRITE (IPR,192)
      WRITE (IPR,171) A,WL
      GO TO 73
C-----HEXAGONAL
 23   ATEST=FRTD*ASTAR*(ZH**2+ZH*ZK+ZK**2)+CSTAR*ZL**2
      IF (ATEST.LE.SH) GO TO 31
      ZH=ZK+1.
      ZK=ZH
      BTEST=FRTD*ASTAR*3.*ZH**2+CSTAR*ZL**2
      IF (BTEST.LE.SH) GO TO 23
      ZH=0.
      ZK=0.
      ZL=ZL+1.
      CTEST=CSTAR*ZL**2
      IF (CTEST.LE.SH) GO TO 23
      WRITE (IPR,193)
      GO TO 72
C-----TRICLINIC
 24   ZHTEST=(2.0*A*SQRT(SH))/WL
      IF (ZH.LE.ZHTEST) GO TO 29
      ZH=0.
      IF (ICON.LT.2) GO TO 25
      ZK=ZK-1.
      GO TO 26
 25   ZK=ZK+1.
 26   ZKTEST=(2.0*B*SQRT(SH))/WL
      IF (ABS(ZK).LE.ZKTEST) GO TO 24
      ZK=0.
      IF ((ICON.EQ.0).OR.(ICON.EQ.2)) GO TO 27
      ZL=ZL-1.
      GO TO 28
 27   ZL=ZL+1.
 28   ZLTEST=(2.0*C*SQRT(SH))/WL
      IF (ABS(ZL).LE.ZLTEST) GO TO 24
      ICON=ICON+1
      GO TO (8,8,8,30), ICON
 29   ATEST=WLSQ4*((ZH*AST)**2+(ZK*BST)**2+(ZL*CST)**2+2.*ZK*ZL*BST*CST*
     1COAST+2.*ZH*ZL*AST*CST*COBST+2.*ZH*ZK*AST*BST*COGST)
      IF (ATEST.GT.SH) GO TO 9
      IF (ICON.EQ.0) GO TO 31
      IF (((ZH.EQ.0.).AND.(ZK.EQ.0.)).OR.((ZK.EQ.0.).AND.(ZL.EQ.0.)).OR.
     1((ZH.EQ.0.).AND.(ZL.EQ.0.))) GO TO 9
      IF ((ICON.EQ.1).AND.(ZL.LT.(-0.9))) GO TO 31
      IF (((ICON.EQ.2).AND.(ZK.LT.(-0.9))).AND.(ZH.GT.0.9)) GO TO 31
      IF ((ICON.EQ.3).AND.((ZH*ZK*ZL).NE.0.)) GO TO 31
      GO TO 9
C-----PRINT TRICLINIC LATTICE CONSTANTS
 30   WRITE (IPR,188)
      WRITE (IPR,172) A,B,C,ALPHA,BETA,GAMMA,WL
      GO TO 73
 31   IF (ATEST.LT.SL) GO TO 9
      XH=ZH
      XK=ZK
      XL=ZL
C-----OMIT HKL VALUES CORRESPONDING TO BRAVAIS LATTICE EXTINCTIONS
 32   GO TO (40,33,34,35,36,37,38), IBRAVL
 33   TESTBR=(XH+XK+XL)/2.
      GO TO 39
 34   TESTBR=(-XH+XK+XL)/3.
      GO TO 39
 35   FACEHK=(XH+XK)/2.
      IF ((AINT(FACEHK)-FACEHK).NE.0.) GO TO 9
 36   TESTBR=(XK+XL)/2.
      GO TO 39
 37   TESTBR=(XH+XL)/2.
      GO TO 39
 38   TESTBR=(XH+XK)/2.
 39   IF ((AINT(TESTBR)-TESTBR).NE.0.) GO TO 68
C-----OMIT HKL VALUES CORRESPONDING TO EXTINCTIONS
 40   IF (XL.EQ.0.) GO TO (41,50,49,50,47), IHKO
 41   IF (XH.EQ.0.) GO TO (42,54,53,54,51), IOKL
 42   IF (XK.EQ.0.) GO TO (43,58,57,58,55), IHOL
 43   IF (XH.EQ.XK) GO TO (44,59,61), IHHL
      IF ((XK.EQ.XL).AND.(ISYSTM.EQ.5)) GO TO (44,62,44,63), IHHL
 44   IF (XK.EQ.0..AND.XL.EQ.0.) GO TO (45,64,133,64), IHOO
 45   IF (XH.EQ.0..AND.XL.EQ.0.) GO TO (46,65), IOKO
 46   IF (XH.EQ.0..AND.XK.EQ.0.) GO TO (67,66,66,66,133,66), IOOL
      GO TO 67
 47   FIHKO=XH/2.
 48   IF (AINT(FIHKO)-FIHKO) 68,41,68
 49   FIHKO=XK/2.
      GO TO 48
 50   HKO=IHKO
      FIHKO=(XH+XK)/HKO
      GO TO 48
 51   FIOKL=XK/2.
 52   IF (AINT(FIOKL)-FIOKL) 68,42,68
 53   FIOKL=XL/2.
      GO TO 52
 54   OKL=IOKL
      FIOKL=(XK+XL)/OKL
      GO TO 52
 55   FIHOL=XH/2.
 56   IF (AINT(FIHOL)-FIHOL) 68,43,68
 57   FIHOL=XL/2.
      GO TO 56
 58   HOL=IHOL
      FIHOL=(XH+XL)/HOL
      GO TO 56
 59   FIHHL=XL/2.
 60   IF (AINT(FIHHL)-FIHHL) 68,44,68
 61   FIHHL=(2.*XH+XL)/4.
      GO TO 60
 62   FIHHL=XH/2.
      GO TO 60
 63   FIHHL=(2.*XL+XH)/4.
      GO TO 60
 64   HOO=IHOO
      FIHOO=XH/HOO
      IF (AINT(FIHOO)-FIHOO) 68,45,68
 65   FIOKO=XK/2.
      IF (AINT(FIOKO)-FIOKO) 68,46,68
 66   OOL=IOOL
      FIOOL=XL/OOL
      IF ((AINT(FIOOL)-FIOOL).NE.0.) GO TO 68
C-----STORE HKL AND SIN2THETA VALUES OF F VALUES  TO BE CALCULATED
 67   N=N+1
C-----CHECK IF NUMBER OF REFLECTIONS TOO LARGE
      IF (N.GT.LIMIT1) GO TO 132
      Q(N)=ATEST
      YH(N)=XH
      YK(N)=XK
      YL(N)=XL
      JJ=N
      J=JJ-1
C-----SKIP REFLECTIONS RELATED BY LAUE SYMMETRY
 68   IF ((LAUE.EQ.2).OR.(ZH.EQ.XK)) GO TO 9
      GO TO (9,9,9,69,70,69,9), ISYSTM
 69   IF ((ZH.GT.ZK).AND.(ZK.GT.0.)) GO TO 71
      GO TO 9
 70   IF ((ZH.GT.ZK).AND.(ZK.GT.ZL)) GO TO 71
      GO TO 9
 71   TEMP=XH
      XH=XK
      XK=TEMP
      GO TO 32
C-----PRINT HEX AND TETRAG LATTICE CONSTANTS, END OF HKL GENER.LOOP
 72   WRITE (IPR,170) A,C,WL
 73   MP=KODLP*5+1
      KK=MP+4
      WRITE (IPR,173) TL,TH,(IDL(I),I=MP,KK)
C-----CHECK IF NUMBER OF REFLECTIONS TOO LARGE
      IF(N.GT.LIMIT1) GO TO 132
C-----PRINT DIFFRACTION GEOMETRY
      IF (KODLP.GT.2) WRITE (IPR,143) DURCHM,BGUIN,DGU
C-----PRINT SPACE GROUP AND EQUIVALENT POSITIONS
      N=6
      IF (IGROUP.EQ.0) N=9
      WRITE (IPR,144) ITIT(N),(NT(I),I=1,36)
      CALL EQUI
C-----PRINT LAUE SYMMETRY
      IF (ISYSTM.LT.3) GO TO 74
      N=10
      IF (LAUE.EQ.2) N=11
      WRITE (IPR,145) ITIT(N)
 74   N=12
C-----PRINT SYMMETRY CENTER
      IF (ISYMCE.EQ.1) N=13
      WRITE (IPR,146) ITIT(N)
C-----PRINT BRAVAIS LATTICE AND EXTINCTIONS
      N=IBRAVL*3-2
      WRITE (IPR,147) JB(N),JB(N+1),JB(N+2)
      I1=IBRAVL
      I2=IBRAVL
      IF (I2.GT.4) I2=1
      I3=1
      IF (IBRAVL.EQ.4) I3=2
      L0=L7
      IF (IBRAVL.EQ.1) L0=L2(1)
      WRITE (IPR,148) L0,L1(I1),L2(I1),L3(I2),L4(I3),L5(I3),L6(I3)
      IF ((IHKO.EQ.2).OR.(IHKO.EQ.4)) WRITE (IPR,176) IHKO
      IF (IHKO.EQ.3) WRITE (IPR,175)
      IF (IHKO.EQ.5) WRITE (IPR,174)
      IF ((IOKL.EQ.2).OR.(IOKL.EQ.4)) WRITE (IPR,178) IOKL
      IF (IOKL.EQ.3) WRITE (IPR,210)
      IF (IOKL.EQ.5) WRITE (IPR,177)
      IF ((IHOL.EQ.2).OR.(IHOL.EQ.4)) WRITE (IPR,181) IHOL
      IF (IHOL.EQ.3) WRITE (IPR,180)
      IF (IHOL.EQ.5) WRITE (IPR,179)
      IF (IHHL.EQ.2) WRITE (IPR,182)
      IF (IHHL.EQ.3) WRITE (IPR,183)
      IF (IHOO.GT.1) WRITE (IPR,184) IHOO
      IF (IOKO.GT.1) WRITE (IPR,185)
      IF (IOOL.GT.1) WRITE (IPR,186) IOOL
C-----PRINT NUMBER AND KINDS OF ATOMS IN UNIT CELL
      WRITE (IPR,196)
C-----NUMBER OF GENERAL POINT POSITIONS
      GEN=DUM*NS*FBRA
      DO 75 M=1,NCOMPO
      NL=NA(M)
      DO 75 I=1,NL
C-----NUMBER OF SPECIAL POINT POSITIONS
      FMULI=GEN*FMULT(I,M)
      SATO=FMULI*FOCCU(I,M)
 75   WRITE (IPR,197) ELEMT(M),IDE(I,M),FMULI,FOCCU(I,M),SATO
C-----CALCULATE NUMBER OF ELECTRONS AND PRINT X RAY SCATTERING FACTORS
      WRITE (IPR,149)
      SATO=0
      DO 78 M=1,NCOMPO
      IF (KODLP.NE.2) GO TO 76
C-----PRINT NEUTRON SCATTERING LENGTH
      WRITE (IPR,150) ELEMT(M),FNEUT(M)
      GO TO 78
 76   FSCAT=0.
      DO 77 I=1,4
      FSCAT=FSCAT+FA(I,M)
 77   CONTINUE
      INEL=FSCAT+FC(M)+0.1
      WRITE (IPR,151) ELEMT(M),(FA(I,M),FB(I,M),I=1,4),FC(M),INEL
      WRITE (IPR,152) DELFR(M),DELFI(M)
C-----CALCULATE F(000)
      NL=NA(M)
      DO 278 I=1,NL
 278  SATO=SATO+GEN*INEL*FMULT(I,M)*FOCCU(I,M)
 78   CONTINUE
C-----INDICATE ANOMALOUS DISPERSION CORRECTION
      IF (ANO.EQ.0.)WRITE (IPR,153)
      IF (ANO.NE.0.)WRITE (IPR,154)
      IF (SATO .EQ. 0) GO TO 79
      IFOO=SATO*(ABS(SATO)+0.5)/SATO
C-----WRITE F(000)
      WRITE (IPR,155) IFOO
C-----PRINT ATOM POSITIONS
 79   WRITE (IPR,198)
      DO 80 M=1,NCOMPO
      NL=NA(M)
C-----PRINT ATOM COORDINATES
      WRITE (IPR,199) (ELEMT(M),IDE(I,M),X(I,M),Y(I,M),Z(I,M),FMULT(I,M)
     1,FOCCU(I,M),BTEMP(I,M),I=1,NL)
 80   CONTINUE
C-----EXIT IF NUMBER OF REFLECTIONS LESS THAN TWO
      IF(J.LE.1) GO TO 206
C-----START ORDERING REFLEXIONS
      DO 81 N=1,J
      NN=N+1
      DO 81 M=NN,JJ
      IF ((Q(N)-Q(M)).LE.0.) GO TO 81
      TEMP=Q(N)
      Q(N)=Q(M)
      Q(M)=TEMP
      TEMP=YH(N)
      YH(N)=YH(M)
      YH(M)=TEMP
      TEMP=YK(N)
      YK(N)=YK(M)
      YK(M)=TEMP
      TEMP=YL(N)
      YL(N)=YL(M)
      YL(M)=TEMP
C-----END OF ORDERING
 81   CONTINUE
C-----START LOOP TO CALCULATE F FOR ALL STORED REFLEXIONS
      DO 107 N=1,JJ
      IF (Q(N).GT.1.)GO TO 133
      THETA(N)=57.29578*ATAN(SQRT(Q(N)/(1.-Q(N))))
C-----CALCULATE LORENTZ POLARISATION FACTORS
      VV=THETA(N)*0.0174533
      SX2=(SIN(VV)/WL)**2
      PLG=1.
      IF (KODLP.EQ.0) PLG=(1.+(1.-2.*Q(N))**2)/(2.*Q(N)*SQRT(1.-Q(N)))
      IF (KODLP.EQ.2) PLG=1./(Q(N)*SQRT(1.-Q(N)))
      WW=(2.*THETA(N)-BGUIN)*0.0174533
      IF (KODLP.GT.2) PLG=(1.+(1.-2.*Q(N))**2.*AGUIN)/((1.+AGUIN)*Q(N)*S
     1QRT(1.-Q(N))*COS(WW))
      IF (KODLP.EQ.5) PLG=1./(Q(N)*SQRT(1.-Q(N))*COS(WW))
C-----CALCULATE MULTIPLICITY FOR POWDERLINE
      GO TO (82,84,87,89,91,93,96), ISYSTM
 82   IF ((YK(N).EQ.0.).OR.((YH(N).EQ.0.).AND.(YL(N).EQ.0.))) GO TO 96
 83   FMULTI=4.0
      GO TO 98
 84   IF (YH(N).EQ.0.) IF (YK(N)) 133,96,86
      IF (YK(N).EQ.0.) GO TO 86
      IF (YL(N).EQ.0.) GO TO 83
 85   FMULTI=8.0
      GO TO 98
 86   IF (YL(N)) 133,96,83
 87   IF ((YH(N).EQ.0.).AND.(YK(N).EQ.0.)) GO TO 96
 88   FMULTI=6.0
      GO TO 98
 89   IF ((YH(N)-YK(N)).EQ.0.) IF (YH(N)) 133,96,90
      IF (YK(N).EQ.0.) GO TO 90
      IF (YL(N).EQ.0.) IF (LAUE-1) 133,83,85
      IF (LAUE.EQ.1) GO TO 85
      FMULTI=16.
      GO TO 98
 90   IF (YL(N)) 133,83,85
 91   IF ((YH(N)-YK(N)).EQ.0.) IF (YL(N)) 133,97,92
      IF ((YL(N).EQ.0.).AND.(LAUE.EQ.2)) IF (YK(N)) 133,88,94
      IF ((YL(N).EQ.0.).AND.(LAUE.EQ.1)) IF (YK(N)) 133,88,97
      IF (((YK(N)-YL(N)).EQ.0.).OR.(LAUE.EQ.1)) GO TO 94
      FMULTI=48.
      GO TO 98
 92   IF (YH(N)-YL(N)) 133,85,94
 93   IF ((YH(N)-YK(N)).EQ.0.) IF (YH(N)) 133,96,95
      IF (YK(N).EQ.0.) GO TO 95
      IF ((YL(N).EQ.0.).AND.(LAUE.EQ.1)) GO TO 88
      IF ((YL(N).EQ.0.).OR.(LAUE.EQ.1)) GO TO 97
 94   FMULTI=24.0
      GO TO 98
 95   IF (YL(N)) 133,88,97
 96   FMULTI=2.0
      GO TO 98
 97   FMULTI=12.0
 98   SUMA(N)=0.
      SUMB(N)=0.
      SUMBX=0.
      SUMAX=0.
C-----LOOP OVER DIFFERENT KINDS OF ATOMS
      DO 104 M=1,NCOMPO
      DELTF=DELFI(M)
      SMA=0.
      SMB=0.
      NL=NA(M)
C-----LOOP OVER ALL ATOMS OF ONE KIND
      DO 100 I=1,NL
C-----LOOP OVER EQUIVALENT POSITIONS
      DO 99 J=1,NS
      XN=TS(1,J)+FS(1,1,J)*X(I,M)+FS(2,1,J)*Y(I,M)+FS(3,1,J)*Z(I,M)
      YN=TS(2,J)+FS(1,2,J)*X(I,M)+FS(2,2,J)*Y(I,M)+FS(3,2,J)*Z(I,M)
      ZN=TS(3,J)+FS(1,3,J)*X(I,M)+FS(2,3,J)*Y(I,M)+FS(3,3,J)*Z(I,M)
      ARG=PI2*(YH(N)*XN+YK(N)*YN+YL(N)*ZN)
C-----INCLUDE OCCUPATION, MULTIPLICITY AND TEMPERATURE FACTOR
      SMA=SMA+DCOS(ARG)*FMULT(I,M)*FOCCU(I,M)*E**(-BTEMP(I,M)*SX2)
      IF (ISYMCE.EQ.1) GO TO 99
      SMB=SMB+DSIN(ARG)*FMULT(I,M)*FOCCU(I,M)*E**(-BTEMP(I,M)*SX2)
C-----END OF LOOP OVER EQUIVALENT POSITIONS
 99   CONTINUE
C-----END OF LOOP OVER ALL ATOMS OF ONE KIND
 100  CONTINUE
      IF (FNEUT(M).NE.0.)GO TO 102
C-----CALCULATE ATOMIC SCATT. FACTOR
      FSCAT=0.
      DO 101 I=1,4
      AR=-FB(I,M)*SX2
      FSCAT=FSCAT+FA(I,M)*EXP(AR)
 101  CONTINUE
C-----REAL PART OF SCATTERING FACTOR
      FSCAT=FSCAT+DELFR(M)+FC(M)
      GO TO 103
C-----NEUTRON SCATTERING LENGTH
 102  FSCAT=FNEUT(M)
C-----MULTIPLY WITH SCATTERING FACTOR AND STORE FOR OUTPUT
 103  SUMA(N)=SUMA(N)+SMA*FSCAT
      SUMB(N)=SUMB(N)+SMB*FSCAT
C-----CALCULATE IMAGINARY CORRECTION TERM FOR ANOMALOUS DISPERSION
      IF (ANO.EQ.0.)GO TO 104
      SUMAX=SUMAX+SMA*DELTF*FBRA*DUM
      SUMBX=SUMBX+SMB*DELTF*FBRA
C-----END OF LOOP OVER DIFFERENT KINDS OF ATOMS
 104  CONTINUE
C-----INCLUDE BRAVAIS MULTIPLICITY AND MULTIPLIER FOR CENTER AT ORIGIN
      SUMA(N)=FBRA*SUMA(N)*DUM
      SUMB(N)=FBRA*SUMB(N)
      FPLG(N)=PLG
      FMUL(N)=FMULTI
      IF (ANO.EQ.0.)GO TO 105
C-----CALCULATE TOTAL CORRECTION TERMS FOR ANOMALOUS DISPERSION
      FMULTI=FMULTI/2.
      AX(N)=SUMA(N)-SUMBX
      AY(N)=SUMA(N)+SUMBX
      BX(N)=SUMB(N)+SUMAX
      BY(N)=-SUMB(N)+SUMAX
      STRU(N)=SUMA(N)**2+SUMB(N)**2+SUMAX**2+SUMBX**2
      GO TO 106
 105  STRU(N)=SUMA(N)**2+SUMB(N)**2
 106  VINT(N)=PLG*FMULTI*STRU(N)
C-----TEST FOR REFLECTION OVERLAP AND SUM WHERE NECCESSARY
C
      IF (THETA(N)-THETA(N-1) .LT. WIN) THEN
         VINT(N)=VINT(N)+VINT(N-1)
         VINT(N-1)=-1.
            ELSE
         CONTINUE
      END IF
C
C-----FIND MAXIMAL INTENSITY FOR NORMALISATION TO 100.
      VMXINT=AMAX1(VMXINT,VINT(N))
C-----END OF LOOP TO CALCULATE F FOR ALL STORED AND ORDERED HKL VALUES
 107  CONTINUE
C
C
      MMINT = VMXINT/100
C-----OUTPUT OF JJ LINES WITH REFLECTION DATA
      N=1
      IF (NORM.EQ.3) N=3
      WRITE (IPR,156) ITIT(N),ITIT(N+1)
C-----SKIP TABULAR LIST
      IF (NORM.EQ.3) GO TO 122
      WRITE (IPR,157) MMINT
      NLINE=60
      K=KODLP+1
      I=NORM+1
      DO 121 N=1,JJ
      IF (NLINE.NE.60) GO TO 115
C-----PRINT HEADING OF PAGES
CC      GO TO (110,109,108,122), I
CC 108  WRITE (IPR,200)
CC      GO TO 114
CC 109  WRITE (IPR,201)
CC      GO TO 114
CC 110  GO TO (112,112,112,111,111), K
CC 111  J=5
CC      GO TO 113
CC 112  J=7
 113  WRITE (IPR,200) CHAR(12)
 200  FORMAT(A1)
      WRITE (IPR,202)
 114  NLINE=0
 115  CONTINUE
      IH=YH(N)
      IK=YK(N)
      IL=YL(N)
      M=FMUL(N)
      DVAL=WL/(2.*SQRT(Q(N)))
      THETA2=2.*THETA(N)
C      IF (KODLP.GT.2) THETA2=THETA(N)*(DURCHM/28.64789)
      PRPINT=VINT(N)*100./VMXINT
      VVV=Q(N)
      DSQ=1./(DVAL*DVAL)
      SUMAN=SUMA(N) +0.000001
      SUMBN=SUMB(N)
C-----
      STRU1=STRU(N)
      STRU1=SQRT(STRU1)
C-----ANOMALOUS DISPERSION FOR FRIEDEL PAIRS
      IF (ANO.EQ.0.)GO TO 116
      A1=AX(N) +0.000001
      A2=AY(N) +0.000001
      B1=BX(N)
      B2=BY(N)
      SUMBN=B1
      STRU1=A1*A1+B1*B1
      STRU2=A2*A2+B2*B2
      STRU1=SQRT(STRU1)
      STRU2=SQRT(STRU2)
      PHA1=(ATAN2(B1,A1))*360./PI2
      PHA2=(ATAN2(B2,A2))*360./PI2
 116  IF ((SUMAN.NE.0.).OR.(SUMBN.NE.0.)) PHANG=(ATAN2(SUMBN,SUMAN))*360
     1./PI2
C
C-----PRINT ALTERNATIVES AT OVERLAP WITHIN WINDOW
C
      IF (VINT(N) .LT. 0.0) THEN
        WRITE (IPR,218)        IH,IK,IL,THETA2,STRU1,M,DVAL,Q(N),FPLG(N)
            ELSE
        WRITE (IPR,217) PRPINT,IH,IK,IL,THETA2,STRU1,M,DVAL,Q(N),FPLG(N)
      END IF
C
 120  NLINE=NLINE+1
      MUMB=MUMB+1
C     WRITE(IMU,9833) IH,IK,IL,M,MUMB
 9833 FORMAT(4I5,20X,I5)
C-----END OF OUTPUT OF NUMERICAL VALUES
 121  CONTINUE
C-----GRAPHIC OUTPUT OF INTENSITIES
 122  N=3
      IF (IMAGE.EQ.0) GO TO 123
      N=1
      STEP=1./(2.*FLOAT(IMAGE))
 123  WRITE (IPR,158) ITIT(N),ITIT(N+1)
      IF (IMAGE.EQ.0) GO TO 1
      WRITE (IPR,159) STEP
      VMXINT=0.
C-CDC-TAKE THE FOLLOWING STATEMENT OUT (SUPPRESSES THE PAGE JUMP)
C-----THIS IS A UNIVAC 1100 GENEVA SYSTEM SUBROUTINE
C-----CALL PAGE('M,320,0,0',2)
      WRITE (IPR,166) COMPND,WL,(IDL(I),I=MP,KK)
C-----FIRST THETA VALUE
      W(1)= TL
C-----NUMBER OF INTERVALS
      KK=INT((TH-TL)/STEP + 1.)
C-----LOOP OVER ALL INTERVALS
      DO 125 K=1,KK
      IF (NFI.EQ.1) GO TO 301
      IF (INADD.EQ.0) GO TO 301
      GO TO 302
 301  SP(K)=0.
 302  FMUL(K)=0.
      STRU(K)=0.
      IF (K.NE.1) W(K)=W(K-1)+STEP
      VMA=0.
      WK1=W(K)-0.5*STEP
      WK2=WK1+STEP
C-----LOOP OVER ALL REFLECTIONS IN ONE INTERVAL
      DO 124 N=1,JJ
      IF ((THETA(N).LT.WK1).OR.(THETA(N).GE.WK2)) GO TO 124
      VMA=AMAX1(VMA,VINT(N))
C-----STORE THE POINTER TO STRONGEST REFLECTION IN THIS INTERVAL
      IF (VMA.EQ.VINT(N)) FMUL(K)=FLOAT(N)
C-----ACCUMULATE COINCIDENT INTENSITIES IN EACH INTERVAL
      SP(K)=SP(K)+VINT(N)
C-----COUNT NUMBER OF COINCIDING REFLECTIONS
      STRU(K)=STRU(K)+1.
 124  CONTINUE
C-----FIND LARGEST SUM OF INTENSITIES AMONG ALL INTERVALS
      VMXINT=AMAX1(VMXINT,SP(K))
 125  CONTINUE
C-----FILL EACH OUTPUT LINE WITH STARS, BLANKS, DOTS ETC
      DO 131 K=1,KK
      NSPIEL=SP(K)*100./(VMXINT)+.5
      NSP10=(NSPIEL-1)/10
      N=FMUL(K)
      IH=YH(N)
      IK=YK(N)
      IL=YL(N)
      I=STRU(K)
      DO 126 MP=1,100
      IPLA(MP)=IBLNK
      IF (W(K).EQ.0.) IPLA(MP)=ISTA
 126  CONTINUE
      IF (NFI.EQ.1) GO TO 303
      IF (INADD.EQ.0) GO TO 303
      IF (NSPIEL.EQ.0) GO TO 303
      GO TO 304
 303  IF (STRU(K).EQ.0.)GO TO 130
      IF (NSPIEL.EQ.0) GO TO 129
 304  DO 127 MP=1,NSPIEL
 127  IPLA(MP)=ISTA
      IF (NSP10.LT.1) GO TO 305
      DO 128 J=1,NSP10
      MP=10*J
 128  IPLA(MP)=IDT(J)
 305  IF (NFI.EQ.1) GO TO 129
      IF (INADD.EQ.0) GO TO 129
      IF (STRU(K).EQ.0.) GO TO 130
C-----WRITE ONE LINE OF GRAPHICAL OUTPUT WITH HKL OF STRONGEST INTENS.
 129  WRITE (IPR,160) IH,IK,IL,I,W(K),(IPLA(MP),MP=1,100)
      GO TO 131
C-----WRITE ONE LINE OF GRAPHICAL OUTPUT WITHOUT HKL
 130  WRITE (IPR,167) W(K),(IPLA(MP),MP=1,100)
 131  CONTINUE
      WRITE (IPR,161)
C-CDC--TAKE THE FOLLOWING STATEMENT OUT (REINITIALIZES PAGE JUMP)
C-----THIS STATEMENT IS UNIVAC 1100 GENEVA SPECIFIC
      GO TO 1
C-----REDUCE UPPER THETA LIMIT AND TRY AGAIN
  132 TH1=TH-5.
      WRITE (IPR,195)  LIMIT1,TH,TH1
      IF(TH1.LE.SL) GO TO 206
      TH=TH1
      SH=(DSIN(TH*PI2/360.0))**2.
      ICON=0
      N=0
      GO TO 8
 133  WRITE (IPR,194)
      GO TO 1
 134  WRITE (IPR,162) NCOMPO
      GO TO 1
 135  WRITE (IPR,163) NL
      GO TO 1
 136  WRITE (IPR,164) NS
      GO TO 1
  206 WRITE(IPR,207)
      GO TO 1
 137  STOP
C-----COMPILATION OF FORMAT STATEMENTS
C-----
 138  FORMAT (   ///,23H START  P U L V E R I X     )
 139  FORMAT (//,'  AWAY! YOU L A Z Y  P U L V E R I X'  )
 140  FORMAT ('1'' JOB  ',I5,' CANCELLED! ....ERROR IN PREVIOUS PROGRAM',
     1/,' GO TO NEXT JOB ',//)
 141  FORMAT (1H //////)
 142  FORMAT ('1',9X,'JOB',I5/ )
 143  FORMAT (/,9X,'DIAMETER',F9.4,'mm',/9X,'   ANGLE BETWEEN NORMAL',
     1' TO PLANE OF SPECIMEN',/,9X,'AND INCIDENT BEAM = ',F7.2,' DEG.',/
     *,9X,'D-SPACING OF MONOCHROMATOR =',F7.3,' ANGSTROM')
 144  FORMAT ( /,9X,'SPACE GROUP:- ',A4,' GIVEN ON GROUP-CARD',36A1)
 145  FORMAT (/,9X,A4,' LAUE SYMMETRY')
 146  FORMAT (/,9X,'THERE IS ',A2,' SYMMETRY CENTRE AT THE ORIGIN')
 147  FORMAT (/,9X,'BRAVAIS LATTICE IS ',3A4)
 148  FORMAT (/,9X,'CONDITIONS LIMITING POSSIBLE REFLECTIONS',//,15X,
     1'HKL ',A4,1X,6A4)
 149  FORMAT (/,9X,'SCATTERING FACTOR  COEFFICIENTS',/)
 150  FORMAT (/,9X,A4,2X,3H F=,F6.3,6H CM-12/)
 151  FORMAT (9X,A4,4F9.5,/,13X,5F9.5,
     */,15X,'NUMBER OF ELECTRONS ='I5,/,15X,
     *'(CALCULATED USING ABOVE COEFFICIENTS)',/)
 152  FORMAT (15X,'DELFR ='F7.3,2X,'DELFI ='F7.3,/,15X,
     *' (ANOMALOUS DISPERSION CORRECTION TERMS)',/)
 153  FORMAT (/,9X,'NO CORRECTION MADE FOR ANOMALOUS DISPERSION')
 154  FORMAT (/,9X,'CORRECTION MADE FOR ANOMALOUS DISPERSION ')
 155  FORMAT (/,9X,'NUMBER OF ELECTRONS IN UNIT CELL   F(0,0,0) ='I8)
 156  FORMAT (/// 9X,50(1H-),//,9X,'- T A B U L A R  L I S T  OF INTEN'
     1,'SITIES',2A4,2H -//,9X,50(1H-))
 157  FORMAT (//,9X,'  THE COLUMNS CONTAIN',//,9X,'  INTENSITY SCALED',
     *' TO 100 AFTER TESTING FOR OVERLAP',/,9X,
     *'  MILLER INDICES, H, K, L, AND DIFFRACTION ANGLE 2*THETA',/,9X,
     *'  SQUARED STRUCTURE FACTOR, F**2, AND MULTIPLICITY',/,9X,
     *'  D-SPACING IN A UNITS, SINE-SQUARE THETA, Q, AND LpG',//,9X,
     *'  INTENSITY SCALING FACTOR =',I10)
C
C
 158  FORMAT (///1X,70(1H-),//,68H - G R A P H I C  R E P R E S E N T A
     1T I O N  OF THE POWDER PATTERN ,2A4,2H -//1X,70(1H-))
 159  FORMAT (//37H THE POWDER PATTERN WILL BE GIVEN IN  9H STEPS OFF7.4
     1,6H THETA//61H THE THETA VALUES INDICATED ARE THE CENTRES OF THE I
     2NTERVALS //50H EACH LINE CONTAINS FROM THE LEFT TO THE RIGHT    //
     392H THE MILLER INDICES OF THE STRONGEST REFLECTION CONTRIBUTING TO
     4 THE INTENSITY   ( H K L )   ,/     54H THE NUMBER OF REFLECTIONS
     5FALLING IN THE INTERVAL (N) ,/56H THE THETA VALUE OF THE CENTER OF
     6 THE INTERVAL  (THETA) /92H THE INTENSITY OF THE SUM OF ALL REFLEC
     7TIONS FALLING IN THE INTERVAL (MAXIMUM=100 ASTERISKS))
 160  FORMAT (1X,3I3,5X,I2,F8.2,1X,1HI,100A1,1HI)
CDC----1X  SHOULD BE REPLACED BY 1HS TO SUPPRESS PAGE JUMP
 161  FORMAT (26X,102(1H-),///)
 162  FORMAT (//'10X,,NUMBER OF ATOMIC SPECIES ='I5,10H TOO LARGE)
 163  FORMAT (29H NUMBER OF ATOMS OF ONE KIND=,I5,10H TOO LARGE)
 164  FORMAT (41H NUMBER OF SYMMETRY EQUIVALENT POSITIONS=,I5,10H TOO LA
     1RGE)
 165  FORMAT (/,9X,'INTENSITY CALCULATION FOR:',//,15X,19A4/)
 166  FORMAT (/26H1 DIFFRACTION PATTERN FOR ,18A4,A2,4H WL=,F8.5,5A4// ,
     12X,24HH  K  L       N   THETA ,102(1H-))
 167  FORMAT ( 1X,16X,F8.2,1X,1HI,100A1,1HI)
CDC----1X  SHOULD BE REPLACED BY 1HS TO SUPPRESS PAGE JUMP
 168  FORMAT (/,19X,'A =',F9.5,//,19X,'B =',F9.5,//,19X,'C =',F9.5,//,
     *16X,'BETA =',F9.5,///,18X,'WL ='F8.5)
 169  FORMAT (/,19X,'A =',F9.5,//,19X,'B =',F9.5,//,19X,'C =',F9.5,///,
     *18X,'WL ='F8.5)
 170  FORMAT (/,19X,'A =',F9.5,//,19X,'C =',F9.5,///,18X,'WL ='F8.5)
 171  FORMAT (/,19X,'A =',F9.5,///,18X,'WL ='F8.5)
 172  FORMAT (/,19X,'A =',F9.5,//,19X,'B =',F9.5,//,19X,'C =',F9.5,//,
     *15X,'ALPHA =',F9.5,//,16X,'BETA =',F9.5,//,15X,'GAMMA =',F9.5,///,
     *18X,'WL ='F8.5)
 173  FORMAT(/,9X,'CALCULATION BETWEEN TL = ',F4.1,' AND TH =',F6.1,
     1' DEGREES THETA ',//,9X,'DIFFRACTION GEOMETRY :- ',5A4)
 174  FORMAT (15X,'HK0 WITH H    = 2N ONLY')
 175  FORMAT (15X,'HK0 WITH K    = 2N ONLY')
 176  FORMAT (15X,'HK0 WITH H+K  = ',I1,'N ONLY')
 177  FORMAT (15X,'0KL WITH K    = 2N ONLY')
 210  FORMAT (15X,'0KL WITH L    = 2N ONLY')
 178  FORMAT (15X,'0KL WITH K+L  = ',I1,'N ONLY')
 179  FORMAT (15X,'H0L WITH H    = 2N ONLY')
 180  FORMAT (15X,'H0L WITH L    = 2N ONLY')
 181  FORMAT (15X,'H0L WITH H+L  = ',I1,'N ONLY')
 182  FORMAT (15X,'HHL WITH L    = 2N ONLY')
 183  FORMAT (15X,'HHL WITH 2H+L = 4N ONLY')
 184  FORMAT (15X,'H00 WITH H    = ',I1,'N ONLY')
 185  FORMAT (15X,'0K0 WITH K    = 2N ONLY')
 186  FORMAT (15X,'00L WITH L    = ',I1,'N ONLY')
 187  FORMAT (/,9X,'MONOCLINIC CELL',/)
 188  FORMAT (/,9X,'TRICLINIC CELL',/)
 189  FORMAT (/,9X,'ORTHORHOMBIC CELL',/)
 190  FORMAT (/,9X,'TRIGONAL CELL',/)
 191  FORMAT (/,9X,'TETRAGONAL CELL',/)
 192  FORMAT (/,9X,'CUBIC CELL',/)
 193  FORMAT (/,9X,'HEXAGONAL CELL',/)
 194  FORMAT(/,'MAJOR ERROR SOMEWHERE.... CONTACT THE AUTHORS!')
 195  FORMAT (/11H *OVERFLOW*,/38H NUMBER OF REFLECTIONS IS GREATER THAN
     1,I5,/42H *** UPPER THETA LIMIT *** IS REDUCED FROM,F6.2,4H TO ,
     XF5.2/)
 196  FORMAT (/,9X,'NUMBER OF ATOMS IN UNIT CELL',//,9X,'ELEMENT NUMBER'
     1,'*  OCCUP =   NTOTAL',/)
 197  FORMAT (9X,A4,1X,A2,F7.1,'*',F7.3,' =',F8.3)
 198  FORMAT (/,9X,'ATOM  POSITIONS',//,9X,'ELEMENT   X/A      Y/B'
     1,'      Z/C    FMULT   OCCUP  BTEMP',/)
 199  FORMAT (9X,A4,A2,3F9.6,F7.4,F8.4,F7.3)
C 200  FORMAT (1H1,131H H  K  L THETA  MM     D     SIN2   H  K  L INTENS
C     1    F+(HKL)    F-(HKL)  A+(HKL)  A-(HKL)  B+(HKL)  B-(HKL) PHA+  P
C     2HA- MULT   LPG /)
C 201  FORMAT(/130H1 H  K  L    THETA  SIN2*1000 INT.SCALED   INTENSITY U
C     1NSCALED           /F(HKL)/        A(HKL)        B(HKL) PHA.ANG. MU
C     2LT    LPG   /)
C 202  FORMAT(/18H1 H  K  L  THETA  ,2A3,107H D VALUE  1/D**2 SIN2*1000
C    1H  K  L INTENSITY         /F(HKL)/       A(HKL)      B(HKL) PHA.AN
C    2G  MULT   LPG  /)
C
  202  FORMAT('1','          INT.  H  K  L    2*THETA    F*2     MLT',
     *'    D-SP.       Q       LpG',//)
  203 FORMAT(3I3,3X,F7.3,4X,F9.4,1X,F7.4,3PF9.2,1X,3I3,0PF10.1,0PF17.1,
     *0P2F13.2,0PF8.2,I3,0PF7.2)
  204 FORMAT (3I3,F9.2,3P1F10.2,0PF10.1,0PF22.1,0PF20.1,0P2F14.2,0PF8.2,
     1I3,0PF8.2)
  205 FORMAT (3I3,2F6.1,F8.4,3PF6.1,3I3,0PF7.1,0P2F11.1,0P4F9.1,0P2F6.1,
     1I3,F7.2)
  207 FORMAT(/13H * BAD LUCK */63H ONLY ONE (OR NO) REFLECTION FALLS IN
     XTHE THETA RANGE SPECIFIED/37H NO POWDER PATTERN WILL BE CALCULATED
     X)
C
  217 FORMAT (F15.2,3I3,F10.3,F10.2,I5,F10.4,F10.6,F9.3)
  218 FORMAT (  15X,3I3,F10.3,F10.2,I5,F10.4,F10.6,F9.3)
      END
C
C-------------------------------------------------------------------------
      SUBROUTINE EQUI
C-------------------------------------------------------------------------
C
C-----PRINTS EQUIPOINTS STORED IN TS,FS,ISYMCE AND IBRAVL
      COMMON /EQUIV/ TS,FS,NG,ISYMCE,IBRAVL
      COMMON /UNITS/ NPT,IMU
      INTEGER DIG,SYMB1,SYMB2
      DIMENSION TS(3,24), FS(3,3,24), CON1(7), SYMB1(8), SYMB2(9), DIG(1
     13), IB(24), IP(12)
      DATA IB(1)/'1/2 '/,IB(2)/'2/3 '/,IB(3)/'1/2 '/,IB(4)/' 0  '/,IB(5)
     1/'1/2 '/,IB(6)/'1/2 '/,IB(7)/'1/2 '/,IB(8)/'1/3 '/,IB(9)/'1/2 '/,I
     2B(10)/'1/2 '/,IB(11)/' 0  '/,IB(12)/'1/2 '/,IB(13)/'1/2)'/,IB(14)/
     3'1/3 '/,IB(15)/' 0, '/,IB(16)/'1/2)'/,IB(17)/'1/2)'/,IB(18)/' 0 )'
     4/,IB(19)/'1/3 '/,IB(20)/'1/2 '/,IB(21)/'2/3 '/,IB(22)/' 0  '/,IB(2
     53)/'2/3)'/,IB(24)/'1/2,'/
      DATA CON1(1)/0.75/,CON1(2)/0.6667/,CON1(3)/0.5/,CON1(4)/0.3333/,CO
     1N1(5)/0.25/,CON1(6)/0.16667/,CON1(7)/0.83333/
      DATA SYMB1(1)/'3/4'/,SYMB1(2)/'2/3'/,SYMB1(3)/'1/2'/,SYMB1(4)/'1/3
     1'/,SYMB1(5)/'1/4'/,SYMB1(6)/'1/6'/,SYMB1(7)/'5/6'/,SYMB1(8)/'   '/
      DATA SYMB2(1)/' +X'/,SYMB2(2)/'  X'/,SYMB2(3)/' -X'/,SYMB2(4)/' +Y
     1'/,SYMB2(5)/'  Y'/,SYMB2(6)/' -Y'/,SYMB2(7)/' +Z'/,SYMB2(8)/'  Z'/
     2,SYMB2(9)/' -Z'/
       DATA I1HBLA/' '/,I1HCOM/','/,I4HBLA/'    '/,I4HPPZ/'+(0 '/,
     * I4HZBZ/'0 0,'/,I4HBZ/' 0  '/,I4H1S2/'1/2 '/,I4H1SP/'1/2)'/,
     * I3HBLA/'   '/
      WRITE (NPT,15)
      DIG(13)=I1HBLA
      IF (ISYMCE.EQ.1) DIG(13)=I1HCOM
C-----FILL OUTPUT STRING WITH BLANKS
      DO 1 NN=1,12
      IP(NN)=I4HBLA
 1    DIG(NN)=SYMB1(8)
C-----FILL OUTPUT STRING IP WITH BRAVAIS LATTICE VECTORS
      IF (IBRAVL.LT.2) GO TO 4
C-----FIRST VECTOR
      IP(1)=I4HPPZ
      IP(2)=I4HZBZ
C-----SECOND VECTOR
      DO 2 I=1,3
      I1=I+2
      I2=IBRAVL-1
      I3=I*6-6
 2    IP(I1)=IB(I2+I3)
      IF ((IBRAVL.LT.3).OR.(IBRAVL.GT.4)) GO TO 4
C-----THIRD VECTOR
      I2=16+IBRAVL
      DO 3 I=1,3
      I1=I+5
      I3=I*2-2
 3    IP(I1)=IB(I2+I3)
C-----FORTH VECTOR
      IF (IBRAVL.EQ.3) GO TO 4
      IP(9)=I4HBZ
      IP(10)=I4H1S2
      IP(11)=I4H1SP
C-----LOOP OVER NUMBER OF EQUIPOINTS
 4    DO 14 I=1,NG
C-----FILL OUTPUT STRING WITH BLANKS
      DO 5 NN=1,12
 5    DIG(NN)=I3HBLA
      ANTI=1.
      NN=1
C-----LOOP OVER X Y Z  COORDINATES
 6    DO 12 J=1,3
      TS1=ANTI*TS(J,I)
      IF (TS1.LT.0.) TS1=1.+TS1
      N1=1
      IF (TS1.EQ.0.) GO TO 9
      DO 7 II=1,7
      DIF=TS1-CON1(II)
      DIF=ABS(DIF)
      IF (DIF.LT..010) GO TO 8
 7    CONTINUE
      WRITE (NPT,16)
      RETURN
 8    DIG(NN)=SYMB1(II)
      NN=NN+1
      N1=2
 9    L=1
C-----LOOP OVER ROWS IN MATRIX
      DO 11 M1=1,3
      FS1=ANTI*FS(M1,J,I)
      IF (FS1.EQ.0.) GO TO 10
      IF (FS1.EQ.1.) L=L-N1+2
      IF (FS1.EQ.-1.) L=L+2
      N1=N1+1
      DIG(NN)=SYMB2(L)
      NN=NN+1
 10   L=M1*3+1
 11   CONTINUE
      NN=NN-N1+3
 12   CONTINUE
      IF (ANTI.EQ.-1.) GO TO 13
      ANTI=-1.
      IF (ISYMCE.EQ.1) GO TO 6
 13   WRITE (NPT,17) (DIG(I1),I1=1,6),DIG(7),DIG(8),DIG(13),DIG(9),DIG(1
     10),DIG(13),DIG(11),DIG(12)
 14   CONTINUE
      RETURN
C
 15   FORMAT (/,9X,'EQUIVALENT POINT POSITIONS',/)
 16   FORMAT (/,9X,'EQUIPOINT CODE BADLY INTERPRETED',/)
 17   FORMAT (15X,2(2A3,1H,),2A3,5X,2(2A3,A1),2A3)
      END
 
