linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial revision

Browse Source
This commit is contained in:
cvs
2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

423
difrac/prnint.f Normal file
View File

@@ -0,0 +1,423 @@
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