C
C==== GENERAL Module of DIFRAC by H.D. Flack, University of Geneva
C==== Version 24th March 1997
C
      program difrac
C----------------------------------------------------------------------C
C**** Convert single-crystal diffractometer  output into a CIF         C
C       - Crystallographic Information file.                           C
C----------------------------------------------------------------------C
C00000000111111111122222222223333333333444444444455555555556666666666777
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      integer jj
C
      include 'common.for'
C
      write(*,
     1 '(/,'' Welcome to DIFRAC by H.D.Flack.'',
     2 '' This is the version of 24th March 1997.''/
     3 '' Information by:''/ ''   WWW at '',
     4 ''ftp://ftp.unige.ch/pub/soft/crystal/difrac/difrac.html''/
     5 ''   anon-ftp at '',
     6 ''ftp://ftp.unige.ch/pub/soft/crystal/difrac/README.1ST''//)')
C
C---- Set type of Output
C
      call set
C
C---- Choose fixed diffractometer parameters
C
      call choos
C
C---- Enquiry of compid and check data file existence
C
      call compnm
C
C---- Read the parameter file
C
      call prflrd
C
C---- Loop over the individual data collection files
C
      do 9005 jj = sdtfil, ndtfil
        call dtflrd(jj)
 9005 continue
C
C---- Interactive question and answer section for data values
C
      call quesan
C
C---- Output the basic non-intensity information
C
      call basout
C
C---- Close the Output file
C
      close(unit=scfsfl, status='KEEP')
C
      write(*,
     1'(/'' Goodbye and thank you for using DIFRAC by H.D.Flack''/)')
      end
C
      subroutine compnm
C
C---- Get compound id and check for data file existence
C
      integer trim
      integer  i, j, n
      logical  zresnt, valid, lansw
C
      include 'common.for'
C
C---- Get the COMPOUND ID
C
 100  valid = .false.
      compid = ' '
      write(*,'('' Give the Compound ID - max 6 characters:'')')
      call fread(0,'CNNNNNNNNN')
      compid = charin(1)(1:6)
C---- Set up DSK
      dsk = compid(1:4)
C
C---- Make sure there are data files of this name
C
      write(*,'(/'' Data files for compound: '',A6)') compid
C---- Try a <compid> data  file first
      inquire(file= compid(1:trim(compid))//datxtn, exist = zresnt)
      if (zresnt) then
C---- One data file of name <compid>//datxtn
        valid = .true.
        write(*,'(''   File: '',A)') compid(1:trim(compid))//datxtn
        sdtfil = 0
        ndtfil = 0
      else
        sdtfil = 1
        ndtfil = 0
      endif
 200  i = (ndtfil+1)/10
      j = mod((ndtfil+1), 10)
      inquire(file= compid(1:trim(compid))//datxto(1:trim(datxto))
     1  //digit(i)//digit(j), exist = zresnt)
      if (zresnt) then
        ndtfil = ndtfil + 1
        valid = .true.
        write(*,'(''   File: '',A)') compid(1:trim(compid))
     1    //datxto(1:trim(datxto))//digit(i)//digit(j)
      endif
      if (zresnt) go to 200
      if (.not. valid) then
        write(*,'(''   There are no data files for this name.'')')
        write(*,'(''   Y to reinput compound ID, N to stop (Y,N)? '')')
        call fread(0,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'N') stop ' '
      endif
      if (.not. valid) go to 100
C
C---- Open the Output File
C
      open( unit=scfsfl, file = compid(1:trim(compid))//extn,
     1 status = 'UNKNOWN', access = 'SEQUENTIAL', form = 'FORMATTED'
     2 )
CVMS 2 ,carriagecontrol='LIST')
CUNX 2 )
C
C---- Set up option to go high speed through the saved answers
C
      hspeed = .false.
      write(*, '(//'' Is ancilliary data to be entered without'',
     1 '' user interaction (Y,N)? '')')
      call fread(0,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'Y') hspeed = .true.
C
C---- File control for saved answers.
C
C---- Is either a compound specific or a general saved answer file there
      inquire(file= compid(1:trim(compid))//'.qan', exist = lquan)
      lansw=.false.
      if (.not.lquan) then
        inquire(file= 'answer.sty', exist = lansw)
        if (lansw) lquan=.true.
      endif
      if (lquan) then
C---- Copy existing saved answer file to <compid>.qao
        open( unit=qaofl, file = compid(1:trim(compid))//'.qao',
     1  status = 'UNKNOWN', access = 'SEQUENTIAL', form = 'FORMATTED'
     2 )
CVMS 2  ,carriagecontrol='LIST')
CUNX 2 )
        if (lansw) then
          open( unit=qanfl, file = 'answer.sty',
     1    status = 'OLD', access = 'SEQUENTIAL', form = 'FORMATTED'
     2    )
CVMS 2    ,readonly)
CUNX 2    )
        else
          open( unit=qanfl, file = compid(1:trim(compid))//'.qan',
     1    status = 'OLD', access = 'SEQUENTIAL', form = 'FORMATTED'
     2    )
CVMS 2    ,readonly)
CUNX 2    )
        endif
        do 210 i=1,10000
          read (qanfl,'(i6,a80)', end=220) n, qline
          write(qaofl,'(i6,a)') n, qline(1:trim(qline))
 210    continue 
 220    rewind  qaofl
        nqaocd = -1
        close(qanfl, status='KEEP')
      endif
C---- Open the new saved answer file
      open( unit=qanfl, file = compid(1:trim(compid))//'.qan',
     1 status = 'UNKNOWN', access = 'SEQUENTIAL', form = 'FORMATTED'
     2 )
CVMS 2 ,carriagecontrol='LIST')
CUNX 2 )
C
C---- Get the TITLE
C
      if (ask(4)) then
        write(*,'(//'' Give a title - max 66 characters:'')')
        call fread(000020,'LNNNNNNNNN')
        title = line(1:66)
      endif
      return
      end
C
      subroutine quesan
C----------------------------------------------------------------------C
C     Question and answer subroutine for interactive input of          C
C     diffractometer information.  The sections of the questions which C
C     are asked in the interactive session are controlled by the       C
C     Boolean array Ask.  The values in Ask are set up in SET and      C
C     CHOOS, so the questions are tailored to the information availableC
C     (or not) from the diffractometer and for the output SCFS or      C
C     another.                                                         C
C                                                                      C
C     Ask(2)    Cell dimensions of crystal.  Not needed by Nicolet     C
C     Ask(3)    Deadtime. May not be needed by CAD4 5.0                C
C     Ask(4)    TITLE.  Not needed by Nicolet or Stoe                  C
C     Ask(6)    Attenuator filter values. Only need to enquire if      C
C               filters have really been used during the data          C
C               collection and the attenuator coefficients not found   C
C               in the files.                                          C
C     Ask(7)    Monochromator angle for polarization calculation       C
C                                                                      C
C----------------------------------------------------------------------C
C
      integer i, k
      logical oka
      integer trim
C
      include 'common.for'
