C     ZALKIN FORDAP PROGRAM MODIFIED BY IBERS(BNL) AND OAK RIDGE
C             COMPLETELY REVISED BY R.SHIONO          MAY 1965
C                       MODIFIED FOR 360   APRIL 1970
C     SETUP PROGRAM
C     AS THE WHOLE FOURIER PROGRAM IS WRITTEN IN SUBROUTINES WITH THE
C        EXCEPTION OF THIS SETUP PROGRAM, YOU MAY REWRITE THE
C        FLOW PATTERN IN ANY MANNER YOU WISH.
C     THIS PROGRAM CONTROLS THE PROGRAM FLOW VIA SUBROUTINES.  THE
C     NAMES AND FUNCTIONS OF THE SUBROUTINES THAT DO THE WORK ARE
C     AS FOLLOWS -
C     RIP - READS IN THE DATA FROM CARDS OR TAPE(WHICH IS USUALLY
C          AN SFLS OUTPUT). THESE DATA ARE EXPANDED ACCORDING
C        TO SYMMETRY AND STORED FOR USE IN THE ACTUAL FOURIER.
C     SIG100-PERFORMS THE FOURIER SUMMATION ACCORDING TO INSTRUCTIONS
C        READ IN BY THE RIP PROGRAM.
C     FRPRNT - GIVES PRINTED OFF LINE ANSWERS.
C     FOURPEAK PROVIDES A LIST OF THE PEAK HEIGHTS IN DESCENDING ORDER
C        AND THEIR LOCATIONS.
CSETUP
	DIMENSION  TRGTBL(1001),ISST(10),WORDS(20)
	DIMENSION  TABLE(12000)
	COMMON TRGTBL,NORIEN,NXX,NYX,     NZ,XMIN,XMAX,YMIN,      YMAX,
	1ZMIN,ZMAX,DX,DY,DZ,AMAX,BMAX,JMAX,KMAX,KMIN,NMEMMX,NEGINA,NCD,NEF,
	2 NEFTBL,NX,NY,LMTD,N1,RMAX,NLAST,NFPLT,YFL,N11,
	3   IN,III,IVXX,IXX,NTPCH,NN3,NDATAP,ISST,
	4       A,B,C,COSA,COSB,COSC,   NSEC,NGRID,NSKIP,CNTRNO,CNTNEG,
	5 NEXPAN,WORDS
	COMMON  TABLE
