9
1
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-10-07 00:25:57 +02:00
qp2/src/tools/molden.irp.f
2019-01-25 11:39:31 +01:00

143 lines
5.5 KiB
Fortran

program molden
implicit none
BEGIN_DOC
! Produce a Molden file
END_DOC
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_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