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


      subroutine q52info(if_info,ante)
      use mod_q5
      use q5cost
! declarations q5
      character(2) ante
      character(300) q5file
      integer(hid_t) file_id
      integer(4) error
      character(32) user_tag
      real(8) potnuc,ecore
      logical lex
! declarations program
      character(4),allocatable,dimension(:) :: atom
      character(8),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
      logical is_frozen,is_core
! 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/))
      
!
! init
!
      if(info1==' ')info1=trim(prefix)//'INFO'
      cote=''''
      q5file=trim(workdir)//trim(prefix)//'q5'
      inquire(FILE=q5file,EXIST=lex)
      if(.not.lex) then
         print*,'************************************'
         print'(2a)','File q5: ',trim(q5file)
         print*,'file q5 not found'
         print*,'************************************'
         stop
      endif
      iuni=(/if_info,6/)
!
! init library, open
!
      call q5cost_init(error)
      call q5cost_file_open(q5file,file_id,error)
!

!
! Read Natom,atom,coor
!
      !call q5cost_geom_get_num_atom(file_id,natom,error)
      call Q5Cost_Sys_Geometry_get_num_atom(file_id,natom,error)
      print*,'natom',natom
      allocate(atom(natom))
      !call q5cost_geom_get_label(file_id,atom,error)
      call Q5Cost_Sys_Geometry_get_label(file_id,atom,error)
      allocate(coor(3,natom))
      !call q5cost_geom_get_coord(file_id,coor,error)
      call Q5Cost_Sys_Geometry_get_coord(file_id,coor,error)
!
! 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 Q5Cost_Sys_Geometry_get_nuc_energy(file_id,enuc,error)
!
! Read symmetry
!
      call Q5Cost_Sys_Symmetry_get_num_sym(file_id,nsym,error)
      allocate(isym(nsym))
      call q5cost_ao_get_num_orb_sym(file_id,isym,error)
      norb=sum(isym(1:nsym))
      allocate(label(norb))
      call Q5Cost_AO_get_label(file_id,label,error)

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




      call oldlabel(label,norb)

!
! 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=',norb
         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,norb)
         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
!
! Write Namelist &cost_MO
!
      user_tag = "default"
      call Q5Cost_MO_get_num_orb_sym 
     *( file_id, norbs(1:nsym), error, user_tag )
      print*,'norbs',norbs
      call Q5Cost_MO_get_num_orb_tot 
     *( file_id, nnorb, error, user_tag )
      print*,'nnorb',nnorb
      allocate(itsym(norb))
      call Q5Cost_MO_get_symmetry ( file_id, itsym, error, user_tag )
      print*,'itsym',itsym
      frozen=0
      delete=0
      do k=1,norb
         call Q5Cost_MO_is_frozen 
     *   ( file_id, k, is_frozen, error, user_tag )
         print*,'is_frozen',k,is_frozen
         if(is_frozen) then
            is=itsym(k)
            call Q5Cost_MO_is_core 
     *      ( file_id, k, is_core, error, user_tag )
            if(is_core) then
               frozen(is)=frozen(is)+1
            else
               delete(is)=delete(is)+1
            endif
         endif
      enddo
        print*,'frozen',frozen
        print*,'delete',delete
      noc=0
      do k=1,norb
         call Q5Cost_MO_is_core 
     *   ( file_id, k, is_core, error, user_tag )
         if(is_core) noc=noc+1
         print*,'is_core',k,is_core
      enddo
      kk=0
      do k=1,norb
         call Q5Cost_MO_is_frozen 
     *   ( file_id, k, is_frozen, error, user_tag )
         if(is_frozen) cycle
         kk=kk+1
         itsym(kk)=k
      enddo
      call Q5Cost_MO_get_symmetry(file_id,itsym,error)
      !itsym(kk+1:norb)=0
      !call Q5Cost_System_get_ref_energy ( file_id, potnuc, error )

      call Q5Cost_Sys_Geometry_set_nuc_energy ( file_id, enuc, error )
      call Q5Cost_WF_set_core_energy ( file_id, ecore, error )
      potnuc=ecore+enuc
      print*,'potnuc',enuc,ecore,potnuc




      do iun=1,2
         iunit=iuni(iun)




         write(iunit,'(a)') ' &cost_MO'
         write(iunit,'(a6,i1,a6,i3,a5,i3)')' nsym=',nsym,',norb='
     *   ,nnorb,',noc=',noc
         write(iunit,'(a7)') ' itsym='
         write(iunit,'(1x,20(20(i2,'',''),/,1x))')(itsym(i),i=1,nnorb)
         write(iunit,'(a6,8(i3,'',''))') ' isym=',norbs(1:nsym)
         write(iunit,'(a8,8(i3,'',''))') ' frozen=',frozen(1:nsym)
         write(iunit,'(a8,8(i3,'',''))') ' delete=',delete(1:nsym)
         write(iunit,'(a6,d20.12)')' enuc=',potnuc




         write(iunit,'(a2)')' /'
      enddo
!



!
! close library, deinit
!
      call q5cost_file_close(file_id,error)
      call q5cost_deinit(error)
      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
