! KGEN-generated Fortran source file
!
! Filename    : rrtmg_lw_cldprmc.f90
! Generated at: 2015-07-26 20:16:59
! KGEN version: 0.4.13

    MODULE rrtmg_lw_cldprmc
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        !  --------------------------------------------------------------------------
        ! |                                                                          |
        ! |  Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER).  |
        ! |  This software may be used, copied, or redistributed as long as it is    |
        ! |  not sold and this copyright notice is reproduced on each copy made.     |
        ! |  This model is provided as is without any express or implied warranties. |
        ! |                       (http://www.rtweb.aer.com/)                        |
        ! |                                                                          |
        !  --------------------------------------------------------------------------
        ! --------- Modules ----------
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind, only : jpim, jprb
        USE parrrtm, ONLY: ngptlw
        USE rrlw_cld, ONLY: absice0
        USE rrlw_cld, ONLY: absice1
        USE rrlw_cld, ONLY: absice2
        USE rrlw_cld, ONLY: absice3
        USE rrlw_cld, ONLY: absliq0
        USE rrlw_cld, ONLY: absliq1
        USE rrlw_wvn, ONLY: ngb
        USE rrlw_vsn, ONLY: hvrclc
        IMPLICIT NONE
        CONTAINS

        ! write subroutines
        ! No subroutines
        ! No module extern variables
        ! ------------------------------------------------------------------------------

        SUBROUTINE cldprmc(ncol, nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, clwpmc, reicmc, dgesmc, relqmc, ncbands, &
        taucmc)
            ! ------------------------------------------------------------------------------
            ! Purpose:  Compute the cloud optical depth(s) for each cloudy layer.
            ! ------- Input -------
            INTEGER, intent(in) :: ncol ! total number of columns
            INTEGER, intent(in) :: nlayers ! total number of layers
            INTEGER, intent(in) :: inflag ! see definitions
            INTEGER, intent(in) :: iceflag ! see definitions
            INTEGER, intent(in) :: liqflag ! see definitions
            !    Dimensions: (ncol)
            REAL(KIND=r8), intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica]
            !    Dimensions: (ncol,ngptlw,nlayers)
            REAL(KIND=r8), intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica]
            !    Dimensions: (ncol,ngptlw,nlayers)
            REAL(KIND=r8), intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica]
            !    Dimensions: (ncol,ngptlw,nlayers)
            REAL(KIND=r8), intent(in) :: relqmc(:,:) ! liquid particle effective radius (microns)
            !    Dimensions: (ncol,nlayers)
            REAL(KIND=r8), intent(in) :: reicmc(:,:) ! ice particle effective radius (microns)
            !    Dimensions: (ncol,nlayers)
            REAL(KIND=r8), intent(in) :: dgesmc(:,:) ! ice particle generalized effective size (microns)
            !    Dimensions: (ncol,nlayers)
            ! ------- Output -------
            INTEGER, intent(out) :: ncbands(:) ! number of cloud spectral bands
            !    Dimensions: (ncol)
            REAL(KIND=r8), intent(inout) :: taucmc(:,:,:) ! cloud optical depth [mcica]
            !    Dimensions: (ncol,ngptlw,nlayers)
            ! ------- Local -------
            INTEGER :: lay ! Layer index
            INTEGER :: ib ! spectral band index
            INTEGER :: ig ! g-point interval index
            REAL(KIND=r8) :: abscoice(ngptlw) ! ice absorption coefficients
            REAL(KIND=r8) :: abscoliq(ngptlw) ! liquid absorption coefficients
            REAL(KIND=r8) :: cwp ! cloud water path
            REAL(KIND=r8) :: radice ! cloud ice effective radius (microns)
            REAL(KIND=r8) :: dgeice ! cloud ice generalized effective size
            REAL(KIND=r8) :: factor !
            REAL(KIND=r8) :: fint !
            REAL(KIND=r8) :: radliq ! cloud liquid droplet radius (microns)
            ! epsilon
            REAL(KIND=r8), parameter :: cldmin = 1.e-80_r8 ! minimum value for cloud quantities
            ! ------- Definitions -------
            !     Explanation of the method for each value of INFLAG.  Values of
            !     0 or 1 for INFLAG do not distingish being liquid and ice clouds.
            !     INFLAG = 2 does distinguish between liquid and ice clouds, and
            !     requires further user input to specify the method to be used to
            !     compute the aborption due to each.
            !     INFLAG = 0:  For each cloudy layer, the cloud fraction and (gray)
            !                  optical depth are input.
            !     INFLAG = 1:  For each cloudy layer, the cloud fraction and cloud
            !                  water path (g/m2) are input.  The (gray) cloud optical
            !                  depth is computed as in CAM3.
            !     INFLAG = 2:  For each cloudy layer, the cloud fraction, cloud
            !                  water path (g/m2), and cloud ice fraction are input.
            !       ICEFLAG = 0:  The ice effective radius (microns) is input and the
            !                     optical depths due to ice clouds are computed as in CAM3.
            !       ICEFLAG = 1:  The ice effective radius (microns) is input and the
            !                     optical depths due to ice clouds are computed as in
            !                     Ebert and Curry, JGR, 97, 3831-3836 (1992).  The
            !                     spectral regions in this work have been matched with
            !                     the spectral bands in RRTM to as great an extent
            !                     as possible:
            !                     E&C 1      IB = 5      RRTM bands 9-16
            !                     E&C 2      IB = 4      RRTM bands 6-8
            !                     E&C 3      IB = 3      RRTM bands 3-5
            !                     E&C 4      IB = 2      RRTM band 2
            !                     E&C 5      IB = 1      RRTM band 1
            !       ICEFLAG = 2:  The ice effective radius (microns) is input and the
            !                     optical properties due to ice clouds are computed from
            !                     the optical properties stored in the RT code,
            !                     STREAMER v3.0 (Reference: Key. J., Streamer
            !                     User's Guide, Cooperative Institute for
            !                     Meteorological Satellite Studies, 2001, 96 pp.).
            !                     Valid range of values for re are between 5.0 and
            !                     131.0 micron.
            !       ICEFLAG = 3: The ice generalized effective size (dge) is input
            !                    and the optical properties, are calculated as in
            !                    Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
            !                    tables which were appropriately averaged for the
            !                    bands in RRTM_LW.  Linear interpolation is used to
            !                    get the coefficients from the stored tables.
            !                    Valid range of values for dge are between 5.0 and
            !                    140.0 micron.
            !       LIQFLAG = 0:  The optical depths due to water clouds are computed as
            !                     in CAM3.
            !       LIQFLAG = 1:  The water droplet effective radius (microns) is input
            !                     and the optical depths due to water clouds are computed
            !                     as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
            !                     The values for absorption coefficients appropriate for
            !                     the spectral bands in RRTM have been obtained for a
            !                     range of effective radii by an averaging procedure
            !                     based on the work of J. Pinto (private communication).
            !                     Linear interpolation is used to get the absorption
            !                     coefficients for the input effective radius.
            INTEGER :: iplon,index
      hvrclc = '$Revision: 1.5 $'
      ncbands = 1
            ! This initialization is done in rrtmg_lw_subcol.F90.
            !      do lay = 1, nlayers
            !         do ig = 1, ngptlw
            !            taucmc(ig,lay) = 0.0_r8
            !         enddo
            !      enddo
            ! Main layer loop
      do iplon=1,ncol
       do lay = 1, nlayers
        do ig = 1, ngptlw
          cwp = ciwpmc(iplon,ig,lay) + clwpmc(iplon,ig,lay)
          if (cldfmc(iplon,ig,lay) .ge. cldmin .and. &
             (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then
                            ! Ice clouds and water clouds combined.
            if (inflag .eq. 0) then
                                ! Cloud optical depth already defined in taucmc, return to main program
               return
            elseif(inflag .eq. 1) then
                stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
                                !               cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
                                !               taucmc(ig,lay) = abscld1 * cwp
                                ! Separate treatement of ice clouds and water clouds.
            elseif(inflag .eq. 2) then
               radice = reicmc(iplon,lay)
                                ! Calculation of absorption coefficients due to ice clouds.
               if (ciwpmc(iplon,ig,lay) .eq. 0.0_r8) then
                  abscoice(ig) = 0.0_r8
               elseif (iceflag .eq. 0) then
                  if (radice .lt. 10.0_r8) stop 'ICE RADIUS TOO SMALL'
                  abscoice(ig) = absice0(1) + absice0(2)/radice
               elseif (iceflag .eq. 1) then
                                    ! mji - turn off limits to mimic CAM3
                                    !                  if (radice .lt. 13.0_r8 .or. radice .gt. 130._r8) stop &
                                    !                      'ICE RADIUS OUT OF BOUNDS'
                  ncbands(iplon) = 5
                  ib = ngb(ig)
                  abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice
                                    ! For iceflag=2 option, combine with iceflag=0 option to handle out of bounds
                                    ! particle sizes.
                                    ! Use iceflag=2 option for ice particle effective radii from 5.0 and 131.0 microns
                                    ! and use iceflag=0 option for ice particles greater than 131.0 microns.
                                    ! *** NOTE: Transition between two methods has not been smoothed.
               elseif (iceflag .eq. 2) then
                  if (radice .lt. 5.0_r8) stop 'ICE RADIUS OUT OF BOUNDS'
                  if (radice .ge. 5.0_r8 .and. radice .le. 131._r8) then
                     ncbands(iplon) = 16
                     factor = (radice - 2._r8)/3._r8
                     index = int(factor)
                     if (index .eq. 43) index = 42
                     fint = factor - float(index)
                     ib = ngb(ig)
                     abscoice(ig) = &
                         absice2(index,ib) + fint * &
                         (absice2(index+1,ib) - (absice2(index,ib)))
                  elseif (radice .gt. 131._r8) then
                     abscoice(ig) = absice0(1) + absice0(2)/radice
                  endif
                                    ! For iceflag=3 option, combine with iceflag=0 option to handle large particle sizes.
                                    ! Use iceflag=3 option for ice particle effective radii from 3.2 and 91.0 microns
                                    ! (generalized effective size, dge, from 5 to 140 microns), and use iceflag=0 option
                                    ! for ice particle effective radii greater than 91.0 microns (dge = 140 microns).
                                    ! *** NOTE: Fu parameterization requires particle size in generalized effective size.
                                    ! *** NOTE: Transition between two methods has not been smoothed.
               elseif (iceflag .eq. 3) then
                  dgeice = dgesmc(iplon,lay)
                  if (dgeice .lt. 5.0_r8) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
                  if (dgeice .ge. 5.0_r8 .and. dgeice .le. 140._r8) then
                     ncbands(iplon) = 16
                     factor = (dgeice - 2._r8)/3._r8
                     index = int(factor)
                     if (index .eq. 46) index = 45
                     fint = factor - float(index)
                     ib = ngb(ig)
                     abscoice(ig) = &
                         absice3(index,ib) + fint * &
                         (absice3(index+1,ib) - (absice3(index,ib)))
                  elseif (dgeice .gt. 140._r8) then
                     abscoice(ig) = absice0(1) + absice0(2)/radice
                  endif
               endif
                                ! Calculation of absorption coefficients due to water clouds.
               if (clwpmc(iplon,ig,lay) .eq. 0.0_r8) then
                  abscoliq(ig) = 0.0_r8
               elseif (liqflag .eq. 0) then
                   abscoliq(ig) = absliq0
               elseif (liqflag .eq. 1) then
                  radliq = relqmc(iplon,lay)
                  if (radliq .lt. 1.5_r8 .or. radliq .gt. 60._r8) stop &
                       'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS'
                  index = radliq - 1.5_r8
                  if (index .eq. 58) index = 57
                  if (index .eq. 0) index = 1
                  fint = radliq - 1.5_r8 - index
                  ib = ngb(ig)
                  abscoliq(ig) = &
                        absliq1(index,ib) + fint * &
                        (absliq1(index+1,ib) - (absliq1(index,ib)))
               endif
               taucmc(iplon,ig,lay) = ciwpmc(iplon,ig,lay) * abscoice(ig) + &
                                clwpmc(iplon,ig,lay) * abscoliq(ig)
            endif
         endif
         enddo
      enddo
    enddo
        END SUBROUTINE cldprmc
    END MODULE rrtmg_lw_cldprmc


      module siesta_pass
      !APE modules (modified)
      use global
      use mesh, only: mesh_null, mesh_type, mesh_generation, mesh_end,&
      mesh_transfer
      !QE modules
      use radial_grids, only: radial_grid_type,ndmx
      use ld1inc, only: zed,enne,zval,nwf,nn,ll,jj,el,rcut,octsc,&
      enltsc,phis,lloc,nbeta,rhos,pawsetup,enls,vpsloc,betas,rho,&
      lls,isws,nlcc,&
      rhoc,rcore,nns,nwfs,vnl,ikk,ocs,oc
      use ld1_parameters, only: nwfx,nwfsx

      type ps_io_type
      integer :: file_format

      type(mesh_type) :: m

      !Generalities
      character(3) :: symbol
      real(R8) :: z_nuc
      real(R8) :: z_val
      real(R8) :: z_ion
      integer :: wave_eq
      integer :: nspin
      integer :: scheme

      !Pseudo potentials
      logical :: have_psp
      integer :: n_psp!the number of pseudopotentials
      integer,  pointer :: psp_l(:)
      real(R8), pointer :: psp_j(:)
      real(R8), pointer :: psp_v(:,:)

      !Pseudo wavefunctions
      logical :: have_wfs
      integer :: n_wfs
      integer :: n_pwfs
      integer, pointer :: wfs_n(:)
      integer, pointer :: wfs_l(:)
      real(R8), pointer :: wfs_j(:)
      character(len=5), pointer :: wfs_label(:)
      real(R8), pointer :: wfs_rc(:)
      real(R8), pointer :: wfs_occ(:,:)
      real(R8), pointer :: wfs_ev(:)
      real(R8), pointer :: wfs(:,:)
      real(R8), pointer :: rho_val(:)

      !XC
      integer :: ixc!exchange correlation functional
      !ape seems to only really allow certain combinations of X and C. set this as constant for now

      !Non-linear core-corrections
      logical :: nlcc
      real(R8) :: nlcc_rc
      real(R8), pointer :: rho_core(:)

      !Kleinman-Bylander projectors
      logical :: have_kb!
      integer :: kb_l_local!
      integer :: kb_n_proj!
      integer,  pointer :: kb_l(:)!
      real(R8), pointer :: kb_j(:)!
      real(R8), pointer :: kb_v_local(:)!
      real(R8), pointer :: kb_e(:)!
      real(R8), pointer :: kb_proj(:,:)!
      end type ps_io_type

      contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!MAIN FUNCTION
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine siesta_output(grid_in)
       type(radial_grid_type), intent(in):: grid_in
       type(ps_io_type) :: info
       print *, "call the ps fill up routine"
       call ps_io_type_fill(grid_in,info)
       print *, "information correctly formatted, now outputting"
       call ps_io_save(info)
      endsubroutine siesta_output
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      function cutoff_function(r) result(j)
        real(R8), intent(in) :: r ! input
        real(R8):: j ! output
        j = exp(-5*r)!this is the correct siesta way
        if (abs(j) .lt. 1.0d-99) then
          j = 0.0d0
        endif
      end function cutoff_function

      function alt_cutoff(r) result(j)
        real(R8), intent(in) :: r ! input
        real(R8):: j ! output
        j = exp(-5*r)!this is the correct siesta way
        if (abs(j) .lt. 1.0d-99) then
          j = 0.0d0
        endif
      end function alt_cutoff

      subroutine ps_io_type_fill(grid_in,info)
       type(radial_grid_type), intent(in) :: grid_in
       type(ps_io_type) ,intent(out) :: info
       !mesh parameters
       type(mesh_type) :: m
       integer :: no_mesh_points,i,j,l,ir,ns,lam,n,jcut
       real(R8) :: rn,r1
       !generalities
       character, external :: atom_name*2

       info%file_format=M_SIESTA! these values are defined in the global.o file

       !set the mesh
       info%m%type=2!set the mesh type to LOG1 ri=b*exp(a*i)
       !set number of mesh points
       no_mesh_points=grid_in%mesh
       allocate(m%r(no_mesh_points))
       m%np=no_mesh_points

       !set the mesh parameters
       r1=grid_in%r(1)
       rn=grid_in%r(no_mesh_points)
       m%a = log(rn/r1)/real(no_mesh_points - 1,R8)
       m%b = r1/exp(m%a)

       !allocate mesh points
       m%r(:)=grid_in%r(:)
       !put this back into the info type
       info%m=m

       !set the generalities
       !set nuclear charge
       info%z_nuc=zed
       !set charge of the ion
       info%z_ion=zed-enne
       !set name
       info%symbol=atom_name(nint(zed))
       !set valence charge
       info%z_val=zval
       !wave_eq to integrate one of schrod. dirac or scalar_rel (1,2,3)
       info%wave_eq=SCHRODINGER!lets assume this for now
       !number of spin channels
       info%nspin=1!assume this for now
       !pseudo potential scheme one of HAM TM RTM MRPP (1,2,3,4)
       info%scheme=2!assume just TM for now

       !set the wavefunction stuff now
       info%have_wfs=.true.
       info%n_wfs=nwf
       info%n_pwfs=0 !this is the number of pseudo wavefunctions. we'll set this later
       allocate(info%wfs_n(nwfx))
       info%wfs_n(:)=nn(:)
       allocate(info%wfs_l(nwfx))
       info%wfs_l(:)=ll(:)
       !allocate(info%wfs_j(nwfx))
       !info%wfs_j(:)=jj(:)
       allocate(info%wfs_label(nwfx))
       info%wfs_label(:)=el(:)
       allocate(info%wfs_rc(nwfsx))!cut off for pseudos (NO US allowed)
       info%wfs_rc(:)=rcut(:)
       allocate(info%wfs_occ(nwfx,info%nspin))
       !here we are using the variale configuration occupation listing, just the first one though
       !info%wfs_occ(:,1)=octsc(:,1)!pretend there's only a single spin channel
       info%wfs_occ(:,1)=oc(:)!pretend there's only a single spin channel
       allocate(info%wfs_ev(nwfsx))
       !info%wfs_ev(:)=enltsc(:,1)
       info%wfs_ev(:)=enls(:)
       allocate(info%wfs(ndmx,nwfsx))
       info%wfs(:,:)=phis(:,:)
       allocate(info%rho_val(ndmx))
       info%rho_val(:)=rhos(:,1)
       !rhos(ndmx,2), i guess this is up and down density. with nspin=1 only 1 channel here is nonzero
       !(check this again later, i might have the wrong channel ^)

       !set xc stuff
       info%ixc=1!this should be set as a constant for now, check code later on to see how to integrate it properly
       info%nlcc=nlcc
       allocate(info%rho_core(ndmx))
       info%rho_core(:)=rhoc(:)
       info%nlcc_rc=rcore

       !set pseudo_potentials
       info%have_psp=.true.
       info%n_psp=nwfs

       !the l components are equal to those of the wavefunctions
       allocate(info%psp_l(nwfs))
       info%psp_l=lls(:nwfs)

       !this is for spin polarised crap !ignore for now
       allocate(info%psp_j(nwfs))
       do i=1,nwfs,1
       info%psp_j(i)=M_ZERO!not needed for non spin polarised
       enddo

!set the potential
       allocate(info%psp_v(ndmx,4))

       do lam=0,3
         do n=1,m%np
           info%psp_v(n,lam+1)= (vnl(n,lam,1)+vpsloc(n))!correct
         enddo
       enddo

       !get jcut mesh index. this is the point where we should just cut off the calculated potential values
       do lam=1,4
         do n=1,m%np
           if (abs(info%psp_v(n,lam)+2*zval/m%r(n)) .gt. 1.d-3) then
           !if (abs(info%psp_v(n,lam)) .gt. 1.d-3) then
             jcut=n
           endif
         enddo
       !put jcut in the middle of the mesh

       print *, "jcut values"
       print *, jcut
       print *, info%m%r(jcut)

       !smooth the curve!this seems all correct 4/8/11
         do n=jcut,m%np
           info%psp_v(n,lam)=-2*zval/m%r(n) + cutoff_function(m%r(n)-m%r(jcut))*(info%psp_v(n,lam)+2*zval/m%r(n))
         enddo
       enddo!end the lam loop

       do n=1,nwfsx !set the number of pseudo wavefunctions
         if (ocs(n) .ne. 0) then
           info%n_pwfs=info%n_pwfs+1
         end if
       enddo

       do l=1,nwfsx!define the proper cutoff values of the wfs (i.e. the mesh point closest to the the cutoff we selected)
         do n=1,grid_in%mesh
           if ( info%m%r(n) .lt. rcut(l) ) then
             info%wfs_rc(l) = info%m%r(n)
           endif
         enddo
       enddo

       print *, "cutoffs"
       print *, info%wfs_rc(:)
       print *, rcut(:)

       open (unit=997,file="psp_v.dat",action="write",status="replace")
       do n=1,m%np
         write (997,*) info%m%r(n),info%psp_v(n,1)*info%m%r(n)+2*zval,(vnl(n,1,1)+vpsloc(n))*info%m%r(n)+2*zval
       enddo
       close (997)

      endsubroutine ps_io_type_fill

      subroutine ps_io_save(info)!this seems only necessary to setup the filename and assign io units
      !-----------------------------------------------------------------------!
      ! Writes the pseudo-atom information to a file so it can be used by     !
      ! other codes.                                                          !
      !-----------------------------------------------------------------------!
      integer :: unit, iostat
      character(len=20) :: filename
      type(ps_io_type), intent(in) :: info

      !Open file
      !call io_assign(unit)
      unit=999!just make sure this is out of the range of the ld1x (seems to be ok though)
      filename = trim(info%symbol)//'.psf'
      open(unit, file=trim(filename), status='unknown', iostat=iostat)
      if (iostat > 0) then
        print *, "Error: something wrong with filename"
        !write(message(1),'("Unable to open file ''",A,"''")') trim(filename)
        !call write_fatal(1)
      end if

      !Write data to the file
      call siesta_save(unit, .false.,info)

      close(unit)

      end subroutine ps_io_save

        subroutine siesta_save(unit, parsec, info)
        !-----------------------------------------------------------------------!
        ! Write the pseudo-potential stuff using the format of the SIESTA code. !
        !-----------------------------------------------------------------------!
        integer, intent(in) :: unit
        logical, intent(in) :: parsec
        type(ps_io_type), intent(in) :: info

        integer :: i, l, n_dn, n_up, values(8), n, ir
        real(R8) :: j, occ
        character(3)    :: irel
        character(4)    :: icore
        character(60)   :: header
        character(70)   :: title
        type(mesh_type) :: new_m
        real(R8), allocatable :: dum(:)

        !Get spin/relativistic mode and number of states
        select case (info%wave_eq)
        case (DIRAC)
          irel = "rel"
          n_up = 0
          n_dn = 0
          do i = 1, info%n_psp
            if (info%psp_l(i) == 0 .or. (info%psp_l(i) /= 0 .and. &
                 info%psp_j(i) == info%psp_l(i) - M_HALF)) then
              n_dn = n_dn + 1
            elseif (info%psp_l(i) /= 0 .and. &
                    (info%psp_j(i) == info%psp_l(i) + M_HALF)) then
              n_up = n_up + 1

            end if
          end do
        case (SCHRODINGER, SCALAR_REL)
          n_dn = info%n_psp
          select case (info%nspin)
          case (1)
            irel = "nrl"
            n_up = 0
          case (2)
            irel = "isp"
            n_up = n_dn
          end select
        end select

        call date_and_time(values=values)
        write(header,'(A,A,3X,I4.4,"/",I2.2,"/",I2.2)') "APE-QE&
             Version-", PACKAGE_VERSION, values(1), values(2), values(3)
        select case (info%scheme)
        case (HAM)
          header = trim(header)//"   Hamann"
        case (TM)
          header = trim(header)//"   Troullier-Martins"
        end select

        !Core corrections mode
        if (info%nlcc) then
          icore = "pcec"
        else
          icore = "nc  "
        end if

        !
        title = ""

!        do l = 0, 3
!          n = minval(info%wfs_n, mask=info%wfs_l == l)
!          !j = minval(info%wfs_j, mask=(info%wfs_l == l .and. info%wfs_n == n))
!
!          do i = 1, info%n_wfs
!            !if (info%wfs_n(i) == n .and. info%wfs_l(i) == l .and. info%wfs_j(i) == j) then
!            if (info%wfs_n(i) == n .and. info%wfs_l(i) == l) then
!              !select case (irel)
!              !case('nrl')
!                write(title,'(A)') (title)
!                write(title,'(A)') trim(title)
!                !here
!                write(title,'(A,A2,F5.2,"  r=",F5.2,"/")') trim(title),&
!                                info%wfs_label(i), info%wfs_occ(i, 1),&
!                                 info%wfs_rc(i)
!     !!          case('isp')
!     !!            write(title,'(A,A2,F4.2,1X,F4.2,1X,F4.2,"/")') &
!      trim(title), &
!     !!                     info%wfs_label(i), info%wfs_occ(i, 1),&
!       info%wfs_occ(i, 2), &
!     !!                     info%wfs_rc(i)
!     !!          case ('rel')
!     !!            occ = sum(info%wfs_occ(:, 1), mask=(info%wfs_l == l&
!      .and. &
!     !!                 (info%wfs_j == l + M_HALF .or. info%wfs_j == l&
!       - M_HALF)))
!     !!            write(title,'(A,A2,F5.2,"  r=",F5.2,"/")') &
!      trim(title), &
!     !!                                           info%wfs_label(i), &
!      occ, info%wfs_rc(i)
!     !!          end select
!            end if
!          end do
!        end do

        !my siesta title thing
        !do i=info%n_wfs-nwfts+1, info%n_wfs
        print *, info%wfs_occ(:,1)
        l=1
        do i=info%n_wfs-info%n_pwfs+1, info%n_wfs
          if (info%wfs_occ(i, 1) .le. 0) then
            info%wfs_occ(i, 1)=0.0
          endif
          write(title,'(A,A2,F5.2,"  r=",F5.2,"/")') trim(title),&
                                info%wfs_label(i),&
                                info%wfs_occ(i, 1),&
                                info%wfs_rc(l)
          l=l+1
        enddo
        print *, title

        !Mesh
        call mesh_null(new_m)
        call mesh_generation(new_m, LOG2, info%m%r(1), info%m%r(info%m%np), info%m%np)

        !General info
        !write(unit,'(1X,A2,1X,A2,1X,A3,1X,A4)') info%symbol(1:2), ixc_to_icorr(info%ixc), irel, icore! we have a problem with ixc
        write(unit,'(1X,A2,1X,A2,1X,A3,1X,A4)') info%symbol(1:2), info%ixc, irel, icore
        write(unit,'(1X,A60)') header
        write(unit,'(1X,A70)') title
        !write(unit,'(1X,2I3,I5,3F20.10)') n_dn, n_up, new_m%np, new_m%b, new_m%a, info%z_val
        write(unit,'(1X,2I3,I5,3F20.10)') n_dn, n_up, info%m%np, info%m%b, info%m%a, info%z_val

        !Write radial grid
        write(unit,'(" Radial grid follows")')
        !write(unit,'(4(g20.12))') (new_m%r(i),i = 1, new_m%np)
        write(unit,'(4(g20.12))') (info%m%r(i),i = 1, info%m%np)
        allocate(dum(new_m%np))

        !Down pseudopotentials
        do l = 0, 3
          if (info%wave_eq == DIRAC) then
            j = max(l - M_HALF, M_HALF)
          else
            j = M_ZERO
          end if

          do i = 1, info%n_psp
            if (info%psp_l(i) == l .and. info%psp_j(i) == j) then
              write(unit,'(" Down Pseudopotential follows (l on next line)")')
              write(unit,'(1X,I2)') info%psp_l(i)

              !call mesh_transfer(info%m, info%psp_v(:, i), new_m, dum, 3)
              call mesh_transfer(info%m, info%psp_v(:, i), new_m, dum, 1)
      !interploation type (last arg) could be 1,2,5
              where (abs(dum) < 1.0E-30)
                dum = M_ZERO
              end where
              !write(unit,'(4(g20.12))') (dum(ir)*new_m%r(ir)*M_TWO, ir = 1, new_m%np)
              !write(unit,'(4(g20.12))') (dum(ir)*new_m%r(ir), ir = 1, new_m%np)
              !why not just use our own data
              write(unit,'(4(g20.12))') (info%psp_v(ir,i)*info%m%r(ir), ir = 1, info%m%np)
              !write(unit,'(4(g20.12))') (dum(ir), ir = 1, new_m%np)!!edit here
            end if
          end do
        end do

        !Up pseudopotentials
        if (n_up /= 0) then
          do l = 0, 3
            do i = 1, info%n_psp
              if (l /= 0 .and. info%wave_eq == DIRAC) then
                j = l + M_HALF
              else
                j = M_ZERO
              end if

              if (info%psp_l(i) == l .and. info%psp_j(i) == j) then
                write(unit,'(" Up Pseudopotential follows (l on next line)")')
                write(unit,'(1X,I2)') info%psp_l(i)

                call mesh_transfer(info%m, info%psp_v(:, i), new_m, dum, 3)
                where (abs(dum) < 1.0E-30)
                  dum = M_ZERO
                end where
                write(unit,'(4(g20.12))') (dum(ir)*new_m%r(ir)*M_TWO, ir = 1, new_m%np)
              end if
            end do
          end do
        end if

        !Write core charge
        write(unit,'(" Core charge follows")')
        if (icore == "nc  ") then
          dum = M_ZERO
        else
          call mesh_transfer(info%m, info%rho_core, new_m, dum, 3)
          where (abs(dum) < 1.0E-30)
            dum = M_ZERO
          elsewhere
            dum = new_m%r**2*M_FOUR*M_PI*dum
          end where
        end if
        write(unit,'(4(g20.12))') (dum(i), i = 1, new_m%np)

        !Write valence charge
        write(unit,'(" Valence charge follows")')
        call mesh_transfer(info%m, info%rho_val, new_m, dum, 3)
!        where (abs(dum) < 1.0E-30)
!          dum = M_ZERO
!        end where
!        write(unit,'(4(g20.12))') (dum(i)*new_m%r(i)**2*M_FOUR*M_PI, i = 1, new_m%np)
        where (abs(info%rho_val) < 1.0E-30)
          info%rho_val = M_ZERO
        end where
        !write(unit,'(4(g20.12))') (info%rho_val(i)*info%m%r(i)**2*M_FOUR*M_PI, i = 1, info%m%np)
        write(unit,'(4(g20.12))') (info%rho_val(i), i = 1, info%m%np)

        if (parsec) then
          !Write pseudo-wave-functions
          do l = 0, 3
            n = minval(info%wfs_n, mask=info%wfs_l == l)
            j = minval(info%wfs_j, mask=(info%wfs_l == l .and. info%wfs_n == n))

            do i = 1, info%n_wfs
              if (info%wfs_n(i) == n .and. info%wfs_l(i) == l .and. info%wfs_j(i) == j) then

                call mesh_transfer(info%m, info%wfs(:, i), new_m, dum, 3)

                write(unit,'(1X,A,A2)') 'Pseudo-wave-function follows (l, zelect, rc)  ',info%wfs_label(i)
                write(unit,'(I2,F6.2,2X,F6.2)') info%wfs_l(i), &
                     info%wfs_occ(i, 1), info%wfs_rc(i)
                write(unit,'(1P4E19.11)') (dum(ir)*new_m%r(ir), ir = 1, new_m%np)

              end if
            end do

          end do
        end if

        deallocate(dum)
        call mesh_end(new_m)

      end subroutine siesta_save
      end module siesta_pass


Subroutine hijcsc(jp, jt)
  Dimension psc1(5), psc2(5)
  Common /hjcrdn/yp(3, 300), yt(3, 300)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /rndf77/nseed
  Common /hstrng/nfp(300, 15), pp(300, 15), nft(300, 15), pt(300, 15)
  Save
  If (jp==0 .Or. jt==0) Goto 25
  Do i = 1, 5
    psc1(i) = pp(jp, i)
    psc2(i) = pt(jt, i)
  End Do
  Call hijels(psc1, psc2)
  dpp1 = psc1(1) - pp(jp, 1)
  dpp2 = psc1(2) - pp(jp, 2)
  dpt1 = psc2(1) - pt(jt, 1)
  dpt2 = psc2(2) - pt(jt, 2)
  pp(jp, 6) = pp(jp, 6) + dpp1/2.0
  pp(jp, 7) = pp(jp, 7) + dpp2/2.0
  pp(jp, 8) = pp(jp, 8) + dpp1/2.0
  pp(jp, 9) = pp(jp, 9) + dpp2/2.0
  pt(jt, 6) = pt(jt, 6) + dpt1/2.0
  pt(jt, 7) = pt(jt, 7) + dpt2/2.0
  pt(jt, 8) = pt(jt, 8) + dpt1/2.0
  pt(jt, 9) = pt(jt, 9) + dpt2/2.0
  Do i = 1, 4
    pp(jp, i) = psc1(i)
    pt(jt, i) = psc2(i)
  End Do
  nfp(jp, 5) = max(1, nfp(jp,5))
  nft(jt, 5) = max(1, nft(jt,5))
  Return
  25 If (jp==0) Goto 45
  pabs = sqrt(pp(jp,1)**2+pp(jp,2)**2+pp(jp,3)**2)
  bx = pp(jp, 1)/pabs
  by = pp(jp, 2)/pabs
  bz = pp(jp, 3)/pabs
  Do i = 1, ihnt2(1)
    If (i==jp) Goto 40
    dx = yp(1, i) - yp(1, jp)
    dy = yp(2, i) - yp(2, jp)
    dz = yp(3, i) - yp(3, jp)
    dis = dx*bx + dy*by + dz*bz
    If (dis<=0) Goto 40
    bb = dx**2 + dy**2 + dz**2 - dis**2
    r2 = bb*hipr1(40)/hipr1(31)/0.1
    gs = 1.0 - exp(-(hipr1(30)+hint1(11))/hipr1(31)/2.0*romg(r2))**2
    gs0 = 1.0 - exp(-(hipr1(30)+hint1(11))/hipr1(31)/2.0*romg(0.0))**2
    If (ranart(nseed)>gs/gs0) Goto 40
    Do k = 1, 5
      psc1(k) = pp(jp, k)
      psc2(k) = pp(i, k)
    End Do
    Call hijels(psc1, psc2)
    dpp1 = psc1(1) - pp(jp, 1)
    dpp2 = psc1(2) - pp(jp, 2)
    dpt1 = psc2(1) - pp(i, 1)
    dpt2 = psc2(2) - pp(i, 2)
    pp(jp, 6) = pp(jp, 6) + dpp1/2.0
    pp(jp, 7) = pp(jp, 7) + dpp2/2.0
    pp(jp, 8) = pp(jp, 8) + dpp1/2.0
    pp(jp, 9) = pp(jp, 9) + dpp2/2.0
    pp(i, 6) = pp(i, 6) + dpt1/2.0
    pp(i, 7) = pp(i, 7) + dpt2/2.0
    pp(i, 8) = pp(i, 8) + dpt1/2.0
    pp(i, 9) = pp(i, 9) + dpt2/2.0
    Do k = 1, 5
      pp(jp, k) = psc1(k)
      pp(i, k) = psc2(k)
    End Do
    nfp(i, 5) = max(1, nfp(i,5))
    Goto 45
  40 End Do
  45 If (jt==0) Goto 80
  pabs = sqrt(pt(jt,1)**2+pt(jt,2)**2+pt(jt,3)**2)
  bx = pt(jt, 1)/pabs
  by = pt(jt, 2)/pabs
  bz = pt(jt, 3)/pabs
  Do i = 1, ihnt2(3)
    If (i==jt) Goto 70
    dx = yt(1, i) - yt(1, jt)
    dy = yt(2, i) - yt(2, jt)
    dz = yt(3, i) - yt(3, jt)
    dis = dx*bx + dy*by + dz*bz
    If (dis<=0) Goto 70
    bb = dx**2 + dy**2 + dz**2 - dis**2
    r2 = bb*hipr1(40)/hipr1(31)/0.1
    gs = (1.0-exp(-(hipr1(30)+hint1(11))/hipr1(31)/2.0*romg(r2)))**2
    gs0 = (1.0-exp(-(hipr1(30)+hint1(11))/hipr1(31)/2.0*romg(0.0)))**2
    If (ranart(nseed)>gs/gs0) Goto 70
    Do k = 1, 5
      psc1(k) = pt(jt, k)
      psc2(k) = pt(i, k)
    End Do
    Call hijels(psc1, psc2)
    dpp1 = psc1(1) - pt(jt, 1)
    dpp2 = psc1(2) - pt(jt, 2)
    dpt1 = psc2(1) - pt(i, 1)
    dpt2 = psc2(2) - pt(i, 2)
    pt(jt, 6) = pt(jt, 6) + dpp1/2.0
    pt(jt, 7) = pt(jt, 7) + dpp2/2.0
    pt(jt, 8) = pt(jt, 8) + dpp1/2.0
    pt(jt, 9) = pt(jt, 9) + dpp2/2.0
    pt(i, 6) = pt(i, 6) + dpt1/2.0
    pt(i, 7) = pt(i, 7) + dpt2/2.0
    pt(i, 8) = pt(i, 8) + dpt1/2.0
    pt(i, 9) = pt(i, 9) + dpt2/2.0
    Do k = 1, 5
      pt(jt, k) = psc1(k)
      pt(i, k) = psc2(k)
    End Do
    nft(i, 5) = max(1, nft(i,5))
    Goto 80
  70 End Do
  80 Return
End Subroutine hijcsc


!! ALL ONE MODULE

!!! MAIN SUBROUTINE FOR READING NAMELIST INPUT AND COMMAND LINE OPTIONS

#include "Definitions.INC"

module getparammod
contains

subroutine getinpfile()
  use parameters
  use mpimod
  use miscmod
  implicit none

  integer :: nargs, i, len
#ifdef PGFFLAG
  integer :: myiargc
#endif
  character (len=SLN) :: buffer

#ifdef PGFFLAG
  nargs=myiargc()
#else
  nargs=iargc()
#endif
  do i=1,nargs
     buffer=nullbuff;     call getarg(i,buffer);     len=getlen(buffer)
     if (buffer(1:4) .eq. 'Inp=') then
        inpfile=nullbuff;        inpfile(1:len-4)=buffer(5:len)
        OFLWR "Inpfile is ", inpfile(1:len-4+1); CFL
     endif
  enddo
end subroutine getinpfile

subroutine getparams()
  use parameters
  use denreg_parameters
  use bio_parameters
  use constraint_parameters
  use lanparameters
  use output_parameters
  use mpimod
  use orblabelmod
  use pulse_parameters   !! numpulses
  use miscmod
  implicit none
  integer :: nargs, i, len,  ishell, ispf,j, myiostat, iiflag,needpulse,ipulse
#ifdef PGFFLAG
  integer :: myiargc
#endif
  character (len=SLN) :: buffer
  integer :: shelltop(100)=-1            !! greater than zero: not full CI.  Number of orbitals in core shell.  Must be even.
  integer :: avectorhole(1000)=-1001
  integer :: avectorexcitefrom(1000)=-1001
  integer :: avectorexciteto(1000)=-1001
  real*8 :: tempreal

!! DUMMIES
  integer :: restrictms=0,  dfrestrictflag=0, allspinproject=1

  NAMELIST/parinp/  noftflag, biodim,biotol, rdenflag,cdenflag, notiming, littlesteps, &
       expotol, eground,  ceground, maxexpodim, numloadfrozen, numholecombo, numholes, excitations, &
       excitecombos, jacsymflag, jacprojorth,jacgmatthird,  fluxoptype, timefac, threshflag, &
       timefacforce, avectoroutfile, spfoutfile,  autopermthresh, messamount, numshells,   &
       lanthresh, lanczosorder,  lioreg, &   !! rcond
       autonormthresh,  saveflag, save_every, &

!!$ IMPLEMENT ME (DEPRECATE fluxinterval as namelist input)      fluxtimestep,

       mrestrictflag, mrestrictval, autotimestep, &
       nosparseforce,  allspinproject,  numfluxfiles,  verletnum, &
       constraintflag, dfrestrictflag, improvedrelaxflag, mcscfnum,  improvednatflag, avectorfile, spffile, &
       quadprecon,  improvedquadflag, quadtol, improvedfockflag, &
       plotxyrange,plotrange,plotskip,pm3d, plotterm, plotmodulus,plotpause, numfluxcurves,  &
       plotres, nspf ,  spfrestrictflag,  spfmvals, spfugvals, spfugrestrict, ugrestrictflag, ugrestrictval, &
       restrictflag,  restrictms,   loadspfflag,  loadavectorflag,  avectorhole, &
       par_timestep,  stopthresh ,  cmf_flag,  intopt, timedepexpect,  avector_flag, &
       numelec,  relerr,  myrelerr,  spf_flag,  denreg,  timingout, tdflag, finaltime, actions, numactions, &
       messflag,  sparseconfigflag,  aorder, maxaorder, aerror, shelltop, numexcite, povres, povrange,&
       numpovranges, povsparse,  povmult, plotnum,lancheckstep,  plotview1, plotview2, &
       computeFlux, FluxInterval, FluxSkipMult, &
       numfrozen, nucfluxopt, natplotbin, spfplotbin, denplotbin, denprojplotbin, &
       natprojplotbin, rnatplotbin, dendatfile, denrotfile, rdendatfile,   avectorexcitefrom, avectorexciteto,&
       numovlfiles, ovlavectorfiles, ovlspffiles, outovl,fluxmofile,fluxafile, spifile, astoptol,  &
       xdipfile,ydipfile,zdipfile,   xtworkfile,ytworkfile,ztworkfile,  xytworkfile,yztworkfile,zxtworkfile,&
       xdftfile,ydftfile,zdftfile,   xydftfile,xzdftfile,yxdftfile,yzdftfile,zxdftfile,zydftfile, &
       xoworkfile,yoworkfile,zoworkfile,        act21circ,  &
       xyoworkfile,xzoworkfile,yxoworkfile,yzoworkfile,zxoworkfile,zyoworkfile,&
       xophotonfile, yophotonfile,zophotonfile,&
       xyophotonfile,xzophotonfile,yxophotonfile,yzophotonfile,zxophotonfile, zyophotonfile,&
       fttriwindow,  ftwindowpower, ftwindowpzero, ftderord,  ftderpwr, &  !ftdiff,  &
       diptime, fluxafile2,fluxmofile2, minocc,maxocc, corrdatfile,corrftfile,numavectorfiles,projfluxfile, &
       expodim,timingdir, hanningflag, numspffiles, condamp,conway, &
       mrestrictmin,mrestrictmax,lntol,invtol,psistatsfile, psistatfreq, &
       parorbsplit,maxbiodim, nkeproj,keprojminenergy,keprojenergystep,keprojminrad,keprojmaxrad, &
       debugflag, eigprintflag, &
       avecloadskip,nonsparsepropmode,sparseopt,lanprintflag,dipmodtime,conprop,&
       orbcompact,spin_restrictval,mshift,numskiporbs,orbskip,debugfac,denmatfciflag,&
       walkwriteflag,iprintconfiglist,timestepfac,max_timestep,expostepfac, maxquadnorm,quadstarttime,&
       reinterp_orbflag,spf_gridshift,load_avector_product,projspifile,readfullvector,walksinturn,&
       turnbatchsize,energyshift, finalstatsfile, fluxtsumfile, projfluxtsumfile,&
       sparsedfflag,sparseprime,sparsesummaflag, par_consplit, &
       pulsewindowtoo,redobra,dipolesumstart,dipolesumend,outmatel,numcatfiles,&
       catspffiles,catavectorfiles,aquadstarttime,quadorthflag,normboflag,logbranch,nzflag,&
       shuffle_dfwalktype,maxdgdim, messavec, messaamount,holeflag, angularflag, angprojspifile,&
       prepropflag, step_flag, postpropflag, scalarflag, angprojfluxtsumfile, &
       catfacs, flux_subtract, jacsymquad, exact_exchange, jacquaddir, tentmode, followflag, &
       exchange_mode, gaugefluxflag, strongcatflag, strongcatspffiles, strongcatavectorfiles, &
       catenergies, nonuc_checkflag, autostart, auto_subtract, plotsubtract, veldipflag, &
       hhgplotmax

  OFL
  write(mpifileptr, *)
  write(mpifileptr, *) " *************************  COMMAND LINE OPTIONS  ***************************"
  write(mpifileptr, *)
  CFL
#ifdef PGFFLAG
  nargs=myiargc()
#else
  nargs=iargc()
#endif

!! Defaults not set in declarations

  numfluxcurves=0;  numfluxcurves(1)=1

#ifdef REALGO
  conway=0
#else
  conway=3
#endif

!! F.T. windowing function, defaults for each action
!! use linear on [0:t], cosine-squared on [-t:t]

  fttriwindow(:)=1
  ftwindowpower(:)=1
  ftwindowpzero(:)=1

  fttriwindow(1)=0
  ftwindowpower(1)=2
  fttriwindow(16)=0
  ftwindowpower(16)=2
  fttriwindow(17)=0
  ftwindowpower(17)=2

  open(971,file=inpfile, status="old", iostat=myiostat)
  if (myiostat/=0) then
     OFLWR "No Input.Inp found for parinp, iostat=",myiostat; CFL
  else
     OFLWR "Reading ",inpfile; CFL
     read(971,nml=parinp,iostat=myiostat)
     call checkiostat(myiostat," reading namelist PARINP")
     restrict_ms=restrictms
     all_spinproject=allspinproject
     df_restrictflag=dfrestrictflag

!! input-dependent defaults

!!$ prepropflag.eq.1 default
!!$     if (constraintflag.ne.0) then
!!$        prepropflag=1
!!$     endif

     if (numfrozen.gt.0) then
        jacsymquad=0
     endif

     jacquaddir = -1
     if ((jacsymflag.eq.0.and.jacsymquad.eq.0).or.(numfrozen.gt.0.and.exact_exchange.eq.0)) then
        jacquaddir = 1
     endif

     if (improvedrelaxflag.ne.0) then
        maxexpodim=max(300,maxexpodim)
        expodim=max(40,expodim)
     endif

     if (intopt.eq.4) then
        expotol=min(1d-9,expotol)
     endif
     if (intopt.eq.1) then
        relerr=1d-8
        myrelerr=1d-8
     endif

     if (improvedrelaxflag.ne.0) then
        expotol=min(expotol,1d-9)
     endif

     if (spin_restrictval.lt.abs(restrictms)) then
        spin_restrictval=abs(restrictms)
     endif

!!$ denreg now 1d-10 default...
!!$     if (improvedrelaxflag.ne.0) then    !! not good.  reprogram this whole thing later.  Defaults here should
!!$        denreg=1.d-9                     !!   go after a first parinp AND command line argument parse; then repeat
!!$     endif

     if (improvedrelaxflag.ne.0) then
        aorder=max(300,aorder)
        maxaorder=max(aorder,maxaorder)
     endif

     if (spfrestrictflag.eq.0) then
        orbcompact=0
     endif

     close(971)
     open(971,file=inpfile, status="old")
     read(971,nml=parinp,iostat=myiostat)
     call checkiostat(myiostat," reading namelist PARINP")
  endif
  close(971)

  !!   ************************************************************************************
  !!
  !!    Coord-dependent namelist input and command line options may be overridden by
  !!    options of the main program
  !!
  !!   ************************************************************************************

  !!   NOW TAKE MCTDHF NAMELIST AND COMMAND LINE INPUT

  call openfile()

  !! NOTE THAT LBIG IS NOT A COMMAND LINE OPTION; IS IN LOOP IN GETH2OPTS.  So as of now it is set.  change later.

  do i=1,nargs
     buffer=nullbuff;     call getarg(i,buffer);     len=getlen(buffer)
     myiostat=0
     if (buffer(1:5) .eq. 'Nspf=') then
        read(buffer(6:len),*,iostat=myiostat) nspf;
        write(mpifileptr,*) "Nspf set to  ", nspf, " by command line option."
     endif

     if (buffer(1:5) .eq. 'Holes') then
        holeflag=1
        write(mpifileptr, *) "indexing holes not electrons by command line option"
     endif

     if (buffer(1:8) .eq. 'NucFlux=') then
        read(buffer(9:len),*,iostat=myiostat) nucfluxopt
        write(mpifileptr, *) "nucfluxopt set to ", nucfluxopt, " by command line option."
     endif

     if (buffer(1:9) .eq. 'NoTiming=') then
        read(buffer(10:len),*,iostat=myiostat) notiming
        write(mpifileptr, *) "notiming variable set to ",notiming," by command line input."
     endif
     if (buffer(1:10) .eq. 'TimingDir=') then
        read(buffer(11:len),*,iostat=myiostat) timingdir
        write(mpifileptr, *) "timing directory set to ",timingdir," by command line input."
     endif
     if (buffer(1:7) .eq. 'Timing=') then
        read(buffer(8:len),*,iostat=myiostat) j
        notiming=2-j
        write(mpifileptr, *) "notiming variable set to ",notiming," by command line input."
     endif
     if (buffer(1:4) .eq. 'Rel=') then
        read(buffer(5:len),*,iostat=myiostat) relerr
        write(mpifileptr, *) "Relative error for spf prop set to ", relerr, " by command line option."
     endif
     if (buffer(1:9) .eq. 'FluxSkip=') then
        read(buffer(10:len),*,iostat=myiostat) fluxskipmult
        write(mpifileptr, *) "Fluxskipmult set to ", fluxskipmult, " by command line option."
     endif
     if (buffer(1:6) .eq. 'Myrel=') then
        read(buffer(7:len),*,iostat=myiostat) myrelerr
        write(mpifileptr, *) "Absolute error (myrelerr) for spf prop set to ", myrelerr, " by command line option."
     endif
     if (buffer(1:9) .eq. 'PovRange=') then
        read(buffer(10:len),*,iostat=myiostat) tempreal
        write(mpifileptr, *) "Povrange set to ", tempreal
        povrange=tempreal  !! all of them
     endif
     if (buffer(1:2) .eq. 'M=') then
        mrestrictflag=1
        read(buffer(3:len),*,iostat=myiostat) mrestrictval
        write(mpifileptr, *) "Restricting configs to ", mrestrictval, " by command line option."
     endif
     if (buffer(1:5) .eq. 'Debug') then
        if (.not.buffer(1:6) .eq. 'Debug=') then
           WRFL "Please specify debug flag option N with command line Debug=N not just Debug"; CFLST
        endif
        read(buffer(7:len),*,iostat=myiostat) debugflag
        write(mpifileptr, *) "Debugflag set to ",debugflag," by command line option"
     endif
     if (buffer(1:5) .eq. 'Walks') then
        walkwriteflag=1
        write(mpifileptr, *) "Walks will be written by command line option"
     endif
     if (buffer(1:7) .eq. 'NoWalks') then
        walkwriteflag=0
        write(mpifileptr, *) "Walks will not be written by command line option"
     endif
     if (buffer(1:2) .eq. 'A=') then
        avectorfile(:)=nullbuff
        avectorfile(:)(1:len-2)=buffer(3:len)
        write(mpifileptr, *) "Avector file is ", avectorfile(1)(1:len-2+1)
        write(mpifileptr, *) "    Loadavectorflag turned on."
        loadavectorflag=1
     endif
     if (buffer(1:4) .eq. 'Spf=') then
        spffile=nullbuff
        spffile(:)(1:len-4)=buffer(5:len)
        write(mpifileptr, *) "Spf file is ", spffile(1)(1:len-4+1)
        write(mpifileptr, *) "    Loadspfflag turned on."
        loadspfflag=1
     endif
     if (buffer(1:5) .eq. 'Pulse') then
        write(mpifileptr, *) "Turning pulse on by command line option."
        tdflag=1
     endif
     if (buffer(1:6) .eq. 'SaveOn') then
        write(mpifileptr, *) "Saving wave function by command line option."
        saveflag=1
     endif
     if (buffer(1:7) .eq. 'SaveOff') then
        write(mpifileptr, *) "NOT Saving wave function by command line option."
        saveflag=0
     endif
#ifndef REALGO
     if (buffer(1:4) .eq. 'Prop') then
        write(mpifileptr, *) "  Forcing propagation in real time by command line option."
        improvedrelaxflag=0
     endif
#endif
     if (buffer(1:6) .eq. 'Relax=') then
        read(buffer(7:len),*,iostat=myiostat) improvedrelaxflag
        write(mpifileptr, *) "  Forcing improved relaxation by command line option.  Relaxing to state ", improvedrelaxflag
     else
        if (buffer(1:5) .eq. 'Relax') then
           write(mpifileptr, *) "  Forcing improved relaxation to ground state by command line option."
           improvedrelaxflag=max(1,improvedrelaxflag)
        endif
     endif

! so you can input numactions=0 but specify the actions you would want in the input file, and then turn them on with:

     if (buffer(1:5) .eq. 'Noact') then
        numactions=0
     endif
     if (buffer(1:6) .eq. 'Allact') then
        do while (actions(numactions+1).ne.0)
           numactions=numactions+1
        enddo
        write(mpifileptr,*) " Setting all specified actions on: they are ", actions(1:numactions)
     endif
     if (buffer(1:4) .eq. 'Act=') then
        numactions=numactions+1;        read(buffer(5:len),*,iostat=myiostat) actions(numactions)
     endif
     if (buffer(1:4) .eq. 'Mess') then
        messflag=1;        messamount=1.d-3
        if (buffer(1:5) .eq. 'Mess=') then
           read(buffer(6:len),*,iostat=myiostat) messamount
        endif
     endif
     if (buffer(1:9) .eq. 'Autoperm=') then
        read(buffer(10:len),*,iostat=myiostat) autopermthresh
        write(mpifileptr,*) "Permutation threshold for autocorr set to ", autopermthresh
     endif

     if (buffer(1:3) .eq. 'VMF') then
        cmf_flag=0;        write(mpifileptr, *) "VMF set by command line option"
     endif

     if (buffer(1:5) .eq. 'Step=') then
        read(buffer(6:len),*,iostat=myiostat) par_timestep
        write(mpifileptr, *) "Timestep set to  ", par_timestep, " by command line option."
     endif

     if (buffer(1:10) .eq. 'Numfrozen=') then
        numshells=2
        read(buffer(11:len),*,iostat=myiostat) shelltop(1)
        shelltop(2)=nspf
        write(mpifileptr, *) "Numshells set to 2 with  ", shelltop(1), " in the first shell by command line option."
     endif
     if (buffer(1:10) .eq. 'Numexcite=') then
        read(buffer(11:len),*,iostat=myiostat) numexcite(1)
        write(mpifileptr, *) "Numexcite for first shell set to  ", numexcite(1), " by command line option."
     endif

     if (buffer(1:9) .eq. 'PlotSkip=') then
        read(buffer(10:len),*,iostat=myiostat) plotskip
        write(mpifileptr, *) "Plotskip set to ", plotskip, " by command line option."
     endif
     if (buffer(1:7) .eq. 'PlotXY=') then
        read(buffer(8:len),*,iostat=myiostat) plotxyrange
        write(mpifileptr, *) "Plot xy-range set to ", plotxyrange, " bohr by command line option."
     endif

     if (buffer(1:4) .eq. 'PM3D') then
        pm3d=1;        write(mpifileptr, *) "PM3D set to on."
     endif
     if (buffer(1:6) .eq. 'PlotZ=') then
        read(buffer(7:len),*,iostat=myiostat) plotrange
        write(mpifileptr, *) "Plot z-range set to ", plotrange, " bohr by command line option."
     endif
     if (buffer(1:8) .eq. 'PlotNum=') then
        read(buffer(9:len),*,iostat=myiostat) plotnum
        write(mpifileptr, *) "Plotnum set to ", plotnum, " bohr by command line option."
     endif
     if (buffer(1:8) .eq. 'PlotRes=') then
        read(buffer(9:len),*,iostat=myiostat) plotres
        write(mpifileptr, *) "Plot resolution set to ", plotres, " bohr by command line option."
     endif
     if (buffer(1:10) .eq. 'PlotPause=') then
        read(buffer(11:len),*,iostat=myiostat) plotpause
        write(mpifileptr, *) "Plotpause set to ", plotpause, " seconds by command line option."
     endif
     if (buffer(1:11) .eq. 'Stopthresh=') then
        read(buffer(12:len),*,iostat=myiostat) stopthresh
        write(mpifileptr, *) "Stopthresh set to  ", stopthresh, " by command line option."
     endif
     if (buffer(1:6) .eq. 'Sparse') then
        write(mpifileptr, *) "Sparseconfigflag turned on by command line option."
        sparseconfigflag=1
     endif
     if (buffer(1:8) .eq. 'NoSparse') then
        write(mpifileptr, *) "Sparseconfigflag turned OFF by command line option."
        sparseconfigflag=0
     endif
     if (buffer(1:7) .eq. 'Denreg=') then
        read(buffer(8:len),*,iostat=myiostat) denreg
        write(mpifileptr, *) "Denreg set by command line option to ", denreg
     endif
     if (buffer(1:3) .eq. 'GBS') then
        intopt=1
        write(mpifileptr, *) "GBS integration set by command line option."
     endif
     if (buffer(1:2) .eq. 'RK') then
        intopt=0
        write(mpifileptr, *) "RK integration set by command line option."
     endif
     if (buffer(1:8) .eq. 'Eground=') then
        read(buffer(9:len),*,iostat=myiostat) eground
        write(mpifileptr, *) "Eground for autoft set to  ", eground, " by command line option."
     endif

     call checkiostat(myiostat," command line argument "//buffer)

  enddo
  write(mpifileptr, *) " ****************************************************************************"
  write(mpifileptr,*);

  call closefile()        !!!!!!!    CLOSING MPIFILEPTR   !!!!!!

  if (constraintflag > 2) then
     OFLWR "Constraintflag not supported: ", constraintflag;     CFLST
  endif

  if (improvedrelaxflag.eq.0) then
     improvednatflag=0
     improvedfockflag=0
  endif

  if (improvedrelaxflag.ne.0.and.constraintflag.eq.1) then
     OFLWR "FOR DEN CONSTRAINT, USE IMPROVEDNATFLAG FOR RELAX, NO CONSTRAINTFLAG."; CFLST
  endif

  if ((sparseconfigflag.ne.0).and.(stopthresh.lt.lanthresh).and.(improvedquadflag.eq.0.or.improvedquadflag.eq.2)) then
     OFLWR "Enforcing lanthresh.le.stopthresh"
     lanthresh=stopthresh
     WRFL "    --> lanthresh now  ", lanthresh; CFL
  endif
  if (intopt.eq.4) then
     if ((constraintflag.ne.0)) then
        OFLWR "Verlet not available with pulse nor constraint yet."; CFLST
     endif
  endif
  if ((intopt.eq.3).or.(intopt.eq.4)) then
     OFLWR "Enforcing CMF defaults for Verlet or EXPO."; CFL;     cmf_flag=1
  endif

  if (timefacforce.eq.0) then
     timefac=(0.0d0, -1.0d0)
  endif
  if (improvedrelaxflag.ne.0) then
     threshflag=1
  endif
  if (threshflag.ne.0) then
     if (timefacforce.eq.0) then
        timefac=(-1.0d0, 0.0d0)
     endif
  endif

  if (numshells.lt.1) then
     OFLWR "Shell error ", numshells; CFLST
  endif

  allshelltop(0)=0;  allshelltop(numshells)=nspf
  allshelltop(1:numshells-1)=shelltop(1:numshells-1)
  do ishell=1,numshells
     if (allshelltop(ishell).gt.nspf) then
        allshelltop(ishell)=nspf
     endif
  enddo
  do ishell=numshells,2,-1
     if (allshelltop(ishell).le.allshelltop(ishell-1)) then
        numshells=numshells-1
        allshelltop(ishell:numshells)=allshelltop(ishell+1:numshells+1)
        numexcite(ishell:numshells)=numexcite(ishell+1:numshells+1)
     endif
  enddo

  do i=1,numshells
     if (allshelltop(i).le.allshelltop(i-1)) then
        OFLWR "allShell error ", allshelltop(i), allshelltop(i-1); CFLST
     endif
  enddo

  do i=2,numshells
     if (numexcite(i).lt.numexcite(i-1)) then
        OFLWR "numexcite error ", numexcite(i), numexcite(i-1); CFLST
     endif
  enddo

  !! define shells

  ishell=1
  do ispf=1,nspf
     shells(ispf)=ishell
     if (ispf.eq.allshelltop(ishell)) then
        ishell=ishell+1
     endif
  enddo

  call get_skipflag_from_actions(skipflag)

  needpulse=0
  if (tdflag.ne.0) then
     needpulse=1
  else
     ! 08-2021  before I did two steps for these flux actions
     !          that is not really a good idea
     !          disabling this logic
     !
     ! if (noftflag.eq.0) then
     !    do j=1,numactions
     !       if ( (actions(j).eq.14).or.&
     !            (actions(j).eq.16).or.&
     !            (actions(j).eq.17)) then
     !          needpulse=1
     !       endif
     !    enddo
     ! endif
     !
     do j=1,numactions
        if ( (actions(j).eq.14).or.&
             (actions(j).eq.16).or.&
             (actions(j).eq.17)) then
           OFLWR "Please do flux calc in 1 not 2 steps. Or programmer checkme.  789789"; CFLST
        endif
     enddo
  endif

  if (needpulse.ne.0) then
     !
     call getpulse(0)            !  Read pulse namelist info from file
     !
     ! else
     !    dipolesumend=0              ! shouldn't be used
     !    dipolesumstart=0
  endif

  do i=1,nargs
     buffer=nullbuff
     myiostat=0
     !!     call mygetarg(i,buffer)
     call getarg(i,buffer)
     len=getlen(buffer)
     if (buffer(1:2) .eq. 'T=') then
        read(buffer(3:len),*,iostat=myiostat) finaltime
        OFLWR "Finaltime set by command line option to ", finaltime
        numpropsteps=floor((finaltime+0.0000000001d0)/par_timestep) +1
        finaltime=numpropsteps*par_timestep
        write(mpifileptr, *) "     numpropsteps now   ", numpropsteps
        write(mpifileptr, *) "     finaltime    now   ", finaltime;
        CFL
     endif
     call checkiostat(myiostat,"Reading finaltime command line input "//buffer)
  enddo

  numpropsteps=floor((finaltime+0.0000000001d0)/par_timestep)

  autosteps=floor(max(1.d0,autotimestep/par_timestep));

  autotimestep = autosteps * par_timestep   !! OOPS forgot 6-16

  autosize=numpropsteps/autosteps+1

  if (autostart.lt.0d0) then
     autostart = (ceiling(lastfinish/par_timestep/autosteps))*par_timestep*autosteps
     OFLWR "   autostart set to ",autostart
  endif

!!$ IMPLEMENT ME (DEPRECATE fluxinterval as namelist input)
!!$ fluxsteps=floor(max(1.d0,fluxtimestep/par_timestep));  fluxtimestep=par_timestep*fluxsteps

  do i=1,nargs
     buffer=nullbuff;     call getarg(i,buffer)
     myiostat=0
     len=getlen(buffer)
     if (buffer(1:12) .eq. 'PlotModulus=') then
        read(buffer(13:len),*,iostat=myiostat) plotmodulus
        write(mpifileptr, *) "Plotmodulus set to ", plotmodulus, " steps by command line option."
     endif
     call checkiostat(myiostat," command line argument plotmodulus "//buffer)
  enddo

  if (holeflag.eq.0) then
     numpart=numelec
  else
     numpart=2*nspf-numelec
  endif
  num2part=2*numpart

  if (stopthresh.lt.1.d-12) then
     OFLWR "Error, stopthresh cannot be less than 1d-12"; CFLST  !! then would send hgram 1d-14
  endif

  if (constraintflag.eq.1.and.improvedrelaxflag.ne.0) then
     OFLWR " Removing denmat constraint for relaxation. Not allowed."; CFL
     constraintflag=0
  endif
  if (spfrestrictflag.eq.0) then
     mrestrictflag=0
  endif
  if (ceground.eq.(0d0,0d0)) then
     ceground=eground
  endif

!! 121912
!! if numholes or numexcite is not set, define from avectorhole etc. input for backwards compatibility

  if (numholes.eq.0) then
     if (numholecombo.ne.1) then
        OFLWR "If setting numholecombo, set numholes."; CFLST
     endif
     do while (avectorhole(numholes+1).ne.-1001)
        numholes=numholes+1
     enddo
     if (numholes.ne.0) then
        OFLWR "You did not set numholes; I am setting it to ", numholes; CFL
     endif
  endif
  if (excitations.eq.0) then
     if (excitecombos.ne.1) then
        OFLWR "If setting excitecombos, set excitations."; CFLST
     endif
     do while (avectorexcitefrom(excitations+1).ne.-1001)
        print *, "blah ",excitations,avectorexcitefrom(excitations+1)
        excitations=excitations+1
     enddo
     if (excitations.ne.0) then
        OFLWR "You did not set excitations; I am setting it to ", excitations; CFL
     endif
  endif
  if (numholes.gt.0) then
     excitations=0
     allocate(myavectorhole(numholes,numholecombo,mcscfnum))
     myavectorhole=RESHAPE(avectorhole(1:numholecombo*numholes*mcscfnum),(/ numholes,numholecombo,mcscfnum/))
  else
     allocate(myavectorhole(1,1,1))
  endif
  if (excitations.gt.0) then
     numholes=0
     allocate(myavectorexcitefrom(excitations,excitecombos,mcscfnum))
     myavectorexcitefrom=RESHAPE(avectorexcitefrom(1:excitations*excitecombos*mcscfnum),(/excitations,excitecombos,mcscfnum/))
     allocate(myavectorexciteto(excitations,excitecombos,mcscfnum))
     myavectorexciteto=RESHAPE(avectorexciteto(1:excitations*excitecombos*mcscfnum),(/excitations,excitecombos,mcscfnum/))
  else
     allocate(myavectorexcitefrom(1,1,1), myavectorexciteto(1,1,1))
  endif

  if (nprocs.eq.1) then
     par_consplit=0
     parorbsplit=0
  endif

  if (sparseconfigflag.eq.0) then
     sparseopt=0
     par_consplit=0
  endif

#ifndef MPIFLAG
  if (par_consplit.ne.0.or.parorbsplit.eq.3) then
     OFLWR "Error, this is not MPI chmctdhf; cannot use par_consplit.ne.0 or parorbsplit.eq.3"; CFLST
  endif
#endif

  if (numavectorfiles.gt.MXF.or.numspffiles.gt.MXF) then
     OFLWR "PROGRAMMER REDIM M X F",numavectorfiles,numspffiles,MXF; CFLST
  endif

  call openfile()        !! OPEN MPIFILEPTR !!

  write(mpifileptr, *)
  write(mpifileptr, *) " ****************************************************************************"
  write(mpifileptr, *) "*****************************************************************************"
  write(mpifileptr, *)
  write(mpifileptr, *) "Number of states in propagation=", mcscfnum
  write(mpifileptr, *)
  write(mpifileptr, *) " Parameters: electronic"
  write(mpifileptr, *)
  write(mpifileptr,'(A40,I5,2F10.5)') "Number of electrons ", numelec
  write(mpifileptr,'(A40,3I5)') "Nuclear KE flag (nonuc_checkflag):     ",  nonuc_checkflag
  write(mpifileptr, *)

  call printmyopts()

  write(mpifileptr, *)
  write(mpifileptr, *) "************************   Parameters: config/spf    ************************   "
  write(mpifileptr, *)

  if (numshells.eq.1) then
     write(mpifileptr, *) "Doing full CI: numshells=1.  Shells:"
  else
     write(mpifileptr, *) "Shells:"
  endif
  do ishell=1,numshells
     if (ishell.eq.numshells) then
        write(mpifileptr,*) "Shell ", ishell
     else
        write(mpifileptr,*) "Shell ", ishell,   "Excitation level: ", numexcite(ishell)
     endif
     write(mpifileptr,'(12A6)')  (orblabel(i),i=allshelltop(ishell-1)*2+1,allshelltop(ishell)*2)
  enddo
  if (df_restrictflag.gt.0) then
     write(mpifileptr,*) " DF restrictflag is on for constraintflag=2 or other purposes = ",df_restrictflag
  endif
  write(mpifileptr, *)
  write(mpifileptr,'(A30,I5)')    "   Number of unfrozen spfs:  ", nspf
  write(mpifileptr,'(A30,I5)')    "   Number of frozen spfs:    ", numfrozen
  write(mpifileptr,'(A30,100I4)') "   Spfs start in m=  ", spfmvals(1:nspf)
  write(mpifileptr, *)
  if (spfrestrictflag.eq.1) then
     write(mpifileptr, *) "Spfs will be restricted to their original m-values."
  endif
  if (spfugrestrict.eq.1) then
     write(mpifileptr, *) "Spfs will be restricted to their original parity values."
  endif
  if (mrestrictflag==1) then
     write(mpifileptr, *) "Configurations will be restricted to total M= ", mrestrictval
  endif
  if (ugrestrictflag==1) then
     write(mpifileptr, *) "Configurations will be restricted to total parity= ", ugrestrictval
  endif
  if (restrictflag.eq.1) then
     write(mpifileptr, *) "Configurations will be restricted to spin projection", restrictms, "/2"
  endif
  if (all_spinproject.ne.0) then
     write(mpifileptr,*) " Configurations will be restricted to spin ",spin_restrictval
  endif
  write(mpifileptr, *)
  write(mpifileptr, *) "***********************    Initial state      ***********************   "
  write(mpifileptr, *)
  if (loadspfflag.eq.1) then
     write(mpifileptr, *) "Spfs will be loaded from files "
     if (numskiporbs.gt.0) then
        write(mpifileptr,*) "Skipping orbitals on file.  Orbitals ", (orbskip(i),i=1,numskiporbs)
     endif
  else
     write(mpifileptr, *) "Spfs will be one-electron eigfuncts."
  endif
  write(mpifileptr, *)
  if (threshflag.ne.0) then

     if (improvedquadflag.gt.1) then
        write(mpifileptr,*) "Spf Quad flag is ON (quadflag>1).  Start time ", quadstarttime
     else
        write(mpifileptr,*) "Sfp Quad flag is OFF."
     endif
     if (improvednatflag.ne.0) then
        write(mpifileptr,*) "Improvednatflag is ON."
     elseif (improvedfockflag.ne.0) then
        write(mpifileptr,*) "Improvedfockflag is ON."
     else
        write(mpifileptr,*) "Improvednatflag and improvedfockflag are OFF."
     endif
     write(mpifileptr, *)
     if (improvedquadflag.eq.1.or.improvedquadflag.eq.3) then
        write(mpifileptr,*) "Avector Quad flag is ON (quadflag=1,3)."
     else
        write(mpifileptr,*) "Avector Quad flag is OFF."
     endif
  end if
  if (loadavectorflag.eq.1) then
     write(mpifileptr, *) "Avector will be loaded from files.  Number of files= ",numavectorfiles
     if (numholes.gt.0) then
        WRFL "We have holes:", numholes, " concurrent holes with ", numholecombo," wfns combined "; WRFL;
        excitations=0
     endif
     if (excitations.gt.0) then
        WRFL "We have exitations: ",excitations, " concurrent excitations with ", excitecombos," wfns combined "; WRFL
     endif
  else
     write(mpifileptr, *) "Avector will be obtained from diagonalization."
  endif
  write(mpifileptr, *)
  write(mpifileptr, *) "***********************    Parameters: propagation    ***********************   "
  write(mpifileptr, *)
  write(mpifileptr,*)  " PAR_TIMESTEP IS ", par_timestep, " LITTLESTEPS IS ", littlesteps
  write(mpifileptr,*)  "  prepropflag is ", prepropflag, " postpropflag is ", postpropflag
  write(mpifileptr,*)  "  step_flag is ", step_flag
  write(mpifileptr,*)

  if (messflag.ne.0) then
     write(mpifileptr,*) "MESSFLAG is on -- messing with spfs.  Messamount=", messamount; write(mpifileptr,*)
  endif
  if (spf_flag /= 1) then
     write(mpifileptr, *) "Spfs will be held CONSTANT. (except for constraint)";    write(mpifileptr,*)
  endif

  if (threshflag.eq.1) then
     write(mpifileptr, *) "Calculation will be stopped with threshold ", stopthresh, "; timestep is ", par_timestep
  else
     write(mpifileptr,'(A40,I10,2F24.8)') "# of steps, final time:",   numpropsteps,  finaltime
  endif

  write(mpifileptr,*);  write(mpifileptr,*)
  if (cmf_flag.ne.0) then
     write(mpifileptr, *) "*******  USING POLYNOMIAL MEAN FIELDS/MAGNUS A-VECTOR PREDICTOR/CORRECTOR   *******  "
     write(mpifileptr,*)
  else
     write(mpifileptr, *) "*************   Variable mean fields    *************   "
     write(mpifileptr,*)
  endif
  if (sparseconfigflag==1) then
     write(mpifileptr, *)  "    Will use sparse configuration routines."
     if (sparseopt.eq.0) then
        write(mpifileptr,*) "   Direct CI, sparseopt=0"
     else
        write(mpifileptr,*) "   Explicit sparse matrix, sparseopt=1"
     endif
     if (par_consplit.ne.0) then
        write(mpifileptr,*) "   Vectors are distributed, par_consplit.ne.0"
     else
        write(mpifileptr,*) "   Vectors are not distributed, par_consplit=0"
     endif
     write(mpifileptr,*)    "          Lanczosorder is ", lanczosorder
     write(mpifileptr,*)    "          Lanthresh is    ", lanthresh
     write(mpifileptr,*)    "          Aorder is       ", aorder
     write(mpifileptr,*)    "          Maxaorder is    ", maxaorder
     write(mpifileptr,*)    "          Aerror is       ", aerror
  else
     write(mpifileptr,*)    "    Using nonsparse configuration routines."
  endif
  iiflag=0

  write(mpifileptr,*) " Jacobian options:"
  write(mpifileptr,*) "    Jacprojorth=", jacprojorth
  write(mpifileptr,*) "    Jacsymflag=", jacsymflag
  if (constraintflag.ne.0) then
     write(mpifileptr,*) "    Jacgmatthird=", jacgmatthird
  endif

  select case (intopt)
  case(4)
     write(mpifileptr,*) " Using VERLET integration, expo first step."
     write(mpifileptr,*) "     Verletnum= ", verletnum
     iiflag=1
  case(3)
     write(mpifileptr,*) " Using EXPONENTIAL integration."
     write(mpifileptr,*) "    Expotol    =", expotol
     write(mpifileptr,*) "    Maxexpodim=", maxexpodim
  case(0)
     write(mpifileptr, *) "RK integration.  Recommend errors 1.d-8"
     write(mpifileptr, *) "Relerr, Myrelerr=", relerr, myrelerr;      iiflag=1
  case(1)
     write(mpifileptr, *) "GBS integration.  Recommend errors 1.d-8";     iiflag=1
     write(mpifileptr, *) "Relerr, Myrelerr=", relerr, myrelerr;      iiflag=1
  case(2)
     write(mpifileptr, *) "DLSODPK integration disabled (intopt=2) !!!"; CFLST
  case default
     write(mpifileptr,*) "Intopt not recognized: ", intopt; CFLST
  end select
  write(mpifileptr,*)
  write(mpifileptr, '(A40, E10.3)') " Density matrix regularized with denreg= ", denreg
  write(mpifileptr,*)

  if (constraintflag.ne.0) then
     select case (constraintflag)
     case(1)
        write(mpifileptr, *) "Using constraintflag=1, density matrices with full lioville solve (assume full, constant off-block diagonal)."
     case(2)
        WRFL "Using true Dirac-Frenkel equation for constraint."
        WRFL "     dfrestrictflag = ", df_restrictflag;
        select case(conway)
        case(0)
           WRFL "McLachlan constraint"
        case(1)
           WRFL "50/50 SVD"
        case(2)
           WRFL "Lagrangian constraint"
        case(3)
           WRFL "Lagrangian with epsilon times McLachlan.  epsilon=conprop=",conprop
        case default
           WRFL "Conway not supported ", conway; CFLST
        end select
     case(0)
        write(mpifileptr, *) "Using zero constraint, constraintflag=0"
     case default
        write(mpifileptr,*) "Constraintflag error ", constraintflag;     call mpistop()
     end select
     if (lioreg.le.0.d0) then
        write(mpifileptr,*) "No regularization of lioville solve."
     else
        write(mpifileptr,*) "Lioville solve regularized with lioreg=", lioreg
     endif
  endif

  write(mpifileptr, *)
  write(mpifileptr, *) "****************************************************************************"
  write(mpifileptr, *)
  write(mpifileptr,*) " Autotimestep= ", autotimestep
  write(mpifileptr,*) " Numpropsteps= ", numpropsteps

!!$ IMPLEMENT ME (DEPRECATE fluxinterval as namelist input)
!!$ write(mpifileptr,*) "Fluxsteps is ", fluxsteps," Fluxtimestep is ", fluxtimestep

  write(mpifileptr, *)
  write(mpifileptr, *) "*****************************************************************************"
  write(mpifileptr, *)
  if (skipflag.ne.0) then
     write(mpifileptr,*) "   ****************************************"
     write(mpifileptr,*) "     SKIPPING CALCULATION!  Doing analysis."
     write(mpifileptr,*) "   ****************************************"
  endif

  write(mpifileptr,*)

  call closefile()

  call write_actions()

end subroutine getparams

subroutine getpulse(no_error_exit_flag)   !! if flag is 0, will exit if &pulse is not read
  use parameters
  use pulse_parameters
  use mpimod
  use pulsesubmod
  use ftutilmod
  use miscmod
  implicit none
  NAMELIST /pulse/ omega,pulsestart,pulsestrength, velflag, omega2,phaseshift,intensity,pulsetype, &
       pulsetheta,pulsephi, numpulses, reference_pulses, minpulsetime, maxpulsetime, &
       chirp, ramp, envdernum, envpwr, pulse7opt1, pulse7opt2
  character (len=12)      :: line
  integer                 :: i, myiostat, ipulse,no_error_exit_flag, neflux, ntime
  integer                 :: FT_OPT ! temp
  real*8, parameter       :: epsilon=1d-4
  real*8                  :: time, fac, pulse_end, dt, emax, energy, mymax, mymin, nyfac
  real*8, allocatable     :: pulseftsq(:), vpulseftsq(:), evals(:)
  complex*16, allocatable :: lenpot(:,:), velpot(:,:), lenft(:,:), velft(:,:)
  DATATYPE                :: pots1(3),pots2(3),pots3(3), pots4(3), pots5(3), pots6(3)

  open(971,file=inpfile, status="old", iostat=myiostat)
  if (myiostat/=0) then
     OFLWR "No Input.Inp found, not reading pulse. iostat=",myiostat; CFL
  else
     read(971,nml=pulse,iostat=myiostat)
     if (myiostat.ne.0.and.no_error_exit_flag.eq.0) then
        OFLWR "Need &pulse namelist input!!"; CFLST
     endif
  endif
  close(971)

  call openfile()       !! OPEN MPIFILEPTR

  if (tdflag.ne.0) then
     line="PULSE IS ON:"
  else
     line="READ PULSE: "
  endif
  select case (velflag)
  case (0)
     WRFL  line,"   length."
  case(1)
     WRFL  line,"   velocity, usual way."
  case default
     WRFL  line,"   ERROR velflag not supported: ",velflag; CFLST
  end select
  if (no_error_exit_flag.ne.0) then    !! mcscf.  just need velflag.
     return
  endif

  WRFL; WRFL    "NUMBER OF PULSES:  ", numpulses;    WRFL

  do ipulse=1,numpulses
     select case(pulsetype(ipulse))
     case(1,2,6)
        pulsedur(ipulse) = pi/omega(ipulse)
     case(7)
        pulsedur(ipulse) = 25.0633d0/omega(ipulse);
     case default
        OFLWR "pulse type not supported ", pulsetype(ipulse); CFLST
     end select
  enddo

  lastfinish=0.d0
  do ipulse=1,numpulses
     if (pulsephi(ipulse).ne.0d0) then
        offaxispulseflag=1
     endif

     pulsefinish(ipulse) = pulsestart(ipulse) + pulsedur(ipulse);
     pulsemiddle(ipulse) = pulsestart(ipulse) + pulsedur(ipulse)/2;
     if (lastfinish.lt.pulsefinish(ipulse)) then
        lastfinish=pulsefinish(ipulse)
     endif

     write(mpifileptr, *) "    -----> Pulse ", ipulse," : "

     ! if (pulsetype(ipulse).eq.1.or.pulsetype(ipulse).eq.5) then
     !    fac=omega(ipulse)
     ! else
     !    fac=omega2(ipulse)
     ! endif

     fac = 0                        ! avoid warn unused
     select case(pulsetype(ipulse))
     case(1)
        fac=omega(ipulse)
     case(2,6)
        fac=omega2(ipulse)
     case(7)
        fac=1/pulsedur(ipulse)
     case default
        OFLWR "ack error programmer"; CFLST
     end select

     if (intensity(ipulse).ne.-1.d0) then !! overrides pulsestrength
        pulsestrength(ipulse) = sqrt(intensity(ipulse)/3.5094478d0)/fac
     else
        intensity(ipulse) = (fac*pulsestrength(ipulse))**2 * 3.5094478d0  !! just output
     endif
     select case (pulsetype(ipulse))
     case (1)
        write(mpifileptr,*) "Pulse type is 1: single sine squared envelope"
        write(mpifileptr, *) "Omega, pulsestart, pulsefinish, pulsestrength:"
        write(mpifileptr, '(8F18.12)') omega(ipulse), pulsestart(ipulse), pulsestart(ipulse) + pi/omega(ipulse), pulsestrength(ipulse)
     case (2)  ! longpulse disabled 08-2021  (2,3)
        write(mpifileptr,*) "Pulse type is 2: envelope with carrier"
        write(mpifileptr, *) "   chirp:           ", chirp(ipulse)
        write(mpifileptr, *) "   ramp:           ", ramp(ipulse), " Hartree"
        write(mpifileptr, *) "   Envelope omega:  ", omega(ipulse)
        write(mpifileptr, *) "   Pulse omega:     ", omega2(ipulse)
        write(mpifileptr, *) "   Pulsestart:      ",pulsestart(ipulse)
        write(mpifileptr, *) "   Pulsestrength:   ",pulsestrength(ipulse)
        write(mpifileptr, *) "   Intensity:       ",intensity(ipulse), " x 10^16 W cm^-2"
        write(mpifileptr, *) "   Pulsetheta:      ",pulsetheta(ipulse)
        write(mpifileptr, *) "   Pulsephi:      ",pulsephi(ipulse)
        write(mpifileptr, *) "   Pulsefinish:     ",pulsefinish(ipulse)
        !$$  ! longpulse disabled 08-2021
        !$$  if (pulsetype(ipulse).eq.3) then
        !$$     write(mpifileptr,*) "---> Pulsetype 3; longstep = ", longstep(ipulse)
        !$$  else if (pulsetype(ipulse).eq.2) then
        !$$     write(mpifileptr,*) "---> Pulsetype 2."
        !$$  endif
        !$$  case (4)                        ! cwpulse disabled 08-2021
        !$$     WRFL "Pulse type is 4, cw"
        !$$     write(mpifileptr, *) "   Duration omega:  ", omega(ipulse)
        !$$     write(mpifileptr, *) "   Pulse omega:     ", omega2(ipulse)
        !$$     write(mpifileptr, *) "   Pulsestrength:   ",pulsestrength(ipulse)
        !$$     write(mpifileptr, *) "   Intensity:       ",intensity(ipulse), " x 10^16 W cm^-2"
        !$$     write(mpifileptr, *) "   Pulsetheta:      ",pulsetheta(ipulse)
        !$$     write(mpifileptr, *) "   Pulsephi:      ",pulsephi(ipulse)
     case (6)  ! better pulse, NewPulse.f90
        write(mpifileptr,*) "Pulse type is 6: envelope with carrier"
        write(mpifileptr, *) "   Envelope omega:  ", omega(ipulse)
        write(mpifileptr, *) "   Pulse omega:     ", omega2(ipulse)
        write(mpifileptr, *) "   EnvDerNum:       ", envdernum
        write(mpifileptr, *) "   EnvPwr:          ", envpwr
        write(mpifileptr, *) "   Pulsestart:      ",pulsestart(ipulse)
        write(mpifileptr, *) "   Pulsestrength:   ",pulsestrength(ipulse)
        write(mpifileptr, *) "   Intensity:       ",intensity(ipulse), " x 10^16 W cm^-2"
        write(mpifileptr, *) "   Pulsetheta:      ",pulsetheta(ipulse)
        write(mpifileptr, *) "   Pulsephi:      ",pulsephi(ipulse)
        write(mpifileptr, *) "   Pulsefinish:     ",pulsestart(ipulse) + pi/omega(ipulse)
     case (7)
        WRFL  "Pulse type is 7 "
        WRFL  "   Pulse omega       :  ",omega(ipulse)
        WRFL  "   --> Pulse duration:  ",pulsedur(ipulse)
        WRFL  "   --> Pulse options:   ",pulse7opt1(ipulse),pulse7opt2(ipulse)
     case default
        WRFL "Pulse type not supported or programmer failure ",pulsetype(ipulse); CFLST
     end select
  end do

#ifdef REALGO
  WRFL "Pulse not available with real prop.";  CFLST
#endif

  if (tdflag.ne.0) then
     finaltime=lastfinish+par_timestep*4

     if (finaltime.lt.minpulsetime) then
        write(mpifileptr,*) " Enforcing minpulsetime =        ", minpulsetime
        finaltime=minpulsetime
     endif
     if (finaltime.gt.maxpulsetime) then
        write(mpifileptr,*) " Enforcing maxpulsetime =        ", maxpulsetime
        finaltime=maxpulsetime
     endif
     numpropsteps=floor((finaltime+0.0000000001d0)/par_timestep) +1
     finaltime=numpropsteps*par_timestep
     write(mpifileptr, *) "    ---> Resetting finaltime to ", finaltime
     write(mpifileptr, *) "                numpropsteps to ", numpropsteps
     write(mpifileptr, *) "   ... Writing pulse to file"

     CFL         !!!!!!   CLOSING MPIFILEPTR   !!!!!!

     ! dipolesumstart, dipolesumend used for integration of work E(omega)* D'(omega)
     !    so they just need to cover the pulse, not the response
     !
     ! also used for plotting pulse FT
     !
     mymax=0d0
     do ipulse=1,numpulses
        select case (pulsetype(ipulse))
        case(1,7)
           mymax=max(mymax,omega(ipulse)*hhgplotmax)
        case(2,6)
           mymax=max(mymax,omega2(ipulse)*hhgplotmax)
        case default
           OFLWR "pulse type not supported - programmer check pulse.f90"; CFLST
        end select
     enddo
     hhgplotend=mymax
     if (dipolesumend.lt.0d0) then
        mymax=0d0
        do ipulse=1,numpulses
           select case (pulsetype(ipulse))
           case(1,7)
              mymax=max(mymax,omega(ipulse) * 24d0)
           case(2,6)
              mymax=max(mymax,omega2(ipulse) + omega(ipulse) * 24d0)
           case default
              OFLWR "pulse type not supported - programmer check pulse.f90"; CFLST
           end select
        enddo
        dipolesumend=mymax
     endif
     if (dipolesumstart.lt.0d0) then
        mymin=1e16
        do ipulse=1,numpulses
           select case (pulsetype(ipulse))
           case(1,7)
              mymin=0d0
           case(2,6)
              mymin=min(mymin,omega2(ipulse) - omega(ipulse) * 24d0)
           case default
              OFLWR "pulse type not supported - programmer check pulse.f90"; CFLST
           end select
        enddo
        dipolesumstart=max(0d0,mymin)
     endif

     OFL
     WRFL "Dipolesumstart   :", dipolesumstart
     WRFL "Dipolesumend     :", dipolesumend
     WRFL "HHG Plot Max     :", hhgplotmax
     WRFL "HHG Plot End     :", hhgplotend
     CFL

     ! ! NOW PLOT

     pulse_end = finaltime

     nyfac     = 3d0
     emax      = dipolesumend * nyfac     ! extra factor of 3 for plotting, output to 1/3 nyquist

     ntime     = floor(emax * finaltime * 2d0 / pi)    !  also t=0 included, ntime+1 points
     dt        = pulse_end/ntime                       !  also t=0 included, ntime+1 points

     FT_OPT = 0

     if (FT_OPT == 0) then
        neflux    = half_ft_size(ntime+1) - 1;
     else
        neflux    = zfftf_size(ntime+1) - 1;
     endif

     ! print *, "NEFLUX:", ntime, neflux, dipolesumend, emax

     if (ntime > 20000 .or. neflux > 200000) then
        OFLWR "CHECKME ntime,neflux too large.. is dipolesumend or finaltime very large? ", ntime, neflux; CFLST
     endif

     if (myrank.eq.1) then
        allocate(lenpot(0:ntime,3),velpot(0:ntime,3))

        open(886, file="Dat/Pulse.Datx", status="unknown",iostat=myiostat)
        call checkiostat(myiostat," opening Dat/Pulse.Datx")
        open(887, file="Dat/Pulse.Daty", status="unknown")
        open(888, file="Dat/Pulse.Datz", status="unknown")

        !$$ csumx=0; csumy=0; csumz=0

        pots5(:) = 0;
        pots6(:) = 0;
        do i=0,ntime
           time=i*dt

           ! integrating E(t) to be sure it equals A(t)
           ! integrating A(t) to get position P(t)

           call vectdpot(time,                  0,pots1,1)
           call vectdpot(time,                  1,pots2,1)
           call vectdpot(time-dt/2 ,            0,pots3,1)
           call vectdpot(time-dt/2 ,            1,pots4,1)
           pots5(:) = pots5(:) + pots3(:) * dt
           pots6(:) = pots6(:) + pots4(:) * dt

           write(886,'(100F15.10)') time, pots1(1), pots2(1), pots5(1), pots6(1)
           write(887,'(100F15.10)') time, pots1(2), pots2(2), pots5(2), pots6(2)
           write(888,'(100F15.10)') time, pots1(3), pots2(3), pots5(3), pots6(3)

           lenpot(i,:)=pots1(:)
           velpot(i,:)=pots2(:)
        enddo
        close(886);
        close(887);
        close(888)

        allocate(evals(0:neflux),lenft(0:neflux,3),velft(0:neflux,3),pulseftsq(0:neflux),vpulseftsq(0:neflux))
        evals(:) = 0; lenft(:,:) = 0; velft(:,:) = 0; pulseftsq(:) = 0; vpulseftsq(:) = 0

        if (FT_OPT==0) then
           call half_ft_evals(ntime+1,evals,neflux+1)
           evals(:) = evals(:) / dt
           do i=1,3
              call half_ft_wrap(ntime+1,lenpot(:,i),lenft(:,i),neflux+1,1)
              call half_ft_wrap(ntime+1,velpot(:,i),velft(:,i),neflux+1,1)
           enddo
        else
           call zfftf_evals(ntime+1,evals,neflux+1)
           evals(:) = evals(:) / dt
           do i=1,3
              lenft(:,i) = lenpot(:,i)
              velft(:,i) = velpot(:,i)
              call zfftf_wrap(neflux+1,lenft(:,i))
              call zfftf_wrap(neflux+1,velft(:,i))
           enddo
        endif

        lenft(:,:)=lenft(:,:)*dt

        velft(:,:)=velft(:,:)*dt

        pulseftsq(:)=abs(lenft(:,1)**2)+abs(lenft(:,2)**2)+abs(lenft(:,3)**2)

        vpulseftsq(:)=abs(velft(:,1)**2)+abs(velft(:,2)**2)+abs(velft(:,3)**2)

        open(885, file="Dat/Pulseftsq.Dat", status="unknown")
        open(886, file="Dat/Pulseft.Datx", status="unknown")
        open(887, file="Dat/Pulseft.Daty", status="unknown")
        open(888, file="Dat/Pulseft.Datz", status="unknown")

        do i=0,neflux
           energy = evals(i)
           if (energy.ge.dipolesumstart.and.energy.le.dipolesumend) then
              !
              write(885,'(100F30.12)',iostat=myiostat) energy, pulseftsq(i), vpulseftsq(i)
              call checkiostat(myiostat," wrting Dat/Pulse.Dat file")
              write(886,'(100F30.12)') energy, lenft(i,1),velft(i,1)
              write(887,'(100F30.12)') energy, lenft(i,2),velft(i,2)
              write(888,'(100F30.12)') energy, lenft(i,3),velft(i,3)
           endif
        enddo

        close(885);   close(886);   close(887);   close(888)

        deallocate(evals,lenft,velft,pulseftsq,vpulseftsq)
        deallocate(lenpot,velpot)

     endif

     call mpibarrier()

     OFLWR "       ... done Writing pulse to file"; CFL

  endif

end subroutine getpulse

end module getparammod


module GildedRose
    implicit none
    private
    save

    public init_item
    public print_item
    public update_quality
    public int2str

    integer, parameter, public :: MAX_STR_LEN = 80

    type, public :: Item
        character(len=MAX_STR_LEN) :: name
        integer :: sellIn
        integer :: quality
    end type

contains

    subroutine init_item(it, name, sellIn, quality)
       type(Item) :: it
       character(len=*) :: name
       integer :: sellIn
       integer :: quality

       it%name = trim(name)
       it%sellIn = sellIn
       it%quality = quality

    end

    function int2str( int_val )
      implicit none
      integer :: int_val
      character( int(log10(real(max(abs(int_val),1)))) + 1 + &
          (1-sign(1,int_val))/2 ) :: int2str
      character(64) :: all_chars
      write(all_chars,*) int_val
      int2str = trim( adjustl( all_chars ) )
    end function

    subroutine print_item(it)
      type(Item) :: it
      write(*,*) trim(it%name), ', ', int2str(it%sellIn), ', ', int2str(it%quality)
    end subroutine

    subroutine update_quality(items, size)
        type(Item), dimension(:) :: items
        integer :: size

        integer :: i

        do i = 1, size
            if (items(i)%name /= "Aged Brie" .and. items(i)%name /= "Backstage passes to a TAFKAL80ETC concert" ) then

                if (items(i)%quality > 0) then

                    if (items(i)%name /= "Sulfuras, Hand of Ragnaros" ) then

                        items(i)%quality = items(i)%quality - 1
                    endif

                endif

            else

                if (items(i)%quality < 50) then

                    items(i)%quality = items(i)%quality + 1

                    if ( items(i)%name =="Backstage passes to a TAFKAL80ETC concert") then

                        if (items(i)%sellIn < 11) then

                            if (items(i)%quality < 50) then

                                items(i)%quality = items(i)%quality + 1

                            endif

                        endif

                        if (items(i)%sellIn < 6) then

                            if (items(i)%quality < 50) then

                                items(i)%quality = items(i)%quality + 1

                            endif

                        endif

                    endif

                endif

            endif
            if (items(i)%name /= "Sulfuras, Hand of Ragnaros") then

                items(i)%sellIn = items(i)%sellIn - 1

            endif

            if (items(i)%sellIn < 0) then

                if (items(i)%name /=  "Aged Brie" ) then

                    if (items(i)%name /=  "Backstage passes to a TAFKAL80ETC concert" ) then

                        if (items(i)%quality > 0 ) then

                            if (items(i)%name /= "Sulfuras, Hand of Ragnaros" )then

                                items(i)%quality = items(i)%quality - 1

                            endif

                        endif

                    else

                        items(i)%quality = items(i)%quality - items(i)%quality

                    end if

                else

                    if (items(i)%quality < 50) then

                        items(i)%quality = items(i)%quality + 1

                    end if

                end if

            end if

        end do

    end subroutine

end module


!
!     ------------------------------------------------------------------
!       C F G N 1
!     ------------------------------------------------------------------
!
      SUBROUTINE CFGN1()
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      use inform_C
      use non30_C
      use ndims_C
      use ovrlap_C
      use closed_C
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:47:32  11/17/01
!...Switches:
!      PARAMETER (NWD=128,NWCD=20)
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE cfgo1_I
      IMPLICIT NONE

!-----------------------------------------------
!   MPI data
!-----------------------------------------------
! >>>>>>     <<<<<<<
      include 'mpif.h'
      integer, parameter :: MAXPROC=999
      common /MPI/ myid, nprocs, ierr, istat(MPI_STATUS_SIZE)
      integer :: myid, nprocs, ierr, istat
      character*4 idstring
      character*128 startdir, permdir, tmpdir
      integer lclst,lentmp,lenstart,lenperm
! >>>>>>     <<<<<<<

!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NWD = 128
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER , DIMENSION(2) :: IEL, IBUFF
      INTEGER :: IASTER, IBLNK, NWF, I, J, M1, N, JJ, I1, J1, M, IJ
      CHARACTER , DIMENSION(3,NWD) :: JAJCMP
      CHARACTER :: BUFFER*8
!-----------------------------------------------
!
!       Read the configurations for a state and determine the
!       non-orthogonal orbitals
!
      DATA IASTER, IBLNK/ 4H*   , 4H    /
!
!      CALL CFGO1 (NCFG,MAXORB,NCLOSD,QIAJCMP,QLJCOMP,QNJCOMP,
!     :                 QNOC,QNELCSH,QNOCORB,QJ1,QIAJCLD,QLJCLSD)
      CALL CFGO1(NCLOSD);
      NWF = MAXORB

      if (myid == 0) print*, 'Closed shells ', nclosd
!
!     Now deal with the non-orthogonality
!
      IF (NWF > 1) THEN
         if (myid == 0) WRITE (6, *) &
            ' alloc, qiorth: nwf*(nwf-1)/2 = ', NWF*(NWF - 1)/2
         ALLOCATE (IORTH(NWF*(NWF-1)/2))
      ENDIF
!
!  ---  SEPARATE THE ELECTRON LABEL CHARACTERS AND LEFT JUSTIFY
!
      DO I = 1, MAXORB
         WRITE (BUFFER, '(A3)') IAJCMP(I)
         READ (BUFFER, '(3A1)') (JAJCMP(J,I),J=1,3)
         IF (JAJCMP(1,I) /= ' ') CYCLE
         JAJCMP(1,I) = JAJCMP(2,I)
         JAJCMP(2,I) = JAJCMP(3,I)
         JAJCMP(3,I) = ' '
      END DO
!
!  ---  INITIALIZE THE ORTHOGONALITY ARRAY
!
      M1 = (MAXORB*(MAXORB - 1))/2
      IORTH(:M1) = -1
!
!  ---  SET ORBITALS IN THE SAME CONFIGURATION TO BE ORTHOGONAL
!
      if (myid == 0) WRITE (6, *) ' NCFG = ', NCFG
      DO I = 1, NCFG
         N = NOCCSH(I)
         DO J = 1, N - 1
            DO JJ = J + 1, N
               I1 = NOCORB(J,I)
               J1 = NOCORB(JJ,I)
               IF (J1 > I1) THEN
                  M = I1
                  I1 = J1
                  J1 = M
               ENDIF
               IORTH(J1+((I1-1)*(I1-2))/2) = 0
            END DO
         END DO
      END DO
!
! --- DETERMINE THE NON-ORTHOGONAL ORBITALS
!
      NORTH = 0
      DO J = 1, MAXORB - 1
         DO I = J + 1, MAXORB
            IJ = J + ((I - 1)*(I - 2))/2
            IF (.NOT.(JAJCMP(2,I)==JAJCMP(2,J) .AND. JAJCMP(3,I)/=' ' .AND. &
               JAJCMP(3,J)/=' ' .AND. JAJCMP(3,I)/=JAJCMP(3,J) .AND. IORTH(IJ)&
               /=0)) CYCLE
            NORTH = NORTH + 1
            IORTH(IJ) = 1
         END DO
      END DO
!
      READ (IREAD, *, END=90)
   79 CONTINUE
      READ (IREAD, '(2(1X,A3))', END=90) IBUFF(1), IBUFF(2)
      IF (IBUFF(1)/=IASTER .AND. IBUFF(1)/=IBLNK) THEN
         L80: DO I = 1, 2
            DO J = 1, MAXORB
               IF (IBUFF(I) /= IAJCMP(J)) CYCLE
               IEL(I) = J
               CYCLE  L80
            END DO
            WRITE (*, '(A,A3,A)') ' ELECTRON ', IBUFF(I), ' NOT FOUND'
            STOP
         END DO L80
         IF (IEL(1) > IEL(2)) THEN
            I = IEL(1)
            IEL(1) = IEL(2)
            IEL(2) = I
         ENDIF
         IJ = IEL(1) + ((IEL(2)-1)*(IEL(2)-2))/2
         IF (IORTH(IJ) == 1) NORTH = NORTH - 1
         IORTH(IJ) = 0
         WRITE (IWRITE, '(1X,A3,A,A3)') IBUFF(1), &
              ' is orthogonal to ', IBUFF(2)
         GO TO 79
      ENDIF
   90 CONTINUE
      RETURN
      END SUBROUTINE CFGN1