C
C==== CIF Module of DIFRAC by H.D. Flack, University of Geneva
C==== Version 16th September 1998
C
      subroutine refout
C
C---- Output a reflection with the CIF diffrn items
C
      include 'common.for'
      character  cnrats*6, cksnba*6
      integer im,id,iy
C
C**** Output the starting lines of the CIF file
C
      if (.not. lhead) then
        lhead = .true.
C
C==== Output the CIF data_ line
C
        write(scfsfl,'(/''data_ '',t6,a6)') compid
C
C==== Output the CIF audit items
C
        write(scfsfl,'(/)')
        call idate(im,id,iy)
C==== Fix up the century - VMS has no decent 4 figure year in its date function
C==== that I can find.
        iy = iy + 1900
        if (iy.lt.1997) iy = iy + 100
        write(scfsfl,
     1 '(''_audit_creation_date '',t36,'''''''',i4.4,''-'',i2.2,
     2 ''-'',i2.2,'''''''')') iy,im,id
        write(scfsfl, '(''_audit_creation_method '',/,
     1 ''; DIFRAC, Single-Crystal Diffractometer'',
     2 '' Output-Conversion Software''/
     3 ''   Flack, H. D., Blanc, E. & Schwarzenbach, D. (1992).''/
     4 ''    J. Appl. Cryst. 25, 455-459.''/
     5 ''    ftp://ftp.unige.ch/pub/soft/crystal/difrac/README.1ST''/
     6 '';'')')
        write(scfsfl,
     1 '(''_audit_conform_dict_name '',t36,
     2 ''''''cif_rawxtal.dic'''''')')
        write(scfsfl,
     1 '(''_audit_conform_dict_version '',t36,
     2 ''''''0.001'''''')')
        write(scfsfl,
     1 '(''_audit_conform_dict_location ''/'';   ftp://ftp.'',
     2 ''unige.ch/pub/soft/crystal/difrac/cif_rawxtal.dic''/'';'')')

      endif
C
C---- Open up the CIF difrn loop
C
      if(.not. hklopn) then
        hklopn = .true.
        write(scfsfl,'(//''loop_ '')')
        write(scfsfl,'(''_diffrn_refln_index_h '')')
        write(scfsfl,'(''_diffrn_refln_index_k '')')
        write(scfsfl,'(''_diffrn_refln_index_l '')')
        write(scfsfl,'(''_diffrn_refln_counts_peak '')')
        write(scfsfl,'(''_diffrn_refln_counts_bg_1 '')')
        write(scfsfl,'(''_diffrn_refln_counts_bg_2 '')')
        write(scfsfl,'(''_diffrn_refln_angle_psi '')')
        write(scfsfl,'(''_diffrn_refln_elapsed_time '')')
        write(scfsfl,'(''_diffrn_refln_attenuator_code '')')
        write(scfsfl,'(''_diffrn_refln_scale_group_code '')')
        write(scfsfl,'(''_diffrn_refln_standard_code '')')
        write(scfsfl,'(''_diffrn_refln_scan_mode_backgd '')')
        write(scfsfl,'(''_diffrn_refln_fbcoeff_peak '')')
        write(scfsfl,'(''_diffrn_refln_fbcoeff_bg_peak '')')
        write(scfsfl,'(''_diffrn_refln_fbcoeff_bg_1 '')')
        write(scfsfl,'(''_diffrn_refln_fbcoeff_bg_2 '')')
        write(scfsfl,'(''_diffrn_refln_scan_width '')')
        if (mstnn.le.2) then
          write(scfsfl,'(''_diffrn_refln_scan_mode '')')
        else
          write(scfsfl,'(''_diffrn_refln_scan_mode_factor '')')
        endif
        write(scfsfl,
     1  '(''_diffrn_refln_detect_slit_horiz '')')
        write(scfsfl,
     1  '(''_diffrn_refln_detect_slit_vert '')')
      endif
C
C--- Set up the output of scan rate
      if (mstnn.eq.1) then
       cnrats = ' ''om'' '
      elseif (mstnn.eq.2) then
       cnrats = ' ''ot'' '
      else
       write(cnrats,'(1x,f4.2,1x)')scnrat
      endif
C
C--- Set up the output of background scan mode
      if (backsn.eq.0) then
       cksnba = ' ''st'' '
      else
       cksnba = ' ''mo'' '
      endif
