424 lines
15 KiB
Fortran
424 lines
15 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C Routine to print intensity data from the IDATA file
|
|
C
|
|
C The data is listed on the terminal if KI = '2', or
|
|
C LPT if KI = '3'.
|
|
C
|
|
C For the BI command, the 25 reflections which are in the 2theta
|
|
C range and have the highest Inet/Sigma(Inet) are saved, sorted and
|
|
C printed.
|
|
C
|
|
C 2theta values are calculated from the R matrix in COMMON.
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE PRNINT
|
|
INCLUDE 'COMDIF'
|
|
PARAMETER (NSIG = 50)
|
|
DIMENSION VEC(3),ENREFB(10),
|
|
$ IHSIG(NSIG),IKSIG(NSIG),ILSIG(NSIG),
|
|
$ INSIG(NSIG),RDSIG(NSIG),THSIG(NSIG)
|
|
C EQUIVALENCE (ACOUNT( 1),IHSIG(1)),(ACOUNT( 51),IKSIG(1)),
|
|
C $ (ACOUNT(101),ILSIG(1)),(ACOUNT(151),INSIG(1)),
|
|
C $ (ACOUNT(201),RDSIG(1)),(ACOUNT(251),THSIG(1)),
|
|
C $ (NREFB(1),ENREFB(1))
|
|
DATA MOST/25/
|
|
IF (KI .EQ. 'BI') THEN
|
|
WRITE (COUT,10000) MOST
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
ENDIF
|
|
IP = 0
|
|
IF (KI .EQ. '2') IOUT = ITP
|
|
IF (KI .EQ. '3') IOUT = LPT
|
|
NSAVE = NBLOCK
|
|
IF (NATTEN .GT. 0 .AND. KI .NE. 'BI') THEN
|
|
DO 100 I = 1,NATTEN+1
|
|
J = I - 1
|
|
WRITE (COUT,12000) J,ATTEN(I)
|
|
CALL GWRITE (IOUT,' ')
|
|
100 CONTINUE
|
|
ENDIF
|
|
IF (KI .EQ.'BI') THEN
|
|
WRITE (COUT,13000)
|
|
SIGMIN = 100000.0
|
|
ELSE
|
|
WRITE (COUT,14000)
|
|
ENDIF
|
|
CALL FREEFM (ITR)
|
|
TPMIN = RFREE(1)
|
|
TPMAX = RFREE(2)
|
|
SIGRAT = RFREE(3)
|
|
IRRFLG = 0
|
|
IF (TPMIN .EQ. 0 .AND. TPMAX .EQ. 0) THEN
|
|
TPMIN = THEMIN
|
|
TPMAX = THEMAX
|
|
SIGRAT = -100000.0
|
|
IRRFLG = 1
|
|
ENDIF
|
|
CALL LENFIL (IID,LASTBL)
|
|
110 WRITE (COUT,15000) LASTBL
|
|
CALL FREEFM (ITR)
|
|
NBEGIN = IFREE(1)
|
|
IF (NBEGIN .LT. 20) NBEGIN = 20
|
|
NEND = IFREE(2)
|
|
IF (NEND .EQ. 0) NEND = NBEGIN
|
|
IF (NEND .GT. LASTBL) NEND = LASTBL
|
|
IALL = 0
|
|
IF (NEND .EQ. LASTBL) IALL = 1
|
|
IF (KI .EQ. 'BI') WRITE (LPT,17000)
|
|
NBLOCK = NBEGIN
|
|
ISAVE = 0
|
|
C-----------------------------------------------------------------------
|
|
C Read the specified blocks of intensity data
|
|
C-----------------------------------------------------------------------
|
|
DO 150 J = NBEGIN,NEND
|
|
READ (IID,REC=NBLOCK)
|
|
$ IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB,BPSI
|
|
NBLOCK = NBLOCK + 1
|
|
C-----------------------------------------------------------------------
|
|
C Unpack indices and NATT
|
|
C-----------------------------------------------------------------------
|
|
DO 140 NB = 1,10
|
|
ITEMP = IHK(NB)/1000
|
|
IH = ITEMP - 500
|
|
IK = IHK(NB) - 500 - 1000*ITEMP
|
|
ITEMP = ILA(NB)/1000
|
|
IL = ITEMP - 500
|
|
IA = ILA(NB) - 1000*ITEMP
|
|
IF (IH .EQ. 99) THEN
|
|
THET2 = 0.0
|
|
GO TO 140
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Calculate the 2theta value
|
|
C-----------------------------------------------------------------------
|
|
SUM = 0.0
|
|
DO 120 I = 1,3
|
|
VEC(I) = R(I,1)*IH + R(I,2)*IK + R(I,3)*IL
|
|
SUM = SUM + VEC(I)*VEC(I)
|
|
120 CONTINUE
|
|
SINSQ = 0.25*SUM
|
|
IF (SINSQ .GE. 1.0) THEN
|
|
NBLOCK = NBLOCK - 1
|
|
WRITE (COUT,17100) NBLOCK,IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 110
|
|
ENDIF
|
|
THET2 = 2.0*DEG*ATAN(SQRT(SINSQ/(1.0 - SINSQ)))
|
|
IF (KI .EQ. 'BI') THEN
|
|
IF (THET2 .LT. TPMIN) GO TO 140
|
|
ELSE
|
|
IF (BPSI(NB) .LT. 900.0 .OR.
|
|
$ (BPSI(NB) .GE. 900.0 .AND. IRRFLG .EQ. 0)) THEN
|
|
IF (THET2 .LT. TPMIN .OR. THET2 .GT. TPMAX) GO TO 140
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Correct for Precision mode (ITYPE = 3 or 4)
|
|
C Allow for Precision mode with Profile Analysis
|
|
C-----------------------------------------------------------------------
|
|
RATIO = FRAC
|
|
NTIMES = 1
|
|
IF (ITYPE .EQ. 3 .OR. ITYPE .EQ. 4) THEN
|
|
NTIMES = BTIME(NB)
|
|
RATIO = FRAC
|
|
IF (IPRFLG .EQ. 0) NTIMES = ENREFB(NB)
|
|
ENDIF
|
|
IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN
|
|
IRAT = BTIME(NB)
|
|
RATIO = 1000*(BTIME(NB) - IRAT)/IRAT
|
|
ENDIF
|
|
IF (IPRFLG .EQ. 0 .AND. BPSI(NB) .LT. 900) RATIO = BTIME(NB)
|
|
RATIO = 1.0/(RATIO + RATIO)
|
|
BAKGND = BBGR1(NB) + BBGR2(NB)
|
|
INET = BCOUNT(NB) - RATIO*BAKGND
|
|
RESD = INET/SQRT(BCOUNT(NB) + RATIO*RATIO*BAKGND)
|
|
AT = ATTEN(IA+1)
|
|
INET = AT*INET/NTIMES
|
|
IF (KI .EQ. 'BI') THEN
|
|
IF (BPSI(NB) .LT. 900.0) THEN
|
|
IF (ISAVE .LT. NSIG) THEN
|
|
ISAVE = ISAVE + 1
|
|
IHSIG(ISAVE) = IH
|
|
IKSIG(ISAVE) = IK
|
|
ILSIG(ISAVE) = IL
|
|
INSIG(ISAVE) = INET
|
|
RDSIG(ISAVE) = RESD
|
|
THSIG(ISAVE) = THET2
|
|
IF (RESD .LT. SIGMIN) THEN
|
|
SIGMIN = RESD
|
|
IMIN = ISAVE
|
|
ENDIF
|
|
ELSE
|
|
IF (RESD .GT. SIGMIN) THEN
|
|
IHSIG(IMIN) = IH
|
|
IKSIG(IMIN) = IK
|
|
ILSIG(IMIN) = IL
|
|
INSIG(IMIN) = INET
|
|
RDSIG(IMIN) = RESD
|
|
THSIG(IMIN) = THET2
|
|
SIGMIN = 100000.0
|
|
DO 130 I = 1,NSIG
|
|
IF (RDSIG(I) .LT. SIGMIN) THEN
|
|
SIGMIN = RDSIG(I)
|
|
IMIN = I
|
|
ENDIF
|
|
130 CONTINUE
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
GO TO 140
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Reflection data print for the PD command.
|
|
C Sort out the reference reflections from the rest
|
|
C-----------------------------------------------------------------------
|
|
IF (RESD .GE. SIGRAT) THEN
|
|
IF (BPSI(NB) .LT. 900.0) THEN
|
|
IF (IP .NE. 0) THEN
|
|
IF (KI .EQ. '3') THEN
|
|
WRITE (COUT,18000)
|
|
CALL GWRITE (IOUT,' ')
|
|
ENDIF
|
|
IP = 0
|
|
ENDIF
|
|
WRITE (COUT,19000) IH,IK,IL,THET2,BTIME(NB),IA,
|
|
$ BBGR1(NB),BCOUNT(NB),BBGR2(NB),
|
|
$ BPSI(NB),INET,RESD
|
|
CALL GWRITE (IOUT,' ')
|
|
ELSE
|
|
IP = 0
|
|
DO 135 I = 1,NSTAN
|
|
IF (IH .EQ. IHSTAN(I) .AND.
|
|
$ IK .EQ. IKSTAN(I) .AND.
|
|
$ IL .EQ. ILSTAN(I)) IP = I - 1
|
|
135 CONTINUE
|
|
IF (IP .EQ. 0) THEN
|
|
IF (KI .EQ. '3') THEN
|
|
WRITE (COUT,18000)
|
|
CALL GWRITE (IOUT,' ')
|
|
ENDIF
|
|
ENDIF
|
|
IP = IP + 1
|
|
WRITE (COUT,20000) IP,IH,IK,IL,THET2,BTIME(NB),IA,
|
|
$ BBGR1(NB),BCOUNT(NB),BBGR2(NB),
|
|
$ INET,RESD
|
|
CALL GWRITE (IOUT,' ')
|
|
ENDIF
|
|
ENDIF
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Sort and print for the BI command
|
|
C-----------------------------------------------------------------------
|
|
IF (KI .EQ. 'BI') THEN
|
|
CALL SORTIS (RDSIG(1),ISAVE,IHSIG(1),IKSIG(1),ILSIG(1),INSIG(1),
|
|
$ THSIG(1))
|
|
ISIG = MOST
|
|
IF (ISAVE .LT. MOST) ISIG = ISAVE
|
|
DO 160 I = 1,ISIG
|
|
WRITE (LPT,21000) IHSIG(I),IKSIG(I),ILSIG(I),
|
|
$ THSIG(I),INSIG(I),RDSIG(I)
|
|
160 CONTINUE
|
|
ENDIF
|
|
IF (IALL .EQ. 0) THEN
|
|
IF (KI .EQ. 'BI') THEN
|
|
WRITE (COUT,22000)
|
|
ELSE
|
|
WRITE (COUT,23000)
|
|
ENDIF
|
|
CALL YESNO ('N',ANS)
|
|
IF (ANS .EQ. 'Y') GO TO 110
|
|
ENDIF
|
|
NBLOCK = NSAVE
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (' Search for the',I3,' biggest Inet/Sigma(Inet) (Y) ? ',$)
|
|
12000 FORMAT (5X,' Attenuator(',I1,') ',F7.2)
|
|
13000 FORMAT (' Type 2thetamin ',$)
|
|
14000 FORMAT (/' Reflns can be selected on 2theta and Inet/Sig(Inet)'/
|
|
$ ' Type 2thetamin, 2thetamax and min(I/sigI)',
|
|
$ ' (All Reflns) '$)
|
|
15000 FORMAT (' Intensity data is in records 20 to',I5/
|
|
$ ' Type the range of records to be examined ',$)
|
|
16000 FORMAT (/' Records',I4,' to',I4,' will be used.')
|
|
17000 FORMAT (' h k l 2Theta Inet I/SigI')
|
|
17100 FORMAT (3I4,' in record',I5,' is incompatible with',
|
|
$ ' the current orientation matrix.'/
|
|
$ ' Please try again.')
|
|
18000 FORMAT ('%')
|
|
19000 FORMAT (3X, 3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,F8.3,I8,F8.2)
|
|
20000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,8X,I8,F8.2)
|
|
21000 FORMAT (3X,3(I3,1X),F7.2,I8,F8.2)
|
|
22000 FORMAT (' Do you want to search more records (N) ? ',$)
|
|
23000 FORMAT (' Do you want to print more records (N) ? ',$)
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Sort the largest Inet/Sigma(Inet) values
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE SORTIS (RIOS,MOST,LH,LK,LL,LI,RT)
|
|
DIMENSION RIOS(1), LH(1), LK(1), LL(1), LI(1), RT(1)
|
|
M = 2
|
|
100 INTVL = MOST/M
|
|
IF (INTVL .EQ. 0) INTVL = 1
|
|
IFIN = MOST - INTVL
|
|
110 MARK = 0
|
|
DO 120 I = 1,IFIN
|
|
J = I+INTVL
|
|
IF (RIOS(I) .LT. RIOS(J)) THEN
|
|
TEMP = RIOS(I)
|
|
RIOS(I) = RIOS(J)
|
|
RIOS(J) = TEMP
|
|
ITEM = LH(I)
|
|
LH(I) = LH(J)
|
|
LH(J) = ITEM
|
|
ITEM = LK(I)
|
|
LK(I) = LK(J)
|
|
LK(J) = ITEM
|
|
ITEM = LL(I)
|
|
LL(I) = LL(J)
|
|
LL(J) = ITEM
|
|
ITEM = LI(I)
|
|
LI(I) = LI(J)
|
|
LI(J) = ITEM
|
|
TEMP = RT(I)
|
|
RT(I) = RT(J)
|
|
RT(J) = TEMP
|
|
MARK = 1
|
|
ENDIF
|
|
120 CONTINUE
|
|
IF (MARK .EQ. 1) GO TO 110
|
|
IF (INTVL .NE. 1) THEN
|
|
M = 2*M
|
|
GO TO 100
|
|
ENDIF
|
|
RETURN
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Subroutine to find the length of a direct-access file
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE LENFIL (IUNIT,LASTBL)
|
|
DIMENSION ISTEP(4)
|
|
DATA ISTEP/1000,100,10,1/
|
|
NRSAVE = 0
|
|
DO 120 I = 1,4
|
|
IDEL = ISTEP(I)
|
|
NOFF = NRSAVE
|
|
N1 = 1
|
|
N2 = 10
|
|
IF (I .EQ. 1) N2 = 1000
|
|
DO 100 N = N1,N2
|
|
NREC = NOFF + N*IDEL
|
|
READ (IUNIT, REC = NREC, IOSTAT = IERR) RJUNK
|
|
IF (IERR .NE. 0) GO TO 110
|
|
NRSAVE = NREC
|
|
100 CONTINUE
|
|
110 IF (I .EQ. 4) THEN
|
|
LASTBL = NREC - 1
|
|
RETURN
|
|
ENDIF
|
|
120 CONTINUE
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C
|
|
C Convert the intensity data on the direct-access IDATA.DA file, into
|
|
C a formatted ASCII file suitable for transmission to or processing by
|
|
C other computers.
|
|
C
|
|
C The contents and format of the ASCII file are :--
|
|
C h,k,l, Ia, Ib1, Ipeak, Ib2, Time, Nref, Ipsi
|
|
C ( 3I4, I2, I6, I7, I6, F9.5, I6, I5) where
|
|
C Ia is the attenuator index (0 to 5),
|
|
C Ib1 is the low angle background,
|
|
C Ipeak is the total peak count,
|
|
C Ib2 is the high angle background,
|
|
C Time is (time for 1 background) / (Time for peak), i.e. FRAC
|
|
C for normal scans, or
|
|
C 10*number of scans + FRAC for controlled precision modes,
|
|
C Nref is the reflection sequence number,
|
|
C Ipsi is the psi value, usually 0, 999 for standards.
|
|
C
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE IDTOAS
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION ENREFB(10)
|
|
EQUIVALENCE(NREFB(1),ENREFB(1))
|
|
CHARACTER FILEF*40,DEFNAM*10,MORE
|
|
DEFNAM = 'IDATA.ASC '
|
|
C-----------------------------------------------------------------------
|
|
C Print the header and connect the file IFM, the formatted ASCII file
|
|
C-----------------------------------------------------------------------
|
|
IFM = IOUNIT(9)
|
|
100 WRITE (COUT,10000) DEFNAM
|
|
FILEF(1:10) = 'DONT DO IT'
|
|
CALL ALFNUM (FILEF)
|
|
IF (FILEF .EQ. ' ') FILEF = DEFNAM//' '
|
|
CALL IBMFIL (FILEF,IFM,IBMREC,'SU',IERR)
|
|
IF (IERR .NE. 0) GO TO 100
|
|
C-----------------------------------------------------------------------
|
|
C Find the intensity data record numbers to process
|
|
C-----------------------------------------------------------------------
|
|
CALL LENFIL (IID,LASTBL)
|
|
WRITE (COUT,11000) LASTBL
|
|
CALL YESNO ('Y',ANS)
|
|
110 IF (ANS .EQ. 'Y') THEN
|
|
ILAST = 1
|
|
NBEGIN = 20
|
|
NEND = LASTBL
|
|
ELSE
|
|
WRITE (COUT,12000)
|
|
CALL FREEFM (ITR)
|
|
NBEGIN = IFREE(1)
|
|
NEND = IFREE(2)
|
|
IF (NEND .EQ. 0) NEND = NBEGIN
|
|
ILAST = 0
|
|
IF (NEND .EQ. LASTBL) ILAST = 1
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Write the data needed by DATRD2 etc from record 1
|
|
C-----------------------------------------------------------------------
|
|
WRITE (IFM,12900) THEMAX,DFTYPE,DFMODL,FRAC
|
|
C-----------------------------------------------------------------------
|
|
C Process the valid data in the selected intensity data records
|
|
C-----------------------------------------------------------------------
|
|
DO 130 I = NBEGIN,NEND
|
|
READ (IID,REC = I) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB,BPSI
|
|
DO 120 J = 1,10
|
|
IF (IHK(J) .NE. 599599) THEN
|
|
IH = IHK(J)/1000 - 500
|
|
IK = IHK(J) - 1000*(IH + 500) - 500
|
|
IL = ILA(J)/1000 - 500
|
|
IA = ILA(J) - 1000*(IL + 500)
|
|
IB1 = BBGR1(J)
|
|
IPEAK = BCOUNT(J)
|
|
IB2 = BBGR2(J)
|
|
TIME = BTIME(J)
|
|
NREF = ENREFB(J)
|
|
IPSI = BPSI(J)
|
|
WRITE (IFM,13000) IH,IK,IL,IA,IB1,IPEAK,IB2,TIME,NREF,IPSI
|
|
ENDIF
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Any more to processing ?
|
|
C-----------------------------------------------------------------------
|
|
IF (ILAST .EQ. 0) THEN
|
|
WRITE (COUT,14000)
|
|
CALL YESNO ('N',MORE)
|
|
IF (MORE .EQ. 'Y') GO TO 110
|
|
ENDIF
|
|
CALL IBMFIL (FILEF,-IFM,IBMREC,'SU',IERR)
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (/10X,'Convert the IDATA File to ASCII'/
|
|
$ ' Type the Output ASCII Filename (',A,') ',$)
|
|
11000 FORMAT (' Valid data is in records 20 to',I5,'. Transform it all',
|
|
$ ' (Y) ? ',$)
|
|
12000 FORMAT (' Type the First and Last record to be transferred ',$)
|
|
12900 FORMAT (F8.3,1X,2A4,F8.4)
|
|
13000 FORMAT (3I4,I2,I6,I7,I6,F9.5,I6,I5)
|
|
14000 FORMAT (' Do you wish to transfer more records (N) ? ',$)
|
|
END
|