linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0ce72deb583005f2b4d0faa4ef251c3f34bbae04
sics/difrac/prnbas.f
cvs 714b8ae84d - Fixed a bug which caused the SICServer to die when a socket was broken. 
- Fixed many things in DIFRAC subsystem:
  * Recoded tcentr.f etc so that the course centering will work and will not
    go into an endless loop.
  * fixed boundary overwrites which occurred when yesno or alfnum where
    uset to get a single character and several were given.
  * Addeded documentation for DIFRAC
- Added tcl-files which  support the WWW status system
2000-03-31 13:16:50 +00:00

292 lines
11 KiB
Fortran
Raw Blame History

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 <CR> 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
Reference in New Issue View Git Blame Copy Permalink