C
      write(scfsfl,'(3i5,3f10.0,f9.3,f10.0,/
     1,1x,'''''''',i1,'''''''',1x,'''''''',i1,'''''''',1x,''''''''
     2,i1,'''''''',1x,a6,f9.3,4f8.3,a6,2f7.3)')
     3ih, ik, il, peak, backl, backr, psicry, time,
     4ptfilt, ptscl, ptstd, cksnba, cnp, cnb, cnl, cnr,
     5swidth, cnrats, dethz, detvt
C
      return
      end
C
      subroutine basout
C
C**** Subroutine to output to the CIF all non-intensity information
C
      integer trim
      integer i,j,k
      integer ipnt
      character*20 valout
C
      include 'common.for'
C
      if (hklopn) then
        hklopn = .false.
      endif
C
C==== Output the CIF audit items to indicate persons name, address etc
C
      write(scfsfl,'(/
     1 ''_audit_author_name '',t36,'''''''',a,'''''''')')
     2 family(1:(trim(family)))
      write(scfsfl,'(''_audit_author_address '',/,'';'',t36,a,
     1  4(/,t36,a),/,'';'')') (addres(i),i=1,5)
      write(scfsfl,'(
     1 ''_audit_contact_author_name '',t36,'''''''',a,'''''''')')
     2 family(1:(trim(family)))
      write(scfsfl,'(''_audit_contact_author_address '',/,'';'',t36,a,
     1  4(/,t36,a),/,'';'')') (addres(i),i=1,5)
      k=trim(email)
      if(k.gt.1) write(scfsfl,'(
     1  ''_audit_contact_author_email '',t36,'''''''',a,'''''''')')
     2  email(1:k)
      k=trim(fax)
      if(k.gt.1) write(scfsfl,'(
     1  ''_audit_contact_author_fax '',t36,'''''''',a,'''''''')')
     2  fax(1:k)
      k = trim(phone)
      if(k.gt.1) write(scfsfl,'(
     1  ''_audit_contact_author_phone '',t36,'''''''',a,'''''''')')
     2  phone(1:k)
      write(scfsfl,'(''loop_ '')')
      write(scfsfl,'(''_audit_link_block_code '')')
      write(scfsfl,'(''_audit_link_block_description '')')
      write(scfsfl,'(''.'',/,''; '',a,/,'';'')') 
     1 title(1:(trim(title)))
C

C
C==== Output the CIF cell items
C
      write(scfsfl,'(/)')
      write(scfsfl,'(''_cell_length_a '',t36,a20)')
     1  valout(cell(1),ecell(1),3)
      write(scfsfl,'(''_cell_length_b '',t36,a20)')
     1  valout(cell(2),ecell(2),3)
      write(scfsfl,'(''_cell_length_c '',t36,a20)')
     1  valout(cell(3),ecell(3),3)
      if ((ecell(4).eq.0.0).and.(abs(cell(4)-90.0).lt.0.01).or.
     1 (abs(cell(4)-120.0).lt.0.01)) then
      write(scfsfl,'(''_cell_angle_alpha '',t36,a20)')
     1  valout(cell(4),-0.1,1)
      else
      write(scfsfl,'(''_cell_angle_alpha '',t36,a20)')
     1  valout(cell(4),ecell(4),3)
      endif
      if ((ecell(5).eq.0.0).and.(abs(cell(5)-90.0).lt.0.01).or.
     1 (abs(cell(5)-120.0).lt.0.01)) then
      write(scfsfl,'(''_cell_angle_beta '',t36,a20)')
     1  valout(cell(5),-0.1,1)
      else
      write(scfsfl,'(''_cell_angle_beta '',t36,a20)')
     1  valout(cell(5),ecell(5),3)
      endif
      if ((ecell(6).eq.0.0).and.(abs(cell(6)-90.0).lt.0.01).or.
     1 (abs(cell(6)-120.0).lt.0.01)) then
      write(scfsfl,'(''_cell_angle_gamma '',t36,a20)')
     1  valout(cell(6),-0.1,1)
      else
      write(scfsfl,'(''_cell_angle_gamma '',t36,a20)')
     1  valout(cell(6),ecell(6),3)
      endif
      write(scfsfl,'(''_cell_volume '',t36,a20)')
     1  valout(volum,evolum,3)
      write(scfsfl,'(''_cell_formula_units_Z '',t36,a20)')
     1  valout(real(zcell),-1.0,1)
      write(scfsfl,'(''_cell_measurement_reflns_used '',t36,a20)')
     1  valout(real(nmcell),-1.0,1)
      if(ctthn.gt.0.0) write(scfsfl,
     1  '(''_cell_measurement_theta_min '',t36,a20)')
     2  valout(0.5*ctthn,-0.01,1)
      if(ctthx.gt.0.0) write(scfsfl,
     1  '(''_cell_measurement_theta_max '',t36,a20)')
     2  valout(0.5*ctthx,-0.01,1)
      if(ctemp.gt.0.0) write(scfsfl,
     1  '(''_cell_measurement_temperature '',t36,a20)')
     2  valout(ctemp,-0.1,1)
      write(scfsfl,'(''_cell_measurement_radiation '',
     1   t36,'''''''',a,'''''''')') clrnam(1:trim(clrnam))
      write(scfsfl,'(''_cell_measurement_wavelength '',t36,a20)')
     1  valout(cwave,-0.00001,1)