6	FORMAT (23H0 BINARY ANSWER TAPE IS I3,22H   SFLS INPUT TAPE IS I3)
10	FORMAT(34H0FOURIER TABLES GO FROM LOCATIONS I6,3H TOI6,17H.  NO. O
	1F UNITS = I6,1H. //)
70	FORMAT ( 1H ,104XF7.2 )
99	FORMAT ( 20A4 )
100	FORMAT ( 1H1, 20A4 ///)
2200	FORMAT ( 8I1, 3I4, F10.4  )
5020	FORMAT (19H0PRINT THE RESULTS. )
5049	FORMAT(24H0SINGLE SPACE FOURPRINT )
5050	FORMAT ( 26H0MULTIPLE SPACE FOURPRINT    )
5060	FORMAT (20H0LIST FOURIER PEAKS. )
5081	FORMAT(44H0THE MAXIMUM NUMBER OF PEAKS LISTED WILL BE I4  /  )
C
C     IBM OS I/O ASSIGNMENTS
	IN = 105
	III = 108
	NTPCH = 106
	IXX = 3
	NDATAP = 4
	IVXX = 9
C  READ AND WRITE TITLE
47	READ(IN,99) WORDS
	WRITE(III,100) WORDS
	WRITE(III,6) IVXX,NDATAP
C  NMEMMX IS TH E SIZE OF AN ARRAY USED IN SIG.
C  THIS MAY BE CHANGED ACCORDING TO THE AVAILABLE CORE SIZE.
	NMEMMX = 12000
	NEGINA = 0
C  READ MASTER CONTROL CARD.
	READ(IN,2200) (ISST(I),I=1,10),LMTD,RMAX
C  PRINT OUT OPTIONS SELECTED.
	IF(ISST(1) ) 5019, 5053, 5019
5019	WRITE(III,5020)
	IF( ISST(5) - 2  ) 5047, 5048, 5048
5047	WRITE( III,5049 )
	GO TO 5053
5048	WRITE( III,5050 )
5053	IF( ISST(6) ) 5055, 40, 5055
5055	WRITE( III,5060 )
5025	IF( ISST(7) ) 5051, 5051, 5052
5051	IJA = 1000
	GO TO 5080
5052	IJA = 100* ISST(7)
5080	WRITE( III,5081 ) IJA
40	IF( ISST(10) ) 42, 41, 42
C CALCULATE COSINE TABLE(TRGTBL) FOR USE IN SIG100
41	ARG = 0.0
	DARG = 0.006283185
	DO 15 I = 1,1001
	TRGTBL(I) = COS(ARG)
15	ARG = ARG + DARG
	TRGTBL(1) = 1.
	TRGTBL(251) = 0.0
	TRGTBL(501) = -1.0
	TRGTBL(751) = 0.0
	TRGTBL(1001)=1.
	CALL RIP
	CALL SIG100
42	IF  ( ISST(1) )  43,  44,  43
43	CALL FRPRNT
44	IF  ( ISST(6) )  45,  64,  45
45	CALL FRPEAK
64	IF ( ISST(1)-1 )  46,  46,  47
46	CALL EXIT
	END
C
C     REVISED BY R.SHIONO,    FOR MODIFIED OR FLS-PX PROGRAM
C                            AUG. 1964 AND MAY 1965
C     DATA CARD 1.  CONTROL CARD.
C        COL 2-3 NEQUIV = NO. OF EQUIVALENT REFLECTIONS TO BE READ IN.
C        COL 4-6  NREF  = NO. OF EXPANDED DATA SETS TO BE LISTED.
C        COL 8-9   00 DATA ON CARDS
C        COL.10-12   NSP    0=FOURIER, 1=DIFF.FOURIER, 2=PATTERSON, 3=FC
C                  4= FC PATTERSON
C        COL 15    NREJ = 0 NO SPECIAL REJECT PROGRAM.
C                  NREJ = 1 - A SPECIAL REJECT PROGRAM CAN BE INCLUDED
C                  THAT SPECIFIES THE REJECTION OF CERTAIN DATA.USER
C                  WRITES HIS OWN SUBROUTINE IN FORTRAN AND SETS NSKIP
C                  EQUAL TO 0 FOR RETAINING THE REFLEXION AND 1 TO
C                  REJECT IT.
C        COL 16-18 NALT = NON-ZERO TO ENTER USERS S.R. ALTER
C        COL 19-21 NXT = EXTRA INTEGER INPUT WHICH
C                  IS PRESENTLY UNASSIGNED.
C        COL 22-31 F000  F000/V FOR FOURIER OR F000**2/V FOR PATTERSON
C        COLS 32-41,42-51,52-61,62-71 EXTRA FLOATING POINT
C                  INPUTS,   EXT(I),I=1,4
C                  THESE NUMBERS MAY BE USED FOR THE SUBROUTINES
C                  ALTER AND REJECT. THE NUMBERS ARE IN COMMON.
C     DATA CARD 2 - FOURIER LIMIT AND DIRECTION.
C        COL 1-45 -9F5.3 - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,DX,DY,DZ
C        COL 46-50 BLANK
C        COL 51-53 DIRECTION OF SECTION OR PROJECTION.
C           100  A AXIS
C           010  B AXIS
C           001  C AXIS
C     DATA CARDS 3.  ONE FOR EACH EQUIVALENT POSITION.
C        3 SETS OF RN(J),      M1(I,J),M2(I,J),M3(I,J)  SUCH THAT
C           RN = TRANSLATIONAL PART
C           J(I)=M1(I,1)*J+M2(I,1)*K+M3(I,1)*L
C           K(I)=M1(I,2)*J+M2(I,2)*K+M3(I,2)*L
C           L(I)=M1(I,3)*J+M2(I,3)*K+M3(I,3)*L
C     IF THE REFLEXION DATA ARE ON CARDS, THE FOLLOWING CARDS ARE USED.
C     DATA CARD 4.  REFLEXION DATA. ONE TO A CARD. (3I4,6F7.2,F5.3,I3)
C         H,K,L,FOBS,FCAL,AO,AC,BO,BC,SINTHETA, ID
C     DATA CARD 5 - END OF FILE OF REFLECTION DATA.
C        COL 3-5 999
C
	SUBROUTINE RIP
	DIMENSION MTX(24 ), MTY(24), MTZ(24), M1(24,3),M2(24,3),M3(24,3),
	1  J(24),K(24),L(24),A(24),B(24),RN(3),WORDS(20),
	2JX(24), KX(24), LX(24),AX(24),BX(24),TRGTBL(1001),ISST(10)
	DIMENSION EXT(4)
	COMMON TRGTBL,NORIEN,NXX,NYX,     NZ,XMIN,XMAX,YMIN,      YMAX,
	1ZMIN,ZMAX,DX,DY,DZ,AMAX,BMAX,JMAX,KMAX,KMIN,NMEMMX,NEGINA,NCD,NEF
	2 ,NEFTBL,NX,NY,NCUE,N1,RMAX,NLAST,NFPLT,YFL,N11,IN,III,IVXX,IXX,
	3 NN5,NN6,NDATAP,ISST,
	4 AXX,BXX,C,COSA,COSB,COSC,NSEC,NGRID,NSKIP,CNTRNO,CNTNEG,NEXPAN,
	5 WORDS,
	6 MTX,MTY,MTZ,J,K,L,A,B,JX,KX,LX,AX,BX,M1,M2,M3,RN,RD
20	FORMAT (3(F11.6,2I2))
80	FORMAT (  7I3, 5F10.3  )
88	FORMAT (1H0,24HINPUT DATA ARE FROM UNIT I5 //)
89	FORMAT (1H0,21HINPUT DATA FROM CARDS  //)
90	FORMAT (9F5.3,5XI3 )
91	FORMAT(13H X GOES FROM F6.3,4H TO F6.3,13H IN STEPS OF F5.3,1H./
	1       13H Y GOES FROM F6.3,4H TO F6.3,13H IN STEPS OF F5.3,1H./
	2      13H Z GOES FROM F6.3,4H TO F6.3,13H IN STEPS OF F5.3,1H.//
	3 16H ORIENTATION IS I3,1H./39H NO. OF EQUIVALENT REFLECTIONS (HKL)
	4 = ,I3/6H LIST I5,13H REFLECTIONS. ///)
109	FORMAT(3(F15.9 ,3I3))
115	FORMAT (10H0  H  K  L,6X1HA,9X1HB //)
116	FORMAT (10H0  H  L  K,6X1HA,9X1HB //)
117	FORMAT (10H0  L  K  H,6X1HA,9X1HB //)
203	FORMAT ( 3I4,6F7.2, F5.3,I3  )
305	FORMAT(1H ,3I3,2F10.2)
306	FORMAT(1H  )
352	FORMAT(5H0THE I5,47H INDEPENDENT REFLECTIONS HAVE BEEN EXPANDED TO
	1 I6,7H TERMS. //)
355	FORMAT(23H THE CD TABLE REQUIRES I5,14H MEMORY UNITS.//)
357	FORMAT(23H THE EF TABLE REQUIRES I5,14H MEMORY UNITS.  // )
361	FORMAT(36H THE MAXIMUM SIZE OF THE EF TABLE IS I5,57H MEMORY UNITS
	1.  THE PROGRAM WILL SPLIT EACH SECTION INTO I2,7H PARTS.///)
390	FORMAT( 29H0 THE FOURIER SUMMATION OVER F8.0,17H GRID POINTS AND
	1 I4,14H SECTIONS FOR I6,17H TOTAL REFLEXIONS )
C
C
	READ (IN,80 ) NEQUIV,NREF,NTAPIN,NSP,NREJ,NALT,NXT,
	1                F000, (EXT(I),I=1,4)
	WRITE ( III,80 ) NEQUIV,NREF,NTAPIN,NSP,NREJ,NALT,NXT,
	1                  F000, (EXT(I),I=1,4)
	IF(NTAPIN) 1,1,2
2	REWIND NDATAP
1	REWIND IXX
	REWIND IVXX
	NEXPAN=0
	NTOTAL=0
	AMAX=0.
	BMAX=0.
	NZERO=0
	JMAX=0
	KMAX=0
	KMIN=0
	IF  (NTAPIN)  85,  85,  84
84	WRITE ( III,88 ) NDATAP
	GO TO 87
85	WRITE ( III,89 )
87	READ (IN,90) XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,DX,DY,DZ,NORIEN
	CALL CHEKUP(XMIN,XMAX,NORIEN,100,DX)
	CALL CHEKUP(YMIN,YMAX,NORIEN, 10,DY)
	CALL CHEKUP(ZMIN,ZMAX,NORIEN,  1,DZ)
104	WRITE (III, 91) XMIN,XMAX,DX,YMIN,YMAX,DY,ZMIN,ZMAX,DZ,
	1NORIEN,NEQUIV,NREF
	IF(NORIEN-10)98,96,94
94	CALL ROTATE(XMIN,ZMIN)
	CALL ROTATE (XMAX,ZMAX)
	CALL ROTATE (DX,DZ)
	GO TO 98
96	CALL ROTATE (YMIN,ZMIN)
	CALL ROTATE (YMAX,ZMAX)
	CALL ROTATE (DY,DZ)
98	NX=(XMAX-XMIN)/DX+1.001
	NY=(YMAX-YMIN)/DY+1.001
	NZ=(ZMAX-ZMIN)/DZ+1.001
122	DO  139  I=1,NEQUIV
	READ (IN,20) (RN(N),J(N),K(N),N=1,3)
	DO  130  N=1,3
	M1(I,N)=0
	M2(I,N)=0
	M3(I,N)=0
	KK=0
	JSMC=ISIGN(1,J(N))
	JSM=IABS(J(N))+1
128	GO TO ( 123, 124, 125, 126), JSM
124	M1(I,N)=M1(I,N)+JSMC
	GO TO 123
125	M2(I,N)=M2(I,N)+JSMC
	GO TO 123
126	M3(I,N)=M3(I,N)+JSMC
123	IF ( KK )  127,  127,  130
127	KK=1
	JSMC=ISIGN(1,K(N))
	JSM=IABS(K(N))+1
	GO TO 128
130	CONTINUE
	WRITE (III,109) (RN(NN),M1(I,NN),M2(I,NN),M3(I,NN),NN=1,3)
	IF(M1(I,1)+M2(I,1))170,400,170
170	IF(M1(I,2)+M2(I,2))179,401,179
400	IF (IABS(M1(I,1))+IABS(M2(I,1)))  179,  179,  171
401	IF ( IABS(M1(I,2))+IABS(M2(I,2)))  179,  179,  171
C     HEXAGONAL SITUATIONS
171	     IF (M1(I,1)+M2(I,2)) 173, 172, 173
172	     NSAVE=M2(I,1)
	     M2(I,1)=M1(I,2)
	     M1(I,2)=NSAVE
	     GO TO 179
173	     NSAVE = M2(I,2)
	     M2(I,2) = M1(I,1)
	     M1(I,1)=NSAVE
179	DO  129  NN=1,3
132	IF ( RN(NN) )  133,  129,  129
133	RN(NN)=1.0+RN(NN)
	GO TO 132
129	CONTINUE
	MTX(I)=12.*RN(1)+.1
	MTY(I)=12.*RN(2)+.1
139	MTZ(I)=12.*RN(3)+.1
110	IF(NREF)111,1000,111
111	IF(NORIEN-10)112,113,114
112	WRITE ( III,115 )
	GO TO 1000
113	WRITE (III, 116 )
	GO TO 1000
114	WRITE (III, 117 )
1000	JJ=0
	KK=0
	LL=0
	AA=F000
	BB=0.0
	NSP=NSP+1
	NSKIP=0
	IF  ( NTAPIN )  1001, 206, 1001
C     SKIP THE RECIPROCAL CELL DATA
1001	READ (NDATAP )  RHO
	  GO TO 206
C     REFLEXION DATA READ
201	IF  (NTAPIN)  202,  202,  142
C     REFLEXION DATA ON CARDS
202	READ (IN,203 ) JJ,KK,LL,FOBS,FCAL,AA,AC,BB,BC,SINT,ID
	FH=JJ
	GO TO 1023
C     REFLEXION DATA ON TAPE
142	READ (NDATAP ) FH,FK,FL,FOBS,FCAL,AA,AC,BB,BC,SIGYO,FS,ID,RHO,
	1  SINT,FAT,FAT,FAT,FAT,FAT,FAT,FAT,FAT,FAT,FAT,PA,PB
	JJ=FH
	KK=FK
	LL=FL
1023	 IF  (FH-999.)  1040,  320,  320
1040	IF  (NALT)  188,  189,  188
188	CALL ALTER(JJ,KK,LL,FOBS,FCAL,AA,AC,BB,BC,ID,RHO,SINT,NXT,EXT,
	1      PA,PB )
189	GO TO ( 204, 183, 184, 186, 187, 182 ), NSP
183	AA=AA-AC
	BB=BB-BC
	GO TO 204
184	IF  (FOBS)  185,  201,  185
185	AA=FOBS*FOBS
	BB=0.
	GO TO 204
186	AA=AC
	BB=BC
	GO TO 204
187	AA=FCAL*FCAL
	BB=0.
	GO TO 204
182	AA=AA-PA
	BB=BB-PB
204	IF  ( NREJ )  205,  206,  205
205	CALL REJECT(JJ,KK,LL,FOBS,FCAL,AA,AC,BB,BC,ID,RHO,SINT,NXT,EXT,
	1             NSKIP  )
	IF  ( NSKIP )  201,  206,  201
206	IF  ( AA )  210,  212,  210
212	IF  ( BB )  210,  201,  210
210	NTOTAL=NTOTAL+1
	DO  254  N=1,NEQUIV
217	J(N)=M1(N,1)*JJ+M2(N,1)*KK+M3(N,1)*LL
	K(N)=M1(N,2)*JJ+M2(N,2)*KK+M3(N,2)*LL
	L(N)=M1(N,3)*JJ+M2(N,3)*KK+M3(N,3)*LL
	NU=J(N)*MTX(N)+K(N)*MTY(N)+L(N)*MTZ(N)
	CALL TRIG(XCOS,XSIN,NU)
	A(N)=AA*XCOS-BB*XSIN
	B(N)=BB*XCOS+AA*XSIN
224	IF(NORIEN-10)238,225,231
225	CALL ROTATE (K(N),L(N))
	GO TO 238
231	CALL ROTATE(J(N),L(N))
238	JPLMI=JZRTST(J(N))
	IF(JPLMI) 239,246,242
239	J(N)=-J(N)
240	K(N)=-K(N)
241	L(N)=-L(N)
	B(N)=-B(N)
242	IF(J(N))246,243,246
243	IF(K(N))240,244,246
244	IF(L(N))241,246,246
246	IF(K(N))255,251,255
251	K(N)=0
255	IF(L(N))257,256,257
256	L(N)=0
257	IF (JMAX-J(N))247,249,249
247	JMAX=J(N)
249	IF(KMAX-K(N))250,252,252
250	KMAX=K(N)
	GO TO 254
252	IF(KMIN-K(N))254,254,253
253	KMIN=K(N)
254	CONTINUE
260	NEW=NEQUIV-1
	DO 270 NN =1,NEW
	NOW=NN+1
	DO 270 N=NOW,NEQUIV
	IF(A(NN))265,264,265
264	IF(B(NN))265,270,265
265	IF(J(NN)-J(N))270,266,270
266	IF(K(NN)-K(N))270,267,270
267	IF(L(NN)-L(N))270,268,270
268	A(N)=0.
	B(N)=0.
270	CONTINUE
	NTRAN=0
	DO 300 N=1,NEQUIV
	IF(A(N))298,285,298
285	IF(B(N))298,300,298
298	AMAX=AMAX+ABS(A(N))
	BMAX=BMAX+ABS(B(N))
	NTRAN=NTRAN+1
	JX(NTRAN)=J(N)
	KX(NTRAN)=K(N)
	LX(NTRAN)=L(N)
	AX(NTRAN)=A(N)
	BX(NTRAN)=B(N)
300	CONTINUE
	WRITE (IVXX ) NTRAN
	WRITE (IVXX ) (JX(N),KX(N),LX(N),AX(N),BX(N),N=1,NTRAN)
	NEXPAN=NEXPAN+NTRAN
301	IF(NREF)201,201,302
302	NREF=NREF-1
303	DO 304 N=1,NTRAN
304	WRITE (III, 305 ) JX(N),KX(N),LX(N),AX(N),BX(N)
	WRITE (III, 306 )
	GO TO 201
C     END OF DATA
320	WRITE ( IVXX ) NZERO
	END FILE IVXX
	REWIND IVXX
	IF  (NTAPIN)  321,  322,  321
321	 REWIND NDATAP
322	NCD=(JMAX+1)*(KMAX-KMIN+1)*2
	NEF=(JMAX+1)*NY*2
	ASSIGN 332 TO NXIT
329	NMEM=0
330	READ ( IVXX ) NTRAN
332	IF(NTRAN)331,348,331
331	NMEM=NMEM+NTRAN
	IF(NMEM-24)335,335,338
335	NPREV=NMEM-NTRAN+1
	READ (IVXX ) (J(N),K(N),L(N),A(N),B(N),N=NPREV,NMEM)
	IF(NMEM-24)330,337,385
337	READ (IVXX ) NTRAN
	GO TO 340
338	NMEM=NMEM-NTRAN+1
	DO 339 M=NMEM,24
	J(M)=0
	K(M)=0
	L(M)=0
	A(M)=0.
339	B(M)=0.
340	WRITE (IXX ) (J(N),K(N),L(N),A(N),B(N),N=1,24)
	NMEM=0
	GO TO NXIT,(332,350)
348	ASSIGN 350 TO NXIT
	REWIND IVXX
	 GO TO 338
350	DO 351 N=1,24
351	J(N)=999
	WRITE (IXX )(J(N),N=1,24),(J(N),N=1,24),(J(N),N=1,24),
	1               (J(N),N=1,24),(J(N),N=1,24)
	REWIND IXX
	WRITE (III, 352 ) NTOTAL,NEXPAN
	NEFTBL=NMEMMX-NCD
	WRITE (III, 355 ) NCD
	IF(NEFTBL-NEF)360,356,356
356	WRITE (III, 357 ) NEF
	GO TO 385
360	NNN=NY*(JMAX+1)/NEFTBL + 1
	WRITE (III, 361 ) NEFTBL,NNN
385	TOTXY=NX*NY
	FNZ=NZ
	TOTL=TOTXY*FNZ
	WRITE ( III, 390 ) TOTL,NZ,NEXPAN
	RETURN
	END
C     SUBROUTINE SIG 100
	SUBROUTINE SIG100
	DIMENSION J(24), K(24), L(24), A(24), B(24), R(1001), TABLE(12000)
	DIMENSION  WORDS(20)
	COMMON TRGTBL(1001), NORIEN,NXMAX,NYMAX,NZ,XMIN
	COMMON  XMAX   , YMIN   , YMAX   , ZMIN   , ZMAX   , DX
	COMMON  DY     , DZ     , AMAX   , BMAX   , JMAX   , KMAX
	COMMON  KMIN   , NMEMMX , NEGINA , NCD    , NEF    , NEFTBL
	COMMON  NX     , NY     , NCUE   , N1     , RMAX   , NLAST
	COMMON  NFPLT  , YFL    , N11    , IN     , III    , IVXX
	COMMON  IXX    , NINPUT , NN3    , NDATAP , ISST(10),AXX
	COMMON  BXX    , C      , COSA   , COSB   , COSC   , NSEC
	COMMON NGRID,NSKIP,CNTRNO,CNTNEG,NEXPAN,WORDS
	COMMON TABLE
441	FORMAT( 8H0RMAX =  E13.6,4X6HRMIN = E13.6 ///)
	REWIND IVXX
	SEV      = 1000.0
	ZER      =    0.0
	AOM7     =-1000.0
	RMAX     =    0.0
	RMIN=0.0
	NJ       = JMAX + 1
	NK       = KMAX - KMIN + 1
	NC       = NCD / 2
	Z        = ZMIN
	NZMAX=IFIX((ZMAX-ZMIN)/DZ)+1
	NYMAX=IFIX((YMAX-YMIN)/DY)+1
	NZ = 1
100	DO 120 I = 1, NMEMMX
120	TABLE(I) = 0.0
130	IF (ISST(8)-2)  99130,1300,99130
99130	 READ ( IXX ) ( J(I), K(I), L(I), A(I), B(I), I = 1, 24 )
	GO TO 1301
1300	READ (IXX) (J(I),K(I),L(I),B(I),A(I), I=1,24)
1301	DO  143  I=1,24
	IF( J(I) .EQ. 999 ) GO TO 175
	LOCC = J(I) * NK + ( K(I) - KMIN ) + 1
	LOCD = LOCC + NC
	XL = L(I)
	XLZ = XL * Z
	CALL SINCOS ( XLZ, SINLZ, COSLZ )
	TABLE(LOCC) = TABLE(LOCC) + A(I) * COSLZ + B(I) * SINLZ
	TABLE(LOCD) = TABLE(LOCD) - A(I) * SINLZ + B(I) * COSLZ
143	CONTINUE
	GO TO 130
175	REWIND IXX
	YI  =  YMIN
	YF  =  YMAX
204	NY=IFIX((YF-YI)/DY)+1
	NEF = ( JMAX + 1 ) * NY * 2
	IF ( (NCD+NEF) .LE. NMEMMX ) GO TO 205
	YF = YF - DY
	GO TO 204
205	NE = NY * NJ
	XKMIN = KMIN
	LOCEI = NCD + 1
	LOCEF = LOCEI + 2*NE - 1
	DO 206 I = LOCEI, LOCEF
206	TABLE(I) = 0.0
	LOCC = 1
	LOCD = LOCC + NC
	DO 250 N = 1, NJ
	RKDY = XKMIN * DY
	RKYI = XKMIN * YI
	DO 240 M = 1, NK
	LOCE = LOCEI
	RKY = RKYI
	LOCF = LOCE + NE
	CHY = TABLE(LOCC)
	DHY = TABLE(LOCD)
	DO 230 I = 1, NY
	CALL SINCOS( RKY, SINKY, COSKY )
	TABLE(LOCE) = TABLE(LOCE) + CHY*COSKY + DHY*SINKY
	TABLE(LOCF) = TABLE(LOCF) - CHY*SINKY + DHY*COSKY
	LOCE = LOCE + NJ
	LOCF = LOCE + NE
	RKY = RKY + RKDY
230	CONTINUE
	RKYI = RKYI + YI
	RKDY = RKDY + DY
	LOCC = LOCC + 1
	LOCD = LOCC + NC
240	CONTINUE
	LOCEI = LOCEI + 1
250	CONTINUE
	NX=IFIX((XMAX-XMIN)/DX)+1
	LOCE = NCD + 1
	LOCF = LOCE + NE
	Y = YI
	WRITE(IVXX) SEV, SEV
	WRITE(IVXX) NX, NY, XMIN, XMAX, DX, ZMAX, Z, NORIEN, Y   , YMAX,
	X            DY, AMAX, BMAX, DZ, ZMIN, NZ
	DO 380 I = 1, NY
	DO 320 N = 1, NX
320	R(N) = 0.0
	HDX = 0.0
	HXI = 0.0
	DO 360 M = 1, NJ
	E = TABLE( LOCE )
	F = TABLE ( LOCF )
	HX = HXI
	DO 340 N = 1, NX
	CALL SINCOS ( HX, SINHX, COSHX )
	R(N) = R(N) + E * COSHX + F * SINHX
	HX = HX + HDX
340	CONTINUE
	HDX = HDX + DX
	HXI= HXI+ XMIN
	LOCE = LOCE + 1
	LOCF = LOCE + NE
360	CONTINUE
	DO 370 N = 1, NX
	IF ( ABS(R(N))-RMAX )  365,  365,  364
364	RMAX=ABS(R(N))
365	IF ( R(N)-RMIN )  366,  370,  370
366	RMIN=R(N)
370	CONTINUE
	WRITE ( IVXX ) ZER, ZER
	WRITE (IVXX) Y, ( R(N), N = 1, NX )
	Y = Y + DY
380	CONTINUE
	IF ( YF .GE. YMAX ) GO TO 400
	YI = YF
	YF = YMAX
	GO TO 204
400	Z = Z + DZ
	NZ = NZ + 1
	IF ( NZ .LE. NZMAX ) GO TO 100
	WRITE ( IVXX ) AOM7, RMAX
	WRITE ( III,441 ) RMAX,RMIN
	END FILE IVXX
	REWIND IVXX
	RETURN
	END
CFRPEAK
C     PICKS OUT PEAKS ON THE FOURIER AND PRINTS THEM IN ORDER OF
C       DECREASING SIZE.
C     USES DATA ON FOURIER BINARY OUTPUT TAPE IVXX (C4).
C
	SUBROUTINE FRPEAK
	DIMENSION R(1010,3),XX(1003),YY(1003),         ZZ(1003),
	1  NNX(1003),NNY(1003), NNZ(1003),RR(1003),TRGTBL(1014),ISST(10),
	2  RRR(250),NNNX(250),NNNY(250),NXPREV(250),RRPREV(250),NYPREV(250)
	3 ,EXCESS(12),WORDS(20),SPACE(5)
	DIMENSION  XYZ(3)
	COMMON TRGTBL,          AMAX,BMAX,EXCESS,RMAX,NLAST,YFPLT,YFL,N11,
	2  IN,III,IVXX,IXX,NTPCH,NN3,NN5,ISST,A,B,C,COSA,COSB,COSC,SPACE,
	3 NEXPAN,WORDS,
	4R,XX,YY,ZZ,NNX,NNY,NNZ,RR,RRR,NNNX,NNNY,NXPREV,NYPREV,RRPREV
	DATA  BSTR/'*'/,BBLK/' '/
C
1	FORMAT ( 1H1, 20A4 )
406	FORMAT( 1H ,20H250 PEAKS IN SECTION,F7.3,22H,  THE REST IS SKIPPED
	1  //)
516	FORMAT (1H0,  30H1000 PEAKS FOUND UP TO SECTION , F6.3 )
703	FORMAT(75H0LIST OF PEAK POSITIONS AND THEIR HEIGHTS.  RHO=TRUE RHO
	1 X  999. / RHO MAX.  /// )
716	FORMAT(5H  NO.,5X1HX,7X1HY,7X1HZ,7X3HRHO,6X8HTRUE RHO //)
810	FORMAT (1H ,I4,3F8.4,I8,4H   (,F14.3,1H),1XA1 )
811	FORMAT  ( 27X 3F9.6,21X I5  )
1000	FORMAT (F10.5,3I5 )
1001	FORMAT (7H0RMIN =F10.5,5X6HRMAX =F14.3,5X14HNO. OF PEAKS =I4 )
C
	REWIND IVXX
	MZ=-1
	WRITE (III,1 ) WORDS
	READ (IN,1000 ) RMIN,JPEAK,JEDG
	JLAST=0
	IF(ISST(7))51,52,51
52	LT=1000
	GO TO 53
51	LT=100*ISST(7)
53	L=0
	NZ=0
	DO 70 M=1,250
	NNX(M)=0
	NNY(M)=0
	NNZ(M)=0
	RRR(M)=RMIN
	NNNX(M)=0
	NNNY(M)=0
	RRPREV(M)=RMIN
	NXPREV(M)=0
70	NYPREV(M)=0
	ASSIGN 100 TO NEWDAT
	ASSIGN 250 TO INDATA
	READ (IVXX ) CODE
	GO TO 115
100	READ (IVXX)  CODE,RMXX
	IF(CODE)108,200,110
108	ASSIGN 700 TO NEWDAT
	RMAX=RMXX
	GO TO 111
110	ASSIGN 640 TO NEWDAT
111	ASSIGN 240 TO INDATA
	GO TO 200
115	READ (IVXX ) NX,NY,XMIN,XMAX,DELTAX,ZMAX,Z,NXIS,YMIN,YMAX,DY
	ZLST=Z
	MZ=MZ+1
	IF(MZ)2,3,2
3	ZMIN=Z
	XLST=XMIN+FLOAT(NX-1)*DELTAX
	YLST=YMIN+FLOAT(NY-1)*DY
C     NX=NUMBER OF GRIDS ACROSS THE PAGE
2	NXX=NX+2
	DO 120 K=1,3
	DO 120 I=1,NXX
120	R(I,K)=RMIN
	NZ=NZ+1
	NXXX=NX+1
	J=0
	NYN=0
	GO TO 100
C     SHIFT THE CONTENTS OF LINES
200	DO 220 I=1,NXX
	R(I,1)=R(I,2)
220	R(I,2)=R(I,3)
	Y=Y+DY
	GO TO INDATA, (250,240)
240	DO 245 I=2,NXXX
245	R(I,3)=RMIN
	ASSIGN 250 TO INDATA
	GO TO 290
C     READ IN ONE HORIZONTAL LINE VALUES
250	READ (IVXX ) Y,(R(I,3),I=2,NXXX)
	Y=Y-DY
290	X=XMIN-DELTAX
	NYN=NYN+1
305	DO 590 I=2,NXXX
	X=X+DELTAX
	IF(R(I,2)-RMIN) 590,590,306
306	JJ=I-1
	JJJ=I+1
	DO 320 M=JJ,JJJ
	DO 320 K=1,3
	IF(R(I,2)-R(M,K)) 590, 320, 320
320	CONTINUE
400	J=J+1
	IF(J-250)408, 408, 405
405	WRITE (III, 406) Z
	J=J-1
	GO TO 591
C     A PEAK IN TWO DIMENNSIONAL SEARCH
408	RRR(J)=R(I,2)
	NNNX(J)=I-1
	NNNY(J)=NYN
409	DO 430 M=1,JLAST
	NEWY=IABS(NYN-NYPREV(M))
	IF(NEWY-1)410,410,430
410	NEWX=IABS(I-1-NXPREV(M))
	IF(NEWX-1)415,415,430
415	IF(R(I,2)-RRPREV(M))590,440,440
430	CONTINUE
C     IF CURRENT PEAK IS HIGHER, REPLACE
440	DO 480 K=1,L
	IF(NZ-NNZ(K)-1) 480, 450, 480
450	NEWY=IABS(NYN-NNY(K))
	IF(NEWY-1) 460, 460, 480
460	NEWX=IABS(I-1-NNX(K))
	IF(NEWX-1) 470, 470, 480
470	IF(R(I,2)-RR(K))590, 475, 475
475	XX(K)= X
	YY(K)=Y
	ZZ(K)=Z
	RR(K)=R(I,2)
	NNX(K)=I-1
	NNY(K)=NYN
	NNZ(K)=NZ
	GO TO  590
480	CONTINUE
510	L=L+1
C     IF THE PEAK TABLE IS FILLED UP
	IF(L-1000)520,520,515
515	WRITE (III,516 ) Z
	L=L-1
C     SKIP TO THE LAST RECORD
	IF ( CODE )  700,  517,  518
517	READ ( IVXX )  CODE,RMAX
	IF ( CODE )  700,  518,  518
518	READ ( IVXX )  Y,(R(I,3),I=2,10)
	GO TO 517
C     STORE THE INFORMATION ABOUT THE PEAK
520	XX(L)= X
	YY(L) = Y
	ZZ(L) = Z
	RR(L) = R(I,2)
	NNX(L) = I-1
	NNY(L) = NYN
	NNZ(L) = NZ
590	CONTINUE
591	GO TO NEWDAT,(100 ,640,700)
C     FOR A NEW SECTION
640	ASSIGN 100 TO NEWDAT
	JLAST=J
	DO 680 I=1,JLAST
	RRPREV(I)=RRR(I)
	NXPREV(I)=NNNX(I)
680	NYPREV(I)=NNNY(I)
	GO TO 115
C     END OF ALL SECTIONS
700	REWIND IVXX
	WRITE (III,1001 ) RMIN,RMAX,L
	WRITE (III, 703 )
	WRITE (III, 716 )
	LP=0
	IF(NXIS-10) 705, 706, 707
705	JX1=1
	JX2=2
	JX3=3
	GO TO 719
706	JX1=1
	JX2=3
	JX3=2
	GO TO 719
707	JX1=3
	JX2=2
	JX3=1
719	CONST = 999./RMAX
C     SORT AND PRINT THE PEAKS IN ORDER OF MAGNITUDE
725	 DO 740 K=1,L
	IF(RR(K)-RMIN) 740,740,730
730	ICE=K
	RBIG=RR(K)
	GO TO 760
740	CONTINUE
	GO TO 880
760	DO 780 K=1,L
	IF(RBIG-RR(K)) 770, 780, 780
770	RBIG=RR(K)
	ICE = K
780	CONTINUE
	RR(ICE)=RMIN
	NRR=RBIG*CONST+.5
	BDER=BBLK
	IF ( ABS(XX(ICE)-XLST)-0.0005 )  910,  910,  911
911	IF ( ABS(XX(ICE)-XMIN)-0.0005 )  910,  910,  912
912	IF (ABS(YY(ICE)-YLST)-0.0005 )  910,  910,  913
913	IF ( ABS(YY(ICE)-YMIN)-0.0005 )  910,  910,  914
914	IF ( ABS(ZZ(ICE)-ZLST)-0.0005 )  910,  910,  915
915	IF ( ABS(ZZ(ICE)-ZMIN)-0.0005 )  910,  910,  916
C     IF PEAKS AT THE EDGES ARE INCLUDED
910	IF ( JEDG )  917,  917,  725
917	BDER=BSTR
916	LP=LP+1
	XYZ(1)=XX(ICE)
	XYZ(2)=YY(ICE)
	XYZ(3)=ZZ(ICE)
	WRITE (III,810) LP,XYZ(JX1),XYZ(JX2),XYZ(JX3),NRR,RBIG,BDER
	IF  (JPEAK )  782,  782,  781
C     PUNCH OUT THE COORDINATES IN SF-LS FORMAT
781	WRITE (NTPCH,811 ) XYZ(JX1),XYZ(JX2),XYZ(JX3),LP
782	IF ( LP-LT )  725,  880,  880
880	RETURN
	END
CFRPRNT
C
	SUBROUTINE FRPRNT
C                  MODIFIED BY R.SHIONO     MAY 1965
C     BINARY INPUT TAPE IS IVXX.
C                     TO NORMALIZE THE DATA FOR THE FIXED POINT OUTPUT.
C                     THE NORMALIZING FACTOR IS C= 999./RMAX.
C                       RMAX IS THE MAXIMUM ELECTRON DENSITY ON THE TAPE
C                       AMAX+BMAX IS THE SUM OF ALL THE A,S AND B,S.
C
	DIMENSION X(1001),NR(101,101),ISST(10), Y(101), TRGTBL(1001)
	1   ,RR(101),X1(26),IX1(26),WORDS(20)
	DIMENSION  ALXY(6)
	DIMENSION  LABC(45)
	COMMON TRGTBL,NXIS,NXX,NYX,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,
	1 DELTAX,DY,DZ,AMAX,BMAX,JMAX,KMAX,KMIN,NMEMMX,NEGINA,NCD,NEF,
	2 NEFTBL,NX,NY,LMTD,N1,RMAX,NLAST,NFPLT,YFL,N11,IN,III,IVXX,IXX,
	3  NTPCH,NN5,NDATAP,ISST,
	4 AXXX,BXXX,CXXX,COSA,COSB,COSC,NSEC,NGRID,NSKIP,CNTRNO,CNTNEG,
	5NEXPAN,WORDS,NR,X,Y,RR
	DATA  LABC/'A','B','C','D','E','F','G','H','I','J','K','L','M','N'
	1, 'O','P','Q','R','S','T','0','1','2','3','4','5','6','7','8',
	2   '9','U','V','W','X','Y','Z','/','-','=','*',','/
	DATA  LDEC/'.'/
	DATA  ALXY/' X =',' Y =',' Z =','X=','Y=','Z='/
C
3011	FORMAT (1H ,13X26F4.0)
3012	FORMAT (1H ,13X26(1XI3))
303	FORMAT (1H ,13X 26A4 )
302	FORMAT (1H ,A2,F6.3,5X 26I4 )
3031	FORMAT (1H ,A2,F6.3,5X 101A1 )
3032	FORMAT (1H ,A2,F6.3,5X 51A2 )
3033	FORMAT (1H ,A2,F6.3,5X 35A3 )
3034	FORMAT  (  3F5.3, 1X 16I4  )
3035	FORMAT (  3F5.3,  65A1  )
3021	FORMAT (1H ,A2,F6.3,5X 26A4 )
3001	FORMAT (1H ,50X 15H*************** )
300	FORMAT (6H RMAX=,F15.2,30X 1H*,3XA4,F6.3,1H*,32X 3HC =,F14.7 )
2125	FORMAT(1H      )
2225	FORMAT (1H1)
9000	FORMAT(1H1////)
C
	IALPH=ISST(2)+1
	MPCH=IALPH
	ISNG=ISST(3)+1
	MBLK=ISST(8)+1
	NPDF=26
	GO TO ( 7, 8, 255, 255, 257, 257 ), MPCH
257	IALPH=IALPH-4
	GO TO 258
255	IALPH=IALPH-2
258	NPDF=16
C     IALPH=1  NUMERIC,  =2  ALPHABETIC
	GO TO ( 7,  256 ), IALPH
256	NPDF=65
	GO TO 9
8	GO TO ( 10, 11, 12, 9 ), MBLK
10	NPDF=101
	GO TO 9
11	NPDF=51
	GO TO 9
12	NPDF=35
9	IF  ( LMTD )  13,  13,  14
13	LMTD=1000
14	ND=ISST(9)
	IF  ( ND )  5,  5,  6
5	ND=10
6	LDD=FLOAT(LMTD)/FLOAT(ND)+0.5
	LDST=LMTD-LDD
C     ASSIGN THE HEADER CHARACTERS
7	CHAR=ALXY(1)
	AHEAD=ALXY(5)
	IF  ( NXIS-10 )  457,  458,  459
457	CHARA=ALXY(3)
	GO TO 470
458	CHARA=ALXY(2)
	AHEAD=ALXY(6)
	GO TO 470
459	CHARA=ALXY(1)
	CHAR=ALXY(3)
C     SINGLE, DOUBLE OR TRIPLE SPACES
470	IF  ( ISST(5)-2 )  1,  2,  4
1	ISZ=1
	GO TO 5510
2	ISZ=2
	GO TO 5510
4	ISZ=3
5510	IF(AMAX+BMAX)5999,1901,5999
1901	AMAX = 1000.
5999	REWIND IVXX
196	IF(RMAX)202,200,202
C     GET RMAX ON THE TAPE
200	READ (IVXX ) CODE,RMAX
	IF(CODE)202,201,201
201	READ (IVXX ) TEMP
	GO TO 200
202	C=999./RMAX
	IF  ( ISST(4)-1 )  310,  250,  254
250	CTRUE=1000000.
253	IF  ( C-CTRUE )  251,  252,  252
251	CTRUE=CTRUE*0.1
	GO TO 253
254	C=9./RMAX
	GO TO 310
252	C=CTRUE
310	REWIND IVXX
C     START READING IN THE RESULT TAPE
2281	READ (IVXX ) CODE
228	IF(CODE)219,207,203
203	READ (IVXX ) NX,NY,XMIN,XMAX,DELTAX,ZMAX,Z,NXIS,YMIN,YMAX,DY,
	1 AMAX, BMAX, DZ
	NXNY=NX*NY
	IF ( NXNY-10201 )  400,  400,  404
404	NVAR=0
	GO TO 405
400	   NVAR=1
C     READ IN SECTION OF RESULT AT A TIME
	DO  441  I=1,NY
	READ (IVXX )  TEMP
	READ (IVXX ) Y(I),(RR(J),J=1,NX)
	   DO 440 J=1,NX
	   IF(RR(J)) 438, 439, 439
438	GO TO  ( 436,  437 ), ISNG
436	NR(J,I)=C*RR(J)-0.5
	GO TO ( 440, 430), IALPH
437	GO TO ( 433, 431 ), IALPH
431	NR(J,I)=LDEC
	GO TO 440
433	NR(J,I)=0
	GO TO 440
439	NR(J,I)=C*RR(J)+0.5
	GO TO ( 440, 432 ), IALPH
432	LD=LDST
	LA1=1
	GO TO 429
430	LD=-LDD
	LA1=21
429	LA2=LA1+ND-1
	NRV=NR(J,I)
	DO  435  LA=LA1,LA2
	IF  ( NRV-LD )  435,  434,  434
435	LD=LD-LDD
	LA=LA2
434	NR(J,I)=LABC(LA)
440	CONTINUE
441	CONTINUE
405	X(1)=XMIN
	DO 204 J=2,NX
204	X(J)=X(J-1)+DELTAX
	GO TO ( 205, 205, 207, 207, 350, 350 ), MPCH
C     PRINT HEADING, SECTION COORDINATE
205	WRITE (III, 2225 )
	WRITE (III, 3001 )
	WRITE (III, 300) RMAX,CHARA,Z,C
	WRITE (III, 3001 )
207	NP = 1
	NQ=NPDF
216	IF(NX-NQ)98,218,218
98	NQ=NX
218	GO TO (  206,  206,  208,  208 ), MPCH
206	WRITE (III,303 ) CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,
	1CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,CHAR,
	2CHAR,CHAR,CHAR,CHAR,CHAR
C     HEADING MAY BE PRINTED FOR FIRST 26 GRIDS ONLY
	NNQ=NQ-NP+1
	IF  ( NNQ-26 )  420,  420,  421
421	NNQ=26
420	NNP=NP+NNQ-1
	DO  3  J=NP,NNP
	K=1+MOD(J-1,NPDF)
	X1(K)=INT(X(J))
3	IX1(K)=SIGN(1.0,X(J))*AMOD(1000.0*X(J),1000.0)+0.0005
	WRITE (III, 3011) (X1(K),K=1,NNQ)
	WRITE (III,3012 ) (IX1(K),K=1,NNQ)
	WRITE (III, 2125 )
208	IF  ( NVAR )  213,  213,  450
450	DO  472 I=1,NY
	GO TO (  486,  487,  209,  210 ), MPCH
486	WRITE (III, 302) AHEAD,Y(I),(NR(J,I),J=NP,NQ)
	GO TO 488
209	WRITE (NTPCH,3034 ) X(NP),Y(I),Z,(NR(J,I),J=NP,NQ)
	GO TO 472
210	WRITE (NTPCH,3035 ) X(NP),Y(I),Z,(NR(J,I),J=NP,NQ)
	GO TO 472
487	GO TO ( 490, 491, 492, 493 ), MBLK
490	WRITE (III, 3031 ) AHEAD,Y(I),(NR(J,I),J=NP,NQ)
	GO TO 488
491	WRITE (III, 3032) AHEAD,Y(I),(NR(J,I),J=NP,NQ)
	GO TO 488
492	WRITE (III, 3033) AHEAD,Y(I),(NR(J,I),J=NP,NQ)
	GO TO 488
493	WRITE (III, 3021) AHEAD,Y(I),(NR(J,I),J=NP,NQ)
488	GO TO ( 472, 462, 460 ), ISZ
460	WRITE (III, 2125)
462	WRITE (III, 2125)
472	CONTINUE
480	   IF(NX-NQ) 2281, 2281, 485
485	GO TO ( 483, 483, 484, 484 ), MPCH
483	WRITE (III, 9000)
484	NP=NP+NPDF
	NQ=NQ+NPDF
	   GO TO 216
C
C     PUNCH OUT HORIZONTALLY FIRST ( MINIMUM FUNCTION INPUT)
350	DO  360  I=1,NY
	NP=1
	NQ=NPDF
351	IF ( NX-NQ )  352,  353,  353
352	NQ=NX
353	GO TO ( 355, 356 ), IALPH
355	WRITE ( NTPCH,3034) X(NP),Y(I),Z,(NR(J,I),J=NP,NQ)
	GO TO 357
356	WRITE (NTPCH,3035 ) X(NP),Y(I),Z,(NR(J,I),J=NP,NQ)
357	IF ( NX-NQ )  360,  360,  354
354	NP=NP+NPDF
	NQ=NQ+NPDF
	GO TO 351
360	CONTINUE
	GO TO 2281
C     IF NX*NY IS GREATER THAN 10201
C     PUNCHING IS NOT IMPLEMENTED IN THIS PART
213	DO 2123 N=1,NY
	READ (IVXX )  TEMP
211	READ (IVXX ) Y(1),(RR(J),J=1,NX)
	DO 212  J=NP,NQ
	IF  ( RR(J) )  230,  231,  231
230	GO TO ( 232, 233 ), ISNG
232	NR(J,1)=C*RR(J)-0.5
	GO TO ( 212, 239), IALPH
233	GO TO ( 238, 234 ), IALPH
234	NR(J,1)=LDEC
	GO TO 212
238	NR(J,1)=0
	GO TO 212
231	NR(J,1)=C*RR(J)+0.5
	GO TO ( 212, 235 ), IALPH
235	LD=LDST
	LA1=1
	GO TO 240
239	LD=-LDD
	LA1=21
240	LA2=LA1+ND-1
	NRV=NR(J,1)
	DO  236  LA=LA1,LA2
	IF  ( NRV-LD )  236,  237,  237
236	LD=LD-LDD
	LA=LA2
237	NR(J,1)=LABC(LA)
212	CONTINUE
	GO TO ( 1000, 1001 ), IALPH
1000	WRITE (III, 302) AHEAD,Y(1),(NR(J,1),J=NP,NQ)
	GO TO 1002
1001	GO TO ( 1005, 1006, 1007, 1008), MBLK
1005	WRITE (III, 3031) AHEAD,Y(1),(NR(J,1),J=NP,NQ)
	GO TO 1002
1006	WRITE (III, 3032) AHEAD,Y(1),(NR(J,1),J=NP,NQ)
	GO TO 1002
1007	WRITE (III, 3033 ) AHEAD,Y(1),(NR(J,1),J=NP,NQ)
	GO TO 1002
1008	WRITE (III, 3021) AHEAD,Y(1),(NR(J,1),J=NP,NQ)
1002	GO TO ( 2123, 1004, 1003 ), ISZ
1003	WRITE (III, 2125)
1004	WRITE (III, 2125 )
2123	CONTINUE
214	IF  (NX-NQ)  2281,  2281,  217
217	WRITE (III, 2225 )
	NBSP= NY + NY
	DO 220  M=1, NBSP
220	BACKSPACE IVXX
	NP=NP+NPDF
	NQ=NQ+NPDF
	GO TO 216
C     END OF ALL RESULTS
219	REWIND IVXX
	RETURN
	END
C     SUBROUTINE SINCOS
	SUBROUTINE SINCOS ( ARG,SINLZ,COSLZ )
	DIMENSION  TRGTBL (1001)
	COMMON  TRGTBL
5	IF  ( ARG )  6,  10,  10
6	ARG=ARG+1.0
	GO TO 5
10	NARG1=(ARG*1000.0+1.5)
11	IF  ( NARG1-1001 )  13,  13,  12
12	NARG1=NARG1-1000
	GO TO 11
13	NARG2=NARG1+250
	IF  ( NARG2-1001 )  20,  20,  16
16	NARG2=NARG2-1000
20	SINLZ=-TRGTBL(NARG2)
	COSLZ=TRGTBL(NARG1)
	RETURN
	END
C     SUBROUTINE  JZTRST
	FUNCTION  JZRTST(K)
	IF  ( K )  1,  2,  2
1	JZRTST=-1
	RETURN
2	JZRTST=1
	RETURN
	END
C     SUBROUTINE ROTATE
	SUBROUTINE  ROTATE (A,B)
	Z=A
	A=B
	B=Z
	RETURN
	END
CCHKUP
C     SUBROUTINE TO TEST AND CHECK THE INPUT DATA IN RIP.  DEALS WITH
C          THE LIMIT DATA.  THE ROUTINE WILL CHANGE THESE VALUES WHERE
C          IT WOULD HARM THE PROCEDURE IT USES TO RUN  THE FOURIER.
	SUBROUTINE CHEKUP(XMIN,XMAX,NORIEN,N,DX)
1	DIFFX=XMAX-XMIN
	IF(DIFFX) 3, 20,  5
3	XMIN=XMAX
	XMAX=XMIN-DIFFX
	GO TO 1
5	IF(DIFFX-1.) 30, 10, 10
10	XMAX=.5
	XMIN=-.5
	GO TO 60
20	NORIEN=N
	DX=.001
	GO TO 60
30	IF(XMAX-1.)  60,  40,  40
40	XMAX=0.
	XMIN=0.-DIFFX
60	RETURN
	END
CTRIG
	SUBROUTINE  TRIG(COSA,SINA,NU)
1170	IF(NU)1173,1201,1171
1171	NU=NU-12
	GO TO 1170
1173	NU=NU+12
	IF(NU)1173,1201,1175
1175	IF(NU-6)1176,1204,1177
1176	IF(NU-3)1209,1206,1212
1177	IF(NU-9)1219,1214,1216
1201	COSA=1.0
1202	SINA=0.0
	GO TO 1218
1204	COSA=-1.0
	GO TO 1202
1206	SINA=1.0
1207	COSA=0.0
	GO TO 1218
1209	COSA=0.5
1210	SINA=0.866025
	GO TO 1218
1212	COSA=-0.5
	GO TO 1210
1214	SINA=-1.0
	GO TO 1207
1216	COSA=0.5
1217	SINA=-0.866025
1218	RETURN
1219	COSA=-0.5
	GO TO 1217
	END
C     SUBROUTINE ALTER
C     TO PRODUCE THE ELECTRON DENSITY IN ABSOLUTE SCALE, 2/V SHOULD
C                BE PUNCHED AS EXT(3) ON CONTROL CARD NO.2.
	SUBROUTINE ALTER(J,K,L,FOBS,FCAL,AA,AC,BB,BC,ID,RHO,SINT,
	1        NXT,EXT,RA,RB  )
	DIMENSION  EXT(4)
	AA=AA*EXT(3)
	AC=AC*EXT(3)
	BB=BB*EXT(3)
	BC=BC*EXT(3)
	RETURN
	END
	SUBROUTINE REJECT(JJ,KK,LL,FOBS,FCAL,AA,AC,BB,BC,ID,RHO,
	1             SINT,NXT,EXT,NSKIP )
	DIMENSION EXT(4)
	NSKIP=0
	IF(ID)1,2,1
1	IF    (FOBS-FCAL)2,2,3
3	NSKIP = 1
2	RETURN
	END
