! This file is part of tblite-int.
! SPDX-Identifier: Apache-2.0
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

program integrator
   use, intrinsic :: iso_fortran_env, only: output_unit
   use mctc_env, only: wp, error_type, fatal_error, get_argument
   use mctc_io, only: structure_type, new
   use mctc_io_symbols, only: symbol_length
   use mctc_io_convert, only: aatoau
   use stdlib_io_npy, only: save_npy
   use tblite_adjlist, only: adjacency_list, new_adjacency_list
   use tblite_basis_type, only: get_cutoff
   use tblite_cutoff, only: get_lattice_points
   use tblite_integral_type, only: integral_type, new_integral
   use tblite_param, only: param_record
   use tblite_xtb_calculator, only: xtb_calculator, new_xtb_calculator
   use tblite_xtb_h0, only: get_selfenergy, get_hamiltonian
   use tblite_xtb_gfn2, only: new_gfn2_calculator
   use tblite_xtb_gfn1, only: new_gfn1_calculator
   use tblite_xtb_ipea1, only: new_ipea1_calculator
   implicit none
   character(len=*), parameter :: prog_name = "tblite-int"

   type :: int_config
      character(len=:), allocatable :: output_file
      character(len=:), allocatable :: method
      character(len=:), allocatable :: param
      real(wp), allocatable :: distance(:)
      character(len=:), allocatable :: species1, species2
      logical :: hamiltonian = .false.
      real(wp) :: accuracy = 1.0_wp
      real(wp) :: conv = aatoau
      real(wp), allocatable :: cn(:)
   end type int_config

   type(int_config) :: config
   type(error_type), allocatable :: error

   call get_arguments(config, error)
   call handle_error(error)

   call main(config, error)
   call handle_error(error)