C
C==== Output the CIF chemical items
C
      write(scfsfl,'(/)')
      if (lform(2)) write(scfsfl,'(
     1  ''_chemical_formula_weight_meas '',t36,a20)')
     2  valout(forwg,eforwg,3)
      if (mptemp.gt.1.0) write(scfsfl,'(''_chemical_melting_point '',
     1  t36,a20)') valout(mptemp,-0.01,1)
      k=trim(chemfm)
      if(k.gt.70) then
        write(scfsfl,'(''_chemical_formula_structural '',/,
     1  '''''''',a70,/,a,'''''''')') chemfm(1:70),chemfm(71:k)
      else if(k.gt.40) then
        write(scfsfl,'(''_chemical_formula_structural '',/,
     1  '''''''',a,'''''''')') chemfm(1:k)
      else if(k.gt.1) then
        write(scfsfl,'(''_chemical_formula_structural '',t36,
     1  '''''''',a,'''''''')') chemfm(1:k)
      endif
C---- Sum formula
      ipnt = -1
      line(1:80) = ' '
      do 2708 k = 1, natmtp
        ipnt = ipnt + 3
        line(ipnt-1:ipnt) = namtyp(k)(1:2)
        if (namtyp(k)(2:2).ne.' ') ipnt = ipnt + 1
        if (nint(fnamtp(k)).ne.1) line(ipnt:)=valout(fnamtp(k),-1.0,1)
        if(nint(fnamtp(k)).gt.9) ipnt = ipnt + 1
        if(nint(fnamtp(k)).gt.99) ipnt = ipnt + 1
 2708 continue
      write(scfsfl,'(''_chemical_formula_sum '',t36,
     1  '''''''',a,'''''''')') line(1:trim(line))
C---- Analytical quantities
      if(lform(1)) then
        ipnt = -1
        line(1:80) = ' '
        do 2709 k = 1, natmtp
          if(peratm(k).gt.0.0) then
            ipnt = ipnt + 3
            line(ipnt-1:ipnt) = namtyp(k)(1:2)
            if (namtyp(k)(2:2).ne.' ') ipnt = ipnt + 1
            line(ipnt:)=valout(peratm(k),eperat(k),1)
            ipnt = trim(line)
          endif
 2709   continue
        write(scfsfl,'(''_chemical_formula_analytical ''
     1    ,t36,'''''''',a,'''''''')') line(1:ipnt)
      endif
      k=trim(cpdsou)
      if(k.gt.40) then
        write(scfsfl,'(''_chemical_compound_source '',/,
     1  '''''''',a,'''''''')') cpdsou(1:k)
      else if(k.gt.1) then
        write(scfsfl,'(''_chemical_compound_source '',t36,
     1  '''''''',a,'''''''')') cpdsou(1:k)
      endif
      k=trim(namecm)
      if (k.gt.40) then
        write(scfsfl,'(''_chemical_name_common '',/,
     1  '''''''',a,'''''''')') namecm(1:k)
      else if (k.gt.1) then
        write(scfsfl,'(''_chemical_name_common '',t36,
     1  '''''''',a,'''''''')') namecm(1:k)
      endif
      k=trim(nameml)
      if (k.gt.40) then
        write(scfsfl,'(''_chemical_name_mineral '',/,
     1  '''''''',a,'''''''')') nameml(1:k)
      else if (k.gt.1) then
        write(scfsfl,'(''_chemical_name_mineral '',t36,
     1  '''''''',a,'''''''')') nameml(1:k)
      endif