C
C---- Input of cell dimensions
C
      if (ask(2)) then
 2005   write(*,'(//
     1  '' ***** Input of the cell dimensions of the crystal'')')
        write(*,'(
     1  '' Do you have refined cell dimension data (Y,N)? '')')
        call fread(010020,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'N') then
          do 2011 i = 1, 6
            cell(i) = cellub(i)
            ecell(i) = 0.01*cell(i)
 2011     continue
          volum = volub
          evolum = 0.03*volum
          write(*,'('' No refined cell dimension data available.'')')
          write(*,'(//'' Cell dimensions from ub matrix:''/12x,''a(A)'',
     1    7x,''b(A)'',7x,''c(A)'',3x,''alpha(d)'',4x,''beta(d)'',3x,
     2    ''gamma(d)''/5x,6f11.2,//7x,''volume'',f8.0,'' A^3^'')') 
     3    cellub, volub
        endif
        if (inchar .eq. 'N') go to 2033
        if (inchar .ne. 'Y') go to 2005
C---- Read the cell dimensions
        write(*,'('' Enter a, b, c, alpha, beta, gamma '',
     1  ''in Angstroms and degrees:'')')
        call fread(010040,'RRRRRRNNNN')
        do 2020 i = 1, 6
 2020   cell(i) = realin(i)
        write(*,
     1  '('' Enter s.u.s in a, b, c, alpha, beta, gamma:'')')
        call fread(010060,'RRRRRRNNNN')
        do 2025 i = 1, 6
 2025   ecell(i) = realin(i)
        write(*,
     1  '('' Enter cell volume and s.u. in cubic Angstroms:'')')
        call fread(010080,'RRNNNNNNNN')
        volum = realin(1)
        evolum = realin(2)
        write(*,
     1  '('' How were these cell dimensions measured?  Enter''/
     2  '' wavelength(A), temperature(K), 2theta-min(d), '',
     3  ''2theta-max(d), number of reflections:'')')
        call fread(010100,'RRRRINNNNN')
        cwave = realin(1)
        ctemp = realin(2)
        ctthn = realin(3)
        ctthx = realin(4)
        nmcell = intin(5)
        write(*,
     1    '('' Enter the name of the cell refinement software:'')')
        call fread(010110,'BNNNNNNNNN')
        cellpg=line(1:40)
C---- End of cell dimension input
        write(*,'(//'' Cell dimension information:''/12x,''a(A)'',
     1  7x,''b(A)'',7x,''c(A)'',3x,''alpha(d)'',4x,''beta(d)'',3x,
     2  ''gamma(d)''/'' cell'',6f11.4/''   su'',6f11.4//7x,
     3  ''volume(A^3^)'',5x,'' su(A^3^)''/5x,2f12.2//5x,''wavel(A)'',
     4  4x,''temp(K)'',3x,''2Tmin(d)'',3x,''2Tmax(d)'',7x,''Nref''
     5  /5x,f8.5,3f11.1,i11//'' Software: '',a)')
     6  cell, ecell, volum, evolum, cwave, ctemp, ctthn, ctthx,
     7  nmcell,cellpg
        oka = .true.
        do 2032 i = 1 , 3
          if(abs(cell(i)-cellub(i)).gt.0.2) oka = .false.
          if(abs(cell(i+3)-cellub(i+3)).gt.2.0) oka = .false.
 2032   continue
        if(.not. oka) then
          write(*,'(/'' ***** Error: Input cell dimensions are too '',
     1    ''different from those calculated ''/13x,''from ub matrix:''
     2    /12x,''a'',7x,''b'',7x,''c'',3x,''alpha'',4x,''beta'',3x,
     3    ''gamma''/'' cell'',6f8.2)') cellub
          go to 2005
        endif
 2033   write(*,'(//'' Cell dimension data OK (Y,N)? '')')
        call fread(010120,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .ne. 'Y') go to 2005
      endif
C
C---- Input of Density Measurement
C
 2035 write(*,'(//
     1  '' ***** Density measurement information'')')
      write(*,'('' Have you measured the density (Y/N)?'')')
      mdensi = .false.
      call fread(050020,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'Y') then
        write(*,
     1    '('' Enter the method used to measure the density:'')')
        call fread(050030,'BNNNNNNNNN')
        denmet=line(1:40)
        write(*,'('' Enter density with s.u.(Mg.m^-3^) and '',
     1    ''temperature(K) of measurement:'')')
        call fread(050040,'RRRNNNNNNN')
        densit = realin(1)
        edensi = realin(2)
        tdensi = realin(3)
        mdensi = .true.
      elseif (inchar .ne. 'N') then
        go to  2035
      endif
C---- End of density input
 2040 if (mdensi) then
        write(*,'(/9x,''dobs'',5x,'' su'',11x,''temp(K)''/
     1  5x,2f8.3,'' Mg.m^-3^'',f8.1/5x,2f8.0,'' Kg.m^-3^'',
     2 //'' Density measurement method:''/10x,a)') 
     3  densit, edensi, tdensi, 1.E3*densit,1.E3*edensi, denmet
      else
        write(*,'('' No density measurements'')')
      endif
      write(*,'(//'' Density data OK (Y,N)? '')')
      call fread(050060,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2035
      if (inchar .ne. 'Y') go to 2040
C
C**** Input the physical dimensions of the crystal (faces or sphere)
C
 2105 write(*,'(//
     1  '' ***** Input of the physical dimensions of the crystal'')')
      write(*,'(''    N means no measurements of crystal shape '')')
      write(*,'(''    S means crystal is spherical in shape '')')
      write(*,'(''    F means indexed polyhedral shape '')')
      write(*,'(''    M means max, mid, min dimensions '')')
      write(*,'('' Make a choice for the shape of the crystal: '')')
      call fread(100020,'XNNNNNNNNN')
      crytyp = charin(1)(1:1)
      if (crytyp .eq. 'N') then
C---- No crystal shape measurements
        crytyp = 'N'
        write(*,'(//'' Physical dimensions of crystal not measured.'')')
      elseif (crytyp .eq. 'S') then
C---- Spherical shape
        crytyp = 'S'
        write(*,'('' Give sphere radius and s.u. in mm:'')')
        call fread(100040,'RRNNNNNNNN')
        dface(1)  = realin(1)
        deface(1) = realin(2)
        write(*,'(//'' Sphere radius '',f6.3,''mm.     s.u. '',
     1  f6.3,''mm'')') dface(1), deface(1)
      elseif (crytyp .eq. 'M') then
C---- Max, Mid, Min dimensions
        crytyp = 'M'
        write(*,
     1  '('' Give maximum, medial and minimum dimensions in mm:'')')
        call fread(100050,'RRRNNNNNNN')
        sizem(1)  = realin(1)
        sizem(2)  = realin(2)
        sizem(3)  = realin(3)
        write(*,'(//'' Crystal Dimensions in mm:'',
     1  /,10x,''Maximum: '', f6.3,
     2  /,10x,''Medial:  '', f6.3,
     3  /,10x,''Mimimum: '', f6.3)') sizem(1), sizem(2), sizem(3)
      elseif (crytyp .eq. 'F') then
C---- Polyhedral shape
        crytyp = 'F'
 2125   write(*,
     1    '('' How many indexed faces does the crystal have? '')')
        call fread(100055,'INNNNNNNNN')
        if (intin(1) .le. 0) go to 2125
        nface = intin(1)
        write(*,
     1  '('' Input one face per line: h, k, l, d,  su(d) in mm. '')')
        do 2130 i = 1, nface
          call fread(100060,'IIIRRNNNNN')
          hface(i) = intin(1)
          kface(i) = intin(2)
          lface(i) = intin(3)
          dface(i) = realin(4)
          deface(i) = realin(5)
 2130   continue
        write (*,'(//'' Crystal faces:''/
     1  ''  Num   h   k   l    d(mm)   su(mm)'')')
        write (*,'(1x,4i4,2f9.3)')
     1  (i, hface(i),kface(i),lface(i),dface(i),deface(i),i=1,nface)
      else
C---- Wrong input
        go to 2105
      endif
 2190 write(*,'(//'' Crystal shape OK (Y,N)? '')')
      call fread(100080,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2105
      if (inchar .ne. 'Y') go to 2190
C
C---- Chemical formula
C
 2205 write(*,'(//
     1 '' ***** Input of the chemical formula information'')')
      natmtp = 0
      do 2215 i = 1, 24
        peratm(i) = 0.0
        eperat(i) = 0.0
 2215 continue
      do 2210 i = 1, 5
 2210 lform(i) = .false.
C---- Z
      write(*,'('' Enter Z, the number of formula units per cell:'')')
      call fread(150020,'INNNNNNNNNN')
      zcell = intin(1)
C---- Assumed formula
      write(*,'('' Enter chemical formula  '',/,
     1'' all numbers are interpreted as subscripts.'',
     2'' separate element symbols (with ''/'' their coefficients '',
     3''and parentheses) from each other by a blank. '',/,
     4'' e.g.: (C6 H5) C H3  or  (C5 H5) Fe (C O)2  :'',/,
     5'' maximum 2 lines of 70 chars each, '',
     6''end each line with <CR> : '')')
      call fread(150040,'LNNNNNNNNN')
      chemfm(1:70)=line(1:70)
      call fread(150060,'BNNNNNNNNN')
      chemfm(71:140)=line(1:70)
C---- Convert formula to tabular sum form
      call chform
      if (natmtp .le. 0) then
        if (natmtp.eq.0)  write(*,'('' No known elements in formula'')')
        if (natmtp.eq.-1) write(*,'('' Position error in formula'')')
        if (natmtp.eq.-2) write(*,'('' Wrong special character  '')')
        if (natmtp.eq.-3) write(*,'('' Unknown element symbol   '')')
        if (natmtp.eq.-4) write(*,'('' Unbalanced parentheses   '')')
        if (natmtp.eq.-5) write(*,'('' Conversion error         '')')
        if (natmtp.eq.-6) write(*,'('' Overflow                 '')')
        go to 2205
      endif
C---- Chemical analysis
 2225 write(*,'('' Do you have a chemical analysis (Y/N)? '')')
      call fread(150080,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'Y') then
        lform(1) = .true.
        write(*,'('' Enter observed mass % of each'',
     1  '' element after the element symbol as:''/
     2  '' observed % composition, s.u.:'')')
        do 2240 i = 1, natmtp
          write(*,'('' Mass % and su of '',a2,'' : '')') namtyp(i)
          call fread(150100,'RRNNNNNNNN')
          peratm(i) = realin(1)
          eperat(i) = realin(2)
 2240   continue
      elseif (inchar .ne. 'N') then
        go to 2225
      endif
C---- Formula weight
 2250 write(*,'('' Do you have an observed value of the formula '',
     1 '' mass (Y/N)? '')')
      call fread(150120,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'Y') then
        lform(2) = .true.
        write(*,'(
     1  '' Enter observed formula mass and s.u.(Daltons):'')')
        call fread(150140,'RRNNNNNNNN')
        forwg  = realin(1)
        eforwg = realin(2)
      elseif (inchar .ne. 'N') then
        go to 2250
      endif
C---- End of chemical formula
 2290 write(*,'(//'' Formula information:'',20x,
     1 ''Z number of formula units per cell '',i4//
     2 '' Chemical formula'',/,3x,a70,/,3x,a70,//
     3 5x,''el'',5x,''num'',3x,''mass%'',5x,'' su''/
     4 (5x,a2,f8.3,2f8.2))')
     5 zcell, chemfm(1:70),chemfm(71:140),
     6 (namtyp(i),fnamtp(i),peratm(i),eperat(i), i = 1 ,natmtp)
      if (lform(2)) write(*,'(//'' Formula weight &  su:'',2f10.3)')
     1 forwg, eforwg
      write(*,'(//'' Chemical formula data OK (Y,N)? '')')
      call fread(150160,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2205
      if (inchar .ne. 'Y') go to 2290
C
C---- Input of chemical compound information
C
 2750 write(*,'(//
     1  '' ***** Chemical compound information'')')
      write(*,'('' Enter the melting-point temperature of '',
     1  ''the compound in K:'')')
      call fread(200020,'RNNNNNNNNN')
      mptemp=realin(1)
      write(*,'('' Enter a description of the source of the '',
     1  ''chemical compound under study.''/
     2  '' If not known leave blank:'')')
      call fread(200040,'BNNNNNNNNN')
      cpdsou=line(1:76)
      write(*,'('' Enter the trivial name of the compound.'',
     1  '' If not known leave blank:'')')
      call fread(200060,'BNNNNNNNNN')
      namecm=line(1:76)
      write(*,'('' Enter the mineral name of the compound'',
     1  '' (if any - otherwise leave blank):'')')
      call fread(200080,'BNNNNNNNNN')
      nameml=line(1:76)
C---- End of name input
 2755 write(*,'(/9x,''Melting-point temperature:'',5x,f8.2,'' K'')')
     1 mptemp
      write(*,'( 9x,''Source of compound:''/1x,a76)') cpdsou
      write(*,'( 9x,''Trivial name of compound:''/1x,a76)') namecm
      write(*,'( 9x,''Mineral name of compound:''/1x,a76)') nameml
      write(*,'(//'' Chemical compound data OK (Y,N)? '')')
      call fread(200100,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2750
      if (inchar .ne. 'Y') go to 2755
C
C---- Input of crystal and crystal-related information
C
 2760 write(*,'(//
     1  '' ***** Crystal information'')')
      write(*,'(
     1 '' The colour of the crystal should be made from 3 attributes'',
     2 '' in the order:''/''   Appearance:''/8X, 
     3 '' metallic, lustrous, translucent, fluorescent, clear.''/ 
     4 ''   Intensity:''/8X,'' dark, light, intense, pale''/
     5 ''   Base colour:''/8X,'' white, black, blue, violet, red,'',
     6 '' pink, yellow, gold, silver,''/8X,'' bronze, grey, orange,'',
     7 '' green, colourless, brown, purple.''/'' Only base-colour is'',
     8 '' mandatory.'',
     9 '' Colour codes made from two colours are allowed.'')')
      write(*,'(/'' Enter the colour of the crystal:'')')
      call fread(250020,'BNNNNNNNNN')
      cryscl=line(1:40)
      write(*,'('' Give details of crystal growth and preparation:'')')
      call fread(250030,'BNNNNNNNNN')
      excrpr=line(1:40)
      write(*,'('' Enter a description of the crystal '',
     1  ''quality and habit if known, otherwise blank:'')')
      call fread(250040,'BNNNNNNNNN')
      crysds=line(1:76)
C---- End of crystal input
 2765 write(*,'(/9x,''Crystal colour:'',5x,a40)') cryscl
      write(*,'( 9x,''Crystal growth and preparation:  '',a)') excrpr
      write(*,'( 9x,''Quality and habit of crystal:''/1x,a76)') crysds
      write(*,'(//'' Crystal data OK (Y,N)? '')')
      call fread(250080,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2760
      if (inchar .ne. 'Y') go to 2765
C
C---- Diffractometer attenuator information
C
C---- Have filters been used for which transmission factors 
C     were not given?
      ask(6) = .false.
      do 2410 i = 1, nfilt
        if (attfac(i) .lt. 1.0) ask(6) = .true.
 2410 continue
C---- Reciprocal attenuation factors and s.u.'s
      if (ask(6)) then
 2305   write(*,'(//
     1   '' ***** Attenuator filter information''/
     2   ''   Enter attenuation factors for the filter index numbers '',
     3   ''indicated as:'',/
     4   ''   Reciprocal attenuation factor (>1.0) and its s.u.'')')
        do 2321 i = 2, nfilt
 2320     write(*,'('' Filter index '',i3,'':'')') nfltcd(i)
          call fread(300020,'RRNNNNNNNN')
	  if(realin(1) .ge. 1.0) then
            attfac(i) = realin(1)
            ettfac(i) = realin(2)
          else
            Write(*,'('' Reciprocal attenuation factor should be '',
     1        '' greater than 1.0.  Reinput last entry.'')')
            go to 2320
          endif
 2321   continue
C---- End of diffractometer attenuator information
 2325   write(*,'(//'' Diffractometer attenuator information:'',//,
     2   '' attenuators: code'',4x,''factor'',4x,''  s.u.''/
     3   (13x,i5,2f10.6))')
     5   (nfltcd(i), attfac(i), ettfac(i), i = 1, nfilt)
        write(*,'(//'' Diffractometer attenuator data OK (Y,N)? '')')
        call fread(300040,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'N') go to 2305
        if (inchar .ne. 'Y') go to 2325
      endif
C
C---- Diffractometer operating conditions
C
 2326 write(*,'(//
     1    '' ***** Diffractometer X-ray source information'')')
      write(*,'(/'' Enter the current (mA) and  voltage (kV)'',
     1 '' of operation of the X-ray source:'')')
      call fread(310020,'RRNNNNNNNN')
      tubcur=realin(1)
      tubvol=realin(2)
      write(*,'(/'' Enter, as a descriptive text, the size of '',
     1 ''the source as viewed from the sample:'')')
      call fread(310040,'BNNNNNNNNN')
      tubciz=line(1:40)
C---- End of crystal input
 2327 write(*,'(/9x,''Operating conditions:  '',i2,'' mA  '',i2,
     1 '' kV'')') nint(tubcur), nint(tubvol)
      write(*,'( 9x,''Source size:  '',a40)') tubciz
      write(*,'(//'' Operating conditons OK (Y,N)? '')')
      call fread(310060,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2326
      if (inchar .ne. 'Y') go to 2327
C
C---- Diffractometer monochromator information
C
C---- Beta-filter or monochromator information
 2330 continue
      if (ask(7)) then
        write(*,'(//
     1    '' ***** Monochromator information'')')
        write(*,'(
     1    '' Did you use a beta-filter(B), monochromator(M)'',
     2    ''  or none (B,M,N)? '')')
        call fread(350020,'XNNNNNNNNN')
        monoch = charin(1)(1:1)
      else
        monoch = 'M'
      endif
      if (monoch .eq. 'M') then
C---- Monochromator
C---- Polarization ratio
 2340   write(*,'('' Have you a measured value of the '',
     1  ''monochromator polarization ratio or fraction(Y,N)? '')')
        call fread(350040,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'Y') then
C---- Measured values of polarization ratio or fraction
          write(*,'('' Polarisation Ratio or Fraction(R,F)? '')')
          call fread(350050,'XNNNNNNNNN')
          knchar = charin(1)(1:1)
          if (knchar .eq. 'R') then
            write(*,'('' Give polarization ratio and s.u.:'')')
            call fread(350060,'RRNNNNNNNN')
            ratpol = realin(1)
            ertpol = realin(2)
            frapol = 1.0/(1.0+ratpol)
            if (abs(abs(fmnhed)-90.).le.2.0) frapol = 1.0 - frapol
            erapol = ertpol/(1.0+ratpol)**2
            fmn2th = rad*acos(sqrt(abs(ratpol)))
            cmix = 0.0
          elseif (knchar .eq. 'F') then
            write(*,'('' Give polarization fraction and s.u.:'')')
            call fread(350070,'RRNNNNNNNN')
            frapol = realin(1)
            erapol = realin(2)
            if (abs(abs(fmnhed)-90.).le.2.0) frapol = 1.0 - frapol
            ratpol = (1.0-frapol)/frapol
            ertpol = erapol/(1.0-frapol)**2
            frapol = realin(1)
            erapol = realin(2)
            fmn2th = rad*acos(sqrt(abs(ratpol)))
            cmix = 0.0
          else
            go to 2340
          endif
        elseif (inchar .eq. 'N') then
C---- Values chosen by the programmme
C---- 2-theta value
          if (ask(7)) then
            write(*,'(
     1        '' Give monochromator 2-theta angle in degrees:'')')
            call fread (350080,'RNNNNNNNNN')
            fmn2th = realin(1)
          endif
          cmn2th = abs(cos(dar*fmn2th))
          cmix = 0.5
C---- Give an estimate based on c(mixing of K's) = 0.5 with s.u.(c) .2
          ratpol = cmix*cmn2th*cmn2th + cmix*cmn2th
          ertpol = 0.2*(cmn2th - cmn2th*cmn2th)
          frapol = 1.0/(1.0+ratpol)
          if (abs(abs(fmnhed)-90.).le.2.0) frapol = 1.0 - frapol
          erapol = ertpol/(1.0+ratpol)**2
        else
C---- Wrong input
          go to 2340
        endif
 2350   write(*,'('' Have you a measured value of the monochromator'',
     1  '' inhomogeneity half-width (Y,N)? '')')
        call fread(350100,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'Y') then
C---- Measured values of inhomogeneity half-width
          write(*,'('' Give inhomogeneity half-width(mm):'')')
          call fread(350120,'RNNNNNNNNN')
          fmhomw = realin(1)
        elseif (inchar .eq. 'N') then
          fmhomw = 0.0
        else
          go to 2350
        endif
      elseif (monoch .eq. 'B') then
C----- Beta-filter
        write(*,'('' Give beta-filter absorption edge wavelength(A):''
     1  )')
        call fread (350140,'RNNNNNNNNN')
        bedwv = realin(1)
        ratpol = 1.0
        ertpol = 0.0
        frapol = 0.5
        erapol = 0.0
        fmn2th = 0.0
        cmix = 0.0
      elseif (monoch .eq. 'N') then
C--- White radiation
        ratpol = 1.0
        ertpol = 0.0
        frapol = 0.5
        erapol = 0.0
        fmn2th = 0.0
        cmix   = 0.0
        mondes = 'none'
      else
C---- Wrong input
        go to 2330
      endif
      if (monoch .ne. 'N') then
        write(*,'('' Give a text description of the method used to '',
     1   ''obtain the monochromatic radiation''/'' (e.g. Zr filter '',
     2   ''or Graphite 200):'')')
        call fread(350150,'BNNNNNNNNN')
        mondes=line(1:40)
      endif
C---- End of diffractometer monochromator information
 2390 write(*,'(//'' Diffractometer monochromator information:'',//,
     1 '' Polarization:'',4x,''Ratio'',6x,'' su'',4x,
     2 ''Fraction'',5x,'' su'',/,13X,4f10.4,
     3 //2x,''dihed(d)'',4x,''width(mm)'',8X,''abs.e(A)'', 
     4 /,f10.1,f10.3,7x,a1,f10.5//'' Description: '',a)')
     5 ratpol, ertpol, frapol, erapol,
     6 fmnhed, fmhomw, monoch, bedwv, mondes
      write(*,'(//'' Diffractometer monochromator data OK (Y,N)? '')')
      call fread(350160,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2330
      if (inchar .ne. 'Y') go to 2390
C
C---- Counter dead time information
C
      if (ask(3)) then
 2405   write(*,'(//
     1  '' ***** Input of counter dead time information'')')
 2460   write(*,'('' Have you a measured value of the counter'',
     1  '' dead time (Y,N)? '')')
        call fread(400020,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'Y') then
C---- Measured values of counter dead-time and  su
          write(*,'('' Give measured dead-time and '',
     1    ''s.u. in microsecs:'')')
          call fread(400040,'RRNNNNNNNN')
          fdeadt = realin(1)
          efdead = realin(2)
        elseif (inchar .eq. 'N') then
          fdeadt = 0.0
          efdead = 0.0
        else
          go to 2460
        endif
C---- End of counter dead time information
 2490   write(*,'(//'' Diffractometer dead time information:'',//,
     1  5x,''Dead T'',7x,'' su (musecs)''/1x,2f10.2)') fdeadt, efdead
        write(*,'(//'' Counter dead time data OK (Y,N)? '')')
        call fread(400060,'XNNNNNNNNN')
        inchar = charin(1)(1:1)
        if (inchar .eq. 'N') go to 2405
        if (inchar .ne. 'Y') go to 2490
      endif
C
C---- Environmental and Measurement Conditions information
C
 2470 write(*,'(//
     1 '' ***** Input of Environmental and measurement conditions'')')
      write(*,'('' Enter temperature (k) and pressure (kPa) during '',
     1  ''intensity measurement:'')')
      call fread(450020,'RRNNNNNNNN')
      temint = realin(1)
      presnt = realin(2)
 2472 write(*,'('' Was air the fluid surrounding the crystal'',
     1 '' (Y,N)? '')')
      call fread(450028,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'Y') then
        envl = .false.
      elseif (inchar .eq. 'N') then
C---- Input the environment
        write(*,'('' Describe the gas or liquid surrounding '',
     1   ''the crystal:'')')
        call fread(450035,'BNNNNNNNNN')
        envamb=line(1:40)
        envl = .true.
      else
        go to 2472
      endif
      write(*,'('' Describe the physical device used to support the '',
     1 ''crystal during data''/'' collection. (e.g. glass capillary '',
     2 ''/ fibre / quartz capillary):'')')
      call fread(450036,'BNNNNNNNNN')
      spmnpt=line(1:40)
      write(*,'('' Describe any treatment of the crystal prior to '',
     1 ''intensity measurement.''/'' Useful for low temperature '',
     2 ''measurements - otherwise leave blank:'')')
      call fread(450038,'BNNNNNNNNN')
      dicrtr=line(1:40)
      write(*,'('' Describe any special aspects of the diffraction '',
     1 ''measurement process''/'' (e.g. instability, crystal '',
     2 ''motion, degradation) - otherwise leave blank:'')')
      call fread(450039,'BNNNNNNNNN')
      meadet=line(1:76)
C---- End of environmental conditions information
 2475 write(*,'(//'' Environmental conditions information:'',//,
     1 ''    Temperature           Pressure'',
     2 /1x,f14.3,'' K'', f16.1, '' KPa'',/,17X,f16.3,'' bar or atm'',
     3 /17X,f16.5,'' GPa'')')
     4 temint, presnt, presnt*.01,presnt*1.0E-6
      if (envl) 
     1 write(*,'('' Surrounding fluid:  '',a)') envamb
      write(*,'('' Device support:  '',a)') spmnpt
      write(*,'('' Crystal treatment:  '',a)') dicrtr
      write(*,'('' Measurement details:  '',a)') meadet
      write(*,'(//'' Environmental conditions data OK (Y,N)? '')')
      call fread(450040,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2470
      if (inchar .ne. 'Y') go to 2475
C
C---- Input of diffractometer operator's name, address etc
C
      open( unit=addrfl, file = addnam(1:trim(addnam)),
     1 status = 'OLD', access = 'SEQUENTIAL', form = 'FORMATTED'
     2 )
CVMS 2 ,readonly)
CUNX 2 )
 2710 WRITE(*,'(//
     1  '' ***** Personal information'')')
C---- Loop over names only
      rewind (addrfl)
      do 2718 i = 1, 200
        read(addrfl,'(A30)', end = 2719) line(1:30)
        write(*,'('' Name '',i2,'': '',a30)') i, line(1:30)
        do 2717 k = 1, 9
          read(addrfl,'(a1)', end = 2719)line(1:1)
 2717   continue
 2718 continue
 2719 continue
      Write(*,'('' name  0: not in list - enter manually''/
     1'' Enter the number of your name in the list:'')')
      call fread(500020,'INNNNNNNNN')
      if (intin(1).gt.0) then
C---- Fetch requested name and address
        rewind (addrfl)
        do 2727 k = 1, 10*(intin(1)-1)
          read(addrfl,'(a1)', end = 2729)line(1:1)
 2727   continue
        read(addrfl,'(A30)', end = 2729) family
        read(addrfl,'(a)', end = 2729) addres(1)
        read(addrfl,'(a)', end = 2729) addres(2)
        read(addrfl,'(a)', end = 2729) addres(3)
        read(addrfl,'(a)', end = 2729) addres(4)
        read(addrfl,'(a)', end = 2729) addres(5)
        read(addrfl,'(a)', end = 2729) email
        read(addrfl,'(a)', end = 2729) fax
        read(addrfl,'(a)', end = 2729) phone
C       Blank separating line
        read(addrfl,'(a1)', end = 2729)line(1:1)
 2729   continue
      else
        write(*,'('' Enter your name as: family name(s) , '',
     1    ''first name(s) or initials:'')')
        call fread(500040,'LNNNNNNNNN')
        family=line(1:30)
        write(*,'('' Enter your address (5 lines):'')')
        do 2720 i = 1,5
          call fread(500060,'BNNNNNNNNN')
          addres(i) = line(1:40)
 2720   continue
        write(*,'('' Enter your e-mail address:'')')
        call fread(500080,'BNNNNNNNNN')
        email=line(1:40)
        write(*,'('' Enter your telefax number:'')')
        call fread(500100,'BNNNNNNNNN')
        fax=line(1:40)
        write(*,'('' Enter your telephone number:'')')
        call fread(500120,'BNNNNNNNNN')
        phone=line(1:40)
      endif
C---- End of name/address input
 2715 write(*,'(/9x,''Name:'',t20,a30)') family
      write(*,'(9x,''Address:'',t20,a40,4(/t20,a40))') (addres(i),i=1,5)
      write(*,'(9x,''Email:'',t20,a40)') email
      write(*,'(9x,''Telefax:'',t20,a40)') fax
      write(*,'(9x,''Telephone:'',t20,a40)') phone
      write(*,'(//'' Name address data OK (Y,N)? '')')
      call fread(500140,'XNNNNNNNNN')
      inchar = charin(1)(1:1)
      if (inchar .eq. 'N') go to 2710
      if (inchar .ne. 'Y') go to 2715
C---- Close file
      close(unit=addrfl, status = 'KEEP')
C
      return
      end
C
      subroutine fread(ncode,formt)
C
C**** Free format read for interactive input
C
      character formt*10, symb(0:13)*1
      integer   i,j,nval,mode,nchar,jchar,idecm
      integer ncode, trim
      logical   decm, minus, first
      include   'common.for'
C---- Formt contains the format of the line. I means an integer, R a 
C     real and N nothing in the order of input.  All values are stored 
C     in order in Intin and Realin. C and X mean character data 
C     separated by blanks and stored in charin. For X the characters are
C     converted to upper case and C they are left alone. L means a whole
C     line of character data to be found in line which must not be 
C     blank. B means a whole line of character to be found in line which
C     may be blank
      data  symb/
     1 '0','1','2','3','4','5','6','7','8','9','+','-','.',' '/
C       0   1   2   3   4   5   6   7   8   9   10 11  12  13
C
C---- Get the line
 95   line = ' '
      do 100 i = 1, 10
        intin(i) = 99999
        realin(i) = 99999.0
        charin(i) = '999999999999999'
 100  continue
C---- Defaults from saved answer file
      if (lquan) then
 110    if (nqaocd.ge.ncode) go to 130 
        read(qaofl,'(i6,a80)',end=120) nqaocd, qline
        go to 110
 120    nqaocd=999999
 130    if (nqaocd.eq.ncode) then
C---- A saved answer for this question
          write(*,'('' ** Saved answer - Return to accept: '',a)') 
     1     qline(1:trim(qline))
          if (hspeed) then
            line=qline        
            read(qaofl,'(i6,a80)',end=140) nqaocd, qline
            go to 145
 140        nqaocd=999999
 145        continue
          else
            read(*,'(a80)',end=9999) line
            if (line(1:10).eq.'          ') then
              line=qline        
              read(qaofl,'(i6,a80)',end=150) nqaocd, qline
            go to 155
 150        nqaocd=999999
 155        continue
            endif
          endif
        else
          read(*,'(a80)',end=9999) line
        endif
      else
C---- No saved answer file
        read(*,'(a80)',end=9999) line
      endif
      nval = 0
C---- mode 0 = looking for start, mode = 1 integer read, mode = 2 real 
C     read, mode 3 = character read, mode = 4 non-blank line read, 
C     mode = 5 line (may be blank read), mode = 6 is character read 
C     converted to upper case
      mode = 0
      if (formt(1:1) .eq. 'B') go to 9999
      do 8675 nchar = 1 ,80
C---- Check the input character
        jchar = -1
        first = .false.
        do 8605 i = 0, 13
          if (line(nchar:nchar) .eq. symb(i)) jchar = i
 8605   continue
C
C**** Treat mode = 0
C
        if (mode .eq. 0) then
C----   Looking for start
          if( jchar .ne. 13 ) then
C----     Got a start
            nval = nval + 1
            if (formt(nval:nval) .eq. 'I') mode = 1
            if (formt(nval:nval) .eq. 'R') mode = 2
            if (formt(nval:nval) .eq. 'C') mode = 3
            if (formt(nval:nval) .eq. 'L') mode = 4
            if (formt(nval:nval) .eq. 'X') mode = 6
            intin(nval) = 0
            charin(nval) = ' '
            ipchar = 0
            idecm = 0
            decm  = .false.
            minus = .false.
            first = .true.
          endif
        endif
C
C**** Treat mode = 1  - Integer
C
        if ( mode .eq. 1) then
          if (jchar. lt. 0) then
            go to 9950
          elseif (jchar .le. 9) then
C----     A digit
            intin(nval) = 10*intin(nval) + jchar
          elseif (jchar .eq. 10) then
C----     A +
            if ( .not. first) go to 9950
          elseif (jchar .eq. 11) then
C----     A -
            if ( .not. first) go to 9950
            minus = .true.
          elseif (jchar .eq. 12) then
C----     A .
            go to 9950
          elseif (jchar .eq. 13) then
C----     A space
            if (minus) intin(nval) = -intin(nval)
            mode = 0
          endif
        endif
C
C****  Treat mode = 2  - Real
C
        if (mode .eq. 2) then
          if (jchar. lt. 0) then
            go to 9950
          elseif (jchar .le. 9) then
C----     A digit
            intin(nval) = 10*intin(nval) + jchar
            if ( decm ) idecm = idecm + 1
          elseif (jchar .eq. 10) then
C----     A +
            if ( .not. first) go to 9950
          elseif (jchar .eq. 11) then
C----     A -
            if ( .not. first) go to 9950
            minus = .true.
          elseif (jchar .eq. 12) then
C----     A .
            if (decm) go to 9950
            decm = .true.
          elseif (jchar .eq. 13) then
C----     A space
            if (minus) intin(nval) = -intin(nval)
            realin(nval) = real(intin(nval))/10.0**idecm
            intin(nval) = 99999
            mode = 0
          endif
        endif
C
C**** Treat mode =  3 or 6 (without or with conversion to upper case)
C
        if ((mode .eq. 3).or.(mode .eq. 6)) then
          if (jchar .ne. 13) then
            ipchar = ipchar + 1
            if (ipchar .gt. 10) go to 9950
            inchar = line(nchar:nchar)
C----     Change to capitals
            if (mode .eq. 6) then
              do 8670 i = 1, 26
                if ( inchar .eq. alphl(i)) inchar = alphc(i)
 8670         continue
            endif
            charin(nval)(ipchar:ipchar) = inchar
          else
            mode = 0
          endif
        endif
C
C**** Treat mode = 4
C
        if (mode .eq. 4) then
C---- No need to do anything for mode 4. Whole line is the input
        endif
C
C**** Treat mode = 5
C
        if (mode .eq. 5) then
C---- No need to do anything for mode 5. Whole line is the input
        endif
 8675 continue
C---- Did we get everything we wanted
 8680 do 8685 i = 1 ,10
        if (formt(i:i) .eq. 'N') go to 8695
        j = i
 8685 continue
 8695 if (j .eq. nval) go to 9999
C---- Incorrect Input
 9950 write(*,'('' **** Wrong input - Try again ****'')')
      go to 95
C---- Copy input line to output
 9999 continue
      if(ncode.gt.0) 
     1  write(qanfl,'(i6,a)') ncode, line(1:trim(line))
C---- Subroutine exit
      return
      end

C
      integer function trim(line)
      character*(*) line
      do 100 trim = len(line),1,-1
         if (line(trim:trim) .ne. ' ') go to 200
 100  continue
 200  if (trim.le.0) trim=1
      return
      end
C
      subroutine chform
C
C===== Conversion of a string record of the chemical formula into the
C      component sums of elements. Adapted from a subroutine by B.Kilger
C===== 07/83 modified by R.Sievers 9.85 and 7.88
C
C    BEDEUTUNG DER ARGUMENTE:
C    CHEMFM:  INPUTSTRING (CHARACTER*(140)) MIT DER STRUKTURIERTEN
C             FORMEL
C    140:     LAENGE DES INPUTSTRINGS
C    namtyp:  CHARACTER*2-ARRAY (LAENGE: 24) MIT natmtp GEFUNDENEN
C             ELEMENT-SYMBOLEN
C    NELIST:  RUECKGABE DER ELEMENTNUMMERN, ALPHABETISCH
C    fnamtp:  RUECKGABE DER ENTSPRECHENDEN INDIZES
C    24:      MAXIMALLAENGE DER ARRAYS namtyp, NELIST UND fnamtp
C    natmtp:>0 - ZAHL DER GEFUNDENEN ELEMENTE
C           <0 - FEHLER. AM HAEUFIGSTEN: -1 : SYNTAX-FEHLER (Z.B. ZAHL
C                                             VOR ELEMENT STATT HINTER)
C                                        -2 : FALSCHES SONDERZEICHEN
C                                        -3 : FALSCHES ELEMENT
C                                        -4 : KLAMMERN NICHT AUSGEWOGEN
C
C
      include 'common.for'
C
      character*1 idmxx
      character*1 nb,flank,nc2,nz
      character*2 nel4
      character*2 nele(106)
C
      real f, ftot, fsav
      real fak(20)
C
      integer iendfl, ilpar, irpar, idig, iele, idezpt, istp, ipnt
      integer izifer, nv, nh, nr, i, jbeg, jl, ja, nesav, jend, klein
      integer ji, kleinp, j
      integer nelist(24)
C
C----VORGABE EINER ELEMENT-HIERARCHIE. DIE SPEZIFIZIERTEN
C     6 ELEMENTE WERDEN NACH VORN GEZOGEN, DIE UEBRIGEN FOLGEN
C     ALPHABETISCH.        Z. ZT.: C H O N S P
C
      integer ielord(6)
      data ielord /15,38,65,57,82,67/
C
      data nele /'AC','AG','AL','AM','AR','AS','AT','AU', 'B ','BA',
C                 1    2    3    4    5    6    7    8     9    10
     1 'BE','BI','BK','BR', 'C ','CA','CD','CE','CF','CL','CM','CO',
C       11   12   13   15    15   16   17   18   19   20   21   22
     2 'CR','CS','CU', 'D ','DY', 'ER','ES','EU', 'F ','FE','FM','FR',
C       23   24   25    26   27    28   29   30    31   32   33   34
     3 'GA','GD','GE', 'H ','HE','HF','HG','HO', 'I ','IN','IR',
C       35   36   37    38   39   40   41   42    43   44   45
     4 'K ','KR','KU', 'LA','LI','LU','LW', 'MD','MG','MN','MO',
C       46   47   48    49   50   51   52    53   54   55   56
     5 'N ','NA','NB','ND','NE','NI','NO','NP', 'O ','OS',
C       57   58   59   60   61   62   63   64    65   66
     6 'P ','PA','PB','PD','PM','PO','PR','PT','PU', 'RA','RB','RE',
C       67   68   69   70   71   72   73   74   75    76   77   78
     7 'RH','RN','RU', 'S ','SB','SC','SE','SI','SM','SN','SR','T',
C       79   80   81    82   83   84   85   86   87   88   89   90
     8 'TA','TB','TC','TE','TH','TI','TL','TM', 'U ', 'V ', 'W ',
C       91   92   93   94   95   96   97   98    99   100    101
     9 'XE', 'Y ','YB', 'ZN','ZR'/
C       102   103  104   105  106
C
      data nb/' '/
      data flank/' '/
      data nel4/' '/
      data nc2/' '/
      data idmxx/' '/
C
      natmtp = 0
      f = 1.0
      iendfl = 0
      ilpar = 0
      irpar = 0
      idig = 0
      iele = 0
      idezpt = 0
      istp = 0
      ipnt = 141
      nc2 = '0'
C
C            ***  LIES INPUTSTRING VON RECHTS NACH LINKS  ***
  100 ipnt = ipnt - 1
      if (ipnt.lt.1) goto 7000
      nb(1:1) = chemfm(ipnt:ipnt)
      nz(1:1) = chemfm(ipnt:ipnt)
C
C             A...Z     a...z     0...9    Blank  Sonderz.
C    -----------------------------------------------------
C    EBCDIC 193..233  129...169 240..249    64    65..128
C    ASCII   65...90   97...122  48...57    32    33...47
C
C----KLEIN-, GROSSBUCHSTABE ODER ZIFFER?
      if(lge(nz,'0')) go to 200
C
C----SONDERZEICHEN ?
      if(nz .eq.' ') go to 5000
      if(nz .eq.'(') go to 3000
      if(nz .eq.')') go to 4000
      if(nz .eq. '.') go to 4500
      go to 9902
C
C----KLEINBUCHSTABE, GROSSBUCHSTABE ODER ZIFFER
C     (GROSSBUCHSTABE ...)
 200  if(lle(nz,'Z') .and. lge(nz,'A')) go to 2000
      if(lle(nz,'9') .and. lge(nz,'0')) go to 1000
C     (KLEINBUCHSTABE ...)
      if(lgt(nz,'z') .or.  llt(nz,'a')) go to 9902
C    KLEIN->GROSS-KONVERSION
      if (lge(nb,'a') .and. lle(nb,'z')) then
         nb = char(ichar(nb) - ichar('a') + ichar('A'))
      end if
      go to 2000
C
C             ***  ZIFFER  ***
 1000 if (idig.gt.0) goto 1100
      if (iele.gt.0.or.ilpar.gt.0) goto 9901
      if (idezpt.le.0) f = 0.0
C
 1100 izifer = ichar(nz) - ichar('0')
      f = f + float(izifer)*10.**(idig-idezpt)
      idig = idig + 1
      irpar = 0
      goto 100
C
C             ***  BUCHSTABE  ***
 2000 if (ilpar.gt.0) goto 9901
      irpar = 0
      idig = 0
      idezpt = 0
      iele = iele + 1
      goto (2020,2030,9903),iele
 2020 nel4(1:1) = nb
      nel4(2:2) = flank
      goto 100
 2030 idmxx      = nel4(1:1)
      nel4(2:2) = idmxx
      nel4(1:1) = nb
      goto 100
C
C             ***  LINKE KLAMMER  ***
 3000 if (idig.gt.0.or.irpar.gt.0) goto 9901
      ilpar = 1
      if (iele.gt.0) goto 6000
 3010 istp = istp - 1
      if (istp.lt.0) goto 9904
      goto 100
C
C             ***  RECHTE KLAMMER  ***
 4000 if (iele.gt.0.or.ilpar.gt.0) goto 9901
      idig = 0
      idezpt = 0
      irpar = 1
      istp = istp + 1
      if (istp.gt.24) goto 9904
      fak(istp) = f
      f = 1.0
      goto 100
C
C             ***  DEZIMALPUNKT  ***
 4500 if (idezpt.gt.0) goto 9905
      f = f*10.**(-idig)
      idig = idig + 1
      idezpt = idig
      goto 100
C
C             ***  BLANK  ***
 5000 if (idig.gt.0) goto 9901
      ilpar = 0
      if (iele.lt.1) goto 100
C
C **********************************************************************
 6000 continue
C
      nv=1
      nh = 106
      nr=65
      go to 25
  10  nv=nr+1
  20  if (nv .gt. nh) go to 30
      nr=(nv+nh)/2
  25  if (nel4 .eq. nele(nr)) go to 40
      if (lgt(nel4,nele(nr))) go to 10
      nh=nr-1
      go to 20
C
  30  nr = 0
  40  continue
C **********************************************************************
C
      if (nr.le.0) goto 9903
      ftot = f
      if (istp.le.0) goto 6050
      do 6020 i=1,istp
 6020 ftot = ftot * fak(i)
 6050 if (natmtp.le.0) goto 6100
      do 6070 i=1,natmtp
      if (nr.ne.nelist(i)) goto 6070
      fnamtp(i) = fnamtp(i) + ftot
      goto 6150
 6070 continue
 6100 natmtp = natmtp + 1
      if(natmtp .gt. 24) go to 9906
      fnamtp(natmtp) = ftot
      nelist(natmtp) = nr
 6150 f = 1.0
      iele = 0
      if (ilpar.gt.0) goto 3010
      if (iendfl.le.0) goto 100
C
C            ***  ENDE DES SCANS VON RECHTS NACH LINKS  ***
 7000 iendfl = 1
      if (istp.ne.0) goto 9904
      if (iele.gt.0) goto 6000
C
C             ***  VERTAUSCHEN DER REIHENFOLGE  ***
      if (natmtp .le. 0) go to 9999
      jbeg = 1
C
C----DIE SPEZIFIZIERTEN ELEMENTE WERDEN NACH VORN GEZOGEN.
      do 7030 jl = 1,6
C----ELEMENT IELORD(JL) IN DER FORMEL SUCHEN:
      do 7010 ja = jbeg,natmtp
      if(nelist(ja) .eq. ielord(jl)) go to 7020
7010  continue
C----NICHT IN DER FORMEL.
      go to 7030
C
7020  nesav = nelist(ja)
      nelist(ja) = nelist(jbeg)
      nelist(jbeg) = nesav
      fsav = fnamtp(ja)
      fnamtp(ja) = fnamtp(jbeg)
      fnamtp(jbeg) = fsav
C
      jbeg = jbeg + 1
      if(jbeg .eq. natmtp) go to 9000
7030  continue
C
      jend = natmtp - 1
      do 7100 ja = jbeg,jend
      klein = 999
      do 7060 ji = ja,natmtp
      if (nelist(ji) .ge. klein) go to 7060
      klein = nelist(ji)
      kleinp = ji
7060  continue
      fsav = fnamtp(kleinp)
      fnamtp(kleinp) = fnamtp(ja)
      fnamtp(ja) = fsav
      nesav = nelist(kleinp)
      nelist(kleinp) = nelist(ja)
      nelist(ja) = nesav
7100  continue
C
9000  if (natmtp .gt. 0) then
         do 9020 j = 1,natmtp
            namtyp(j) = nele(nelist(j))
C
C              2. Buchstaben nach klein konvertieren
            if (namtyp(j)(2:2) .ne. ' ') then
               namtyp(j)(2:2) = char(ichar(namtyp(j)(2:2)) -
     1         ichar('A') + ichar('a'))
            end if
9020     continue
      end if
C
      go to 9999
C
C             ***  ALLG. STELLUNGSFEHLER  ***
 9901 natmtp = -1
      go to 9999
C             ***  FALSCHES SONDERZEICHEN  ***
 9902 natmtp = -2
      go to 9999
C             ***  FALSCHES ELEMENTSYMBOL  ***
 9903 natmtp = -3
      go to 9999
C             ***  KLAMMERN NICHT AUSGEWOGEN  ***
 9904 natmtp = -4
      go to 9999
C             ***  KONVERTIERFEHLER  ***
 9905 natmtp = -5
      go to 9999
C             ***  UEBERLAUF  ***
 9906 natmtp = -6
C
 9999 continue
      return
      end
C
      block data blockd
C
C**** COMMON and DATA statements for Diffractometer Conversion Progs
C
      include 'common.for'
C
C---- TYPE STATEMENTS
      integer i
C
C
C---- DATA STATEMENTS
C
      data digit/'0','1','2','3','4','5','6','7','8','9','-',' '/
C
      data alphc/'A','B','C','D','E','F','G','H','I','J','K','L','M',
     1           'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
      data alphl/'a','b','c','d','e','f','g','h','i','j','k','l','m',
     1           'n','o','p','q','r','s','t','u','v','w','x','y','z'/
C
      data includ /'INCLUDE '/
      data exclud /'EXCLUDE '/
C
      data dar, rad/ .017453293, 57.29577951/
C
      data nseq, nrefl/ 0, 0/
C
      data time, bastim, prvtim/ 0.0, 0.0, -99.0/
C
      data condon/ .false./
C
      data ask /16*.true./
C
      data meas(1)/'\w scans              '/
      data meas(2)/'\w-2\q scans          '/
      data meas(3)/'\w-X.X \q scans       '/
      data meas(4)/'variable scan type    '/
C
      data lquan  /.false./
      data hklopn /.false./
      data lhead  /.false./
C
      data hmin, hmax, kmin, kmax, lmin, lmax
     1 /+9999,-9999,+9999,-9999,+9999,-9999/
C
      data stlmin, stlmax/50.0, 0.0/
C
      data (avint(i), sdint(i), count(i), i = 1,10)/30*0.0/
C
      data swdb /0.0/
      data sct  /0.0/
      data mxn  /0/
      data smo  /0/
      data bmo  /0/
      data bgt  /0.0/
      data parclp  /0/
      data numref  /0/
      data backsn  /0/
      data stdseq  /0/
      data fdeadt  /0.0/
      data efdead  /0.0/
      data numang  /0/
C
      data nfilt     /1/
      data nfltcd    /20*0/
      data attfac    /1.0,19*0.0/
      data ettfac(1) /0.0/
      data attn      /0.0/
C
      data nmcell   /0/
      data ctthn    /180./
      data ctthx    /0.0/
      data ctemp    /293.0/
C
      data navtab  /3/
      data wavtab  /
     1  1.54183, 1.540562,  1.544390, 0.6680, 0.3320,
     2  0.71073, 0.709300,  0.713590, 0.6671, 0.3329,
     3  0.56087, 0.5594075, 0.563798, 0.6671, 0.3329
     4 /
      data wavnam /
     1 'Cu       ','Cu K\a   ','Cu K\a~1~','Cu K\a~2~',
     2 'Mo       ','Mo K\a   ','Mo K\a~1~','Mo K\a~2~',
     3 'Ag       ','Ag K\a   ','Ag K\a~1~','Ag K\a~2~'/
C
      data mstnn  /0/
C
      data sinter /0.0/
C
      end
