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 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 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