	PROGRAM SCFS

C	THIS PROGRAM READS THE CRYSTAL MODEL FILE
C	USING THE GX SUBROUTINE LIBRARY
C	MODEL FILE INPUT/OUTPUT ROUTINES ARE USED
C	IT THEN WRITES THE OUTPUT IN A STANDARD
C	CRYSTALLOGRAPHIC FILE STRUCTURE-SCFS
	
	CHARACTER COMPID(72),TAG1,TAG2
	CHARACTER*8 LABEL(200),FTYPE(13),tag
        character*4 cid
        character*72 line
	INTEGER CN(200),CONTNT(13),I1(3),I2(3),I3(3)
	REAL W(3)
	DATA PI/3.141593/
	COMMON/MODELC/COMPID,LABEL,FTYPE
	COMMON/MODEL/NATOM,NR,NT,NTYPE,NFTYPE(200),P(3,200),
     1	CN,SOF(200),UIJ(6,200),EP(3,200),ESOF(200),EUIJ(6,200),
     2  WAVEL,CELL(6),ECELL(6),R(24,3,4),T(3,4),ICENT,
     3  SFAC(14,13),CONTNT,SCALE(4),ETA,NQ,EXTNCT
	CALL MDLIN(1)
C	
C	END OF READING THE CRYSTAL MODEL FILE
C       Are we reading or writing the SCFS file?
 900    write (*,*) 
     U  'Do you want to read (R) or write (W) the SCFS file? (W)'
        read (5,'(A8)') tag
        if (tag.eq.'R'.or.tag.eq.'r') then
 901    read (7,'(A72)',end=902) line
        read (line,'(1x,a4)') cid
        if (cid.eq.'ATCO') then
         NATOM=NATOM+1                                                  0113.000
         read (line,910) LABEL(NATOM),(P(i,NATOM),i=1,3),UIJ(1,NATOM),
     U   SOF(NATOM),oxid,tag
 910     format (9x,a8,6f8.5,5x,a4)
         DO 34 J=1,NTYPE                                        
         IF (TAG.EQ.FTYPE(J)) GO TO 35                                  0147.000
 34      CONTINUE                                                       0148.000
         CALL LOOKUP(10,TAG)                                            0149.000
         J=NTYPE                                                        0150.000
 35      NFTYPE(NATOM)=J                                                0151.000
         DO 19 I=2,6                                                    0165.000
 19      UIJ(I,NATOM)=0.                                                0166.000
        else if (cid.eq.'ATCE') then
          read (line,910) tag
           if (tag.eq.LABEL(NATOM)) then
           read (line,910) tag,(EP(i,NATOM),i=1,3),EUIJ(1,NATOM),
     U     ESOF(NATOM)
           endif
        else if (cid.eq.'UIJ') then
          read (line,910) tag
           if (tag.eq.LABEL(NATOM)) then
           read (line,910) tag,(UIJ(i,NATOM),i=1,6)
           endif
        else if (cid.eq.'UIJE') then
          read (line,910) tag
           if (tag.eq.LABEL(NATOM)) then
           read (line,910) tag,(EUIJ(i,NATOM),i=1,6)
           endif
        endif
        go to 901
 902    call mdlout(3)
        stop
        else 
