      
!      character(80) prefix,info1
!      prefix='acetone.'
!      info1=' '
!      call qcio2info(prefix,info1)
!      end


      subroutine qcio2info(if_info,ante)
      use mod_qcio
! declarations qcio
      character(2) ante
      character(300) qciofile
      real(8) potnuc,ecore
      logical lex
! declarations program
      character(32),allocatable,dimension(:) :: atom
      character(32),allocatable,dimension(:) :: label
      real(8),allocatable,dimension(:,:) :: coor
      integer,allocatable,dimension(:) :: itsym
      integer norbs(8),frozen(8),delete(8)
      character(1) cote
      integer,allocatable :: isym(:)
      double precision enuc
      !logical,allocatable,dimension(:) :: frozorb
! data
      dimension iuni(2)
      integer(4),dimension(8,8) :: its= reshape(
     *(/1,2,3,4,5,6,7,8,
     *  2,1,4,3,6,5,8,7,
     *  3,4,1,2,7,8,5,6,
     *  4,3,2,1,8,7,6,5,
     *  5,6,7,8,1,2,3,4,
     *  6,5,8,7,2,1,4,3,
     *  7,8,5,6,3,4,1,2,
     *  8,7,6,5,4,3,2,1/),
     *  (/8,8/))
      integer(4),dimension(8,8) :: jtsr= reshape(
     *(/1,  1,  1,  1,  1,  1,  1,  1,
     *  1, -1,  1, -1,  1, -1,  1, -1,
     *  1,  1, -1, -1,  1,  1, -1, -1,
     *  1, -1, -1,  1,  1, -1, -1,  1,
     *  1,  1,  1,  1, -1, -1, -1, -1,
     *  1, -1,  1, -1, -1,  1, -1,  1,
     *  1,  1, -1, -1, -1, -1,  1,  1,
     *  1, -1, -1,  1, -1,  1,  1, -1/),
     *  (/8,8/))
      character,allocatable :: classif(:)
      character(10000) namel
      