contains

   subroutine main(config, error)
      type(int_config), intent(in) :: config
      type(error_type), allocatable, intent(out) :: error

      type(structure_type) :: mol
      type(param_record) :: param
      type(xtb_calculator) :: calc
      character(len=:), allocatable :: method
      real(wp) :: cutoff
      real(wp), allocatable :: selfenergy(:), lattr(:, :)
      type(integral_type) :: ints
      type(adjacency_list) :: list
      character(len=symbol_length) :: sym(2)
      real(wp) :: xyz(3, 2)

      sym = [character(len=symbol_length):: config%species1, config%species2]
      xyz = reshape([0.0_wp, 0.0_wp, 0.0_wp, config%distance*config%conv], [3, 2])
      call new(mol, sym, xyz)

      if (allocated(config%param)) then
         call param%load(config%param, error)
         if (.not. allocated(error)) then
            call new_xtb_calculator(calc, mol, param, error)
         end if
      else
         method = "gfn2"
         if (allocated(config%method)) method = config%method
         select case (method)
         case default
            call fatal_error(error, "Unknown method '"//method//"' requested")
         case ("gfn2")
            call new_gfn2_calculator(calc, mol)
         case ("gfn1")
            call new_gfn1_calculator(calc, mol)
         case ("ipea1")
            call new_ipea1_calculator(calc, mol)
         end select
      end if
      if (allocated(error)) return

      allocate (selfenergy(calc%bas%nsh))
      call get_selfenergy(calc%h0, mol%id, calc%bas%ish_at, calc%bas%nsh_id, cn=config%cn, &
         & selfenergy=selfenergy)

      cutoff = get_cutoff(calc%bas, config%accuracy)
      call get_lattice_points(mol%periodic, mol%lattice, cutoff, lattr)
      call new_adjacency_list(list, mol, lattr, cutoff)

      call new_integral(ints, calc%bas%nao)
      call get_hamiltonian(mol, lattr, list, calc%bas, calc%h0, selfenergy, &
         & ints%overlap, ints%dipole, ints%quadrupole, ints%hamiltonian)

      if (config%hamiltonian) then
         call write_matrix(ints%hamiltonian)
         call save_npy(config%output_file, ints%hamiltonian)
         write (output_unit, '(a)') "[Info] Hamiltonian written to '"//config%output_file//"'"
      else
         call write_matrix(ints%overlap)
         call save_npy(config%output_file, ints%overlap)
         write (output_unit, '(a)') "[Info] Overlap written to '"//config%output_file//"'"
      end if

   end subroutine main

   subroutine get_arguments(config, error)
      type(int_config), intent(out) :: config
      type(error_type), allocatable, intent(out) :: error

      integer :: iarg, narg
      character(len=:), allocatable :: arg

      iarg = 0
      narg = command_argument_count()
      do while (iarg < narg)
         iarg = iarg + 1
         call get_argument(iarg, arg)
         select case (arg)
         case default
            if (.not. allocated(config%species1)) then
               call move_alloc(arg, config%species1)
               cycle
            end if
            if (.not. allocated(config%species2)) then
               call move_alloc(arg, config%species2)
               cycle
            end if
            if (.not. allocated(config%distance)) then
               allocate (config%distance(3))
               call get_argument_as_realv(arg, config%distance, error)
               if (allocated(error)) exit
               cycle
            end if
            call fatal_error(error, "Too many positional arguments present")
            exit

         case ("--help")
            call help(output_unit)
            stop

         case ("--method")
            if (allocated(config%param)) then
               call fatal_error(error, "Cannot specify method if parameter file is provided")
               exit
            end if
            iarg = iarg + 1
            call get_argument(iarg, config%method)
            if (.not. allocated(config%method)) then
               call fatal_error(error, "Missing argument for method")
               exit
            end if

         case ("--cn")
            iarg = iarg + 1
            call get_argument(iarg, arg)
            if (.not. allocated(arg)) then
               call fatal_error(error, "Missing argument for coordination number")
               exit
            end if
            allocate (config%cn(2))
            call get_argument_as_realv(arg, config%cn, error)
            if (allocated(error)) exit

         case ("--hamiltonian")
            config%hamiltonian = .true.

         case ("--param")
            if (allocated(config%param)) then
               call fatal_error(error, "Cannot specify parameter file if method is provided")
               exit
            end if
            iarg = iarg + 1
            call get_argument(iarg, config%param)
            if (.not. allocated(config%param)) then
               call fatal_error(error, "Missing argument for param")
               exit
            end if

         case ("--bohr")
            config%conv = 1.0_wp

         case ("-o", "--output")
            iarg = iarg + 1
            call get_argument(iarg, arg)
            if (.not. allocated(arg)) then
               call fatal_error(error, "Output file name not specified")
               exit
            end if
            call move_alloc(arg, config%output_file)

         end select
      end do

      if (.not. allocated(config%output_file)) then
         config%output_file = "tblite.npy"
      end if

      if (.not. all([allocated(config%species1), allocated(config%species2), &
         & allocated(config%distance)])) then
         call help(output_unit)
         call fatal_error(error, "Error: Missing positional arguments")
         call handle_error(error)
      end if
   end subroutine get_arguments

   subroutine get_argument_as_realv(arg, val, error)
      !> Index of command line argument, range [0:command_argument_count()]
      character(len=:), intent(in), allocatable :: arg
      !> Real value
      real(wp), intent(out) :: val(:)
      !> Error handling
      type(error_type), allocatable :: error

      integer :: stat
      integer :: i
      character(len=*), parameter :: sep = ","
      character(len=:), allocatable :: targ

      if (.not. allocated(arg)) then
         call fatal_error(error, "Cannot read real value, argument missing")
         return
      end if
      allocate (character(len=len(arg)) :: targ)
      do i = 1, len(arg)
         if (arg(i:i) == sep) then
            targ(i:i) = " "
         else
            targ(i:i) = arg(i:i)
         end if
      end do
      read (targ, *, iostat=stat) val
      if (stat /= 0) then
         call fatal_error(error, "Cannot read real value from '"//arg//"'")
         return
      end if

   end subroutine get_argument_as_realv

   subroutine help(io)
      integer, intent(in) :: io
      character(len=*), parameter :: nl = new_line('a')
      character(len=*), parameter :: help_text = &
                                     "Usage: "//prog_name//" [options] <element1> <element2> <distance>"//nl// &
                                     ""//nl// &
                                     "Takes two element symbols and a distance to calculate the overlap."//nl// &
                                     "Distance vector is given as three comma-separated values in Ångström."//nl// &
                                     ""//nl// &
                                     "Options"//nl// &
                                     ""//nl// &
                                     "      --method <name>     Parametrization of the xTB Hamiltonian to use"//nl// &
                                     "                          Available methods: gfn1, gfn2, ipea1 (Default: gfn2)"//nl// &
                                     "      --param <file>      Parametrization file to use for calculation"//nl// &
                                     "      --hamiltonian       Calculate Hamiltonian instead of overlap integrals"//nl// &
                                     "      --bohr              Use Bohr instead of Angstrom as distance unit"//nl// &
                                     "      --cn <real>,<real>  Coordination number of the two atomic species"//nl// &
                                     "  -o, --output <file>     Output file for writing Hamiltonian"//nl// &
                                     "      --help              Show this help message"//nl// &
                                     ""

      write (io, '(a)') help_text
   end subroutine help

   subroutine handle_error(error)
      use, intrinsic :: iso_fortran_env, only: error_unit
      type(error_type), allocatable, intent(inout) :: error

      interface
         subroutine sys_exit(stat) bind(c, name="exit")
            use, intrinsic :: iso_c_binding, only: c_int
            integer(c_int), value :: stat
         end subroutine sys_exit
      end interface

      if (allocated(error)) then
         write (error_unit, '(a)') error%message

         ! Use exit(3) to get consistent behaviour across compilers
         call sys_exit(1)
      end if
   end subroutine handle_error

   subroutine write_matrix(matrix, name, unit, step)
      real(wp), intent(in) :: matrix(:, :)
      character(len=*), intent(in), optional :: name
      integer, intent(in), optional :: unit
      integer, intent(in), optional :: step
      integer :: d1, d2
      integer :: i, j, k, l, istep, iunit

      d1 = size(matrix, dim=1)
      d2 = size(matrix, dim=2)

      if (present(unit)) then
         iunit = unit
      else
         iunit = output_unit
      end if

      if (present(step)) then
         istep = step
      else
         istep = 5
      end if

      if (present(name)) write (iunit, '("matrix printed:",1x,a)') name

      do i = 1, d2, istep
         l = min(i + istep - 1, d2)
         write (iunit, '(/,6x)', advance='no')
         do k = i, l
            write (iunit, '(9x,i7)', advance='no') k
         end do
         write (iunit, '(a)')
         do j = 1, d1
            write (iunit, '(i6)', advance='no') j
            do k = i, l
               write (iunit, '(1x,f15.8)', advance='no') matrix(j, k)
            end do
            write (iunit, '(a)')
         end do
      end do
      write (iunit, '(a)')

   end subroutine write_matrix

end program integrator


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c                            main idea                                 c
c  using vegas together with pythia to get the more precise results.   c
c  by the several first runs of in the vegas, we may get the optimized c
c  density distribution function which make the distribution of cross- c
c  section not fluctuate too much. After the running of vegas, it will c
c  call the pythia subroutines to generate events. in this way the     c
c  MC efficiency is greatly improved.                                  c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c    A pure linux version BCVEGPY2.1;    using GNU C compiler make     c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c!!!       to save all the datas, you have to create a directory    !!!c
c!!!              named ( data ) at the present directory.   !!!    !!!c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c main program for seting the external process gg->bc+b+\bar{c}        c
c into pythia, whose version is pythia6208.if higher version of pythia c
c exists, your may directly replay the old one with the new one, but   c
c remember to commoment out two subroutines upinit and upevnt there.   c
c we also can provide the quark-anti-quark annihilation mechanism      c
c which via the subprocess q+\bar{q}->Bc+b+\bar{c} with Bc in s-wave   c
c states. Such mechanism has a quite small contribution around 1% of   c
c that of gluon-gluon fusion.                                          c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  bcvegpy1.0   finished  in 10, auguest 2003                          c
c               improved  in 1, november 2003                          c
c copyright (c) c.h. chang, chafik driouich, paula eerola and x.g. wu  c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c the original version of bcvegpy is in reference: hep-ph/0309120      c
c or, in computer physics communication 159, 192-224(2004).            c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c second version bcvegpy2.0, in which (p-wave) generation based on     c
c the gluon-gluon fusion subprocess is given. the gauge invariance     c
c for all the p-wave states have been checked exactly. because we      c
c have implicitly used the propertities of poralization vector to      c
c simplify the amplitude, (such (p.\epsilon(p)=0)) the gauge check can c
c not be done by using the present amplitudes. the interesting reader  c
c may ask the authors for the (full amplitudes) that keep the gauge    c
c invariance exactly.         reference: hep-ph/0504017                c
c      computer physics communication 174, 41,251(2006)                c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c    bcvegpy2.0         finished in 24, febrary 2005                   c
c   copyright (c)       c.h chang, j.x. wang and x.g. wu               c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c problems or suggestions email to:         wuxg@itp.ac.cn             c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c this is the linux version for BCVEGPY2.1, with better modularity and c
c code reusability, i.e. less cross-talk among different modules.      c
c this version combines all the feedback suggestions from the users.   c
c thanks are given for: y.n. gao, j.b. he and z.w. yang                c
c                        finished in 6, April 2006                     c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c...main program.
c      program bcvegpy
      subroutine bcvegpy
      implicit double precision(a-h, o-z)
	implicit integer(i-n)

c...three pythia functions return integers, so need declaring.
      external pydata

c...pythia common block.
      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
      parameter (maxnup=500)
      common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
     &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
     &vtimup(maxnup),spinup(maxnup)
      save /hepeup/

      parameter (maxpup=100)
      integer pdfgup,pdfsup,lprup
      common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
     &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
     &lprup(maxpup)
      save /heprup/

c...user process event common block.
      common/pypars/mstp(200),parp(200),msti(200),pari(200)
	common/counter/ibcstate,nev
	common/vegcross/vegsec,vegerr,iveggrade
	common/confine/ptcut,etacut
	logical generate
	common/genefull/generate
      common/totcross/appcross
      common/ptpass/ptmin,ptmax,crossmax,etamin,etamax,
     &	smin,smax,ymin,ymax,psetamin,psetamax
      common/loggrade/ievntdis,igenerate,ivegasopen,igrade
	common/mixevnt/xbcsec(8),imix,imixtype
	character*8 begin_time,end_time,blank

c....Temporaty file for initialization/event output
        MSTP(161) = 77
        OPEN (77, FILE='BCVEGPY.init',STATUS='unknown')
        MSTP(162) = 78
        OPEN (78, FILE='BCVEGPY.evnt',STATUS='unknown')
c....Final Les Houches Event file, obtained by combaining above two
        MSTP(163) = 79
        OPEN (79, FILE='BCVEGPY.lhe',STATUS='unknown')
        MSTP(164) = 1

c*********************************************
c... setting initial parameters in parameter.F.
c... User may change the values to his/her favorate one.
c*********************************************
      call setparameter

c... initialization, including:
c... if ivegasopen=1, then generate vegas-grade;
c... open files to record data (intermediate results for vegas or
c... pythia running information);
c... if ivegasopen=0 and igrade=1, then initialize the grade;
c... setting some initial values for pythia running.
	call evntinit

C...Fills the HEPRUP commonblock with info on incoming beams and allowed
C...processes, and optionally stores that information on file.
        call bcvegpy_PYUPIN
c...
c*****************************************************************
c...using pybook to record the different distributions or
c...event-distributions.
c*****************************************************************
c*****************************************************************
c...any subroutines about pybook can be conveniently commented out
c...and then one can directly use his/her own way to record the data.
c*****************************************************************

c...pybook init.
	call pybookinit

c...approximate total cross-section.
	appcross =0.0d0
c
	blank  ='    '
	ncount =0
c	call time(begin_time)

c*******************************************************
c...there list some typical ways for recording the data.
c...users may use one convenient way/or their own way.
c******************************************************
c***********find highest weight*******************
      MAXWGT=0.0D0
      do iev=1,10000
      call pyevnt
      if (MAXWGT.le.xwgtup) then
         MAXWGT=xwgtup
      end if
      end do
c---------------------------------------------------
      do iev=1,nev
		call pyevnt
c     call bcvegpy_write_lhe
c**************The unweighting scheme****************
c******the ratio of xwgtup and the xwgtup_max setted at the beginning******
      xwt_r=xwgtup/MAXWGT

      x_r = rand(0)

      if (x_r.le.xwt_r.and.xwt_r.le.1) then
c         write(*,*) "random number ",x_r," ratio ",xwt_r
c         write(*,*) "max xwgtup",MAXWGT
         call bcvegpy_write_lhe
      end if
      if(xwt_r.gt.1) then
         do ic=1,int(xwt_r)
c         write(*,*) "fill times",ic
         call bcvegpy_write_lhe
         end do
         sxwt=xwt_r-int(xwt_r)
         x_r = rand(0)
         if (x_r.le.sxwt) then
         call bcvegpy_write_lhe
         end if
      end if

c****************************************************************
		if (idwtup.eq.1.and.iev.ne.1.and.generate) then
	        call pylist(7)
c	        call time(end_time)
	        print *, iev,blank,end_time
	    end if

		if(msti(51).eq.1) go to 400

c*********************************************************
	    do i=1,10
             if(k(i,2).eq.541) then
c...pt of bc.
                pt =pyp(i,10)
c...true rapidity.
	          eta=pyp(i,17)
c...pseudo-rapidity
	          pseta=pyp(i,19)
c...these two constrain (and other) may be added here to partly compensate
c...some numerical problems.
			  if(pt.lt.ptcut) xwgtup=0.0d0
	          if(abs(eta) .gt. etacut) xwgtup=0.0d0
c...rapidity of the hard-interaction subsystem(ln(x1/x2)/2.0)
			  y=pari(37)
c...the mass of the complete three- final state(\sqrt(shat))
			  st=pari(19)

c**********************************************************************
c...   users may use his own way to record the data      ..............
c**********************************************************************
c...to fill the histogram. we list three methods to get the differential
c...distributions. 1) idwtup=3; 2) (idwtup=1 and generate.eq.fause); 3)
c...(idwtup=1 and generate.eq.true). where method 1) and 2) are the
c...quickest, while the third method is slow.