C	NOW SET UP FILE STRUCTURE
C
	WRITE(7,506) COMPID
 506    FORMAT ('TITLE'/'*',72A1)
	WRITE(7,501)
 501    FORMAT ('CELL DIMENSION','   A','         B','         C',
     1	'     ALPHA','      BETA','     GAMMA')
	CELL(4)=ACOS(CELL(4))*180/PI
	CELL(5)=ACOS(CELL(5))*180/PI
	CELL(6)=ACOS(CELL(6))*180/PI
	WRITE(7,40) (CELL(I),I=1,6)
	WRITE(7,50) (ECELL(I),I=1,6)
   40	FORMAT(1X,'CELL',4X,6F10.4)
   50   FORMAT(1X,'ERRS',4X,6F10.4)	
	WRITE(7,'(''*EOS'')')

	WRITE(7,*)
	WRITE(7,502)
 502    FORMAT('SG NAME')
	IF (ICENT.EQ.0) THEN
		TAG1='C'
	ELSE
		TAG1='N'
	ENDIF
	IF (NT.EQ.1) THEN
		TAG2='P'
	ELSEIF (NT.EQ.3) THEN
		TAG2='R'
	ELSEIF (NT.EQ.4) THEN
		TAG2='F'
	ELSEIF ((NT.EQ.2).AND.(T(1,2).EQ.0.5).AND.(T(2,2).EQ.0.5).AND.
     1  (T(3,2).EQ.0.5)) THEN
		TAG2='I'
	ELSEIF (NT.EQ.2.AND.T(1,2).EQ.0) THEN
		TAG2='A'
	ELSEIF (NT.EQ.2.AND.T(2,2).EQ.0) THEN
		TAG2='B'
	ELSEIF (NT.EQ.2.AND.T(3,2).EQ.0) THEN
		TAG2='C'
	ENDIF
	WRITE(7,70) TAG1,TAG2
   70	FORMAT(1X,'LATT',4X,2A1)
	WRITE(7,'(''*EOS'')')

	WRITE(7,*)
  	WRITE(7,500)
 500    FORMAT ('HKL','          H','    K','    L','     F(OBS)',
     1	'     SIGMA(F(OBS))')
    1 	READ(2,END=2)IW1,IW2,FSQ,SIGFSQ
	I=MOD(IW1,16777216)
	IH=(I/65536)-128
	I=MOD(I,65536)
	IK=(I/256)-128
	I=MOD(I,256)
	IL=I-128
	FOBS=SQRT(FSQ)
	SIGMAFOBS=SIGFSQ/(2*FOBS)    
	WRITE(7,60)IH,IK,IL,FOBS,SIGMAFOBS
   60   FORMAT(1X,'FOBS',4X,3I5,1X,2F10.3)
	N=N+1
	GO TO 1
    2	WRITE(*,*)'NUMBER OF REFLECTIONS INPUT =',N
	WRITE(7,'(''*EOS'')')
	
	WRITE(7,*)
	WRITE(7,503)
 503    FORMAT ('SYMMETRY')
	DO 4 I=1,NR 
        DO 5 J=1,3
       	I1(J)=R(I,J,1)
	I2(J)=R(I,J,2)	
	I3(J)=R(I,J,3)
	W(J)=R(I,J,4)
    5   CONTINUE
	WRITE(7,80)(I1(J),I2(J),I3(J),W(J),J=1,3)
   80   FORMAT(1X,'SYOP',4X,3I2,F10.7,4X,3I2,F10.7,
     2	4X,3I2,F10.7)	
    4   CONTINUE
	WRITE(7,'(''*EOS'')')

	WRITE(7,*)
	WRITE(7,504)
 504    FORMAT ('ATOMS')
	DO 3 I=1,NATOM
        IF (UIJ(2,I).EQ.0.0) THEN
         IDT=1
          ELSE
         IDT=2
        ENDIF
	WRITE (7,10) FTYPE(NFTYPE(I)),LABEL(I),(P(J,I),J=1,3),
     1  UIJ(1,I),SOF(I),FTYPE(NFTYPE(I)),IDT
	WRITE (7,20) FTYPE(NFTYPE(I)),LABEL(I),(EP(J,I),J=1,3),
     1  EUIJ(1,I),ESOF(I)
	WRITE (7,30) FTYPE(NFTYPE(I)),LABEL(I),(UIJ(J,I),J=1,6)
   10   FORMAT(1X,'ATCO',4X,A2,A6,5F8.5,13X,A2,2X,I1)
   20	FORMAT(1X,'ATCE',4X,A2,A6,5F8.5)
   30	FORMAT(1X,'UIJ',5X,A2,A6,6F8.5)
    3   CONTINUE
        WRITE (7,'(''*EOS'')')
        WRITE (7,507)
 507    FORMAT ('FORM FACTOR')
        DO 6 I=1,NTYPE
        WRITE (7,508) FTYPE(I),(SFAC(J,I),J=1,6)
 508    FORMAT (' EXP1',4X,A2,4X,6F10.6)
   6    WRITE (7,509) FTYPE(I),(SFAC(J,I),J=7,11)
 509    FORMAT (' EXP2',4X,A2,4X,5F10.6)
	WRITE(7,'(''*EOS''/''END'')')
        endif
	END
