mirror of
https://github.com/LCPQ/quantum_package
synced 2024-12-23 12:56:14 +01:00
140 lines
5.1 KiB
Fortran
140 lines
5.1 KiB
Fortran
program print_mos
|
|
implicit none
|
|
character*(128) :: output
|
|
integer :: i_unit_output,getUnitAndOpen
|
|
provide ezfio_filename
|
|
|
|
integer :: i
|
|
print*,trim(ezfio_filename)
|
|
output=trim(ezfio_filename)//'.mol'
|
|
print*,'output = ',trim(output)
|
|
i_unit_output = getUnitAndOpen(output,'w')
|
|
print*,'i_unit_output = ',i_unit_output
|
|
call write_intro_gamess(i_unit_output)
|
|
call write_geometry(i_unit_output)
|
|
call write_Ao_basis(i_unit_output)
|
|
call write_Mo_basis(i_unit_output)
|
|
|
|
|
|
write(i_unit_output,*),''
|
|
write(i_unit_output,*),''
|
|
write(i_unit_output,*)' ------------------------'
|
|
|
|
close(i_unit_output)
|
|
end
|
|
|
|
subroutine write_intro_gamess(i_unit_output)
|
|
implicit none
|
|
integer, intent(in) :: i_unit_output
|
|
integer :: i,j,k,l
|
|
|
|
write(i_unit_output,*)' * GAMESS VERSION = 22 FEB 2006 (R5) *'
|
|
write(i_unit_output,*)' * FROM IOWA STATE UNIVERSITY *'
|
|
write(i_unit_output,*)' * M.W.SCHMIDT, K.K.BALDRIDGE, J.A.BOATZ, S.T.ELBERT, *'
|
|
write(i_unit_output,*)' * M.S.GORDON, J.H.JENSEN, S.KOSEKI, N.MATSUNAGA, *'
|
|
write(i_unit_output,*)' * K.A.NGUYEN, S.J.SU, T.L.WINDUS, *'
|
|
write(i_unit_output,*)' * TOGETHER WITH M.DUPUIS, J.A.MONTGOMERY *'
|
|
write(i_unit_output,*)' * J.COMPUT.CHEM. 14, 1347-1363(1993) *'
|
|
write(i_unit_output,*)''
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
subroutine write_geometry(i_unit_output)
|
|
implicit none
|
|
integer, intent(in) :: i_unit_output
|
|
integer :: i,j,k,l, getUnitAndOpen
|
|
|
|
|
|
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
write(i_unit_output,*)'ATOM ATOMIC COORDINATES (BOHR) '
|
|
write(i_unit_output,*)' CHARGE X Y Z'
|
|
do i = 1, nucl_num
|
|
! write(i_unit_output,'(A2 I3 X F3.1 X 3(F16.10))') trim(element_name(int(nucl_charge(i)))),i,(nucl_charge(i)), nucl_coord(i,1), nucl_coord(i,2), nucl_coord(i,3)
|
|
write(i_unit_output,'(A2,I1, 9X F5.1 X 3(F16.10 ,4X))') trim(element_name(int(nucl_charge(i)))),i,(nucl_charge(i)), nucl_coord(i,1), nucl_coord(i,2), nucl_coord(i,3)
|
|
enddo
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
end
|
|
|
|
|
|
subroutine write_Ao_basis(i_unit_output)
|
|
implicit none
|
|
integer, intent(in) :: i_unit_output
|
|
integer :: i,j,k,l, getUnitAndOpen
|
|
character*(128) :: character_shell
|
|
integer :: i_shell,i_prim,i_ao
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
write(i_unit_output,*)''
|
|
write(i_unit_output,*)''
|
|
write(i_unit_output,*)' ATOMIC BASIS SET'
|
|
write(i_unit_output,*)' ----------------'
|
|
write(i_unit_output,*)'THE CONTRACTED PRIMITIVE FUNCTIONS HAVE BEEN UNNORMALIZED'
|
|
write(i_unit_output,*)'THE CONTRACTED BASIS FUNCTIONS ARE NOW NORMALIZED TO UNITY'
|
|
write(i_unit_output,*)''
|
|
write(i_unit_output,*)'SHELL TYPE PRIMITIVE EXPONENT CONTRACTION COEFFICIENT(S)'
|
|
write(i_unit_output,*)''
|
|
write(i_unit_output,*)''
|
|
|
|
i_shell = 0
|
|
i_prim = 0
|
|
do i = 1, Nucl_num
|
|
write(i_unit_output,'(A2,I1)') trim(element_name(int(nucl_charge(i)))),i
|
|
write(i_unit_output,*)' '
|
|
! write(i_unit_output,*)'Nucl_num_shell_Aos(i) = ',Nucl_num_shell_Aos(i)
|
|
do j = 1, Nucl_num_shell_Aos(i)
|
|
i_shell +=1
|
|
i_ao = Nucl_list_shell_Aos(i,j)
|
|
character_shell = trim(ao_l_char(i_ao))
|
|
! write(i_unit_output,*),j,i_shell,i_ao!trim(character_shell)
|
|
do k = 1, ao_prim_num(i_ao)
|
|
i_prim +=1
|
|
if(i_prim.lt.100)then
|
|
write(i_unit_output,'(4X,I3,3X,A1,6X,I2,6X,F16.7,2X,F16.12)')i_shell,character_shell,i_prim,ao_expo(i_ao,k),ao_coef(i_ao,k)
|
|
else
|
|
write(i_unit_output,'(4X,I3,3X,A1,5X,I3,6X,F16.7,2X,F16.12)')i_shell,character_shell,i_prim,ao_expo(i_ao,k),ao_coef(i_ao,k)
|
|
endif
|
|
enddo
|
|
write(i_unit_output,*)''
|
|
enddo
|
|
enddo
|
|
|
|
write(i_unit_output,*)''
|
|
write(i_unit_output,'(A47,2X,I3)')'TOTAL NUMBER OF BASIS SET SHELLS =', i_shell
|
|
write(i_unit_output,'(A47,2X,I3)')'NUMBER OF CARTESIAN GAUSSIAN BASIS FUNCTIONS =', ao_num
|
|
! this is for the new version of molden
|
|
write(i_unit_output,'(A12)')'PP =NONE'
|
|
write(i_unit_output,*)''
|
|
|
|
|
|
end
|
|
|
|
subroutine write_Mo_basis(i_unit_output)
|
|
implicit none
|
|
integer, intent(in) :: i_unit_output
|
|
integer :: i,j,k,l, getUnitAndOpen
|
|
integer :: i_5,i_mod
|
|
|
|
write(i_unit_output,*),' ----------------------'
|
|
write(i_unit_output,*),' MCSCF NATURAL ORBITALS'
|
|
write(i_unit_output,*),' ----------------------'
|
|
write(i_unit_output,*),' '
|
|
|
|
do j = 1, mo_tot_num
|
|
write(i_unit_output,'(18X,I3)')j
|
|
write(i_unit_output,*)''
|
|
write(i_unit_output,'(18X,F8.5)')-1.d0
|
|
write(i_unit_output,*)''
|
|
do i = 1, ao_num
|
|
! write(i_unit_output,'(2X,I3, 2X A1, I3, 2X A4 , F9.6)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i)),mo_coef(i,j)
|
|
! F12.6 for larger coefficients...
|
|
write(i_unit_output,'(2X,I3, 2X A1, I3, 2X A4 , F12.6)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i)),mo_coef(i,j)
|
|
! write(i_unit_output,'(I3, X A1, X I3, X A4 X F16.8)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i))
|
|
enddo
|
|
write(i_unit_output,*)''
|
|
enddo
|
|
|
|
end
|