SUBROUTINE RPLSHA C C PROGRAMMER: R.S. ZHOU C ALFRED UNIVERSITY FEB-1987 C C THIS ROUTINE READS FROM AN SHADOW OUTPUT PLOT C DATA FILE AND WRITES OUT A DATA FILE FOR GRAFIT. C C X-RAY RIETVELD PLOT IS NEW CIRCA-1990 VERSION BY C SCOTT HOWARD, CONVERSION MODIFICATION WRITTEN BY C DAVID MATHEIS,AND S.ZDZIESZYNSKI (TO WRITE FORMATED C OUTPUT FOR ERROR BARS DATA.) C INCLUDE 'FILECONV.CBS' CHARACTER qtext*78, FILPAR*32, title*80, qdgttl(20)*28 character qntitl*20 INTEGER NDPTS(20) DIMENSION kdgfrq(20), pdgofs(20), kdgpen(20), 1 kdgtyp(20), pdginc(20), kdgusd(20), pdglxy(20,3), 2 xdata(7500,20), ydata(7500,20), PDVVL2(999,20), KDVIV1(999,20), 3 PDVXVL(999,20),PDVYVL(999,20),PDVVL1(999,20) CALL COLORS(-1) CALL putext('Writing the output file... Please wait...',41,24,1) C============================================================== C TRY TO OPEN THE INPUT FILE AS AN UNFORMATTED FILE FIRST... C============================================================== CLOSE( UNIT=IINP ) OPEN(IINP, FILE=FILINP, STATUS='OLD', 1 FORM='UNFORMATTED', ERR=888 ) C C READ THE file header... C READ(IINP,err=1111,end=777) qtext READ(IINP,ERR=1111,END=777) title READ(IINP,ERR=1111,END=777) xscale, jaxbox, jaxdrw READ(IINP,ERR=1111,END=777) jxaxid, xaxor, xaxln, 1 xaxst, xaxen, xaxdv READ(IINP,ERR=1111,END=777) jyaxid, yaxor, yaxln, 1 yaxst, yaxen, yaxdv READ(IINP,ERR=1111,END=777) knum * C * GET THE GROUP PARAMETERS * DO I=1,KNUM READ(IInp) QNTITL,I1,X1,I2,I3,X2 QDGTTL(I) = QNTITL KDGFRQ(I) = I1 PDGOFS(I) = X1 KDGPEN(I) = I2 KDGTYP(I) = I3 PDGINC(I) = X2 KDGUSD(I) = 0 PDGLXY(I,1) = 0.0 PDGLXY(I,2) = 0.0 PDGLXY(I,3) = 0.0 enddo * ** READ THE DATA SETS * 100 READ(IInp,END=1) NSET,NDVPTS,PDVBEG WRITE(6,12) NSET,NDVPTS,PDVBEG 12 FORMAT(' Reading group ',I2,2X, &'Number of points = ',I5,2X,'Starting angle ='F9.4) ndpts(nset) = ndvpts C * C ** READ TYPE 0 DATA, PLOTTING DATA SET C * IF(KDGTYP(NSET).NE.0) GO TO 200 NREC = ndvpts / 10 NREM = NDVPTS - NREC * 10 NTRK = 0 DO I=1,NREC READ(iinp,END=1) ( ydata(J,nset), J=(NTRK+1),(NTRK+10) ) NTRK = NTRK + 10 enddo IF(NREM.GT.0) THEN READ(iinp,END=1) ( ydata(J,nset), J=(NTRK+1),(NTRK+NREM) ) ENDIF do i=1,ndvpts xdata(i,nset) = pdvbeg + (i-1) * pdginc(nset) enddo GO TO 100 C * C ** READ TYPE 1 = X-Y DATA C * 200 IF(KDGTYP(NSET).NE.1) GO TO 300 DO I=1,NDVPTS READ(iinp,END=1) xdata(I,nset),ydata(I,nset) enddo GO TO 100 C * C ** READ TYPE 2 DATA = MARKER INFORMATION C * 300 IF(KDGTYP(NSET).NE.2) GO TO 400 DO I=1,NDVPTS READ(iinp,END=1) PDVXVL(i,nset),PDVYVL(i,nset), 1 PDVVL1(i,nset),PDVVL2(i,nset),KDVIV1(i,nset) enddo GO TO 100 C * C ** READ TYPE 3 DATA = VERTICAL ERROR BARS C * 400 IF(KDGTYP(NSET).NE.3) GO TO 500 PRINT *, 'Y ERROR BARS' DO I=1,NDVPTS READ(iinp,END=1)PDVXVL(i,nset),PDVYVL(i,nset),PDVVL1(i,nset) enddo GO TO 100 C * C ** READ TYPE 4 DATA = HORIZONTAL ERROR BARS C * 500 IF(KDGTYP(NSET).NE.4) GO TO 777 PRINT *, 'X ERROR BARS' DO I=1,NDVPTS READ(iinp,END=1) PDVXVL(i,nset),PDVYVL(i,nset),PDVVL1(i,nset) enddo GO TO 100 C================================================================ C OPEN THE PARAMETER FILE... C================================================================ 1 CALL NAMEXT( FILOUT, FILPAR, 'PAR' ) CLOSE( UNIT=13 ) OPEN( UNIT=13, FILE=FILPAR, STATUS='UNKNOWN', 1 CARRIAGECONTROL='LIST', FORM='FORMATTED') XAXDV = (XAXEN - XAXST)/5.0 WRITE(13,1000) title, xaxst, xaxen, xaxdv,FILOUT 1000 FORMAT('%This is a GRAFIT parameter/setup file: '/ 1 'TITL= ',a/ 2 'XLB1=TWO-THETA (DEGREES)'/ 3 'YLB1=INTENSITY (CPS)'/ A 'XLB2='/ B 'YLB2='/ 4 'OVER= 2 1 0 1 1 1 4.000 4.500 1.250 5 1.200 0.000 0.000 1.000 1.000'/ C 'XAX1= 1 5 1 0 11 8.000 0.000 0.000 0.000' C ,f8.5,3x,f10.5,3x,f6.3/ D 'YAX1= 1 4 1 0 11 6.000',/ 6 'PAR1= 1.00 1.00 1.00 1.00 0.00 0.00 1.00 7 1.00 1.00 0.00'/ 8 'PAR2= 5.00 1.00 1.00 0.00 0.00 0.00 0.00 9 0.00 0.00 0.00'/ E 'IDEN=',A32) * * WRITE LABELS TO PARAMETER FILE * do i=1,knum YOFF = 0.0 IPN = i + 1 WRITE(13,1101)IPN,YOFF,qdgttl(i) 1101 FORMAT('SETS=',I4,' 0 1 3 1 1 0 0.100 0.000', 1 F8.3,' 1.0000 1.0000 0.00000E+00'/ 2 'LABL=',A28) enddo * C==================================================================== C OPEN THE OUTPUT FILE... C==================================================================== 900 CLOSE( UNIT=IOUT ) OPEN( UNIT=IOUT, FILE=FILOUT, STATUS='NEW', 1 FORM='FORMATTED') * do i=1,knum if(ndpts(i).eq.0)goto 910 IF(KDGTYP(I).EQ.0)THEN WRITE(IOUT,21) Ndpts(i) 21 FORMAT(I5) DO J=1,NDPTS(I) WRITE(IOUT,22) Xdata(j,I),Ydata(j,I) 22 FORMAT(2F10.4) ENDDO ENDIF IF(KDGTYP(I).EQ.1)THEN WRITE(IOUT,23) NDPTS(I) 23 FORMAT(I5) DO J=1,NDPTS(I) WRITE(IOUT,24) XDATA(J,I),YDATA(J,I) 24 FORMAT(2F10.4) ENDDO ENDIF IF(KDGTYP(I).EQ.2) THEN C WRITE(IOUT,21) NDPTS(I) C DO J=1,NDPTS(I) C WRITE(IOUT)(PDVXVL(J,I),J=1,NDPTS(I)) C WRITE(IOUT)(PDVYVL(J,I),J=1,NDPTS(I)) C WRITE(IOUT)(PDVVL1(J,I),J=1,NDPTS(I)) C WRITE(IOUT)(PDVVL2(J,I),J=1,NDPTS(I)) C WRITE(IOUT)(KDVIV1(J,I),J=1,NDPTS(I)) ENDIF IF(KDGTYP(I).EQ.3) THEN PRINT *, ' WRITE Y ERROR BARS' WRITE(IOUT,25) NDPTS(I) 25 FORMAT(I5) DO J=1,NDPTS(I) WRITE(IOUT,26)PDVXVL(J,I),PDVYVL(J,I),PDVVL1(J,I) 26 FORMAT(3F10.4) ENDDO ENDIF 910 enddo go to 999 1111 IERR = -2 GO TO 999 777 IERR = 1 GOTO 999 666 IERR = -1 GOTO 999 888 IERR = 2 999 CLOSE( UNIT=13 ) CLOSE(UNIT=Iinp) CLOSE(UNIT=IOUT) RETURN END