C
C==== Output the CIF computing items
C
      write(scfsfl,'(/)')
      write(scfsfl,'(''_computing_data_collection '',t36,'''''''',
     1 a,'''''''')') softwr(1:trim(softwr))
      write(scfsfl,'(''_computing_cell_refinement '',t36,'''''''',
     1 a,'''''''')') cellpg(1:trim(cellpg))

C
C==== Output the CIF diffrn items
C
      write(scfsfl,'(/)')
      if (envl) write(scfsfl,'(''_diffrn_ambient_environment '',
     1   t36,'''''''',a,'''''''')') envamb(1:trim(envamb))
      write(scfsfl,'(''_diffrn_ambient_pressure '',t36,a20)')
     1  valout(presnt,-0.01,1)
      write(scfsfl,'(''_diffrn_ambient_temperature '',t36,a20)')
     1  valout(temint,-0.01,1)
      k=trim(dicrtr)
      if(k.gt.1) write(scfsfl,'(''_diffrn_crystal_treatment '',t36,
     1  '''''''',a,'''''''')') dicrtr(1:k)
      write(scfsfl,'(''_diffrn_detector '',t36,'''''''',
     1 a,'''''''')') dettyp(1:trim(dettyp))
      if(fdeadt.gt.0.0) write(scfsfl,
     1  '(''_diffrn_detector_dtime '',t36,a20)')
     2  valout(fdeadt,efdead,3)
      write(scfsfl,'(''_diffrn_measurement_device_type '',
     1   t36,'''''''',a,'''''''')') device(1:trim(device))
      if(mstnn.gt.0) then
        if(mstnn.eq.3) then
          write(meas(3)(4:6),'(f3.1)') scnrat
        endif
        write(scfsfl,'(''_diffrn_measurement_method '',
     1   t36,'''''''',a,'''''''')')  meas(mstnn)(1:trim(meas(mstnn)))
      endif
      write(scfsfl,'(''_diffrn_measurement_specimen_support '',
     1   t40,'''''''',a,'''''''')') spmnpt(1:trim(spmnpt))
      k=trim(meadet)
      if(k.gt.1) write(scfsfl,'(''_diffrn_measurement_details '',t36,
     1  '''''''',a,'''''''')') meadet(1:k)
      write(scfsfl,'(''_diffrn_radiation_monochromator '',
     1   t36,'''''''',a,'''''''')')  mondes(1:trim(mondes))
      if(Monoch .EQ. 'b') WRITE(Scfsfl,'(
     1  ''_diffrn_radiation_filter_edge '',t36,a20)')
     2  valout(bedwv,-0.00001,1)
      if(fmhomw.gt.0.0) write(scfsfl,
     1  '(''_diffrn_radiation_inhomogeneity '',t36,a20)')
     2  valout(fmhomw,-0.0001,1)
      write(scfsfl,'(''_diffrn_radiation_polarisn_fract '',
     1  t36,a20)')  valout(frapol,erapol,3)
      write(scfsfl,'(''_diffrn_radiation_probe '',t36,
     1 ''''''x-ray'''''')')
      write(scfsfl,'(''_diffrn_radiation_type '',t36, 
     1 '''''''',a,'''''''')') wl0nam(1:trim(wl0nam))
      write(scfsfl,'(''_diffrn_source '',t36,
     1 ''''''sealed tube'''''')')
      write(scfsfl,'(''_diffrn_source_current '',t36,a20)')
     1  valout(tubcur,-1.0,1)
      write(scfsfl,'(''_diffrn_source_voltage '',t36,a20)')
     1  valout(tubvol,-1.0,1)
      write(scfsfl,'(''_diffrn_source_size '',
     1   t36,'''''''',a,'''''''')')  tubciz(1:trim(tubciz))
      write(scfsfl,'(''_diffrn_source_target '',
     1   t36,'''''''',a,'''''''')')  tubtar(1:trim(tubtar))
      write(scfsfl,'(''_diffrn_reflns_theta_max '',t36,a20)')
     1  valout(rad*asin(stlmax*wavel),-0.01,1)
      write(scfsfl,'(''_diffrn_reflns_theta_min '',t36,a20)')
     1  valout(rad*asin(stlmin*wavel),-0.01,1)
      write(scfsfl,'(''_diffrn_reflns_limit_h_max '',t36,a20)')
     1  valout(real(hmax),-1.0,1)
      write(scfsfl,'(''_diffrn_reflns_limit_h_min '',t36,a20)')
     1  valout(real(hmin),-1.0,1)
      write(scfsfl,'(''_diffrn_reflns_limit_k_max '',t36,a20)')
     1  valout(real(kmax),-1.0,1)
      write(scfsfl,'(''_diffrn_reflns_limit_k_min '',t36,a20)')
     1  valout(real(kmin),-1.0,1)
      write(scfsfl,'(''_diffrn_reflns_limit_l_max '',t36,a20)')
     1  valout(real(lmax),-1.0,1)
      write(scfsfl,'(''_diffrn_reflns_limit_l_min '',t36,a20)')
     1  valout(real(lmin),-1.0,1)
      write(scfsfl,'(''_diffrn_reflns_number '',t36,a20)')
     1  valout(real(nrefl),-1.0,1)
      if (sinter.gt.0.0) write(scfsfl,'(
     1  ''_diffrn_standards_interval_time '',t36,a20)')
     2  valout(sinter/60.0,-1.0,1)
      write(scfsfl,'(''_diffrn_standards_number '',t36,a20)')
     1  valout(real(numref),-1.0,1)