c...we also list three ways to get the event number distributions:
c...1) (idwtup=1 and generte.eq.true) and ievntdis.eq.1;
c...2)  idwtup=3 and ievntdis.eq.0; 3) (idwtup=1 and generate.eq.fause)
c...and ievntdis.eq.0; the method 2) and 3) are the same, both needs
c...a proper normalization for numbers and at the same time
c...recording every event with it's corresponding weight so as to get
c...final right event number distributions. the method 1) is general
c...one used by experimental, which will spend a long time. so for
c...theoretical studies we suggest using method 2) or 3).
c**********************************************************************
	call uppyfill(idwtup,generate,xwgtup,pt,eta,st,y,pseta)

			  isub=msti(1)
	          ncount=ncount+1
                  if(ncount.le.10) then
                  write(*,'(a,i5)') 'following event is subprocess',isub
                  call pylist(7)
		        call pylist(1)
                end if
                call pyedit(2)
	       end if
	    end do
	end do

c***************************************************************
c...close grade files
      call upclosegradefile(iveggrade,imix,imixtype)
c***************************************************************

c***************************************************************
c...can be commentted out by user, if using his/her own way to
c...record the data.
c---------------------------------------------------------------
c...pyfact all the pybooks.
c	call uppyfact(idwtup,generate,ievntdis)
c...open files to record the obtained pybook data for distributions.
c	call updatafile
c...dump the data into the corresponding files.
c      call uppydump
c...close pybook files.
c      call upclosepyfile
c***************************************************************

