sics/difrac/difini.f

C-----------------------------------------------------------------------
C 
C    Diffractometer Control Routine for NRC Picker or Rigaku AFC6
C                       E.J.Gabe and P.S White
C            Chemistry Department , UNC, Chapel Hill, NC, USA
C
C  This routine is based on the original NRC Picker routine for the PDP8
C                E.J. Gabe, Y. Le Page & D.F. Grant
C           Chemistry Division, N.R.C., Ottawa, Canada.
C
C  The original code has been cleaned up and brought to F77 standard.
C
C  Transformed into a Subroutine for initialization for SICS by 
C  Mark Koennecke, November 1999
C
C      Key              Function
C
C           *** Terminal Data Input Commands *** 
C
C       AD Attenuator Data: number and values. 
C       BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP) 
C       CZ Correct angle Zero values. 
C       FR First Reflection to be measured. 
C       LA LAmbda for the wavelength in use, usually alpha1. 
C       LN Liquid Nitrogen option - specific to cryosystem. 
C       OM Orientation Matrix. 
C       PS PSi rotation data. 
C       RO re-Orientation Reflections: frequency and h,k,ls. 
C       RR Reference Reflections: frequency and h,k,ls. 
C       SD Scan Data: type, width, speed, profile control. 
C       SE Systematic Extinctions. 
C       SG Space-Group symbol. 
C       TM 2Theta Min and max values. 
C       TP Time and Precision parameters for intensity measurement. 
C
C           *** Crystal Alignment Commands *** 
C
C       AL ALign reflections and their symmetry equivalents for MM. 
C       AR Align Resumption after interruption. 
C       A8 Align the 8 alternate settings of one reflection. 
C       CH CHoose reflections from the PK list for use with M2/M3. 
C       CR Centre the Reflection which is already in the detector. 
C       LC 2theta Least-squares Cell with symmetry constrained cell. 
C       MM Matrix from Many reflections by least-squares on AL data. 
C       M2 Matrix from 2 indexed reflections and a unit cell. 
C       M3 Matrix from 3 indexed reflections. 
C       OC Orient a Crystal, i.e. index the peaks from PK. 
C       PK PeaK search in 2Theta, Chi, Phi for use with OC. 
C       RC Reduce a unit Cell. 
C       RP Rotate Phi 360degs, centre and save any peaks found. 
C       RS ReSet the cell and matrix with the results from RC. 
C
C           *** Intensity Data Collection *** 
C
C       GO Start of intensity data collection. 
C       K  Kill operation at the end of the current reflection. 
C       Q  Quit after the next set of reference reflections.
C
C           *** Angle Setting and Intensity Measurement *** 
C
C       GS Grid Search measurement in 2theta, omega or chi. 
C       IE Intensity measurement for Equivalent reflections. 
C       IM Intensity Measurement of the reflection in the detector. 
C       IP Intensity measurement in Psi for empirical absorption. 
C       IR Intensity measurement for specified Reflections. 
C       LP Line Profile plot on the printer. 
C       SA Set All angles to specified values. 
C       SC Set    Chi to the specified value. 
C       SH SHutter open or close as a flip/flop. 
C       SO Set  Omega to the specified value. 
C       SP Set    Phi to the specified value. 
C       SR Set Reflection: h,k,l,psi. 
C       ST Set 2Theta to the specified value. 
C       TC Timed Counts. 
C       ZE ZEro the instrument Angles.
C
C           *** Photograph Setup Commands *** 
C
C       PL Photograph in the Laue mode. 
C       PO Photograph in the Oscillation mode (same as OS). 
C       PR Photograph in the Rotation mode.
C
C           *** General System Commands *** 
C       AH Angles to H,k,l (same as IX). 
C       AI Ascii Intensity data file conversion. 
C       AP Ascii Profile data file conversion. 
C       BC Big Chi search for psi rotation. 
C       BI Big Intensity search in the IDATA.DA file. 
C       EX EXit the program saving the basic data on IDATA.DA. 
C       HA H,k,l to Angles (same as RA). 
C       PA Print Angle settings. 
C       PD Print Data of all forms. 
C       Q  Quit the program directly. 
C       RB Read the Basic data from the IDATA.DA file. 
C       SW SWitch register flags setting. 
C       UM (UMpty) Count unique reflections within theta limits. 
C       WB Write the Basic data to the IDATA.DA file.
C
C  The program uses 2 main files:--
C   1. On unit IID the file IDATA.DA contains all the permanent 
C      information for a data collection:
C   2. ON unit ISD the file ORIENT.DA is really a scratch file for 
C      use with the crystal orientation routines
C
C  Both files are 'direct-access' with records of length 85 4-byte
C  variables.
C
C  The file IDATA.DA contains the following information:--
C      Record #            Information
C       1,2,3       All the basic info for a particular data collection;
C      4 to 8       All symmetry info from SGROUP;
C         9         Automatic restart info for use after interruption;
C     16 to 19      Alignment data for ALIGN;
C     20 and up     Intensity data, 10 reflns per record.
C
C  There is a 9-bit switch register which can be changed with the SW
C  command or during operation by typing any digit from 1 to 9.
C  The switches control the following :--
C
C   1.  0 normal screen display; 1 profile display. 
C   2.  0 display raw profile data; 1 display smoothed data.
C   3.  0 dont print profiles;   1 print profiles on printer.
C   4.  0 print intensity data;  1 do not print intensity data.
C   5.  0 print standards data;  1 do not print standards.
C   6.  0 no action; 1 add 20 points to profile tolerance.
C   7.  0 no action; 1 add 10 points to profile tolerance.
C   8.  0 no action; 1 add  5 points to profile tolerance.
C   9.  0 no action; 1 write profiles to unit 7.
C
C  Common to match the CREDUC Common /GEOM/
C-----------------------------------------------------------------------
      SUBROUTINE DIFINI
      INCLUDE 'COMDIF'
      COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
     $                IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
     $                VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
      COMMON /GEOM/   GJUNK(370)
      CALL INIDATA
      IDH(1,1,1) = 1
      IDH(1,2,2) = 1
      IDH(1,3,3) = 1
      NOTEND = 0
      IKO(5) = -777
      ALPHA = 50.0
