      program convert2fast
c     convert madnes or eval data file(s) to standard fast file
c     syntax : CONVERT2FAST outputfilename inputfilenames
c
c     inputfilenames may contain wild characters
c
c---- format of output file:
c
c     !! BEGIN
c     !! DIST ....
c     !! SWING ....
c     !! DATUM ....
c     !! LAMBDA ....
c     !! CELL .....
c     !! ORIENT1 ....
c     !! ORIENT2 ....
c     !! ORIENT3 ....
c     !! MISSET ....
c     !! SCAN ...
c     !! ROT ....
c     !! INC ....
c     !! TIME ....
c     !!_END
c     h,k,l,I,SigI,Code,YmsObs,ZmsObs,RotObs
c       h,k,l = indices
c       I     = Intensity or F       (depending on IntOpt)
c       SigI  = Sigma Intensity or F (depending on IntOpt)
c       Code  = error code
c       YmsObs = Observed Y_Mass_store
c       ZmsObs = Observed Z_Mass_store
c       RotObs = Observed Rotation angle
c
c     if BgSd/BgAvg > 1.0 then
c       reflection is written to file 'inputname'.ERR and never used.
      implicit  none
      character title*80
      character comment_1*80
      character comment_2*80
      character comment_3*80
      character deri*4
      character xtal*4
      character nuffil*80
      character wrtfil*80
      character intfil*80
      integer   intopt
      character template*80
      character xdfile*80
      common /madnes_madnes/ title,comment_1,comment_2,comment_3,deri,
     1 xtal,nuffil,wrtfil,intfil,intopt,template,xdfile
 
      character det_spdfil*80
      integer   det_hvca
      integer   det_hvii
      integer   det_adcz
      integer   det_adcr
      integer   det_bls
      integer   det_setdet(5)
      real      det_theta
      real      det_dist
      real      det_omega,det_kappa,det_phi
      real      det_datum(3)
      real      det_gain
      integer   det_ovfl
      integer   det_dcpos(4)
      real      det_dcflim
      real      det_beterr
      equivalence (det_hvca,det_setdet(1))
      equivalence (det_omega,det_datum(1))
      common /madnes_det/ det_spdfil,det_hvca,det_hvii,det_adcz,
     1 det_adcr,det_bls,det_theta,det_dist,det_omega,det_kappa,
     2 det_phi,det_gain,det_ovfl,det_dcpos,det_dcflim,det_beterr
 
      character header_kv*80
      character header_ma*80
      character header_Atten*80
      character header_focal*80
      character header_collim*80
      character header_mono*80
      character header_data*80
      character header_anal*80
      character header_user*80
      character header_site*80
      common /madnes_header/ header_kv,header_ma,header_Atten,
     1 header_focal,header_collim,header_mono,header_data,
     2 header_anal,header_user,header_site
 
      character bnl_ionfil*80
      real      bnl_time
      real      bnl_satrat
      common /madnes_bnl/ bnl_ionfil,bnl_time,bnl_satrat
 
      integer   find_limits(4)
      integer   find_neigh(2)
      integer   find_pkcrit(3)
      real      find_sigma
      integer   find_cutoff
      real      find_rot(2)
      real      find_inc
      real      find_time
      integer   find_nuftyp(2)
      integer   find_filnum(2)
      common /madnes_find/ find_limits,find_neigh,find_pkcrit,
     1 find_sigma,find_cutoff,find_rot,find_inc,find_time,
     2 find_nuftyp,find_filnum
 
      real       predict_cell(6)
      integer    predict_spcgrp
      integer    predict_axes(3)
      real       predict_misset(3)
      real       predict_camera(3)
      real       predict_dist
      real       predict_tau(3)
      real       predict_mu(2)
      real       predict_eps
      real       predict_lambda
      real       predict_dispr
      real       predict_polarz(4)
      real       predict_syn(4)
      real       predict_reso
      real       predict_rmin
      real       predict_rmax
      real       predict_wmax
      real       predict_rot(2)
      real       predict_setovl(3)
      real       predict_amat(3,3)
      common /madnes_predict/ predict_cell,predict_spcgrp,predict_axes,
     1 predict_misset,predict_camera,predict_dist,predict_tau,
     2 predict_mu,predict_eps,predict_lambda,predict_dispr,
     3 predict_polarz,predict_syn,predict_reso,predict_rmin,
     4 predict_rmax,predict_wmax,predict_rot,predict_setovl,
     5 predict_amat
 
      real       refine_rejlim(3)
      real       refine_reso(2)
      real       refine_rmschk(2)
      integer    refine_keep
      integer    refine_ncyc
      real       refine_lsweigh(3)
      real       refine_sigcut
      integer    refine_nnofix
      character  refine_nofix(19)*4
      integer    refine_nfix
      character  refine_fix(19)*4
      common /madnes_refine/ refine_rejlim,refine_reso,refine_rmschk,
     1 refine_keep,refine_ncyc,refine_lsweigh,refine_sigcut,
     2 refine_nnofix,refine_nofix,refine_nfix,refine_fix
 
      real       orient_v1(3)
      real       orient_v2(3)
      real       orient_l1(3)
      real       orient_l2(3)
      character  orient_mode*4
      common /madnes_orient/ orient_v1,orient_v2,orient_l1,orient_l2,
     1 orient_mode
 
      character  collect_scan*20
      real       collect_rot(2)
      real       collect_inc
      real       collect_time
      integer    collect_dark(2)
      integer    collect_filnum(2)
      integer    collect_nuftyp(2)
      integer    collect_eval
      real       collect_eval_data(3)
      integer    collect_recent(2)
      integer    collect_size(2)
      real       collect_batch
      integer    collect_pad(2)
      real       collect_wait
      real       collect_sub
      real       collect_exptim
      integer    collect_bord(3)
      real       collect_errlim_yms
      real       collect_errlim_zms
      real       collect_errlim_rot
      real       collect_errlim_bg
      real       collect_errlim_bg_sd
      integer    collect_errlim_bogus
      real       collect_errlim_ratio
      integer    collect_errlim_spot(2)
      integer    collect_smooth
      integer    collect_mask(4)
      integer    collect_bktype(2)
      integer    collect_dump
      real       collect_sdfact
 
      common /madnes_collect/ collect_scan,collect_rot,collect_inc,
     1 collect_time,collect_dark,collect_filnum,
     2 collect_nuftyp,collect_eval,collect_eval_data,collect_recent,
     3 collect_size,collect_batch,collect_pad,collect_wait,collect_sub,
     4 collect_exptim,collect_bord,collect_errlim_yms,
     5 collect_errlim_zms,collect_errlim_rot,collect_errlim_bg,
     6 collect_errlim_bg_sd,collect_errlim_bogus,collect_errlim_ratio,
     7 collect_errlim_spot,collect_smooth,collect_mask,collect_bktype,
     8 collect_dump,collect_sdfact
