C----------------------------------------------------------------------- C Routine to print the Basic Data or Intensity Data on LPT C----------------------------------------------------------------------- SUBROUTINE PRNBAS INCLUDE 'COMDIF' DIMENSION RW(3,3),ANG(3) CHARACTER CPROF*4,STRING*10 WRITE (COUT,10000) CALL ALFNUM (STRING) ANS = STRING(1:1) KZ = -1 IF (ANS .EQ. ' ' .OR. ANS .EQ. '0') KZ = 0 IF (ANS .EQ. '1') KZ = 1 IF (ANS .EQ. '2') KZ = 2 IF (ANS .EQ. '3') KZ = 3 IF (KZ .EQ. -1) THEN KI = ' ' RETURN ENDIF C----------------------------------------------------------------------- C Call to PRNINT to print Intensity Data C----------------------------------------------------------------------- IF (KZ .EQ. 2 .OR. KZ .EQ. 3) THEN KI = ANS CALL PRNINT KI = ' ' RETURN ENDIF IOUT = ITP IF (KZ .EQ. 1) IOUT = LPT C----------------------------------------------------------------------- C Print the space-group symbol, wavelength and unit cell C----------------------------------------------------------------------- WRITE (STRING,11000) SGSYMB WRITE (COUT,11100) STRING,WAVE CALL GWRITE (IOUT,' ') DO 100 I = 1,3 ANG(I) = DEG*ATAN2(SANG(I),CANG(I)) 100 CONTINUE C----------------------------------------------------------------------- C Matrix and cell data C----------------------------------------------------------------------- DO 110 I = 1,3 DO 110 J = 1,3 RW(I,J) = R(I,J)/WAVE 110 CONTINUE WRITE (COUT,13000) CALL GWRITE (IOUT,' ') WRITE (COUT,13100) (RW(1,J),J = 1,3),(SINABS(J),J = 1,3) CALL GWRITE (IOUT,' ') WRITE (COUT,13100) (RW(2,J),J = 1,3),(SINABS(J),J = 4,6) CALL GWRITE (IOUT,' ') WRITE (COUT,13100) (RW(3,J),J = 1,3) CALL GWRITE (IOUT,' ') WRITE (COUT,14000) AP,ANG CALL GWRITE (IOUT,' ') C----------------------------------------------------------------------- C CZ data C----------------------------------------------------------------------- WRITE (COUT,15000) DTHETA,DOMEGA,DCHI CALL GWRITE (IOUT,' ') C----------------------------------------------------------------------- C Attenuator Data C----------------------------------------------------------------------- IF (NATTEN .EQ. 0) THEN WRITE (COUT,15100) ELSE WRITE (COUT,15200) (ATTEN(J),J = 1,NATTEN+1) ENDIF CALL GWRITE (IOUT,' ') C----------------------------------------------------------------------- C Psi data C----------------------------------------------------------------------- IF (DPSI .EQ. 0) THEN WRITE (COUT,15300) ELSE WRITE (COUT,15400) PSIMIN,PSIMAX,DPSI ENDIF CALL GWRITE (IOUT,' ') C----------------------------------------------------------------------- C Reference Reflection data C----------------------------------------------------------------------- IF (NSTAN .EQ. 0) THEN WRITE (COUT,15900) CALL GWRITE (IOUT,' ') ELSE WRITE (COUT,16000) NSTAN,NINTRR CALL GWRITE (IOUT,' ') DO 310 J = 1, NSTAN WRITE (COUT,17000)IHSTAN(J),IKSTAN(J),ILSTAN(J) CALL GWRITE (IOUT,' ') 310 CONTINUE ENDIF C----------------------------------------------------------------------- C Re-Orientation data C----------------------------------------------------------------------- IF (NINTOR .EQ. 0) THEN WRITE (COUT,18000) ELSE WRITE (COUT,19000) NINTOR,REOTOL ENDIF CALL GWRITE (IOUT,' ') READ (IID,REC = 16) (IOH(I),I = 1,80) READ (IID,REC = 17) (IOK(I),I = 1,80),NTOT READ (IID,REC = 18) (IOL(I),I = 1,80) I = NTOT + NTOT IF (NTOT .GT. 0) THEN WRITE (COUT,16900) I CALL GWRITE (IOUT,' ') DO 320 I = 1, NTOT WRITE (COUT,17000)IOH(I),IOK(I),IOL(I) CALL GWRITE (IOUT,' ') 320 CONTINUE ENDIF C----------------------------------------------------------------------- C Pause to allow users to read the screen C----------------------------------------------------------------------- WRITE (COUT,20000) CALL ALFNUM (STRING) ANS = STRING(1:1) C----------------------------------------------------------------------- C Theta min/max and h,k,l max data C----------------------------------------------------------------------- WRITE (COUT,21000) THEMIN,THEMAX,IHMAX,IKMAX,ILMAX CALL GWRITE (IOUT,' ') C----------------------------------------------------------------------- C SE data C----------------------------------------------------------------------- IF (NCOND .LE. 0) THEN WRITE (COUT,22000) CALL GWRITE (IOUT,' ') ELSE WRITE (COUT,23000) CALL GWRITE (IOUT,' ') DO 140 J = 1,NCOND WRITE (COUT,24000) ICOND(J),IHS(J),IKS(J),ILS(J),IR(J),IS(J) CALL GWRITE (IOUT,' ') 140 CONTINUE ENDIF C----------------------------------------------------------------------- C SD data C----------------------------------------------------------------------- IF (ISCAN .EQ. 1) THEN WRITE (COUT,25000) CALL GWRITE (IOUT,' ') ELSE CPROF = 'No p' IF (IPRFLG .EQ. 0) CPROF = ' P' IF (ITYPE .EQ. 0) THEN WRITE (COUT,26000) CPROF CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 2) THEN WRITE (COUT,27000) CPROF CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 1) THEN WRITE (COUT,28000) CPROF CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 3) THEN WRITE (COUT,29000) CPROF CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 5) THEN WRITE (COUT,30000) CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 6) THEN WRITE (COUT,31000) CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 7) THEN WRITE (COUT,32000) CALL GWRITE (IOUT,' ') ENDIF IF (ITYPE .EQ. 8) THEN WRITE (COUT,33000) CALL GWRITE (IOUT,' ') ENDIF ENDIF C IF (ITYPE .LE. 3) THEN C IF (IBSECT .EQ. 1) THEN C WRITE (COUT,34000) SPEED C CALL GWRITE (IOUT,' ') C ELSE C WRITE (COUT,35000) SPEED C CALL GWRITE (IOUT,' ') C ENDIF C ENDIF WRITE (COUT,36000) AS,BS,CS CALL GWRITE (IOUT,' ') WRITE (COUT,37000) FRAC,TMAX,PA,PM CALL GWRITE (IOUT,' ') WRITE(COUT,37100),STEP, PRESET CALL GWRITE (IOUT,' ') C----------------------------------------------------------------------- C DH data C----------------------------------------------------------------------- WRITE (COUT,38000) NSEG CALL GWRITE (IOUT,' ') DO 150 J = 1,NSEG WRITE (COUT,39000) IHO(J), IKO(J), ILO(J), $ IDH(J,1,1),IDH(J,2,1),IDH(J,3,1), $ IDH(J,1,2),IDH(J,2,2),IDH(J,3,2), $ IDH(J,1,3),IDH(J,2,3),IDH(J,3,3) CALL GWRITE (IOUT,' ') 150 CONTINUE C----------------------------------------------------------------------- C Compton scattering data (not active EJG April 94) C----------------------------------------------------------------------- IF (ISCAN .EQ. 1) THEN WRITE (COUT,40000) CALL GWRITE (IOUT,' ') DO 160 J = 1,NSEG WRITE (COUT,39000) JA(J),JB(J),JC(J),JMIN(J),JMAX(J) CALL GWRITE (IOUT,' ') 160 CONTINUE ENDIF C----------------------------------------------------------------------- C Current GO data C----------------------------------------------------------------------- IF (NSET .LE. 0) READ (IID,REC=9) JUNK,JUNK,JUNK,JUNK,NSET WRITE (COUT,43000) IND,NREF,NSET,NMSEG,NBLOCK CALL GWRITE (IOUT,' ') IF (ILN .EQ. 1) THEN WRITE (COUT,44000) DELAY CALL GWRITE (IOUT,' ') ENDIF KI = ' ' RETURN 10000 FORMAT (10X,' Print Data on Terminal or LPT'/ $ ' Options are :-- 0 Print Basic Data on Terminal'/ $ ' 1 Print Basic Data on LPT'/ $ ' 2 Print Intensity Data on Terminal'/ $ ' 3 Print Intensity Data on LPT'/ $ ' Type your choice (0) ',$) 11000 FORMAT (10A1) 11100 FORMAT (' Space-group ',A,' Wavelength ',F10.5) 13000 FORMAT (10X,'Orientation Matrix',26X,'Theta Matrix') 13100 FORMAT (3F12.8,5X,3F12.8) 14000 FORMAT (' Cell ',3F9.4,5X,3F9.3) 15000 FORMAT (' D2theta ',F6.3,' Domega ',F6.3,' Dchi ',F6.3) 15100 FORMAT (' No attenuators.') 15200 FORMAT (' Attenuator factors ',6F8.3) 15300 FORMAT (' No Psi rotation') 15400 FORMAT (' Psi rotation from',F7.2,' to',F7.2,' in steps of',F6.2) 15900 FORMAT (' No reference reflection measurements') 16000 FORMAT (I3,' reference reflections measured every',I4, $ ' reflections') 16900 FORMAT (I4,' Alignment/Re-orientation Reflections', $ ' (including Friedel equivalents)') 17000 FORMAT (4(3I4,3X)) 18000 FORMAT (' No Re-orientation during data-collection.') 19000 FORMAT (' Re-orientation every',I4,' reflections.'/ $ ' Angular tolerance for new matrix acceptance',F7.3) 20000 FORMAT (/' Type when ready to proceed.') 21000 FORMAT (' 2Theta Limits: Min',F7.3,'; Max',F8.3,'.', $ ' Hmax',I3,', Kmax',I3,', Lmax',I3,'.') $ 22000 FORMAT (' There are NO Explicit Absence Conditions') 23000 FORMAT (' The Explicit Absence Conditions are :--') 24000 FORMAT (' Type',I3,' -- ', $ I4,'*h +',I2,'*k +',I2,'*l = ',I2,'*n +',I2) 30000 FORMAT (' Peak Top Counting - 2Theta range') 31000 FORMAT (' Peak Top Counting - Omega range') 32000 FORMAT (' Economized Peak Top - 2Theta range') 33000 FORMAT (' Economized Peak Top - Omega range') 26000 FORMAT (' Omega/2Theta Scan. ',A,'rofile analysis.') 27000 FORMAT (' Omega Scan. ',A,'rofile analysis.') 28000 FORMAT (' Omega/2Theta Scan with Precision Control. ',A, $ 'rofile analysis.') 29000 FORMAT (' Omega Scan with Precision Control. ',A, $ 'rofile analysis.') 25000 FORMAT (' Compton or TDS Measurements') 35000 FORMAT (' Bisecting Geometry. Scan speed ',F8.3,'deg/min') 34000 FORMAT (' Parallel Geometry. Scan speed ',F8.3,'deg/min') 36000 FORMAT (' Scan Parameters: ', $ F6.3,' + ',F6.3,'*tan(theta) + ',F6.3) 37000 FORMAT (' Time/Precision Params: ', $ ' Bkfrac',F6.3,'; Tmax ',F6.1,', PA ',F6.2,', PM ',F6.2) 37100 FORMAT(' Stepwidth: ',F8.3,' Counter Preset: ', F12.2) 38000 FORMAT (' Segment Data (DH Matrices) ',I2,' segment(s)') 39000 FORMAT (12I4) 40000 FORMAT (' Brillouin Zone Data for each segment',/, $ ' JA JB JC JMN JMX') 43000 FORMAT (' Next reflection: ',3I4,', #',I5,', set',I3, $ ', segment',I2,', at record ',I4) 44000 FORMAT (' This is a low-temperature experiment.'/ $ ' The waiting time after a refill is',F6.2,' minutes.') END