C-----------------------------------------------------------------------
C  Get the I/O unit numbers with SETIOU
C-----------------------------------------------------------------------
      CALL SETIOU (IID,ISD,LPT,ITR,ITP,IBYLEN)
      CALL WNSET (3)
C-----------------------------------------------------------------------
C  Check that the angles did not change since the last time the
C  program was stopped.
C-----------------------------------------------------------------------
      CALL ANGVAL
      DFMODL = 'TRICS'
      DFTYPE = 'TRICS'
      WRITE (COUT,10000) DFMODL
      CALL GWRITE (ITP,' ')
      LPT = ITP
C-----------------------------------------------------------------------
C  Open the Idata file (IID) and the scratch file (ISD)
C  If either file does not exist, create it.
C-----------------------------------------------------------------------
      DO 100 I = 1,85
        ACOUNT(I) = 0.0
  100 CONTINUE
      IDREC = 85*IBYLEN
      STATUS = 'OD'
      IDNAME = 'IDATA.DA'
      LENID = 700
      CALL IBMFIL (IDNAME,IID,IDREC,STATUS,IERR)
      IF (IERR .NE. 0) THEN
        STATUS = 'DN'
        CALL IBMFIL (IDNAME,IID,IDREC,STATUS,IERR)
        KI = 'W2'
        CALL WRBAS
        KI = ' '
        DO 110 I = 4,20
          WRITE (IID,REC=I) (NOTEND,J = 1,85)
  110   CONTINUE
        STATUS = 'DO'
        CALL IBMFIL (IDNAME,-IID,IDREC,STATUS,IERR)
        CALL IBMFIL (IDNAME, IID,IDREC,STATUS,IERR)
      ELSE
        KI = 'AN'
        CALL WRBAS
      ENDIF
      STATUS = 'OD'
      DSNAME = 'ORIENT.DA'
      LENSD = 300
      CALL IBMFIL (DSNAME,ISD,IDREC,STATUS,IERR)
      IF (IERR .NE. 0) THEN
        WRITE (COUT,11000) DSNAME(1:9)
        CALL GWRITE (ITP,' ')
        STATUS = 'DN'
        CALL IBMFIL (DSNAME,ISD,IDREC,STATUS,IERR)
        DO 120 I = 1,300
          WRITE (ISD,REC=I) (NOTEND,J = 1,85)
  120   CONTINUE
        STATUS = 'OD'
        CALL IBMFIL (DSNAME,-ISD,IDREC,STATUS,IERR)
        CALL IBMFIL (DSNAME, ISD,IDREC,STATUS,IERR)
      ENDIF
