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