!
! init
!
      if(info1==' ')info1=trim(prefix)//'INFO'
      cote=''''
      qciofile=trim(workdir)//trim(prefix)//'qcio'
      inquire(FILE=trim(qciofile)//'/.exists',EXIST=lex)
      if(.not.lex) then
         print*,'************************************'
         print'(2a)','File qcio: ',trim(qciofile)
         print*,'file qcio not found'
         print*,'************************************'
         stop
      endif
      iuni=(/if_info,6/)
!
! init library, open
!
      call qcio_set_file(qciofile)
!

!
! Read Natom,atom,coor
!
      call qcio_get_geometry_num_atom(natom)
      print*,'natom',natom
      allocate(atom(natom))
      call qcio_get_geometry_label(atom)
      allocate(coor(3,natom))
      call qcio_get_geometry_coord(coor)
!
! Back to unique atoms
!
      kk=1
      do k=2,natom
         if(atom(k)/=atom(k-1)) then
            kk=kk+1
            atom(kk)=atom(k)
            coor(:,kk)=coor(:,k)
         endif
      enddo
      natom=kk
      print*,'natom',natom
      print*,'atom',atom(1:natom)
      do k=1,natom
         print*,'coor',coor(:,k)
      enddo
     
         
!
! Read enuc
!
      call qcio_get_geometry_nuc_energy(enuc)
      print*,'enuc',enuc
!
! Read symmetry
!
      call qcio_get_symmetry_num_sym(nsym)
      print*,'nsym',nsym
      allocate(isym(nsym))
      call qcio_get_ao_num_orb_sym(isym)
      print*,'isym',isym
      nao=sum(isym(1:nsym))
      print*,'nao',nao
      allocate(label(nao))
      call qcio_get_ao_label(label)
      do k=1,nao
         print*,'new_label',k,'  ',label(k)
      enddo
      call oldlabel(label,nao)
      do k=1,nao
         print*,'old_label',k,'  ',label(k)
      enddo

      
      
C! pour peter
C      do k=1,natom
C         !print*,'atom1',atom(k)
C         atom(k)=adjustl(atom(k))
C         !print*,'atom2',atom(k)
C      enddo
C      do k=1,nao
C         !print*,'label1',label(k)
C         label(k)(1:4)=adjustl(label(k)(1:4))
C         !print*,'label2',label(k)
C         if(label(k)(5:5)=='S') label(k)(5:6)='1S'
C         if(label(k)(5:6)=='PX') label(k)(5:7)='2PX'
C         if(label(k)(5:6)=='PY') label(k)(5:7)='2PY'
C         if(label(k)(5:6)=='PZ') label(k)(5:7)='2PZ'
C      enddo
C      !print*,'label3',label




C      call oldlabel(label,nao)

!
! Write Namelist &cost_AO
!
 1001 format(a,8(i4,','))
 1003 format(100(1x,5(a1,a4,a1,','),/))
 1002 format(100(1x,5(a1,a8,a1,','),/))
      do iun=1,2
         iunit=iuni(iun)
         print*,'iun',iun,iunit
         write(iunit,'(a)') ' &cost_AO'
         write(iunit,'(a,i4)')' natom=',natom
         write(iunit,'(a)') ' atom='
         write(iunit,1003) (cote,atom(l),cote,l=1,natom)
         write(iunit,'(a,i1)')' nsym=',nsym
         write(iunit,1001) ' isym=',isym(1:nsym)
         write(iunit,'(a6,i5)')' norb=',nao
         write(iunit,'(a)')' coor='
         do l=1,natom
            write(iunit,'(3(f20.10,'',''))') coor(:,l)
         enddo
         write(iunit,'(a,f20.12)') ' enuc=',enuc
         write(iunit,'(a)')' label='
         write(iunit,1002) (cote,label(l),cote,l=1,nao)
         write(iunit,'(a5)')' its='
         do j=1,nsym
            write(iunit,'(6x,8(i1,'',''))') 
     *      (its(i,j),i=1,nsym),(0,i=nsym+1,8)
         enddo
         write(iunit,'(a6)')' jtsr='
         do j=1,nsym
            write(iunit,'(6x,8(i2,'',''))') 
     *      (jtsr(i,j),i=1,nsym),(0,i=nsym+1,8)
         enddo
         write(iunit,'(a2)')' /'
      enddo
      deallocate(isym)
      deallocate(coor)
      deallocate(atom)
      deallocate(label)
!
! Write Namelist &cost_MO
!
      call Qcio_get_MO_num_orb_sym (norbs(1:nsym))
      print*,'norbs',norbs
      call Qcio_get_MO_num_orb_tot (nnorb)
      print*,'nnorb',nnorb
      allocate(itsym(nnorb))
      call Qcio_get_MO_symmetry (itsym)
      print*,'itsym',itsym
      allocate(classif(nnorb))
      call Qcio_get_MO_classif (classif)
      do k=1,nnorb
         print'(a,2i4,a4)','itsym,classif',k,itsym(k),classif(k)
      enddo
      rewind 93
      call LECNAM('&QCIO2CASDI ',namel,93,ierr,1)
      frozen=0
      delete=0
      call namela(namel,frozen(1:nsym),'FROZEN')
      call namela(namel,DELETE(1:nsym),'DELETE')
        print*,'frozen',frozen
        print*,'delete',delete
      noc=0
      do k=1,norb
         if(classif(k)=='c') noc=noc+1
      enddo
      noc=noc-sum(frozen(1:nsym))
      print*,'noc',noc
      call Qcio_get_system_core_energy (potnuc)
      print*,'potnuc',potnuc
C=======
C      call Q5Cost_MO_get_symmetry(file_id,itsym,error)
C      !itsym(kk+1:norb)=0
C      !call Q5Cost_System_get_ref_energy ( file_id, potnuc, error )
C>>>>>>> .r301
C
C      call Q5Cost_Sys_Geometry_set_nuc_energy ( file_id, enuc, error )
C      call Q5Cost_WF_set_core_energy ( file_id, ecore, error )
C      potnuc=ecore+enuc
C      print*,'potnuc',enuc,ecore,potnuc
C
C
C
C
C      do iun=1,2
C         iunit=iuni(iun)
C
C
C
C
C         write(iunit,'(a)') ' &cost_MO'
C         write(iunit,'(a6,i1,a6,i3,a5,i3)')' nsym=',nsym,',norb='
C     *   ,nnorb,',noc=',noc
C         write(iunit,'(a7)') ' itsym='
C         write(iunit,'(1x,20(20(i2,'',''),/,1x))')(itsym(i),i=1,nnorb)
C         write(iunit,'(a6,8(i3,'',''))') ' isym=',norbs(1:nsym)
C         write(iunit,'(a8,8(i3,'',''))') ' frozen=',frozen(1:nsym)
C         write(iunit,'(a8,8(i3,'',''))') ' delete=',delete(1:nsym)
C         write(iunit,'(a6,d20.12)')' enuc=',potnuc
C
C
C
C
C         write(iunit,'(a2)')' /'
C      enddo
!



!
! close library, deinit
!
      return
      end
       subroutine oldlabel(label,norb)
!
! reecriture du label selon l'ancienne forme (les S sont toutes 1s,
! les p toutes 2p, etc...
! utile a partir de molcas 6.7
!
      character(8) label(norb)
      do k=1,norb
         if(label(k)(6:6)=='s') label(k)(5:5)='1'
         if(label(k)(6:6)=='p') label(k)(5:5)='2'
         if(label(k)(6:6)=='d') label(k)(5:5)='3'
         if(label(k)(6:6)=='f') label(k)(5:5)='4'
         if(label(k)(6:6)=='g') label(k)(5:5)='5'
         if(label(k)(6:6)=='h') label(k)(5:5)='6'
         if(label(k)(6:6)=='i') label(k)(5:5)='7'
      enddo
      return
      end