C
C==== Output the CIF exptl items
C
      write(scfsfl,'(/)')
      k=trim(cryscl)
      if(k.gt.1) write(scfsfl,'(''_exptl_crystal_colour '',t36,
     1  '''''''',a,'''''''')') cryscl(1:k)
      if (mdensi) then
        write(scfsfl,'(''_exptl_crystal_density_method '',
     1   t36,'''''''',a,'''''''')')  denmet(1:trim(denmet))
        write(scfsfl,'(''_exptl_crystal_density_meas '',
     1   t36,a20)') valout(densit, edensi,3)
        write(scfsfl,
     1   '(''_exptl_crystal_density_meas_temp '',
     2   t36,a20)') valout(tdensi,-0.01,1)
      else
        write(scfsfl,'(''_exptl_crystal_density_method '',
     1   t36,''''''not measured'''''')')
        write(scfsfl,'(''_exptl_crystal_density_meas '',
     1   t36,''?'')')
        write(scfsfl,
     1   '(''_exptl_crystal_density_meas_temp '',
     2   t36,''?'')')
      endif
      k=trim(crysds)
      if (k.gt.40) then
        write(scfsfl,'(''_exptl_crystal_description '',/,
     1   '''''''',a,'''''''')') crysds(1:k)
      else if(k.gt.1) then
        write(scfsfl,'(''_exptl_crystal_description '',t36,
     1   '''''''',a,'''''''')') crysds(1:k)
      endif
      k=trim(excrpr)
      if(k.gt.1) write(scfsfl,'(''_exptl_crystal_preparation '',t36,
     1  '''''''',a,'''''''')') excrpr(1:k)
      if (crytyp .eq. 'S') then
        write(scfsfl,'(''_exptl_crystal_size_rad '',
     1   t36,a20)')  valout(dface(1), deface(1), 3)
      else if (crytyp .eq. 'M') then
        write(scfsfl,'(''_exptl_crystal_size_max '',
     1   t36,a20)')  valout(sizem(1), -0.01, 3)
        write(scfsfl,'(''_exptl_crystal_size_mid '',
     1   t36,a20)')  valout(sizem(2), -0.01, 3)
        write(scfsfl,'(''_exptl_crystal_size_min '',
     1   t36,a20)')  valout(sizem(3), -0.01, 3)
      endif
C
C==== Output the CIF atom type loop items
C
      if (natmtp .gt. 0) then
        write(scfsfl,'(//''loop_ '')')
        write(scfsfl,'(''_atom_type_symbol '')')
        write(scfsfl,'(''_atom_type_number_in_cell '')')
        if(lform(1)) write(scfsfl,'(''_atom_type_analytical_mass_% '')')
        do 2719 k = 1, natmtp
          if(lform(1)) then
            write(scfsfl,'(5x,'''''''',a,'''''''',3x,f8.2,3x,a20)')
     1        namtyp(k)(1:trim(namtyp(k))), zcell*fnamtp(k),
     2        valout(peratm(k),eperat(k),1)
          else
            write(scfsfl,'(5x,'''''''',a,'''''''',3x,f8.2)') 
     1        namtyp(k)(1:trim(namtyp(k))), zcell*fnamtp(k)
          endif
 2719   continue
      endif