c---- functions
      integer   length
      integer   lenstr
c---- local vars
      character filename*80
      integer   lf
      integer   dir_error
      character infile*80
      integer   li
      character outfile*80
      integer   lo
      integer   nd
      integer   iostat
      integer   h,k,l
      integer   i
      integer   netint,sigint
      real      f,sigf
      integer   n,ntot
      character line*80
      integer   oldintopt
      integer   idum,code
      character HVCA*1
      character HVII*1
      integer   bgavg,bgsd
      integer   nbgsd,nbgsd_tot
      integer   ier
      real      q
      real      ymsobs,zmsobs,rotobs
      logical   handle_header
      logical   eval_file
      logical   madnes_file
      character filetype*10
      integer   lft
      integer   nr
      real      intensity
      real      lp
      integer   neti
      real      sigi
      character message*256
      character header_file*80
      integer   lh
      character edge*6
      character bad*1
      character ovf*1
      real      wght
      real      deth,detv,rot
      integer   pq
      real      empirical_msu
      real      sx,sy,sz
      integer   u_out,u_in
 
      call finish(-6)
      call str_unit(6)
      empirical_msu = 0.1
      HVCA = '?'
      HVII = '?'
      call get_commandline
      call get_inp(outfile,nd,'Enter FAST file to create',*990)
      call build_file(outfile,'FAST','.FAST',outfile,lo)
      oldintopt = -1
      intopt = -1
      call create_file(outfile(1:lo),u_out,message,iostat)
      call str_write(6,message)
      if(iostat.ne.0) goto 990
      call begin(u_out)
      ntot = 0
