C=======================================================
C
        PROGRAM REV
C
C       PROGRAMMER: Rongsheng Zhou
C                   ALFRED UNIVERSITY, FEB-1987
C       Modified continuously by R. L. Snyder
C
C       AN INTEGRATED FILE FORMAT CONVERSION ROUTINE
C       MAINLY FOR X-RAY DIFFRACTION ANALYSIS PROGRAMS
C
C=======================================================
 
        INCLUDE 'FILECONV.CBS'
 	
	REAL ST, SP, STP,M,SEC
	INTEGER u,X,nofiles,w
        PARAMETER LINE= 22
        PARAMETER IRAW1=  1, IRAW2= 19
        PARAMETER IDIF1= 21, IDIF2= 32
        PARAMETER IPLT1= 41, IPLT2= 43
        PARAMETER ILIS1= 46, ILIS2= 47
        PARAMETER IDAT1= 51, IDAT2= 52
        CHARACTER TEXT*80, DEFFIL*32, FILNUM(NTYP)*4,EXT*3
        DIMENSION IL(NTYP), IC(NTYP),RYOBS(20,20000),scale(20)
	DIMENSION TOTNPTS(20)
C
C
        IERR = 0                        !ERROR FLAG OFF
C
C
C   	THIS PORTION OF THE PROGRAM ALLOWS INPUT OF THE NUMBER OF DATAFILES
C
	TYPE 1
1       FORMAT($,' ENTER THE NUMBER OF DATA FILES YOU WISH TO MERGE:')
	READ*,NOFILES
C
C
C  GET THE INPUT FILENAME...
C
       TYPE 2