C
C==== Output the CIF  cell measurement loop items
C
C**** Don't output the cell measurement lines as they are non-standard
      numang = 0
C****
      if (numang .gt. 0) then
        write(scfsfl,'(//''loop_ '')')
        write(scfsfl,'(''_cell_measurement_refln_index_h '')')
        write(scfsfl,'(''_cell_measurement_refln_index_k '')')
        write(scfsfl,'(''_cell_measurement_refln_index_l '')')
        write(scfsfl,'(
     1    ''_cell_measurement_refln_theta '')')
        write(scfsfl,'(
     1    ''_cell_measurement_refln_wl_id '')')
        do 2013 i = 1, numang
          write(scfsfl,'(3i5,1x,f10.4,1x,'''''''',i1,'''''''')')
     1    hang(i), kang(i), lang(i), 0.5*twoang(i), wang(i)
 2013   continue
      endif
C
C==== Output the CIF diffrn attenuator loop items
C
      if (nfilt .gt. 0) then
        write(scfsfl,'(//''loop_ '')')
        write(scfsfl,'(''_diffrn_attenuator_code '')')
        write(scfsfl,'(''_diffrn_attenuator_scale '')')
        do 1030 i = 1 , nfilt
          write(scfsfl,'(1x,'''''''',i1'''''''',1x,a20)') nfltcd(i),
     1      valout(attfac(i),ettfac(i),3)
 1030   continue
      endif
C
C==== Output the CIF  diffrn standard loop items
C
      if (numref .gt. 0) then
        write(scfsfl,'(//''loop_ '')')
        write(scfsfl,'(''_diffrn_standard_refln_index_h '')')
        write(scfsfl,'(''_diffrn_standard_refln_index_k '')')
        write(scfsfl,'(''_diffrn_standard_refln_index_l '')')
        write(scfsfl,'(''_diffrn_standard_refln_code '')')
        do 100 j = 1, numref
          write(scfsfl,'(3i5,1x,'''''''',i1,'''''''')')
     1      href(j), kref(j), lref(j), j
 100    continue
      endif
C
C==== Output the CIF radiation wavelength loop items
C
      write(scfsfl,'(//''loop_ '')')
      write(scfsfl,'(''_diffrn_radiation_wavelength '')')
      write(scfsfl,'(''_diffrn_radiation_wavelength_wt '')')
      write(scfsfl,'(''_diffrn_radiation_wavelength_id '')')
      write(scfsfl,'(1x,2f8.5,''  1'')') flam1, weigh1
      write(scfsfl,'(1x,2f8.5,''  2'')') flam2, weigh2 
C
C==== Output the CIF  exptl crystal face loop items
C
      if (crytyp .eq. 'F') then
        write(scfsfl,'(//''loop_ '')')
        write(scfsfl,'(''_exptl_crystal_face_index_h '')')
        write(scfsfl,'(''_exptl_crystal_face_index_k '')')
        write(scfsfl,'(''_exptl_crystal_face_index_l '')')
        write(scfsfl,'(''_exptl_crystal_face_perp_dist '')')
        do 1025 i = 1 , nface
          write(scfsfl,'(3i5,3x,a20)')
     1      hface(i),kface(i),lface(i),valout(dface(i),deface(i),3)
 1025   continue
      endif