c	call time(end_time)
	write(3,'(a,d19.6,a)') 'maximum diff. cross-sec=',crossmax,'pb'
	write(3,'(i9,3x,a,3x,a)') nev,begin_time,end_time

c...when the number of sampling points are high enough, it is
c...just the real value. for (idwtup.eq.1.and.ievntdis.eq.1),
c...becaue of small event number the value of appcros is not
c...accurate.
	if(idwtup.ne.1.and.ievntdis.eq.1) then
	  write(3,'(a,d16.6,1x,a)') '!approxi. total cross-sec=',
     &	appcross,'nb'
      end if

c...store the approximate total cross-section.
c...appcross=\sum(xwgtup*wgt)/nev. when the number of sampling points
c...are high enough, it will be the true value obtained from pythia.
	pari(1) =appcross*1.0d-3
	write(3,'(a,3x,d16.6,x,a)') 'total cross-sec(from pythia)=',
     &	pari(1),'mb'

c*****************************
c...histograms.
       call pyhist
c*****************************
400	continue
c...type cross-section table.
c      call pystat(1)
c
c      write(*,'(a)') 'the cross-section in PYSTAT table is nonsense'
c      write(*,'(a)') 'see the true value in obtained cross-section file'
c      write(*,*)
c      write(3,*)
c      write(3,'(a)') 'note: cross-section in PYSTAT table is nonsense,'
c      write(3,'(a)') 'especially for the mixed events.'
c      write(3,*)
       write(*,*)
       write(*,'(a)') '     program finished !'
       write(*,*)

