linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ef5a0354f3edfc92ac90fc462f77df3478bad641
sics/difrac/difint.f
cvs ff5e8cf0b2 - Improved centering in DIFRAC 
- Fixed a bug in UserWait
- Improved scan message in scancom
- Added zero point correction in lin2ang
- fixed an issue with uuencoded messages
2000-04-06 12:18:53 +00:00

725 lines
27 KiB
Fortran
Raw Blame History

C-----------------------------------------------------------------------
C This is the Command interpreting subroutine
C
C Each 2-letter command in KI is associated with a unique call or
C set of calls. Having made the call the particular 2-letter sequence
C will not make any further calls and will be cleared at the end of
C the call.
C When routines change the value of KI, which some do, the new value
C is always unique and will always cause action further down in SETOP.
C
C-----------------------------------------------------------------------
SUBROUTINE DIFINT(COMMAND, LEN)
INTEGER COMMAND(256), LEN
INCLUDE 'COMDIF'
CHARACTER STRING*80
KI(1:1) = CHAR(COMMAND(1))
KI(2:2) = CHAR(COMMAND(2))
C----------------------------------------------------------------------
C Disabling some unsupported commands for TRICS
C----------------------------------------------------------------------
IF(KI .EQ. 'AD' .OR. KI .EQ. 'LT' .OR. KI .EQ. 'SH' .OR.
$ KI .EQ. 'IN' .OR. KI .EQ. 'NR' .OR.
$ KI .EQ. 'EK' .OR. KI .EQ. 'FI' .OR. KI .EQ. 'KE' .OR.
$ KI .EQ. 'MR' .OR. KI .EQ. 'MS')THEN
WRITE(COUT,23000)
CALL GWRITE(ITP,' ')
RETURN
ENDIF
C-----------------------------------------------------------------------
C The program runs in two modes, full screen and windowed.
C The following routines require the use of the windowed mode
C-----------------------------------------------------------------------
IF (KI .EQ. 'GO' .OR. KI .EQ. 'IP' .OR.
$ KI .EQ. 'IR' .OR. KI .EQ. 'IE' .OR. KI .EQ. 'IM') THEN
IF (IWNCUR .EQ. 3) CALL WNSET (2)
ENDIF
C-----------------------------------------------------------------------
C These routines require full screen mode, any others should work
C in either mode so we are not flipping screens all the time
C-----------------------------------------------------------------------
IF (KI .EQ. 'AL' .OR. KI .EQ. 'A8' .OR. KI .EQ. 'RO' .OR.
$ KI .EQ. 'OC' .OR. KI .EQ. 'SD' .OR. KI .EQ. 'AR' .OR.
$ KI .EQ. 'PK' .OR. KI .EQ. 'RC' .OR. KI .EQ. 'PD' .OR.
$ KI .EQ. 'RP' .OR. KI .EQ. 'BD' .OR. KI .EQ. 'CH' .OR.
$ KI .EQ. 'GS' .OR. KI .EQ. 'CR' .OR. KI .EQ. 'LC' .OR.
$ KI .EQ. 'LP' .OR. KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR.
$ KI .EQ. 'MM' .OR. KI .EQ. 'RS' .OR. KI .EQ. 'BC' .OR.
$ KI .EQ. 'NR' .OR. KI .EQ. 'TO' .OR.
$ KI .EQ. 'MR' .OR. KI .EQ. 'MS' .OR. KI .EQ. 'FI') THEN
IF (IWNCUR .NE. 3) CALL WNSET (3)
ENDIF
C-----------------------------------------------------------------------
C This routine reads commands from the terminal and sets a flag to
C indicate whether the command may inhibit an automatic restart of
C data collection, if appropriate.
C All control of the program flow is via the variable KI.
C-----------------------------------------------------------------------
IF (KI .NE. ' ') THEN
IMENU = 0
ELSE
IF (IMENU .EQ. 0) THEN
WRITE (COUT,11000)
CALL YESNO ('N',ANS)
ELSE
IMENU = 0
ANS = 'Y'
ENDIF
IF (ANS .EQ. 'Y') THEN
IWNOLD = IWNCUR
IF (IWNCUR .NE. 3) CALL WNSET (3)
WRITE (COUT,12000)
CALL GWRITE (ITP,' ')
IF (DFMODL .EQ. 'CAD4') THEN
WRITE (COUT,12100)
CALL GWRITE (ITP,' ')
ENDIF
WRITE (COUT,12200)
CALL FREEFM (ITR)
I = IFREE(1)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0 .OR. I .EQ. 1) THEN
WRITE (COUT,13000)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 2) THEN
WRITE (COUT,15000)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 3) THEN
WRITE (COUT,16000)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 4) THEN
WRITE (COUT,17000)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 5) THEN
WRITE (COUT,18000)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (I .EQ. 0 .OR. I .EQ. 6) THEN
WRITE (COUT,19000)
CALL GWRITE (ITP,' ')
WRITE (COUT,20000)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
IF (DFMODL .EQ. 'CAD4' .AND. (I .EQ. 0 .OR. I .EQ. 7)) THEN
WRITE (COUT,20100)
CALL GWRITE (ITP,' ')
IF (I .EQ. 0) THEN
WRITE (COUT,14000)
CALL ALFNUM (STRING)
ANS = STRING(1:1)
ENDIF
ENDIF
ENDIF
RETURN
ENDIF
IF (KI .EQ. 'RI') KI = 'RB'
JAUTO = 0
IF (KI .EQ. 'AD') CALL BASINP
IF (KI .EQ. 'AL' .OR. KI .EQ. 'AR') CALL ALIGN
IF (KI .EQ. 'AP') CALL PROFAS
IF (KI .EQ. 'A8') CALL CENT8
IF (KI .EQ. 'BI') CALL PRNINT
IF (KI .EQ. 'CR') CALL ALIGN
IF (KI .EQ. 'CZ') CALL BASINP
IF (KI .EQ. 'DE') CALL DEMO1E
IF (KI .EQ. 'GO') THEN
ISEG = 0
IAUTO = 0
CALL BEGIN
ENDIF
IF (KI .EQ. 'GS') CALL GRID
IF (KI .EQ. 'AI') CALL IDTOAS
IF (KI .EQ. 'IE') CALL INDMES
IF (KI .EQ. 'IM') CALL INDMES
IF (KI .EQ. 'IN') CALL ANGINI
IF (KI .EQ. 'IR') CALL INDMES
IF (KI .EQ. 'IP') CALL INDMES
IF (KI .EQ. 'AH') KI = 'IX'
IF (KI .EQ. 'IX') CALL RCPCOR
IF (KI .EQ. 'LP') CALL LINPRF
IF (KI .EQ. 'MM') THEN
CALL LSORMT
IF (KI .NE. ' ') CALL BASINP
ENDIF
IF (KI .EQ. 'M2') THEN
CALL ORCEL2
IF (KI .NE. ' ') CALL BASINP
ENDIF
IF (KI .EQ. 'M3') THEN
CALL ORMAT3
IF (KI .NE. ' ') CALL BASINP
ENDIF
IF (KI .EQ. 'TO') THEN
CALL TRANSF
IF (KI .NE. ' ') CALL BASINP
ENDIF
IF (KI .EQ. 'LC') CALL CELLLS
IF (KI .EQ. 'OM') CALL BASINP
IF (KI .EQ. 'PO') KI = 'OS'
IF (KI .EQ. 'OS') CALL OSCIL
IF (KI .EQ. 'PA') CALL PRTANG
IF (KI .EQ. 'PD') CALL PRNBAS
IF (KI .EQ. 'PL') CALL SETROW
IF (KI .EQ. 'PR') CALL SETROW
IF (KI .EQ. 'HA') KI = 'RA'
IF (KI .EQ. 'P9') CALL PHI90
IF (KI .EQ. 'RA') CALL ORMAT3
IF (KI .EQ. 'RB') CALL WRBAS
IF (KI .EQ. 'RP') CALL PSCAN (JUNK,JUNK)
IF (KI .EQ. 'SA') CALL INDMES
IF (KI .EQ. 'SC') CALL INDMES
IF (KI .EQ. 'SH') THEN
CALL SHUTTR (0)
KI = ' '
ENDIF
IF (KI .EQ. 'SW') CALL SWITCH
IF (KI .EQ. 'SO') CALL INDMES
IF (KI .EQ. 'SP') CALL INDMES
IF (KI .EQ. 'SR') CALL INDMES
IF (DFMODL .EQ. 'CAD4') THEN
IF (KI .EQ. 'EK' .OR. KI .EQ. 'KE') CALL EKKE
IF (KI .EQ. 'MS') CALL INDMES
IF (KI .EQ. 'MR') CALL RCPCOR
IF (KI .EQ. 'FI') CALL FACEIN
ENDIF
IF (KI .EQ. 'ST') CALL INDMES
IF (KI .EQ. 'TC') CALL PCOUNT
IF (KI .EQ. 'UM') CALL CNTREF
IF (KI .EQ. 'VM') CALL VUMICR
IF (KI .EQ. 'WB') CALL WRBAS
IF (KI .EQ. 'HO' .OR. KI .EQ. 'ZE') THEN
CALL ZERODF
KI = ' '
ENDIF
IF (KI .EQ. 'NR') CALL SETNRC
C-----------------------------------------------------------------------
C If the command has not yet been executed, no auto restart is
C possible
C-----------------------------------------------------------------------
IF (KI .NE. ' ') JAUTO = 1
IF (KI .EQ. 'BD') CALL BASINP
IF (KI .EQ. 'CH') CALL REINDX
IF (KI .EQ. 'DH') THEN
IKO(5) = 0
CALL BASINP
ENDIF
IF (KI .EQ. 'FR') CALL BASINP
IF (KI .EQ. 'LA') CALL BASINP
IF (KI .EQ. 'LT') CALL LOTEM
IF (KI .EQ. 'OC') CALL BLIND
IF (KI .EQ. 'PK') CALL PEAKSR
IF (KI .EQ. 'PS') CALL BASINP
IF (KI .EQ. 'RC') CALL CREDUC (KI)
IF (KI .EQ. 'RO') CALL BASINP
IF (KI .EQ. 'BC') CALL BIGCHI
IF (KI .EQ. 'RR') CALL BASINP
IF (KI .EQ. 'RS') CALL REINDX
IF (KI .EQ. 'SD') CALL BASINP
IF (KI .EQ. 'SE') CALL BASINP
IF (KI .EQ. 'SG') THEN
IOUT = ITP
CALL SPACEG (IOUT,1)
ENDIF
IF (KI .EQ. 'TM') CALL BASINP
IF (KI .EQ. 'TP') CALL BASINP
C-----------------------------------------------------------------------
C If the KI code is in the first 60 codes, then no automatic restart.
C-----------------------------------------------------------------------
IF (JAUTO .NE. 0) THEN
NSAVE = NBLOCK
ZERO = 0
WRITE (IID,REC=9) ZERO
NBLOCK = NSAVE
ENDIF
IF (KI .NE. ' ') THEN
WRITE (COUT,22000) KI
CALL GWRITE (ITP,' ')
KI = ' '
IMENU = 1
RETURN
ENDIF
RETURN
10000 FORMAT (' Command ',$)
11000 FORMAT (' Unacceptable command. Do you want the menus (N) ? ',$)
12000 FORMAT (/' The following help menus are available :--'/
$ ' 1. Terminal Data Input Commands;'/
$ ' 2. Crystal Alignment Commands;'/
$ ' 3. Intensity Data Collection;'/
$ ' 4. Angle Setting and Intensity Measurement;'/
$ ' 5. Photograph Setup Commands;'/
$ ' 6. General System Commands.')
12100 FORMAT ( ' 7. Kappa Geometry (CAD-4) Commands.')
12200 FORMAT (' Which do you want (All) ? ',$)
13000 FORMAT (/10X,'*** Terminal Data Input Commands ***'/
$' AD Attenuator Data: number and values.'/
$' BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP)'/
$' CZ Correct angle Zero values.'/
$' FR First Reflection to be measured.'/
$' LA LAmbda for the wavelength in use, usually alpha1.'/
$' LT Liquid Nitrogen option - specific to cryosystem.'/
$' OM Orientation Matrix.'/
$' PS PSi rotation data.'/
$' RO re-Orientation Reflections: frequency and h,k,ls.'/
$' RR Reference Reflections: frequency and h,k,ls.'/
$' SD Scan Data: type, width, speed, profile control.'/
$' SE Systematic Extinctions.'/
$' SG Space-Group symbol.'/
$' TM 2Theta Min and max values.'/
$' TP Time and Precision parameters for intensity measurement.'/)
14000 FORMAT (' Type <CR> when ready to proceed.')
15000 FORMAT (/10X,'*** Crystal Alignment Commands ***'/
$' AL ALign reflections and their symmetry equivalents for MM.'/
$' AR Align Resumption after interruption.'/
$' A8 Align the 8 alternate settings of one reflection.'/
$' CH CHoose reflections from the PK list for use with M2/M3.'/
$' CR Centre the Reflection which is already in the detector.'/
$' LC 2theta Least-squares Cell with symmetry constrained cell.'/
$' MM Matrix from Many reflections by least-squares on AL data.'/
$' M2 Matrix from 2 indexed reflections and a unit cell.'/
$' M3 Matrix from 3 indexed reflections.'/
$' OC Orient a Crystal, i.e. index the peaks from PK.'/
$' PK PeaK search in 2Theta, Chi, Phi for use with OC.'/
$' RC Reduce a unit Cell.'/
$' RP Rotate Phi 360degs, centre and save any peaks found.'/
$' RS ReSet the cell and matrix with the results from RC.'/
$' TO Transform the Orientation matrix.'/)
16000 FORMAT (/10X,'*** Intensity Data Collection ***'/
$' GO Start of intensity data collection.'/
$' K Kill operation at the end of the current reflection.'/
$' Q Quit after the next set of reference reflections.'/)
17000 FORMAT (/5X,'*** Angle Setting and Intensity Measurement ***'/
$' GS Grid Search measurement in 2theta, omega or chi.'/
$' IE Intensity measurement for Equivalent reflections.'/
$' IM Intensity Measurement of the reflection in the detector.'/
$' IP Intensity measurement in Psi for empirical absorption.'/
$' IR Intensity measurement for specified Reflections.'/
$' LP Line Profile plot on the printer.'/
$' SA Set All angles to specified values.'/
$' SC Set Chi to the specified value.'/
$' SH SHutter open or close as a flip/flop.'/
$' SO Set Omega to the specified value.'/
$' SP Set Phi to the specified value.'/
$' SR Set Reflection: h,k,l,psi.'/
$' ST Set 2Theta to the specified value.'/
$' TC Timed Counts.'/
$' ZE ZEro the instrument Angles.'/)
18000 FORMAT (/10X,'*** Photograph Setup Commands ***'/
$' PL Photograph in the Laue mode.'/
$' PO Photograph in the Oscillation mode (same as OS).'/
$' PR Photograph in the Rotation mode.'/)
19000 FORMAT (/10X,'*** General System Commands ***'/
$' AH Angles to H,k,l (same as IX).'/
$' AI Ascii Intensity data file conversion.'/
$' AP Ascii Profile data file conversion.'/
$' BC Big Chi search for psi rotation.'/
$' BI Big Intensity search in the IDATA.DA file.'/
$' EX EXit the program saving the basic data on IDATA.DA.'/
$' HA H,k,l to Angles (same as RA).')
20000 FORMAT (
$' IN INitialize integer parts of present angles (NRC only).'/
$' NR set the NRC program flag.'/
$' P9 Rotate Phi by 90 degrees for crystal centering.'/
$' PA Print Angle settings.'/
$' PD Print Data of all forms.'/
$' Q Quit the program directly.'/
$' RB Read the Basic data from the IDATA.DA file.'/
$' SW SWitch register flags setting.'/
$' UM (UMpty) Count unique reflections within theta limits.'/
$' VM View crystal with Microscope.'/
$' WB Write the Basic data to the IDATA.DA file.'/)
20100 FORMAT (/10X,'*** For Kappa geometry (CAD-4) ***'/
$' EK Euler to Kappa angle conversion.'/
$' KE Kappa to Euler angle conversion.'/
$' MR emulate CAD-4 MICROR command.'/
$' MS emulate CAD-4 MICROS command.')
21000 FORMAT (' EX was typed. Are you sure you wish to exit (Y) ? ',$)
22000 FORMAT (' The command ',A,' is invalid. Type <CR> for the menus.')
23000 FORMAT ('ERROR: Unsupported command ignored by difrac subsystem')
END
C-----------------------------------------------------------------------
C Subroutine to open and close the X-ray shutter
C This routine is called via 'SH' or direct from other routines.
C The argument IDO has the following values :--
C -1 Close the shutter
C 0 Reverse the sense of the shutter. The sense is held in SENSE
C 1 Open the shutter
C 2 ??
C 99 Called from GOLOOP at the start of data-collection;
C Opens the shutter and sets DOIT = 'NO'
C to prevent shutter operation during data-collection.
C -99 Called from GOLOOP at the end of data-collection;
C Closes the shutter and sets DOIT = 'YES'
C to allow normal shutter operation.
C
C This version is for Rigaku diffractometers,but should work (surely?)
C for all instruments with trivial modification.
C-----------------------------------------------------------------------
SUBROUTINE SHUTTR (IDO)
CHARACTER SENSE*4,COUT(20)*132,DOIT*4
COMMON /IOUASC/ COUT
DATA SENSE/'CLOS'/,ICLOSE,IOPEN/0,1/,DOIT/'YES '/
INF = 0
IF (DOIT .EQ. 'YES ') THEN
IF (IDO .EQ.-1 .OR. IDO .EQ. -99) THEN
IF (SENSE .EQ. 'OPEN') THEN
CALL SHUTR (ICLOSE,INF)
IF (INF .NE. 0) GO TO 100
SENSE = 'CLOS'
ENDIF
ELSE IF (IDO .EQ. 0) THEN
IF (SENSE .EQ. 'OPEN') THEN
CALL SHUTR (ICLOSE,INF)
IF (INF .NE. 0) GO TO 100
SENSE = 'CLOS'
ELSE
CALL SHUTR (IOPEN,INF)
IF (INF .NE. 0) GO TO 100
SENSE = 'OPEN'
ENDIF
ELSE IF (IDO .EQ. 1 .OR. IDO .EQ. 99) THEN
IF (SENSE .EQ. 'CLOS') THEN
CALL SHUTR (IOPEN,INF)
IF (INF .NE. 0) GO TO 100
SENSE = 'OPEN'
ENDIF
ELSE IF (IDO .EQ. 2) THEN
IF (SENSE .EQ. 'OPEN') CALL SHUTR (IOPEN,INF)
IF (SENSE .EQ. 'CLOS') CALL SHUTR (ICLOSE,INF)
ENDIF
ELSE
IF (IDO .EQ. -99) THEN
CALL SHUTR (ICLOSE,INF)
IF (INF .NE. 0) GO TO 100
SENSE = 'CLOS'
ENDIF
ENDIF
IF (IDO .EQ. 99) DOIT = 'NO '
IF (IDO .EQ. -99) DOIT = 'YES '
RETURN
100 WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
RETURN
10000 FORMAT (' Shutter Error.')
END
C-----------------------------------------------------------------------
C Subroutine to initialize the integer values of the angles
C-----------------------------------------------------------------------
SUBROUTINE ANGINI
INCLUDE 'COMDIF'
WRITE (COUT,10000)
CALL YESNO ('Y',ANS)
IF (ANS .EQ. 'Y') THEN
WRITE (COUT,11000)
CALL FREEFM (ITR)
RTHETA = RFREE(1)
ROMEGA = RFREE(2)
RCHI = RFREE(3)
RPHI = RFREE(4)
CALL INITL (RTHETA,ROMEGA,RCHI,RPHI)
KI = ' '
ENDIF
RETURN
10000 FORMAT (' Initialize the integer parts of the angle (Y) ? ',$)
11000 FORMAT (' Type the integers for 2theta,omega,chi,phi ',$)
END
C-----------------------------------------------------------------------
C Subroutine to call the space group symbol interpreting routines
C If IOUT .LT. -1 the symbol is not asked for
C If IOUT .LT. 0 there is no printed output from SGROUP
C If IDHFLG .EQ. 1 the DH matrices are generated
C-----------------------------------------------------------------------
SUBROUTINE SPACEG (IOUT,IDHFLG)
INCLUDE 'COMDIF'
DIMENSION CEN(3,4),GARB(500),ISET(25)
EQUIVALENCE (ACOUNT(1),GARB(1))
CHARACTER STRING*10
IF (IOUT .EQ. -2) THEN
IOUT = -1
GO TO 130
ENDIF
100 IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0) THEN
WRITE (COUT,10000)
ELSE
WRITE (STRING,11000) SGSYMB
DO 110 I = 10,1,-1
IF (STRING(I:I) .NE. ' ') GO TO 120
110 CONTINUE
120 WRITE (COUT,12000) STRING(1:I)
ENDIF
CALL ALFNUM (STRING)
IF (STRING .NE. ' ') READ (STRING,11000) SGSYMB
130 IERR = ITP
CALL SGROUP (SGSYMB,LAUENO,NAXIS,ICENT,LATCEN,NSYM,NPOL,JRT,
$ CEN,NCV,IOUT,IERR,GARB)
IF (NAXIS .GE. 4) GO TO 100
IF (IDHFLG .EQ. 1) THEN
SAVE = NBLOCK
CALL DHGEN
NBLOCK = SAVE
C-----------------------------------------------------------------------
C Read the DH segment data from the IDATA file
C-----------------------------------------------------------------------
READ (IID,REC=4) LATCEN,NSEG,(IHO(I),IKO(I),ILO(I),((IDH(I,J,M),
$ J = 1,3),M = 1,3),I = 1,4),
$ NSYM,NSET,ISET,LAUENO,NAXIS,ICENT
ENDIF
IF (KI .EQ. 'SG') KI = ' '
RETURN
10000 FORMAT (' Type the space-group symbol ')
11000 FORMAT (10A1)
12000 FORMAT (' Type the space-group symbol (',A,') ')
END
C-----------------------------------------------------------------------
C Subroutine to set switches
C-----------------------------------------------------------------------
SUBROUTINE SWITCH
INCLUDE 'COMDIF'
CHARACTER STRING*20
WRITE (COUT,10000) (ISREG(I),I=1,10)
CALL ALFNUM (STRING)
IF (STRING .NE. ' ') THEN
DO 100 I = 1,LEN(STRING)
IASCII = ICHAR (STRING(I:I))
IF (IASCII .GE. 48 .AND. IASCII .LE. 57) THEN
ISWTCH = IASCII - 48 + 1
IF (ISREG(ISWTCH) .EQ. 0) THEN
ISREG(ISWTCH) = 1
ELSE
ISREG(ISWTCH) = 0
ENDIF
ENDIF
100 CONTINUE
ENDIF
WRITE (COUT,11000) (ISREG(I),I=1,10)
CALL GWRITE (ITP,' ')
KI = ' '
RETURN
10000 FORMAT (' The current settings are: 0 1 2 3 4 5 6 7 8 9'/
$ ' ',10I2/
$ ' Input switches to change (none): ')
11000 FORMAT (' The new settings are: 0 1 2 3 4 5 6 7 8 9'/
$ ' ',10I2)
END
C----------------------------------------------------------------------
C Set the NRC flag +1 if Chi(0) is at the bottom of the chi circle,
C -1 if Chi(0) is at the top.
C Assuming the instrument itself is defined in a right-handed way.
C----------------------------------------------------------------------
SUBROUTINE SETNRC
INCLUDE 'COMDIF'
WRITE (COUT,10000) NRC
CALL FREEFM (ITR)
IF (IFREE(1) .NE. 0) NRC = IFREE(1)
RETURN
10000 FORMAT (' The current value of the NRC flag is',I3/
$ ' Type the new value (Current) ',$)
END
C-----------------------------------------------------------------------
C Convert Euler angles to Kappa (KI = 'EK') or vice-versa (KI = 'KE')
C-----------------------------------------------------------------------
SUBROUTINE EKKE
INCLUDE 'COMDIF'
COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
$ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
$ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
PARAMETER (RA = 57.2958)
SALPHA = SIN(ALPHA/RA)
CALPHA = COS(ALPHA/RA)
ISTATUS = 0
C-----------------------------------------------------------------------
C KI = 'EK' Euler to Kappa
C-----------------------------------------------------------------------
IF (KI .EQ. 'EK') THEN
WRITE (COUT,10000) THETA,OMEGA,CHI,PHI
CALL FREEFM (ITR)
IF (RFREE(1) .EQ. 0.0 .AND. RFREE(2) .EQ. 0.0 .AND.
$ RFREE(3) .EQ. 0.0) THEN
THE = THETA
OME = OMEGA
CHE = CHI
PHE = PHI
ELSE
THE = RFREE(1)
OME = RFREE(2)
CHE = RFREE(3)
PHE = RFREE(4)
ENDIF
THE = THE/2.0
SCO2 = SIN(ONE80(CHE)/(2.0*RA))
BOT = SALPHA*SALPHA - SCO2*SCO2
IF (BOT .LT. 0.0) THEN
ISTATUS = 1
KI = ' '
RETURN
ENDIF
RKAO2 = ATAN(SCO2/SQRT(BOT))
RKA = ONE80(2.0*RA*RKAO2)
DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2))
OMK = ONE80(OME - DELTA) + THE
PHK = ONE80(PHE - DELTA)
WRITE (COUT,11000) THE,OMK,RKA,PHK
C-----------------------------------------------------------------------
C KI = 'KE' Kappa to Euler
C-----------------------------------------------------------------------
ELSE
WRITE (COUT,12000)
CALL FREEFM (ITR)
THE = RFREE(1)
OMK = RFREE(2)
RKA = RFREE(3)
PHK = RFREE(4)
OMK = OMK - THE
THE = THE + THE
RKAO2 = RKA/(2.0*RA)
CHE = ONE80(2.0*RA*ASIN(SALPHA*SIN(RKAO2)))
DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2))
OME = ONE80(OMK + DELTA)
PHE = ONE80(PHK + DELTA)
WRITE (COUT,13000) THE,OME,CHE,PHE
ENDIF
CALL GWRITE (ITP,' ')
KI = ' '
RETURN
10000 FORMAT (' The present Euler angles are 2T,O,C,P',4F8.3,/
$ ' Type the angles to convert (Present) ',$)
11000 FORMAT (' The 4 Kappa angles T,O,K,P are ',4F8.3)
12000 FORMAT (' Type the 4 Kappa angles T,O,K,P ',$)
13000 FORMAT (' The 4 Euler angles 2T,O,C,P are ',4F8.3)
END
C-----------------------------------------------------------------------
C Set the diffractometer to a convenient microscope viewing position
C-----------------------------------------------------------------------
SUBROUTINE VUMICR
INCLUDE 'COMDIF'
NATT = 0
CALL VUPOS (THETA,OMEGA,CHI,PHI)
CALL SHUTTR (-99)
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR)
IF (IERR .NE. 0) THEN
WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
ENDIF
KI = ' '
RETURN
10000 FORMAT (' Setting collision during VM')
END
C-----------------------------------------------------------------------
C Rotate the crystal 90 degrees in phi for centering operations
C-----------------------------------------------------------------------
SUBROUTINE PHI90
INCLUDE 'COMDIF'
CALL ANGET (THETA,OMEGA,CHI,PHI)
PHI = PHI + 90.0
CALL MOD360 (PHI)
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR)
KI = ' '
RETURN
END
C-----------------------------------------------------------------------
C Transform the orientation matrix
C-----------------------------------------------------------------------
SUBROUTINE TRANSF
INCLUDE 'COMDIF'
DIMENSION HOLD(3,3),HNEW(3,3),HNEWI(3,3),RNEW(3,3)
WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
DO 100 I = 1,3
90 WRITE (COUT,11000) I
CALL FREEFM (ITR)
HOLD(1,I) = IFREE(1)
HOLD(2,I) = IFREE(2)
HOLD(3,I) = IFREE(3)
HNEW(1,I) = IFREE(4)
HNEW(2,I) = IFREE(5)
HNEW(3,I) = IFREE(6)
IF ((HOLD(1,I) .EQ. 0.0 .AND. HOLD(2,I) .EQ. 0.0 .AND.
$ HOLD(3,I) .EQ. 0.0) .OR.
$ (HNEW(1,I) .EQ. 0.0 .AND. HNEW(2,I) .EQ. 0.0 .AND.
$ HNEW(3,I) .EQ. 0.0)) THEN
WRITE (COUT,11100)
CALL GWRITE (ITP,' ')
GO TO 90
ENDIF
100 CONTINUE
C-----------------------------------------------------------------------
C Invert the IHNEW matrix and form RNEW = R.IHOLD.(IHNEW)-1
C-----------------------------------------------------------------------
CALL MATRIX (HNEW,HNEWI,HNEWI,HNEWI,'INVERT')
CALL MATRIX (R,HOLD,RNEW,RJUNK,'MATMUL')
CALL MATRIX (RNEW,HNEWI,RNEW,RJUNK,'MATMUL')
C-----------------------------------------------------------------------
C Print the new matrix and parameters
C-----------------------------------------------------------------------
DO 110 I = 1,3
DO 110 J = 1,3
ROLD(I,J) = R(I,J)/WAVE
R(I,J) = RNEW(I,J)
RNEW(I,J) = RNEW(I,J)/WAVE
110 CONTINUE
C-----------------------------------------------------------------------
C Evaluate the determinant to decide if right or left handed
C-----------------------------------------------------------------------
DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) -
$ R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) +
$ R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1))
IF (NRC*DET .EQ. 0) THEN
WRITE (COUT,12000)
KI = ' '
ELSE IF (NRC*DET .GT. 0) THEN
WRITE (COUT,13000) KI,((RNEW(I,J),J = 1,3),I = 1,3)
ELSE
WRITE (COUT,14000) KI,((RNEW(I,J),J = 1,3),I = 1,3)
ENDIF
CALL GWRITE (ITP,' ')
CALL GETPAR
DO 120 I = 1,3
AP(I) = AP(I)*WAVE
120 CONTINUE
WRITE (COUT,15000) AP,CANG
CALL GWRITE (ITP,' ')
RETURN
10000 FORMAT (10X,' Transform the Orientation Matrix'/
$ ' Type in old and new h,k,l values for 3 reflections')
11000 FORMAT (' Type old and new h,k,l for reflection',I2,' ',$)
11100 FORMAT (' 0,0,0 indices not allowed. Try again.')
12000 FORMAT (' The determinant of the matrix is 0.')
13000 FORMAT (' New RIGHT-handed Orientation Matrix from ',A2/(3F12.8))
14000 FORMAT (' New LEFT-handed Orientation Matrix from ',A2/(3F12.8))
15000 FORMAT (' New Unit Cell ',3F9.4,3F9.3)
END
Reference in New Issue View Git Blame Copy Permalink