2      FORMAT(' THE FILES MUST BE PUT IN ORDER FROM HIGHEST 
     & ANGLE TO LOWEST')
       
       DO 1001 X=1,NOFILES
1004   TYPE 1111,NOFILES+1-X
1111   FORMAT('$ Enter  input filename of ',I1,' file: ')
        READ(5,2001,ERR=501,END=501)IQ, FILINP
2001    FORMAT(Q,A<IQ>)
        IF( FILINP.EQ.' ' ) GOTO 445

        

C
C  READ FROM THE INPUT FILE AND STORE IN THE COMMON BLOCKS...
C  THIS STORES EACH FILE IN A SEPERATE ARRAY CALLED RYOBS
C
C
        CALL RRW5000
        DO K=1,NPTS
        YOBS(K)=YOBS(K)/BANG(10)
        ENDDO
        IF(ERR.EQ.666) GO TO 1004
        IF(X.EQ.1) SP=BANG(2)
        IF(X.EQ.NOFILES) ST=BANG(1)
        TYPE*,' NPTS=',NPTS,'  COUNT TIME=',BANG(10)
	DO 1002 U=1,NPTS
        if (x.eq. 1) then
       
           bang(10)=20.
C           IF(YOBS(U)/BANG(10).LE.1) YOBS(U)=1.0*BANG(10)
	   RYOBS(X,U)=(YOBS(U)/bang(10))/(1-(yobs(u)/bang(10))*1.5e-6)

C           RYOBS(X,U)=ALOG(YOBS(U)/BANG(10))
C         TYPE 3,U,YOBS(U)/BANG(10), RYOBS(X,U)
3        FORMAT(I4,5X,F,F)
        else
           bang(10)=1.
            ryobs(x,u)=yobs(u)
        endif
	   TOTNPTS(X)=NPTS
1002	CONTINUE
1001   CONTINUE
C
C
C
C
C  THIS PROTION CALCULATES THE SCALE FACTORS FOR THE VARIOUS RANGES
C
C
445	DO 2000 X=1,NOFILES
    	   IF (X .EQ. 1) THEN
	      DO 2003 U=1,TOTNPTS(X)
    		RYOBS(X,U)=RYOBS(X,U)
2003          CONTINUE
    	   ELSE
    	      if (ryobs(x,totnpts(x)).eq. 0) then
    		goto 2000
    	      endif
    	      SCALE(X)=RYOBS(X-1,1)/RYOBS(X,TOTNPTS(X))
    	      print*,x
    	      print*,scale(x),ryobs(x-1,x),ryobs(x,totnpts(x))
C		read*,wow
    	      DO 2005 U=1,TOTNPTS(X)
		RYOBS(X,U)=RYOBS(X,U)*SCALE(X)
2005	      CONTINUE
    	   ENDIF
2000	CONTINUE
C
C
C
C
C  THIS PORTION TAKES THE DATA SETS AND COMBINES THEM INTO ONE SMOOTH DATA SET
C
C
	W=1
	DO 3001 X=NOFILES,1,-1
	   DO 3002 U=1,TOTNPTS(X)-1
		YOBS(W)=RYOBS(X,U)
C          TYPE*,W,'  YOBS=',YOBS(W)
		W=W+1
3002	   CONTINUE
3001	CONTINUE
C
C
C

        CLOSE( UNIT=IINP )
 

	BANG(1)=ST
	BANG(2)=SP
        BANG(10)=1
C        TYPE*,' START=',BANG(1),' STOP=',BANG(2),' STEP=',BANG(3)
        npts = ((bang(2) - bang(1)) / bang(3)+0.5) + 1
C        TYPE*,' 1 NPTS=',NPTS



        TYPE 100
100     FORMAT( ' Select output file format:'/
     &          ' 1. ASCII RIETVELD/SHADOW format.',/
     &          ' 2. ASCII ORIGIN format.',/
     &          ' 3. ASCII MDI format.',/,I2)
        ACCEPT 101, IFORM
101     FORMAT(I2)

        IF(IFORM.EQ.1) EXT='XDA'
        IF(IFORM.EQ.2) EXT='DAT'
        IF(IFORM.EQ.3) EXT='MDI'

        DO I=1,30
        IF(FILINP(I:I).EQ.'.') THEN
        ENCODE(I+3,550,FILOUT) FILINP(1:I),EXT
550     FORMAT(A<I>, A3)
        ENDIF
        ENDDO
      
        IF(IFORM.EQ.1) CALL WRWXRR
        IF(IFORM.EQ.2) CALL WRWORG
        IF(IFORM.EQ.3) CALL  WRWMDI
501	END
c
c
c
c
c
     	FUNCTION DATCOD( DAY )
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY,  FEB-1987
C
C	THIS ROUTINE ENCODES D-500 SYSTEM DATE
C
     	CHARACTER DAY*9, DAT*6
     	CHARACTER*36 MONTHS
     	DATA MONTHS/'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'/

     	DATCOD = 0.0
     	IVAL = INDEX( MONTHS, DAY(4:6) )
     	IF( IVAL.GT.0 ) THEN
     	    DAT(1:2) = DAY(1:2)
     	    ENCODE( 2, 1, DAT(3:4) ) IVAL
     	    DAT(5:6) = DAY(8:9)
     	    DECODE( 6, 2, DAT, ERR=9 ) VAL
     	    DATCOD = VAL
     	ENDIF
1	FORMAT(I2)
2	FORMAT(F7.0)
9	RETURN
     	END
C
C
C
C
C
C
C
     	FUNCTION TIMCOD( TIM )
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY,  FEB-1987
C
C	THIS ROUTINE ENCODES D-500 SYSTEM TIME
C
     	CHARACTER TIM*8, ATIM*6

     	TIMCOD = 0.0
     	ATIM(1:2) = TIM(1:2)
     	ATIM(3:4) = TIM(4:5)
     	ATIM(5:6) = TIM(7:8)
     	DECODE( 6, 1, ATIM, ERR=9 ) VAL
     	TIMCOD = VAL
1	FORMAT(F7.0)
9	RETURN
     	END
C
C
C
C
C
C
C
C

     	SUBROUTINE RRW5000
C
     	INCLUDE 'FILECONV.CBS'

        INTEGER*2 DUMY,MESFLG,IOVER,MTHC
	REAL*4 SPCAN(4)
        CHARACTER DACOUT*1
        LOGICAL*1 LSTPNT
     
        LSTPNT=.FALSE.
       
     	CLOSE( UNIT=IINP )

     	OPEN( UNIT=IINP, FILE=FILINP, STATUS='OLD',
     1   ACCESS='DIRECT', RECL=12,  READONLY,err=666 )

C
C  READ THE FILE HEADER BLOCK...
C
     	READ(IINP,REC= 1,ERR=777) DUMY,ITYP,NHDB,ISBF,LENG,MESFLG,IOVER

     	IF( ITYP.NE.1 ) GOTO 777     
     	IF( LENG.LT.3 ) GOTO 777
C
C  READ THE SPECIFICATION BLOCK REFERENCES...
C
     	IREC = ISBF                        !200
     
      READ(IINP,REC=IREC,ERR=777)(IRPR(I,1),IRPR(I,2),IRLR(I),I=1,4)
      READ(IINP,REC=IREC+1,ERR=777)(IRPR(I,1),IRPR(I,2),IRLR(I),I=5,8)
      READ(IINP,REC=IREC+2,ERR=777)(IRPR(I,1),IRPR(I,2),IRLR(I),I=9,12)

C
C  READ THE INSTRUMENTATION BLOCK...
C
     	IREC = IRPR(1,1)+4 

C  READ THE WAVE SOURCES

      READ(IINP,REC=IREC,ERR=777)DIFNUM,DIFVER,GONINT,ANODE(6),CHRLIN
     &                                 ,(WAVE(I,6),I=1,5)
     	IF( WAVE(1,6).LE.0.0 ) GOTO 777
     	DO I=1, 5
C
     	   IF( ABS(WAVE(1,6)-WAVE(1,I)).LT.0.05 ) IELE = I
      
     	ENDDO

	IF(IELE.LE.0 .OR. IELE.GT.6 )IELE = 4   !S.Z.

C
C  READ THE FILE DESCRIPTION BLOCK...
C
     	IREC = IRPR(3,1)
     	READ(IINP,REC= IREC,ERR=777 ) (NAME(I),I=1,3),DATM,TIMM
     &  ,FTYP,MTYP,INTMAX,RES,NREP,MPRO,NRNG,SCAN
     	IF( NREP.LT.1 ) GOTO 777
C      	IF( NRNG.LT.1 .OR. SCAN.NE.'S' ) GOTO 777 ! removed for contignous 
C                                                 ! runs (S.Z.)
     	IF( NRNG.LT.1 ) GOTO 777	!JDW
      READ(IINP,REC=IREC+1,ERR=777)(SPCAN(I),I=3,4),STYP,MTHC
     &           ,DACOUT,(SLID(I),I=1,9)
     	READ(IINP,REC= IREC+2,ERR=777) (SLID(I),I=10,15)
C
C  READ THE LINE MEASUREMENT BLOCK...
C
     	IREC = IRPR(4,1)
C
C  SHOW ALL THE RANGES...
C
              READ(IINP,REC= IREC,ERR=777) (BANG(I),I=1,12)
     	      READ(IINP,REC= IREC+1,ERR=777) (BANG(I),I=13,14)
       
        IREC=IREC+2 
C
C  CALCULATE RECORD LENGHT FOR EACH RANGE   S.Z.
C
     	NPTS = INT( (BANG(2)-BANG(1))/BANG(3)+0.5 ) + 1
C
C  READ THE INTENSITY DATA BLOCK...
C

        IREC=IRPR(6,1)        
        K=1
        FIRST=1
        LAST=12

10      CONTINUE
        READ(IINP,REC=IREC,ERR=777)(YOBS(K),K=FIRST,LAST)

C        TYPE*,(K,YOBS(K),K=FIRST,LAST)
        IF(LSTPNT) GO TO 500
        FIRST=FIRST+12
        LAST=LAST+12
        IREC=IREC+1
        IF(NPTS-LAST.LT.0) THEN
        LAST=NPTS
        LSTPNT=.TRUE.
        ENDIF
        GO TO 10
500     type*,'FILE ', FILINP,' READ O.K.' 
    	GOTO 999
666     type*,' CAN NOT FIND/OPEN FILE: ',FILINP
        GO TO 999


777	TYPE*,' ERROR DURING READING FILE:',FILINP
        
     	GOTO 999
888	IERR = 2
999	RETURN    
    	END
C
C
C
     	SUBROUTINE CODDAT( DAY, CDAY )
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY,  FEB-1987
C
C	THIS ROUTINE DECODES D-500 SYSTEM DATE
C
     	CHARACTER DAY*9,DAT*6
     	CHARACTER*36 MONTHS
     	DATA MONTHS/'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'/

     	DAY = '00-000-00'
     	IF( CDAY.GT.0.0 ) THEN
     	    IDAY = CDAY
     	    ENCODE( 6, 1, DAT ) IDAY
     	    DAY(1:2) = DAT(1:2)
     	    DECODE( 2, 1, DAT(3:4) ) IVAL
C S.Z.           ival = ival*3 - 2                  
     	    DAY(4:6) = MONTHS( IVAL : IVAL+2 )
     	    DAY(8:9) = DAT(5:6)
     	ENDIF
1	FORMAT(I6)
     	RETURN
     	END
c
c
c
c
c
     	SUBROUTINE CODTIM( TIM, RTIM )
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY,  FEB-1987
C
C	THIS ROUTINE DECODES D-500 SYSTEM TIME
C
     	CHARACTER TIM*8, ATIM*6

     	TIM = '00:00:00'
     	ITIM = RTIM
     	ENCODE( 6, 1, ATIM ) ITIM
     	TIM(1:2) = ATIM(1:2)
     	TIM(4:5) = ATIM(3:4)
     	TIM(7:8) = ATIM(5:6)
1	FORMAT(I6)

     	RETURN
     	END

     	SUBROUTINE WRWXRR
C
C  PROGRAMMER:  R.S. ZHOU
C		ALFRED UNIVERSITY   FEB-1987
C
C	THIS ROUTINE WRITES OUT AN X-RAY RIETVELD RAW DATA FILE
C	FROM THE COMMON BLOCKS
C
     	INCLUDE 'FILECONV.CBS'
     	CHARACTER IQS*1, DAY*9, TIM*8
C
C  WRITE OUT AN ASCII FILE...
C
     	CLOSE( UNIT=IOUT )
     	OPEN( UNIT=IOUT, FILE=FILOUT, STATUS='NEW', ERR=888,
     	1 FORM='FORMATTED', CARRIAGECONTROL='LIST' )

     	WRITE(IOUT,1000,ERR=888) SLID
1000	FORMAT(20A4)
     	CALL CODDAT( DAY, DATM )
     	CALL CODTIM( TIM, TIMM )
     	WRITE(IOUT,1001,ERR=888) DAY, TIM
1001	FORMAT(A9,A8)
     	WRITE(IOUT,1002,ERR=888) BANG(1),BANG(2),BANG(3),BANG(10)
1002	FORMAT(4F10.4)
C        TYPE*,' NPTS=',NPTS
     	WRITE(IOUT,1003,ERR=888) (YOBS(I), I=1, NPTS+1)
1003	FORMAT(10F7.0)
        CLOSE(UNIT=IOUT)        
     	GOTO 999

777	IERR = 3		!BAIL OUT
     	GOTO 999
888	IERR = 1
999	RETURN
     	END
        SUBROUTINE WRWORG(IQ)
        INCLUDE 'FILECONV.CBS'
        INTEGER NPTS*4
        ENCODE(IQ,2,FILOUT)(FILINP(I:I),I=1,IQ-3),'DAT'
2       FORMAT(<IQ-3>A,3A)
        OPEN(UNIT=IOUT,FILE=FILOUT,STATUS='NEW')
C        TYPE*,'NPTS=',NPTS,'  BANG(1)=',BANG(1)
        XOBS(1)=BANG(1)-BANG(3)
C        TYPE*,' NPTS=',NPTS
        DO I=2,NPTS+1
        XOBS(I)=XOBS(I-1)+BANG(3)
C        TYPE* ,I,'   X=', XOBS(I),'   Y=',YOBS(I-1)
        WRITE(IOUT,1) XOBS(I),YOBS(I-1)/BANG(10)
1       FORMAT(2F10.3)
        ENDDO
        RETURN
        END
