! -*- F90 -*- ! !-----------------------------------------------! ! This file was generated with the irpf90 tool. ! ! ! ! DO NOT MODIFY IT BY HAND ! !-----------------------------------------------! module xmatel_mod integer :: nexmx logical :: nexmx_is_built = .False. integer :: nexmx_double integer :: nocc logical :: nocc_is_built = .False. integer, allocatable :: ileft(:) logical :: ileft_is_built = .False. integer, allocatable :: iright(:) integer, allocatable :: ispinl(:) integer, allocatable :: ispinr(:) integer, allocatable :: itypel(:) integer, allocatable :: ityper(:) integer, allocatable :: ileft2(:) integer, allocatable :: iright2(:) integer, allocatable :: iholes(:) character*1, allocatable :: csign(:) logical :: csign_is_built = .False. character*8 :: pname end module xmatel_mod subroutine provide_nexmx use xmatel_mod implicit none character*(13), parameter :: irp_here = 'provide_nexmx' integer :: irp_err logical :: irp_dimensions_OK call bld_nexmx nexmx_is_built = .True. end subroutine provide_nexmx subroutine bld_nexmx use xmatel_mod character*(9), parameter :: irp_here = 'bld_nexmx' write(6,*) ' please give a maximum excitation degree ' ! xmatel.irp.f : 599 read(5,*) nexmx ! xmatel.irp.f : 600 nexmx_double=2*nexmx ! xmatel.irp.f : 601 end subroutine bld_nexmx subroutine free_nexmx use xmatel_mod implicit none nexmx_is_built = .False. end subroutine free_nexmx subroutine touch_nexmx use xmatel_mod implicit none nexmx_is_built = .False. call touch_ileft end subroutine touch_nexmx subroutine reader_nexmx (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_nexmx_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) nexmx close(irp_iunit) call touch_nexmx nexmx_is_built = .True. end subroutine reader_nexmx subroutine writer_nexmx (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.nexmx_is_built) then call provide_nexmx endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_nexmx_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) nexmx close(irp_iunit) call writer_nexmx_double(irp_num) end subroutine writer_nexmx subroutine provide_nexmx_double use xmatel_mod implicit none character*(20), parameter :: irp_here = 'provide_nexmx_double' integer :: irp_err logical :: irp_dimensions_OK call bld_nexmx nexmx_is_built = .True. end subroutine provide_nexmx_double subroutine free_nexmx_double use xmatel_mod implicit none nexmx_is_built = .False. end subroutine free_nexmx_double subroutine reader_nexmx_double (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_nexmx_double_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) nexmx_double close(irp_iunit) call touch_nexmx nexmx_is_built = .True. end subroutine reader_nexmx_double subroutine writer_nexmx_double (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.nexmx_is_built) then call provide_nexmx endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_nexmx_double_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) nexmx_double close(irp_iunit) end subroutine writer_nexmx_double subroutine provide_nocc use xmatel_mod implicit none character*(12), parameter :: irp_here = 'provide_nocc' integer :: irp_err logical :: irp_dimensions_OK call bld_nocc nocc_is_built = .True. end subroutine provide_nocc subroutine bld_nocc use xmatel_mod character*(8), parameter :: irp_here = 'bld_nocc' write(6,*) ' please give the number of occupied orbitals ' ! xmatel.irp.f : 605 read(5,*) nocc ! xmatel.irp.f : 606 end subroutine bld_nocc subroutine free_nocc use xmatel_mod implicit none nocc_is_built = .False. end subroutine free_nocc subroutine touch_nocc use xmatel_mod implicit none nocc_is_built = .False. end subroutine touch_nocc subroutine reader_nocc (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_nocc_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) nocc close(irp_iunit) call touch_nocc nocc_is_built = .True. end subroutine reader_nocc subroutine writer_nocc (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.nocc_is_built) then call provide_nocc endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_nocc_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) nocc close(irp_iunit) end subroutine writer_nocc subroutine provide_ileft use xmatel_mod implicit none character*(13), parameter :: irp_here = 'provide_ileft' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_ileft subroutine bld_ileft use xmatel_mod character*(9), parameter :: irp_here = 'bld_ileft' ileft =0 ! xmatel.irp.f : 618 iright =0 ! xmatel.irp.f : 619 ispinl =0 ! xmatel.irp.f : 620 ispinr =0 ! xmatel.irp.f : 621 itypel =0 ! xmatel.irp.f : 622 ityper =0 ! xmatel.irp.f : 623 ileft2 =0 ! xmatel.irp.f : 624 iright2 =0 ! xmatel.irp.f : 625 iholes =0 ! xmatel.irp.f : 626 end subroutine bld_ileft subroutine free_ileft use xmatel_mod implicit none ileft_is_built = .False. if (allocated(ileft)) then deallocate (ileft) endif end subroutine free_ileft subroutine touch_ileft use xmatel_mod implicit none ileft_is_built = .False. end subroutine touch_ileft subroutine reader_ileft (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit call reader_nexmx(irp_num) irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ileft_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) ileft(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_ileft subroutine writer_ileft (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif call writer_nexmx(irp_num) irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ileft_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) ileft(:) close(irp_iunit) call writer_iright(irp_num) call writer_ispinl(irp_num) call writer_ispinr(irp_num) call writer_itypel(irp_num) call writer_ityper(irp_num) call writer_ileft2(irp_num) call writer_iright2(irp_num) call writer_iholes(irp_num) end subroutine writer_ileft subroutine provide_iright use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_iright' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_iright subroutine free_iright use xmatel_mod implicit none ileft_is_built = .False. if (allocated(iright)) then deallocate (iright) endif end subroutine free_iright subroutine reader_iright (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_iright_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) iright(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_iright subroutine writer_iright (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_iright_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) iright(:) close(irp_iunit) end subroutine writer_iright subroutine provide_ispinl use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_ispinl' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_ispinl subroutine free_ispinl use xmatel_mod implicit none ileft_is_built = .False. if (allocated(ispinl)) then deallocate (ispinl) endif end subroutine free_ispinl subroutine reader_ispinl (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ispinl_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) ispinl(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_ispinl subroutine writer_ispinl (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ispinl_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) ispinl(:) close(irp_iunit) end subroutine writer_ispinl subroutine provide_ispinr use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_ispinr' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_ispinr subroutine free_ispinr use xmatel_mod implicit none ileft_is_built = .False. if (allocated(ispinr)) then deallocate (ispinr) endif end subroutine free_ispinr subroutine reader_ispinr (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ispinr_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) ispinr(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_ispinr subroutine writer_ispinr (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ispinr_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) ispinr(:) close(irp_iunit) end subroutine writer_ispinr subroutine provide_itypel use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_itypel' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_itypel subroutine free_itypel use xmatel_mod implicit none ileft_is_built = .False. if (allocated(itypel)) then deallocate (itypel) endif end subroutine free_itypel subroutine reader_itypel (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_itypel_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) itypel(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_itypel subroutine writer_itypel (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_itypel_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) itypel(:) close(irp_iunit) end subroutine writer_itypel subroutine provide_ityper use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_ityper' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_ityper subroutine free_ityper use xmatel_mod implicit none ileft_is_built = .False. if (allocated(ityper)) then deallocate (ityper) endif end subroutine free_ityper subroutine reader_ityper (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ityper_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) ityper(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_ityper subroutine writer_ityper (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ityper_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) ityper(:) close(irp_iunit) end subroutine writer_ityper subroutine provide_ileft2 use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_ileft2' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_ileft2 subroutine free_ileft2 use xmatel_mod implicit none ileft_is_built = .False. if (allocated(ileft2)) then deallocate (ileft2) endif end subroutine free_ileft2 subroutine reader_ileft2 (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ileft2_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) ileft2(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_ileft2 subroutine writer_ileft2 (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_ileft2_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) ileft2(:) close(irp_iunit) end subroutine writer_ileft2 subroutine provide_iright2 use xmatel_mod implicit none character*(15), parameter :: irp_here = 'provide_iright2' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_iright2 subroutine free_iright2 use xmatel_mod implicit none ileft_is_built = .False. if (allocated(iright2)) then deallocate (iright2) endif end subroutine free_iright2 subroutine reader_iright2 (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_iright2_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) iright2(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_iright2 subroutine writer_iright2 (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_iright2_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) iright2(:) close(irp_iunit) end subroutine writer_iright2 subroutine provide_iholes use xmatel_mod implicit none character*(14), parameter :: irp_here = 'provide_iholes' integer :: irp_err logical :: irp_dimensions_OK if (.not.nexmx_is_built) then call provide_nexmx_double endif if (allocated (ileft) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft) if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright) if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinl) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinl,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinl) if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinl(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinl' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ispinr) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ispinr,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ispinr) if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ispinr(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ispinr' print *, ' size: (nexmx_double)' endif endif endif if (allocated (itypel) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(itypel,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(itypel) if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(itypel(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: itypel' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ityper) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ityper,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ityper) if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ityper(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ityper' print *, ' size: (nexmx_double)' endif endif endif if (allocated (ileft2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(ileft2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(ileft2) if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(ileft2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: ileft2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iright2) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iright2,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iright2) if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iright2(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iright2' print *, ' size: (nexmx_double)' endif endif endif if (allocated (iholes) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(iholes,1)==(nexmx_double)) if (.not.irp_dimensions_OK) then deallocate(iholes) if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif else if ((nexmx_double>0)) then allocate(iholes(nexmx_double),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: iholes' print *, ' size: (nexmx_double)' endif endif endif call bld_ileft ileft_is_built = .True. end subroutine provide_iholes subroutine free_iholes use xmatel_mod implicit none ileft_is_built = .False. if (allocated(iholes)) then deallocate (iholes) endif end subroutine free_iholes subroutine reader_iholes (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_iholes_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) iholes(:) close(irp_iunit) call touch_ileft ileft_is_built = .True. end subroutine reader_iholes subroutine writer_iholes (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.ileft_is_built) then call provide_ileft endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_iholes_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) iholes(:) close(irp_iunit) end subroutine writer_iholes subroutine provide_csign use xmatel_mod implicit none character*(13), parameter :: irp_here = 'provide_csign' integer :: irp_err logical :: irp_dimensions_OK if (allocated (csign) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(csign,1)==(3)) if (.not.irp_dimensions_OK) then deallocate(csign) if ((3>0)) then allocate(csign(-1:1),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: csign' print *, ' size: (-1:1)' endif endif endif else if ((3>0)) then allocate(csign(-1:1),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: csign' print *, ' size: (-1:1)' endif endif endif call bld_csign csign_is_built = .True. end subroutine provide_csign subroutine bld_csign use xmatel_mod character*(9), parameter :: irp_here = 'bld_csign' csign(-1)='-' ! xmatel.irp.f : 632 csign( 0)=' ' ! xmatel.irp.f : 633 csign( 1)='+' ! xmatel.irp.f : 634 pname='XMATEL ' ! xmatel.irp.f : 635 end subroutine bld_csign subroutine free_csign use xmatel_mod implicit none csign_is_built = .False. if (allocated(csign)) then deallocate (csign) endif end subroutine free_csign subroutine touch_csign use xmatel_mod implicit none csign_is_built = .False. end subroutine touch_csign subroutine reader_csign (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_csign_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) csign(:) close(irp_iunit) call touch_csign csign_is_built = .True. end subroutine reader_csign subroutine writer_csign (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.csign_is_built) then call provide_csign endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_csign_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) csign(:) close(irp_iunit) call writer_pname(irp_num) end subroutine writer_csign subroutine provide_pname use xmatel_mod implicit none character*(13), parameter :: irp_here = 'provide_pname' integer :: irp_err logical :: irp_dimensions_OK if (allocated (csign) ) then irp_dimensions_OK = .True. irp_dimensions_OK = irp_dimensions_OK.and.(SIZE(csign,1)==(3)) if (.not.irp_dimensions_OK) then deallocate(csign) if ((3>0)) then allocate(csign(-1:1),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: csign' print *, ' size: (-1:1)' endif endif endif else if ((3>0)) then allocate(csign(-1:1),stat=irp_err) if (irp_err /= 0) then print *, irp_here//': Allocation failed: csign' print *, ' size: (-1:1)' endif endif endif call bld_csign csign_is_built = .True. end subroutine provide_pname subroutine free_pname use xmatel_mod implicit none csign_is_built = .False. end subroutine free_pname subroutine reader_pname (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_pname_'//trim(irp_num),form='FORMATTED',status='OLD',action='READ') read(irp_iunit,*) pname close(irp_iunit) call touch_csign csign_is_built = .True. end subroutine reader_pname subroutine writer_pname (irp_num) use xmatel_mod implicit none character*(*), intent(in) :: irp_num logical :: irp_is_open integer :: irp_iunit if (.not.csign_is_built) then call provide_csign endif irp_is_open = .True. irp_iunit = 9 do while (irp_is_open) irp_iunit = irp_iunit+1 inquire(unit=irp_iunit,opened=irp_is_open) enddo open(unit=irp_iunit,file='irpf90_pname_'//trim(irp_num),form='FORMATTED',status='UNKNOWN',action='WRITE') write(irp_iunit,*) pname close(irp_iunit) end subroutine writer_pname program irp_program call main end program subroutine main ! xmatel.irp.f : 2 use xmatel_mod implicit none ! xmatel.irp.f : 3 character*(4), parameter :: irp_here = 'main' WRITE(6,*) ! xmatel.irp.f : 5 WRITE(6,*) ' ----------------------------------------------' ! xmatel.irp.f : 6 WRITE(6,*) ! xmatel.irp.f : 7 WRITE(6,*) ' X M A T E L ' ! xmatel.irp.f : 8 WRITE(6,*) ' Slater rules for calculating matrix elements ' ! xmatel.irp.f : 9 WRITE(6,*) ' of the Hamiltonian between excited determinants ' ! xmatel.irp.f : 10 WRITE(6,*) ! xmatel.irp.f : 11 WRITE(6,*) ' implementation using IRPF90 10/2009 ' ! xmatel.irp.f : 12 WRITE(6,*) ' (Peter Reinhardt, Univ Paris VI) ' ! xmatel.irp.f : 13 WRITE(6,*) ! xmatel.irp.f : 14 WRITE(6,*) ' ----------------------------------------------' ! xmatel.irp.f : 15 WRITE(6,*) ! xmatel.irp.f : 16 call driver ! xmatel.irp.f : 17 end ! xmatel.irp.f : 19 subroutine driver ! xmatel.irp.f : 21 use xmatel_mod integer :: kk,i,nexl,nexr ! xmatel.irp.f : 22 character*(17), parameter :: irp_here = 'subroutine driver' if (.not.ileft_is_built) then call provide_ileft endif if (.not.nexmx_is_built) then call provide_nexmx endif if (.not.nocc_is_built) then call provide_nocc endif write(6,*) ' NOCC = ',nocc ! xmatel.irp.f : 24 write(6,*) ' NEXMAX = ',nexmx ! xmatel.irp.f : 25 write(6,*) ! xmatel.irp.f : 26 WRITE(6,*) ' ----------------------------------------------' ! xmatel.irp.f : 27 WRITE(6,*) ! xmatel.irp.f : 28 100 continue ! xmatel.irp.f : 30 write(6,9901) ! xmatel.irp.f : 31 9901 format(' left determinant (excitation ' ,'degree, hole ind., part ind., -1 stops the program)' ) ! xmatel.irp.f : 32 read(5,*,iostat=kk) nexl,(ileft(i),i=1,2*nexl) ! xmatel.irp.f : 34 if (kk.ne.0) then ! xmatel.irp.f : 35 go to 200 ! xmatel.irp.f : 35 endif ! xmatel.irp.f : 35 if (nexl.eq.-1) then ! xmatel.irp.f : 36 if (.not.csign_is_built) then call provide_pname endif write(6,*) ! xmatel.irp.f : 37 write(6,*) ' normal end of ',pname ! xmatel.irp.f : 38 write(6,*) ! xmatel.irp.f : 39 stop ! xmatel.irp.f : 40 end if ! xmatel.irp.f : 41 if (nexl.gt.nexmx) then ! xmatel.irp.f : 42 write(6,*) ' excitation degree larger than anticipated ' ! xmatel.irp.f : 43 write(6,*) ' you gave nexmx = ',nexmx ! xmatel.irp.f : 44 end if ! xmatel.irp.f : 45 write(6,9902) ! xmatel.irp.f : 47 9902 format(' right determinant (excitation ' ,'degree, hole indices, part indices)' ) ! xmatel.irp.f : 48 read(5,*) nexr,(iright(i),i=1,2*nexr) ! xmatel.irp.f : 51 if (nexr.gt.nexmx) then ! xmatel.irp.f : 52 write(6,*) ' excitation degree larger than anticipated ' ! xmatel.irp.f : 53 write(6,*) ' you gave nexmx = ',nexmx ! xmatel.irp.f : 54 end if ! xmatel.irp.f : 55 call xmatel(nexl,nexr) ! xmatel.irp.f : 56 write(6,*) ! xmatel.irp.f : 57 write(6,*) ' - - - - - - - - - - - - - - - - - -' ! xmatel.irp.f : 58 write(6,*) ! xmatel.irp.f : 59 write(6,*) ! xmatel.irp.f : 60 go to 100 ! xmatel.irp.f : 61 200 continue ! xmatel.irp.f : 62 end ! xmatel.irp.f : 64 subroutine xmatel(nexl,nexr) ! xmatel.irp.f : 66 use xmatel_mod implicit none ! xmatel.irp.f : 67 integer :: nexl,nexr,i,j,norbi,isign,jsign,j1,ih,ihole ! xmatel.irp.f : 68 integer :: ii1,jj1,kk1,ll1,ii2,jj2,kk2,ll2,iequal,ipart ! xmatel.irp.f : 69 integer :: i1,i2,j2,ndiff,lspin,nholes,lsub,nequal,idum ! xmatel.irp.f : 70 integer :: jj,lfound,irp1,irp2,irpa,irpb,nleft,nright,indx ! xmatel.irp.f : 71 integer :: ilhb,ilpa,ilpb,irha,irhb,ilha ! xmatel.irp.f : 72 character*(17), parameter :: irp_here = 'subroutine xmatel' if (.not.ileft_is_built) then call provide_ileft endif if (.not.nocc_is_built) then call provide_nocc endif if (.not.csign_is_built) then call provide_csign endif do i=1,2*max(nexl,nexr) ! xmatel.irp.f : 74 ileft2(i)=0 ! xmatel.irp.f : 75 iright2(i)=0 ! xmatel.irp.f : 76 end do ! xmatel.irp.f : 77 ilha=0 ! xmatel.irp.f : 83 ilhb=0 ! xmatel.irp.f : 84 ilpa=0 ! xmatel.irp.f : 85 ilpb=0 ! xmatel.irp.f : 86 do i=1,2*nexl ! xmatel.irp.f : 87 if (ileft(i).lt.0) then ! xmatel.irp.f : 88 if (abs(ileft(i)).le.nocc) then ! xmatel.irp.f : 89 ilhb=ilhb+1 ! xmatel.irp.f : 90 itypel(i)=1 ! xmatel.irp.f : 91 ispinl(i)=1 ! xmatel.irp.f : 92 else ! xmatel.irp.f : 93 ilpb=ilpb+1 ! xmatel.irp.f : 94 itypel(i)=2 ! xmatel.irp.f : 95 ispinl(i)=1 ! xmatel.irp.f : 96 end if ! xmatel.irp.f : 97 else if (ileft(i).gt.0) then ! xmatel.irp.f : 98 if (ileft(i).le.nocc) then ! xmatel.irp.f : 99 ilha=ilha+1 ! xmatel.irp.f : 100 itypel(i)=1 ! xmatel.irp.f : 101 ispinl(i)=2 ! xmatel.irp.f : 102 else ! xmatel.irp.f : 103 ilpa=ilpa+1 ! xmatel.irp.f : 104 itypel(i)=2 ! xmatel.irp.f : 105 ispinl(i)=2 ! xmatel.irp.f : 106 end if ! xmatel.irp.f : 107 end if ! xmatel.irp.f : 108 end do ! xmatel.irp.f : 109 irha=0 ! xmatel.irp.f : 111 irhb=0 ! xmatel.irp.f : 112 irpa=0 ! xmatel.irp.f : 113 irpb=0 ! xmatel.irp.f : 114 do i=1,2*nexr ! xmatel.irp.f : 115 if (iright(i).lt.0) then ! xmatel.irp.f : 116 if (abs(iright(i)).le.nocc) then ! xmatel.irp.f : 117 irhb=irhb+1 ! xmatel.irp.f : 118 ityper(i)=1 ! xmatel.irp.f : 119 ispinr(i)=1 ! xmatel.irp.f : 120 else ! xmatel.irp.f : 121 irpb=irpb+1 ! xmatel.irp.f : 122 ityper(i)=2 ! xmatel.irp.f : 123 ispinr(i)=1 ! xmatel.irp.f : 124 end if ! xmatel.irp.f : 125 else if (iright(i).gt.0) then ! xmatel.irp.f : 126 if (iright(i).le.nocc) then ! xmatel.irp.f : 127 irha=irha+1 ! xmatel.irp.f : 128 ityper(i)=1 ! xmatel.irp.f : 129 ispinr(i)=2 ! xmatel.irp.f : 130 else ! xmatel.irp.f : 131 irpa=irpa+1 ! xmatel.irp.f : 132 ityper(i)=2 ! xmatel.irp.f : 133 ispinr(i)=2 ! xmatel.irp.f : 134 end if ! xmatel.irp.f : 135 end if ! xmatel.irp.f : 136 end do ! xmatel.irp.f : 137 nleft=ilha+ilhb+ilpa+ilpb ! xmatel.irp.f : 138 nright=irha+irhb+irpa+irpb ! xmatel.irp.f : 139 if (ilha.ne.ilpa) then ! xmatel.irp.f : 146 stop ' error in holes/particles alpha lhs' ! xmatel.irp.f : 146 endif ! xmatel.irp.f : 146 if (ilhb.ne.ilpb) then ! xmatel.irp.f : 147 stop ' error in holes/particles beta lhs' ! xmatel.irp.f : 147 endif ! xmatel.irp.f : 147 if (irha.ne.irpa) then ! xmatel.irp.f : 148 stop ' error in holes/particles alpha rhs' ! xmatel.irp.f : 148 endif ! xmatel.irp.f : 148 if (irhb.ne.irpb) then ! xmatel.irp.f : 149 stop ' error in holes/particles beta rhs' ! xmatel.irp.f : 149 endif ! xmatel.irp.f : 149 indx=0 ! xmatel.irp.f : 152 do i=1,2*nexl ! xmatel.irp.f : 153 if (ileft(i).ne.0.and.abs(ileft(i)).le.nocc) then ! xmatel.irp.f : 154 indx=indx+1 ! xmatel.irp.f : 155 ileft2(indx)=ileft(i) ! xmatel.irp.f : 156 end if ! xmatel.irp.f : 157 end do ! xmatel.irp.f : 158 if (indx.ne.nexl) then ! xmatel.irp.f : 159 stop ' left determinant incorrectly specified ' ! xmatel.irp.f : 159 endif ! xmatel.irp.f : 159 do i=1,2*nexr ! xmatel.irp.f : 161 if (iright(i).ne.0.and.abs(iright(i)).le.nocc) then ! xmatel.irp.f : 162 indx=indx+1 ! xmatel.irp.f : 163 ileft2(indx)=iright(i) ! xmatel.irp.f : 164 end if ! xmatel.irp.f : 165 end do ! xmatel.irp.f : 166 if (indx.ne.nexl+nexr) then ! xmatel.irp.f : 167 stop ' right determinant incorrectly specified ' ! xmatel.irp.f : 167 endif ! xmatel.irp.f : 167 do i=1,nexl+nexr ! xmatel.irp.f : 173 do j=i+1,nexl+nexr ! xmatel.irp.f : 174 if (ileft2(i).eq.ileft2(j).and.ileft2(i).ne.0) then ! xmatel.irp.f : 175 ileft2(j)=0 ! xmatel.irp.f : 176 end if ! xmatel.irp.f : 177 end do ! xmatel.irp.f : 178 end do ! xmatel.irp.f : 179 isign=1 ! xmatel.irp.f : 181 norbi=nexl+nexr ! xmatel.irp.f : 189 do i=1,nexl+nexr ! xmatel.irp.f : 190 if (ileft2(i).eq.0) then ! xmatel.irp.f : 191 lfound=0 ! xmatel.irp.f : 192 do j=i+1,nexl+nexr ! xmatel.irp.f : 193 if (lfound.eq.0) then ! xmatel.irp.f : 194 if (ileft2(j).ne.0) then ! xmatel.irp.f : 195 ileft2(i)=ileft2(j) ! xmatel.irp.f : 196 ileft2(j)=0 ! xmatel.irp.f : 197 lfound=1 ! xmatel.irp.f : 198 end if ! xmatel.irp.f : 199 end if ! xmatel.irp.f : 200 end do ! xmatel.irp.f : 201 end if ! xmatel.irp.f : 202 end do ! xmatel.irp.f : 203 norbi=0 ! xmatel.irp.f : 205 do i=1,nexl+nexr ! xmatel.irp.f : 206 if (ileft2(i).ne.0) then ! xmatel.irp.f : 207 norbi=norbi+1 ! xmatel.irp.f : 207 endif ! xmatel.irp.f : 207 end do ! xmatel.irp.f : 208 if (irha.ge.2.or.irhb.ge.2) then ! xmatel.irp.f : 211 do i=1,norbi ! xmatel.irp.f : 212 if (ileft2(i).eq.iright(1)) then ! xmatel.irp.f : 213 irp1=i ! xmatel.irp.f : 213 endif ! xmatel.irp.f : 213 if (ileft2(i).eq.iright(2)) then ! xmatel.irp.f : 214 irp2=i ! xmatel.irp.f : 214 endif ! xmatel.irp.f : 214 end do ! xmatel.irp.f : 215 if (irp1.gt.irp2) then ! xmatel.irp.f : 216 isign=-isign ! xmatel.irp.f : 216 endif ! xmatel.irp.f : 216 end if ! xmatel.irp.f : 217 9902 format(' norbi = ',i4,' string ',20i4) ! xmatel.irp.f : 220 do i=1,norbi ! xmatel.irp.f : 222 iholes(i)=ileft2(i) ! xmatel.irp.f : 223 end do ! xmatel.irp.f : 224 nholes=norbi ! xmatel.irp.f : 225 do i=1,norbi ! xmatel.irp.f : 227 iright2(i)=ileft2(i) ! xmatel.irp.f : 228 end do ! xmatel.irp.f : 229 do i=1,norbi ! xmatel.irp.f : 233 lfound=0 ! xmatel.irp.f : 236 do j=1,2*nexl ! xmatel.irp.f : 237 if (ileft2(i).eq.ileft(j)) then ! xmatel.irp.f : 238 lfound=1 ! xmatel.irp.f : 239 lspin=ispinl(j) ! xmatel.irp.f : 240 end if ! xmatel.irp.f : 241 end do ! xmatel.irp.f : 242 if (lfound.eq.1) then ! xmatel.irp.f : 244 lsub=0 ! xmatel.irp.f : 245 do j=1,2*nexl ! xmatel.irp.f : 246 if (lsub.eq.0) then ! xmatel.irp.f : 247 if ((lspin.eq.ispinl(j)).and.(itypel(j).eq.2)) then ! xmatel.irp.f : 249 ileft2(i)=ileft(j) ! xmatel.irp.f : 250 itypel(j)=0 ! xmatel.irp.f : 251 lsub=1 ! xmatel.irp.f : 252 end if ! xmatel.irp.f : 253 end if ! xmatel.irp.f : 254 end do ! xmatel.irp.f : 255 end if ! xmatel.irp.f : 256 end do ! xmatel.irp.f : 257 do i=1,norbi ! xmatel.irp.f : 259 lfound=0 ! xmatel.irp.f : 262 do j=1,2*nexr ! xmatel.irp.f : 263 if (iright2(i).eq.iright(j)) then ! xmatel.irp.f : 264 lfound=1 ! xmatel.irp.f : 265 lspin=ispinr(j) ! xmatel.irp.f : 266 end if ! xmatel.irp.f : 267 end do ! xmatel.irp.f : 268 if (lfound.eq.1) then ! xmatel.irp.f : 270 lsub=0 ! xmatel.irp.f : 271 do j=1,2*nexr ! xmatel.irp.f : 272 if (lsub.eq.0) then ! xmatel.irp.f : 273 if ((lspin.eq.ispinr(j)).and.(ityper(j).eq.2)) then ! xmatel.irp.f : 275 iright2(i)=iright(j) ! xmatel.irp.f : 276 ityper(j)=0 ! xmatel.irp.f : 277 lsub=1 ! xmatel.irp.f : 278 end if ! xmatel.irp.f : 279 end if ! xmatel.irp.f : 280 end do ! xmatel.irp.f : 281 end if ! xmatel.irp.f : 282 end do ! xmatel.irp.f : 283 9903 format(' ',a5,' determinant as occupation : ',10i4) ! xmatel.irp.f : 288 9804 format(' ',a5,' in the determinants : ',10i4) ! xmatel.irp.f : 289 nequal=0 ! xmatel.irp.f : 294 do i=1,norbi ! xmatel.irp.f : 295 lfound=0 ! xmatel.irp.f : 296 do j=1,norbi ! xmatel.irp.f : 297 if (ileft2(i).eq.iright2(j).and.lfound.eq.0) then ! xmatel.irp.f : 298 nequal=nequal+1 ! xmatel.irp.f : 299 lfound=1 ! xmatel.irp.f : 300 if (i.ne.j) then ! xmatel.irp.f : 301 isign=-isign ! xmatel.irp.f : 303 idum=iright2(j) ! xmatel.irp.f : 304 iright2(j)=iright2(i) ! xmatel.irp.f : 305 iright2(i)=idum ! xmatel.irp.f : 306 end if ! xmatel.irp.f : 307 end if ! xmatel.irp.f : 308 end do ! xmatel.irp.f : 309 end do ! xmatel.irp.f : 310 do i=1,norbi ! xmatel.irp.f : 313 lfound=0 ! xmatel.irp.f : 314 do j=i,norbi ! xmatel.irp.f : 315 if (ileft2(j).ne.iright2(j).and.lfound.eq.0) then ! xmatel.irp.f : 317 idum=ileft2(i) ! xmatel.irp.f : 318 ileft2(i)=ileft2(j) ! xmatel.irp.f : 319 ileft2(j)=idum ! xmatel.irp.f : 320 idum=iright2(i) ! xmatel.irp.f : 321 iright2(i)=iright2(j) ! xmatel.irp.f : 322 iright2(j)=idum ! xmatel.irp.f : 323 lfound=1 ! xmatel.irp.f : 324 end if ! xmatel.irp.f : 325 end do ! xmatel.irp.f : 326 end do ! xmatel.irp.f : 327 ndiff=norbi-nequal ! xmatel.irp.f : 335 if (ndiff.le.2) then ! xmatel.irp.f : 346 do i=1,norbi ! xmatel.irp.f : 348 if (ileft2(i).lt.0) then ! xmatel.irp.f : 349 ispinl(i)=1 ! xmatel.irp.f : 350 else ! xmatel.irp.f : 351 ispinl(i)=2 ! xmatel.irp.f : 352 end if ! xmatel.irp.f : 353 if (iright2(i).lt.0) then ! xmatel.irp.f : 354 ispinr(i)=1 ! xmatel.irp.f : 355 else ! xmatel.irp.f : 356 ispinr(i)=2 ! xmatel.irp.f : 357 end if ! xmatel.irp.f : 358 end do ! xmatel.irp.f : 359 if (ndiff.eq.0) then ! xmatel.irp.f : 361 if (.not.csign_is_built) then call provide_csign endif write(6,*) ' ndiff = 0 : diagonal element ' ! xmatel.irp.f : 362 write(6,9924) csign(isign) ! xmatel.irp.f : 363 9924 format(' calculating matrix element : ',a1,'e_hf ') ! xmatel.irp.f : 364 do i=1,norbi ! xmatel.irp.f : 365 i1=abs(iholes(i)) ! xmatel.irp.f : 366 j1=abs(ileft2(i)) ! xmatel.irp.f : 367 write(6,9921) csign(-isign),i1,i1,csign(isign),j1,j1 ! xmatel.irp.f : 368 9921 format(' diagonal element : ',a1,'f (',i3,',',i3,' ) ',a1 ,' f (',i3,',',i3,' )') ! xmatel.irp.f : 369 end do ! xmatel.irp.f : 371 do i=1,norbi ! xmatel.irp.f : 380 do j=1,norbi ! xmatel.irp.f : 381 i1=abs(iholes(i)) ! xmatel.irp.f : 385 j1=abs(ileft2(j)) ! xmatel.irp.f : 386 jsign=1 ! xmatel.irp.f : 388 if (i1.le.nocc.and.j1.gt.nocc) then ! xmatel.irp.f : 389 jsign=-1 ! xmatel.irp.f : 389 endif ! xmatel.irp.f : 389 if (i1.gt.nocc.and.j1.le.nocc) then ! xmatel.irp.f : 390 jsign=-1 ! xmatel.irp.f : 390 endif ! xmatel.irp.f : 390 if (ispinl(i).eq.ispinl(j)) then ! xmatel.irp.f : 391 write(6,9922) csign(isign*jsign), i1,i1,j1,j1, csign(-isign*jsign),i1,j1,i1,j1 ! xmatel.irp.f : 392 else ! xmatel.irp.f : 394 write(6,9923) csign(isign*jsign),i1,i1,j1,j1 ! xmatel.irp.f : 395 end if ! xmatel.irp.f : 396 end do ! xmatel.irp.f : 398 end do ! xmatel.irp.f : 399 do i=1,norbi-1 ! xmatel.irp.f : 401 do j=i+1,norbi ! xmatel.irp.f : 402 i1=abs(iholes(i)) ! xmatel.irp.f : 404 j1=abs(iholes(j)) ! xmatel.irp.f : 405 jsign=1 ! xmatel.irp.f : 407 if (i1.le.nocc.and.j1.gt.nocc) then ! xmatel.irp.f : 408 jsign=-1 ! xmatel.irp.f : 408 endif ! xmatel.irp.f : 408 if (i1.gt.nocc.and.j1.le.nocc) then ! xmatel.irp.f : 409 jsign=-1 ! xmatel.irp.f : 409 endif ! xmatel.irp.f : 409 if (ispinl(i).eq.ispinl(j)) then ! xmatel.irp.f : 410 write(6,9922) csign(isign*jsign), i1,i1,j1,j1, csign(-isign*jsign),i1,j1,i1,j1 ! xmatel.irp.f : 411 else ! xmatel.irp.f : 413 write(6,9923) csign(isign*jsign),i1,i1,j1,j1 ! xmatel.irp.f : 414 end if ! xmatel.irp.f : 415 i1=abs(ileft2(i)) ! xmatel.irp.f : 418 j1=abs(ileft2(j)) ! xmatel.irp.f : 419 jsign=1 ! xmatel.irp.f : 421 if (i1.le.nocc.and.j1.gt.nocc) then ! xmatel.irp.f : 422 jsign=-1 ! xmatel.irp.f : 422 endif ! xmatel.irp.f : 422 if (i1.gt.nocc.and.j1.le.nocc) then ! xmatel.irp.f : 423 jsign=-1 ! xmatel.irp.f : 423 endif ! xmatel.irp.f : 423 if (ispinl(i).eq.ispinl(j)) then ! xmatel.irp.f : 424 write(6,9922) csign(isign*jsign), i1,i1,j1,j1, csign(-isign*jsign),i1,j1,i1,j1 ! xmatel.irp.f : 425 else ! xmatel.irp.f : 427 write(6,9923) csign(isign*jsign),i1,i1,j1,j1 ! xmatel.irp.f : 428 end if ! xmatel.irp.f : 429 end do ! xmatel.irp.f : 431 end do ! xmatel.irp.f : 432 9922 format(' diagonal element : ',a1,' (',2i4,'|',2i4,' ) ', a1,' (',2i4,'|',2i4,' ) ') ! xmatel.irp.f : 433 9923 format(' diagonal element : ',a1,' (',2i4,'|',2i4,' )') ! xmatel.irp.f : 435 else if (ndiff.eq.1) then ! xmatel.irp.f : 436 i=min(abs(ileft2(1)),abs(iright2(1))) ! xmatel.irp.f : 437 j=max(abs(ileft2(1)),abs(iright2(1))) ! xmatel.irp.f : 438 write(6,9912) ileft2(1),iright2(1),csign(isign),i,j ! xmatel.irp.f : 439 do ih=1,nholes ! xmatel.irp.f : 441 ihole=iholes(ih) ! xmatel.irp.f : 442 if (sign(1,ihole).eq.sign(1,ileft2(1))) then ! xmatel.irp.f : 444 ihole=abs(ihole) ! xmatel.irp.f : 445 ii1=abs(ileft2(1)) ! xmatel.irp.f : 446 jj1=abs(iright2(1)) ! xmatel.irp.f : 447 kk1=ihole ! xmatel.irp.f : 448 ll1=ihole ! xmatel.irp.f : 449 ii2=abs(ileft2(1)) ! xmatel.irp.f : 450 jj2=ihole ! xmatel.irp.f : 451 kk2=abs(iright2(1)) ! xmatel.irp.f : 452 ll2=ihole ! xmatel.irp.f : 453 call ocan(ii1,jj1,kk1,ll1) ! xmatel.irp.f : 454 call ocan(ii2,jj2,kk2,ll2) ! xmatel.irp.f : 455 write(6,9913) ileft2(1),iright2(1), csign(-isign),ii1,jj1,kk1,ll1,csign(isign),ii2,jj2,kk2,ll2 ! xmatel.irp.f : 456 else ! xmatel.irp.f : 458 ihole=abs(ihole) ! xmatel.irp.f : 459 ii1=abs(ileft2(1)) ! xmatel.irp.f : 460 jj1=abs(iright2(1)) ! xmatel.irp.f : 461 kk1=ihole ! xmatel.irp.f : 462 ll1=ihole ! xmatel.irp.f : 463 call ocan(ii1,jj1,kk1,ll1) ! xmatel.irp.f : 464 write(6,9914) ileft2(1),iright2(1),csign(-isign),ii1,jj1,kk1,ll1 ! xmatel.irp.f : 465 end if ! xmatel.irp.f : 466 end do ! xmatel.irp.f : 467 do iequal=1,nequal ! xmatel.irp.f : 469 ipart=ileft2(1+iequal) ! xmatel.irp.f : 470 if (sign(1,ipart).eq.sign(1,ileft2(1))) then ! xmatel.irp.f : 472 ipart=abs(ipart) ! xmatel.irp.f : 473 ii1=abs(ileft2(1)) ! xmatel.irp.f : 474 jj1=abs(iright2(1)) ! xmatel.irp.f : 475 kk1=ipart ! xmatel.irp.f : 476 ll1=ipart ! xmatel.irp.f : 477 ii2=abs(ileft2(1)) ! xmatel.irp.f : 478 jj2=ipart ! xmatel.irp.f : 479 kk2=abs(iright2(1)) ! xmatel.irp.f : 480 ll2=ipart ! xmatel.irp.f : 481 call ocan(ii1,jj1,kk1,ll1) ! xmatel.irp.f : 482 call ocan(ii2,jj2,kk2,ll2) ! xmatel.irp.f : 483 write(6,9913) ileft2(1),iright2(1),csign(isign),ii1,jj1, kk1,ll1,csign(-isign),ii2,jj2,kk2 ,ll2 ! xmatel.irp.f : 484 else ! xmatel.irp.f : 486 ipart=abs(ipart) ! xmatel.irp.f : 487 ii1=abs(ileft2(1)) ! xmatel.irp.f : 488 jj1=abs(iright2(1)) ! xmatel.irp.f : 489 kk1=ipart ! xmatel.irp.f : 490 ll1=ipart ! xmatel.irp.f : 491 call ocan(ii1,jj1,kk1,ll1) ! xmatel.irp.f : 492 write(6,9914) ileft2(1),iright2(1),csign(isign),ii1,jj1,kk1,ll1 ! xmatel.irp.f : 493 end if ! xmatel.irp.f : 494 end do ! xmatel.irp.f : 495 else if (ndiff.eq.2) then ! xmatel.irp.f : 497 i1=ileft2(1) ! xmatel.irp.f : 498 i2=ileft2(2) ! xmatel.irp.f : 499 j1=iright2(1) ! xmatel.irp.f : 500 j2=iright2(2) ! xmatel.irp.f : 501 do i=1,2 ! xmatel.irp.f : 502 ileft2(i)=abs(ileft2(i)) ! xmatel.irp.f : 503 iright2(i)=abs(iright2(i)) ! xmatel.irp.f : 504 end do ! xmatel.irp.f : 505 if (ispinl(1).eq.ispinl(2)) then ! xmatel.irp.f : 507 ii1=ileft2(1) ! xmatel.irp.f : 509 jj1=iright2(1) ! xmatel.irp.f : 510 kk1=ileft2(2) ! xmatel.irp.f : 511 ll1=iright2(2) ! xmatel.irp.f : 512 call ocan(ii1,jj1,kk1,ll1) ! xmatel.irp.f : 514 ii2=ileft2(1) ! xmatel.irp.f : 516 jj2=iright2(2) ! xmatel.irp.f : 517 kk2=ileft2(2) ! xmatel.irp.f : 518 ll2=iright2(1) ! xmatel.irp.f : 519 call ocan(ii2,jj2,kk2,ll2) ! xmatel.irp.f : 520 write(6,9915) i1,i2,j1,j2,csign(isign),ii1,jj1,kk1,ll1, csign(-isign),ii2,jj2,kk2,ll2 ! xmatel.irp.f : 521 else ! xmatel.irp.f : 523 ii1=ileft2(1) ! xmatel.irp.f : 524 jj1=iright2(1) ! xmatel.irp.f : 525 kk1=ileft2(2) ! xmatel.irp.f : 526 ll1=iright2(2) ! xmatel.irp.f : 527 call ocan(ii1,jj1,kk1,ll1) ! xmatel.irp.f : 528 write(6,9916) i1,i2,j1,j2,csign(isign),ii1,jj1,kk1,ll1 ! xmatel.irp.f : 529 end if ! xmatel.irp.f : 530 end if ! xmatel.irp.f : 531 else ! xmatel.irp.f : 532 write(6,9917) ! xmatel.irp.f : 533 end if ! xmatel.irp.f : 534 9904 format(' calculating diagonal element <',4i4,'||', 4i4,'> ') ! xmatel.irp.f : 536 9912 format(' calculating matrix element <',i4,'||',i4 ,'> : interaction ',a1,'F(',i3,',',i3,')',f20.12) ! xmatel.irp.f : 538 9913 format(' calculating matrix element <',i4,'||',i4 ,'> : interaction ',a1,'(',2i4,'|',2i4,') ',a1,' (',2i4,'|' ,2i4,') ',f20.12) ! xmatel.irp.f : 540 9914 format(' calculating matrix element <',i4,'||',i4 ,'> : interaction ',a1,'(',2i4,'|',2i4,') ',f20.12) ! xmatel.irp.f : 543 9915 format(' calculating matrix element <',2i4,'||',2i4 ,'> : interaction ',a1,'(',2i4,'|',2i4,') ',a1,' (',2i4,'|' ,2i4,') ',f20.12) ! xmatel.irp.f : 545 9916 format(' calculating matrix element <',2i4,'||',2i4 ,'> : interaction ',a1,'(',2i4,'|',2i4,') ',f20.12) ! xmatel.irp.f : 548 9917 format(' calculating matrix element : no interaction ') ! xmatel.irp.f : 550 end ! xmatel.irp.f : 552 subroutine ocan(i,j,k,l) ! xmatel.irp.f : 554 use xmatel_mod implicit none ! xmatel.irp.f : 555 integer :: i,j,k,l ! xmatel.irp.f : 556 integer :: i1,j1,k1,l1,idum ! xmatel.irp.f : 557 character*(15), parameter :: irp_here = 'subroutine ocan' i1=i ! xmatel.irp.f : 559 j1=j ! xmatel.irp.f : 560 k1=k ! xmatel.irp.f : 561 l1=l ! xmatel.irp.f : 562 if (i1.gt.j1) then ! xmatel.irp.f : 564 idum=i1 ! xmatel.irp.f : 565 i1=j1 ! xmatel.irp.f : 566 j1=idum ! xmatel.irp.f : 567 end if ! xmatel.irp.f : 568 if (k1.gt.l1) then ! xmatel.irp.f : 569 idum=k1 ! xmatel.irp.f : 570 k1=l1 ! xmatel.irp.f : 571 l1=idum ! xmatel.irp.f : 572 end if ! xmatel.irp.f : 573 if (i1.gt.k1) then ! xmatel.irp.f : 575 idum=i1 ! xmatel.irp.f : 576 i1=k1 ! xmatel.irp.f : 577 k1=idum ! xmatel.irp.f : 578 idum=j1 ! xmatel.irp.f : 579 j1=l1 ! xmatel.irp.f : 580 l1=idum ! xmatel.irp.f : 581 else if (i1.eq.k1) then ! xmatel.irp.f : 582 if (j1.gt.l1) then ! xmatel.irp.f : 583 idum=j1 ! xmatel.irp.f : 584 j1=l1 ! xmatel.irp.f : 585 l1=idum ! xmatel.irp.f : 586 end if ! xmatel.irp.f : 587 end if ! xmatel.irp.f : 588 i=i1 ! xmatel.irp.f : 590 j=j1 ! xmatel.irp.f : 591 k=k1 ! xmatel.irp.f : 592 l=l1 ! xmatel.irp.f : 593 end ! xmatel.irp.f : 595