c***************************

c***************************
c...close intemediate file.
      close(3)

C....Produce final LHE file
c      CALL PYUPIN
c      call bcvegpy_PYUPIN
      CALL PYLHEF

      end     !end of main program


C
C $Id: untfdp.f,v 1.5 2008-07-27 00:17:12 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE UNTFDP (INUNIT,IOUNIT,FACTOR,IFLG)
C
C SUBROUTINE TO DETERMINE CONVERGENCE FACTOR BETWEEN TWO LINEAL UNITS
C
C * INPUT ........
C * INUNIT * UNIT CODE OF SOURCE.
C * IOUNIT * UNIT CODE OF TARGET.
C
C * OUTPUT .......
C * FACTOR * CONVERGENCE FACTOR FROM SOURCE TO TARGET.
C * IFLG   * RETURN FLAG .EQ. 0 , NORMAL RETURN.
C            RETURN FLAG .NE. 0 , ABNORMAL RETURN.
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      INTEGER INUNIT,IOUNIT,IFLG,MAXUNT
      DIMENSION FACTRS(6,6)
      COMMON /PRINZ0/ IPEMSG,IPELUN,IPPARM,IPPLUN
        INTEGER IPEMSG,IPELUN,IPPARM,IPPLUN
      SAVE   /PRINZ0/
      PARAMETER (ZERO = 0.0D0, MAXUNT = 6)
      DATA FACTRS /0.1000000000000000D01 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.2062648062470963D06 ,
     .             0.5729577951308231D02 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.1000000000000000D01 ,
     .             0.3048006096012192D00 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.1000002000004000D01 ,
     .             0.0000000000000000D00 , 0.3280833333333333D01 ,
     .             0.1000000000000000D01 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.3280839895013124D01 ,
     .             0.4848136811095360D-5 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.1000000000000000D01 ,
     .             0.2777777777777778D-3 , 0.0000000000000000D00 ,
     .             0.1745329251994330D-1 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.3600000000000000D04 ,
     .             0.1000000000000000D01 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.9999980000000000D00 ,
     .             0.3048000000000000D00 , 0.0000000000000000D00 ,
     .             0.0000000000000000D00 , 0.1000000000000000D01 /
C
      IF (INUNIT .GE. 0 .AND. INUNIT .LT. MAXUNT .AND.
     .    IOUNIT .GE. 0 .AND. IOUNIT .LT. MAXUNT) THEN
         FACTOR = FACTRS(IOUNIT+1 , INUNIT+1)
         IF (FACTOR .NE. ZERO) THEN
            IFLG = 0
            RETURN
         ELSE
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2000) INUNIT,IOUNIT
 2000       FORMAT (' INCONSISTENT UNIT CODES = ',I6,' / ',I6)
            IFLG = 12
            RETURN
         END IF
      ELSE
         IF (INUNIT.LT.0 .OR. INUNIT.GE.MAXUNT) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2010) INUNIT
 2010       FORMAT (' ILLEGAL SOURCE OR TARGET UNIT CODE = ',I6)
         ELSE
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2010) IOUNIT
         END IF
         IFLG = 11
         RETURN
      END IF
C
      END