C
C==== End of CIF
C
      WRITE(scfsfl,'(//,
     1''#-end-end-end-end-end-end-end-end-end-end-end-end-end-end'')')
C
      return
      end
C
      subroutine set
C
C----- Set up fixed characteristics for CIF output
C
      include 'common.for'
C
      extn = '.cfi'
C
      return
      end
C
      character*20 function valout (v1,v2,i3)
C
C==== A value (V1) and its  su (V2) are formatted into character form 
C     with the necessary number of decimal digits and the  su in 
C     parentheses. numsu controls the number of digits for the  su.
C     A negative value of V2 means no  su is available and V2 gives 
C==== instead the required precision for printing the value.
C
      include 'common.for'
      integer   point, numsu, power, powcur, nzerop, valint, jk
      integer    suint
      integer   i3
      real      v1, v2, value,  su
      logical    suok, positf
C
C==== Initialisations
C
C     Set up the output string and the current position pointer.
      valout = '                    '
      point  = 1
C
C==== Keep the value and its  su.
C
      value  = v1
       su    = v2
      numsu = i3
C
C==== Deal with negative VALUE
C
      if (value.lt.0.0) then
        positf = .false.
        value = abs(value)
      else
        positf = .true.
      endif
C
C==== Test to see if  su is OK. If not do fixes
C
      if ( su.gt.0.0) then
C---- Valid  su given
         suok = .true.
      else if ( su.lt.0.0) then
C---- No  su for this value
         suok = .false.
         su = abs( su)
        numsu = 1
      else
C---- su of 0.0 given print with 6 decimals
         suok = .false.
         su = 0.00001
      endif
C
C==== Set up the POWER to which VALUE must be raised in order to get
C     only the significant digits output.
C
      power = 0
C---- Make value of  su less than 0.4 in the loop
C**** Loop
 3140 if ( su.lt.0.4) go to 3145
        power = power - 1
         su =  su/10.0
        go to 3140
 3145 continue
C**** Bottom of loop
C
C---- Now make rounded integer value of  su greater than numsu in the 
C     loop
       suint = int( su + 0.5)
C**** Loop
 3125 if ( suint.ge.numsu) go to 3135
        power = power + 1
        su  = su *10.0
        suint = int(su + 0.5)
        go to 3125
 3135 continue
C**** Bottom of loop
C
C==== Clean up VALUE and take care of the special case of VALUE zero
C
C---- Save the power and number of non-significant zeroes
      powcur =  power
      nzerop = -power
C---- Raise VALUE to POWER, round and make it a 'clean' real
      valint = nint((10.0**power)*value)
      value =  real(valint) + 0.5
C---- VALUE of zero has only one zero and is not negative
      if (valint.eq.0) then
        nzerop = min0(nzerop,0) + 1
        positf = .true.
      endif
C
C==== Make  VALUE to be fractional (i.e. less than 1.0)
C==== with POWCUR less or equal to zero
C
C**** Loop
 3170 if ((valint.le.0).and.(powcur.le.0)) go to 3180
        powcur = powcur - 1
        value = value/10.0
        valint = int(value)
      go to 3170
 3180 continue
C**** Bottom of Loop
C
C---- Output the sign
      if (.not. positf) then
        valout(point:point) = '-'
        point = point+1
      endif
C
C==== Output the significant digits of VALUE
C
      do 3185 jk = powcur, power-1
        if (jk.eq.0) then
C----   Put in a decimal point if needed here
          if (jk.eq.powcur) then
C----     Put in 0. instead .
            valout(point:point) = '0'
            point = point + 1
          endif
          valout(point:point) = '.'
          point = point + 1
        endif
C----   Get next digit and update parameter
        value = value*10.0
        valint = int(value)
        value = value - real(valint)
        valout(point:point) = digit(valint)
        point = point + 1
 3185 continue
C
C==== Output the non-significant digits of VALUE
C
      do 3225 jk = 1, nzerop
        valout(point:point) = '0'
        point = point + 1
 3225 continue
C
C==== Output the su as (xxx) if present.
C
      if (suok) then
C----   Output the opening parenthesis
        valout(point:point) = '('
        point = point + 1
C----   Save the power
        powcur =  power
C----   Make su clean as its already to correct power
        su =  real(suint) + 0.5
C----   Make su to be fractional (i.e. less than 1.0) in the loop
C**** Loop
 3270 if (suint.le.0) go to 3280
        powcur = powcur - 1
        su = su/10.0
        suint = int(su)
      go to 3270
 3280 continue
C**** Bottom of Loop
C
C==== Output the significant digits of su
C
      do 3285 jk = powcur, power-1
C----   Get next digit and update parameter
        su = su*10.0
        suint = int(su)
        su = su - real(suint)
        valout(point:point) = digit(suint)
        point = point + 1
 3285 continue
C----   Output the non-significant zeroes
        do 3275 jk = 1, -power
          valout(point:point) = '0'
          point = point + 1
 3275   continue
C----   Output the closing parenthesis
        valout(point:point) = ')'
        point = point + 1
      endif
C
      return
      end