10000 FORMAT (/,10X,'Diffractometer Routine for TRICS ',A /)
11000 FORMAT (' There is no file ',A,'.  It will be created.')
      RETURN
      END
C----------------------------------------------------------------------
      SUBROUTINE WNSET(I)
      INTEGER I
      RETURN
      END
C----------------------------------------------------------------------
      SUBROUTINE WNEND
      RETURN
      END
C-----------------------------------------------------------------------
C  Block Data routine to initialize the COMMONs
C-----------------------------------------------------------------------
      SUBROUTINE INIDATA
      INCLUDE 'COMDIF'
      DATA ISCDEF,ICDDEF/150,250/,IDTDEF,IDODEF,IDCDEF/4,2,10/,
     $     IFRDEF/100/,NRC/-1/,STEPDG/100.0/,ICADSL/60/,NATTEN/0/,
     $     ATTEN/1.0,1.88,3.54,6.66,12.52,170.4/
      DATA KQFLG2/0/,IUPDWN/1/,IUMPTY/0/,IAUTO,NSET/0,1/,SGSYMB/10*0.0/,
     $     DEG/57.2958/
      DATA R/0.070932,0,0, 0,0.070932,0, 0,0,0.070932/, 
     $     DTHETA,DOMEGA,DCHI/0.,0.,0./,NAXIS/2/,
     $     THEMIN,THEMAX/2.0,100.0/, AS,BS,CS/1.0,0.7,1.0/,
     $     DPSI,PSIMIN,PSIMAX/3*0.0/, 
     $     TIME,QTIME,TMAX/1000,1000,100000/,
     $     PA,PM/2*1.0/, IHMAX,IKMAX,ILMAX/3*22/, WAVE/0.70932/, 
     $     NCOND/0/,ICOND,IHS,IKS,ILS,IR,IS/30*0/,
     $     SPEED/4.0/, STEPOF/0.5/, IORNT/0/,NINTOR/0/
      DATA NSTAN/1/,NINTRR/100/,IHSTAN,IKSTAN,ILSTAN/4,17*0/,ISTAN/0/,
     $     NSEG/1/,NMSEG/1/,NMSTAN/1/, NREF/0/, NBLOCK/20/,
     $     IHO,IKO,ILO/24*0/, IND/3*0/, ITYPE/0/, JMIN,JMAX/16*0/, 
     $     AP/3*10.0/,APS/3*0.1/,
     $     CANGS/3*0.0/,SANGS/3*1.0/,CANG/3*0.0/,SANG/3*1.0/,
     $     RTHETA,ROMEGA,RCHI,RPHI/4*0.0/, IH,IK,IL/1,2,3/
      DATA IDH/72*0/, IBSECT,ISCAN/2*0/, FRAC/0.1/, IPRFLG/0/,
     $     ISYS/1/, SINABS/3*0.00503135,3*0.0/, ILN/0/, DELAY/100/
      DATA COUT/20*' '/,IWNCUR/0/,ISREG/1,1,1,0,0,0,0,0,1,0/
      DATA STEP/0.02/,PRESET/15000./DPHI/0./
      RETURN
      END