c
c---- next input filename from input
c
10    continue
      call get_inp(filename,nd,'Madnes/Eval output file(s) / EXIT ',
     1 *900)
      if(filename.eq.'EXIT') goto 900
      call build_file(filename,' ','.DAT',filename,lf)
      call filescan(filename,'TYPE',filetype,lft)
      eval_file = (filetype(2:4).eq.'EVA')
      madnes_file = .not. eval_file
      call str_logical_out(eval_file,'Eval_file=#')
      call str_logical_out(madnes_file,'Madnes_file=#')
      call str_flush
      call directory(0,filename,infile,dir_error)
      if(dir_error.ne.0) then
        call str_write(6,' No such file '//filename(1:lf))
        call directory(-1,filename,infile,dir_error)
        goto 10
      endif
      call read_header(infile,eval_file,u_out,hvca,hvii,message,ier)
      call str_write(6,message)
      if(ier.ne.0) goto 990
c
c---- next wild character expanded filename
c
      nbgsd_tot = 0
      do while(dir_error.eq.0)
        n = 0
        nbgsd = 0
        li = length(infile)
        call open_file(infile(1:li),u_in,message,iostat)
        call str_write(6,message)
        if(iostat.ne.0) goto 10
        read (u_in,100,iostat=iostat) line
100     format(a)
        if(madnes_file) then
          if(line(1:10).eq.' ! !!! Sta') then
            handle_header = .true.
          else
            call str_write(6,'No header found. Reading reflections...')
            handle_header = .false.
            rewind 1
          endif
c
c---  -   next block of data from same file
c
30        continue
          if(handle_header) then
            call read_sav_block(u_in,message,ier)
            if(ier.ne.0) then
              call str_write(6,message)
              goto 990
            endif
            if(oldintopt.eq.-1) then
              oldintopt = intopt
              if(intopt.eq.1.or.intopt.eq.3) then
                call str_integer_write(6,intopt,'Intopt=#'//
     1           ' Input data hkl F SigF')
                call str_write(6,
     1           'Change mad2dist format for intopt 1 and 3')
                ier = 1
                goto 990
              else if(intopt.eq.2.or.intopt.eq.4) then
                call str_integer_write(6,intopt,'Intopt=#'//
     1           ' Input data hkl I SigI')
              else
                call str_write(6,'Unknown intopt')
                close(u_in)
                goto 10
              endif
            else
              if(oldintopt.ne.intopt) then
                call str_integer_write(6,intopt,
     1           'Intopt=# Mixed I and F data')
                close(u_in)
                goto 10
              endif
            endif
            write (hvca,130) det_hvca
            write (hvii,130) det_hvii
130         format(i1)
          endif ! handle_header
        else ! i.e. eval file
          do while(line(1:6).ne.'!!_END')
            read(u_in,100,iostat=iostat) line
            if(iostat.ne.0) then
              call str_write(6,'Premature end-of-file')
              ier = 1
              goto 990
            endif
          enddo
        endif
        if(madnes_file) then
          if(intopt.eq.1.or.intopt.eq.3) then
            read(u_in,140,iostat=iostat) h,k,l,f,sigf,bgavg,bgsd,code,
     1       ymsobs,zmsobs,rotobs
140         format(3i5,4f9.2,i6,15x,2f6.1,f9.3)
             do while(iostat.eq.0)
              n = n + 1
c              if(mod(n,1000).eq.0) write (6,660) n
c660           format('+',i5)
              if(bgavg.gt.0) then
                q = abs(float(bgsd)/bgavg)
              else
                q = 0.0
              endif
              if(q.gt.1.0) then
                code = (code.or.2048)
                nbgsd = nbgsd + 1
              endif
              write(u_out,200) n,h,k,l,f,sigf,
     1         code,ymsobs,zmsobs,rotobs
200           format(i5,3i5,2(1x,f8.2),1x,i6,2(1x,f6.1),1x,f9.3)
              read(u_in,140,iostat=iostat) h,k,l,f,sigf,bgavg,bgsd,code,
     1         ymsobs,zmsobs,rotobs
            enddo
          else if(intopt.eq.2.or.intopt.eq.4) then
            read(u_in,120,iostat=iostat) h,k,l,netint,sigint,
     1       bgavg,bgsd,code,ymsobs,zmsobs,rotobs
120         format(3i5,4i9,i6,2f6.1,f9.3)
            do while(iostat.eq.0)
              n = n + 1
c              if(mod(n,1000).eq.0) write (6,660) n
              if(bgavg.gt.0) then
                q = abs(float(bgsd)/bgavg)
              else
                q = 0.0
              endif
              if(q.gt.1.0) then
                code = (code.or.2048)
                nbgsd = nbgsd + 1
              endif
              write(u_out,200) n,h,k,l,0.01*netint,0.01*sigint,
     1         code,ymsobs,zmsobs,rotobs
              read(u_in,120,iostat=iostat) h,k,l,netint,sigint,bgavg,
     1         bgsd,code,ymsobs,zmsobs,rotobs
            enddo
          else
            call str_write(6,'Intopt unknown')
            ier = 1
            goto 990
          endif ! intopt
          if(iostat.eq.64) then   ! format error during read
c----       there is more
            handle_header = .true.
            goto 30
          endif
        else
c         1         2         3         4         5         6         7
c123456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789
c   nr   h   k   l   DetH   DetV   Rot      LP   Int wght   PQ obxXyYzZ  ShX  Sh
c    1  -2   6 -16  -5.92   8.05   0.80 0.6025   172 12.5   14 ........  0.1  0.
c    2   0   4 -13   0.81   1.61   0.99 0.4424   398 12.8   31 ........  0.2  0.
c    3   1   3 -13   2.28  -2.24   1.00 0.4092   951 15.4   62 ........  0.7 -0.
c    4  -1   5 -14  -1.89   5.02   1.01 0.5053  1991 14.0  142 ........  0.2 -0.
c    5   2   2 -14   2.52  -6.63   1.06 0.4037 24314 30.4  800 o....... -0.1  0.
 
 
          read(u_in,110,iostat=iostat) nr,h,k,l,deth,detv,rot,lp,neti,
     1     wght,pq,sx,sy,sz,ovf,bad,edge
110       format(i5,3i4,3f7.2,f7.4,i6,f6.1,i5,2f5.1,f6.2,1x,a1,a1,a)
          do while(iostat.eq.0)
            n = n + 1
c            if(mod(n,1000).eq.0) write (6,660) n
c660         format('+',i5)
            if(pq.lt.30) then
              code = 1
            else
              code = 0
            endif
            intensity = lp*neti*empirical_msu
            sigi = lp*wght*empirical_msu
            if(ovf.ne.'.') code = code .or. 32768
            if(bad.eq.'B') then
              code = code .or. 16384
            else if(bad.ne.'.') then
              code = code .or. 4096
            endif
            call make_code(edge(1:2),256,4,code)
            call make_code(edge(3:4),128,2,code)
            call make_code(edge(5:6),512,8,code)
            write(u_out,200) nr,h,k,l,Intensity,sigi,code,
     1       deth,detv,rot
            read(u_in,110,iostat=iostat) nr,h,k,l,deth,detv,rot,lp,neti,
     1       wght,pq,sx,sy,sz,ovf,bad,edge
          enddo
        endif
        close(u_in)
        call str_unit(6)
        call str_num_out(n,'# reflection^ processed.')
        call str_num(n,'# reflection^ from '//infile(1:li),line)
        call log_add(line)
        if(nbgsd.gt.0) then
          call str_num(nbgsd,
     1     '# reflection^ with bad background. Added error code 2048',
     2     line)
          call str_out(line)
          call log_add(line)
        endif
        call str_flush
        ntot = ntot + n
        nbgsd_tot = nbgsd_tot + nbgsd
        call str_num_out(ntot,'total # reflection^ processed.')
        if(nbgsd_tot.gt.0) then
          call str_num_out(nbgsd_tot,
     1     'total # reflection^ with bad background.')
        endif
        call str_flush
        call directory(1,filename,infile,dir_error)
      enddo ! while(dir_error.eq.0)
      call directory(-1,filename,infile,dir_error)
      goto 10
900   continue
      call set_symbol('HVCA',HVCA)
      call set_symbol('HVII',HVII)
      ier = 0
990   continue
      call log_close(ier)
      call finish(6)
      if(ier.eq.0) then
        call exit(1)
      else
        call exit(2)
      endif
      end
 
      subroutine make_code(s,big,edge,code)
      character s*2
      integer   big
      integer   edge
      integer   code
      if(s(1:1).ne.'.'.and.s(2:2).ne.'.') then
        code = code .or. big
      else if(s(1:1).ne.'.'.or.s(2:2).ne.'.') then
        code = code .or. edge
      endif
      return
      end
 
      subroutine read_header(filename,eval_file,out,hvca,hvii,message,
     1 ier)
      character filename*(*)
      logical   eval_file
      integer   out
      character hvca*(*)
      character hvii*(*)
      character message*(*)
      integer   ier
      character title*80
      character comment_1*80
      character comment_2*80
      character comment_3*80
      character deri*4
      character xtal*4
      character nuffil*80
      character wrtfil*80
      character intfil*80
      integer   intopt
      character template*80
      character xdfile*80
      common /madnes_madnes/ title,comment_1,comment_2,comment_3,deri,
     1 xtal,nuffil,wrtfil,intfil,intopt,template,xdfile
 
      character det_spdfil*80
      integer   det_hvca
      integer   det_hvii
      integer   det_adcz
      integer   det_adcr
      integer   det_bls
      integer   det_setdet(5)
      real      det_theta
      real      det_dist
      real      det_omega,det_kappa,det_phi
      real      det_datum(3)
      real      det_gain
      integer   det_ovfl
      integer   det_dcpos(4)
      real      det_dcflim
      real      det_beterr
      equivalence (det_hvca,det_setdet(1))
      equivalence (det_omega,det_datum(1))
      common /madnes_det/ det_spdfil,det_hvca,det_hvii,det_adcz,
     1 det_adcr,det_bls,det_theta,det_dist,det_omega,det_kappa,
     2 det_phi,det_gain,det_ovfl,det_dcpos,det_dcflim,det_beterr
 
      character header_kv*80
      character header_ma*80
      character header_Atten*80
      character header_focal*80
      character header_collim*80
      character header_mono*80
      character header_data*80
      character header_anal*80
      character header_user*80
      character header_site*80
      common /madnes_header/ header_kv,header_ma,header_Atten,
     1 header_focal,header_collim,header_mono,header_data,
     2 header_anal,header_user,header_site
 
      character bnl_ionfil*80
      real      bnl_time
      real      bnl_satrat
      common /madnes_bnl/ bnl_ionfil,bnl_time,bnl_satrat
 
      integer   find_limits(4)
      integer   find_neigh(2)
      integer   find_pkcrit(3)
      real      find_sigma
      integer   find_cutoff
      real      find_rot(2)
      real      find_inc
      real      find_time
      integer   find_nuftyp(2)
      integer   find_filnum(2)
      common /madnes_find/ find_limits,find_neigh,find_pkcrit,
     1 find_sigma,find_cutoff,find_rot,find_inc,find_time,
     2 find_nuftyp,find_filnum
 
      real       predict_cell(6)
      integer    predict_spcgrp
      integer    predict_axes(3)
      real       predict_misset(3)
      real       predict_camera(3)
      real       predict_dist
      real       predict_tau(3)
      real       predict_mu(2)
      real       predict_eps
      real       predict_lambda
      real       predict_dispr
      real       predict_polarz(4)
      real       predict_syn(4)
      real       predict_reso
      real       predict_rmin
      real       predict_rmax
      real       predict_wmax
      real       predict_rot(2)
      real       predict_setovl(3)
      real       predict_amat(3,3)
      common /madnes_predict/ predict_cell,predict_spcgrp,predict_axes,
     1 predict_misset,predict_camera,predict_dist,predict_tau,
     2 predict_mu,predict_eps,predict_lambda,predict_dispr,
     3 predict_polarz,predict_syn,predict_reso,predict_rmin,
     4 predict_rmax,predict_wmax,predict_rot,predict_setovl,
     5 predict_amat
 
      real       refine_rejlim(3)
      real       refine_reso(2)
      real       refine_rmschk(2)
      integer    refine_keep
      integer    refine_ncyc
      real       refine_lsweigh(3)
      real       refine_sigcut
      integer    refine_nnofix
      character  refine_nofix(19)*4
      integer    refine_nfix
      character  refine_fix(19)*4
      common /madnes_refine/ refine_rejlim,refine_reso,refine_rmschk,
     1 refine_keep,refine_ncyc,refine_lsweigh,refine_sigcut,
     2 refine_nnofix,refine_nofix,refine_nfix,refine_fix
 
      real       orient_v1(3)
      real       orient_v2(3)
      real       orient_l1(3)
      real       orient_l2(3)
      character  orient_mode*4
      common /madnes_orient/ orient_v1,orient_v2,orient_l1,orient_l2,
     1 orient_mode
 
      character  collect_scan*20
      real       collect_rot(2)
      real       collect_inc
      real       collect_time
      integer    collect_dark(2)
      integer    collect_filnum(2)
      integer    collect_nuftyp(2)
      integer    collect_eval
      real       collect_eval_data(3)
      integer    collect_recent(2)
      integer    collect_size(2)
      real       collect_batch
      integer    collect_pad(2)
      real       collect_wait
      real       collect_sub
      real       collect_exptim
      integer    collect_bord(3)
      real       collect_errlim_yms
      real       collect_errlim_zms
      real       collect_errlim_rot
      real       collect_errlim_bg
      real       collect_errlim_bg_sd
      integer    collect_errlim_bogus
      real       collect_errlim_ratio
      integer    collect_errlim_spot(2)
      integer    collect_smooth
      integer    collect_mask(4)
      integer    collect_bktype(2)
      integer    collect_dump
      real       collect_sdfact
 
      common /madnes_collect/ collect_scan,collect_rot,collect_inc,
     1 collect_time,collect_dark,collect_filnum,
     2 collect_nuftyp,collect_eval,collect_eval_data,collect_recent,
     3 collect_size,collect_batch,collect_pad,collect_wait,collect_sub,
     4 collect_exptim,collect_bord,collect_errlim_yms,
     5 collect_errlim_zms,collect_errlim_rot,collect_errlim_bg,
     6 collect_errlim_bg_sd,collect_errlim_bogus,collect_errlim_ratio,
     7 collect_errlim_spot,collect_smooth,collect_mask,collect_bktype,
     8 collect_dump,collect_sdfact
c---- functions
      integer   lenstr
c---- local vars
      integer   in
      character savfile*80
      integer   ls
      character line*80
      character string*80
      integer   i
      character new_format*80
 
      new_format = '!! FORMAT h k l Int Sig Error Hor Ver Rot'
      savfile = filename
      ls = lenstr(savfile)
      if(eval_file) then
        call open_file(savfile(1:ls),in,message,ier)
        call str_write(6,message)
        if(ier.ne.0) return
        read(in,100,iostat=ier) line
        if(ier.ne.0) goto 900
        if(line(1:8).ne.'!!_BEGIN') then
          message = 'No BEGIN header found'
          close(in)
          ier = 1
          return
        endif
        read(in,100,iostat=ier) line
        if(ier.ne.0) goto 900
        do while(line(1:6).ne.'!!_END')
          if(line(1:9).ne.'!! FORMAT') then
            write(out,100) line(1:lenstr(line))
          endif
          if(line(1:9).eq.'!! SETDET') then
            call str_extract(line,3,HVCA)
            call str_extract(line,4,HVII)
          endif
          read(in,100,iostat=ier) line
          if(ier.ne.0) goto 900
        enddo
        write (out,100) new_format(1:lenstr(new_format))
        write(out,100) line(1:lenstr(line))
        message = 'HVCA '//hvca//' HVII '//hvii
        close(in)
        ier = 0
        return
      else
        call read_sav(savfile,message,ier)
        if(ier.ne.0) return
        call str_2integer_write(out,det_hvca,det_hvii,
     1   '!! HVCA # HVII #')
        write (hvca,110) det_hvca
110     format(i1)
        write (hvii,110) det_hvii
        call str_real_len(2)
        call str_real_write(out,predict_dist,'!! DIST')
        call str_real_write(out,predict_tau(2),'!! SWING')
        call str_vector_write(out,det_datum,'!! DATUM')
        call str_real_len(5)
        call str_real_write(out,predict_lambda,'!! LAMBDA')
        call str_real_len(4)
        call str_array_write(out,6,predict_cell,'!! CELL')
        call str_vector_write(out,predict_misset,'!! MISSET')
        call str_matrix_write(out,predict_amat,
     1   '!! ORIENT1','!! ORIENT2','!! ORIENT3')
        call str_write(out,'!! SCAN '//collect_scan)
        write (out,100) new_format(1:lenstr(new_format))
100     format(a)
        call str_write(out,'!!_END')
        message = 'HVCA '//hvca//' HVII '//hvii
        ier = 0
        return
      endif
900   continue
      message = 'Premature end-of-file in '//savfile
      close(in)
      ier = 1
      return
      end
