C 21 Apr 08 - YW  - Davidson CI fixes
C  4 Mar 08 - HN  - NEW MODULE FOR GENERAL REFERENCE MCQDPT COMPUTATION
C
C*MODULE GMCPT   *DECK GMCPT
      subroutine gmcpt
c
c  GMC-QDPT program
c
c  Written by
c     Haruyuki Nakano
c     Department of Chemistry, Graduate School of Sciences
c     Kyushu University
c     E-mail: nakano@ccl.scc.kyushu-u.ac.jp
c
c=======================================================================
c
c  1. Description of GMC-QDPT (and GMC-PT)
c
c     GMC-QDPT (quasidegenerate perturbation theory with general multi-
c     configuration reference functions) is a multistate
c     multiconfiguration PT using general MCSCF/MCCI reference
c     functions.  (Once an active orbital set is chosen, there is no
c     restriction on reference functions.)  It is an extension of
c     MC-QDPT, which is based on CASSCF/CASCI reference functions.
c
c     In some literatures, this form of MRPT (i.e. GMC-QDPT and MC-QDPT)
c     is sometimes referred to as a "diagonalize-then-perturb-then-
c     diagonalize" method.  We first perform MCSCF/MCCI (namely,
c     "diagonalize" the active space Hamiltonian) to obtain reference
c     functions, then "perturb" the reference functions to make the
c     effective Hamiltonian, and then "diagonalize" the effective
c     Hamiltonian to get energies.
c
c     GMC-PT is a term for the cases that GMC-QDPT is applied to a
c     single state.  That is, GMC-PT is a special case name of GMC-QDPT
c     like CISD to MRCISD, HF-SCF to MC-SCF, MRMP to MC-QDPT, etc.
c     (The omitting of QD is because the word QD usually implies
c     "multistate.")
c
c     Notes:
c
c     * "GMC-PT" is sometimes used also as a generic name (which does
c       not specify the number of target states) of GMC-QDPT (as a
c       multistate PT) and GMC-PT (as a single state) for simplicity
c       (shorter name) and for avoiding confusion (QD implies
c       "multistate" as mentioned above).
c
c       As a key-word in GAMESS, "GMCPT" is used rather than "GMCQDPT"
c       because "GMCQDPT" exceeds six letters.
c       ($GMCPT; MRPT=GMCPT in $MRMP)
c
c     References:
c     1. R. Ebisuzaki, Y. Watanabe, H. Nakano, Chem. Phys. Lett. 442,
c        164-169 (2007)
c     2. H. Nakano, R. Uchiyama, K. Hirao, J. Comput. Chem. 23,
c        1166-1175 (2002)
c     (This program is based Ref. 1.  GMC-QDPT was initially described
c     in is Ref. 2.)
c
c
c  2. Program for GMC-QDPT
c
c     The present program is based on a scheme that uses matrix elements
c     between the reference and ionized determinants [See Ref.1].  It is
c     different from our original MC-QDPT scheme used in mcqdpt.src,
c     which is based on the Goldstone diagrams, and also different from
c     the original MRMP scheme by Hirao, which uses the matrix elements
c     between CSFs, i.e. the Boys-Reeves formalism with the use of
c     bonded functions.  (Note: It has been sometimes confused recent
c     days, but historically the original MRMP and MC-QDPT computational
c     schemes and codes were developed in different groups at Nagoya and
c     Kyoto at that time, and hence quite independent.)  The current
c     scheme is related to the Kozlowski-Davidson (adopted by Ivanic in
c     demrpt.src) and Celani-Werner schemes.
c
c
c     Input instructions (All possible input are explained, but )
c
c
c     (1) Name-lists $MCSCF and $MRMP
c
c       Use
c         $MCSCF CISTEP=GMCCI $END
c       to invoke the present program for MCSCF runs, or specify
c         $MCSCF CISTEP=GMCCI $END
c         $MRMP  MRPT=GMCPT   $END
c       to start up the program for GMC-QDPT runs.
c
c
c     (2) Name-list $GMCPT
c
c     (Variables with * are rarely used or rarely needed to be changed
c     from the default values.)
c
c     *** General ***
c
c     NELACT : # of active electrons (default: taken from INFOA)
c     MULT   : Spin multiplicity (default: taken from INFOA)
c    *SZ     : Sz value (default: (MULT-1)/2 )
c     ISTSYM : State symmetry of target state(s) (default: 1)
c     NMOFZC : # of frozen core orbitals (not correlated in PT
c                                             optimized  in MCSCF)
c              (default: # of chemical cores)
c     NMODOC : # of doubly occupied orbitals (correlated in PT)
c     NMOACT : # of active orbitals
c              (default: taken from DETWFN if defined)
c     NMOFZV : # of frozen virtual orbitals (not correlated in PT)
c              (default: 0)
c
c       You can set NMOCOR(=NMOFZC+NMODOC) instead of NMOFZC and
c       NMODOC.  In this case, NMOFZC becomes # of chemical cores and
c       NMODOC will be computed as NMODOC=NMOCOR-NMOFZC.
c
c       Actually ISTSYM is a 1-d array (ISTSYM(3)).  You can set up to 3
c       symmetries.  This is useful to degenerate states.
c
c    *MOSPN  : Spins of active spin-orbital (1-d array)
c              1: alpha, 2: beta (default: given by the program
c              depending on REFTYP)
c              Do not use!  This option does not affect the results.
c              Only necessary memory size can be changed.
c
c     *** Reference space in GMC-QDPT / MCSCF / MCCI ***
c
c     REFTYP : Type of the reference space
c       MRX (multireference plus excitations) (default)
c         MRX-space consists of parent determinants + 1, 2, ..., NEXCIT
c         excitations.  This choice requires $PDET that specifies parent
c         determinants (see below ["Data-list $PDET"]).
c         Needs also NEXCIT and NPDET.
c       ORMAS (occupation restricted multiple active space)
c         Needs also NSPACE, MSTART, MXHOLE, MXPART, NPDET.
c         (See $ORMAS for details)
c       RAS (restricted active space)
c         Needs MSTART and NEXCIT.
c           Ex. REFTYP=RAS MSTART(1)=4,6,9 NEXCIT=2
c           This example produces a RAS for RAS1=2, RAS2=3,
c           RAS3=NMOACT-2-3
c         (You can make RAS also via ORMAS.)
c      *MRVX (multireference plus various excitations)
c         Similar to MRX, MRVX-space consists of parent determinants +
c         excitations.  However, the excitation level depends on orbital
c         subspace.  This choice requires $PDET that specifies parent
c         determinants (see below ["Data-list $PDET"]).
c         Needs also NSPACE, MSTART, MXHOLE, MXPART, NPDET, and NEXCIT.
c         This space would be rarely used; thus not described precisely.
c         Ask HN for more details.
c      *MRXOS (multireference plus excitations with occupation
c         specified)
c         Needs $PDET, NSPACE, MSTART, MXHOLE, MXPART (MXPART=MXHOLE)
c         NPDET.
c         This space would be rarely used; thus not described.  Ask HN
c         for details.
c
c       Note: MRVX >= MRX >= RAS,  MRXOS >= ORMAS >= RAS
c
c     NPDET  : # of parent determinants (for MRX, MRVX, and MRXOS)
c     NEXCIT : Excitation level (for MRX and RAS)
c     NSPACE, MSTART, MINE, AND MAXE: (same as $ORMAS (See $ORMAS))
c    *MXHOLE/MXPART: Maximum # of holes/particles in each subspace (for
c              MRVX) (1-d array)
c              MXHOLE and MXPART are used with REFTYP=MRVX or MRXOS
c
c     *** Reference space CI ***
c
c     KSTATE : State is used (1) or not (0) (1-d array)
c
c       ex. If you want the second and the fourth roots, set
c           KSTATE(1)=0,1,0,1
c
c    *WSTATE : Weights of the states (1-d array).  (same as $GUGDM2)
c     ISPINA : Spin adaptation (default: 0)
c              0: off, 1: on (strict), -1: on (loose)
c              Proper spin states are automatically picked up after
c              lowest several states of various spins are computed.  So
c              in many cases, you do not have to turn on this option.
c     KFORB  : Canonicalization of MOs
c              T: on, F: off  (default: T)
c              Canonicalization for core, virtual, and invariant-active
c              orbital spaces is necessary to make GMC-QDPT energies
c              uniquely.
c    *KSFORB : Specify if each orbital subspace is canonicalized or not
c              (for MRVX and MRXOS) (1-d array)
c              T: yes, F: no  (default: all F)
c     KNOSYM : Symmetry specification
c              T: off, F: on  (default: F)
c     KNOSPN : Spin specification
c              T: off, F: on  (default: F)
c     MAXBAS : Maximum # of basis vectors in the Davidson method
c              (default: 100)
c     MXITER : Maximum # of iterations in the Davidson method
c              (default: 200)
c     MDI    : Dimension of small Hamiltonian used in setting
c              initial vector(s) in the Davidson method
c              (default: 300)
c    *NSOLUT : # of solutions to be obtained in the Davidson method
c              (In the case of ISPINA=0, the program looks for proper
c              spin states from NSOLUT lowest states of various spins.
c              Increase NSOLUT if the program complains.)
c     THRENE : Threshold for the energy convergence in the Davidson
c              method
c              (default: -1.0d-12 ... Negative value means "off")
c     THRCON : Threshold for the vector convergence in the Davidson
c              method  (default: 1.0d-06)
c
c     *** PT ***
c
c     IWGT   : Wavefunction analysis (default: 1)
c              0: off, 1: on (for external), -1: on (for internal)
c              (Approximate) Reference weight in 1st-order W.F. is
c              computed, which is a good measure for estimate quality of
c              the results.  In many cases, IWGT=1 is preferable to
c              IWGT=-1.  Turn off if you need speed.
c              The definition of the approximate reference weight is
c              given in the relativistic GMC-QDPT paper:
c                M. Miyajima, Y. Watanabe, and H. Nakano, J. Chem. Phys.
c                124, 044101 (2006)
c              The decomposition into orbitals is slightly different
c              from our original (mcqdwt.src).
c     KSZDOE : Electron spin (Sz) dependent orbital energies or not
c              (i.e. use different orbital energy for alpha/beta spin or
c              not)
c              T: on, F: off (default: T)
c     THRWGT : Threshold weight (=|Ci|**2) for determinant selection
c              Give negative value to turn this option off
c              (default: 1.0d-08)
c
c    (Intruder states treatment)
c
c     THRDE  : Threshold for denominator omitting
c              (default: 0.005)
c              Give zero to make this option off
c     EDSHFT : Energy denominator shifts (E -> E + EDSHFT/E)
c              (default: zero shift)
c
c       Each option has each problem: THRDE may give (small)
c       discontinuity because THRDE option just omits small denominator
c       terms; EDSHFT always gives shift-dependent results (even for
c       no-intruder-state cases).
c
c    *THRHDE : Threshold for term omitting ( |<I|V|nu>/dE| )
c              (default: 1.0)
c              This option is not so effective and thus not recommended.
c              Try to improve reference first, using more active
c              orbitals for example.  Possible values are 0.05-0.10
c              because the magnitude of most <I|V|nu>/dE is less than
c              about 0.02-0.03.
c
c    (Misc.)
c
c     CEXCEN : Unit in which the excitation energies are computed
c              eV, cm-1, kcal/mol, kJ/mol
c              (default: eV)
c    *GSENE  : 1st/2nd order ground state energies in a.u.
c              (GSENE(1)/GSENE(2)).  Use if you needs excitation
c              energies and E(1) is not the ground state energy. (1-d
c              array)
c              (default: GSENE(1)=0.0, 0.0)
c    *KROT   : (ij)->(ab) rotation [MP2 formula for (ij)->(ab)]
c              T: on, F: off
c              (default: T ; strongly recommended)
c     KMPART : Different orbital energy set for different target state
c              T: on, F: off (default: F)
c              In this case, GMC-QDPT is not based on the standard van
c              Vleck PT, but the multipartitioning PT of Zaitsevskii
c              and Malrieu.  In some cases, this option improves
c              multi-state results.
c    *THRGEN : Threshold for coupling constants.  Most users do not have
c              to care about this option.  Decrease if numerical
c              precision in PT is a problem.  Increase if a user wants
c              speedup. (default: 1.0d-09)
c
c
c     (3) Data-list $PDET ($ADDDET, $REMDET)
c
c     Parent determinant list like:
c       $PDET
c         2200
c         2+-0
c         2-+0
c       $END
c     (This input needs $GMCPT npdet=3 $END)
c     Note that 2+-0 and 2-+0 mean determinants not CSFs.
c     You can put spaces before determinants, but you cannot split
c     determinants by spaces like 22 00.
c
c     You can add/remove some determinants to/from reference:
c       $ADDDET/$REMDET
c         2      <-- # of dets. to be added/removed
c         2002
c         +-02
c       $END
c     though these options $ADDDET and $REMDET would be rarely used.
c     A problem is that $ADDDET can interfere orbital canonicalization.
c     Thus it is much better to use with KFORB=.F.
c
c
c     Notes
c
c     The program was designed for general MC reference functions
c     basically (and originates from relativistic GMC-QDPT program).  So
c     please keep in mind:
c
c     - (A remark on the orbital canonicalization: removed)
c
c     - The program should not be fast compared to the CAS-based
c       programs and other reference-type specific programs.
c
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 30, 2007 by HN                 ===
c=======================================================================
c
c     Routine gmcpt drives GMC-QDPT runs
c
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c==== GAMESS commons ===================================================
c     LOGICAL GOPARR,DSKWRK,MASWRK  ! Moved to os_info.fh
      LOGICAL DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,DOVVVO,DOVVVV,DOCORE
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
c
      logical svdskw
c
      ordskw=DSKWRK
      svdskw=DSKWRK
      DSKWRK=.true.
c
c**** Read input data **************************************************
      kprint=.true.
      call os_init_data
      call os_read_data(2)
c
c**** Orbital canonicalization *****************************************
      if(kforb) then
        if(MASWRK) then
          write(lunout,'(/5x,24(1h-)/
     *      5x,"Orbital canonicalization"/
     *      5x,24(1h-))')
          write(lunout,'(
     *      /" MOs are canonicalized for core, virtual, and invariant",
     *       "-active orbital spaces."
     *      /" This is a part of the GMC-QDPT calculation.")')
        end if
        nc=nmofzc+nmodoc
        no=nmofzc+nmodoc+nmoact
        nt=nmofzc+nmodoc+nmoact
        nprttf=-5
c       kforb=.false.
        dditrf=GOPARR
        DOOOOO=.true.
        DOVOOO=.false.
        DOVVOO=.false.
        DOVOVO=.false.
        DOVVVO=.false.
        DOVVVV=.false.
        DOCORE=.true.
        call TRFMCX(nprttf,nc,no,nt,.true.,.false.,
     *              DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *              DOVVVO,DOVVVV,DOCORE)
        call os_gmcci_start(.false.)  ! kpr=kprint=.false.
        dskwrk=.false.
        call os_gmcci_solve(DDITRF)
        call os_gmcci_print
        call gms_focke     (.false.)  ! SOME=.false.
        dskwrk=.true.
        if(GOPARR) call DDI_DESTROY(D_OOOO)
        kprint=.true.
        kforb =.false.
      end if
c
c**** Integral transformation fort GMC-QDPT ****************************
c
c     Taken from Joe's code (demrpt.src)
c
c     IF(SOME) WRITE(IW,9040)
c     NC = NCORSV-NVAL
c     NO = NCORSV+NACT
c     NT = NCORSV+NACT+NEXT
c
c     Acutually (VV|OO) part is not necesary for PT; only used for the
c     orbital energies
c
      nc=nmofzc
      no=nmofzc+nmodoc+nmoact
      nt=nmofzc+nmodoc+nmoact+nmoext
      nprttf=0
      dditrf=GOPARR
      DOOOOO=.true.
      DOVOOO=.true.
      DOVVOO=.true.
      DOVOVO=.true.
      DOVVVO=.false.
      DOVVVV=.false.
      DOCORE=.true.
      call TRFMCX(nprttf,nc,no,nt,.false.,.false.,
     *            DDITRF,DOOOOO,DOVOOO,DOVVOO,DOVOVO,
     *            DOVVVO,DOVVVV,DOCORE)
c
c**** Dipole moment integrals transformation ***************************
c
c     Compute dipole moment integrals for oscillator strength
c     calculations
c
      call os_trans_dip
c
c**** Call os_gmcpt ****************************************************
c
c     Go into the GMC-QDPT routine
c
      call os_gmcpt
c
      DSKWRK=svdskw
c
c**** Destroy global arrays ********************************************
      if(GOPARR) then
        call DDI_DESTROY(D_VVOO)
        call DDI_DESTROY(D_OOOO)
        call DDI_DESTROY(D_VOOO)
        call DDI_DESTROY(D_VOVO)
      end if
      end
      SUBROUTINE GMS_DPTCAN(SOME,V,Q,S,F,FMO,VOLD,U,IWRK,EIG,SCR,
     *                      L0,L1,L2,L3,NACT,NCORBS)
c     SUBROUTINE     DPTCAN(SOME,V,Q,S,F,FMO,VOLD,U,IWRK,EIG,SCR,
c    *                      L0,L1,L2,L3,NACT,NCORBS,NCORPT)
c=======================================================================
c===            Taken from demrpt.src (original DPTCAN)              ===
c===           Modified by H. Nakano (Kyushu University)             ===
c===               Last revision: Oct 26, 2007 by HN                 ===
c=======================================================================
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION V(L1,L1),Q(L1,L1),S(L2),F(L2),FMO(L2),VOLD(L1,L1),
     *          U(L1,L1),IWRK(L1),EIG(L1),SCR(*)
      LOGICAL SOME
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      PARAMETER (ZERO=0.0D+00)
c====<HN
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      dimension timstr(3)
c==== HN>
C
C     Canonicalize orbitals for DETPT...core/active/virtual space
C     Note: this is just always done, if called, because if the
C           MCSCF has canonicalized, this processes diagonal blocks,
C           and thus does not change anything at all.
C
      NORB = L0
      NVIRT= NORB-NCORBS-NACT
      IF(SOME) WRITE(IW,9000) NCORBS,NACT,NVIRT
C
C     ----- ZERO BLOCKS CONNECTING CORE, ACTIVE, EXTERNAL SPACES -----
C     THIS WILL PREVENT ANY SUBSEQUENT MIXING OF THESE ORBITAL SPACES
C
      DO I=NCORBS+1,NCORBS+NACT
         IROW = (I*I-I)/2
         DO J=1,NCORBS
            IJ = IROW+J
            FMO(IJ) = ZERO
         ENDDO
      ENDDO
      DO I=NCORBS+NACT+1,NORB
         IROW = (I*I-I)/2
         DO J=1,NCORBS+NACT
            IJ = IROW+J
            FMO(IJ) = ZERO
         ENDDO
      ENDDO
c====<HN
c
c     Clear inter-subspace block in the active orbital part
c
      imosum=0
      do k=1,nspace
        do i=ncorbs+imosum+1,ncorbs+imosum+morb(k)/2
          jmosum=0
          do l=1,k-1
            do j=ncorbs+jmosum+1,ncorbs+jmosum+morb(l)/2
              irow = (i*i-i)/2
              ij = irow+j
              fmo(ij) = zero
            end do
            jmosum=jmosum+morb(l)/2
          end do
        end do
        imosum=imosum+morb(k)/2
      end do
c==== HN>
C
C     ----- TRANSFORM BLOCKED FOCK MATRIX BACK TO AO SPACE -----
C
      CALL DAREAD(IDAF,IODA,S,L2,12,0)
      CALL TFTRIB(F,FMO,S,V,U,SCR,L0,L1,L2,L3)
C
C     ----- DIAGONALIZE IN THE -Q- MATRIX SPACE -----
C
      CALL DAREAD(IDAF,IODA,Q,L3,45,0)
      CALL TFTRI(FMO,F,Q,SCR,L0,L1,L1)
      CALL SYMDIA(FMO,V,EIG,SCR,IWRK,L0,L2,L1)
C
C        transform density and orbitals
C
      CALL TFSQB(V,Q,SCR,L0,L1,L1)
C
C        MAKE SURE WE PRESERVE ORIGINAL CORE/ACTIVE/EXTERNAL ORDERING.
C        THEN WITHIN EACH ORBITAL SPACE, WE SORT BY EIGENVALUE.
C
      CALL DAREAD(IDAF,IODA,VOLD,L3,15,0)
      CALL OVLSEL(V,EIG,VOLD,S,U,SCR,IWRK,SCR,L0,L1,L2)
C
c====<HN
c
c ??? This part changes MCCI and PT energies.  HN does not know the
c ??? reason, maybe related to symmetry treatment.  Currently this part
c ??? is off, which does not affect the PT results.
c
c$$$      DO K=1,NCORBS-1
c$$$         KMIN=K
c$$$         RMIN=EIG(K)
c$$$         DO I=K+1,NCORBS
c$$$            IF(EIG(I).LT.RMIN) THEN
c$$$               KMIN=I
c$$$               RMIN=EIG(I)
c$$$            END IF
c$$$         END DO
c$$$         IF(KMIN.NE.K) THEN
c$$$            CALL DSWAP( 1,EIG(K),1,EIG(KMIN),1)
c$$$            CALL DSWAP(L1,V(1,K),1,V(1,KMIN),1)
c$$$         END IF
c$$$      ENDDO
c==== HN>
C
c====<HN
c     NORBS = NCORBS+NACT
c     DO K=NCORBS+1,NORBS-1
c        KMIN=K
c        RMIN=EIG(K)
c        DO I=K+1,NORBS
c           IF(EIG(I).LT.RMIN) THEN
c              KMIN=I
c              RMIN=EIG(I)
c           END IF
c        END DO
c        IF(KMIN.NE.K) THEN
c           CALL DSWAP( 1,EIG(K),1,EIG(KMIN),1)
c           CALL DSWAP(L1,V(1,K),1,V(1,KMIN),1)
c        END IF
c     END DO
c
c ??? This part changes MCCI and PT energies.  HN does not know the
c ??? reason, maybe related to symmetry treatment.  Currently this part
c ??? is off, which does not affect the PT results.
c
c$$$      m=0
c$$$      do l=1,nspace
c$$$        do k=ncorbs+m+1,ncorbs+m+morb(l)/2-1
c$$$          kmin=k
c$$$          rmin=eig(k)
c$$$          do i=k+1,ncorbs+m+morb(l)/2
c$$$            if(eig(i).lt.rmin) then
c$$$              kmin=i
c$$$              rmin=eig(i)
c$$$            end if
c$$$          end do
c$$$          if(kmin.ne.k) then
c$$$            call dswap( 1,eig(k),1,eig(kmin),1)
c$$$            call dswap(l1,v(1,k),1,v(1,kmin),1)
c$$$          end if
c$$$        end do
c$$$        m=m+morb(l)/2
c$$$      end do
c==== HN>
C
c====<HN
c
c ??? This part changes PT energies. HN does not know the reason.
c ??? Currently this part is off, which does not affect the PT results.
c
c$$$      DO K=NORBS+1,NORBS+NVIRT-1
c$$$         KMIN=K
c$$$         RMIN=EIG(K)
c$$$         DO I=K+1,NORBS+NVIRT
c$$$            IF(EIG(I).LT.RMIN) THEN
c$$$               KMIN=I
c$$$               RMIN=EIG(I)
c$$$            END IF
c$$$         END DO
c$$$         IF(KMIN.NE.K) THEN
c$$$            CALL DSWAP( 1,EIG(K),1,EIG(KMIN),1)
c$$$            CALL DSWAP(L1,V(1,K),1,V(1,KMIN),1)
c$$$         END IF
c$$$      END DO
c====<HN
c
c     Re-insert the old MOs into the 2nd part of active orbital space.
c     This part is only for the MRX cases,
c
c$$$      if(reftyp.eq.'MRX     ') then
c$$$        do k=ncorbs+morb(1)/2+1,ncorbs+morb(1)/2+morb(2)/2
c$$$          call dcopy(l1,vold(1,k),1,v(1,k),1)
c$$$          eig(k) = zero
c$$$        end do
c$$$      end if
      m=0
      do ispace=1,nspace
        if(.not.ksforb(ispace)) then
          do i=ncorbs+m+1,ncorbs+m+morb(ispace)/2
            call dcopy(l1,vold(1,i),1,v(1,i),1)
            eig(i) = zero
          end do
        end if
        m=m+morb(ispace)/2
      end do
c==== HN>
C
C           --- save results of canonicalization ---
C        the calling routine picks the desired orbital energies
C        from the diagonal of -fmo-, and then saves to the disk.
C
      CALL DAWRIT(IDAF,IODA,V,L3,15,0)
C
c====<HN
c     IF(SOME) THEN
c        WRITE(IW,9010) NCORPT
      if(MASWRK) then
         write(iw,'(/" Orbital energies for filled orbital space")')
         WRITE(IW,9040) (EIG(I),I=1,NCORBS)
         WRITE(IW,9020)
         WRITE(IW,9040) (EIG(I),I=NCORBS+1,NCORBS+NACT)
         WRITE(IW,9030)
         WRITE(IW,9040) (EIG(I),I=NCORBS+NACT+1,NCORBS+NACT+NVIRT)
         write(iw,'(/" Zero values mean non-canonical orbitals.")')
c
         call tmdate(timstr)
         write(ip,'("--- Semi-canonical MOs --- generated at ",3a8)')
     *     timstr
         write(ip,'(a8)') ' $VEC   '
         npun = ncorbs+nact+nvirt
         call pusql(v,npun,l1,l1)
         write(ip,'(a8)') ' $END   '
      end if
c     END IF
c==== HN>
      II = 0
      DO I=1,NCORBS+NACT+NVIRT
         II = II + I
         FMO(II) = EIG(I)
      ENDDO
c====<HN
c
c
c ??? This part was from routine NTNCAN in mcscf.src.  HN thought this
c ??? might solve the energy problem commented above, but dit not.
c
C
C     ----- ASSIGN SYMMETRY LABELS TO -MCHF- ORBITALS -----
C
      CALL DAREAD(IDAF,IODA,  S,L2,12,0)
      CALL DAREAD(IDAF,IODA,  V,L3,15,0)
      CALL DAREAD(IDAF,IODA,  Q,L3,45,0)
      CALL SYMMOS(IWRK,Q,S,V,SCR,L0,L1,L0,L1)
      CALL DAWRIT(IDAF,IODA,IWRK,L1,255,1)
c==== HN>
      RETURN
C
 9000 FORMAT(/1X,'GENERATING DIAGONAL FOCK ENERGIES FOR EACH ORBITAL'/
     *        1X,'THERE ARE',I5,' FILLED,',I5,' ACTIVE, AND',I5,
     *           ' VIRTUAL ORBITALS')
c====<HN
c9010 FORMAT(1X,'ORBITAL ENERGIES FOR FILLED ORBITAL SPACE (',I5,
c    *          ' ARE FROZEN CORES)')
c==== HN>
 9020 FORMAT(1X,'Orbital energies for active orbital space')
 9030 FORMAT(1X,'Orbital energies for external orbital space')
 9040 FORMAT(1X,5F11.6)
      END
      SUBROUTINE GMS_FOCKE(SOME)
c=======================================================================
c===             Taken from demrpt.src (original FOCKE)              ===
c===           Modified by H. Nakano (Kyushu University)             ===
c===               Last revision: Oct 20, 2007 by HN                 ===
c=======================================================================
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (MXRT=100, MXATM=2000)
C
      LOGICAL SOME
c====<HN
      LOGICAL PACK2E,           GOPARR,DSKWRK,MASWRK,
     *        DIRSAV,DIRSCF,FDIFF
c     LOGICAL PACK2E,NOS,IVANIC,GOPARR,DSKWRK,MASWRK,
c    *        DIRSAV,DIRSCF,FDIFF
c==== HN>
C
c====<HN
c     COMMON /DETMRP/ EBAR0,EPT0(MXRT),EPT1(MXRT),WPTST(MXRT),
c    *                IPTST(MXRT),NPTST,NVAL,NEXT,IFORB,NOS,IVANIC
c==== HN>
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,S,SZ,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORB,
     *                NA,NB,K,KST,IROOT,IPURES,MAXW1,NITER,MAXP,NCI,
     *                IGPDET,KSTSYM,NFTGCI
      COMMON /FMCOM / X(1)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NATO,NBTO,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
C
      DATA CHECK/8HCHECK   /
C
      IF (GOPARR) THEN
         DIRSAV=DIRSCF
         DIRSCF=.TRUE.
      END IF
C
      L1 = NCORSV + NACT
      L2 = (L1*(L1+1))/2
C
      N0 = NQMT
      N1 = NUM
      N2 = (N1*(N1+1))/2
      N3 = N1*N1
C
      CALL VALFM(LOADFM)
      LDM1  = LOADFM + 1
      LVEC  = LDM1  + L2
      LDM2  = LVEC  + N3
      LWRK  = LDM2  + N2
      LBUF  = LWRK  + N2
      LIBF  = LBUF  + NINTMX
      LSCR  = LIBF  + NINTMX
      LQ    = LSCR  + 8*N1
      LS    = LQ    + N3
      LFAO  = LS    + N2
      LWRK1 = LFAO  + N2
      LWRK2 = LWRK1 + N3
      LIWRK = LWRK2 + N3
      LEIG  = LIWRK + N1
      LAST  = LEIG  + N1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      IF(EXETYP.EQ.CHECK) THEN
         CALL VCLR(X(LWRK),1,L1)
         GO TO 500
      END IF
C
      CALL DAREAD(IDAF,IODA,X(LVEC),N3,15,0)
      CALL DAREAD(IDAF,IODA,X(LDM1),L2,68,0)
C
C Tranform the density matrix to the ao basis
C
      CALL TRPOSQ(X(LVEC),N1)
      CALL TFTRI(X(LDM2),X(LDM1),X(LVEC),X(LWRK),N1,L1,N1)
C
C Calculate fock matrix in ao basis
C
      CALL VCLR(X(LWRK),1,N2)
      CALL FLMAT(X(LDM2),X(LVEC),X(LWRK),X(LBUF),X(LIBF),N1)
      CALL DAREAD(IDAF,IODA,X(LDM2),N2,11,0)
      CALL VADD(X(LWRK),1,X(LDM2),1,X(LWRK),1,N2)
C
C Tranform the fock matrix to the mo basis
C
      CALL DAREAD(IDAF,IODA,X(LVEC),N3,15,0)
      CALL TFTRI(X(LDM2),X(LWRK),X(LVEC),X(LSCR),N0,N1,N1)
C
c====<HN
c     IF(NOS) THEN
c        IF(SOME) WRITE(IW,*) 'USING NO-S, SKIPPING CANONICALIZATION'
c     ELSE IF(IFORB.EQ.0) THEN
c        IF(SOME) WRITE(IW,*) 'BY REQUEST, SKIPPING CANONICALIZATION'
c     ELSE
c        NCORPT=NCORSV-NVAL
c        CALL     DPTCAN(SOME,X(LVEC),X(LQ),X(LS),X(LFAO),X(LDM2),
c    *                   X(LWRK1),X(LWRK2),X(LIWRK),X(LEIG),X(LSCR),
c    *                   N0,N1,N2,N3,NACT,NCORSV,NCORPT)
         CALL GMS_DPTCAN(SOME,X(LVEC),X(LQ),X(LS),X(LFAO),X(LDM2),
     *                   X(LWRK1),X(LWRK2),X(LIWRK),X(LEIG),X(LSCR),
     *                   N0,N1,N2,N3,NACT,NCORSV)
c     END IF
c==== HN>
C
C  And dump to record 284
C
      IPOS = 0
      DO II=1,N1
         IPOS = IPOS + II
         IF(II.LE.N0) THEN
            X(LWRK+II-1) = X(LDM2+IPOS-1)
         ELSE
            X(LWRK+II-1) = 0.0D+0
         END IF
      ENDDO
C
  500 CONTINUE
      CALL DAWRIT(IDAF,IODA,X(LWRK),N1,284,0)
      CALL RETFM(NEED)
      CALL FLSHBF(IW)
      IF (GOPARR) DIRSCF=DIRSAV
      RETURN
      END
      SUBROUTINE GMS_RDCI12
     *  (hint,gint,DDITRF,NFT,X1,   NCORE,M1,M2,      XX,IX,NINTMX)
c    *  (          DDITRF,NFT,X1,X2,NCORE,M1,M2,M4,IA,XX,IX,NINTMX)
c=======================================================================
c===            Taken from aldeci.src (original RDCI12)              ===
c===           Modified by H. Nakano (Kyushu University)             ===
c===               Last revision: Oct 09, 2007 by HN                 ===
c=======================================================================
C
C     M1=NACT, M2=(M1*M1+M1)/2
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SVDSKW,DDITRF
C          non-dditrf needx xx(nintmx), and ix(nintmx d.p.)
C              dditrf needs xx(m2), and no ix array
c====<HN
c     DIMENSION X1(M2),X2(M4),IA(M2),XX(*),IX(*)
      DIMENSION X1(M2),hint(M1,M1),gint(M1,M1,M1,M1),XX(*),IX(*)
c==== HN>
C
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
C  DDI ARRAY HANDLES
C
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
C
C     -- read 1 and 2 e- transformed integrals into replicated memory --
C     Only integrals in the active space, between NCORE and NCORE+M1
C     are returned in X1 and X2 arrays.  The 2e- integrals might be
C     in distributed memory, depending on DDITRF flag.
C
c     IROW = 0
c     DO 110 I=1,M2
c        IA(I) = IROW
c        IROW = IROW+I
c 110 CONTINUE
C
c     CALL VCLR(X2,1,M4)
      CALL VCLR(gint,1,M1**4)
C
C         integrals are to be obtained from distributed memory
C
      IF (DDITRF) THEN
C
C         obtain the one electron integrals, always read from disk.
C
         SVDSKW=DSKWRK
         DSKWRK=.FALSE.
         CALL SEQREW(NFT)
         CALL SQREAD(NFT,X1,M2)
         CALL SEQREW(NFT)
C
C         obtain the two electron integrals from distributed memory.
C
         CALL DDI_DISTRIB(D_OOOO,ME,ILO,IHI,JLO,JHI)
         NACT = M1
         NOCC = NACT + NCORE
         NOTR = (NOCC*NOCC+NOCC)/2
         DO I = 1, NACT
           IN = I + NCORE
           DO J = 1, I
             JN = J + NCORE
             IJ = (I*I-I)/2 + J
             IJN = (IN*IN-IN)/2 + JN
             IF ((IJN.ge.JLO).AND.(IJN.le.JHI)) THEN
               CALL DDI_GET(D_OOOO,1,NOTR,IJN,IJN,XX)
               DO K = 1, NACT
                 KN = K + NCORE
                 DO L = 1, K
                  LN = L + NCORE
                   KL = (K*K-K)/2 + L
                   IF (IJ.ge.KL) THEN
                     KLN = (KN*KN-KN)/2 + LN
c====<HN
c                    IJKL = (IJ*IJ-IJ)/2 + KL
c                    X2(IJKL) = XX(KLN)
                     gint(i,j,k,l)=xx(kln)
                     gint(i,j,l,k)=xx(kln)
                     gint(j,i,k,l)=xx(kln)
                     gint(j,i,l,k)=xx(kln)
                     gint(k,l,i,j)=xx(kln)
                     gint(l,k,i,j)=xx(kln)
                     gint(k,l,j,i)=xx(kln)
                     gint(l,k,j,i)=xx(kln)
c==== HN>
                   END IF
                 END DO
               END DO
             END IF ! LOCAL STRIPE
           END DO ! J
         END DO ! I
c====<HN
         dskwrk=svdskw
c==== HN>
C
      ELSE
C
C         obtain the one electron integrals, always read from disk.
C         only the master has the 1e- integrals, but if the 2e-
C         integrals are on disk, all nodes must process them.
C
         SVDSKW=DSKWRK
         DSKWRK=.TRUE.
         CALL SEQREW(NFT)
         IF(MASWRK) CALL SQREAD(NFT,X1,M2)
         IF(GOPARR) CALL DDI_BCAST(2511,'F',X1,M2,MASTER)
C
C         Read transformed 2e- integral file in reverse canonical order.
C
  200    CONTINUE
         CALL PREAD(NFT,XX,IX,NX,NINTMX)
         IF (NX.EQ.0) GO TO 240
         MX = ABS(NX)
         IF (MX.GT.NINTMX) THEN
            IF(MASWRK) WRITE(IW,*) 'INTEGRAL CONFUSION IN -GMS_RDCI12-'
            CALL ABRT
         END IF
         DO 220 M = 1,MX
            VAL = XX(M)
            NPACK = M
            IF(LABSIZ .EQ. 2) THEN
*I32           LABEL1 = IX( 2*NPACK - 1 )
*I32           LABEL2 = IX( 2*NPACK     )
*I32           IPACK = ISHFT( LABEL1, -16 )
*I32           JPACK = IAND( LABEL1, 65535 )
*I32           KPACK = ISHFT( LABEL2, -16 )
*I32           LPACK = IAND( LABEL2, 65535 )
*I64           LABEL = IX(NPACK)
*I64           IPACK = ISHFT( LABEL, -48 )
*I64           JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64           KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64           LPACK = IAND( LABEL, 65535 )
            ELSE IF (LABSIZ .EQ. 1) THEN
*I32           LABEL = IX(NPACK)
*I32           IPACK = ISHFT( LABEL, -24 )
*I32           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32           LPACK = IAND( LABEL, 255 )
*I64           IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64              LABEL = IX( NPACK/2 )
*I64              IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64              JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64              KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64              LPACK = IAND( LABEL, 255 )
*I64           ELSE
*I64              LABEL = IX( (NPACK/2)+1 )
*I64              IPACK = ISHFT( LABEL, -56 )
*I64              JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64              KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64              LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64           END IF
            END IF
C
C        note index reversals to convert from reverse canonical order
C
            K = IPACK - NCORE
            L = JPACK - NCORE
            I = KPACK - NCORE
            J = LPACK - NCORE
C
            IF(I.LE.0  .OR.  I.GT.M1) GO TO 220
            IF(J.LE.0  .OR.  J.GT.M1) GO TO 220
            IF(K.LE.0  .OR.  K.GT.M1) GO TO 220
            IF(L.LE.0  .OR.  L.GT.M1) GO TO 220
C
c====<HN
c           IJ = IA(I)+J
c           KL = IA(K)+L
c           IJKL = IA(IJ) + KL
c           X2(IJKL) = VAL
            gint(i,j,k,l)=val
            gint(i,j,l,k)=val
            gint(j,i,k,l)=val
            gint(j,i,l,k)=val
            gint(k,l,i,j)=val
            gint(l,k,i,j)=val
            gint(k,l,j,i)=val
            gint(l,k,j,i)=val
c==== HN>
  220    CONTINUE
         IF(NX.GT.0) GO TO 200
C
  240    CONTINUE
         CALL SEQREW(NFT)
         DSKWRK=SVDSKW
      END IF
C
C  GLOBAL SUM ALSO ACTS AS A SYNC
C
c     CALL DDI_GSUMF(5000,X2,M4)
      CALL DDI_GSUMF(5000,gint,M1**4)
c====<HN
c
c  Store 1e integrals into hint
c
      n=0
      do i=1,M1
        do j=1,i
          n=n+1
          hint(i,j)=x1(n)
          hint(j,i)=x1(n)
        end do
      end do
c==== HN>
      RETURN
      END
      subroutine os_calc_oscstr
     * (norder,
     *  eigvec,eigval,dipint,den1  ,trndip,oscstr,list  ,lrf2or,lor2rf)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
c
c     Calculate osilator strength for the reference CI states
c
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension eigvec(nci,nstate), eigval(nstate)
      dimension dipint(nmoact,nmoact,3)
      dimension den1  (nmoact,nmoact,nstate)
      dimension trndip(3,nstate)
      dimension oscstr(nstate,2)
      dimension list  (3,nelact*(nsoact-nelact+1))
c     dimension icc0p (3,nelact*(nsoact-nelact+1)),
c    *          icc0m (3,nelact*(nsoact-nelact+1))
      dimension lrf2or(nci),lor2rf(ndet)
c
      if(nstate.eq.1) return
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_calc_oscstr ",45(1h*))')
        call ut_init_time
      END IF
c
c**** Read dipole moment integrals *************************************
      call seqrew(lundin)       ! rewind lundin
      read(lundin) dipint
c
      call seqrew(lunref)       ! rewind lunref
      call seqrew(luno2r)       ! rewind luno2r
      read(lunref) lrf2or
      read(luno2r) lor2rf
c
c***********************************************************************
c**** Loop for order ***************************************************
c****                ***************************************************
      do iorder=1,norder
c
c**** Read wavefunctions and energies **********************************
        if(iorder.eq.1) then
          call seqrew(luneig)   ! rewind luneig
          read(luneig) eigvec
          read(luneig) eigval
        else
          call seqrew(lunvef)   ! rewind lunvef
          read(lunvef) eigvec
          read(lunvef) eigval
        end if
c
c**** One-electron transition density matrix ***************************
        call vclr(den1,1,nmoact*nmoact*nstate)
c
        call seqrew(luncc0)     ! rewind luncc0
c
        do jref=1+me,nci,nproc  ! do iref=1,nci
          jdet=lrf2or(jref)
          call os_make_cc0_pq_oscstr(numelm,jdet,list,lor2rf)
          do i=1,numelm
            lp  =lso2mo( list(1,i) )
            lq  =lso2mo( list(2,i) )
            iref=        list(3,i)
            if     (iref.gt.0) then
              do istate=2,nstate
                den1(lp,lq,istate)=den1(lp,lq,istate)
     *            +eigvec( iref,istate)*eigvec(jref,1)
              end do
            else if(iref.lt.0) then
              do istate=2,nstate
                den1(lp,lq,istate)=den1(lp,lq,istate)
     *            -eigvec(-iref,istate)*eigvec(jref,1)
              end do
            end if
          end do
        end do
c
        if(GOPARR) call DDI_GSUMF(5000,den1,nmoact*nmoact*nstate)
c
c**** Compute oscillator strength **************************************
        call vclr(trndip,1,3*nstate)
        do istate=2,nstate
          do j=1,nmoact
          do i=1,nmoact
            trndip(1,istate)=trndip(1,istate)
     *        +dipint(i,j,1)*den1(i,j,istate)
            trndip(2,istate)=trndip(2,istate)
     *        +dipint(i,j,2)*den1(i,j,istate)
            trndip(3,istate)=trndip(3,istate)
     *        +dipint(i,j,3)*den1(i,j,istate)
          end do
          end do
        end do
c
        do istate=2,nstate
          oscstr(istate,iorder)= ( trndip(1,istate)**2
     *                            +trndip(2,istate)**2
     *                            +trndip(3,istate)**2 )
     *                          *(eigval(istate)-eigval(1))
     *                          *(2.0d+00/3.0d+00)
        end do
c
c***********************************************************************
c**** Loop end *********************************************************
c****          *********************************************************
      end do
c
c**** Write oscillator strength ****************************************
      if(MASWRK) then
        if(norder.eq.1) then
          write(lunout,
     *      '(/" Oscillator strength (invalid if E(1)/=E(GS)):"/
     *        1x,41(1h-)                /
     *        3x,"State",24x,"f"/
     *        1x,41(1h-))')
          write(lunout,
     *      '(i6,5x,"F(REF-CI)=",f20.10)')
     *        (istate,oscstr(istate,1),istate=2,nstate)
          write(lunout,'(1x,41(1h-))')
        else
          write(lunout,
     *      '(/" Oscillator strength (invalid if E(1)/=E(GS)):"/
     *         1x,76(1h-)                                /
     *         3x,"State",24x,"1st order",27x,"2nd order"/
     *         1x,76(1h-))')
          write(lunout,
     *      '(i6,5x,"F(REF-CI)=",f20.10,5x,"F(GMC-PT2)=",f20.10)')
     *       (istate,oscstr(istate,1),oscstr(istate,2),istate=2,nstate)
          write(lunout,'(1x,76(1h-))')
        end if
      END IF
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_davidson_diag(hdia, h,g, icc0p,icc0m)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
c
c     Make the diagonal part of H for Davidson diagonalization
c
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension hdia(nci)
      dimension h(nmoact,nmoact), g(nmoact,nmoact,nmoact,nmoact)
      dimension icc0p(3,nelact*(nsoact-nelact+1))
      dimension icc0m(3,nelact*(nsoact-nelact+1))
c
c**** Clear Ab *********************************************************
      call vclr(hdia,1,nci)
c
c**** One-electron integrals *******************************************
      call seqrew(luncc0)       ! rewind luncc0
c
      do iref=1+me,nci,nproc    ! do iref=1,nci
        read(luncc0) np,nm
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
        do i=1,np
          lp  =lso2mo( icc0p(1,i) )
          lq  =lso2mo( icc0p(2,i) )
          jref=        icc0p(3,i)
          if(iref.eq.jref) hdia(iref)=hdia(iref)+h(lp,lq)
        end do
        do i=1,nm
          lp  =lso2mo( icc0m(1,i) )
          lq  =lso2mo( icc0m(2,i) )
          jref=        icc0m(3,i)
          if(iref.eq.jref) hdia(iref)=hdia(iref)-h(lp,lq)
        end do
      end do
c
c**** Two-electron integrals *******************************************
  100 continue
        read(luncc0) np,nm
        if(np.lt.0) go to 102
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        do i=1,np
          lq  =lso2mo( icc0p(1,i) )
          lp  =lso2mo( icc0p(2,i) )
          iref=        icc0p(3,i)
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
            if(iref.eq.jref) hdia(iref)=hdia(iref)+g(lp,lq,lr,ls)
c                 g=(real_val)/2
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
            if(iref.eq.jref) hdia(iref)=hdia(iref)-g(lp,lq,lr,ls)
c                 g=(real_val)/2
          end do
        end do
        do i=1,nm
          lq  =lso2mo( icc0m(1,i) )
          lp  =lso2mo( icc0m(2,i) )
          iref=        icc0m(3,i)
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
            if(iref.eq.jref) hdia(iref)=hdia(iref)-g(lp,lq,lr,ls)
c                 g=(real_val)/2
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
            if(iref.eq.jref) hdia(iref)=hdia(iref)+g(lp,lq,lr,ls)
c                 g=(real_val)/2
          end do
        end do
      go to 100
  102 continue
c
      if(GOPARR) call DDI_GSUMF(5000,hdia,nci)
c
c**** End **************************************************************
      end
      subroutine os_davidson_init0
     * (ninitv,v     ,h     ,g     ,icc0p ,icc0m ,hdia  ,maxvec,
     *  lnw2od,lod2nw,diahma,diaval,diavec,diawrk,s2    ,
     *  s2v   ,vnorm2,i2sz  )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
c
c     Make initial vector(s) for Davidson diagonalization
c
      implicit double precision (a-h,o-z)
      parameter (ONE=1.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c     dimension v(nci,ninitv)
      dimension v(nci,maxvec)
      dimension h(nmoact,nmoact), g(nmoact,nmoact,nmoact,nmoact)
      dimension icc0p(3,nelact*(nsoact-nelact+1))
      dimension icc0m(3,nelact*(nsoact-nelact+1))
      dimension hdia(nci)
c
      dimension lnw2od(nci), lod2nw(nci)
      dimension diahma(mdi*(mdi+1)/2)
      dimension diaval(mdi), diavec(mdi,mdi), diawrk(9*mdi)
      dimension s2(maxvec)
c
      dimension s2v(nci,*), vnorm2(*), i2sz(nci)
c
c**** Sort diagonal elements *******************************************
      do i=1,nci
        lnw2od(i)=i
      end do
      do i=1,mdi
        do j=i+1,nci
          if(hdia(lnw2od(i)).gt.hdia(lnw2od(j))) then
            k        =lnw2od(i)
            lnw2od(i)=lnw2od(j)
            lnw2od(j)=k
          end if
        end do
      end do
      do i=1,nci
        lod2nw(lnw2od(i))=i
      end do
c
c**** One-electron integrals *******************************************
      call vclr(diahma,1,mdi*(mdi+1)/2)
c
      call seqrew(luncc0)       ! rewind luncc0
c
      do iref=1+me,nci,nproc    ! do iref=1,nci
        read(luncc0) np,nm
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        irefnw=lod2nw(iref)
        if(irefnw.le.mdi) then
          iretri=(irefnw-1)*irefnw/2
          do i=1,np
            lp  =lso2mo( icc0p(1,i) )
            lq  =lso2mo( icc0p(2,i) )
            jref=        icc0p(3,i)
            jrefnw=lod2nw(jref)
            if(jrefnw.le.mdi .and. jrefnw.le.irefnw)
     *        diahma(iretri+jrefnw)=diahma(iretri+jrefnw)+h(lp,lq)
          end do
          do i=1,nm
            lp  =lso2mo( icc0m(1,i) )
            lq  =lso2mo( icc0m(2,i) )
            jref=        icc0m(3,i)
            jrefnw=lod2nw(jref)
            if(jrefnw.le.mdi .and. jrefnw.le.irefnw)
     *        diahma(iretri+jrefnw)=diahma(iretri+jrefnw)-h(lp,lq)
          end do
        end if
      end do
c
c**** Two-electron integrals *******************************************
  100 continue
        read(luncc0) np,nm
        if(np.lt.0) go to 102
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        do i=1,np
          lq  =lso2mo( icc0p(1,i) )
          lp  =lso2mo( icc0p(2,i) )
          iref=        icc0p(3,i)
          irefnw=lod2nw(iref)
          if(irefnw.le.mdi) then
            iretri=(irefnw-1)*irefnw/2
            do j=1,np
              lr  =lso2mo( icc0p(1,j) )
              ls  =lso2mo( icc0p(2,j) )
              jref=        icc0p(3,j)
              jrefnw=lod2nw(jref)
              if(jrefnw.le.mdi .and. jrefnw.le.irefnw)
     *          diahma(iretri+jrefnw)=diahma(iretri+jrefnw)
     *          +g(lp,lq,lr,ls)
c                                g=(real_val)/2
            end do
            do j=1,nm
              lr  =lso2mo( icc0m(1,j) )
              ls  =lso2mo( icc0m(2,j) )
              jref=        icc0m(3,j)
              jrefnw=lod2nw(jref)
              if(jrefnw.le.mdi .and. jrefnw.le.irefnw)
     *          diahma(iretri+jrefnw)=diahma(iretri+jrefnw)
     *          -g(lp,lq,lr,ls)
c                                g=(real_val)/2
            end do
          end if
        end do
        do i=1,nm
          lq  =lso2mo( icc0m(1,i) )
          lp  =lso2mo( icc0m(2,i) )
          iref=        icc0m(3,i)
          irefnw=lod2nw(iref)
          if(irefnw.le.mdi) then
            iretri=(irefnw-1)*irefnw/2
            do j=1,np
              lr  =lso2mo( icc0p(1,j) )
              ls  =lso2mo( icc0p(2,j) )
              jref=        icc0p(3,j)
              jrefnw=lod2nw(jref)
              if(jrefnw.le.mdi .and. jrefnw.le.irefnw)
     *          diahma(iretri+jrefnw)=diahma(iretri+jrefnw)
     *          -g(lp,lq,lr,ls)
c                                g=(real_val)/2
            end do
            do j=1,nm
              lr  =lso2mo( icc0m(1,j) )
              ls  =lso2mo( icc0m(2,j) )
              jref=        icc0m(3,j)
              jrefnw=lod2nw(jref)
              if(jrefnw.le.mdi .and. jrefnw.le.irefnw)
     *          diahma(iretri+jrefnw)=diahma(iretri+jrefnw)
     *          +g(lp,lq,lr,ls)
c                                g=(real_val)/2
            end do
          end if
        end do
      go to 100
  102 continue
c
      if(GOPARR) call DDI_GSUMF(5000,diahma,mdi*(mdi+1)/2)
c
c**** Diagonalize small Hamiltonian ************************************
c
c     To avoid different phase EVs on different processors
c
      if(MASWRK) then
c$$$        mtri=0
c$$$        do i=1,mdi
c$$$          do j=1,i
c$$$            mtri=mtri+1
c$$$            diahma(mtri)=hmat(i,j)
c$$$          end do
c$$$        end do
        mtri=mdi*(mdi+1)/2
        call evvrsp(lunout,mdi   ,mdi   ,mtri  ,mdi   ,diahma,
     *              diawrk,diawrk(8*mdi+1),
     *                            diaval,diavec,0     ,info  )
c
        if(info.ne.0) then        ! error stop
          write(lunout,
     *      '(" *** Error stop in sub.os_davidson_init0 ***"/
     *        " Error in diagonalization"/
     *        " info =",i10)') info
          call abrt
        end if
      end if
c
      if(GOPARR) then
        if(knospn) then
          mxvec=ninitv
        else
          mxvec=min(ninitv*3,maxvec,mdi)
        end if
        call DDI_BCAST(5000,'F',diavec,mdi*mxvec,master)
      end if
c
c**** Set initial vector(s) ********************************************
c     call vclr(v,1,nci*ninitv)
c
c     do j=1,ninitv
c       do i=1,mdi
c         v(lnw2od(i),j)=hmat(i,j)
c       end do
c     end do
c
c     Select proper spin states
c
c     mxvec=min(maxvec,mdi)
      if(knospn) then
        mxvec=ninitv
      else
        mxvec=min(ninitv*3,maxvec,mdi)
      end if
      call vclr(v,1,nci*mxvec)
      do j=1,mxvec
        do i=1,mdi
          v(lnw2od(i),j)=diavec(i,j)
        end do
      end do
c
      if(knospn .or. ispina.eq.0) return
c
      call os_s2_calc(mxvec,v,s2,s2v,vnorm2,i2sz)
c
      nst=0
      do j=1,mxvec
c       if( s2(j) .gt. dble(mult-1)*HALF    -0.01d+00 .and.
c    *      s2(j) .lt. dble(mult-1)*HALF+ONE-0.01d+00      ) then
        if( s2(j) .gt. dble(mult-1)*HALF    -0.10d+00 .and.
     *      s2(j) .lt. dble(mult-1)*HALF+ONE-0.10d+00      ) then
          nst=nst+1
          do i=1,nci
            v(i,nst)=v(i,j)
          end do
          if(nst.eq.ninitv) go to 104
        end if
      end do
  104 continue
c
      if(nst.lt.ninitv) then
        if(MASWRK)
     *  write(lunout,'(" *** Error stop in sub.os_davidson_init0 ***"/
     *                 " # of spin adapted initial vectors is smaller",
     *                 " than expected."/" Increase MAXBAS."/
     *                 " nst =",i10,"  ninitv =",i10)') nst,ninitv
c
c                        or change the code:
c                              mxvec=min(ninitv*3,maxvec,mdi)
c                                        ^^^^^^^^
        call abrt
      end if
c
c**** End **************************************************************
      end
      subroutine os_davidson_keep_char(lci,eigvec,eigval,kvec)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 30, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension eigvec(maxbas,lci),eigval(lci)
      logical kvec(lci)         ! local arrays
c
      do i=1,lci
        kvec(i)=.false.
      end do
      do i=1,nstci
        ci2max=-1.0d+00
        ivecmx=0
        do j=1,lci
          ci2=eigvec(i,j)**2
          if((ci2.gt.ci2max) .and. .not.kvec(j)) then
            ci2max=ci2
            ivecmx=j
          end if
        end do
        kvec(ivecmx)=.true.
      end do
c
      n=0
      do j=1,lci
        if(kvec(j)) then
          n=n+1
          do i=1,lci
            eigvec(i,n)=eigvec(i,j)
          end do
          eigval(n)=eigval(j)
        end if
      end do
c
      if(n.lt.nstci) then
        if(MASWRK) then
          write(lunout,
     *      '(" *** Error stop in sub.os_davidson_keep_char ***"/
     *        " n =",i10,"  nstci =",i10)')
        end if
        call abrt
      end if
c
      end
      subroutine os_davidson_method
     * (kmcscf,kmxovl,maxdia,
     *  q     ,xi    ,ab    ,atilde,bvec  ,h     ,g     ,icc0p ,icc0m ,
     *  kconv ,hdia  ,diahma,w     ,diavec,diawrk,lrfocc,s2    ,enepre,
     *  respre,lnw2od,lod2nw,kvec  ,ovlp  ,hcore ,gjkint,geoin1,geoin2,
     *  s2work)
c=======================================================================
c===            Coded by H. Miyajima (Kyushu University)             ===
c===            Last revision: Mar 18, 2008 by Y. Watanabe           ===
c=======================================================================
c
c     Do Davidson diagonalization
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,ONE=1.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c==== GAMESS commons ===================================================
      PARAMETER (MXRT=100, MXATM=2000)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FUNCT / E,EGRAD(3,MXATM)
c
c     lci: number of basis vectors
c
      dimension q(nci), xi(nci)
      dimension Ab(nci,maxbas), Atilde(maxbas,maxbas), bvec(nci,maxbas)
c
c     h:            one-electron integrals
c     g:            two-electron integrals
c     icc0p, icc0m: coupling-coefficient buffers
c     kconv:        array indicate if the states are converged or not
c                   (.T.=converged, .F.=unconverged)
c     hdia:         diagonal elements of Hamiltonian
c     diahma:       working array for diagonalization
c                   (Atilde(input), eigenvectors(output))
c     w:            eigenvalues
c     lrfocc:       array storing occupation integer
c
      dimension h(nmoact,nmoact), g(nmoact,nmoact,nmoact,nmoact)
      dimension icc0p (3,nelact*(nsoact-nelact+1)),
     *          icc0m (3,nelact*(nsoact-nelact+1))
      logical   kconv (nsolut)
      dimension hdia  (nci)
c     maxdia=max(maxbas,mdi)
c     diahma, diavec, diawrk, and s2 are used also in os_davidson_init0
      dimension diahma(maxdia*(maxdia+1)/2)
c     dimension diahma(maxbas*(maxbas+1)/2)
      dimension w     (maxdia),diavec(maxdia,maxdia),diawrk(9*maxdia)
c     dimension w     (maxbas),diavec(maxbas,maxbas),diawrk(9*maxbas)
      dimension lrfocc(2,nci)
c     always maxbas>=nsolut
      dimension s2(maxbas), enepre(nsolut), respre(nsolut)
c     dimension s2(nsolut), enepre(nsolut), respre(nsolut)
      dimension lnw2od(nci), lod2nw(nci)
      logical   kvec(maxbas)
      dimension ovlp(nstci)
      dimension hcore(nmo,nmo), gjkint(lasdoc,lasdoc)
      dimension geoin1(nmo,lasact,lasact), geoin2(nmo,lasact,lasact)
      dimension s2work(nci,nsolut+2)
      logical   iocc(NSOMAX)
      logical   kmcscf, kmxovl
c
c     maxbas: maximum number of basis vectors
c     mxiter: maximum number of iterations
c     thrzro: threshold value for zero
c     thrcon: threshold value for vector convergece in Davidson method
c     threne: threshold value for energy convergece in Davidson method
c     prttol: threshold value for CI vector printing
c     ecore:  core energy
c
      if(.not.kmcscf .AND.MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_davidson_method ",41(1h*))')
        call ut_init_time
      end if
      if(.not.kmcscf .AND.MASWRK) then
        write(lunout, '(/" ***                    ***",
     *                  /" *** Reference space CI ***",
     *                  /" ***                    ***")')
        call ut_init_time
        if(threne.gt.ZERO) write(lunout,'(/" Energy convergence: on")')
      end if
c
      thrzro=1.0d-12
      prttol=0.05d+00
      prtmai=0.20d+00
c
c**** If kmxovl=.T. (i.e. 2nd CI), slide luneig to luneig+1 ************
      if(kmxovl) luneig=luneig+1
c
c**** Copy input parameters ********************************************
c     maxbas=maxbas_ci
c     mxiter=mxiter_ci
c     threne=threne_ci
c     thrcon=thrcon_ci
c     mdi   =min(mdi_ci,nci)
      mdi   =min(mdi,nci)
c
c**** Read integrals ***************************************************
      if(kmcscf) then
        call os_read_int_mcscf(h,g,ecore)
      else
        call os_read_int(h,g,ecore,hcore,gjkint,geoin1,geoin2)
      end if
c
c**** Get diagonal elements of Hamiltonian matrix **********************
      call os_davidson_diag(hdia, h,g, icc0p,icc0m)
c
c**** Make bvec (= initialize vectors) *********************************
      lci=nsolut
c
c     if(.not.kmxovl) then
c       call os_davidson_init(lci,bvec)
c     else
        call os_davidson_init0
     *   (lci   ,bvec  ,h     ,g     ,icc0p ,icc0m ,hdia  ,maxbas,
     *    lnw2od,lod2nw,diahma,w     ,diavec,diawrk,s2    ,
     *    Ab,s2work(1,1),s2work(1,2))
c         -- Used as working arrays
c
        if(ispina.ne.0) then      ! spin adaptation
          call os_s2_proj(lci,bvec,s2work(1,1),s2work(1,lci+1))
c
c         ONVMGS did not work for an unknown reason (HN).
c         call ONVMGS(nci,lci,bvec,0)
          do j=1,lci
            vlensq=ZERO
            do i=1,nci
              vlensq=vlensq+bvec(i,j)*bvec(i,j)
            end do
            vnorm=ONE/sqrt(vlensq)
            do i=1,nci
              bvec(i,j)=bvec(i,j)*vnorm
            end do
            do k=j+1,lci
              vovlp=ZERO
              do i=1,nci
                vovlp=vovlp+bvec(i,j)*bvec(i,k)
              end do
              do i=1,nci
                bvec(i,k)=bvec(i,k)-vovlp*bvec(i,j)
              end do
            end do
          end do
c
        end if
c
c     end if
c
c     Print initial vectors
c
      if(.not.kmcscf .AND.MASWRK .and. lpout.eq.1) then
        call seqrew(lunroc)     ! rewind lunroc
        read(lunroc) lrfocc
c
        write(lunout,'(" *** Initial vector(s) ***")')
        do j=1,nsolut
          write(lunout,'(1x,"State #",i5/
     *      6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",6x,"----",4x,"--------- --------- -----")')
     *      j
          do idet=1,nci
            if(abs(bvec(idet,j)) .gt. prtmai) then
              call os_int2occ(iocc,lrfocc(1,idet))
              call os_print_string(idet,bvec(idet,j),iocc,.false.)
            end if
          end do
        end do
      end if
c
c****           ********************************************************
c**** Loop head ********************************************************
c****           ********************************************************
      niter=0
c     do i=1,nsolut
c       kconv(i)=.false.
c     end do
c     nremai=nsolut  ! nremai: number of unconverged vectors
c%%%% nretgt=nstate  ! nretgt: number of unconverged target states
      lci   =nsolut
      lcipre=0
      do i=1,nsolut
        w     (i)=ZERO
        respre(i)=ONE
      end do
c
  100 continue
      niter=niter+1
c
c**** Make Ab **********************************************************
c
c     bvec -> Ab
c
      call os_davidson_sigma(lci-lcipre,
     *                       bvec(1,lcipre+1),
     *                       Ab  (1,lcipre+1),
     *                       h,g, icc0p,icc0m)
c@@@@ @@@@ @@@@
c     call os_s2_proj(lci-lcipre,Ab(1,lcipre+1))
c
c**** Make Atilde ******************************************************
      do j=lcipre+1,lci
        do i=1,j
          Atilde(i,j)=ZERO
          do k=1,nci
            Atilde(i,j)=Atilde(i,j)+bvec(k,i)*Ab(k,j)
          enddo
          Atilde(j,i)=Atilde(i,j)
        enddo
      enddo
c
c**** Diagonalize Hamiltonian matrix ***********************************
c
c     Copy Atilde to diahma to keep the contents of Atilde
c
      ltri=0
      do i=1,lci
        do j=1,i
          ltri=ltri+1
          diahma(ltri)=Atilde(i,j)
        end do
      end do
c     do j=1,lci
c     do i=1,lci
c       diahma(i,j)=Atilde(i,j)
c     end do
c     end do
c
c     Store previsous energies
c
      do i=1,nsolut
        enepre(i)=w(i)
      end do
c
c     To avoid different phase EVs on different processors
c
      if(MASWRK) then
        call evvrsp(lunout,lci   ,lci   ,ltri  ,maxdia,diahma,
     *              diawrk,diawrk(8*lci+1),
     *                            w     ,diavec,0     ,info  )
c
c       Print eigenvalue and vectors
c
        if(info.ne.0) then
          write(lunout,
     *      '(" *** Error stop in sub.os_davidson_method ***"/
     *        " Diagonalization failed."/
     *        " info =",i10)') info
          call abrt
        end if
      end if
      if(GOPARR) then
c       call DDI_BCAST(5000,'F',w     ,       nsolut,MASTER)
c       call DDI_BCAST(5000,'F',diavec,maxbas*nsolut,MASTER)
        call DDI_BCAST(5000,'F',w     ,       lci,MASTER)
        call DDI_BCAST(5000,'F',diavec,maxdia*lci,MASTER)
      end if
c
c==== ==== ====
      if(ispina.eq.-1)
     *  call os_davidson_keep_char(lci,diavec,w,kvec)
c
      do i=1,nsolut
        kconv(i)=.false.
      end do
      nremai=nsolut              ! nremai: number of unconverged vectors
      lcipre=lci
      do istci=1,nsolut
c       if(kconv(istci)) go to 102
c
c**** Make q(M) residual vector ****************************************
        do i=1,nci
          q(i)=ZERO
          do j=1,lcipre
            q(i)=q(i)+(Ab(i,j)-w(istci)*bvec(i,j))*diavec(j,istci)
          end do
        end do
c
c@@@@ @@@@ @@@@
c       call os_s2_proj(1,q)
c
c**** Make norm ********************************************************
        qnorm=ZERO
        do i=1,nci
          qnorm=qnorm+q(i)*q(i)
        end do
        qnorm=sqrt(qnorm)
c
c**** Convergence check ************************************************
        if(qnorm.lt.thrcon) then
          kconv(istci)=.true.
          nremai=nremai-1
          go to 102
c%%%%     if(kstate(istci)) nretgt=nretgt-1
c
c       Energy convergence
c
        else if(abs(enepre(istci)-w(istci)).lt.threne) then
          kconv(istci)=.true.
          nremai=nremai-1
          go to 102
c%%%%     if(kstate(istci)) nretgt=nretgt-1
        end if
        respre(istci)=qnorm
c
c**** Make xi **********************************************************
        do i=1,nci
          if(abs(w(istci)-hdia(i)) .gt. thrzro) then ! thrzro
            xi(i)=q(i)/(w(istci)-hdia(i))
          else
            xi(i)=ZERO
          endif
        end do
c
c@@@@
c       if(ispina.gt.0) call os_s2_proj(1,xi) ! spin adaptation
c                spin adaptation
        if(ispina.eq.1 .or. ispina.eq.2) then
          call os_s2_proj(1,xi,s2work(1,1),s2work(1,2))
        else if(ispina.eq.-1) then
          call os_s2_calc(1,xi,s2,
     *      s2work(1,1),s2work(1,2),s2work(1,3)) ! spin calculation
c               spin adaptation
          if( s2(1) .gt. dble(mult-1)*HALF    -0.10d+00 .and.
     *        s2(1) .lt. dble(mult-1)*HALF+ONE-0.10d+00      ) then
            call os_s2_proj(1,xi,s2work(1,1),s2work(1,2))
          end if
        end if
c
c**** Schmidt orthogonalization ****************************************
        do i=1,lci
          temp=ZERO
          do j=1,nci
            temp=temp+bvec(j,i)*xi(j)
          end do
          do j=1,nci
            xi(j)=xi(j)-temp*bvec(j,i)
          end do
        end do
c
        dnorm=ZERO
        do i=1,nci
          dnorm=dnorm+xi(i)*xi(i)
        end do
        dnorm=sqrt(dnorm)
c
c**** One more Schmidt orthogonalization to keep precision *************
        do i=1,nci
          xi(i)=xi(i)/dnorm
        end do
c
        do i=1,lci
          temp=ZERO
          do j=1,nci
            temp=temp+bvec(j,i)*xi(j)
          end do
          do j=1,nci
            xi(j)=xi(j)-temp*bvec(j,i)
          end do
        end do
c
        dnorm=ZERO
        do i=1,nci
          dnorm=dnorm+xi(i)*xi(i)
        end do
        dnorm=sqrt(dnorm)
        if(dnorm.lt.thrzro) go to 102
c
c**** Make bvec (= Make new basis) *************************************
        lci=lci+1
        do i=1,nci
          bvec(i,lci)=xi(i)/dnorm
        end do
c
  102   continue
c
      end do
c
c**** Make (approximate) eigenvectors if necessary *********************
      if((nremai    .eq.0     ) .or.
     *   (niter+1   .gt.mxiter) .or.
     *   (lci+nremai.gt.maxbas)     ) then
c%%%% if((     kmxovl .and. nremai.eq.0) .or.
c%%%%$   (.not.kmxovl .and. nretgt.eq.0) .or.
c%%%%$  niter+1   .gt.mxiter             .or.
c%%%%$  lci+nremai.gt.maxbas                 ) then
        do i=1,nci
          do j=1,nsolut
            q(j)=ZERO
            do k=1,lcipre
              q(j)=q(j)+bvec(i,k)*diavec(k,j)
            end do
          end do
          do j=1,nsolut
            bvec(i,j)=q(j)
          end do
        end do
        if(niter.ne.mxiter .and. lci+nremai.gt.maxbas) then
          do i=1,nsolut
            w     (i)=ZERO
            respre(i)=ONE
          end do
        end if
        lci   =nsolut
        lcipre=0
      end if
c
c**** Exit if converged ************************************************
      if(nremai.eq.0) go to 104
c%%%%  if((kmxovl .and. nremai.eq.0) .or.
c%%%%$   (.not.kmxovl .and. nretgt.eq.0)) go to 104
c
c**** Error stop if niter=mxiter ***************************************
      if(niter.eq.mxiter) then
c
        call seqrew(luneig)     ! rewind luneig
        call os_val_write(luneig,nci*nsolut,bvec)
c       write(luneig) bvec(:,1:nsolut)
c
        if(MASWRK) then
          write(lunout,
     *      '(" *** Error stop in sub.os_davidson_method ***"/
     *      " # of iterations reached mxiter."/
     *      " mxiter =",i10/
     *      " Approximate vectors were stored in file.")') mxiter
c
          call os_s2_calc(nsolut,bvec,s2,
     *      s2work(1,1),s2work(1,nsolut+1),s2work(1,nsolut+2))
c
          call seqrew(lunroc)   ! rewind lunroc
          read(lunroc) lrfocc
c
          write(lunout,'(/" *** Main characters of lowest",i3,
     *                    " approximate CI wavefunctions ***")') nsolut
          do j=1,nsolut
            write(lunout,
     *        '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *        6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *        6x,"---",6x,"----",4x,"--------- --------- -----")')
     *        j,w(j)+encsum+ecore,s2(j)
            do idet=1,nci
              if(abs(bvec(idet,j)) .gt. prtmai) then
                call os_int2occ(iocc,lrfocc(1,idet))
                call os_print_string(idet,bvec(idet,j),iocc,.false.)
              end if
            end do
          end do
          write(lunout,'(/" *** Residues in the previous cycle ***")')
          call ut_rmat_print_1(lunout,respre,1,nsolut,1)
        END IF
        call abrt
c
      end if
c
c**** Loop end *********************************************************
      go to 100
c
  104 continue
c
      if(.not.knospn .and. ispina.eq.0) then
        call os_s2_calc(nsolut,bvec,s2,
     *    s2work(1,1),s2work(1,nsolut+1),s2work(1,nsolut+2))
        nst=0
        do isolut=1,nsolut
          if(s2(isolut) .gt. dble(mult-1)*HALF    -0.10d+00 .and.
     *       s2(isolut) .lt. dble(mult-1)*HALF+ONE-0.10d+00      ) then
            nst=nst+1
            w (nst)=w (isolut)
            s2(nst)=s2(isolut)
            do ici=1,nci
              bvec(ici,nst)=bvec(ici,isolut)
            end do
          end if
        end do
        if(nst.lt.nstci) then
          if(MASWRK) then
            write(lunout,
     *        '(" *** Error stop in sub.os_davidson_method ***"/
     *        " # of proper spin solutions < nstci.  Increase nsolut."/
     *        " nst =",i10,"  nstci =",i10,"  nsolut =",i10)')
     *        nst,nstci,nsolut
          end if
          call abrt
        end if
      end if
c
c**** Write main characters of lowest nstci states *********************
      if(.not.kmcscf .and. MASWRK) then
        write(lunout,'(/" Converged after",i5," iterations")') niter
c
        if(nstci.ne.nstate) then
          call os_s2_calc(nstci,bvec,s2,
     *      s2work(1,1),s2work(1,nstci+1),s2work(1,nstci+2))
c
          call seqrew(lunroc)   ! rewind lunroc
          read(lunroc) lrfocc
c
          write(lunout,
     *      '(/" *** Main characters of lowest",i3,
     *         " CI wavefunctions ***")') nstci
          do j=1,nstci
            write(lunout,
     *        '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *        6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *        6x,"---",6x,"----",4x,"--------- --------- -----")')
     *        j,w(j)+encsum+ecore,s2(j)
            do idet=1,nci
              if(abs(bvec(idet,j)) .gt. prtmai) then
                call os_int2occ(iocc,lrfocc(1,idet))
                call os_print_string(idet,bvec(idet,j),iocc,.false.)
              end if
            end do
          end do
        end if
      end if
c
c**** Re-make kstate ***************************************************
      if(kmxovl) call os_mxovlp_pick(lrfocc,bvec,ovlp)
c
c**** Store eigen-values and vectors ***********************************
      n=0
      do i=1,nstci
        if(kstate(i)) then
          n=n+1
          w   (  n)=w   (  i)+encsum+ecore
          do idet=1,nci
            bvec(idet,n)=bvec(idet,i)
          end do
        end if
      end do
c
c**** Write results ****************************************************
      if(.not.kmcscf .AND.MASWRK) then
        call os_s2_calc(nstate,bvec,s2,
     *    s2work(1,1),s2work(1,nstate+1),s2work(1,nstate+2))
c
        call seqrew(lunroc)     ! rewind lunroc
        read(lunroc) lrfocc
c
        write(lunout,'(/" Reference wavefunctions:")')
        do j=1,nstate
          write(lunout,
     *      '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *      6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",6x,"----",4x,"--------- --------- -----")')
     *      j,w(j),s2(j)
          do idet=1,nci
            if(abs(bvec(idet,j)) .gt. prttol) then
              call os_int2occ(iocc,lrfocc(1,idet))
              call os_print_string(idet,bvec(idet,j),iocc,.false.)
            end if
          end do
        end do
      end if
c
c**** Write vectors (and eigenvalues) on file **************************
      call seqrew(luneig)       ! rewind luneig
      call os_val_write(luneig,nci*nstate,bvec)
      call os_val_write(luneig,    nstate,w   )
c     write(luneig) bvec(1:nci,1:nstate)
c     write(luneig) w   (      1:nstate)
c
c**** Save kmxovl ******************************************************
      if(.not.kmcscf) then
        call os_mxovlp_save(lrfocc,bvec)
        kmxovl=.true.
      end if
c
c**** If MCSCF run, set some parameters and return *********************
      if(kmcscf) then
        e=ZERO
        do i=1,nstate
          e=e+avecoe(i)*w(i)
        end do
      end if
c
c**** End **************************************************************
      if(.not.kmcscf .AND.MASWRK) then
        call ut_return_time(tcpu,twall)
        write(lunout,'(/" Davidson method:",
     *                  " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *                    tcpu,twall
        call flshbf(lunout)
      end if
      if(.not.kmcscf .AND.MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_davidson_sigma(nvec, b,Ab, h,g, icc0p,icc0m)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
c
c     Computes sigma-vectors in the Davidson method.
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension b(nci,nvec), Ab(nci,nvec)
      dimension h(nmoact,nmoact), g(nmoact,nmoact,nmoact,nmoact)
      dimension icc0p(3,nelact*(nsoact-nelact+1))
      dimension icc0m(3,nelact*(nsoact-nelact+1))
c
c**** Clear Ab *********************************************************
      call vclr(Ab,1,nci*nvec)
c
c**** One-electron integrals *******************************************
      call seqrew(luncc0)       ! rewind luncc0
c
      do iref=1+me,nci,nproc    ! do iref=1,nci
        read(luncc0) np,nm
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        do i=1,np
          lp  =lso2mo( icc0p(1,i) )
          lq  =lso2mo( icc0p(2,i) )
          jref=        icc0p(3,i)
          if(h(lp,lq).ne.ZERO) then
            do ivec=1,nvec
              Ab(iref,ivec)=Ab(iref,ivec)+h(lp,lq)*b(jref,ivec)
            end do
          end if
        end do
        do i=1,nm
          lp  =lso2mo( icc0m(1,i) )
          lq  =lso2mo( icc0m(2,i) )
          jref=        icc0m(3,i)
          if(h(lp,lq).ne.ZERO) then
            do ivec=1,nvec
              Ab(iref,ivec)=Ab(iref,ivec)-h(lp,lq)*b(jref,ivec)
            end do
          end if
        end do
      end do
c
c**** Two-electron integrals *******************************************
  100 continue
        read(luncc0) np,nm
        if(np.lt.0) go to 102
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        do i=1,np
          lq  =lso2mo( icc0p(1,i) )
          lp  =lso2mo( icc0p(2,i) )
          iref=        icc0p(3,i)
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
            if(g(lp,lq,lr,ls).ne.ZERO) then
              do ivec=1,nvec
                Ab(iref,ivec)=Ab(iref,ivec)+g(lp,lq,lr,ls)*b(jref,ivec)
c                                           g=(real_val)/2
              end do
            end if
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
            if(g(lp,lq,lr,ls).ne.ZERO) then
              do ivec=1,nvec
                Ab(iref,ivec)=Ab(iref,ivec)-g(lp,lq,lr,ls)*b(jref,ivec)
c                                           g=(real_val)/2
              end do
            end if
          end do
        end do
        do i=1,nm
          lq  =lso2mo( icc0m(1,i) )
          lp  =lso2mo( icc0m(2,i) )
          iref=        icc0m(3,i)
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
            if(g(lp,lq,lr,ls).ne.ZERO) then
              do ivec=1,nvec
                Ab(iref,ivec)=Ab(iref,ivec)-g(lp,lq,lr,ls)*b(jref,ivec)
c                                           g=(real_val)/2
              end do
            end if
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
            if(g(lp,lq,lr,ls).ne.ZERO) then
              do ivec=1,nvec
                Ab(iref,ivec)=Ab(iref,ivec)+g(lp,lq,lr,ls)*b(jref,ivec)
c                                           g=(real_val)/2
              end do
            end if
          end do
        end do
        go to 100
  102 continue
c
      if(GOPARR) call DDI_GSUMF(5000,Ab,nci*nvec)
c
c**** End **************************************************************
      end
      subroutine os_det2int(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Find occupation pattern of IDET and store it into IOCC(2)
c
      implicit double precision (a-h,o-z)
*I32  parameter (INTBIT=32)
*I64  parameter (INTBIT=64)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
c     Clone function(s) for f77
c-f77 ibset(i,j)=ior (i,    ishft(1, j))
c
      dimension iocc(2)
      iocc(1)=0
      iocc(2)=0
      jdet=idet
      ne=nelact+meldif
      do iorb=nsoact-1,INTBIT,-1
        itest=jdet-mwt(ne,iorb,meldif)
        if(itest.gt.0) then
          iocc(2)=ibset(iocc(2),iorb-INTBIT)
          ne=ne-1
          jdet=itest
        end if
      end do
      do iorb=min(nsoact-1,INTBIT-1),0,-1
        itest=jdet-mwt(ne,iorb,meldif)
        if(itest.gt.0) then
          iocc(1)=ibset(iocc(1),iorb)
          ne=ne-1
          jdet=itest
        end if
      end do
      end
      subroutine os_det2occ(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Find occupation pattern of IDET and store it into IOCC
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      jdet=idet
      ne=nelact+meldif
      do iorb=nsoact,1,-1
        itest=jdet-mwt(ne,iorb-1,meldif)
        if(itest.gt.0) then
          iocc(iorb)=.true.
          ne=ne-1
          jdet=itest
        else
          iocc(iorb)=.false.
        end if
      end do
      end
      subroutine os_det2occ0(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Find occupation pattern of IDET and store it into IOCC
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      jdet=idet
      if(meldif.ne.-2) then
        ne=nelact+meldif
      else
        ne=nelact
      end if
      do iorb=nsoact,1,-1
        itest=jdet-mwt0(ne,iorb-1,meldif)
        if(itest.gt.0) then
          iocc(iorb)=.true.
          ne=ne-1
          jdet=itest
        else
          iocc(iorb)=.false.
        end if
      end do
      end
      subroutine os_det2occi(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Find occupation pattern of IDET and store it into IOCC
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      jdet=idet
      if(meldif.eq.-1 .or. meldif.eq.-3) then
        ne=nelact-1
      else
        ne=nelact
      end if
      do iorb=nsoact,1,-1
        itest=jdet-mwti(ne,iorb-1,meldif)
        if(itest.gt.0) then
          iocc(iorb)=.true.
          ne=ne-1
          jdet=itest
        else
          iocc(iorb)=.false.
        end if
      end do
      end
      subroutine os_det2occx(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 07, 2006 by HN                 ===
c=======================================================================
c
c     Find occupation pattern of IDET and store it into IOCC
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      jdet=idet
      ne=nelact+meldif
      do iorb=nsoact,1,-1
        itest=jdet-mwtx(ne,iorb-1,meldif)
        if(itest.gt.0) then
          iocc(iorb)=.true.
          ne=ne-1
          jdet=itest
        else
          iocc(iorb)=.false.
        end if
      end do
      end
      subroutine os_diag_hamiltonian
     * (kmcscf,kmxovl,hmat  ,eigvec,eigval,diahma,diaval,diavec,diawrk,
     *  lrfocc,s2    ,ovlp  )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 05, 2007 by HN                 ===
c=======================================================================
c
c     Directly diagonalize reference CI Hamiltonian matrix
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,ONE=1.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c==== GAMESS commons ===================================================
      PARAMETER (MXRT=100, MXATM=2000)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FUNCT / E,EGRAD(3,MXATM)
c
      dimension hmat(nci,nci)
      dimension eigvec(nci,nstate)
      dimension eigval(nstate)
      dimension diahma(nci*(nci+1)/2)
      dimension diaval(nci), diavec(nci,nci), diawrk(9*nci)
      dimension lrfocc(2,nci)
c     dimension s2(nstci)
      dimension s2(nstci*5)
      dimension ovlp(nstci)
      logical   iocc  (NSOMAX)
      logical   kmcscf, kmxovl
c     dimension istrng(NSOMAX)
c
      if(.not.kmcscf .AND.MASWRK .and. lpout.eq.1) then
        write(lunout, '(/1x,10(1h*)," Routine os_diag_hamiltonian ",
     *    40(1h*))')
        call ut_init_time
      end if
c
      if(.not.kmcscf .AND.MASWRK) then
        write(lunout, '(/" ***                    ***",
     *                  /" *** Reference space CI ***",
     *                  /" ***                    ***")')
        call ut_init_time
      end if
c
      mxvec=min(nstci*5,nci)
c
      prttol=0.05d+00
      prtmai=0.20d+00
c
c**** If kmxovl=.T. (i.e. 2nd CI), slide luneig to luneig+1 ************
      if(kmxovl) luneig=luneig+1
c
c**** Diagonalize Hamiltonian ******************************************
      call seqrew(lunhma)       ! rewind lunhma
      read(lunhma) hmat
      read(lunhma) ecore
c
c     To avoid different phase EVs on different processors
c
      ntri=0
      do i=1,nci
        do j=1,i
          ntri=ntri+1
          diahma(ntri)=hmat(i,j)
        end do
      end do
c
      if(MASWRK) then
        call evvrsp(lunout,nci   ,nci   ,ntri  ,nci   ,diahma,
     *              diawrk,diawrk(8*nci+1),
     *                            diaval,diavec,0     ,info  )
c
        if(info.ne.0) then        ! error stop
          write(lunout,
     *      '(" *** Error stop in sub.os_diag_hamiltonian ***"/
     *        " Error in diagonalization"/
     *        " info =",i10)') info
          call abrt
        end if
      end if
c
      if(GOPARR) then
        call DDI_BCAST(5000,'F',diaval,    mxvec,master)
        call DDI_BCAST(5000,'F',diavec,nci*mxvec,master)
      end if
c
c@@@@
c
c     Select proper spin states
c
c     if(ispina.ne.0) then
      if(.not.knospn) then
        call os_s2_calc
     *    (mxvec,diavec,s2,hmat(1,1),diawrk(1),diawrk(mxvec+1))
c   Used as working arrays ----      ------    ------
c
        nst=0
        do j=1,mxvec
c         if( s2(j) .gt. dble(mult-1)*HALF    -0.01d+00 .and.
c    *        s2(j) .lt. dble(mult-1)*HALF+ONE-0.01d+00      ) then
          if( s2(j) .gt. dble(mult-1)*HALF    -0.10d+00 .and.
     *        s2(j) .lt. dble(mult-1)*HALF+ONE-0.10d+00      ) then
            nst=nst+1
            diaval(nst)=diaval(j)
            do i=1,nci
              diavec(i,nst)=diavec(i,j)
            end do
            if(nst.eq.nstci) go to 100
          end if
        end do
  100   continue
c
        if(nst.lt.nstci) then
          if(MASWRK)
     *      write(lunout,
     *      '(" *** Error stop in sub.os_diag_hamiltonian ***"/
     *        " # of spin adapted eigen-vectors is smaller",
     *        " than expected."/
     *        " nst =",i10,"  nstci =",i10)') nst,nstci
          call abrt
        end if
      end if
c
c     Debug output
c
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Some eigenvalues of Hamiltonian ***"/
     *                (" E(",i3,") =",f15.8))')
     *                (istate,diaval(istate),istate=1,nstci)
      end if
c
c**** Re-make kstate ***************************************************
      if(kmxovl) call os_mxovlp_pick(lrfocc,diavec,ovlp)
c
c**** Store eigen-values and vectors ***********************************
      n=0
      do j=1,nstci
        if(kstate(j)) then
          n=n+1
          eigval(n)=diaval(j)+encsum+ecore
          do i=1,nci
            eigvec(i,n)=diavec(i,j)
          end do
        end if
      end do
c
c**** Write main characters of lowest nstci states *********************
      if(.not.kmcscf .and. nstci.ne.nstate .AND.MASWRK) then
        call os_s2_calc
     *    (nstci,diavec,s2,hmat(1,1),diawrk(1),diawrk(nstci+1))
c   Used as working arrays ----      ------    ------
c
        call seqrew(lunroc)     ! rewind lunroc
        read(lunroc) lrfocc
        write(lunout,'(/" *** Main characters of lowest",i3,
     *    " CI wavefunctions ***")') nstci
        do j=1,nstci
          write(lunout,
     *      '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *      6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",6x,"----",4x,"--------- --------- -----")')
     *      j,diaval(j)+encsum+ecore,s2(j)
          do idet=1,nci
            if(abs(diavec(idet,j)) .gt. prtmai) then
              call os_int2occ(iocc,lrfocc(1,idet))
              call os_print_string(idet,diavec(idet,j),iocc,.false.)
            end if
          end do
        end do
      end if
c
c**** Write results ****************************************************
      if(.not.kmcscf .AND.MASWRK) then
c     if(.not.kmcscf) then
        call os_s2_calc
     *    (nstate,eigvec,s2,hmat(1,1),diawrk(1),diawrk(nstate+1))
c    Used as working arrays ----      ------    ------
c
        call seqrew(lunroc)     ! rewind lunroc
        read(lunroc) lrfocc
c
        write(lunout,'(/" Reference wavefunctions:")')
        do istate=1,nstate
          write(lunout,
     *      '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *      6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",6x,"----",4x,"--------- --------- -----")')
     *      istate,eigval(istate),s2(istate)
          do idet=1,nci
            if(abs(eigvec(idet,istate)) .gt. prttol) then
              call os_int2occ(iocc,lrfocc(1,idet))
              call os_print_string
     *          (idet,eigvec(idet,istate),iocc,.false.)
            end if
          end do
        end do
      end if
c
c**** Write vectors (and eigenvalues) on file **************************
      call seqrew(luneig)       ! rewind luneig
      write(luneig) eigvec
      write(luneig) eigval
c
c**** Save kmxovl ******************************************************
      if(.not.kmcscf) then
        call os_mxovlp_save(lrfocc,eigvec)
        kmxovl=.true.
      end if
c
c**** if MCSCF run, set some parameters ********************************
      if(kmcscf) then
        e=ZERO
        do i=1,nstate
          e=e+avecoe(i)*eigval(i)
        end do
      end if
c
c**** End **************************************************************
      if(.not.kmcscf .AND.MASWRK) then
        call ut_return_time(tcpu,twall)
        write(lunout,'(/" Diagonalization:",
     *                  " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *                    tcpu,twall
      end if
      if(.not.kmcscf .AND.MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_find_minmax_dbl(val,cmnmx)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 15, 2007 by HN                 ===
c=======================================================================
c
c     Find the smallest/largest value among processors
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      character*3 cmnmx
C-MWS dimension buf(0:NPROC-1)
      dimension buf(0:1023)
c
      if(.not. GOPARR) return
c
      if(nproc-1.gt.1023) then
         if(maswrk) write(6,*) 'os-min-max-find-dbl: exceeded dimension'
         call abrt
      end if
c
      do i=0,nproc-1
        buf(i)=ZERO
      end do
      buf(me)=val
      call DDI_GSUMF(5000,buf,nproc)
      val=buf(0)
      if     (cmnmx.eq.'min' .or. cmnmx.eq.'MIN') then
        do i=1,nproc-1
          val=min(buf(i),val)
        end do
      else if(cmnmx.eq.'max' .or. cmnmx.eq.'MAX') then
        do i=1,nproc-1
          val=max(buf(i),val)
        end do
      else
        call abrt
      end if
      end
c---      subroutine os_find_minmax_int(ival,cmnmx)
c---c=================================================================
c---c===          Coded by H. Nakano (Kyushu University)           ===
c---c===            Last revision: Nov 15, 2007 by HN              ===
c---c=================================================================
c---c
c---c     Find the smallest/largest value among processors
c---c
c---      implicit double precision (a-h,o-z)
c---      LOGICAL GOPARR,DSKWRK,MASWRK
c---      COMMON /PAR/ ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c---      character*3 cmnmx
c---c     dimension ibuf(0:1023)
c---      dimension ibuf(0:NPROC-1)
c---      if(.not. GOPARR) return
c---      do i=0,nproc-1
c---        ibuf(i)=0
c---      end do
c---      ibuf(me)=ival
c---      call DDI_GSUMI(5000,ibuf,nproc)
c---      ival=ibuf(0)
c---      if(cmnmx.eq.'min' .or. cmnmx.eq.'MIN') then
c---        do i=1,nproc-1
c---          ival=min(ibuf(i),ival)
c---        end do
c---      else if(cmnmx.eq.'max' .or. cmnmx.eq.'MAX') then
c---        do i=1,nproc-1
c---          ival=max(ibuf(i),ival)
c---        end do
c---      else
c---        call abrt
c---      end if
c---      end
      subroutine os_get_energies
     *  (eigval,diahma,diaval,diavec,diawrk,heff2 ,heff  ,excene,lrfocc,
     *   eigvec,eigtmp,s2    ,s2work)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 05, 2007 by HN                 ===
c=======================================================================
c
c     Diagonalize the effective Hamiltonian and gets energies of target
c     states
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension diahma(nstate*(nstate+1)/2)
      dimension eigval(nstate)
      dimension diaval(nstate), diavec(nstate,nstate), diawrk(9*nstate)
      dimension heff2(nstate,nstate,-2:2), heff(nstate,nstate,2)
c
      dimension excene(nstate,2)
      dimension lrfocc(2,nci)
      dimension eigvec(nci,nstate),eigtmp(nstate)
      dimension s2(nstate)
      dimension s2work(nci,nstate+2)
      logical   iocc(NSOMAX)
c     dimension istrng(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_get_energies ",44(1h*))')
        call ut_init_time
      END IF
c
      if(MASWRK) then
        if(nstate.gt.1) then
          write(lunout,'(/" ***                  ***"/
     *                    " *** GMC-QDPT Results ***"/
     *                    " ***                  ***")')
        else
          write(lunout,'(/" ***                ***"/
     *                    " *** GMC-PT Results ***"/
     *                    " ***                ***")')
        end if
      end if
c
      prtmai=0.2d+00
c
c**** Read effective Hamiltonian ***************************************
      call seqrew(luneig)       ! rewind luneig
      read(luneig)
      read(luneig) eigval
c
      call seqrew(lunhef)       ! rewind lunhef
      read(lunhef) heff2
c
c**** Sum up internal and 1-, 2-, and 3-body effective Hamiltonian *****
      call vclr(heff,1,nstate*nstate*2)
c
c     First order
c
      do istate=1,nstate
        heff(istate,istate,1)=eigval(istate)
      end do
c
c     Second order
c
      do iorder=-2,2
        do jstate=1,nstate
        do istate=1,nstate
          heff(istate,jstate,2)=heff(istate,jstate,2)
     *      +heff2(istate,jstate,iorder)
        end do
        end do
      end do
c
c     Symmetrize effective Hamiltonian
c
      do jstate=1     ,nstate
      do istate=jstate,nstate
        s=(  heff(istate,jstate,1) + heff(jstate,istate,1)
     *     + heff(istate,jstate,2) + heff(jstate,istate,2)) * HALF
        heff(istate,jstate,2)=s
        heff(jstate,istate,2)=s
      end do
      end do
c**** Print effective Hamitonian ***************************************
      if(nstate.gt.1 .and.MASWRK) then
        write(lunout,
     *    '(/" Diagonal elements of effective Hamiltonian:"/
     *      (" Heff(",i3,") =",f15.8))')
     *    (i,dble(heff(i,i,2)),i=1,nstate)
        write(lunout,
     *    '(/" Off-diagonal elements of effective Hamiltonian:")')
        inicol=1
  100   continue
          lascol=min(inicol+4,nstate-1)
          write(lunout,'(7x,5i13)') (j,j=inicol,lascol)
          do i=inicol+1,nstate
            k=min(lascol,i-1)
            write(lunout,'(i6,1x,1p,5d13.6)') i,(heff(i,j,2),j=inicol,k)
          end do
          inicol=lascol+1
        if(inicol.lt.nstate) go to 100
      end if
c
c**** Diagonaliza effective Hamiltonian ********************************
c
c     To avoid different phase EVs on different processors
c
      ntri=0
      do i=1,nstate
        do j=1,i
          ntri=ntri+1
          diahma(ntri)=heff(i,j,2)
        end do
      end do
c
      if(MASWRK) then
        call evvrsp(lunout,nstate,nstate,ntri  ,nstate,diahma,
     *              diawrk,diawrk(8*nstate+1),
     *                            diaval,diavec,0     ,info  )
c
        if(info.ne.0) then        ! error
          write(lunout,'(" *** Error stop in sub.os_get_energies ***"/
     *                   " Error in diagonalization"/
     *                   " info =",i10)') info
          call abrt
        end if
      end if
c
      if(GOPARR) then
        call DDI_BCAST(5000,'F',diaval,nstate       ,MASTER)
        call DDI_BCAST(5000,'F',diavec,nstate*nstate,MASTER)
      end if
c
      call os_sort_energies(diaval,diavec)
c
c**** Make perturbed MC-QDPT states ************************************
      if(nstate.gt.1) then
        call seqrew(lunroc)     ! rewind lunroc
        read(lunroc) lrfocc
        call seqrew(luneig)     ! rewind luneig
        read(luneig) eigvec
c
        do i=1,nci              ! Make perturbed MC-QDPT states
          call vclr(eigtmp,1,nstate)
          do jstate=1,nstate
            do istate=1,nstate
              eigtmp(istate)=eigtmp(istate)
     *          +eigvec(i,jstate)*diavec(jstate,istate)
            end do
          end do
          do istate=1,nstate
            eigvec(i,istate)=eigtmp(istate)
          end do
        end do
c
        call os_s2_calc
     *   (nstate,eigvec,s2,
     *    s2work(1,1),s2work(1,nstate+1),s2work(1,nstate+2))
      end if
c
c**** Write results ****************************************************
      if(MASWRK) then
        if(nstate.gt.1) then
          write(lunout,'(/" ******** GMC-QDPT energies ********"    /
     *                    1x,76(1h-)                                /
     *                    3x,"State",24x,"1st order",27x,"2nd order"/
     *                    1x,76(1h-))')
          write(lunout,
     *      '(i6,5x,"E(REF-CI)=",f20.10,3x,"E(GMC-QDPT2)=",f20.10)')
     *      (istate,eigval(istate),diaval(istate),istate=1,nstate)
          write(lunout,'(1x,76(1h-))')
        else
          write(lunout,'(/" ******** GMC-PT energies ********"      /
     *                    1x,76(1h-)                                /
     *                    3x,"State",24x,"1st order",27x,"2nd order"/
     *                    1x,76(1h-))')
          write(lunout,
     *      '(i6,5x,"E(REF-CI)=",f20.10,5x,"E(GMC-PT2)=",f20.10)')
     *      (istate,eigval(istate),diaval(istate),istate=1,nstate)
          write(lunout,'(1x,76(1h-))')
        end if
c
        if(gsene(1).ne.ZERO) then
          do istate=1,nstate
            excene(istate,1)=eigval(istate)-gsene(1)
            excene(istate,2)=diaval(istate)-gsene(2)
          end do
          write(lunout,
     *      '(/" *** Excitation energies *** (for input E(GS))"/
     *      1x,76(1h-)                                /
     *      3x,"State",24x,"1st order",27x,"2nd order"/
     *      1x,76(1h-))')
          inista=1
        else if(nstate.gt.1) then
          excene(1,1)=ZERO
          excene(1,2)=ZERO
          do istate=2,nstate
            excene(istate,1)=eigval(istate)-eigval(1)
            excene(istate,2)=diaval(istate)-diaval(1)
          end do
          write(lunout,
     *      '(/" Excitation energies (invalid if E(1)/=E(GS)):"/
     *      1x,76(1h-)                                /
     *      3x,"State",24x,"1st order",27x,"2nd order"/
     *      1x,76(1h-))')
          inista=2
        end if
c
        if(gsene(1).ne.ZERO .or. nstate.gt.1) then
c
c         cm-1
c
          if     (cexcen.eq.'cm-1    ' .or. cexcen.eq.'CM-1    ' .or.
     *            cexcen.eq.'cm      ' .or. cexcen.eq.'CM      ') then
c           excene=excene*219474.63d+00 ! Hartree -> cm-1
            do istate=1,nstate
              excene(istate,1)=excene(istate,1)*219474.63d+00
              excene(istate,2)=excene(istate,2)*219474.63d+00
            end do
            write(lunout,'(i6,5x,"E(REF-CI)=",f15.5," cm-1",
     *                     3x,"E(GMC-QDPT2)=",f15.5," cm-1")')
     *        (istate,excene(istate,1),excene(istate,2),
     *        istate=inista,nstate)
c
c         kcal/mol
c
          else if(cexcen.eq.'kcal/mol' .or. cexcen.eq.'KCAL/MOL' .or.
     *            cexcen.eq.'kcal    ' .or. cexcen.eq.'KCAL    ') then
c           excene=excene*627.510d+00 ! Hartree -> kcal/mol
            do istate=1,nstate
              excene(istate,1)=excene(istate,1)*627.510d+00
              excene(istate,2)=excene(istate,2)*627.510d+00
            end do
            write(lunout,'(i6,5x,"E(REF-CI)=",f11.1," kcal/mol",
     *                     3x,"E(GMC-QDPT2)=",f11.1," kcal/mol")')
     *        (istate,excene(istate,1),excene(istate,2),
     *        istate=inista,nstate)
c
c         kJ/mol
c
          else if(cexcen.eq.'kj/mol  ' .or. cexcen.eq.'KJ/MOL  ' .or.
     *            cexcen.eq.'kj      ' .or. cexcen.eq.'KJ      ' .or.
     *            cexcen.eq.'kJ/mol  ' .or. cexcen.eq.'kJ      ') then
c           excene=excene*2625.50d+00 ! Hartree -> kJ/mol
            do istate=1,nstate
              excene(istate,1)=excene(istate,1)*2625.50d+00
              excene(istate,2)=excene(istate,2)*2625.50d+00
            end do
            write(lunout,'(i6,5x,"E(REF-CI)=",f13.3," kJ/mol",
     *                     3x,"E(GMC-QDPT2)=",f13.3," kJ/mol")')
     *        (istate,excene(istate,1),excene(istate,2),istate=2,nstate)
c
c         eV
c
          else
c           excene=excene*27.2114d+00 ! Hartree -> eV
            do istate=1,nstate
              excene(istate,1)=excene(istate,1)*27.2114d+00
              excene(istate,2)=excene(istate,2)*27.2114d+00
            end do
            write(lunout,'(i6,5x,"E(REF-CI)=",f17.7," eV",
     *                     3x,"E(GMC-QDPT2)=",f17.7," eV")')
     *        (istate,excene(istate,1),excene(istate,2),
     *        istate=inista,nstate)
          end if
          write(lunout,'(1x,76(1h-))')
        end if
c
        if(nstate.gt.1) then
          write(lunout,
     *      '(/" Main characters of perturbed GMC-QDPT states:")')
          do istate=1,nstate    ! Write perturbed GMC-QDPT states
            write(lunout,
     *        '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *        6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *        6x,"---",6x,"----",4x,"--------- --------- -----")')
     *        istate,diaval(istate),s2(istate)
            do idet=1,nci
              if(abs(eigvec(idet,istate)) .gt. prtmai) then
                call os_int2occ(iocc,lrfocc(1,idet))
                call os_print_string
     *            (idet,eigvec(idet,istate),iocc,.false.)
              end if
            end do
          end do
        end if
      end if
c
      if(GOPARR) call os_find_minmax_dbl(hdemax,'max')
      if(MASWRK) then
        write(lunout,'(/" <<<Max |V/de| =",1p,d10.3,
     *                  "  Thresh =",d10.3)') hdemax,thrhde
      end if
c
c**** Write perturbed wavefunctions and energies ***********************
      call seqrew(lunvef)       ! rewind lunvef
      call os_val_write(lunvef,nci*nstate,eigvec)
      call os_val_write(lunvef,    nstate,diaval)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_get_weights
     *  (diavec,wfovli,wfovl0,wfovl1,wfovl2,wfoi  ,wfo0  ,wfo1  )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 05, 2007 by HN                 ===
c=======================================================================
c
c     Computes and reports the (approximate) reference weights
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,ONE=1.0d+00,HALF=0.5d+00)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension diavec(nstate,nstate)
      dimension wfovli(nstate), wfovl0(nstate)
      dimension wfovl1(iniwgt:laswgt,nstate)
      dimension wfovl2(iniwgt:laswgt,iniwgt:laswgt,nstate)
      dimension wfoi(nstate), wfo0(nstate), wfo1(iniwgt:laswgt,nstate)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_get_weights ",45(1h*))')
        call ut_init_time
      END IF
c
c**** Read weights of states *******************************************
      call seqrew(lunwgt)       ! rewind lunwgt
      read(lunwgt) wfovli,wfovl0,wfovl1,wfovl2
c
c**** Compute reference weights ****************************************
c
c     Resolve weights for external orbitals
c
      if(iwgt.eq.1) then
c
      do k=1,nstate
c
      do i=iniact,lasext
      do j=iniact,i-1
        wfovl2(i,j,k)=wfovl2(i,j,k)+wfovl2(j,i,k)
        wfovl2(j,i,k)=ZERO
      end do
      end do
c
      do i=iniact,lasact
      do j=iniact,i
        wfovl0(    k)=wfovl0(k)+wfovl2(i,j,k)
        wfovl2(i,j,k)=ZERO
      end do
      end do
c
      do i=iniext,lasext
      do j=iniact,lasact
        wfovl1(i  ,k)=wfovl1(i  ,k)+wfovl2(i,j,k)
        wfovl2(i,j,k)=ZERO
      end do
      end do
c
      do i=iniext,lasext
      do j=iniext,i
        wfovl1(i,  k)=wfovl1(i,  k)+wfovl2(i,j,k)*HALF
        wfovl1(j,  k)=wfovl1(j,  k)+wfovl2(i,j,k)*HALF
        wfovl2(i,j,k)=ZERO
      end do
      end do
c
      do i=iniact,lasact
        wfovl0(  k)=wfovl0(  k)+wfovl1(i,k)
        wfovl1(i,k)=ZERO
      end do
c
      end do
c
      call vclr(wfoi,1,nstate)
      call vclr(wfo0,1,nstate)
      call vclr(wfo1,1,nmowgt*nstate)
c     wfoi=ZERO ; wfo0=ZERO ; wfo1=ZERO
c
      do j=1,nstate
        do k=1,nstate
          wfoi(  j)=wfoi(  j)
     *      +wfovli(              k)*diavec(k,j)*diavec(k,j)
          wfo0(  j)=wfo0(  j)
     *      +wfovl0(              k)*diavec(k,j)*diavec(k,j)
          do i=iniext,lasext
            wfo1(i,j)=wfo1(i,j)+wfovl1(i,k)*diavec(k,j)*diavec(k,j)
          end do
        end do
      end do
c
c     Resolve weights for internal orbitals
c
      else
c
      do k=1,nstate
c
      do i=inidoc,lasdoc
      do j=inidoc,i-1
        wfovl2(i,j,k)=wfovl2(i,j,k)+wfovl2(j,i,k)
        wfovl2(j,i,k)=ZERO
      end do
      end do
c
c     do i=iniact,lasact
c     do j=iniact,i
c       wfovl0(    :)=wfovl0(:)+wfovl2(i,j,:)
c       wfovl2(i,j,:)=ZERO
c     end do
c     end do
c
c     do i=iniext,lasext
c     do j=iniact,lasact
c       wfovl1(i  ,:)=wfovl1(i  ,:)+wfovl2(i,j,:)
c       wfovl2(i,j,:)=ZERO
c     end do
c     end do
c
      do i=inidoc,lasdoc
      do j=inidoc,i
        wfovl1(i,  k)=wfovl1(i,  k)+wfovl2(i,j,k)*HALF
        wfovl1(j,  k)=wfovl1(j,  k)+wfovl2(i,j,k)*HALF
        wfovl2(i,j,k)=ZERO
      end do
      end do
c
c     do i=iniact,lasact
c       wfovl0(  :)=wfovl0(  :)+wfovl1(i,:)
c       wfovl1(i,:)=ZERO
c     end do
c
      end do
c
      call vclr(wfoi,1,nstate)
      call vclr(wfo0,1,nstate)
      call vclr(wfo1,1,nmowgt*nstate)
c     wfoi=ZERO ; wfo0=ZERO ; wfo1=ZERO
c
      do j=1,nstate
        do k=1,nstate
          wfoi(  j)=wfoi(  j)
     *      +wfovli(              k)*diavec(k,j)*diavec(k,j)
          wfo0(  j)=wfo0(  j)
     *      +wfovl0(              k)*diavec(k,j)*diavec(k,j)
          do i=inidoc,lasdoc
            wfo1(i,j)=wfo1(i,j)+wfovl1(i,k)*diavec(k,j)*diavec(k,j)
          end do
c         wfo1(:,j)=wfo1(:,j)
c    *      +wfovl1(inidoc:lasdoc,k)*diavec(k,j)*diavec(k,j)
        end do
      end do
c
      end if
c
c**** Write results ****************************************************
      if(MASWRK) then
        write(lunout,'(/" ***                       ***"
     *                 /" *** Wavefunction analysis ***"
     *                 /" ***                       ***")')
c
        do i=1,nstate
          wgti=    wfoi(  i)
          wgt0=    wfo0(  i)
          wgt1=ZERO
          do j=iniwgt,laswgt
            wgt1=wgt1+wfo1(j,i)
          end do
c         wgt1=sum(wfo1(:,i))
          wtot=ONE+wgti+wgt0+wgt1
          write(lunout,'(/" State #",i5)') i
          write(lunout,
     *      '( "   Reference =",f8.3," %     Others =",f8.3," %")')
     *      ONE/wtot*100.0d+00, (wgti+wgt0+wgt1)/wtot*100.0d+00
          write(lunout,'( "   SD-components:")')
          write(lunout,
     *      '( "     Pure internal =",f15.8,"  (",f8.3," %)")')
     *      wgti,wgti/wtot*100.0d+00
          write(lunout,
     *      '( "     Internal      =",f15.8,"  (",f8.3," %)")')
     *      wgt0,wgt0/wtot*100.0d+00
          write(lunout,
     *      '( "     External      =",f15.8,"  (",f8.3," %)")')
     *      wgt1,wgt1/wtot*100.0d+00
          if(iwgt.eq.1) then
            call os_get_weights_print(wfo1(iniext,i),iniext,lasext)
          else
            call os_get_weights_print(wfo1(inidoc,i),inidoc,lasdoc)
          end if
        end do
      END IF
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_get_weights_print(a,inimo,lasmo)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jun 24, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ONE=1.0d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      parameter (nmaxmx=200)
      dimension labmax(nmaxmx)
      dimension a     (inimo:lasmo) ,amax (nmaxmx)
c
      IF(.NOT.MASWRK) RETURN
c
c     if(iwgt.eq.1) then
c       inimo=iniext ; lasmo=lasext
c     else
c       inimo=inidoc ; lasmo=lasdoc
c     end if
c
      nmax=min(20,lasmo-inimo+1)
      if(nmax.eq.0) return
c
      s=-ONE
      do i=inimo,lasmo
        ag=abs(a(i))
        if(ag.gt.s) then
          s   =ag
          imax=i
        end if
      end do
      amax  (1)=a(imax)
      labmax(1)=imax
      do k=2,nmax
        s=-ONE
        agmbef=abs(amax(k-1))
        do i=inimo,lasmo
          ag=abs(a(i))
          if(s.lt.ag .and. ag.lt.agmbef) then
            s   =ag
            imax=i
          end if
        end do
        amax  (k)=a(imax)
        labmax(k)=imax
      end do
c
      inilab=1
  100 continue
        laslab=inilab+4
        laslab=min(laslab,nmax)
        write(lunout,'(7x,"orb.  ",5(2x,i10))')
     *    (labmax(i),i=inilab,laslab)
        write(lunout,'(7x,"value ",5(2x,1p,d10.3))')
     *    (amax  (i),i=inilab,laslab)
        inilab=laslab+1
      if(inilab.le.nmax) go to 100
      end
      subroutine os_gmcci_print
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 06, 2007 by HN                 ===
c=======================================================================
c
c     Print reference CI energies and wavefunctions
c
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c==== GAMESS commons ===================================================
      common /FMCOM / d(1)
c
c     call ut_init_time
c
      if(.not.MASWRK) return
c
c**** Solve reference CI ***********************************************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci*nstate      ! eigvec
      n03 = n02 + nstate          ! eigval
      n04 = n03 + 2*nci           ! lrfocc
c     n05 = n04 + nstci           ! s2
      n05 = n04 + nstci*5         ! s2
      n06 = n05 + nci*(nstate+2)  ! s2work
      NEED = n06 - LOADFM - 1
      call GETFM(NEED)
c
      call os_gmcci_print_wavefunctions
     *  (d(n01),d(n02),d(n03),d(n04),d(n05))
      call RETFM(NEED)
c
c     call ut_report_time
c
c**** End **************************************************************
      end
      subroutine os_gmcci_print_wavefunctions
     *  (eigvec,eigval,lrfocc,s2,s2work)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 06, 2007 by HN                 ===
c=======================================================================
c
c     Print refernce CI wavefunctions
c
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      PARAMETER (MXATM=2000)
      COMMON /FUNCT / E,EGRAD(3,MXATM)
      dimension eigvec(nci,nstate), eigval(nstate)
      dimension lrfocc(2,nci)
c     dimension s2(nstci)
      dimension s2(nstci*5)
      dimension s2work(nci,nstate+2)
      logical   iocc  (NSOMAX)
c     dimension istrng(NSOMAX)
c
      if(.not.MASWRK) RETURN
c
      prttol=0.05d+00
c
c**** Read wavefunctions and energies **********************************
      call seqrew(luneig)       ! rewind luneig
      read(luneig) eigvec
      read(luneig) eigval
c
c**** Write wavefunctions **********************************************
      call os_s2_calc(nstate,eigvec,s2,
     *  s2work(1,1),s2work(1,nstate+1),s2work(1,nstate+2))
c
      call seqrew(lunroc)       ! rewind lunroc
      read(lunroc) lrfocc
c
c     write(lunout,'(/" ***                         ***"
c    *               /" *** Reference wavefunctions ***"
c    *               /" ***                         ***")')
      if(nstate.gt.1) write(lunout,'(/1x,"Averaged energy =",f18.9)') e
      if(kprint) then
        do istate=1,nstate
          write(lunout,
     *      '(/1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3//
     *      6x,"Det",6x,"Coef",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",6x,"----",4x,"--------- --------- -----")')
     *      istate,eigval(istate),s2(istate)
          do idet=1,nci
            if(abs(eigvec(idet,istate)) .gt. prttol) then
              call os_int2occ(iocc,lrfocc(1,idet))
              call os_print_string
     *          (idet,eigvec(idet,istate),iocc,.false.)
            end if
          end do
        end do
c
c     If kprint=F, just print energies
c
      else
        write(lunout,*)
        do istate=1,nstate
          write(lunout,
     *      '(1x,"State #",i5,"  Energy =",f18.9,"  S =",f7.3)')
     *      istate,eigval(istate),s2(istate)
        end do
      end if
c
c**** End **************************************************************
      end
      subroutine os_gmcci_solve(DDITRF)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jan 31, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      logical kmcscf,kmxovl
c
c==== GAMESS commons ===================================================
      PARAMETER (MXRT=100)
      LOGICAL PACK2E
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / d(1)
c     COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
c    *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
c     COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
c
      logical DDITRF,dditrf_tmp
      common /gmcddi/ dditrf_tmp
      logical svdskw
c
      kmcscf=.true.
      kmxovl=.false.
      dditrf_tmp=DDITRF
      ordskw=DSKWRK
      svdskw=DSKWRK
      DSKWRK=.true.
c
      encsum=ENUCR+ECORE
c
c     call ut_init_time
c
c**** Read integrals in MO basis ***************************************
c     call os_shuffle
c
c**** Solve reference CI ***********************************************
      if(nci .gt. mdi) then
c
        if(nci.lt.mdi) mdi=nci
        maxdia=max(maxbas,mdi)
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci                         ! q
        n03 = n02 + nci                         ! xi
        n04 = n03 + nci*maxbas                  ! ab
        n05 = n04 + maxbas*maxbas               ! atilde
        n06 = n05 + nci*maxbas                  ! bvec
        n07 = n06 + nmoact*nmoact               ! h
        n08 = n07 + nmoact**4                   ! g
        n09 = n08 + 3*nelact*(nsoact-nelact+1)  ! icc0p
        n10 = n09 + 3*nelact*(nsoact-nelact+1)  ! icc0m
        n11 = n10 + nsolut                      ! kconv
        n12 = n11 + nci                         ! hdia
        n13 = n12 + maxdia*(maxdia+1)/2         ! diahma
        n14 = n13 + maxdia                      ! w
        n15 = n14 + maxdia*maxdia               ! diavec
        n16 = n15 + 9*maxdia                    ! diawrk
        n17 = n16 + 2*nci                       ! lrfocc
        n18 = n17 + maxbas                      ! s2
        n19 = n18 + nsolut                      ! enepre
        n20 = n19 + nsolut                      ! respre
        n21 = n20 + nci                         ! lnw2od
        n22 = n21 + nci                         ! lod2nw
        n23 = n22 + maxbas                      ! kvec
        n24 = n23 + nstci                       ! ovlp
        n25 = n24 + nmo*nmo                     ! hcore
        n26 = n25 + lasdoc*lasdoc               ! gjkint
        n27 = n26 + nmo*lasact*lasact           ! geoin1
        n28 = n27 + nmo*lasact*lasact           ! geoin2
        n29 = n28 + nci*(nsolut+2)              ! s2work
        NEED = n29 - LOADFM - 1
        call GETFM(NEED)
c
        call os_davidson_method
     *  (kmcscf,kmxovl,maxdia,
     *   d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10),d(n11),d(n12),d(n13),d(n14),d(n15),d(n16),d(n17),d(n18),
     *   d(n19),d(n20),d(n21),d(n22),d(n23),d(n24),d(n25),d(n26),d(n27),
     *   d(n28))
        call RETFM(NEED)
c
      else
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nmoact*nmoact               ! hint
        n03 = n02 + nmoact**4                   ! gint
        n04 = n03 + nci*nci                     ! hmat
        n05 = n04 + 3*nelact*(nsoact-nelact+1)  ! icc0p
        n06 = n05 + 3*nelact*(nsoact-nelact+1)  ! icc0m
        n07 = n06 + nmo*nmo                     ! hcore
        n08 = n07 + lasdoc*lasdoc               ! gjkint
        n09 = n08 + nmo*lasact*lasact           ! geoin1
        n10 = n09 + nmo*lasact*lasact           ! geoin2
        NEED = n10 - LOADFM - 1
        call GETFM(NEED)
c
        call os_make_hamiltonian
     *   (kmcscf,d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),
     *    d(n08),
     *    d(n09))
        call RETFM(NEED)
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci*nci        ! hmat
        n03 = n02 + nci*nstate     ! eigvec
        n04 = n03 + nstate         ! eigval
        n05 = n04 + nci*(nci+1)/2  ! diahma
        n06 = n05 + nci            ! diaval
        n07 = n06 + nci*nci        ! diavec
        n08 = n07 + 9*nci          ! diawrk
        n09 = n08 + 2*nci          ! lrfocc
c       n10 = n09 + nstci          ! s2
        n10 = n09 + nstci*5        ! s2
        n11 = n10 + nstci          ! ovlp
        NEED = n11 - LOADFM - 1
        call GETFM(NEED)
c
        call os_diag_hamiltonian
     *  (kmcscf,kmxovl,d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),
     *   d(n08),d(n09),d(n10))
        call RETFM(NEED)
c
      end if
c
c**** Make densities ***************************************************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci*nstate                  ! eigvec
      n03 = n02 + 3*nelact*(nsoact-nelact+1)  ! icc0p
      n04 = n03 + 3*nelact*(nsoact-nelact+1)  ! icc0m
      n05 = n04 + nmoact*nmoact               ! den1
      n06 = n05 + nmoact**4                   ! den2
      n07 = n06 + (nmofzc+nmodoc+nmoact)*(nmofzc+nmodoc+nmoact+1)/2
                                              ! dm1tri
      n08 = n07 + NINTMX                      ! x
      n09 = n08 + NINTMX                      ! ix
      NEED = n09 - LOADFM - 1
      call GETFM(NEED)
c
      call os_make_density
     * (d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08))
      call RETFM(NEED)
c
c     call ut_report_time
c
      DSKWRK=svdskw
c
c**** End **************************************************************
      end
      subroutine os_gmcci_start(kpr)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jan 31, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      logical kremak,kpr
c
c==== GAMESS commons ===================================================
      COMMON /FMCOM / d(1)
c     COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
c    *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
c     COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      logical svdskw
c
      if(MASWRK .and. lpout.eq.1) call ut_init_time
c
      ordskw=DSKWRK
      svdskw=DSKWRK
      DSKWRK=.true.
c
c**** Read input data **************************************************
      kprint=kpr
      call os_init_data
      if(kprint) then
        call os_read_data(1)
      else
        call os_read_data(0)
      end if
c
c**** os_make_graph ****************************************************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + (nelact+1)*(nsoact+1)  ! mwtdum
      NEED = n02 - LOADFM - 1
      call GETFM(NEED)
      call os_make_graph(d(n01))
      call RETFM(NEED)
c
c**** Make reference determinants and CCs for reference CI *************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + npdet  ! lpdet
      n03 = n02 + ndet   ! lrdet
      NEED = n03 - LOADFM - 1
      call GETFM(NEED)
      call os_make_ref(d(n01),d(n02))
      call RETFM(NEED)
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci           ! lrf2or
      n03 = n02 + ndet          ! lor2rf
      n04 = n03 + 2*nci         ! lrfocc
      n05 = n04 + 2*ndet        ! lorocc
c     n06 = n05 + (nbab+1)*nci  ! lrfbab
c     NEED = n06 - LOADFM - 1
      NEED = n05 - LOADFM - 1
      call GETFM(NEED)
      call os_make_tables(d(n01),d(n02),d(n03),d(n04))
      call RETFM(NEED)
c
c     Make graph again
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + (nelact+1)*(nsoact+1) ! mwtdum
      n03 = n02 + 2*nci         ! lrfocc
      NEED = n03 - LOADFM - 1
      call GETFM(NEED)
      call os_remake_graph(kremak,d(n01),d(n02))
      call RETFM(NEED)
      if(kremak) then
c
c       Make reference again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + 2*nci       ! lrfocc
        n03 = n02 + nci         ! lrdet
        NEED = n03 - LOADFM - 1
        call GETFM(NEED)
        call os_remake_ref(d(n01),d(n02))
        call RETFM(NEED)
c
c       Make tables again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci           ! lrf2or
        n03 = n02 + ndet          ! lor2rf
        n04 = n03 + 2*nci         ! lrfocc
        n05 = n04 + 2*ndet        ! lorocc
c       n06 = n05 + (nbab+1)*nci  ! lrfbab
c       NEED = n06 - LOADFM - 1
        NEED = n05 - LOADFM - 1
        call GETFM(NEED)
        call os_make_tables(d(n01),d(n02),d(n03),d(n04))
        call RETFM(NEED)
      end if
c
      call os_make_graph0
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci                         ! lrf2or
      n03 = n02 + ndet                        ! lor2rf
      n04 = n03 + 3*nelact*(nsoact-nelact+1)  ! icc0p
      n05 = n04 + 3*nelact*(nsoact-nelact+1)  ! icc0m
      n06 = n05 + nci                         ! i2sz
      NEED = n06 - LOADFM - 1
      call GETFM(NEED)
      call os_make_cc0   (d(n01),d(n02),d(n03),d(n04))
      call os_make_cc0_s2(d(n01),d(n02),d(n03),d(n04),d(n05))
      call RETFM(NEED)
c
      DSKWRK=svdskw
c
      if(MASWRK .and. lpout.eq.1) call ut_report_time
c
c**** End **************************************************************
      end
      subroutine os_gmcpt
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      logical kmcscf,kremak,kmxovl
c
c==== GAMESS commons ===================================================
      PARAMETER (MXRT=100)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / d(1)
c     COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
c    *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
c     COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
c
c     ncore      =100000000
c
      kprint=.true.
      kmcscf=.false.
      kmxovl=.false.
      encsum=ENUCR+ECORE
c
      if(MASWRK) then
        write(lunout,'(/5x,8(1h-),5x,42(1h-)/
     *   5x,"GMC-QDPT",5x,"Program written by H.Nakano (Kyushu Univ.)"/
     *   5x,8(1h-),5x,42(1h-))')
      end if
c
      if(MASWRK .and. lpout.eq.1) call ut_init_time
c
c**** os_init_data & os_read_data **************************************
c     call os_init
c     call os_read
c
c**** os_make_graph ****************************************************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + (nelact+1)*(nsoact+1)  ! mwtdum
      NEED = n02 - LOADFM - 1
      call GETFM(NEED)
c     if(n02.gt.ncore+1) stop
c
      call os_make_graph(d(n01))
c
      call RETFM(NEED)
c
c**** Make reference determinants and CCs for reference CI *************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + npdet  ! lpdet
      n03 = n02 + ndet   ! lrdet
      NEED = n03 - LOADFM - 1
      call GETFM(NEED)
      call os_make_ref(d(n01),d(n02))
      call RETFM(NEED)
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci           ! lrf2or
      n03 = n02 + ndet          ! lor2rf
      n04 = n03 + 2*nci         ! lrfocc
      n05 = n04 + 2*ndet        ! lorocc
c     n06 = n05 + (nbab+1)*nci  ! lrfbab
c     NEED = n06 - LOADFM - 1
      NEED = n05 - LOADFM - 1
      call GETFM(NEED)
      call os_make_tables(d(n01),d(n02),d(n03),d(n04))
c     call os_make_tables(d(n01),d(n02),d(n03),d(n04),d(n05))
      call RETFM(NEED)
c
c     Make graph again
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + (nelact+1)*(nsoact+1)  ! mwtdum
      n03 = n02 + 2*nci                  ! lrfocc
      NEED = n03 - LOADFM - 1
      call GETFM(NEED)
      call os_remake_graph(kremak,d(n01),d(n02))
      call RETFM(NEED)
      if(kremak) then
c
c       Make reference again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + 2*nci  ! lrfocc
        n03 = n02 + nci    ! lrdet
        NEED = n03 - LOADFM - 1
        call GETFM(NEED)
        call os_remake_ref(d(n01),d(n02))
        call RETFM(NEED)
c
c       Make tables again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci           ! lrf2or
        n03 = n02 + ndet          ! lor2rf
        n04 = n03 + 2*nci         ! lrfocc
        n05 = n04 + 2*ndet        ! lorocc
c       n06 = n05 + (nbab+1)*nci  ! lrfbab
c       NEED = n06 - LOADFM - 1
        NEED = n05 - LOADFM - 1
        call GETFM(NEED)
        call os_make_tables(d(n01),d(n02),d(n03),d(n04))
        call RETFM(NEED)
      end if
c
      call os_make_graph0
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci                         ! lrf2or
      n03 = n02 + ndet                        ! lor2rf
      n04 = n03 + 3*nelact*(nsoact-nelact+1)  ! icc0p
      n05 = n04 + 3*nelact*(nsoact-nelact+1)  ! icc0m
      n06 = n05 + nci                         ! i2sz
      NEED = n06 - LOADFM - 1
      call GETFM(NEED)
c
      call os_make_cc0   (d(n01),d(n02),d(n03),d(n04))
      call os_make_cc0_s2(d(n01),d(n02),d(n03),d(n04),d(n05))
      call RETFM(NEED)
c
c**** Read integrals in MO basis ***************************************
      call os_shuffle
c
c**** Solve reference CI ***********************************************
      if(nci .gt. mdi) then
c
        if(nci.lt.mdi) mdi=nci
        maxdia=max(maxbas,mdi)
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci                         ! q
        n03 = n02 + nci                         ! xi
        n04 = n03 + nci*maxbas                  ! ab
        n05 = n04 + maxbas*maxbas               ! atilde
        n06 = n05 + nci*maxbas                  ! bvec
        n07 = n06 + nmoact*nmoact               ! h
        n08 = n07 + nmoact**4                   ! g
        n09 = n08 + 3*nelact*(nsoact-nelact+1)  ! icc0p
        n10 = n09 + 3*nelact*(nsoact-nelact+1)  ! icc0m
        n11 = n10 + nsolut                      ! kconv
        n12 = n11 + nci                         ! hdia
        n13 = n12 + maxdia*(maxdia+1)/2         ! diahma
        n14 = n13 + maxdia                      ! w
        n15 = n14 + maxdia*maxdia               ! diavec
        n16 = n15 + 9*maxdia                    ! diawrk
        n17 = n16 + 2*nci                       ! lrfocc
        n18 = n17 + maxbas                      ! s2
        n19 = n18 + nsolut                      ! enepre
        n20 = n19 + nsolut                      ! respre
        n21 = n20 + nci                         ! lnw2od
        n22 = n21 + nci                         ! lod2nw
        n23 = n22 + maxbas                      ! kvec
        n24 = n23 + nstci                       ! ovlp
        n25 = n24 + nmo*nmo                     ! hcore
        n26 = n25 + lasdoc*lasdoc               ! gjkint
        n27 = n26 + nmo*lasact*lasact           ! geoin1
        n28 = n27 + nmo*lasact*lasact           ! geoin2
        n29 = n28 + nci*(nsolut+2)              ! s2work
        NEED = n29 - LOADFM - 1
        call GETFM(NEED)
c
        call os_davidson_method
     *  (kmcscf,kmxovl,maxdia,
     *   d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10),d(n11),d(n12),d(n13),d(n14),d(n15),d(n16),d(n17),d(n18),
     *   d(n19),d(n20),d(n21),d(n22),d(n23),d(n24),d(n25),d(n26),d(n27),
     *   d(n28))
        call RETFM(NEED)
c
      else
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nmoact*nmoact               ! hing
        n03 = n02 + nmoact**4                   ! gint
        n04 = n03 + nci*nci                     ! hmat
        n05 = n04 + 3*nelact*(nsoact-nelact+1)  ! icc0p
        n06 = n05 + 3*nelact*(nsoact-nelact+1)  ! icc0m
        n07 = n06 + nmo*nmo                     ! hcore
        n08 = n07 + lasdoc*lasdoc               ! gjkint
        n09 = n08 + nmo*lasact*lasact           ! geoin1
        n10 = n09 + nmo*lasact*lasact           ! geoin2
        NEED = n10 - LOADFM - 1
        call GETFM(NEED)
c
        call os_make_hamiltonian
     *   (kmcscf,d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),
     *    d(n08),
     *    d(n09))
        call RETFM(NEED)
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci*nci        ! hmat
        n03 = n02 + nci*nstate     ! eigvec
        n04 = n03 + nstate         ! eigval
        n05 = n04 + nci*(nci+1)/2  ! diahma
        n06 = n05 + nci            ! diaval
        n07 = n06 + nci*nci        ! diavec
        n08 = n07 + 9*nci          ! diawrk
        n09 = n08 + 2*nci          ! lrfocc
c       n10 = n09 + nstci          ! s2
        n10 = n09 + nstci*5        ! s2
        n11 = n10 + nstci          ! ovlp
        NEED = n11 - LOADFM - 1
        call GETFM(NEED)
c
        call os_diag_hamiltonian
     *  (kmcscf,kmxovl,d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),
     *   d(n08),d(n09),d(n10))
        call RETFM(NEED)
c
      end if
c
c**** Re-select reference determinants according to reference CI *******
c**** coefficients                                               *******
      if(thrwgt.ge.ZERO) then
c
c       Select reference
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci         ! lrf2or
        n03 = n02 + 2*nci       ! lrfocc
        n04 = n03 + nci*nstate  ! eigvec
        NEED = n04 - LOADFM - 1
        call GETFM(NEED)
        call os_select_ref(d(n01),d(n02),d(n03))
        call RETFM(NEED)
c
c       Make graph again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + (nelact+1)*(nsoact+1)  ! mwtdum
        n03 = n02 + 2*nci                  ! lrfocc
        NEED = n03 - LOADFM - 1
        call GETFM(NEED)
        call os_remake_graph(kremak,d(n01),d(n02))
        call RETFM(NEED)
c
c       Make reference again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + 2*nci       ! lrfocc
        n03 = n02 + nci         ! lrdet
        NEED = n03 - LOADFM - 1
        call GETFM(NEED)
        call os_remake_ref(d(n01),d(n02))
        call RETFM(NEED)
c
c       Make tables again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci           ! lrf2or
        n03 = n02 + ndet          ! lor2rf
        n04 = n03 + 2*nci         ! lrfocc
        n05 = n04 + 2*ndet        ! lorocc
        NEED = n05 - LOADFM - 1
        call GETFM(NEED)
        call os_make_tables(d(n01),d(n02),d(n03),d(n04))
        call RETFM(NEED)
c
c       Make graph0 again
c
        call os_make_graph0
c
c       Make CCs for reference CI again
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci                         ! lrf2or
        n03 = n02 + ndet                        ! lor2rf
        n04 = n03 + 3*nelact*(nsoact-nelact+1)  ! icc0p
        n05 = n04 + 3*nelact*(nsoact-nelact+1)  ! icc0m
        n06 = n05 + nci                         ! i2sz
        NEED = n06 - LOADFM - 1
        call GETFM(NEED)
        call os_make_cc0   (d(n01),d(n02),d(n03),d(n04))
        call os_make_cc0_s2(d(n01),d(n02),d(n03),d(n04),d(n05))
        call RETFM(NEED)
c
        if(nci.gt.mdi) then
c
          if(nci.lt.mdi) mdi=nci
          maxdia=max(maxbas,mdi)
c
          call VALFM(LOADFM)
          n01 = LOADFM + 1
          n02 = n01 + nci                         ! q
          n03 = n02 + nci                         ! xi
          n04 = n03 + nci*maxbas                  ! ab
          n05 = n04 + maxbas*maxbas               ! atilde
          n06 = n05 + nci*maxbas                  ! bvec
          n07 = n06 + nmoact*nmoact               ! h
          n08 = n07 + nmoact**4                   ! g
          n09 = n08 + 3*nelact*(nsoact-nelact+1)  ! icc0p
          n10 = n09 + 3*nelact*(nsoact-nelact+1)  ! icc0m
          n11 = n10 + nsolut                      ! kconv
          n12 = n11 + nci                         ! hdia
          n13 = n12 + maxdia*(maxdia+1)/2         ! diahma
          n14 = n13 + maxdia                      ! w
          n15 = n14 + maxdia*maxdia               ! diavec
          n16 = n15 + 9*maxdia                    ! diawrk
          n17 = n16 + 2*nci                       ! lrfocc
          n18 = n17 + maxbas                      ! s2
          n19 = n18 + nsolut                      ! enepre
          n20 = n19 + nsolut                      ! respre
          n21 = n20 + nci                         ! lnw2od
          n22 = n21 + nci                         ! lod2nw
          n23 = n22 + maxbas                      ! kvec
          n24 = n23 + nstci                       ! ovlp
          n25 = n24 + nmo*nmo                     ! hcore
          n26 = n25 + lasdoc*lasdoc               ! gjkint
          n27 = n26 + nmo*lasact*lasact           ! geoin1
          n28 = n27 + nmo*lasact*lasact           ! geoin2
          n29 = n28 + nci*(nsolut+2)              ! s2work
          NEED = n29 - LOADFM - 1
          call GETFM(NEED)
          call os_davidson_method
     *     (kmcscf,kmxovl,maxdia,
     *      d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),
     *      d(n09),
     *      d(n10),d(n11),d(n12),d(n13),d(n14),d(n15),d(n16),d(n17),
     *      d(n18),
     *      d(n19),d(n20),d(n21),d(n22),d(n23),d(n24),d(n25),d(n26),
     *      d(n27),
     *      d(n28))
          call RETFM(NEED)
c
        else
c
c         Make Hamiltonian
c
          call VALFM(LOADFM)
          n01 = LOADFM + 1
          n02 = n01 + nmoact*nmoact               ! hing
          n03 = n02 + nmoact**4                   ! gint
          n04 = n03 + nci*nci                     ! hmat
          n05 = n04 + 3*nelact*(nsoact-nelact+1)  ! icc0p
          n06 = n05 + 3*nelact*(nsoact-nelact+1)  ! icc0m
          n07 = n06 + nmo*nmo                     ! hcore
          n08 = n07 + lasdoc*lasdoc               ! gjkint
          n09 = n08 + nmo*lasact*lasact           ! geoin1
          n10 = n09 + nmo*lasact*lasact           ! geoin2
          NEED = n10 - LOADFM - 1
          call GETFM(NEED)
          call os_make_hamiltonian
     *     (kmcscf,d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),
     *      d(n08),
     *      d(n09))
          call RETFM(NEED)
c
c         Diagonalize Hamiltonian
c
          call VALFM(LOADFM)
          n01 = LOADFM + 1
          n02 = n01 + nci*nci        ! hmat
          n03 = n02 + nci*nstate     ! eigvec
          n04 = n03 + nstate         ! eigval
          n05 = n04 + nci*(nci+1)/2  ! diahma
          n06 = n05 + nci            ! diaval
          n07 = n06 + nci*nci        ! diavec
          n08 = n07 + 9*nci          ! diawrk
          n09 = n08 + 2*nci          ! lrfocc
c         n10 = n09 + nstci          ! s2
          n10 = n09 + nstci*5        ! s2
          n11 = n10 + nstci          ! ovlp
          NEED = n11 - LOADFM - 1
          call GETFM(NEED)
          call os_diag_hamiltonian
     *      (kmcscf,kmxovl,d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),
     *       d(n07),d(n08),d(n09),d(n10))
          call RETFM(NEED)
        end if
      end if
c
c**** Compute oscillator strength **************************************
      if(nstate.gt.1 .and. gsene(1).eq.ZERO) then
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci*nstate                  ! eigvec
        n03 = n02 + nstate                      ! eigval
        n04 = n03 + nmoact*nmoact*3             ! dipint
        n05 = n04 + nmoact*nmoact*nstate        ! den1
        n06 = n05 + 3*nstate                    ! trndip
        n07 = n06 + nstate*2                    ! oscstr
        n08 = n07 + 3*nelact*(nsoact-nelact+1)  ! list
        n09 = n08 + nci                         ! lrf2or
        n10 = n09 + ndet                        ! lor2rf
        NEED = n10 - LOADFM - 1
        call GETFM(NEED)
        call os_calc_oscstr
     * (1     ,
     *  d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09))
c    * (norder,
c    *  eigvec,eigval,dipint,den1  ,trndip,oscstr,list  ,lrf2or,lor2rf)
        call RETFM(NEED)
      end if
c
c**** Do GMC-QDPT ******************************************************
      call os_make_graphx
c
      nbuf  =100000
      ncibuf=5000000
c
      call VALFM(LOADFM)
      call GOTFM(NGOTMX)
      n01 = LOADFM + 1
      n02 = n01 + nci           ! lrf2or
      n03 = n02 + ncibuf        ! lrdwrk
c
      nremai = n01 + NGOTMX - n03
      nbuf=nremai
c
      n04 = n03 + nbuf          ! kidtab
      NEED = n04 - LOADFM - 1
      call GETFM(NEED)
c
      call os_make_ionized_dets
     *  (nbuf  ,d(n01),d(n02),d(n03))
      call RETFM(NEED)
c
c$$$      ncimax=max(ncim2,ncim1,nci00,ncip1,ncip2)
c$$$c
c$$$      call VALFM(LOADFM)
c$$$      n01 = LOADFM + 1
c$$$      n02 = n01 + ncibuf        ! lrdrea
c$$$      n03 = n02 + ncimax        ! lrdwri
c$$$      NEED = n03 - LOADFM - 1
c$$$      call GETFM(NEED)
c$$$c
c$$$      call os_make_ionized_dets_rewrite(ncimax,d(n01),d(n02))
c$$$      call RETFM(NEED)
c
c     Make graph for internal excitations
c
      call os_make_graphi
c
c     Setup for MC-QDPT
c
      nummx1=nelact*(nsoact-nelact+1)
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci*nstate                  ! eigvec
      n03 = n02 + nmoact*nmoact*2*(nstate+1)  ! den1
      n04 = n03 + nmo*2*(nstate+1)            ! eorb
      n05 = n04 + nci*(nstate+1)              ! edet
      n06 = n05 + nstate*(nstate+1)           ! eref
      n07 = n06 + nmo*nmo                     ! hcore
      n08 = n07 + nmo*lasact*lasact           ! geoin1
      n09 = n08 + nmo*lasact*lasact           ! geoin2
      n10 = n09 + 3*nummx1                    ! list
      n11 = n10 + nci                         ! lrf2or
      n12 = n11 + ndet                        ! lor2rf
      NEED = n12 - LOADFM - 1
      call GETFM(NEED)
c
      call os_setup_mcqdpt
     *  (nummx1,
     *   d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10),d(n11))
      call RETFM(NEED)
c
c     Write MOS (temp)
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nmo
      NEED = n02 - LOADFM - 1
      call GETFM(NEED)
c
      call os_sort_mcqdpt(d(n01))
      call RETFM(NEED)
c
c     GMC-QDPT run: Routine mcqdptx
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nci*nstate    ! ev
      n03 = n02 + nmo*2*(nstate+1) ! e
      n04 = n03 + nci*(nstate+1) ! edet
      n05 = n04 + nstate*(nstate+1) ! eref
      n06 = n05 + nmo*nmo       ! u
      n07 = n06 + nci           ! lrf2or
      n08 = n07 + ndet          ! lor2rf
      n09 = n08 + nmo           ! mos
      n10 = n09 + nstate*nstate*5 ! heff2
      n11 = n10 + nstate        ! wfovli
      n12 = n11 + nstate        ! wfovl0
      n13 = n12 + nmowgt*nstate ! wfovl1
      n14 = n13 + nmowgt*nmowgt*nstate ! wfovl2
c
      NEED = n14 - LOADFM - 1
      call GETFM(NEED)
c
      call os_mcqdptx
     *  (d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10),d(n11),d(n12),d(n13))
c    *  (ev    ,e     ,edet  ,eref  ,u     ,lrf2or,lor2rf,mos   ,heff2 ,
c    *   wfovli,wfovl0,wfovl1,wfovl2)
        call RETFM(NEED)
c
c**** Get energies *****************************************************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + nstate               ! eigval
      n03 = n02 + nstate*(nstate+1)/2  ! diahma
      n04 = n03 + nstate               ! diaval
      n05 = n04 + nstate*nstate        ! diavec
      n06 = n05 + 9*nstate             ! diawrk
      n07 = n06 + nstate*nstate*5      ! heff2
      n08 = n07 + nstate*nstate*2      ! heff
      n09 = n08 + nstate*2             ! excene
      n10 = n09 + 2*nci                ! lrfocc
      n11 = n10 + nci*nstate           ! eigvec
      n12 = n11 + nstate               ! eigtmp
      n13 = n12 + nstate               ! s2
      n14 = n13 + nci*(nstate+2)       ! s2work
      n15 = n14 + nstate               ! wfovli
      n16 = n15 + nstate               ! wfovl0
      n17 = n16 + nmowgt*nstate        ! wfovl1
      n18 = n17 + nmowgt**2*nstate     ! wfovl2
      n19 = n18 + nstate               ! wfoi
      n20 = n19 + nstate               ! wfo0
      n21 = n20 + nmowgt*nstate        ! wfo1
      NEED = n21 - LOADFM - 1
      call GETFM(NEED)
c
      call os_get_energies
     *  (d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10),d(n11),d(n12),d(n13))
c
      if(iwgt.ne.0) then
        call os_get_weights
     *    (d(n04),d(n13),d(n15),d(n16),d(n17),d(n18),d(n19),d(n20))
      end if
c
      call RETFM(NEED)
c
c**** Compute oscillator strength **************************************
      if(nstate.gt.1 .and. gsene(1).eq.ZERO) then
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nci*nstate                  ! eigvec
        n03 = n02 + nstate                      ! eigval
        n04 = n03 + nmoact*nmoact*3             ! dipint
        n05 = n04 + nmoact*nmoact*nstate        ! den1
        n06 = n05 + 3*nstate                    ! trndip
        n07 = n06 + nstate*2                    ! oscstr
        n08 = n07 + 3*nelact*(nsoact-nelact+1)  ! list
        n09 = n08 + nci                         ! lrf2or
        n10 = n09 + ndet                        ! lor2rf
        NEED = n10 - LOADFM - 1
        call GETFM(NEED)
        call os_calc_oscstr
     * (2     ,
     *  d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09))
c    * (norder,
c    *  eigvec,eigval,dipint,den1  ,trndip,oscstr,list  ,lrf2or,lor2rf)
        call RETFM(NEED)
      end if
c
      if(MASWRK .and. lpout.eq.1) call ut_report_time
c
c**** End **************************************************************
      end
      subroutine os_init_cc1(lrf2or,lor2rf)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 27, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
c
      dimension lrf2or(nci), lor2rf(ndet)
c
c     mstr0=nstr( 0)
c     mstr1=nstr(-1)
c
      call seqrew(lunref)       ! rewind lunref
      read(lunref) lrf2or
      call seqrew(luno2r)       ! rewind luno2r
      read(luno2r) lor2rf
      end
      subroutine os_init_data
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Set logical unit numbers and open files
c
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      logical svdskw
c
c**** Logical unit numbers *********************************************
      lpout =  0
c
      lunin =  5
      lunout=  6
      lunref= 70
      luno2r= 71
      lunroc= 72
      lunooc= 73
      luncc0= 74
      lunhma= 75
      luneig= 76
c             77 is used for luneig
      luneob= 78
      lunedt= 79
      lunerf= 80
      lunhcr= 81
      lungjk= 82
      lungai= 83
      lungeo= 84
      lunte1= 85
      lunte2= 86
      lunhef= 87
      lunmol= 88
      lunmos= 89
      lunwgt= 90
      lunrm2= 91
      lunrm1= 92
      lunr00= 93
      lunrp1= 94
      lunrp2= 95
      lunvef= 96
      lundin= 97
      lun2sz= 98
      lunccs= 99
c
c**** Open files for GAMESS ********************************************
      svdskw=DSKWRK
      DSKWRK=.true.
c
      call seqopn(lunref  ,'GMCREF','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(luno2r  ,'GMCO2R','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunroc  ,'GMCROC','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunooc  ,'GMCOOC','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(luncc0  ,'GMCCC0','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunhma  ,'GMCHMA','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(luneig  ,'GMCEI1','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(luneig+1,'GMCEI2','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(luneob  ,'GMCEOB','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunedt  ,'GMCEDT','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunerf  ,'GMCERF','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunhcr  ,'GMCHCR','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lungjk  ,'GMCGJK','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lungai  ,'GMCGAI','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lungeo  ,'GMCGEO','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunte1  ,'GMCTE1','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunte2  ,'GMCTE2','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunhef  ,'GMCHEF','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunmol  ,'GMCMOL','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunmos  ,'GMCMOS','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunwgt  ,'GMCWGT','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunrm2  ,'GMCRM2','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunrm1  ,'GMCRM1','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunr00  ,'GMCR00','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunrp1  ,'GMCRP1','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunrp2  ,'GMCRP2','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunvef  ,'GMCVEF','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lundin  ,'GMCDIN','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lun2sz  ,'GMC2SZ','UNKNOWN',.false.,'UNFORMATTED')
      call seqopn(lunccs  ,'GMCCCS','UNKNOWN',.false.,'UNFORMATTED')
c
      DSKWRK=svdskw
c
c**** end **************************************************************
      end
      subroutine os_int2det(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Find index of pattern IOCC(2) and store it into IDET
c
      implicit double precision (a-h,o-z)
*I32  parameter (INTBIT=32)
*I64  parameter (INTBIT=64)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      dimension iocc(2)
c
c     Clone function(s) for f77
c-f77 logical btest
c-f77 btest(i,j)=iand(1,ishft(i,-j))
c
      idet=1
      ne  =0
      do iorb=0,min(nsoact-1,INTBIT-1)
        if(btest(iocc(1),iorb)) then
          ne=ne+1
          idet=idet+marcwt(ne,iorb+1,meldif)
        end if
        if(mwt(ne,iorb+1,meldif).le.0) then
          idet=-1
          return
        end if
      end do
      do iorb=INTBIT,nsoact-1
        if(btest(iocc(2),iorb-INTBIT)) then
          ne=ne+1
          idet=idet+marcwt(ne,iorb+1,meldif)
        end if
        if(mwt(ne,iorb+1,meldif).le.0) then
          idet=-1
          return
        end if
      end do
      end
      subroutine os_int2occ(iocc,intexp)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (INTBIT=32)
*I64  parameter (INTBIT=64)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
c
      logical   iocc(nsoact)
      dimension intexp(2)
c
c     Clone function(s) for f77
c-f77 logical btest
c-f77 btest(i,j)=iand(1,ishft(i,-j))
c
      do i=1,min(nsoact,INTBIT)
        iocc(i)=btest(intexp(1),i-1 )
      end do
      do i=INTBIT+1,nsoact
        iocc(i)=btest(intexp(2),i-INTBIT-1)
      end do
      end
      subroutine os_lab_read(lun,lenlab,label)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      dimension label(lenlab)
      read(lun) label
      end
      subroutine os_lab_write(lun,lenlab,label)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      dimension label(lenlab)
      write(lun) label
      end
      subroutine os_labval_read(lun,lenlab,lenval,label,value)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      dimension label(lenlab),value(lenval)
      read(lun) label,value
      end
      subroutine os_labval_write(lun,lenlab,lenval,label,value)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      dimension label(lenlab),value(lenval)
      write(lun) label,value
      end
      subroutine os_make_cc0(lrf2or,lor2rf,icc0p,icc0m)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 23, 2007 by HN                 ===
c=======================================================================
c
c     <I|(i+)j|J>=<I|(i+)|K><K|j|J>
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrf2or(nci),lor2rf(ndet)
      dimension icc0p(3,nelact*(nsoact-nelact+1)),  ! Check
     *          icc0m(3,nelact*(nsoact-nelact+1))   !
      logical iphase,kphase
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(/1x,10(1h*)," Routine os_make_cc0 ",48(1h*))')
        call ut_init_time
      END IF
c
c**** Read info ********************************************************
      call seqrew(luncc0)       ! rewind luncc0
      call seqrew(lunref)       ! rewind lunref
      call seqrew(luno2r)       ! rewind luno2r
      read(lunref) lrf2or
      read(luno2r) lor2rf
c
c**** Make CCs for 1-electron operator *********************************
      do jref=1+me,nci,nproc    ! do jref=1,nci
        jdet=lrf2or(jref)
        call os_det2occ0(jdet,jocc,0)
        np=0
        nm=0
        kphase=.true.
        do j=1,nsoact
          if(jocc(j)) then
            jocc(j)=.false.
            iphase=kphase
            do i=1,nsoact
              if(.not.jocc(i)) then
c
                if(mospn(i).eq.mospn(j) .and. mosym(i).eq.mosym(j)) then
c
                jocc(i)=.true.
                call os_occ2det0(idet,jocc,0)
                if(idet.gt.0) then
                  if(lor2rf(idet).gt.0) then
                    if(iphase) then
                      np=np+1
                      icc0p(1,np)=j
                      icc0p(2,np)=i
                      icc0p(3,np)=lor2rf(idet)
                    else
                      nm=nm+1
                      icc0m(1,nm)=j
                      icc0m(2,nm)=i
                      icc0m(3,nm)=lor2rf(idet)
                    end if
                  end if
                end if
                jocc(i)=.false.
c
                end if
c
              else
                iphase=.not.iphase
              end if
            end do
            kphase=.not.kphase
            jocc(j)=.true.
          end if
        end do
        write(luncc0) np,nm
        call os_lab_write(luncc0,3*np,icc0p)
        call os_lab_write(luncc0,3*nm,icc0m)
c       write(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
      end do
c
c**** Make CCs for 2-electron operator *********************************
      do jdet=1+me,nstr0(-2),nproc ! do jdet=1,nstr0(-2)       ! |J>
        call os_det2occ0(jdet,jocc,-2)
        np=0
        nm=0
        kphase=.true.
        do j=1,nsoact
          if(jocc(j)) then ! if j|J> /= 0
            jocc(j)=.false.
            iphase=kphase
            do i=1,nsoact
              if(.not.jocc(i)) then ! if (i+)j|J> /=0
c
                if(mospn(i).eq.mospn(j)) then
c
                jocc(i)=.true.
                call os_occ2det0(idet,jocc,0) ! find |I>
                if(idet.gt.0) then
                  if(lor2rf(idet).gt.0) then
                    if(iphase) then
                      np=np+1
                      icc0p(1,np)=j
                      icc0p(2,np)=i
                      icc0p(3,np)=lor2rf(idet)
                    else
                      nm=nm+1
                      icc0m(1,nm)=j
                      icc0m(2,nm)=i
                      icc0m(3,nm)=lor2rf(idet)
                    end if
                  end if
                end if
                jocc(i)=.false.
c
                end if
c
              else
                iphase=.not.iphase
              end if
            end do
            kphase=.not.kphase
            jocc(j)=.true.
          end if
        end do
        if(np.gt.0 .or. nm.gt.0) then ! Write
          write(luncc0) np,nm
          call os_lab_write(luncc0,3*np,icc0p)
          call os_lab_write(luncc0,3*nm,icc0m)
c         write(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        end if
      end do
      write(luncc0) -1,-1
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_cc0_s2(lrf2or,lor2rf,icc0p,icc0m,i2sz)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 23, 2007 by HN                 ===
c=======================================================================
c
c     This code assumes that determinants are of abab...ab type
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrf2or(nci),lor2rf(ndet)
c     dimension icc0p(3,nelact*(nsoact-nelact+1))
      dimension icc0p(nelact), icc0m(nelact)
      logical iphase,kphase
      logical jocc(NSOMAX)
      dimension i2sz(nci)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(/1x,10(1h*)," Routine os_make_cc0_s2 ",45(1h*))')
        call ut_init_time
      END IF
c
c**** Read info ********************************************************
      call seqrew(lun2sz)       ! rewind lun2sz
      call seqrew(lunccs)       ! rewind lunccs
c
      call seqrew(lunref)       ! rewind lunref
      call seqrew(luno2r)       ! rewind luno2r
      read(lunref) lrf2or
      read(luno2r) lor2rf
c
c**** Make CCs for 1-electron operator *********************************
      do jref=1,nci
        jdet=lrf2or(jref)
        call os_det2occ0(jdet,jocc,0)
        i2sz(jref)=0
        do j=1,nsoact
          if(jocc(j)) then
            if(mospn(j).eq.1) then
              i2sz(jref)=i2sz(jref)+1
            else
              i2sz(jref)=i2sz(jref)-1
            end if
          end if
        end do
      end do
      write(lun2sz) i2sz
c
c**** Make CCs for 2-electron operator *********************************
      do jdet=1,nstr0(-2)       ! |J>
        call os_det2occ0(jdet,jocc,-2)
        np=0
        nm=0
        kphase=.true.
        do j=1,nsoact
          if(jocc(j)) then
            if(mospn(j).eq.1) then
              jocc(j)=.false.
              iphase=kphase
              do i=1,nsoact
                if(.not.jocc(i)) then
                  if(mospn(i).eq.2 .and. lso2mo(i).eq.lso2mo(j)) then
                    jocc(i)=.true.
                    call os_occ2det0(idet,jocc,0)
                    if(idet.gt.0) then
                      if(lor2rf(idet).gt.0) then
                        if(iphase) then
                          np=np+1
                          icc0p(np)=lor2rf(idet)
                        else
                          nm=nm+1
                          icc0m(nm)=lor2rf(idet)
                        end if
                      end if
                    end if
                    jocc(i)=.false.
                  end if
                else
                  iphase=.not.iphase
                end if
              end do
              jocc(j)=.true.
            end if
            kphase=.not.kphase
          end if
        end do
        if(np.gt.0 .or. nm.gt.0) then ! Write
          write(lunccs) np,nm
          call os_lab_write(lunccs,np,icc0p)
          call os_lab_write(lunccs,nm,icc0m)
        end if
      end do
      write(lunccs) -1,-1
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_cc1_v1
     *  (nummx1,numelm,jdetr,list,lrf2or,lor2rf)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 08, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
      dimension list(3,nummx1)
      dimension lrf2or(nci), lor2rf(ndet)
      logical   jocc(NSOMAX)
      logical   iphase,jphase
c
      jdeto=lrf2or(jdetr)
      call os_det2occ(jdeto,jocc,0)
c
      numelm=0
c
      iphase=.false.
c
c**** Loop head of q ***************************************************
      do lq=1,nsoact
        if(jocc(lq)) then
          jocc(lq)=.false.
          jphase=iphase
c
c**** Loop head of p ***************************************************
      do lp=1,nsoact
        if(.not.jocc(lp)) then
          if(mospn(lp).eq.mospn(lq) .and. mosym(lp).eq.mosym(lq)) then
            jocc(lp)=.true.
            call os_occ2det(ideto,jocc,0)
            if(ideto.gt.0) then
              idetr=lor2rf(ideto)
              if(idetr.ne.0) then
                numelm=numelm+1
c               if(numelm.gt.nummx1) stop 'numelm>nummx1'
                list(1,numelm)=lp
                list(2,numelm)=lq
                if(jphase) then
                  list(3,numelm)=-idetr
                else
                  list(3,numelm)= idetr
                end if
              end if
            end if
c
c**** Loop end of p ****************************************************
            jocc(lp)=.false.
          end if
        else
          jphase=.not.jphase
        end if
      end do
c
c**** Loop end of q ****************************************************
          jocc(lq)=.true.
          iphase=.not.iphase
        end if
      end do
c
c**** End **************************************************************
      end
      subroutine os_make_cc0_pq_oscstr(numelm,jdet,list,lor2rf)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
c
c     Make CC for 1-electron transtion operators
c
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
      dimension list(3,nelact*(nsoact-nelact+1)), lor2rf(ndet)
      logical iphase,kphase,jocc(NSOMAX)
c
c**** Make CCs *********************************************************
      call os_det2occ0(jdet,jocc,0)
      numelm=0
      kphase=.true.
      do j=1,nsoact
        if(jocc(j)) then
          jocc(j)=.false.
          iphase=kphase
          do i=1,nsoact
            if(.not.jocc(i)) then
c             if(mospn(i).eq.mospn(j) .and. mosym(i).eq.mosym(j)) then
              if(mospn(i).eq.mospn(j)                           ) then
                jocc(i)=.true.
                call os_occ2det0(idet,jocc,0)
                if(idet.gt.0) then
                  if(lor2rf(idet).gt.0) then
                    numelm=numelm+1
                    list(1,numelm)=i
                    list(2,numelm)=j
                    if(iphase) then
                      list(3,numelm)= lor2rf(idet)
                    else
                      list(3,numelm)=-lor2rf(idet)
                    end if
                  end if
                end if
                jocc(i)=.false.
              end if
            else
              iphase=.not.iphase
            end if
          end do
          kphase=.not.kphase
          jocc(j)=.true.
        end if
      end do
c
c**** End **************************************************************
      end
      subroutine os_make_cc_p(nump,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 11, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     nump=nvir
c         =nsoact-nelact+1
c
      dimension list(2,nump)
      dimension lor2rf(ndet)
c     dimension locc(NSOMAX),lvir(NSOMAX)
      dimension              lvir(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase
c
      call os_det2occx(jdeto,jocc,-1)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
c         locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
          lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do i=1,nvir
        lp=lvir(i)
        jocc(lp)=.true.
        iphase=phase(lp)
        isym=ieor(jdtsym,mosym(lp))
c       if(.not.knosym .and. isym.ne.istsym   -1) go to 100
        if(.not.knosym .and. isym.ne.istsym(1)-1
     *                 .and. isym.ne.istsym(2)-1
     *                 .and. isym.ne.istsym(3)-1) go to 100
        if(mospn(lp).eq.1) then
          ins=ns+1
        else
          ins=ns-1
        end if
        if(.not.knospn .and. ins.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
            numelm=numelm+1
            if(numelm.gt.nump) stop 'numelm>nump'
            list(1,numelm)=lp
            if(iphase) then
              list(2,numelm)=-idetr
            else
              list(2,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(lp)=.false.
      end do
      end
      subroutine os_make_cc_pq(numpq,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 06, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     numpq=nocc*(nvir+1)
c          =nelact*(nsoact-nelact+1)
c
      dimension list(3,numpq)
      dimension lor2rf(ndet)
      dimension locc(NSOMAX),lvir(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase,jphase
c
      call os_det2occx(jdeto,jocc,0)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
          locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
          lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do j=1,nocc
        lq=locc(j)
        lvir(nvir+1)=lq
        jocc(lq)=.false.
        jphase=phase(lq)
        jsym=ieor(jdtsym,mosym(lq))
        if(mospn(lq).eq.1) then
          jns=ns-1
        else
          jns=ns+1
        end if
      do i=1,nvir+1
        lp=lvir(i)
        jocc(lp)=.true.
        iphase=jphase.neqv.phase(lp)
        isym=ieor(jsym,mosym(lp))
c       if(.not.knosym .and. isym.ne.istsym   -1) go to 100
        if(.not.knosym .and. isym.ne.istsym(1)-1
     *                 .and. isym.ne.istsym(2)-1
     *                 .and. isym.ne.istsym(3)-1) go to 100
        if(mospn(lp).eq.1) then
          ins=jns+1
        else
          ins=jns-1
        end if
        if(.not.knospn .and. ins.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
c           lp<=lq
c           lq< lp -- (-1)
c
            if(lq.lt.lp) iphase=.not.iphase
c
            numelm=numelm+1
            if(numelm.gt.numpq) stop 'numelm>numpq'
            list(1,numelm)=lp
            list(2,numelm)=lq
            if(iphase) then
              list(3,numelm)=-idetr
            else
              list(3,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(lp)=.false.
      end do
        jocc(lq)=.true.
      end do
      end
      subroutine os_make_cc_pr(numpr,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 11, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     numpr=nvir*(nvir-1)/2
c          =(nsoact-nelact+2)*(nsoact-nelact+1)/2
c
      dimension list(3,numpr)
      dimension lor2rf(ndet)
c     dimension locc(NSOMAX),lvir(NSOMAX)
      dimension              lvir(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase,kphase
c
      call os_det2occx(jdeto,jocc,-2)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
c         locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
          lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do k=1,nvir
        lr=lvir(k)
        jocc(lr)=.true.
        kphase=phase(lr)
        ksym=ieor(jdtsym,mosym(lr))
        if(mospn(lr).eq.1) then
          kns=ns+1
        else
          kns=ns-1
        end if
      do i=1,k-1
        lp=lvir(i)
        jocc(lp)=.true.
        iphase=kphase.neqv.phase(lp)
        isym=ieor(ksym,mosym(lp))
c       if(.not.knosym .and. isym.ne.istsym   -1) go to 100
        if(.not.knosym .and. isym.ne.istsym(1)-1
     *                 .and. isym.ne.istsym(2)-1
     *                 .and. isym.ne.istsym(3)-1) go to 100
        if(mospn(lp).eq.1) then
          ins=kns+1
        else
          ins=kns-1
        end if
        if(.not.knospn .and. ins.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
c           lp<lr
c           lr>lp -- (-1)
c
            if(lr.lt.lp) iphase=.not.iphase
c
            numelm=numelm+1
            if(numelm.gt.numpr) stop 'numelm>numpr'
            list(1,numelm)=lp
            list(2,numelm)=lr
            if(iphase) then
              list(3,numelm)=-idetr
            else
              list(3,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(lp)=.false.
      end do
        jocc(lr)=.false.
      end do
      end
      subroutine os_make_cc_prs(numprs,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 07, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     numprs=nocc*(nvir+1)*nvir/2
c           =(nelact-1)*(nsoact-nelact+2)*(nsoact-nelact+1)/2
c
      dimension list(4,numprs)
      dimension lor2rf(ndet)
      dimension locc(NSOMAX),lvir(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase,kphase,lphase
c
      call os_det2occx(jdeto,jocc,-1)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
          locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
          lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do l=1,nocc
        ls=locc(l)
        lvir(nvir+1)=ls
        jocc(ls)=.false.
        lphase=phase(ls)
        lsym=ieor(jdtsym,mosym(ls))
        if(mospn(ls).eq.1) then
          lns=ns-1
        else
          lns=ns+1
        end if
      do k=1,nvir+1
        lr=lvir(k)
        jocc(lr)=.true.
        kphase=lphase.neqv.phase(lr)
        ksym=ieor(lsym,mosym(lr))
        if(mospn(lr).eq.1) then
          kns=lns+1
        else
          kns=lns-1
        end if
      do i=1,k-1
        lp=lvir(i)
        jocc(lp)=.true.
        iphase=kphase.neqv.phase(lp)
        isym=ieor(ksym,mosym(lp))
c       if(.not.knosym .and. isym.ne.istsym   -1) go to 100
        if(.not.knosym .and. isym.ne.istsym(1)-1
     *                 .and. isym.ne.istsym(2)-1
     *                 .and. isym.ne.istsym(3)-1) go to 100
        if(mospn(lp).eq.1) then
          ins=kns+1
        else
          ins=kns-1
        end if
        if(.not.knospn .and. ins.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
c           lp< lr & lr<=ls
c           lp<=ls & ls< lr -- (-1)
c           ls< lp & lp< lr
c           lr< lp & lp<=ls -- (-1)
c           lr<=ls & ls< lp
c           ls< lr & lr< lp -- (-1)
c
            if((lp.le.ls .and. ls.lt. lr) .or.
     *         (lr.lt. lp .and. lp.le.ls) .or.
     *         (ls.lt. lr .and. lr.lt. lp)     ) iphase=.not.iphase
c
            numelm=numelm+1
            if(numelm.gt.numprs) stop 'numelm>numprs'
            list(1,numelm)=lp
            list(2,numelm)=lr
            list(3,numelm)=ls
            if(iphase) then
              list(4,numelm)=-idetr
            else
              list(4,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(lp)=.false.
      end do
        jocc(lr)=.false.
      end do
        jocc(ls)=.true.
      end do
      end
      subroutine os_make_cc_q(numq,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 11, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     numq=nocc
c         =nelact+1
c
      dimension list(2,numq)
      dimension lor2rf(ndet)
c     dimension locc(NSOMAX),lvir(NSOMAX)
      dimension locc(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase,jphase
c
      call os_det2occx(jdeto,jocc,1)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
          locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
c         lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do j=1,nocc
        lq=locc(j)
c       lvir(nvir+1)=lq
        jocc(lq)=.false.
        jphase=phase(lq)
        jsym=ieor(jdtsym,mosym(lq))
c       if(.not.knosym .and. jsym.ne.istsym   -1) go to 100
        if(.not.knosym .and. jsym.ne.istsym(1)-1
     *                 .and. jsym.ne.istsym(2)-1
     *                 .and. jsym.ne.istsym(3)-1) go to 100
        if(mospn(lq).eq.1) then
          jns=ns-1
        else
          jns=ns+1
        end if
        if(.not.knospn .and. jns.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
            numelm=numelm+1
            if(numelm.gt.numq) stop 'numelm>numq'
            list(1,numelm)=lq
            if(jphase) then
              list(2,numelm)=-idetr
            else
              list(2,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(lq)=.true.
      end do
      end
      subroutine os_make_cc_rsq(numrsq,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 11, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     numrsq=nocc*(nocc-1)*(nvir+2)/2
c           =(nelact+1)*nelact*(nsoact-nelact+1)/2
c
      dimension list(4,numrsq)
      dimension lor2rf(ndet)
      dimension locc(NSOMAX),lvir(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase,jphase,kphase,lphase
c
      call os_det2occx(jdeto,jocc,1)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
          locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
          lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do j=1,nocc
        lq=locc(j)
        lvir(nvir+1)=lq
        jocc(lq)=.false.
        jphase=phase(lq)
        jsym=ieor(jdtsym,mosym(lq))
        if(mospn(lq).eq.1) then
          jns=ns-1
        else
          jns=ns+1
        end if
      do l=1,j-1
        ls=locc(l)
        lvir(nvir+2)=ls
        jocc(ls)=.false.
        lphase=jphase.neqv.phase(ls)
        lsym=ieor(jsym,mosym(ls))
        if(mospn(ls).eq.1) then
          lns=jns-1
        else
          lns=jns+1
        end if
      do k=1,nvir+2
        lr=lvir(k)
        jocc(lr)=.true.
        kphase=lphase.neqv.phase(lr)
        ksym=ieor(lsym,mosym(lr))
c       if(.not.knosym .and. ksym.ne.istsym   -1) go to 100
        if(.not.knosym .and. ksym.ne.istsym(1)-1
     *                 .and. ksym.ne.istsym(2)-1
     *                 .and. ksym.ne.istsym(3)-1) go to 100
        if(mospn(lr).eq.1) then
          kns=lns+1
        else
          kns=lns-1
        end if
        if(.not.knospn .and. kns.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
c           lr<=ls & ls< lq
c           ls< lr & lr<=lq -- (-1)
c           ls< lq & lq< lr
c           lr<=lq & lq< ls -- (-1)
c           lq< lr & lr<=ls
c           lq< ls & ls< lr -- (-1)
c
            if((ls.lt. lr .and. lr.le.lq) .or.
     *         (lr.le.lq .and. lq.lt. ls) .or.
     *         (lq.lt. ls .and. ls.lt. lr)     ) kphase=.not.kphase
c
            numelm=numelm+1
            if(numelm.gt.numrsq) stop 'numelm>numrsq'
            list(1,numelm)=lr
            list(2,numelm)=ls
            list(3,numelm)=lq
            if(kphase) then
              list(4,numelm)=-idetr
            else
              list(4,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(lr)=.false.
      end do
        jocc(ls)=.true.
      end do
        jocc(lq)=.true.
      end do
      end
      subroutine os_make_cc_sq(numsq,numelm,jdeto,list,lor2rf,jocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 11, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
c     numsq=nocc*(nocc-1)/2
c          =(nelact+2)*(nelact+1)/2
c
      dimension list(3,numsq)
      dimension lor2rf(ndet)
c     dimension locc(NSOMAX),lvir(NSOMAX)
      dimension locc(NSOMAX)
      logical   jocc(NSOMAX),phase(NSOMAX)  ! F: + phase, T: - phase
      logical   iphase,jphase,lphase
c
      call os_det2occx(jdeto,jocc,2)
c
      nocc  =0
      nvir  =0
      jdtsym=0
      ns    =0
      iphase=.false.
c
      do i=1,nsoact
        if(jocc(i)) then
          nocc=nocc+1
          locc(nocc)=i
          jdtsym=ieor(jdtsym,mosym(i))
          phase(i)=iphase
          iphase=.not.iphase
          if(mospn(i).eq.1) then
            ns=ns+1
          else
            ns=ns-1
          end if
        else
          nvir=nvir+1
c         lvir(nvir)=i
          phase(i)=iphase
        end if
      end do
c
      numelm=0
c
      do j=1,nocc
        lq=locc(j)
c       lvir(nvir+1)=lq
        jocc(lq)=.false.
        jphase=phase(lq)
        jsym=ieor(jdtsym,mosym(lq))
        if(mospn(lq).eq.1) then
          jns=ns-1
        else
          jns=ns+1
        end if
      do l=1,j-1
        ls=locc(l)
c       lvir(nvir+2)=ls
        jocc(ls)=.false.
        lphase=jphase.neqv.phase(ls)
        lsym=ieor(jsym,mosym(ls))
c       if(.not.knosym .and. lsym.ne.istsym   -1) go to 100
        if(.not.knosym .and. lsym.ne.istsym(1)-1
     *                 .and. lsym.ne.istsym(2)-1
     *                 .and. lsym.ne.istsym(3)-1) go to 100
        if(mospn(ls).eq.1) then
          lns=jns-1
        else
          lns=jns+1
        end if
        if(.not.knospn .and. lns.ne.nspin) go to 100
c
        call os_occ2det(ideto,jocc,0)
c
        if(ideto.gt.0) then
          idetr=lor2rf(ideto)
          if(idetr.ne.0) then
c
c           ls<lq
c           lq<ls -- (-1)
c
            if(lq.lt.ls) lphase=.not.lphase
c
            numelm=numelm+1
            if(numelm.gt.numsq) stop 'numelm>numsq'
            list(1,numelm)=ls
            list(2,numelm)=lq
            if(lphase) then
              list(3,numelm)=-idetr
            else
              list(3,numelm)= idetr
            end if
c
          end if
        end if
  100   continue
        jocc(ls)=.true.
      end do
        jocc(lq)=.true.
      end do
      end
      subroutine os_make_density
     * (eigvec,icc0p ,icc0m ,den1  ,den2  ,dm1tri,x     ,ix)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jan 29, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,TWO=2.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
c==== GAMESS commons ===================================================
c     parameter (NFT15=15)
      PARAMETER (MXAO=8192)
c     LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL PACK2E
      COMMON /CIFILS/ NFT11,NFT12,NFT13,NFT14,NFT15,NFT16,IDAF20,NEMEMX
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
c     COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
c     COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
c
      logical svdskw
c
      dimension eigvec(nci,nstate)
      dimension icc0p (3,nelact*(nsoact-nelact+1)),
     *          icc0m (3,nelact*(nsoact-nelact+1))
      dimension den1(nmoact,nmoact)
      dimension den2(nmoact,nmoact,nmoact,nmoact)
c
c     In the GMC-QDPT calculation, frozen core orbitals are omitted
c
      dimension dm1tri((nmofzc+nmodoc+nmoact  )*
     *                 (nmofzc+nmodoc+nmoact+1)/2)
      dimension x(NINTMX), ix(NINTMX)
c
c     dimension hint(nmoact,nmoact)
c     dimension gint(nmoact,nmoact,nmoact,nmoact)
c
C        next lines are for f90 +version = 2.8 under HP-UX,
c        allowing the program to run correctly at +O2 level.
      save ipack,jpack,kpack,lpack,npack,label
      save i,j,k,l,nx
c
      nmofda=nmofzc+nmodoc+nmoact
c
c     cutoff=1.0d-09
      cutoff=ZERO
c
c**** Read wavefunctions and energies **********************************
      call seqrew(luneig)       ! rewind luneig
      read(luneig) eigvec
c
c***********************************************************************
c**** Make density matrices ********************************************
c****                       ********************************************
c**** One-electron density matrix **************************************
      call vclr(den1,1,nmoact*nmoact)
c
      call seqrew(luncc0)       ! rewind luncc0
c
      do iref=1+me,nci,nproc             ! do iref=1,nci
        read(luncc0) np,nm
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
        do i=1,np
          lp  =lso2mo( icc0p(1,i) )
          lq  =lso2mo( icc0p(2,i) )
          jref=        icc0p(3,i)
c         if(mospn(icc0p(1,i)).ne.mospn(icc0p(2,i))) cycle
          do istate=1,nstate
            den1(lp,lq)=den1(lp,lq)
     *        +eigvec(iref,istate)*eigvec(jref,istate)*avecoe(istate)
          end do
        end do
        do i=1,nm
          lp  =lso2mo( icc0m(1,i) )
          lq  =lso2mo( icc0m(2,i) )
          jref=        icc0m(3,i)
c         if(mospn(icc0m(1,i)).ne.mospn(icc0m(2,i))) cycle
          do istate=1,nstate
            den1(lp,lq)=den1(lp,lq)
     *        -eigvec(iref,istate)*eigvec(jref,istate)*avecoe(istate)
          end do
        end do
      end do
c
c**** Two-electron density matrix **************************************
      call vclr(den2,1,nmoact**4)
  100 continue
        read(luncc0) np,nm
        if(np.lt.0) go to 102
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
        do i=1,np
          lq  =lso2mo( icc0p(1,i) )
          lp  =lso2mo( icc0p(2,i) )
          iref=        icc0p(3,i)
c         if(mospn(icc0p(1,i)).ne.mospn(icc0p(2,i))) cycle
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
c           if(mospn(icc0p(1,j)).ne.mospn(icc0p(2,j))) cycle
            do istate=1,nstate
              den2(lp,lq,lr,ls)=den2(lp,lq,lr,ls)
     *          +eigvec(iref,istate)*eigvec(jref,istate)*avecoe(istate)
c                                                        g=(real_val)/2
            end do
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
c           if(mospn(icc0m(1,j)).ne.mospn(icc0m(2,j))) cycle
            do istate=1,nstate
              den2(lp,lq,lr,ls)=den2(lp,lq,lr,ls)
     *          -eigvec(iref,istate)*eigvec(jref,istate)*avecoe(istate)
c                                                        g=(real_val)/2
            end do
          end do
        end do
        do i=1,nm
          lq  =lso2mo( icc0m(1,i) )
          lp  =lso2mo( icc0m(2,i) )
          iref=        icc0m(3,i)
c         if(mospn(icc0m(1,i)).ne.mospn(icc0m(2,i))) cycle
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
c           if(mospn(icc0p(1,j)).ne.mospn(icc0p(2,j))) cycle
            do istate=1,nstate
              den2(lp,lq,lr,ls)=den2(lp,lq,lr,ls)
     *          -eigvec(iref,istate)*eigvec(jref,istate)*avecoe(istate)
c                                                        g=(real_val)/2
            end do
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
c           if(mospn(icc0m(1,j)).ne.mospn(icc0m(2,j))) cycle
            do istate=1,nstate
              den2(lp,lq,lr,ls)=den2(lp,lq,lr,ls)
     *          +eigvec(iref,istate)*eigvec(jref,istate)*avecoe(istate)
c                                                        g=(real_val)/2
            end do
          end do
        end do
      go to 100
  102 continue
c
c     <Eij,kl> = <EijEkl> - delta_jk * <Eil>
c
      do l=1,nmoact
      do j=1,nmoact
      do i=1,nmoact
        den2(i,j,j,l)=den2(i,j,j,l)-den1(i,l)
      end do
      end do
      end do
c
c     Symmetrize den1 and den2
c    (Symmetrization for den1 is just for safety.)
c
      do i=1,nmoact
      do j=1,i
        s=(den1(i,j)+den1(j,i))*HALF
        den1(i,j)=s
        den1(j,i)=s
      end do
      end do
c
      do i=1,nmoact
      do j=1,i
      do k=1,i
        lmax=k
        if(k.eq.i) lmax=j
        do l=1,lmax
          s=(den2(i,j,k,l)+den2(i,j,l,k)+den2(j,i,k,l)+den2(j,i,l,k)
     *      +den2(k,l,i,j)+den2(l,k,i,j)+den2(k,l,j,i)+den2(l,k,j,i))
     *      *0.125d+00
          den2(i,j,k,l)=s
          den2(i,j,l,k)=s
          den2(j,i,k,l)=s
          den2(j,i,l,k)=s
          den2(k,l,i,j)=s
          den2(l,k,i,j)=s
          den2(k,l,j,i)=s
          den2(l,k,j,i)=s
        end do
      end do
      end do
      end do
c
      if(GOPARR) then
        call DDI_GSUMF(5000,den1,nmoact**2)
        call DDI_GSUMF(5000,den2,nmoact**4)
      end if
c
c***********************************************************************
c**** Write density matrices *******************************************
c****                        *******************************************
c
c     In writing den1 on the GAMESS file, nmofzc orbs. have to be added
c     because they have been omitted in GMC-SCF calculations.
c
      svdskw=DSKWRK
      DSKWRK=ordskw
c
      call SEQOPN(NFT15,'WORK15','UNKNOWN',.FALSE.,'UNFORMATTED')
c
c**** Two-particle density *********************************************
      call seqrew(NFT15)        ! rewind NFT15
      nx=0
      do i=1,nmoact
      do j=1,i
      do k=1,i
        lmax=k
        if(k.eq.i) lmax=j
      do l=1,lmax
        val=den2(i,j,k,l)
        if(abs(val).gt.cutoff) then
            nx=nx+1
            if(nx.gt.NINTMX) then
              call pwrit(NFT15,x,ix,NINTMX,NINTMX)
              nx=1
            end if
            npack=nx
            ipack=i
            jpack=j
            kpack=k
            lpack=l
            x(nx)=val
            if (LABSIZ .eq. 2) then
CI32
*I32          label1 = ishft( ipack, 16 ) + jpack
*I32          label2 = ishft( kpack, 16 ) + lpack
*I32          ix( 2*npack-1 ) = label1
*I32          ix( 2*npack   ) = label2
CI32
CI64
*I64          label = ishft( ipack, 48 ) + ishft( jpack, 32 ) +
*I64 *                ishft( kpack, 16 ) + lpack
*I64          ix(npack) = label
CI64
            else if (LABSIZ .eq. 1) then
CI32
*I32          label = ishft( ipack, 24 ) + ishft( jpack, 16 ) +
*I32 *                ishft( kpack,  8 ) + lpack
*I32          ix(npack) = label
CI32
CI64
*I64          if ( mod(npack,2) .eq. 0 ) then
*I64            label = ishft( ipack, 24 ) + ishft( jpack, 16 ) +
*I64 *                  ishft( kpack,  8 ) + lpack
*I64            ix( npack/2 ) = ix( npack/2 ) + label
*I64          else
*I64            label = ishft( ipack, 56 ) + ishft( jpack, 48 ) +
*I64 *                  ishft( kpack, 40 ) + ishft( lpack, 32 )
*I64            ix( (npack/2)+1 ) = label
*I64          end if
CI64
            end if
          end if
        end do
      end do
      end do
      end do
      nx=-nx
      call pwrit(NFT15,x,ix,nx,NINTMX)
c
c**** Write one-particle density matrix ********************************
c
c     write -dm1- with    core orbitals after -dm2- on file -nfto-
c     write -dm1- with    core orbitals to daf record 68
c
      call vclr(dm1tri,1,nmofda*(nmofda+1)/2)
      do i=1,nmofzc+nmodoc
        ij=i*(i+1)/2
        dm1tri(ij)=TWO
      end do
      do i=iniact,lasact
        ij=(i+nmofzc-1)*(i+nmofzc)/2+nmofzc+nmodoc
        do j=iniact,i
          ij=ij+1
          dm1tri(ij)=den1(i-nmodoc,j-nmodoc)
        end do
      end do
      call sqwrit(nft15,dm1tri,nmofda*(nmofda+1)/2)
      call seqrew(NFT15)        ! rewind NFT15
      ndsize=nmofda*(nmofda+1)/2
      call DAWRIT(IDAF,IODA,dm1tri,ndsize,68,0)
C
C     write -dm1- without core orbitals to daf record 320
C
      ij=0
      do i=1,nmoact
      do j=1,i
        ij=ij+1
        dm1tri(ij)=den1(i,j)
      end do
      end do
      ndsize=nmoact*(nmoact+1)/2
      call DAWRIT(IDAF,IODA,dm1tri,ndsize,320,0)
c
      ndsize=nbf
      call DAWRIT(IDAF,IODA,IRMON,nbf,262,1)
c
      DSKWRK=svdskw
c
c**** End **************************************************************
      end
      subroutine os_make_graph(mwtdum)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c     dimension istrng(NSOMAX)
      dimension mwtdum(0:nelact,0:nsoact)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout, '(/1x,10(1h*)," Routine os_make_graph ",46(1h*))')
        call ut_init_time
      END IF
c
c**** Clear matrices ***************************************************
c     call viclr(mwt   ,1,(NELAMX+1)*(NSOMAX+1)*4)
c     call viclr(marcwt,1,(NELAMX+1)*(NSOMAX+1)*4)
c     call viclr(nstr  ,1,5)
c
c**** Read graph *******************************************************
      if(reftyp.eq.'MRX     ') call os_make_graph_mrx  (mwtdum)
      if(reftyp.eq.'MRVX    ') call os_make_graph_mrx  (mwtdum)
      if(reftyp.eq.'MRXOS   ') call os_make_graph_mrxos(mwtdum)
      if(reftyp.eq.'ORMAS   ') call os_make_graph_ormas
      if(reftyp.eq.'RAS     ') call os_make_graph_ras  (mwtdum)
c
c**** Make graphs of ionized determinants ******************************
      do k=-1,-3,-1
        if(nelact+k.lt.0) go to 108
        do j=0,nsoact
        do i=0,nelact
          mwt(i,j,k)=mwt(i,j,k+1)
        end do
        end do
        do j=0,nsoact
          mwt(nelact+k+1,j,k)=0
        end do
        do i=0,nelact+k
          do j=i,nsoact-nelact-k+i
            if(mwt(i+1,j,k+1).ne.0) mwt(i,j,k)=mwt(i+1,j,k+1)
          end do
        end do
      end do
  108 continue
c
      do k=0,-3,-1
        if(nelact+k.lt.0) go to 110
        do j=0,nsoact
        do i=0,nelact
          if(mwt(i,j,k).ne.0) mwt(i,j,k)=1
        end do
        end do
c       if(k.eq.0) then
c         write(lunout,'(" *** Reference graph ***")')
c         do i=nelact,0,-1
c           write(lunout,'(1x,128i1)') (mwt(i,j,k),j=0,nsoact)
c         end do
c       end if
        do j=1,nsoact
c         do i=max(1,j-nsoact+nelact+k),min(nelact+k,j)
          do i=1,nelact
            if(mwt(i,j,k).ne.0) mwt(i,j,k)=mwt(i-1,j-1,k)+mwt(i,j-1,k)
          end do
        end do
      end do
  110 continue
c
      if(lpout.lt.0 .AND.MASWRK) then          ! debug output
        do i=0,-3,-1
          write(lunout,'(" *** Weight (",i2,") ***")') i
          call ut_imat_print_2
     *      (lunout,mwt(0,0,i),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end do
      end if
c
c**** Store dimensions of string spaces ********************************
      do i=0,-3,-1
        if(nelact+i.lt.0) go to 112
        nstr(i)=mwt(nelact+i,nsoact,i)
      end do
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** Dimension of ionized spaces ***")')
        do i=0,-3,-1
          write(lunout,'(i3," space: ",i10)') i,nstr(i)
        end do
      END IF
c
  112 continue
c
c**** Make arc-weights *************************************************
      do k=0,-3,-1
        if(nelact+k.lt.0) go to 114     ! ????? check check
        n=nstr(k)
        do i=1,nelact+k
          do j=1,nsoact
            if(mwt(i-1,j-1,k).ne.0) marcwt(i,j,k)=mwt(i,j-1,k)
          end do
        end do
        do i=nelact,1,-1
          do j=nsoact,1,-1
            if(mwt(i,j,k).eq.0 .or. mwt(i-1,j-1,k).eq.0)
     *        marcwt(i,j,k)=-n
          end do
          marcwt(i,0,k)=-n
        end do
        do j=0,nsoact
          if(mwt(0,j,k).eq.0) marcwt(0,j,k)=-n
        end do
        if(lpout.lt.0 .AND.MASWRK) then        ! debug output
          write(lunout,'(" *** Arc-weight (",i2,") ***")') k
c         call utwmai
c    *      (lunout,marcwt(0,0,k),NELAMX+1,nelact+1,nsoact+1,'    ')
          call ut_imat_print_2
     *      (lunout,marcwt(0,0,k),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end if
      end do
  114 continue
c
c**** Set ndet *********************************************************
      ndet=nstr(0)
c
c     mstr0,1,2,3 are unnecessary for the present version
c
c     mstr0=nstr(-0)
c     mstr1=nstr(-1)
c     mstr2=nstr(-2)
c     mstr3=nstr(-3)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_graph0
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 17, 2005 by HN                 ===
c=======================================================================
c
c     <I|EpqErs|J> = <I|Epq|K><K|Ers|J>
c
c     Make graph for <K|Ers|J>: This routine is for MC-CI
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_make_graph0 ",45(1h*))')
        call ut_init_time
      END IF
c
c     Temporary code:
c
c     The following error stop should be replaced later by some code
c     that allows nelact=0.
c
      if(nelact.lt.1) then         ! Error stop
        if(MASWRK)
     *    write(lunout,'(" *** Error stop in sub.os_make_graph0 ***"/
     *                   " # of electrons < 1."/
     *                   " nelact =",i10)') nelact
        call abrt
      end if
c
c**** Clear arrays *****************************************************
      call viclr(mwt0  ,1,(NELAMX+1)*(NSOMAX+1)*3)
      call viclr(marcw0,1,(NELAMX+1)*(NSOMAX+1)*3)
      call viclr(nstr0 ,1,3)
c
c**** Copy mwt *********************************************************
      do j=0,nsoact
      do i=0,nelact
        mwt0  (i,j, 0)=mwt   (i,j, 0) !  |J> graph
        marcw0(i,j, 0)=marcwt(i,j, 0)
        mwt0  (i,j,-1)=mwt   (i,j,-1) ! s|J> graph
        marcw0(i,j,-1)=marcwt(i,j,-1)
      end do
      end do
c
c**** Make graph for r+s|J> ********************************************
      do j=0,nsoact
      do i=0,nelact
        mwt0(i,j,-2)=mwt0(i,j,-1)
      end do
      end do
c
      do i=0,nelact-1
        j=nsoact-nelact+1+i
        mwt0(i,j,-2)=0
      end do
c
      do i=1,nelact
        do j=i,nsoact-nelact+i
          if(mwt0(i-1,j,-1).ne.0) mwt0(i,j,-2)=mwt0(i-1,j,-1)
        end do
      end do
c
      do j=0,nsoact
      do i=0,nelact
        if(mwt0(i,j,-2).ne.0) mwt0(i,j,-2)=1
      end do
      end do
c
      do j=1,nsoact
        do i=1,nelact
          if(mwt0(i,j,-2).ne.0)
     *      mwt0(i,j,-2)=mwt0(i-1,j-1,-2)+mwt0(i,j-1,-2)
        end do
      end do
c
      if(lpout.lt.0 .AND. MASWRK) then  ! Debug output
        do i=0,-2,-1
          write(lunout,'(" *** Weight (",i2,") ***")') i
c         call utwmai
c    *      (lunout,mwt0(0,0,i),NELAMX+1,nelact+1,nsoact+1,'    ')
          call ut_imat_print_2
     *      (lunout,mwt(0,0,i),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end do
      end if
c
c**** Store dimensions of string spaces ********************************
      nstr0( 0)=mwt0(nelact  ,nsoact, 0)
      nstr0(-1)=mwt0(nelact-1,nsoact,-1)
      nstr0(-2)=mwt0(nelact  ,nsoact,-2)
c
      if(MASWRK .and. kprint) then
        write(lunout,'(/" <<<Ionized spaces for Ref-CI:"/
     *    "      0: ",i12," /   -1-0: ",i12," /  0-1-0: ",i12)')
     *    nstr0(0),nstr0(-1),nstr0(-2)
      end if
c
c**** Make arc-weights *************************************************
      n=nstr0(-2)
c
      do i=1,nelact
        do j=1,nsoact
          if(mwt0(i-1,j-1,-2).ne.0) marcw0(i,j,-2)=mwt0(i,j-1,-2)
        end do
      end do
c
      do i=nelact,1,-1
        do j=nsoact,1,-1
          if(mwt0(i,j,-2).eq.0 .or. mwt0(i-1,j-1,-2).eq.0)
     *      marcw0(i,j,-2)=-n
        end do
        marcw0(i,0,-2)=-n
      end do
c
      do j=0,nsoact
        if(mwt0(0,j,-2).eq.0) marcw0(0,j,-2)=-n
      end do
c
      if(lpout.lt.0 .AND.MASWRK) then          ! debug output
        write(lunout,'(" *** Arc-weight (-2) ***")')
c       call utwmai
c    *    (lunout,marcw0(0,0,-2),NELAMX+1,nelact+1,nsoact+1,'    ')
        call ut_imat_print_2
     *    (lunout,marcw0(0,0,-2),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
      end if
c
c     ndet0=nstr0( 0)
c     ndet1=nstr0(-1)
c     ndet2=nstr0(-2)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_graph_mrx(mwtdum)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 09, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      character*8   char8
c     character*128 chr128
      dimension istrng(NSOMAX)
      dimension mwtdum(0:nelact,0:nsoact)
c
      call viclr(mwt   ,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(marcwt,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(nstr  ,1,5)
c
c**** Read parent determinants and make graph **************************
      if(MASWRK) then
        call seqrew(lunin)      ! rewind lunin
  100   continue
C-MWS     read(lunin,*,err=102,end=102) char8
C-MWS   if(char8.ne.'$PDET   ' .and. char8.ne.'$pdet   ' .and.
C-MWS*     char8.ne.'$GDS    ' .and. char8.ne.'$gds    ' .and.
C-MWS*     char8.ne.'$GCS    ' .and. char8.ne.'$gcs    ') go to 100
          read(lunin,fmt='(a8)',err=102,end=102) char8
        if(char8.ne.' $PDET  ' .and. char8.ne.' $pdet  ' .and.
     *     char8.ne.' $GDS   ' .and. char8.ne.' $gds   ' .and.
     *     char8.ne.' $GCS   ' .and. char8.ne.' $gcs   ') go to 100
c====   read(lunin,*) npdet,nexcit,istsym,nspin,mult
c
c       istsym=istsym-1
        do ipdet=1,npdet
c         read(lunin,'(128i1)') (istrng(i),i=1,nsoact)
cc        read(lunin,*) chr128
cc        read(chr128,'(128i1)') (istrng(i),i=1,nsoact)
          call os_read_string(istrng)
          call viclr(mwtdum,1,(nelact+1)*(nsoact+1))
c
          i=0
          mwtdum(0,0)=1
          do j=1,nsoact
            if(istrng(j).ne.0) then
              i=i+1
              mwtdum(i,j)=1
            else
              mwtdum(i,j)=1
            end if
          end do
          do j=0,nsoact
          do i=0,nelact
            if(mwtdum(i,j).ne.0) then
              do ii=max(i-nexcit,j-nsoact+nelact,0     ),
     *              min(i+nexcit,j              ,nelact)
                mwt(ii,j,0)=1
              end do
            end if
          end do
          end do
        end do
c
        do j=0,nsoact
        do i=0,nsoact
          if(mwt(i,j,0).gt.0) mwt(i,j,0)=1
        end do
        end do
c
  102   continue
      end if
c
c**** Read more determinants *******************************************
      if(MASWRK) then
c
        call seqrew(lunin)      ! rewind lunin
  104   continue
C-MWS     read(lunin,*,err=106,end=106) char8
C-MWS   if(char8.ne.'$ADDDET ' .and. char8.ne.'$adddet ') go to 104
          read(lunin,fmt='(a8)',err=106,end=106) char8
        if(char8.ne.' $ADDDET' .and. char8.ne.' $adddet') go to 104
c
        read(lunin,*) naddet
        do iaddet=1,naddet
c         read(lunin,'(128i1)') (istrng(i),i=1,nsoact)
cc        read(lunin,*) chr128
cc        read(chr128,'(128i1)') (istrng(i),i=1,nsoact)
          call os_read_string(istrng)
          call viclr(mwtdum,1,(nelact+1)*(nsoact+1))
          mwtdum(0,0)=1
          n=0
          do j=1,nsoact
            if(istrng(j).ne.0) then
              n=n+1
              mwtdum(n,j)=1
            else
              mwtdum(n,j)=1
            end if
          end do
          if(n.ne.nelact) then    ! Error stop
            if(MASWRK)
     *        write(lunout,
     *        '(" *** Error stop in sub.os_make_graph_mrx ***"/
     *          " # of electrons /= nelact in $adddet"/
     *          " n =",i10,"  nelact =",i10)') n,nelact
            call abrt
          end if
          do j=0,nsoact
            do i=0,nelact
              mwt(i,j,0)=mwt(i,j,0)+mwtdum(i,j)
            end do
          end do
        end do
c
        do j=0,nsoact
        do i=0,nsoact
          if(mwt(i,j,0).gt.0) mwt(i,j,0)=1
        end do
        end do
c
c       write(lunout,'(" *** Input graph ***")')
c       call utwmai(lunout,mwt(0,0,0),NELAMX+1,nelact+1,nsoact+1,'    ')
c       call ut_imat_print_2
c    *    (lunout,mwt(0,0,0),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
c
  106   continue
c
      end if
c
      if(GOPARR)
     *  call DDI_BCAST(5000,'I',mwt(0,0,0),(NELAMX+1)*(NSOMAX+1),MASTER)
c
c 108 continue
c
      end
      subroutine os_make_graph_mrxos(mwtdum)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 04, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      character*8   char8
c     character*128 chr128
      dimension istrng(NSOMAX)
      dimension mwtdum(0:nelact,0:nsoact)
c
      dimension moccsp(NSPCMX)
c
      call viclr(mwt   ,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(marcwt,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(nstr  ,1,5)
c
c**** Read parent determinants and make graph **************************
      if(MASWRK) then
        call seqrew(lunin)      ! rewind lunin
  100   continue
C-MWS     read(lunin,*,err=102,end=102) char8
C-MWS   if(char8.ne.'$PDET   ' .and. char8.ne.'$pdet   ' .and.
C-MWS*     char8.ne.'$GDS    ' .and. char8.ne.'$gds    ' .and.
C-MWS*     char8.ne.'$GCS    ' .and. char8.ne.'$gcs    ') go to 100
          read(lunin,fmt='(a8)',err=102,end=102) char8
        if(char8.ne.' $PDET  ' .and. char8.ne.' $pdet  ' .and.
     *     char8.ne.' $GDS   ' .and. char8.ne.' $gds   ' .and.
     *     char8.ne.' $GCS   ' .and. char8.ne.' $gcs   ') go to 100
c
        do ipdet=1,npdet
          call os_read_string(istrng)
          call viclr(mwtdum,1,(nelact+1)*(nsoact+1))
          call viclr(moccsp,1,nspace)
c
          i=0
          mwtdum(0,0)=1
          do j=1,nsoact
            if(istrng(j).ne.0) then
              i=i+1
              mwtdum(i,j)=1
            else
              mwtdum(i,j)=1
            end if
          end do
c
          m=0
          do ispace=1,nspace
            do j=m+1,m+morb(ispace)
              if(istrng(j).ne.0) moccsp(ispace)=moccsp(ispace)+1
            end do
            m=m+morb(ispace)
          end do
c
          mwt(0,0,0)=1
          m=0
          n=0
          do ispace=1,nspace
            do j=m,m+morb  (ispace)
            do i=n,n+moccsp(ispace)
              if(mwtdum(i,j).ne.0) then
                do ii=max(i-mxhole(ispace)                 ,
     *                    j-m-morb(ispace)+n+moccsp(ispace),
     *                    n                                ),
     *                min(i+mxpart(ispace),
     *                    j-m             +n               ,
     *                    n+moccsp(ispace)                 )
                  mwt(ii,j,0)=1
                end do
              end if
            end do
            end do
            m=m+morb  (ispace)
            n=n+moccsp(ispace)
          end do
c
c         do j=0,nsoact
c         do i=0,nelact
c           if(mwtdum(i,j).ne.0) then
c             do ii=max(i-nexcit,j-nsoact+nelact,0     ),
c    *              min(i+nexcit,j              ,nelact)
c               mwt(ii,j,0)=1
c             end do
c           end if
c         end do
c         end do
        end do
c
        do j=0,nsoact
        do i=0,nsoact
          if(mwt(i,j,0).gt.0) mwt(i,j,0)=1
        end do
        end do
c
  102   continue
      end if
c
c**** Read more determinants *******************************************
      if(MASWRK) then
c
        call seqrew(lunin)      ! rewind lunin
  104   continue
C-MWS     read(lunin,*,err=106,end=106) char8
C-MWS   if(char8.ne.'$ADDDET ' .and. char8.ne.'$adddet ') go to 104
          read(lunin,fmt='(a8)',err=106,end=106) char8
        if(char8.ne.' $ADDDET' .and. char8.ne.' $adddet') go to 104
c
        read(lunin,*) naddet
        do iaddet=1,naddet
          call os_read_string(istrng)
          call viclr(mwtdum,1,(nelact+1)*(nsoact+1))
          mwtdum(0,0)=1
          n=0
          do j=1,nsoact
            if(istrng(j).ne.0) then
              n=n+1
              mwtdum(n,j)=1
            else
              mwtdum(n,j)=1
            end if
          end do
          if(n.ne.nelact) then    ! Error stop
            if(MASWRK)
     *        write(lunout,
     *        '(" *** Error stop in sub.os_make_graph_mrvx ***"/
     *          " # of electrons /= nelact in $adddet"/
     *          " n =",i10,"  nelact =",i10)') n,nelact
            call abrt
          end if
          do j=0,nsoact
            do i=0,nelact
              mwt(i,j,0)=mwt(i,j,0)+mwtdum(i,j)
            end do
          end do
        end do
c
        do j=0,nsoact
        do i=0,nsoact
          if(mwt(i,j,0).gt.0) mwt(i,j,0)=1
        end do
        end do
c
c       write(lunout,'(" *** Input graph ***")')
c       call utwmai(lunout,mwt(0,0,0),NELAMX+1,nelact+1,nsoact+1,'    ')
c       call ut_imat_print_2
c    *    (lunout,mwt(0,0,0),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
c
  106   continue
c
      end if
c
      if(GOPARR)
     *  call DDI_BCAST(5000,'I',mwt(0,0,0),(NELAMX+1)*(NSOMAX+1),MASTER)
c
c 108 continue
c
      end
      subroutine os_make_graph_ormas
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 09, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      dimension minspc(0:NSPCMX),maxspc(0:NSPCMX)
c     dimension mine(nspcmx),maxe(nspcmx)
c
      call viclr(mwt   ,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(marcwt,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(nstr  ,1,5)
c
      minspc(0)=0
      maxspc(0)=0
      do ispace=1,nspace
        m1=0
        n1=0
        do jspace=1,ispace
          m1=m1+mine(jspace)
          n1=n1+maxe(jspace)
        end do
        m2=0
        n2=0
        do jspace=ispace+1,nspace
          m2=m2+mine(jspace)
          n2=n2+maxe(jspace)
        end do
        minspc(ispace)=max(m1,nelact-n2)
        maxspc(ispace)=min(n1,nelact-m2)
      end do
c
      mspace=0
      do ispace=1,nspace
        do m=minspc(ispace-1),maxspc(ispace-1)
        do n=minspc(ispace  ),maxspc(ispace  )
          do i=m,n
            do j=mspace+i-m,mspace+i-m+morb(ispace)-(n-m)
              mwt(i,j,0)=1
            end do
          end do
        end do
        end do
        mspace=mspace+morb(ispace)
      end do
      end
      subroutine os_make_graph_ras(mwtdum)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 01, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      dimension mwtdum(0:nelact,0:nsoact)
c
      call viclr(mwt   ,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(marcwt,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(nstr  ,1,5)
c
c**** Make RAS *********************************************************
      call viclr(mwtdum,1,(nelact+1)*(nsoact+1)  )
c
      mras1=morb(1)
      mras2=morb(2)
      mras3=morb(3)
      do j=0,mras1
        mwtdum(j,j)=1
      end do
      do i=mras1,nelact
        do j=i,i+mras2-(nelact-mras1)
          mwtdum(i,j)=1
        end do
      end do
      do j=mras1+mras2,mras1+mras2+mras3
        mwtdum(nelact,j)=1
      end do
c
      do j=0,nsoact
      do i=0,nelact
        if(mwtdum(i,j).ne.0) then
          do ii=max(i-nexcit,j-nsoact+nelact,0     ),
     *          min(i+nexcit,j              ,nelact)
            mwt(ii,j,0)=1
          end do
        end if
      end do
      end do
c
      do j=0,nsoact
      do i=0,nsoact
        if(mwt(i,j,0).gt.0) mwt(i,j,0)=1
      end do
      end do
c
      end
      subroutine os_make_graphi
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     <I|EpqErs|J> = <I|Epq|K><K|Ers|J>
c
c     Make graph for SD-space {|I>} relative to |J>
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_make_graphi ",45(1h*))')
        call ut_init_time
      END IF
c
c     Temporary code:
c
c     The following error stop should be replaced later by some code
c     that allows nelact=0.
c
      if(nelact.lt.1) then         ! Error stop
        if(MASWRK)
     *    write(lunout,'(" *** Error stop in sub.os_make_graphi ***"/
     *                   " # of electrons < 1."/
     *                   " nelact =",i10)') nelact
        call abrt
      end if
c
c**** Clear arrays *****************************************************
      call viclr(mwti  ,1,(NELAMX+1)*(NSOMAX+1)*5)
      call viclr(marcwi,1,(NELAMX+1)*(NSOMAX+1)*5)
      call viclr(nstri ,1,5)
c
c**** Copy mwt *********************************************************
      do j=0,nsoact
      do i=0,nelact
        mwti  (i,j, 0)=mwt   (i,j, 0) !  |J> graph
        marcwi(i,j, 0)=marcwt(i,j, 0)
        mwti  (i,j,-1)=mwt   (i,j,-1) ! s|J> graph
        marcwi(i,j,-1)=marcwt(i,j,-1)
      end do
      end do
c
c**** Make graph of r+s|J> *********************************************
      do j=0,nsoact
      do i=0,nelact
        mwti(i,j,-2)=mwti(i,j,-1)
      end do
      end do
c
      do i=0,nelact-1
        j=nsoact-nelact+1+i
        mwti(i,j,-2)=0
      end do
c
      do i=1,nelact
        do j=i,nsoact-nelact+i
          if(mwti(i-1,j,-1).ne.0) mwti(i,j,-2)=mwti(i-1,j,-1)
        end do
      end do
c
      do j=0,nsoact
      do i=0,nsoact
        if(mwti(i,j,-2).ne.0) mwti(i,j,-2)=1
      end do
      end do
c
      do j=1,nsoact
        do i=1,nelact
          if(mwti(i,j,-2).ne.0)
     *      mwti(i,j,-2)=mwti(i-1,j-1,-2)+mwti(i,j-1,-2)
        end do
      end do
c
c**** Make graph for qr+s|J> *******************************************
      do j=0,nsoact
        do i=0,nelact
          mwti(i,j,-3)=mwti(i,j,-2)
        end do
        mwti(nelact,j,-3)=0
      end do
c
      do i=0,nelact-1
        do j=i,nsoact-nelact+1+i
          if(mwti(i+1,j,-2).ne.0) mwti(i,j,-3)=mwti(i+1,j,-2)
        end do
      end do
c
      do j=0,nsoact
      do i=0,nelact
        if(mwti(i,j,-3).ne.0) mwti(i,j,-3)=1
      end do
      end do
c
      do j=1,nsoact
        do i=1,nelact
          if(mwti(i,j,-3).ne.0)
     *      mwti(i,j,-3)=mwti(i-1,j-1,-3)+mwti(i,j-1,-3)
        end do
      end do
c
c**** Make graph of p+qr+s|J> ******************************************
      do j=0,nsoact
      do i=0,nelact
        mwti(i,j,-4)=mwti(i,j,-3)
      end do
      end do
c
      do i=0,nelact-1
        j=nsoact-nelact+1+i
        mwti(i,j,-4)=0
      end do
c
      do i=1,nelact
        do j=i,nsoact-nelact+i
          if(mwti(i-1,j,-3).ne.0) mwti(i,j,-4)=mwti(i-1,j,-3)
        end do
      end do
c
      do j=0,nsoact
      do i=0,nelact
        if(mwti(i,j,-4).ne.0) mwti(i,j,-4)=1
      end do
      end do
c
      do j=1,nsoact
        do i=1,nelact
          if(mwti(i,j,-4).ne.0)
     *      mwti(i,j,-4)=mwti(i-1,j-1,-4)+mwti(i,j-1,-4)
        end do
      end do
c
      if(lpout.lt.0 .AND.MASWRK) then          ! Debug output
        do i=0,-4,-1
          write(lunout,'(" *** Weight (",i2,") ***")') i
c         call utwmai
c    *      (lunout,mwti(0,0,i),NELAMX+1,nelact+1,nsoact+1,'    ')
          call ut_imat_print_2
     *      (lunout,mwti(0,0,i),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end do
      end if
c
c**** Store dimensions of string spaces ********************************
      nstri( 0)=mwti(nelact  ,nsoact, 0)
      nstri(-1)=mwti(nelact-1,nsoact,-1)
      nstri(-2)=mwti(nelact  ,nsoact,-2)
      nstri(-3)=mwti(nelact-1,nsoact,-3)
      nstri(-4)=mwti(nelact  ,nsoact,-4)
c
      if(MASWRK) then
        write(lunout,'(/" <<<Ionized spaces for internal:"/
     *    "         0: ",i12," /      -1-0: ",i12," /     0-1-0: ",i12/
     *    "  -1-0-1-0: ",i12," / 0-1-0-1-0: ",i12)')
     *    nstri(0),nstri(-1),nstri(-2),nstri(-3),nstri(-4)
      END IF
c
c**** Make arc-weights *************************************************
      do k=-2,-4,-1
        n=nstri(k)
c       do i=1,nelact+K (K=0 for k=-2 and -4, K=-1 for k=-3), but the
c                        next is OK because mwti(i,j-1,nelact)=0 for
c                        K=-1.)
        do i=1,nelact
          do j=1,nsoact
            if(mwti(i-1,j-1,k).ne.0) marcwi(i,j,k)=mwti(i,j-1,k)
          end do
        end do
        do i=nelact,1,-1
          do j=nsoact,1,-1
            if(mwti(i,j,k).eq.0 .or. mwti(i-1,j-1,k).eq.0)
     *        marcwi(i,j,k)=-n
          end do
          marcwi(i,0,k)=-n
        end do
        do j=0,nsoact
          if(mwti(0,j,k).eq.0) marcwi(0,j,k)=-n
        end do
        if(lpout.lt.0 .AND.MASWRK) then        ! debug output
          write(lunout,'(" *** Arc-weight (",i2,") ***")') k
c         call utwmai
c    *      (lunout,marcwi(0,0,k),NELAMX+1,nelact+1,nsoact+1,'    ')
          call ut_imat_print_2
     *      (lunout,marcwi(0,0,k),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end if
      end do
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_graphx
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jul 21, 2006 by HN                 ===
c=======================================================================
c
c     Make graph for <K|p+r+sq|J>
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_make_graphx ",45(1h*))')
        call ut_init_time
      END IF
c
c     Temporary code:
c
c     The following error stop should be replaced later by some code
c     that allows nelact=0.
c
      if(nelact.lt.1) then         ! Error stop
        if(MASWRK)
     *    write(lunout,'(" *** Error stop in sub.os_make_graphx ***"/
     *                   " # of electrons < 1."/
     *                   " nelact =",i10)') nelact
        call abrt
      end if
c
c**** Clear arrays *****************************************************
      call viclr(mwtx  ,1,(NELAMX+3)*(NSOMAX+1)*5)
      call viclr(marcwx,1,(NELAMX+3)*(NSOMAX+1)*5)
      call viclr(nstrx ,1,5)
c
c**** Copy p+q|J> and sq|J> from mwt0 and mwt, respectively  ***********
      do j=0,nsoact
      do i=0,nelact
        mwtx(i,j,0)=mwt0(i,j,-2)
      end do
      end do
c
      do j=0,nsoact
      do i=0,nelact-2
        mwtx(i,j,-2)=mwt(i,j,-2)
      end do
      end do
c
c**** Make qr+s|J> from mwt0 *******************************************
      do j=0,nsoact
      do i=0,nelact
        mwtx(i,j,-1)=mwt0(i,j,-2)  ! Copy from mwt0
      end do
      end do
c
      do j=0,nsoact
        mwtx(nelact,j,-1)=0
      end do
c
      do i=0,nelact-1
        do j=i,nsoact-nelact+1+i
          if(mwt0(i+1,j,-2).ne.0) mwtx(i,j,-1)=mwt0(i+1,j,-2)
        end do
      end do
c
c**** Make r+|J> *******************************************************
      do j=0,nsoact
      do i=0,nelact
        mwtx(i,j,1)=mwtx(i,j,0)
      end do
      end do
c
      do i=0,nelact
        j=nsoact-nelact+i
        mwtx(i,j,1)=0
      end do
c
      do i=1,nelact+1
        do j=i,nsoact-nelact-1+i
          if(mwtx(i-1,j,0).ne.0) mwtx(i,j,1)=mwtx(i-1,j,0)
        end do
      end do
c
c**** Make p+r+|J> *****************************************************
      do j=0,nsoact
      do i=0,nelact+1
        mwtx(i,j,2)=mwtx(i,j,1)
      end do
      end do
c
      do i=0,nelact+1
        j=nsoact-nelact-1+i
        mwtx(i,j,2)=0
      end do
c
      do i=1,nelact+2
        do j=i,nsoact-nelact-2+i
          if(mwtx(i-1,j,1).ne.0) mwtx(i,j,2)=mwtx(i-1,j,1)
        end do
      end do
c
c**** Make p+r+s|J> from mwt0 ******************************************
      do j=0,nsoact
        mwtx(nelact+1,j,1)=0  ! Clear i=nelact+1 part
      end do
c
      do j=0,nsoact
      do i=0,nelact
        mwtx(i,j,1)=mwt0(i,j,-2)  ! Copy from mwt0
      end do
      end do
c
      do i=0,nelact
        j=nsoact-nelact+i
        mwtx(i,j,1)=0
      end do
c
      do i=1,nelact+1
        do j=i,nsoact-nelact-1+i
          if(mwt0(i-1,j,-2).ne.0) mwtx(i,j,1)=mwt0(i-1,j,-2)
        end do
      end do
c
      do k=-2,2
        do j=0,nsoact
        do i=0,nelact+k
          if(mwtx(i,j,k).ne.0) mwtx(i,j,k)=1
        end do
        end do
c
        do j=1,nsoact
        do i=1,nelact+k
          if(mwtx(i,j,k).ne.0)
     *      mwtx(i,j,k)=mwtx(i-1,j-1,k)+mwtx(i,j-1,k)
        end do
        end do
      end do
c
      if(lpout.lt.0 .AND.MASWRK) then  ! Debug output
        do k=-2,2
          write(lunout,'(" *** Weight (",i2,") ***")') k
          call ut_imat_print_2
     *      (lunout,mwt(0,0,k),' ',NELAMX+3,0,nelact+k,0,nsoact,0,0)
        end do
      end if
c
c**** Store dimensions of string spaces ********************************
      nstrx(-2)=mwtx(nelact-2,nsoact,-2)
      nstrx(-1)=mwtx(nelact-1,nsoact,-1)
      nstrx( 0)=mwtx(nelact  ,nsoact, 0)
      nstrx( 1)=mwtx(nelact+1,nsoact, 1)
      nstrx( 2)=mwtx(nelact+2,nsoact, 2)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** Dimension of ionized spaces ***")')
        write(lunout,'("   p+q space: ",i10)')
     *    nstrx( 0)
        write(lunout,'("  qr+s space: ",i10,"  /    sq space: ",i10)')
     *    nstrx(-1),nstrx(-2)
        write(lunout,'(" p+r+s space: ",i10,"  /  p+r+ space: ",i10)')
     *    nstrx( 1),nstrx( 2)
      END IF
c
c**** Make arc-weights *************************************************
c
c     Copy p+q|J> and sq|J> arc-weights from marcw0 and marcwt, rspctvly
c
c     do j=0,nsoact
c     do i=0,nelact
c       marcwx(i,j,0)=marcw0(i,j,-2)
c     end do
c     end do
c
c     do j=0,nsoact
c     do i=0,nelact-2
c       marcwx(i,j,-2)=marcwt(i,j,-2)
c     end do
c     end do
c
c     Make arc-weights
c
      do k=-2,2
c                          if(k.eq.-2 .or. k.eq.0) cycle
        n=nstrx(k)
        do i=1,nelact+k
          do j=1,nsoact
            if(mwtx(i-1,j-1,k).ne.0) marcwx(i,j,k)=mwtx(i,j-1,k)
          end do
        end do
        do i=nelact+k,1,-1
          do j=nsoact,1,-1
            if(mwtx(i,j,k).eq.0 .or. mwtx(i-1,j-1,k).eq.0)
     *        marcwx(i,j,k)=-n
          end do
          marcwx(i,0,k)=-n
        end do
c
        do j=0,nsoact
          if(mwtx(0,j,k).eq.0) marcwx(0,j,k)=-n
        end do
c
        if(lpout.lt.0 .AND.MASWRK) then        ! debug output
          write(lunout,'(" *** Arc-weight (",i2,") ***")') k
          call ut_imat_print_2
     *      (lunout,marcwx(0,0,k),' ',NELAMX+3,0,nelact+k,0,nsoact,0,0)
        end if
c
      end do
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_hamiltonian
     * (kmcscf,hint  ,gint  ,hmat  ,icc0p ,icc0m ,hcore ,gjkint,geoin1,
     *  geoin2)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 24, 2005 by HN                 ===
c=======================================================================
c
c     Make reference CI Hamiltonian
c
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension hint(nmoact,nmoact), gint(nmoact,nmoact,nmoact,nmoact)
      dimension hmat(nci,nci)
      dimension icc0p(3,nelact*(nsoact-nelact+1))
      dimension icc0m(3,nelact*(nsoact-nelact+1))
      dimension hcore(nmo,nmo), gjkint(lasdoc,lasdoc)
      dimension geoin1(nmo,lasact,lasact), geoin2(nmo,lasact,lasact)
      logical   kmcscf
c
      if(.not.kmcscf .AND.MASWRK .and. lpout.eq.1) then
        write(lunout, '(/1x,10(1h*)," Routine os_make_hamiltonian ",
     *    40(1h*))')
        call ut_init_time
      end if
c
c**** Read one- and two-electron integrals *****************************
      if(kmcscf) then
        call os_read_int_mcscf(hint,gint,ecore)
      else
        call os_read_int(hint,gint,ecore,hcore,gjkint,geoin1,geoin2)
      end if
c
c**** Make Hamiltonian *************************************************
      call vclr(hmat,1,nci*nci)
c
      call seqrew(luncc0)       ! rewind luncc0
c
c     One-electron terms
c
      do iref=1+me,nci,nproc    ! do iref=1,nci
        read(luncc0) np,nm
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        do i=1,np
          lp  =lso2mo( icc0p(1,i) )
          lq  =lso2mo( icc0p(2,i) )
          jref=        icc0p(3,i)
          hmat(iref,jref)=hmat(iref,jref)+hint(lp,lq)
        end do
        do i=1,nm
          lp  =lso2mo( icc0m(1,i) )
          lq  =lso2mo( icc0m(2,i) )
          jref=        icc0m(3,i)
          hmat(iref,jref)=hmat(iref,jref)-hint(lp,lq)
        end do
      end do
c
c     Two-electron terms: gint=(real_val)/2
c
  100 continue
        read(luncc0) np,nm
        if(np.lt.0) go to 102
        call os_lab_read(luncc0,3*np,icc0p)
        call os_lab_read(luncc0,3*nm,icc0m)
c       read(luncc0) icc0p(1:3,1:np),icc0m(1:3,1:nm)
        do i=1,np
          lq  =lso2mo( icc0p(1,i) )
          lp  =lso2mo( icc0p(2,i) )
          iref=        icc0p(3,i)
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
            hmat(iref,jref)=hmat(iref,jref)+gint(lp,lq,lr,ls)
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
            hmat(iref,jref)=hmat(iref,jref)-gint(lp,lq,lr,ls)
          end do
        end do
        do i=1,nm
          lq  =lso2mo( icc0m(1,i) )
          lp  =lso2mo( icc0m(2,i) )
          iref=        icc0m(3,i)
          do j=1,np
            lr  =lso2mo( icc0p(1,j) )
            ls  =lso2mo( icc0p(2,j) )
            jref=        icc0p(3,j)
            hmat(iref,jref)=hmat(iref,jref)-gint(lp,lq,lr,ls)
          end do
          do j=1,nm
            lr  =lso2mo( icc0m(1,j) )
            ls  =lso2mo( icc0m(2,j) )
            jref=        icc0m(3,j)
            hmat(iref,jref)=hmat(iref,jref)+gint(lp,lq,lr,ls)
          end do
        end do
      go to 100
c
  102 continue
c
      if(GOPARR) call DDI_GSUMF(5000,hmat,nci*nci)
c
c**** Write Hamiltonian file *******************************************
      call seqrew(lunhma)       ! rewind lunhma
      write(lunhma) hmat
      write(lunhma) ecore
      if(lpout.lt.0 .and.maswrk) then
        write(lunout,'(" *** Some diagonal elements of Hamiltonian ***"/
     *                 " encsum =",f15.8,"  ecore =",f15.8/
     *                (" H(",i3,") =",f15.8))')
     *    encsum,ecore,(i,hmat(i,i)+encsum+ecore,i=1,min(10,nci))
      end if
c
c**** End **************************************************************
      if(.not.kmcscf .and.maswrk .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_ionized_dets
     *  (nbuf  ,lrf2or,lrdwrk,kidtab)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 07, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrf2or(nci), lrdwrk(ncibuf), kidtab(nbuf)
c
      dimension locc(NSOMAX), lvir(NSOMAX)
      logical   jocc(NSOMAX)
c     logical kloop
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(/1x,10(1h*)," Routine os_make_ionized_dets ",
     *    39(1h*))')
        call ut_init_time
      END IF
c
c**** Read ref->det label **********************************************
      call seqrew(lunref)       ! rewind lunref
      read(lunref) lrf2or
c
c**** Make sq|J> dets **************************************************
      initid=1
      ncim2 =0
      n=0
      call seqrew(lunrm2)       ! rewind lunrm2
  100 continue
        lastid=min(initid+nbuf-1,nstrx(-2))
        ioff=initid-1
c
        call viclr(kidtab,1,lastid-initid+1)
c
        do jci=1,nci            ! Jref
c
c         kloop=.false.
c         do istate=1,nstate
c           if(abs(ev(jci,istate)).gt.thrgen) kloop=.true.
c         end do
c         if(.not.kloop) go to 100
c
          jdet=lrf2or(jci)      ! Jorg
          call os_det2occ(jdet,jocc,0) ! Jpattern
c
c         Get occ and vir orbs.
c
          nocc=0
          nvir=0
          do i=1,nsoact
            if(jocc(i)) then
              nocc=nocc+1
              locc(nocc)=i
            else
              nvir=nvir+1
              lvir(nvir)=i
            end if
          end do
c
c         Make sq|J> dets
c
          do j=1,nocc
            lq=locc(j)
            lvir(nvir+1)=lq
            jocc(lq)=.false.    ! jqocc=ibclr(jocc ,lq-1)
c           jspn=mospn(lq)
c           jsym=mosym(lq)
          do l=1,j-1
            ls=locc(l)
            lvir(nvir+2)=ls
            jocc(ls)=.false.
c           lspn=mospn(ls)
c           lsym=ieor(jsym,mosym(ls))
            if(.true.) then
              call os_occ2detx(iondet,jocc,-2)
              if(initid.le.iondet .and. iondet.le.lastid)
     *          kidtab(iondet-ioff)=-1
            end if
            jocc(ls)=.true.
          end do
            jocc(lq)=.true.
          end do
        end do
        do i=initid,lastid
          if(kidtab(i-ioff).eq.-1) then
            ncim2=ncim2+1
            n    =n    +1
            if(n.gt.ncibuf) then
              write(lunrm2) ncibuf
              write(lunrm2) lrdwrk
              n=1
            end if
            lrdwrk(n)=i
          end if
        end do
        initid=initid+nbuf
      if(initid.le.nstrx(-2)) go to 100
c
      write(lunrm2) n
      call os_lab_write(lunrm2,n,lrdwrk)
      write(lunrm2) -1
c
c     if(MASWRK) write(lunout,*) 'ncim2',ncim2
c
c**** Make p+sq|J> and q|J> ********************************************
      initid=1
      ncim1 =0
      n     =0
      call seqrew(lunrm1)       ! rewind lunrm1
  102 continue
        lastid=min(initid+nbuf-1,nstrx(-1))
        ioff=initid-1
c
        call viclr(kidtab,1,lastid-initid+1)
c
        do jci=1,nci            ! Jref
c
          jdet=lrf2or(jci)      ! Jorg
          call os_det2occ(jdet,jocc,0) ! Jpattern
c
c         Get occ and vir orbs.
c
          nocc=0
          nvir=0
          do i=1,nsoact
            if(jocc(i)) then
              nocc=nocc+1
              locc(nocc)=i
            else
              nvir=nvir+1
              lvir(nvir)=i
            end if
          end do
c
c         Make p+sq|J> dets
c
          do j=1,nocc
            lq=locc(j)
            lvir(nvir+1)=lq
            jocc(lq)=.false.    ! jqocc=ibclr(jocc ,lq-1)
c           jspn=mospn(lq)
c           jsym=mosym(lq)
          do l=1,j-1
            ls=locc(l)
            lvir(nvir+2)=ls
            jocc(ls)=.false.
c           lspn=mospn(ls)
c           lsym=ieor(jsym,mosym(ls))
          do i=1,nvir+2
            lp=lvir(i)
            jocc(lp)=.true.
c           ispn=mospn(lp)
c           isym=ieor(lsym,mosym(lp))
            if(.true.) then
              call os_occ2detx(iondet,jocc,-1)
              if(initid.le.iondet .and. iondet.le.lastid)
     *          kidtab(iondet-ioff)=-1
            end if
            jocc(lp)=.false.
          end do
            jocc(ls)=.true.
          end do
            jocc(lq)=.true.
          end do
        end do
        do i=initid,lastid
          if(kidtab(i-ioff).eq.-1) then
            ncim1=ncim1+1
            n    =n    +1
            if(n.gt.ncibuf) then
              write(lunrm1) ncibuf
              write(lunrm1) lrdwrk
              n=1
            end if
            lrdwrk(n)=i
          end if
        end do
        initid=initid+nbuf
      if(initid.le.nstrx(-1)) go to 102
c
      if(nelact.eq.1) then
        ncim1=1
        n    =1
        lrdwrk(1)=1
      end if
c
      write(lunrm1) n
      call os_lab_write(lunrm1,n,lrdwrk)
      write(lunrm1) -1
c
c     if(MASWRK) write(lunout,*) 'ncim1',ncim1
c
c**** Make p+q|J> ******************************************************
      initid=1
      nci00 =0
      n     =0
      call seqrew(lunr00)       ! rewind lunr00
  104 continue
        lastid=min(initid+nbuf-1,nstrx(0))
        ioff=initid-1
c
        call viclr(kidtab,1,lastid-initid+1)
c
        do jci=1,nci            ! Jref
c
          jdet=lrf2or(jci)      ! Jorg
          call os_det2occ(jdet,jocc,0) ! Jpattern
c
c         Get occ and vir orbs.
c
          nocc=0
          nvir=0
          do i=1,nsoact
            if(jocc(i)) then
              nocc=nocc+1
              locc(nocc)=i
            else
              nvir=nvir+1
              lvir(nvir)=i
            end if
          end do
c
c         Make p+q|J> dets
c
          do j=1,nocc
            lq=locc(j)
            lvir(nvir+1)=lq
            jocc(lq)=.false.  ! ibclr(jocc,lq-1)
c           jspn=mospn(lq)
c           jsym=mosym(lq)
          do k=1,nvir+1
            lp=lvir(k)
            jocc(lp)=.true.   ! jocc=ibset(jocc,lp-1)
c           kspn=mospn(lp)
c           ksym=ieor(jsym,mosym(lp))
            if(.true.) then
              call os_occ2detx(iondet,jocc,0)
              if(initid.le.iondet .and. iondet.le.lastid)
     *          kidtab(iondet-ioff)=-1
            end if
            jocc(lp)=.false.  ! jocc=ibclr(jocc,lp-1)
          end do
            jocc(lq)=.true.   ! jocc=ibset(jocc,lq-1)
          end do
        end do
        do i=initid,lastid
          if(kidtab(i-ioff).eq.-1) then
            nci00=nci00+1
            n    =n    +1
            if(n.gt.ncibuf) then
              write(lunr00) ncibuf
              write(lunr00) lrdwrk
              n=1
            end if
            lrdwrk(n)=i
          end if
        end do
        initid=initid+nbuf
      if(initid.le.nstrx(0)) go to 104
c
!!$  if(nelact.eq.0) then
!!$    ncip1=nmoact
!!$    n    =nmoact
!!$!   do i=1,nmoact
!!$!     jocc(i)=.false.
!!$!   end do
!!$    jocc=0
!!$    do i=0,nmoact-1
!!$      jocc=ibset(jocc,i)
!!$      call ofc_find_weightx(iondet,jocc,1)
!!$      lrdwrk(i)=iondet  ! Should be ncibuf > nmoact
!!$      jocc=ibclr(jocc,i)
!!$    end do
!!$  end if
c
      write(lunr00) n
      call os_lab_write(lunr00,n,lrdwrk)
      write(lunr00) -1
c
c     if(MASWRK) write(lunout,*) 'nci00',nci00
c
c**** Make p+r+q|J> and p+|J> ******************************************
      initid=1
      ncip1 =0
      n     =0
      call seqrew(lunrp1)       ! rewind lunrp1
  106 continue
        lastid=min(initid+nbuf-1,nstrx(1))
        ioff=initid-1
c
        call viclr(kidtab,1,lastid-initid+1)
c
        do jci=1,nci            ! Jref
c
          jdet=lrf2or(jci)      ! Jorg
          call os_det2occ(jdet,jocc,0) ! Jpattern
c
c         Get occ and vir orbs.
c
          nocc=0
          nvir=0
          do i=1,nsoact
            if(jocc(i)) then
              nocc=nocc+1
              locc(nocc)=i
            else
              nvir=nvir+1
              lvir(nvir)=i
            end if
          end do
c
c         Make p+r+q|J> dets
c
          do j=1,nocc
            lq=locc(j)
            lvir(nvir+1)=lq
            jocc(lq)=.false.    ! jqocc=ibclr(jocc ,lq-1)
c           jspn=mospn(lq)
c           jsym=mosym(lq)
          do k=1,nvir+1
            lr=lvir(k)
            jocc(lr)=.true.
c           kspn=mospn(lr)
c           ksym=ieor(jsym,mosym(lr))
          do i=1,k-1
            lp=lvir(i)
            jocc(lp)=.true.
c           ispn=mospn(lp)
c           isym=ieor(ksym,mosym(lp))
            if(.true.) then
              call os_occ2detx(iondet,jocc,1)
              if(initid.le.iondet .and. iondet.le.lastid)
     *          kidtab(iondet-ioff)=-1
            end if
            jocc(lp)=.false.
          end do
            jocc(lr)=.false.
          end do
            jocc(lq)=.true.
          end do
        end do
        do i=initid,lastid
          if(kidtab(i-ioff).eq.-1) then
            ncip1=ncip1+1
            n    =n    +1
            if(n.gt.ncibuf) then
              write(lunrp1) ncibuf
              write(lunrp1) lrdwrk
              n=1
            end if
            lrdwrk(n)=i
          end if
        end do
        initid=initid+nbuf
      if(initid.le.nstrx(1)) go to 106
c
      if(nelact.eq.0) then
        ncip1=nsoact
        n    =nsoact
        do i=1,nsoact
          jocc(i)=.false.
        end do
        do i=1,nsoact
          jocc(i)=.true.
          call os_occ2detx(iondet,jocc,1)
          lrdwrk(i)=iondet  ! Should be ncibuf > nsoact
          jocc(i)=.false.
        end do
      end if
c
      write(lunrp1) n
      call os_lab_write(lunrp1,n,lrdwrk)
      write(lunrp1) -1
c
c     if(MASWRK) write(lunout,*) 'ncip1',ncip1
c
c**** Make p+r+|J> *****************************************************
      initid=1
      ncip2 =0
      n     =0
      call seqrew(lunrp2)       ! rewind lunrp2
  108 continue
        lastid=min(initid+nbuf-1,nstrx(2))
        ioff=initid-1
c
        call viclr(kidtab,1,lastid-initid+1)
c
        do jci=1,nci            ! Jref
c
          jdet=lrf2or(jci)      ! Jorg
          call os_det2occ(jdet,jocc,0) ! Jpattern
c
c         Get occ and vir orbs.
c
          nocc=0
          nvir=0
          do i=1,nsoact
            if(jocc(i)) then
              nocc=nocc+1
              locc(nocc)=i
            else
              nvir=nvir+1
              lvir(nvir)=i
            end if
          end do
c
c         Make p+r+|J> dets
c
          do k=1,nvir
            lr=lvir(k)
            jocc(lr)=.true.    ! jqocc=ibclr(jocc ,lq-1)
c           kspn=mospn(lr)
c           ksym=mosym(lr)
          do i=1,k-1
            lp=lvir(i)
            jocc(lp)=.true.
c           ispn=mospn(lp)
c           isym=ieor(ksym,mosym(lp))
            if(.true.) then
              call os_occ2detx(iondet,jocc,2)
              if(initid.le.iondet .and. iondet.le.lastid)
     *          kidtab(iondet-ioff)=-1
            end if
            jocc(lp)=.false.
          end do
            jocc(lr)=.false.
          end do
        end do
        do i=initid,lastid
          if(kidtab(i-ioff).eq.-1) then
            ncip2=ncip2+1
            n    =n    +1
            if(n.gt.ncibuf) then
              write(lunrp2) ncibuf
              write(lunrp2) lrdwrk
              n=1
            end if
            lrdwrk(n)=i
          end if
        end do
        initid=initid+nbuf
      if(initid.le.nstrx(2)) go to 108
c
      write(lunrp2) n
      call os_lab_write(lunrp2,n,lrdwrk)
      write(lunrp2) -1
c
c     if(MASWRK) write(lunout,*) 'ncip2',ncip2
c
      if(MASWRK) then
        write(lunout,'(/" Dimension of ionized spaces for PT:"/
     *    " (N-2) space:",i13," /  (N-1) space:",i13," /  N space:",i13/
     *    " (N+1) space:",i13," /  (N+2) space:",i13)')
     *    ncim2,ncim1,nci00,ncip1,ncip2
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
c$$$      subroutine os_make_ionized_dets_rewrite(ncimax,lrdrea,lrdwri)
c$$$c=================================================================
c$$$c===         Coded by H. Nakano (Kyushu University)            ===
c$$$c===           Last revision: Aug 10, 2006 by HN               ===
c$$$c=================================================================
c$$$      implicit double precision (a-h,o-z)
c$$$      parameter (MAXSTA=100, NSPCMX=20)
c$$$      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,
c$$$     *  LUNROC,LUNOOC,
c$$$     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,
c$$$     *  LUNGJK,LUNGAI,
c$$$     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,
c$$$     *  LUNRM2,LUNRM1,
c$$$     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
c$$$      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
c$$$      CHARACTER*8 REFTYP,CEXCEN
c$$$      COMMON /OSGMCPT/
c$$$     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
c$$$     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
c$$$     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
c$$$     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,
c$$$     *  THRHDE,HDEMAX,
c$$$     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,
c$$$     *  NSOLUT,NPDET ,
c$$$     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,
c$$$     *  NSPACE,MAXBAS,
c$$$     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,
c$$$     *  KMPART,NILOOP,
c$$$     *  NCIBUF
c$$$c
c$$$      dimension lrdrea(ncibuf), lrdwri(ncimax)
c$$$c
c$$$c     write(lunout,
c$$$c    *  '(/1x,10(1h*)," Routine os_make_ionized_dets_rewite ",
c$$$c    *  32(1h*))')
c$$$c
c$$$      call seqrew(lunrm2)       ! rewind lunrm2
c$$$      n=0
c$$$  100 continue
c$$$      read(lunrm2) nelm
c$$$      if(nelm.ge.0) then
c$$$        call os_lab_read(lunrm2,nelm,lrdrea)
c$$$        do i=1,nelm
c$$$          n=n+1
c$$$          if(n.gt.ncim2) stop 'n>ncim2'
c$$$          lrdwri(n)=lrdrea(i)
c$$$        end do
c$$$        go to 100
c$$$      end if
c$$$      if(n.ne.ncim2) stop 'n/=ncim2'
c$$$      call seqrew(lunrm2)       ! rewind lunrm2
c$$$      call os_lab_write(lunrm2,ncim2,lrdwri)
c$$$c
c$$$      call seqrew(lunrm1)       ! rewind lunrm1
c$$$      n=0
c$$$  102 continue
c$$$      read(lunrm1) nelm
c$$$      if(nelm.ge.0) then
c$$$        call os_lab_read(lunrm1,nelm,lrdrea)
c$$$        do i=1,nelm
c$$$          n=n+1
c$$$          if(n.gt.ncim1) stop 'n>ncim1'
c$$$          lrdwri(n)=lrdrea(i)
c$$$        end do
c$$$        go to 102
c$$$      end if
c$$$      if(n.ne.ncim1) stop 'n/=ncim1'
c$$$      call seqrew(lunrm1)       ! rewind lunrm1
c$$$      call os_lab_write(lunrm1,ncim1,lrdwri)
c$$$c
c$$$      call seqrew(lunr00)       ! rewind lunr00
c$$$      n=0
c$$$  104 continue
c$$$      read(lunr00) nelm
c$$$      if(nelm.ge.0) then
c$$$        call os_lab_read(lunr00,nelm,lrdrea)
c$$$        do i=1,nelm
c$$$          n=n+1
c$$$          if(n.gt.nci00) stop 'n>nci00'
c$$$          lrdwri(n)=lrdrea(i)
c$$$        end do
c$$$        go to 104
c$$$      end if
c$$$      if(n.ne.nci00) stop 'n/=nci00'
c$$$      call seqrew(lunr00)       ! rewind lunr00
c$$$      call os_lab_write(lunr00,nci00,lrdwri)
c$$$c
c$$$      call seqrew(lunrp1)       ! rewind lunrp1
c$$$      n=0
c$$$  106 continue
c$$$      read(lunrp1) nelm
c$$$      if(nelm.ge.0) then
c$$$        call os_lab_read(lunrp1,nelm,lrdrea)
c$$$        do i=1,nelm
c$$$          n=n+1
c$$$          if(n.gt.ncip1) stop 'n>ncip1'
c$$$          lrdwri(n)=lrdrea(i)
c$$$        end do
c$$$        go to 106
c$$$      end if
c$$$      if(n.ne.ncip1) stop 'n/=ncip1'
c$$$      call seqrew(lunrp1)       ! rewind lunrp1
c$$$      call os_lab_write(lunrp1,ncip1,lrdwri)
c$$$c
c$$$      call seqrew(lunrp2)       ! rewind lunrp2
c$$$      n=0
c$$$  108 continue
c$$$      read(lunrp2) nelm
c$$$      if(nelm.ge.0) then
c$$$        call os_lab_read(lunrp2,nelm,lrdrea)
c$$$        do i=1,nelm
c$$$          n=n+1
c$$$          if(n.gt.ncip2) stop 'n>ncip2'
c$$$          lrdwri(n)=lrdrea(i)
c$$$        end do
c$$$        go to 108
c$$$      end if
c$$$      if(n.ne.ncip2) stop 'n/=ncip2'
c$$$      call seqrew(lunrp2)       ! rewind lunrp2
c$$$      call os_lab_write(lunrp2,ncip2,lrdwri)
c$$$c
c$$$c**** End **********************************************************
c$$$c     if(MASWRK .and. lpout.eq.1) call ut_report_time
c$$$      end
      subroutine os_make_ref(lpdet,lrdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Needs reading NPDET and NEXCIT before being called
c
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lpdet(npdet),lrdet(ndet)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout, '(/1x,10(1h*)," Routine os_make_ref ",49(1h*))')
        call ut_init_time
      end if
      if(MASWRK .and. kprint) then
        write(lunout,'(/" *** Reference space")')
      end if
c
c**** Set up references ************************************************
      if     (reftyp.eq.'MRX     ') then
        call os_make_ref_mrx  (lpdet,lrdet)
      else if(reftyp.eq.'MRVX    ') then
        call os_make_ref_mrvx (lpdet,lrdet)
      else if(reftyp.eq.'MRXOS   ') then
        call os_make_ref_mrxos(lpdet,lrdet)
      else if(reftyp.eq.'ORMAS   ' .or. reftyp.eq.'RAS     ') then
        call os_make_ref_ormas_ras(lrdet)
      end if
c
c**** Broadcast NCI and LRDET ******************************************
      if(GOPARR) then
        call DDI_BCAST(5000,'I',nci  ,1  ,MASTER)
        call DDI_BCAST(5000,'I',lrdet,nci,MASTER)
      end if
c
c**** Write reference determinants on file *****************************
c     if(MASWRK) write(lunout,'(" nci =",i10,"  ndet =",i10)') nci,ndet
      if(MASWRK .and. kprint) then
        write(lunout,'(" Dimension of reference space =",i10,
     *                 "  (from",i10," walks)")') nci,ndet
      end if
c
      call seqrew(lunref)       ! rewind lunref
      call os_lab_write(lunref,nci,lrdet)
c     write(lunref) lrdet(1:nci)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_make_ref_mrvx(lpdet,lrdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 30, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lpdet(npdet),lrdet(ndet)
      dimension istrng(NSOMAX)
      logical   iocc  (NSOMAX),ipocc(NSOMAX)
      character*8   char8
c
c**** Read parant determinants *****************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  100   continue
C-MWS     read(lunin,*,err=102,end=102) char8
C-MWS   if(char8.ne.'$PDET   ' .and. char8.ne.'$pdet   ' .and.
C-MWS*     char8.ne.'$GDS    ' .and. char8.ne.'$gds    ' .and.
C-MWS*     char8.ne.'$GCS    ' .and. char8.ne.'$gcs    ') go to 100
          read(lunin,fmt='(a8)',err=102,end=102) char8
        if(char8.ne.' $PDET  ' .and. char8.ne.' $pdet  ' .and.
     *     char8.ne.' $GDS   ' .and. char8.ne.' $gds   ' .and.
     *     char8.ne.' $GCS   ' .and. char8.ne.' $gcs   ') go to 100
c
c       NPDET and NEXCIT have been read in sub.os_read_data
c
        if(kprint) then
          write(lunout,
     *      '(/" Reference type: MRVX",
     *      " (= Parent determinants plus various excitations)")')
          write(lunout,
     *      '(" Excitation level =",128i3)') (-mxhole(i),i=1,nspace)
          write(lunout,
     *      '("                   ",128i3)') ( mxpart(i),i=1,nspace)
          write(lunout,
     *      '(" Excitation level =",i5/
     *      " Parent determinants:"/
     *      6x,"Det",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",4x,"--------- --------- -----")') nexcit
        end if
c
        do ipdet=1,npdet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          lpdet(ipdet)=idet
          if(kprint) call os_print_string(idet,ZERO,iocc,.true.)
c
          n=0
          do i=1,nsoact
            if(iocc(i)) n=n+1
          end do
          if(n.ne.nelact) then
            write(lunout,
     *      '(" *** Error stop in sub.os_make_ref_mrvx ***"/
     *        " # of electrons in a string /= # of active electrons")')
            call abrt
          end if
        end do
c
  102   continue
      END IF
c
      if(GOPARR) then
        call DDI_BCAST(5000,'I',lpdet ,npdet,MASTER)
      end if
c
c     Set state symmetry
c
      if(knosym) then
c       istsym   =0
        istsym(1)=0
        if(MASWRK .and. kprint)
     *    write(lunout,'(" State symmetry    =    - (general)")')
c     else if(istsym   .lt.0) then
      else if(istsym(1).lt.0) then
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),iocc,0)
          isym=0
          do i=1,nsoact
            if(iocc(i)) isym=ieor(isym,mosym(i))
          end do
c         if(istsym   .lt.0) then
c           istsym   =isym
c         else if(isym.ne.istsym   ) then
          if(istsym(1).lt.0) then
            istsym(1)=isym
          else if(isym.ne.istsym(1)) then
            if(MASWRK)
     *        write(lunout,
     *        '(" *** Error stop in os_make_ref_mrvx ***"/
     *          " Inconsistent symmetries of parent dets.")')
            call abrt
          end if
        end do
c       istsym   =istsym   +1
        istsym(1)=istsym(1)+1
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5,
c    *                   " (determined from parent dets.)")') istsym
          write(lunout,'(" State symmetry    =",i5,
     *                   " (determined from parent dets.)")') istsym(1)
        end if
      else
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5," (input)")') istsym
          write(lunout,  '(" State symmetry    =",i5," (input)")')
     *        istsym(1)
          if(istsym(2).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(2)
          end if
          if(istsym(3).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(3)
          end if
        end if
      end if
c
c     Set nspin
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =    - (general)")')
        end if
      else if(nspin.lt.0) then
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),iocc,0)
          ns=0
          do i=1,nsoact
            if(iocc(i)) then
              if(mospn(i).eq.1) then
                ns=ns+1
              else
                ns=ns-1
              end if
            end if
          end do
          if(nspin.lt.0) then
            nspin=ns
          else if(ns.ne.nspin) then
            if(MASWRK) then
              write(lunout,'(" *** Error stop in os_make_ref_mrvx ***"/
     *                       " Inconsistent Sz of parent dets.")')
            end if
          end if
        end do
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5,
     *                   " (determined from parent dets.)")') nspin
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5," (input)")') nspin
        end if
      end if
c
c     Set mult
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =    - (general)")')
        end if
      else if(mult.lt.0) then
        mult=nspin+1
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5,
     *                   " (determined from parent dets.)")') mult
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5," (input)")') mult
        end if
      end if
c
c**** Make reference determinants **************************************
      nci=0
      do idet=1,ndet
        call os_det2occ(idet,iocc,0)
c
        is=0
        ns=0
        do i=1,nsoact
          if(iocc(i)) then
            is=ieor(is,mosym(i))
            if(mospn(i).eq.1) then
              ns=ns+1
            else
              ns=ns-1
            end if
          end if
        end do
c       if((.not.knosym .and. is.ne.istsym-1) .or.
c    *     (.not.knospn .and. ns.ne.nspin   )     ) go to 106
        if((.not.knosym .and. is.ne.istsym(1)-1
     *                  .and. is.ne.istsym(2)-1
     *                  .and. is.ne.istsym(3)-1) .or.
     *     (.not.knospn .and. ns.ne.nspin      )     ) go to 106
c
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),ipocc,0)
c
          m=0
          ndiff=0
          do ispace=1,nspace
            nhole=0
            npart=0
            do i=m+1,m+morb(ispace)
c           do i=1,nsoact
              if(     iocc(i) .and. .not.ipocc(i)) then
                npart=npart+1
                if(npart.gt.mxpart(ispace)) go to 104
              end if
              if(.not.iocc(i) .and.      ipocc(i)) then
                nhole=nhole+1
                if(nhole.gt.mxhole(ispace)) go to 104
              end if
              if(iocc(i) .neqv. ipocc(i)) then
                ndiff=ndiff+1
                if(ndiff.gt.2*nexcit) go to 104
              end if
            end do
            m=m+morb(ispace)
          end do
          ndiff=ndiff/2
c
          nci=nci+1
          lrdet(nci)=idet
          go to 106
c
  104     continue
        end do
c
  106   continue
      end do
c
c**** Read more determinants *******************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  108   continue
C-MWS     read(lunin,*,err=112,end=112) char8
C-MWS   if(char8.ne.'$ADDDET ' .and. char8.ne.'$adddet ') go to 108
          read(lunin,fmt='(a8)',err=112,end=112) char8
        if(char8.ne.' $ADDDET' .and. char8.ne.' $adddet') go to 108
c
        read(lunin,*) naddet
        do iaddet=1,naddet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do ici=1,nci
            if(idet.eq.lrdet(ici)) then
              if(MASWRK)
     *          write(lunout,
     *          '(" The determinant is in the reference: ",128i1)')
     *          (istrng(i),i=1,nmoact)
              go to 110
            end if
          end do
          nci=nci+1
          lrdet(nci)=idet
  110     continue
        end do
c
  112   continue
c
c**** Remove determinants **********************************************
        call seqrew(lunin)      ! rewind lunin
  114   continue
C-MWS     read(lunin,*,err=118,end=118) char8
C-MWS   if(char8.ne.'$REMDET ' .and. char8.ne.'$remdet ') go to 114
          read(lunin,fmt='(a8)',err=118,end=118) char8
        if(char8.ne.' $REMDET' .and. char8.ne.' $remdet') go to 114
c
        read(lunin,*) nrmdet
        do irmdet=1,nrmdet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do ici=1,nci
            if(idet.eq.lrdet(ici)) then
              do jci=ici,nci-1
                lrdet(jci)=lrdet(jci+1)
              end do
              lrdet(nci)=0
              nci=nci-1
              go to 116
            end if
          end do
          if(MASWRK)
     *      write(lunout,
     *      '(" The determinant is not in the reference: ",128i1)')
     *      (istrng(i),i=1,nmoact)
  116     continue
        end do
  118   continue
      END IF
      end
      subroutine os_make_ref_mrx(lpdet,lrdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lpdet(npdet),lrdet(ndet)
      dimension istrng(NSOMAX)
      logical   iocc  (NSOMAX),ipocc(NSOMAX)
      character*8   char8
c
c**** Read parant determinants *****************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  100   continue
C-MWS     read(lunin,*,err=102,end=102) char8
C-MWS   if(char8.ne.'$PDET   ' .and. char8.ne.'$pdet   ' .and.
C-MWS*     char8.ne.'$GDS    ' .and. char8.ne.'$gds    ' .and.
C-MWS*     char8.ne.'$GCS    ' .and. char8.ne.'$gcs    ') go to 100
          read(lunin,fmt='(a8)',err=102,end=102) char8
        if(char8.ne.' $PDET  ' .and. char8.ne.' $pdet  ' .and.
     *     char8.ne.' $GDS   ' .and. char8.ne.' $gds   ' .and.
     *     char8.ne.' $GCS   ' .and. char8.ne.' $gcs   ') go to 100
c
c       NPDET and NEXCIT have been read in sub.os_read_data
c
        if(kprint) then
          write(lunout,
     *      '(/" Reference type: MRX",
     *      " (= Parent determinants plus excitations)")')
          write(lunout,
     *      '(" Excitation level =",i5/
     *      " Parent determinants:"/
     *      6x,"Det",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",4x,"--------- --------- -----")') nexcit
        end if
c
        morb(1)=nsoact
        morb(3)=0
        do ipdet=1,npdet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          lpdet(ipdet)=idet
          if(kprint) call os_print_string(idet,ZERO,iocc,.true.)
c
          n=0
          do i=1,nsoact
            if(iocc(i)) n=n+1
          end do
          if(n.ne.nelact) then
            write(lunout,
     *      '(" *** Error stop in sub.os_make_ref_mrx ***"/
     *        " # of electrons in a string /= # of active electrons")')
            call abrt
          end if
          do i=1,nsoact
            if(.not.iocc(i) .and. lso2mo(i).lt.morb(1)) then
              morb(1)=lso2mo(i)
            end if
            if(     iocc(i) .and. lso2mo(i).gt.morb(3)) then
              morb(3)=lso2mo(i)
            end if
          end do
        end do
        nspace=3
        morb(1)=2*(morb(1)-1)
        morb(3)=nsoact-2*morb(3)
        morb(2)=nsoact-morb(1)-morb(3)
c
  102   continue
c
      END IF
c
      if(GOPARR) then
        call DDI_BCAST(5000,'I',lpdet ,npdet,MASTER)
        call DDI_BCAST(5000,'I',nspace,1    ,MASTER)
        call DDI_BCAST(5000,'I',morb  ,3    ,MASTER)
      end if
c
c     Set state symmetry
c
      if(knosym) then
c       istsym   =0
        istsym(1)=0
        if(MASWRK .and. kprint)
     *    write(lunout,'(" State symmetry    =    - (general)")')
c     else if(istsym   .lt.0) then
      else if(istsym(1).lt.0) then
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),iocc,0)
          isym=0
          do i=1,nsoact
            if(iocc(i)) isym=ieor(isym,mosym(i))
          end do
c         if(istsym   .lt.0) then
c           istsym   =isym
c         else if(isym.ne.istsym(1)) then
          if(istsym(1).lt.0) then
            istsym(1)=isym
          else if(isym.ne.istsym(1)) then
            if(MASWRK)
     *        write(lunout,
     *        '(" *** Error stop in os_make_ref_mrx ***"/
     *          " Inconsistent symmetries of parent dets.")')
            call abrt
          end if
        end do
c       istsym   =istsym   +1
        istsym(1)=istsym(1)+1
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5,
c    *                   " (determined from parent dets.)")') istsym
          write(lunout,'(" State symmetry    =",i5,
     *                   " (determined from parent dets.)")') istsym(1)
        end if
      else
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5," (input)")') istsym
          write(lunout,  '(" State symmetry    =",i5," (input)")')
     *        istsym(1)
          if(istsym(2).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(2)
          end if
          if(istsym(3).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(3)
          end if
        end if
      end if
c
c     Set nspin
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =    - (general)")')
        end if
      else if(nspin.lt.0) then
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),iocc,0)
          ns=0
          do i=1,nsoact
            if(iocc(i)) then
              if(mospn(i).eq.1) then
                ns=ns+1
              else
                ns=ns-1
              end if
            end if
          end do
          if(nspin.lt.0) then
            nspin=ns
          else if(ns.ne.nspin) then
            if(MASWRK) then
              write(lunout,'(" *** Error stop in os_make_ref_mrx ***"/
     *                       " Inconsistent Sz of parent dets.")')
            end if
          end if
        end do
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5,
     *                   " (determined from parent dets.)")') nspin
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5," (input)")') nspin
        end if
      end if
c
c     Set mult
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =    - (general)")')
        end if
      else if(mult.lt.0) then
        mult=nspin+1
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5,
     *                   " (determined from parent dets.)")') mult
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5," (input)")') mult
        end if
      end if
c
c**** Make reference determinants **************************************
      nci=0
      do idet=1,ndet
        call os_det2occ(idet,iocc,0)
c
        is=0
        ns=0
        do i=1,nsoact
          if(iocc(i)) then
            is=ieor(is,mosym(i))
            if(mospn(i).eq.1) then
              ns=ns+1
            else
              ns=ns-1
            end if
          end if
        end do
c       if((.not.knosym .and. is.ne.istsym   -1) .or.
c    *     (.not.knospn .and. ns.ne.nspin   )        ) go to 106
        if((.not.knosym .and. is.ne.istsym(1)-1
     *                  .and. is.ne.istsym(2)-1
     *                  .and. is.ne.istsym(3)-1) .or.
     *     (.not.knospn .and. ns.ne.nspin      )     ) go to 106
c
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),ipocc,0)
c
          ndiff=0
          do i=1,nsoact
            if(iocc(i) .neqv. ipocc(i)) then
              ndiff=ndiff+1
              if(ndiff.gt.2*nexcit) go to 104
            end if
          end do
c         ndiff=ndiff/2
c
          nci=nci+1
          lrdet(nci)=idet
          go to 106
c
  104     continue
        end do
c
  106   continue
      end do
c
c**** Read more determinants *******************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  108   continue
C-MWS     read(lunin,*,err=112,end=112) char8
C-MWS   if(char8.ne.'$ADDDET ' .and. char8.ne.'$adddet ') go to 108
          read(lunin,fmt='(a8)',err=112,end=112) char8
        if(char8.ne.' $ADDDET' .and. char8.ne.' $adddet') go to 108
c
        read(lunin,*) naddet
        do iaddet=1,naddet
c         read(lunin,'(128i1)') (istrng(i),i=1,nsoact)
cc        read(lunin,*) chr128
cc        read(chr128,'(128i1)') (istrng(i),i=1,nsoact)
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do ici=1,nci
            if(idet.eq.lrdet(ici)) then
              if(MASWRK)
     *          write(lunout,
     *          '(" The determinant is in the reference: ",128i1)')
     *          (istrng(i),i=1,nmoact)
              go to 110
            end if
          end do
          nci=nci+1
          lrdet(nci)=idet
  110     continue
        end do
c
  112   continue
c
c**** Remove determinants **********************************************
        call seqrew(lunin)      ! rewind lunin
  114   continue
C-MWS     read(lunin,*,err=118,end=118) char8
C-MWS   if(char8.ne.'$REMDET ' .and. char8.ne.'$remdet ') go to 114
          read(lunin,fmt='(a8)',err=118,end=118) char8
        if(char8.ne.' $REMDET' .and. char8.ne.' $remdet') go to 114
c
        read(lunin,*) nrmdet
        do irmdet=1,nrmdet
c         read(lunin,'(128i1)') (istrng(i),i=1,nsoact)
cc        read(lunin,*) chr128
cc        read(chr128,'(128i1)') (istrng(i),i=1,nsoact)
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do ici=1,nci
            if(idet.eq.lrdet(ici)) then
              do jci=ici,nci-1
                lrdet(jci)=lrdet(jci+1)
              end do
              lrdet(nci)=0
              nci=nci-1
              go to 116
            end if
          end do
          if(MASWRK)
     *      write(lunout,
     *      '(" The determinant is not in the reference: ",128i1)')
     *      (istrng(i),i=1,nmoact)
  116     continue
        end do
  118   continue
      END IF
      end
      subroutine os_make_ref_mrxos(lpdet,lrdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 30, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lpdet(npdet),lrdet(ndet)
      dimension istrng(NSOMAX)
      logical   iocc  (NSOMAX),ipocc(NSOMAX)
      character*8   char8
c
c**** Read parant determinants *****************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  100   continue
C-MWS     read(lunin,*,err=102,end=102) char8
C-MWS   if(char8.ne.'$PDET   ' .and. char8.ne.'$pdet   ' .and.
C-MWS*     char8.ne.'$GDS    ' .and. char8.ne.'$gds    ' .and.
C-MWS*     char8.ne.'$GCS    ' .and. char8.ne.'$gcs    ') go to 100
          read(lunin,fmt='(a8)',err=102,end=102) char8
        if(char8.ne.' $PDET  ' .and. char8.ne.' $pdet  ' .and.
     *     char8.ne.' $GDS   ' .and. char8.ne.' $gds   ' .and.
     *     char8.ne.' $GCS   ' .and. char8.ne.' $gcs   ') go to 100
c
c       NPDET and NEXCIT have been read in sub.os_read_data
c
        if(kprint) then
          write(lunout,
     *      '(/" Reference type: MRXOS",
     *      " (= Parent determinants plus excitations with occupation",
     *      " specified)")')
          write(lunout,
     *      '(" Excitation level =",128i3)') (-mxhole(i),i=1,nspace)
          write(lunout,
     *      '("                   ",128i3)') ( mxpart(i),i=1,nspace)
          write(lunout,
     *      '(" Parent determinants:"/
     *      6x,"Det",4x,"Occupancy (Ignoring core)"/
     *      6x,"---",4x,"--------- --------- -----")')
        end if
c
        do ipdet=1,npdet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          lpdet(ipdet)=idet
          if(kprint) call os_print_string(idet,ZERO,iocc,.true.)
c
          n=0
          do i=1,nsoact
            if(iocc(i)) n=n+1
          end do
          if(n.ne.nelact) then
            write(lunout,
     *      '(" *** Error stop in sub.os_make_ref_mrvx ***"/
     *        " # of electrons in a string /= # of active electrons")')
            call abrt
          end if
        end do
c
  102   continue
      END IF
c
      if(GOPARR) then
        call DDI_BCAST(5000,'I',lpdet ,npdet,MASTER)
      end if
c
c     Set state symmetry
c
      if(knosym) then
c       istsym   =0
        istsym(1)=0
        if(MASWRK .and. kprint)
     *    write(lunout,'(" State symmetry    =    - (general)")')
c     else if(istsym   .lt.0) then
      else if(istsym(1).lt.0) then
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),iocc,0)
          isym=0
          do i=1,nsoact
            if(iocc(i)) isym=ieor(isym,mosym(i))
          end do
c         if(istsym   .lt.0) then
c           istsym   =isym
c         else if(isym.ne.istsym   ) then
          if(istsym(1).lt.0) then
            istsym(1)=isym
          else if(isym.ne.istsym(1)) then
            if(MASWRK)
     *        write(lunout,
     *        '(" *** Error stop in os_make_ref_mrvx ***"/
     *          " Inconsistent symmetries of parent dets.")')
            call abrt
          end if
        end do
c       istsym   =istsym   +1
        istsym(1)=istsym(1)+1
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5,
c    *                   " (determined from parent dets.)")') istsym
          write(lunout,'(" State symmetry    =",i5,
     *                   " (determined from parent dets.)")') istsym(1)
        end if
      else
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5," (input)")') istsym
          write(lunout,  '(" State symmetry    =",i5," (input)")')
     *        istsym(1)
          if(istsym(2).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(2)
          end if
          if(istsym(3).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(3)
          end if
        end if
      end if
c
c     Set nspin
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =    - (general)")')
        end if
      else if(nspin.lt.0) then
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),iocc,0)
          ns=0
          do i=1,nsoact
            if(iocc(i)) then
              if(mospn(i).eq.1) then
                ns=ns+1
              else
                ns=ns-1
              end if
            end if
          end do
          if(nspin.lt.0) then
            nspin=ns
          else if(ns.ne.nspin) then
            if(MASWRK) then
              write(lunout,'(" *** Error stop in os_make_ref_mrvx ***"/
     *                       " Inconsistent Sz of parent dets.")')
            end if
          end if
        end do
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5,
     *                   " (determined from parent dets.)")') nspin
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5," (input)")') nspin
        end if
      end if
c
c     Set mult
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =    - (general)")')
        end if
      else if(mult.lt.0) then
        mult=nspin+1
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5,
     *                   " (determined from parent dets.)")') mult
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5," (input)")') mult
        end if
      end if
c
c**** Make reference determinants **************************************
      nci=0
      do idet=1,ndet
        call os_det2occ(idet,iocc,0)
c
        is=0
        ns=0
        do i=1,nsoact
          if(iocc(i)) then
            is=ieor(is,mosym(i))
            if(mospn(i).eq.1) then
              ns=ns+1
            else
              ns=ns-1
            end if
          end if
        end do
c       if((.not.knosym .and. is.ne.istsym   -1) .or.
c    *     (.not.knospn .and. ns.ne.nspin      )     ) go to 106
        if((.not.knosym .and. is.ne.istsym(1)-1
     *                  .and. is.ne.istsym(2)-1
     *                  .and. is.ne.istsym(3)-1) .or.
     *     (.not.knospn .and. ns.ne.nspin      )     ) go to 106
c
        do ipdet=1,npdet
          call os_det2occ(lpdet(ipdet),ipocc,0)
c
          m=0
c         ndiff=0
          do ispace=1,nspace
            nhole=0
            npart=0
            do i=m+1,m+morb(ispace)
              if(     iocc(i) .and. .not.ipocc(i)) then
                npart=npart+1
                if(npart.gt.mxpart(ispace)) go to 104
              end if
              if(.not.iocc(i) .and.      ipocc(i)) then
                nhole=nhole+1
                if(nhole.gt.mxhole(ispace)) go to 104
              end if
c             if(iocc(i) .neqv. ipocc(i)) then
c               ndiff=ndiff+1
c               if(ndiff.gt.2*nexcit) go to 104
c             end if
            end do
            m=m+morb(ispace)
          end do
c         ndiff=ndiff/2
c
          nci=nci+1
          lrdet(nci)=idet
          go to 106
c
  104     continue
        end do
c
  106   continue
      end do
c
c**** Read more determinants *******************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  108   continue
C-MWS     read(lunin,*,err=112,end=112) char8
C-MWS   if(char8.ne.'$ADDDET ' .and. char8.ne.'$adddet ') go to 108
          read(lunin,fmt='(a8)',err=112,end=112) char8
        if(char8.ne.' $ADDDET' .and. char8.ne.' $adddet') go to 108
c
        read(lunin,*) naddet
        do iaddet=1,naddet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do ici=1,nci
            if(idet.eq.lrdet(ici)) then
              if(MASWRK)
     *          write(lunout,
     *          '(" The determinant is in the reference: ",128i1)')
     *          (istrng(i),i=1,nmoact)
              go to 110
            end if
          end do
          nci=nci+1
          lrdet(nci)=idet
  110     continue
        end do
c
  112   continue
c
c**** Remove determinants **********************************************
        call seqrew(lunin)      ! rewind lunin
  114   continue
C-MWS     read(lunin,*,err=118,end=118) char8
C-MWS   if(char8.ne.'$REMDET ' .and. char8.ne.'$remdet ') go to 114
          read(lunin,fmt='(a8)',err=118,end=118) char8
        if(char8.ne.' $REMDET' .and. char8.ne.' $remdet') go to 114
c
        read(lunin,*) nrmdet
        do irmdet=1,nrmdet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do ici=1,nci
            if(idet.eq.lrdet(ici)) then
              do jci=ici,nci-1
                lrdet(jci)=lrdet(jci+1)
              end do
              lrdet(nci)=0
              nci=nci-1
              go to 116
            end if
          end do
          if(MASWRK)
     *      write(lunout,
     *      '(" The determinant is not in the reference: ",128i1)')
     *      (istrng(i),i=1,nmoact)
  116     continue
        end do
  118   continue
      END IF
      end
      subroutine os_make_ref_ormas_ras(lrdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrdet(ndet)
      logical   iocc  (NSOMAX)
      if(MASWRK .and. kprint) then
        if(reftyp.eq.'ORMAS   ') then
          write(lunout,'(/" Reference type: ORMAS",
     *      " (= Occupation restricted multiple active space)")')
          write(lunout,'(" # of orbitals          =",100i3)')
     *      (morb(i)/2,i=1,nspace)
          write(lunout,'(" # of minimum electrons =",100i3)')
     *      (mine(i),i=1,nspace)
          write(lunout,'(" # of maximum electrons =",100i3)')
     *      (maxe(i),i=1,nspace)
        else if(reftyp.eq.'RAS     ') then
          write(lunout,'(/" Reference type: RAS",
     *      " (= Restricted active space)")')
          write(lunout,'(" # of orbitals in RAS1-3 =",3i3)')
     *      (morb(i)/2,i=1,3)
          write(lunout,'(" Excitation level        =", i3)') nexcit
        end if
      end if
c
c     Set state symmetry
c
      if(knosym) then
c       istsym   =0
        istsym(1)=0
        if(MASWRK .and. kprint) then
          write(lunout,'(" State symmetry    =    - (general)")')
        end if
c     else if(istsym   .lt.0) then
c       istsym   =1
      else if(istsym(1).lt.0) then
        istsym(1)=1
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5,
c    *                   " (default)")') istsym
          write(lunout,'(" State symmetry    =",i5,
     *                   " (default)")') istsym(1)
        end if
      else
        if(MASWRK .and. kprint) then
c         write(lunout,'(" State symmetry    =",i5," (input)")') istsym
          write(lunout,  '(" State symmetry    =",i5," (input)")')
     *        istsym(1)
          if(istsym(2).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(2)
          end if
          if(istsym(3).gt.0) then
            write(lunout,'("                   =",i5," (input)")')
     *        istsym(3)
          end if
        end if
      end if
c
c     Set nspin
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =    - (general)")')
        end if
      else if(nspin.lt.0) then
        nspin=0
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5,
     *                   " (default)")') nspin
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" 2*Sz              =",i5," (input)")') nspin
        end if
      end if
c
c     Set mult
c
      if(knospn) then
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =    - (general)")')
        end if
      else if(mult.lt.0) then
        mult=nspin+1
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5,
     *                   " (defalut)")') mult
        end if
      else
        if(MASWRK .and. kprint) then
          write(lunout,'(" Spin multiplicity =",i5," (input)")') mult
        end if
      end if
c
c**** Make reference determinants **************************************
      nci=0
      do idet=1,ndet
        call os_det2occ(idet,iocc,0)
c
        is=0
        ns=0
        do i=1,nsoact
          if(iocc(i)) then
            is=ieor(is,mosym(i))
            if(mospn(i).eq.1) then
              ns=ns+1
            else
              ns=ns-1
            end if
          end if
        end do
c       if((.not.knosym .and. is.ne.istsym   -1) .or.
c    *     (.not.knospn .and. ns.ne.nspin      )     ) go to 126
        if((.not.knosym .and. is.ne.istsym(1)-1
     *                  .and. is.ne.istsym(2)-1
     *                  .and. is.ne.istsym(3)-1) .or.
     *     (.not.knospn .and. ns.ne.nspin      )     ) go to 126
c
c       if(reftyp.eq.'ORMAS   ') then
          is=0
          ie=0
          do ispace=1,nspace
            is=ie+1
            ie=ie+morb(ispace)
            ne=0
            do i=is,ie
              if(iocc(i)) ne=ne+1
            end do
            if(ne.lt.mine(ispace) .or. maxe(ispace).lt.ne) go to 126
          end do
c       end if
c
        nci=nci+1
        lrdet(nci)=idet
  126   continue
      end do
      end
      subroutine os_make_tables(lrf2or,lor2rf,lrfocc,lorocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 23, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrf2or(  nci),lor2rf(  ndet)
      dimension lrfocc(2,nci),lorocc(2,ndet)
c
c     logical   iocc(NSOMAX)
c     logical   iphase,jphase, kphase(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_make_tables ",45(1h*))')
        call ut_init_time
      END IF
c
c**** Read references **************************************************
      call seqrew(lunref)       ! rewind lunref
      read(lunref) lrf2or
c
c**** Original det -> reference det ************************************
      call viclr(lor2rf,1,ndet)
c
      do i=1,nci
        lor2rf(lrf2or(i))=i
      end do
c
c**** Det -> occ *******************************************************
      call viclr(lrfocc,1,2*nci)
      do i=1,nci
        call os_det2int(lrf2or(i),lrfocc(1,i),0)
      end do
c
      call viclr(lorocc,1,2*ndet)
      do i=1,ndet
        call os_det2int(       i ,lorocc(1,i),0)
      end do
c
c**** Write results on files *******************************************
      call seqrew(luno2r)       ! rewind luno2r
      call seqrew(lunroc)       ! rewind lunroc
      call seqrew(lunooc)       ! rewind lunooc
      write(luno2r) lor2rf
      write(lunroc) lrfocc
      write(lunooc) lorocc
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_0
     *  (numpq ,
     *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl1,v     ,
     *   ejdeti,h     ,list  ,lod2nd)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
      dimension u(nmo,nmo)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl1(iniwgt:laswgt,nstate)
c
c     v=ve
      dimension v(inipex:laspex,inidoc:lasact,
     *            iniact:lasact,inidoc:lasact)
c
      dimension ejdeti(nstate)
      dimension h(2,2,nstate)
      dimension list(3,numpq)
c     dimension lod2nd(min(nci00,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(nci00)
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" ***   0 -ionized ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute 0-ionized terms ******************************************
      call seqrew(lunr00)       ! rewind lunr00
      last=0
   98 continue
      read(lunr00) length
      call os_lab_read(lunr00,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///      read(lunr00) lod2nd
c
c     do jdeti=1,nstrx(0)
      do jdetx=init,last
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1,nci00
c///    jdeti=lod2nd(jdetx)
c
        call os_make_cc_pq(numpq,numelm,jdeti,list,lor2rf,jocc)
        call os_occ2det(ideto,jocc,0)
        if(ideto.gt.0) then
          idetrx=lor2rf(ideto)
        else
          idetrx=0
        end if
        if(numelm.eq.0 .and. idetrx.eq.0) go to 102  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do ki=inidoc,lasdoc
          isymi=mos(ki)
        do ke=inipex,laspex  ! do ke=iniext,lasext
          isyme=ieor(isymi,mos(ke))
          call vclr(h,1,4*nstate)
          do m=1,numelm
            mp   =list(1,m)
            mq   =list(2,m)
            idetr=list(3,m)
            lp =lso2mo(mp)+nmocor
            lq =lso2mo(mq)+nmocor
c
            if(ieor(isyme,ieor(mos(lp),mos(lq))).ne.0)
     *        go to 100         ! cycle
            if(v(ke,ki,lq,lp).eq.ZERO .and. v(ke,lp,lq,ki).eq.ZERO)
     *        go to 100         ! cycle
c
            isp=mospn (mp)
            isq=mospn (mq)
c
            if(idetr.gt.0) then
              if(isp.eq.isq) then
                do istate=1,nstate
                  h(1,1,istate)=h(1,1,istate)
     *              +v(ke,ki,lq,lp)*ev( idetr,istate)
                  h(2,2,istate)=h(2,2,istate)
     *              +v(ke,ki,lq,lp)*ev( idetr,istate)
                end do
              end if
              do istate=1,nstate
                h(isp,isq,istate)=h(isp,isq,istate)
     *            -v(ke,lp,lq,ki)*ev( idetr,istate)
              end do
            else
              if(isp.eq.isq) then
                do istate=1,nstate
                  h(1,1,istate)=h(1,1,istate)
     *              -v(ke,ki,lq,lp)*ev(-idetr,istate)
                  h(2,2,istate)=h(2,2,istate)
     *              -v(ke,ki,lq,lp)*ev(-idetr,istate)
                end do
              end if
              do istate=1,nstate
                h(isp,isq,istate)=h(isp,isq,istate)
     *            +v(ke,lp,lq,ki)*ev(-idetr,istate)
              end do
            end if
  100       continue
          end do
c
          if(isyme.eq.0 .and. idetrx.ne.0 .and. u(ki,ke).ne.ZERO) then
            do istate=1,nstate
              h(1,1,istate)=h(1,1,istate)+u(ki,ke)*ev(idetrx,istate)
              h(2,2,istate)=h(2,2,istate)+u(ki,ke)*ev(idetrx,istate)
            end do
          end if
c
          do jstate=1,nstate
c         do isi=1,2
c         do ise=1,2
c           if(abs(h(ise,isi,jstate)).gt.thrgen) then
c             de=e(ke,ise,jstate)-e(ki,isi,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(ise,isi,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,0)=heff2(istate,jstate,0)
c    *              -h(ise,isi,istate)*hde
c               end do
c             end if
c           end if
c         end do
c         end do
            isi=1
            ise=1
            if(abs(h(ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
     *              -h(ise,isi,istate)*hde
                end do
              end if
            end if
            isi=1
            ise=2
            if(abs(h(ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
     *              -h(ise,isi,istate)*hde
                end do
              end if
            end if
            isi=2
            ise=1
            if(abs(h(ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
     *              -h(ise,isi,istate)*hde
                end do
              end if
            end if
            isi=2
            ise=2
            if(abs(h(ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
     *              -h(ise,isi,istate)*hde
                end do
              end if
            end if
          end do
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
c           do isi=1,2
c           do ise=1,2
c             if(abs(h(ise,isi,jstate)).gt.thrgen) then
c               de=e(ke,ise,jstate)-e(ki,isi,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(ise,isi,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2
c                 end if
c               end if
c             end if
c           end do
c           end do
              isi=1
              ise=1
              if(abs(h(ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              isi=1
              ise=2
              if(abs(h(ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              isi=2
              ise=1
              if(abs(h(ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              isi=2
              ise=2
              if(abs(h(ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
            end do
          end if
c
        end do
        end do
  102   continue
      end do
c
      if(last.lt.nci00) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[0-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,0),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_0r
     *  (ev    ,e     ,edet  ,eref  ,mos   ,heff2 ,wfovl1,h     ,v     ,
     *   inimo ,lasmo )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate)
      dimension edet(nci,0:nstate), eref(nstate,0:nstate)
c     dimension u(nmo,nmo)
c     dimension lrf2or(nci), lor2rf(ndet)
      dimension mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl1(iniwgt:laswgt,nstate)
c
      dimension h(2,2,nstate)
      dimension v(inidoc:lasact,inidoc:lasact,
     *            inipex:laspex,inimo :lasmo )
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" ***   0 -ionized (r) ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
      rthalf=sqrt(HALF)
c
      if(GOPARR) then
        call DDI_BCAST(5000,'F',ev  ,nci*nstate       ,MASTER)
        call DDI_BCAST(5000,'F',e   ,nmo*2*(nstate+1) ,MASTER)
        call DDI_BCAST(5000,'F',edet,nci*(nstate+1)   ,MASTER)
        call DDI_BCAST(5000,'F',eref,nstate*(nstate+1),MASTER)
        call DDI_BCAST(5000,'I',mos ,nmo              ,MASTER)
      end if
c
c**** Compute 0-ionized terms ******************************************
c
c     MP2 formula
c
      if(krot) then
c
      do ke=inipex         ,laspex  ! do ke=iniext         ,lasext
        isyme=           mos(ke)
      do kf=inimo          ,lasmo
        isymf=ieor(isyme,mos(kf))
      do ki=inidoc         ,lasdoc
        isymi=ieor(isymf,mos(ki))
      do kj=inidoc         ,lasdoc
c
        if(ieor(isymi,mos(kj)).ne.0)
     *    go to 100             ! cycle
        if(v(ki,kj,ke,kf).eq.ZERO .and. v(kj,ki,ke,kf).eq.ZERO)
     *    go to 100             ! cycle
c
        do istate=1,nstate
          h(1,1,istate)
     *      =(v(ki,kj,ke,kf)-v(kj,ki,ke,kf))*HALF
          h(1,2,istate)
     *      = v(ki,kj,ke,kf)                *rthalf
          h(2,1,istate)
     *      = v(ki,kj,ke,kf)                *rthalf
          h(2,2,istate)
     *      =(v(ki,kj,ke,kf)-v(kj,ki,ke,kf))*HALF
        end do
c
        do jstate=1,nstate
c         do isei=1,2
c         do isfj=1,2
c           if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c             de= e(ke,isei,jstate)-e(ki,isei,jstate)
c    *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c             de=de+edshft/de
c             hde=h(isei,isfj,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
c    *            -h(isei,isfj,jstate)*hde
c             end if
c           end if
c         end do
c         end do
          isei=1
          isfj=1
          if(abs(h(isei,isfj,jstate)).gt.thrgen) then
            de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *         +e(kf,isfj,jstate)-e(kj,isfj,jstate)
            de=de+edshft/de
            hde=h(isei,isfj,jstate)/de
            if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
            if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
              heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *          -h(isei,isfj,jstate)*hde
            end if
          end if
          isei=1
          isfj=2
          if(abs(h(isei,isfj,jstate)).gt.thrgen) then
            de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *         +e(kf,isfj,jstate)-e(kj,isfj,jstate)
            de=de+edshft/de
            hde=h(isei,isfj,jstate)/de
            if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
            if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
              heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *          -h(isei,isfj,jstate)*hde
            end if
          end if
          isei=2
          isfj=1
          if(abs(h(isei,isfj,jstate)).gt.thrgen) then
            de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *         +e(kf,isfj,jstate)-e(kj,isfj,jstate)
            de=de+edshft/de
            hde=h(isei,isfj,jstate)/de
            if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
            if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
              heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *          -h(isei,isfj,jstate)*hde
            end if
          end if
          isei=2
          isfj=2
          if(abs(h(isei,isfj,jstate)).gt.thrgen) then
            de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *         +e(kf,isfj,jstate)-e(kj,isfj,jstate)
            de=de+edshft/de
            hde=h(isei,isfj,jstate)/de
            if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
            if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
              heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *          -h(isei,isfj,jstate)*hde
            end if
          end if
        end do
c
c       Reference weights
c
        if(iwgt.ne.0) then
          do jstate=1,nstate
c           do isei=1,2
c           do isfj=1,2
c             if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c               de= e(ke,isei,jstate)-e(ki,isei,jstate)
c    *             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c               de=de+edshft/de
c               hde=h(isei,isfj,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kf,jstate)=wfovl1(kf,jstate)
c    *                +hde**2*HALF
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kj,jstate)=wfovl1(kj,jstate)
c    *                +hde**2*HALF
c                 end if
c               end if
c             end if
c           end do
c           end do
            isei=1
            isfj=1
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                if(iwgt.eq.1) then
                  wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *              +hde**2*HALF
                  wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *              +hde**2*HALF
                else
                  wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *              +hde**2*HALF
                  wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *              +hde**2*HALF
                end if
              end if
            end if
            isei=1
            isfj=2
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                if(iwgt.eq.1) then
                  wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *              +hde**2*HALF
                  wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *              +hde**2*HALF
                else
                  wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *              +hde**2*HALF
                  wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *              +hde**2*HALF
                end if
              end if
            end if
            isei=2
            isfj=1
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                if(iwgt.eq.1) then
                  wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *              +hde**2*HALF
                  wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *              +hde**2*HALF
                else
                  wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *              +hde**2*HALF
                  wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *              +hde**2*HALF
                end if
              end if
            end if
            isei=2
            isfj=2
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                if(iwgt.eq.1) then
                  wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *              +hde**2*HALF
                  wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *              +hde**2*HALF
                else
                  wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *              +hde**2*HALF
                  wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *              +hde**2*HALF
                end if
              end if
            end if
          end do
        end if
  100   continue
      end do
      end do
      end do
      end do
c
c
c     *** Original formula ***
c
      else
c
      do ke=inipex         ,laspex  ! do ke=iniext         ,lasext
        isyme=           mos(ke)
      do kf=inimo          ,lasmo
        isymf=ieor(isyme,mos(kf))
      do ki=inidoc         ,lasdoc
        isymi=ieor(isymf,mos(ki))
      do kj=inidoc         ,lasdoc
c
        if(ieor(isymi,mos(kj)).ne.0)
     *    go to 102             ! cycle
        if(v(ki,kj,ke,kf).eq.ZERO .and. v(kj,ki,ke,kf).eq.ZERO)
     *    go to 102             ! cycle
c
        do idetr=1,nci
c
          do istate=1,nstate
            h(1,1,istate)
     *        =(v(ki,kj,ke,kf)-v(kj,ki,ke,kf))*ev(idetr,istate)*HALF
            h(1,2,istate)
     *        = v(ki,kj,ke,kf)                *ev(idetr,istate)*RTHALF
            h(2,1,istate)
     *        = v(ki,kj,ke,kf)                *ev(idetr,istate)*RTHALF
            h(2,2,istate)
     *        =(v(ki,kj,ke,kf)-v(kj,ki,ke,kf))*ev(idetr,istate)*HALF
          end do
c
c         Off-diagonal elements omitting
c
          do jstate=1,nstate
c           do isei=1,2
c           do isfj=1,2
c             if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c               de= e(ke,isei,jstate)-e(ki,isei,jstate)
c    *             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c    *             +edet(idetr,jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(isei,isfj,jstate)/de
c               if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
c    *              -h(isei,isfj,jstate)*hde
c               end if
c             end if
c           end do
c           end do
            isei=1
            isfj=1
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *           +edet(idetr,jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *            -h(isei,isfj,jstate)*hde
              end if
            end if
            isei=1
            isfj=2
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *           +edet(idetr,jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *            -h(isei,isfj,jstate)*hde
              end if
            end if
            isei=2
            isfj=1
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *           +edet(idetr,jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *            -h(isei,isfj,jstate)*hde
              end if
            end if
            isei=2
            isfj=2
            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
              de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *           +edet(idetr,jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(isei,isfj,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                heff2(jstate,jstate,0)=heff2(jstate,jstate,0)
     *            -h(isei,isfj,jstate)*hde
              end if
            end if
          end do
c
c         Original
c
c$$$          do jstate=1,nstate
c$$$c           do isei=1,2
c$$$c           do isfj=1,2
c$$$c             if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c$$$c               de= e(ke,isei,jstate)-e(ki,isei,jstate)
c$$$c    $             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c$$$c    $             +edet(idetr,jstate)-eref(jstate,jstate)
c$$$c               de=de+edshft/de
c$$$c               hde=h(isei,isfj,jstate)/de
c$$$c               if(abs(hde).gt.hdemax) hdemax=abs(hde)
c$$$c
c$$$c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c$$$c                 do istate=1,nstate
c$$$c                   heff2(istate,jstate,0)=heff2(istate,jstate,0)
c$$$c    $                -h(isei,isfj,istate)*hde
c$$$c                 end do
c$$$c               end if
c$$$c             end if
c$$$c           end do
c$$$c           end do
c$$$            isei=1
c$$$            isfj=1
c$$$            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c$$$              de= e(ke,isei,jstate)-e(ki,isei,jstate)
c$$$     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c$$$     *           +edet(idetr,jstate)-eref(jstate,jstate)
c$$$              de=de+edshft/de
c$$$              hde=h(isei,isfj,jstate)/de
c$$$              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c$$$
c$$$              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c$$$                do istate=1,nstate
c$$$                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
c$$$     *              -h(isei,isfj,istate)*hde
c$$$                end do
c$$$              end if
c$$$            end if
c$$$            isei=1
c$$$            isfj=2
c$$$            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c$$$              de= e(ke,isei,jstate)-e(ki,isei,jstate)
c$$$     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c$$$     *           +edet(idetr,jstate)-eref(jstate,jstate)
c$$$              de=de+edshft/de
c$$$              hde=h(isei,isfj,jstate)/de
c$$$              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c$$$
c$$$              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c$$$                do istate=1,nstate
c$$$                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
c$$$     *              -h(isei,isfj,istate)*hde
c$$$                end do
c$$$              end if
c$$$            end if
c$$$            isei=2
c$$$            isfj=1
c$$$            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c$$$              de= e(ke,isei,jstate)-e(ki,isei,jstate)
c$$$     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c$$$     *           +edet(idetr,jstate)-eref(jstate,jstate)
c$$$              de=de+edshft/de
c$$$              hde=h(isei,isfj,jstate)/de
c$$$              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c$$$
c$$$              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c$$$                do istate=1,nstate
c$$$                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
c$$$     *              -h(isei,isfj,istate)*hde
c$$$                end do
c$$$              end if
c$$$            end if
c$$$            isei=2
c$$$            isfj=2
c$$$            if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c$$$              de= e(ke,isei,jstate)-e(ki,isei,jstate)
c$$$     *           +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c$$$     *           +edet(idetr,jstate)-eref(jstate,jstate)
c$$$              de=de+edshft/de
c$$$              hde=h(isei,isfj,jstate)/de
c$$$              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c$$$
c$$$              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c$$$                do istate=1,nstate
c$$$                  heff2(istate,jstate,0)=heff2(istate,jstate,0)
c$$$     *              -h(isei,isfj,istate)*hde
c$$$                end do
c$$$              end if
c$$$            end if
c$$$          end do
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
c             do isei=1,2
c             do isfj=1,2
c               if(abs(h(isei,isfj,jstate)).gt.thrgen) then
c                 de= e(ke,isei,jstate)-e(ki,isei,jstate)
c    *               +e(kf,isfj,jstate)-e(kj,isfj,jstate)
c    *               +edet(idetr,jstate)-eref(jstate,jstate)
c                 de=de+edshft/de
c                 hde=h(isei,isfj,jstate)/de
c
c                 if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                   if(iwgt.eq.1) then
c                     wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                  +hde**2*HALF
c                     wfovl1(kf,jstate)=wfovl1(kf,jstate)
c    *                  +hde**2*HALF
c                   else
c                     wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                  +hde**2*HALF
c                     wfovl1(kj,jstate)=wfovl1(kj,jstate)
c    *                  +hde**2*HALF
c                   end if
c                 end if
c               end if
c             end do
c             end do
              isei=1
              isfj=1
              if(abs(h(isei,isfj,jstate)).gt.thrgen) then
                de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *             +edet(idetr,jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(isei,isfj,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              isei=1
              isfj=2
              if(abs(h(isei,isfj,jstate)).gt.thrgen) then
                de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *             +edet(idetr,jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(isei,isfj,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              isei=2
              isfj=1
              if(abs(h(isei,isfj,jstate)).gt.thrgen) then
                de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *             +edet(idetr,jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(isei,isfj,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              isei=2
              isfj=2
              if(abs(h(isei,isfj,jstate)).gt.thrgen) then
                de= e(ke,isei,jstate)-e(ki,isei,jstate)
     *             +e(kf,isfj,jstate)-e(kj,isfj,jstate)
     *             +edet(idetr,jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(isei,isfj,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
            end do
          end if
c
        end do
  102   continue
      end do
      end do
      end do
      end do
c
      end if
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2(0-ionized) ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,0),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_int_calc_sd
     *  (inidet,lasdet,ncisd ,lengsd,nbuf  ,ininsd,lasnsd,
     *   ev    ,e     ,eref  ,u     ,lrf2or,heff2 ,wfovli,v     ,ksdtab,
     *   lrec  ,vrec  ,sdvec,lsdr2o ,edetsd)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 28, 2007 by HN                 ===
c=======================================================================
c
c     Note1: Phase
c       .false.: positive phase; .true.: negative phase
c
c     Note2: spin-orbitals and spatial orbitals
c       lp,lq,lr,ls: spin-orbitals; mp,mq,mr,ms: spatial orbitals
c
c       (This notation is reverse to the mcqdpt0,1,2,3 routines !!!)
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate)
      dimension eref(nstate,0:nstate)
      dimension u(nmo,nmo)
      dimension lrf2or(nci)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovli(nstate)
c
c     v=vi
      dimension v(iniact:lasact,inidoc:lasact,
     *            iniact:lasact,inidoc:lasact)
c
      dimension ksdtab(inidet:lasdet)
      dimension lrec(lengsd), vrec(lengsd)
      dimension sdvec(nbuf,nstate), lsdr2o(nbuf)
      dimension edetsd(nbuf)
c
      dimension locc(NSOMAX), lvir(NSOMAX)
      logical   jocc(NSOMAX), kphase(NSOMAX)
      logical iphas1,iphas2,iphase
      logical kloop
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" SD-determinant calculation")')
        call ut_init_time
      END IF
c
      if(inidet.gt.lasdet .or. ncisd.le.0 .or. ininsd.gt.lasnsd)
     *  go to 108
c
c**** Initialize sdvec *************************************************
      call vclr(sdvec,1,nbuf*nstate)
c
      ioff=ininsd-1
c
c**** Make lsdr2o ******************************************************
      n=0
c$$$      do isddet=inidet,lasdet
c$$$c     do isddet=1,nsddet
c$$$        ielm=(isddet-1)/INTBIT+1
c$$$        ibit=mod(isddet-1,INTBIT)
c$$$        if( btest(ksdtab(ielm),ibit) ) then
c$$$          n=n+1
c$$$          if(ininsd.le.n .and. n.le.lasnsd) then
c$$$            lsdr2o(n-ioff)=isddet
c$$$            if(n.eq.ininsd) isdmin=isddet
c$$$            if(n.eq.lasnsd) isdmax=isddet
c$$$          end if
c$$$        end if
c$$$      end do
      do isddet=inidet,lasdet
        if(ksdtab(isddet).ne.0) then
          n=n+1
          if(ininsd.le.n .and. n.le.lasnsd) then
            lsdr2o(n-ioff)=isddet
            ksdtab(isddet)=n-ioff
            if(n.eq.ininsd) isdmin=isddet
            if(n.eq.lasnsd) isdmax=isddet
          else
            ksdtab(isddet)=-1
          end if
        end if
      end do
      if(n.ne.ncisd) stop 'n/=ncisd'
c
c**** Compute 1st-order interacting vectors ****************************
      do jci=1,nci
c     do jci=1+me,nci,nproc              ! Jref
c
c       Pre-screening   Check! Check! Check! Check! Check! Check! Check!
c
        kloop=.false.
        do istate=1,nstate
          if(abs(ev(jci,istate)).gt.thrgen) kloop=.true.
        end do
        if(.not.kloop) go to 106
c
        jdet=lrf2or(jci)        ! Jorg
        call os_det2occi(jdet,jocc,0)  ! Jpattern
        nocc=0
        nvir=0
        iphase=.false.
        do i=1,nsoact
          if(jocc(i)) then
            nocc=nocc+1
            locc(nocc)=i
            kphase(i)=iphase
            iphase=.not.iphase
          else
            nvir=nvir+1
            lvir(nvir)=i
            kphase(i)=iphase
          end if
        end do
c
        n=0
c
c       Singles (pure singles)
c
        do j=1,nocc
          lq=locc(j)
c         lvir(nvir+1)=lq
          jocc(lq)=.false.      ! jqocc=ibclr(jocc ,lq-1)
          do i=1,nvir
c         do i=1,nvir+1
            lp=lvir(i)
            jocc(lp)=.true.     ! iocc =ibset(jqocc,lp-1)
            if(mospn(lp).ne.mospn(lq) .or.
     *         mosym(lp).ne.mosym(lq)     ) go to 100
            call os_occ2deti(isddet,jocc,-4)
            if(isddet.lt.isdmin .or. isdmax.lt.isddet) go to 100
c           if(isddet        .le.0) go to 100
            if(ksdtab(isddet).le.0) go to 100
            if(lp.le.lq) then
              iphase=kphase(lp).eqv. kphase(lq)
            else
              iphase=kphase(lp).neqv.kphase(lq)
            end if
            mp=lso2mo( lp )+nmocor
            mq=lso2mo( lq )+nmocor
            if(iphase) then
              s=-u(mp,mq)
              do k=1,nocc
                ls=locc(k)
                ms=lso2mo( ls )+nmocor
                s=s-v(mp,mq,ms,ms)
                if(mospn(lp).eq.mospn(ls)) s=s+v(mp,ms,ms,mq)
              end do
            else
              s= u(mp,mq)
              do k=1,nocc
                ls=locc(k)
                ms=lso2mo( ls )+nmocor
                s=s+v(mp,mq,ms,ms)
                if(mospn(lp).eq.mospn(ls)) s=s-v(mp,ms,ms,mq)
              end do
            end if
            n=n+1
            lrec(n)=isddet
            vrec(n)=s
c
  100       continue
            jocc(lp)=.false.    ! iocc =ibset(jqocc,lp-1)
          end do
          jocc(lq)=.true.
        end do
c
c       Doubles (pure doubles)
c
        do j=1,nocc
          lq=locc(j)
c         lvir(nvir+1)=lq
          jocc(lq)=.false.      ! jqocc =ibclr(jocc  ,lq-1)
          jspn=mospn(lq)
          jsym=mosym(lq)
          do l=1,j-1
            ls=locc(l)
c           lvir(nvir+2)=ls
            jocc(ls)=.false.    ! jsqocc=ibclr(jqocc ,ls-1)
            lspn=          mospn(ls)
            lsym=ieor(jsym,mosym(ls))
            iphas1=kphase(lq).eqv.kphase(ls)
            do k=1,nvir
c           do k=1,nvir+2
              lr=lvir(k)
              jocc(lr)=.true.   ! jrsqoc=ibset(jsqocc,lr-1)
              kspn=          mospn(lr)
              ksym=ieor(lsym,mosym(lr))
              iphas2=iphas1.eqv.kphase(lr)
              do i=1,k-1
                lp=lvir(i)
                jocc(lp)=.true. ! iocc  =ibset(jrsqoc,lp-1)
                ispn=          mospn(lp)
                isym=ieor(ksym,mosym(lp))
                if(isym.ne.0 .or.
     *             ((ispn.ne.jspn .or. kspn.ne.lspn) .and.
     *              (ispn.ne.lspn .or. kspn.ne.jspn)      ) ) go to 102
                call os_occ2deti(isddet,jocc,-4)
                if(isddet.lt.isdmin .or. isdmax.lt.isddet) go to 102
c               if(isddet        .le.0) go to 102
                if(ksdtab(isddet).le.0) go to 102
c
                if(lp.lt.lr) then
                  if( (lp.le.ls .and. ls.lt.lr .and. lr.le.lq) .or.
     *                (ls.lt.lp .and. lp.le.lq .and. lq.lt.lr) ) then
c                   iphase=.not.(iphas2.eqv. kphase(lp))
                    iphase=      iphas2.neqv.kphase(lp)
                  else
                    iphase=      iphas2.eqv. kphase(lp)
                  end if
                else
                  if( (lr.le.ls .and. ls.lt.lp .and. lp.le.lq) .or.
     *                (ls.lt.lr .and. lr.le.lq .and. lq.lt.lp) ) then
                    iphase=      iphas2.eqv. kphase(lp)
                  else
                    iphase=      iphas2.neqv.kphase(lp)
                  end if
                end if
c
                mp=lso2mo( lp )+nmocor
                mq=lso2mo( lq )+nmocor
                mr=lso2mo( lr )+nmocor
                ms=lso2mo( ls )+nmocor
                if(     mospn(lp).eq.mospn(lq) .and.
     *                  mospn(lp).eq.mospn(ls)      ) then
                  if(iphase) then
                    s = -v(mp,mq,mr,ms)+v(mp,ms,mr,mq)
                  else
                    s =  v(mp,mq,mr,ms)-v(mp,ms,mr,mq)
                  end if
                else if(mospn(lp).eq.mospn(lq) .and.
     *                  mospn(lp).ne.mospn(ls)      ) then
                  if(iphase) then
                    s = -v(mp,mq,mr,ms)
                  else
                    s =  v(mp,mq,mr,ms)
                  end if
                else if(mospn(lp).ne.mospn(lq) .and.
     *                  mospn(lp).eq.mospn(ls)      ) then
                  if(iphase) then
                    s =                 v(mp,ms,mr,mq)
                  else
                    s =                -v(mp,ms,mr,mq)
                  end if
                else
                  go to 102
                end if
c
c               if(iphase) then
c                 s= -v(mp,mq,mr,ms)+v(mp,ms,mr,mq)
c               else
c                 s=  v(mp,mq,mr,ms)-v(mp,ms,mr,mq)
c               end if
c
                n=n+1
                lrec(n)=isddet
                vrec(n)=s
c
  102           continue
                jocc(lp)=.false.
              end do
c 104         continue
              jocc(lr)=.false.
            end do
            jocc(ls)=.true.
          end do
          jocc(lq)=.true.
        end do
c
c       Make (internal) first-order vectors
c
        do i     =1,n
          icisd=ksdtab(lrec(i))
          if(icisd.gt.0) then
            do istate=1,nstate
              sdvec(icisd,istate)=sdvec(icisd,istate)
     *          +vrec(i)*ev(jci,istate)
            end do
          end if
        end do
c
  106   continue
c
      end do
c
c**** Compute SD-contribution ******************************************
      do jstate=1,nstate
c
c       Compute edetsd:
c         If memory allows edetsd(ncisd,nstate), this part can be moved
c         to the outside of this loop and become nstate times faster.
c
        ec=ZERO
c       do i=1,lasdoc
c         ec=ec+e(i,1,jstate)+e(i,2,jstate)
c       end do
c         ec=sum(e(1:lasdoc,jstate))
        do i=1,nbuf
c       do i=1+me,nbuf,nproc
          edetsd(i)=ec
        end do
c
        do icisd=1,nbuf
c       do icisd=1+me,nbuf,nproc
          isddet=lsdr2o(icisd)
          call os_det2occi(isddet,jocc,-4)
          do i=1,nsoact
            imo=lso2mo(i)+nmocor
            is =mospn (i)
            if(jocc(i)) edetsd(icisd)=edetsd(icisd)+e(imo,is,jstate)
c           if(btest(iocc,i)) edetsd(icisd)=edetsd(icisd)
c     *                                    +e(i+iniact,jstate)
          end do
        end do
c
        do istate=1,nstate
          do icisd=1,nbuf
c         do icisd=1+me,nbuf,nproc
            de=(eref(jstate,jstate)-edetsd(icisd))
            de=de+edshft/de
            hde=sdvec(icisd,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
            if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
              heff2(istate,jstate,0)=heff2(istate,jstate,0)
     *          + sdvec(icisd,istate) * hde
            end if
          end do
        end do
c
c       Wavefunction overlap
c
        if(iwgt.ne.0) then
          do icisd=1,nbuf
c         do icisd=1+me,nbuf,nproc
            de=(eref(jstate,jstate)-edetsd(icisd))
            de=de+edshft/de
            hde=sdvec(icisd,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
            if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
              wfovli(jstate)=wfovli(jstate)
     *          + hde**2
            end if
          end do
        end if
      end do
c
c**** Debug output *****************************************************
  108 continue
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2(internal) ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,0),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_int_make_sd
     *  (inidet,lasdet,mcisd ,ncisd ,ev    ,lrf2or,ksdtab)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 28, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate),lrf2or(nci)
      dimension ksdtab(inidet:lasdet)
c
      dimension locc(NSOMAX), lvir(NSOMAX)
      logical   jocc(NSOMAX)
      logical kloop
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** Internal ***"/
     *                 " SD-determinant construction")')
        call ut_init_time
      END IF
c
      if(inidet.gt.lasdet) go to 102
c
c**** Read ref->det label **********************************************
      call seqrew(lunref)       ! rewind lunref
      read(lunref) lrf2or
c
c**** Make SD dets *****************************************************
      call viclr(ksdtab,1,lasdet-inidet+1)
c     call viclr(ksdtab,1,nsddet)
c
      do jci=1,nci              ! Jref
c
c       Pre-screening   Check! Check! Check! Check! Check! Check! Check!
c
        kloop=.false.
        do istate=1,nstate
          if(abs(ev(jci,istate)).gt.thrgen) kloop=.true.
        end do
        if(.not.kloop) go to 100
c
        jdet=lrf2or(jci)        ! Jorg
        call os_det2occi(jdet,jocc,0) ! Jpattern
c
c       Get occ and vir orbs.
c
        nocc=0
        nvir=0
        do i=1,nsoact
          if(jocc(i)) then
            nocc=nocc+1
            locc(nocc)=i
          else
            nvir=nvir+1
            lvir(nvir)=i
          end if
        end do
c
c       Make pure S dets
c
        do j=1,nocc
          lq          =locc(j)
c         lvir(nvir+1)=lq
          jocc(lq)=.false.  ! jqocc=ibclr(jocc ,lq-1)
          do i=1,nvir
c         do i=1,nvir+1
            lp=lvir(i)
            jocc(lp)=.true.  ! iocc =ibset(jqocc,lp-1)
            if(mospn(lp).eq.mospn(lq) .and. mosym(lp).eq.mosym(lq)) then
              call os_occ2deti(isddet,jocc,-4)
              if(isddet.ge.inidet .and. isddet.le.lasdet) then
                ksdtab(isddet)=-1
              end if
            end if
            jocc(lp)=.false.
          end do
          jocc(lq)=.true.
        end do
c
c       Make pure D dets
c
        do j=1,nocc
          lq=locc(j)
c         lvir(nvir+1)=lq
          jocc(lq)=.false.  ! jqocc =ibclr(jocc  ,lq-1)
          jspn=mospn(lq)
          jsym=mosym(lq)
          do l=1,j-1
            ls=locc(l)
c           lvir(nvir+2)=ls
            jocc(ls)=.false.  ! jsqocc=ibclr(jqocc ,ls-1)
            lspn=          mospn(ls)
            lsym=ieor(jsym,mosym(ls))
            do k=1,nvir
c           do k=1,nvir+2
              lr=lvir(k)
              jocc(lr)=.true.  ! jrsqoc=ibset(jsqocc,lr-1)
              kspn=          mospn(lr)
              ksym=ieor(lsym,mosym(lr))
              do i=1,k-1
                lp=lvir(i)
                jocc(lp)=.true.  ! iocc  =ibset(jrsqoc,lp-1)
                ispn=          mospn(lp)
                isym=ieor(ksym,mosym(lp))
                if(isym.eq.0 .and.
     *             ((ispn.eq.jspn .and. kspn.eq.lspn) .or.
     *              (ispn.eq.lspn .and. kspn.eq.jspn)     ) ) then
                  call os_occ2deti(isddet,jocc,-4)
                  if(isddet.ge.inidet .and. isddet.le.lasdet) then
                    ksdtab(isddet)=-1
                  end if
                end if
                jocc(lp)=.false.
              end do
              jocc(lr)=.false.
            end do
            jocc(ls)=.true.
          end do
          jocc(lq)=.true.
        end do
  100   continue
      end do
c
c**** Clear reference determinants *************************************
      do jci=1,nci
        jdet=lrf2or(jci)        !Jorg
        call os_det2occi(jdet  ,jocc, 0)
        call os_occ2deti(isddet,jocc,-4)
        if(isddet.ge.inidet .and. isddet.le.lasdet) then
          ksdtab(isddet)=0
        end if
      end do
c
c**** Get ncisd value **************************************************
  102 continue
      ncisd=0
      do isddet=inidet,lasdet
        if(ksdtab(isddet).ne.0) ncisd=ncisd+1
      end do
      mcisd=ncisd
      if(GOPARR) call DDI_GSUMI(5000,mcisd,1)
      if(MASWRK) then
        write(lunout,
     *    '(" Dimension of internal CISD space     =",i10,
     *      "  (after screening)")') mcisd
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_m1
     *  (nump  ,numprs,
     *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,
     *   v     ,ejdeti,h     ,list2 ,list4 ,lod2nd)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
      dimension u(nmo,nmo)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl0(nstate), wfovl1(iniwgt:laswgt,nstate)
c
c     v=ve
      dimension v(inipex:laspex,inidoc:lasact,
     *            iniact:lasact,inidoc:lasact)
c
      dimension ejdeti(nstate)
      dimension h(2,nstate)
      dimension list2(2,nump), list4(4,numprs)
c     dimension lod2nd(min(ncim1,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(ncim1)
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** (-1)-ionized ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute (-1)-ionized terms ***************************************
      call seqrew(lunrm1)       ! rewind lunrm1
      last=0
   98 continue
      read(lunrm1) length
      call os_lab_read(lunrm1,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///  read(lunrm1) lod2nd
c
c     do jdeti=1,nstrx(-1)
      do jdetx=init,last
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1,ncim1
c///    jdeti=lod2nd(jdetx)
c
        call os_make_cc_prs(numprs,numel4,jdeti,list4,lor2rf,jocc)
        call os_make_cc_p  (nump  ,numel2,jdeti,list2,lor2rf,jocc)
        if(numel4.eq.0 .and. numel2.eq.0) go to 104  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do ke=inipex,laspex  ! do ke=iniext,lasext
          isyme=mos(ke)
          call vclr(h,1,2*nstate)
          do m=1,numel4
            mp   =list4(1,m)
            mr   =list4(2,m)
            ms   =list4(3,m)
            idetr=list4(4,m)
            lp =lso2mo(mp)+nmocor
            lr =lso2mo(mr)+nmocor
            ls =lso2mo(ms)+nmocor
c
            if(ieor(ieor(isyme,mos(lp)),ieor(mos(lr),mos(ls))).ne.0)
     *        go to 100         ! cycle
            if(v(ke,lp,ls,lr).eq.ZERO .and. v(ke,lr,ls,lp).eq.ZERO)
     *        go to 100         ! cycle
c
            isp=mospn (mp)
            isr=mospn (mr)
            iss=mospn (ms)
c
            if(isr.ne.iss .and. isp.ne.iss) go to 100  ! cycle
c
            if(idetr.gt.0) then
              if(isr.eq.iss) then
                do istate=1,nstate
                  h(isp,istate)=h(isp,istate)
     *              +v(ke,lp,ls,lr)*ev( idetr,istate)
                end do
              end if
              if(isp.eq.iss) then
                do istate=1,nstate
                  h(isr,istate)=h(isr,istate)
     *              -v(ke,lr,ls,lp)*ev( idetr,istate)
                end do
              end if
            else
              if(isr.eq.iss) then
                do istate=1,nstate
                  h(isp,istate)=h(isp,istate)
     *              -v(ke,lp,ls,lr)*ev(-idetr,istate)
                end do
              end if
              if(isp.eq.iss) then
                do istate=1,nstate
                  h(isr,istate)=h(isr,istate)
     *              +v(ke,lr,ls,lp)*ev(-idetr,istate)
                end do
              end if
            end if
  100       continue
          end do
c
          do m=1,numel2
            mp   =list2(1,m)
            idetr=list2(2,m)
            lp =lso2mo(mp)+nmocor
c
            if(ieor(isyme,mos(lp)).ne.0) go to 102  ! cycle
c
            isp=mospn (mp)
c
            if(idetr.gt.0) then
              do istate=1,nstate
                h(isp,istate)=h(isp,istate)+u(lp,ke)*ev( idetr,istate)
              end do
            else
              do istate=1,nstate
                h(isp,istate)=h(isp,istate)-u(lp,ke)*ev(-idetr,istate)
              end do
            end if
  102       continue
          end do
c
          do jstate=1,nstate
c         do is=1,2
c           if(abs(h(is,jstate)).gt.thrgen) then
c             de=e(ke,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(is,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
c    *              -h(is,istate)*hde
c               end do
c             end if
c           end if
c         end do
            is=1
            if(abs(h(is,jstate)).gt.thrgen) then
              de=e(ke,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(is,istate)*hde
                end do
              end if
            end if
            is=2
            if(abs(h(is,jstate)).gt.thrgen) then
              de=e(ke,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(is,istate)*hde
                end do
              end if
            end if
          end do
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(is,jstate)).gt.thrgen) then
c               de=e(ke,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(is,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2
c                 else
c                   wfovl0(   jstate)=wfovl0(   jstate)
c    *                +hde**2
c                 end if
c               end if
c             end if
c           end do
              is=1
              if(abs(h(is,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl0(   jstate)=wfovl0(   jstate)
     *                +hde**2
                  end if
                end if
              end if
              is=2
              if(abs(h(is,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl0(   jstate)=wfovl0(   jstate)
     *                +hde**2
                  end if
                end if
              end if
            end do
          end if
c
        end do
  104   continue
      end do
c
      if(last.lt.ncim1) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[(-1)-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,-1),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_m1r
     *  (nump  ,
     *   ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl1,ejdeti,list  ,
     *   h     ,lod2nd,v     ,inimo ,lasmo )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
c     dimension u(nmo,nmo)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl1(iniwgt:laswgt,nstate)
c
      dimension ejdeti(nstate)
      dimension list(2,nump)
c     dimension lod2nd(min(ncim1,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(ncim1)
c
      dimension h(2,2,2,nstate)
      dimension v(inidoc:lasact,inidoc:lasact,
     *            inipex:laspex,inimo :lasmo )
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** (-1)-ionized (r) ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute (-1)-ionized terms ***************************************
      call seqrew(lunrm1)       ! rewind lunrm1
      last=0
   98 continue
      read(lunrm1) length
      call os_lab_read(lunrm1,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///  read(lunrm1) lod2nd
c
c     do jdeti=1,nstrx(-1)
      do jdetx=init,last
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1,ncim1
c///    jdeti=lod2nd(jdetx)
c
        call os_make_cc_p(nump,numelm,jdeti,list,lor2rf,jocc)
        if(numelm.eq.0) go to 102  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do kf=inimo ,lasmo
          isymf=mos(kf)
c@@@@   do ke=iniext,lasext
        do ke=inipex,min(laspex,kf)  ! do ke=iniext,kf
          isyme=ieor(isymf,mos(ke))
        do ki=inidoc,lasdoc
          isymi=ieor(isyme,mos(ki))
          call vclr(h,1,8*nstate)
          do m=1,numelm
            mp   =list(1,m)
            idetr=list(2,m)
            lp =lso2mo(mp)+nmocor
c
            if(ieor(isymi,mos(lp)).ne.0)
     *        go to 100         ! cycle
            if(v(ki,lp,ke,kf).eq.ZERO .and. v(lp,ki,ke,kf).eq.ZERO)
     *        go to 100         ! cycle
c
            isp=mospn (mp)
            if(idetr.gt.0) then
              do istate=1,nstate
                h(1  ,isp,1,istate)=h(1  ,isp,1,istate)
     *            -v(ki,lp,ke,kf)*ev( idetr,istate)
                h(2  ,isp,2,istate)=h(2  ,isp,2,istate)
     *            -v(ki,lp,ke,kf)*ev( idetr,istate)
                h(isp,1  ,1,istate)=h(isp,1  ,1,istate)
     *            +v(lp,ki,ke,kf)*ev( idetr,istate)
                h(isp,2  ,2,istate)=h(isp,2  ,2,istate)
     *            +v(lp,ki,ke,kf)*ev( idetr,istate)
              end do
            else
              do istate=1,nstate
                h(1  ,isp,1,istate)=h(1  ,isp,1,istate)
     *            +v(ki,lp,ke,kf)*ev(-idetr,istate)
                h(2  ,isp,2,istate)=h(2  ,isp,2,istate)
     *            +v(ki,lp,ke,kf)*ev(-idetr,istate)
                h(isp,1  ,1,istate)=h(isp,1  ,1,istate)
     *            -v(lp,ki,ke,kf)*ev(-idetr,istate)
                h(isp,2  ,2,istate)=h(isp,2  ,2,istate)
     *            -v(lp,ki,ke,kf)*ev(-idetr,istate)
              end do
            end if
  100       continue
          end do
c
          do jstate=1,nstate
c         do is=1,2
c           if(abs(h(1,2,is,jstate)).gt.thrgen) then
c             de=e(ke,1,jstate)+e(kf,2,jstate)-e(ki,is,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(1,2,is,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
c    *              -h(1,2,is,istate)*hde
c               end do
c             end if
c           end if
c         end do
            is=1
            if(abs(h(1,2,is,jstate)).gt.thrgen) then
              de=e(ke,1,jstate)+e(kf,2,jstate)-e(ki,is,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(1,2,is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(1,2,is,istate)*hde
                end do
              end if
            end if
            is=2
            if(abs(h(1,2,is,jstate)).gt.thrgen) then
              de=e(ke,1,jstate)+e(kf,2,jstate)-e(ki,is,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(1,2,is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(1,2,is,istate)*hde
                end do
              end if
            end if
          end do
c
          if(ke.lt.kf) then
c@@@@
          do jstate=1,nstate
c<<<<
c         do is=1,2
c           if(abs(h(2,1,is,jstate)).gt.thrgen) then
c             de=e(ke,2,jstate)+e(kf,1,jstate)-e(ki,is,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(2,1,is,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
c    *              -h(2,1,is,istate)*hde
c               end do
c             end if
c           end if
c         end do
            is=1
            if(abs(h(2,1,is,jstate)).gt.thrgen) then
              de=e(ke,2,jstate)+e(kf,1,jstate)-e(ki,is,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(2,1,is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(2,1,is,istate)*hde
                end do
              end if
            end if
            is=2
            if(abs(h(2,1,is,jstate)).gt.thrgen) then
              de=e(ke,2,jstate)+e(kf,1,jstate)-e(ki,is,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(2,1,is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(2,1,is,istate)*hde
                end do
              end if
            end if
c         end do
c
c         do jstate=1,nstate
c         do ise=1,2
c         do isi=1,2
c           if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
c             de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(ise,ise,isi,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
c    *              -h(ise,ise,isi,istate)*hde
c               end do
c             end if
c           end if
c         end do
c         end do
            ise=1
            isi=1
            if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(ise,ise,isi,istate)*hde
                end do
              end if
            end if
            ise=1
            isi=2
            if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(ise,ise,isi,istate)*hde
                end do
              end if
            end if
            ise=2
            isi=1
            if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(ise,ise,isi,istate)*hde
                end do
              end if
            end if
            ise=2
            isi=2
            if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,ise,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-1)=heff2(istate,jstate,-1)
     *              -h(ise,ise,isi,istate)*hde
                end do
              end if
            end if
          end do
          end if
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(1,2,is,jstate)).gt.thrgen) then
c               de=e(ke,1,jstate)+e(kf,2,jstate)-e(ki,is,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(1,2,is,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kf,jstate)=wfovl1(kf,jstate)
c    *                +hde**2*HALF
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2
c                 end if
c               end if
c             end if
c           end do
              is=1
              if(abs(h(1,2,is,jstate)).gt.thrgen) then
                de=e(ke,1,jstate)+e(kf,2,jstate)-e(ki,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(1,2,is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              is=2
              if(abs(h(1,2,is,jstate)).gt.thrgen) then
                de=e(ke,1,jstate)+e(kf,2,jstate)-e(ki,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(1,2,is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
            end do
c
            if(ke.lt.kf) then
c@@@@
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(2,1,is,jstate)).gt.thrgen) then
c               de=e(ke,2,jstate)+e(kf,1,jstate)-e(ki,is,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(2,1,is,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kf,jstate)=wfovl1(kf,jstate)
c    *                +hde**2*HALF
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2
c                 end if
c               end if
c             end if
c           end do
              is=1
              if(abs(h(2,1,is,jstate)).gt.thrgen) then
                de=e(ke,2,jstate)+e(kf,1,jstate)-e(ki,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(2,1,is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              is=2
              if(abs(h(2,1,is,jstate)).gt.thrgen) then
                de=e(ke,2,jstate)+e(kf,1,jstate)-e(ki,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(2,1,is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
c           end do
c
c           do jstate=1,nstate
c           do ise=1,2
c           do isi=1,2
c             if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
c               de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(ise,ise,isi,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kf,jstate)=wfovl1(kf,jstate)
c    *                +hde**2*HALF
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2
c                 end if
c               end if
c             end if
c           end do
c           end do
              ise=1
              isi=1
              if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              ise=1
              isi=2
              if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              ise=2
              isi=1
              if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              ise=2
              isi=2
              if(abs(h(ise,ise,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)+e(kf,ise,jstate)-e(ki,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,ise,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
            end do
            end if
c
          end if
c
        end do
        end do
        end do
  102   continue
      end do
c
      if(last.lt.ncim1) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[(-1)-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,-1),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_m2r
     *  (numpr ,
     *   ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,ejdeti,
     *   list  ,h     ,lod2nd,v     ,inimo ,lasmo )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
c     dimension u(nmo,nmo)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl0(nstate), wfovl1(iniwgt:laswgt,nstate)
c
      dimension ejdeti(nstate)
      dimension list(3,numpr)
c     dimension lod2nd(min(ncim2,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(ncim2)
c
      dimension h(2,2,nstate)
      dimension v(inidoc:lasact,inidoc:lasact,
     *            inipex:laspex,inimo :lasmo )
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** (-2)-ionized (r) ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute (-2)-ionized terms ***************************************
      call seqrew(lunrm2)       ! rewind lunrm2
      last=0
   98 continue
      read(lunrm2) length
      call os_lab_read(lunrm2,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///  read(lunrm2) lod2nd
c
c     do jdeti=1,nstrx(-2)
      do jdetx=init,last
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1,ncim2
c       jdeti=lod2nd(jdetx)
c
        call os_make_cc_pr(numpr,numelm,jdeti,list,lor2rf,jocc)
        if(numelm.eq.0) go to 102  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do kf=inimo ,lasmo
          isymf=mos(kf)
        do ke=inipex,laspex  ! do ke=iniext,lasext
          isyme=ieor(isymf,mos(ke))
          call vclr(h,1,4*nstate)
          do m=1,numelm
            mp   =list(1,m)
            mr   =list(2,m)
            idetr=list(3,m)
            lp =lso2mo(mp)+nmocor
            lr =lso2mo(mr)+nmocor
c
            if(ieor(isyme,ieor(mos(lp),mos(lr))).ne.0)
     *        go to 100         ! cycle
            if(v(lp,lr,ke,kf).eq.ZERO .and. v(lr,lp,ke,kf).eq.ZERO)
     *        go to 100         ! cycle
c
            isp=mospn (mp)
            isr=mospn (mr)
c
            if(idetr.gt.0) then
              do istate=1,nstate
                h(isp,isr,istate)=h(isp,isr,istate)
     *            +v(lp,lr,ke,kf)*ev( idetr,istate)
                h(isr,isp,istate)=h(isr,isp,istate)
     *            -v(lr,lp,ke,kf)*ev( idetr,istate)
              end do
            else
              do istate=1,nstate
                h(isp,isr,istate)=h(isp,isr,istate)
     *            -v(lp,lr,ke,kf)*ev(-idetr,istate)
                h(isr,isp,istate)=h(isr,isp,istate)
     *            +v(lr,lp,ke,kf)*ev(-idetr,istate)
              end do
            end if
  100       continue
          end do
c
          do jstate=1,nstate
            if(abs(h(1,2,jstate)).gt.thrgen) then
              de=e(ke,1,jstate)+e(kf,2,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(1,2,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,-2)=heff2(istate,jstate,-2)
     *              -h(1,2,istate)*hde
                end do
              end if
            end if
          end do
c
          if(ke.lt.kf) then
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(is,is,jstate)).gt.thrgen) then
c               de=e(ke,is,jstate)+e(kf,is,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(is,is,jstate)/de
c               if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 do istate=1,nstate
c                   heff2(istate,jstate,-2)=heff2(istate,jstate,-2)
c    *                -h(is,is,istate)*hde
c                 end do
c               end if
c             end if
c           end do
              is=1
              if(abs(h(is,is,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)+e(kf,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,is,jstate)/de
                if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  do istate=1,nstate
                    heff2(istate,jstate,-2)=heff2(istate,jstate,-2)
     *                -h(is,is,istate)*hde
                  end do
                end if
              end if
              is=2
              if(abs(h(is,is,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)+e(kf,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,is,jstate)/de
                if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  do istate=1,nstate
                    heff2(istate,jstate,-2)=heff2(istate,jstate,-2)
     *                -h(is,is,istate)*hde
                  end do
                end if
              end if
            end do
          end if
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
              if(abs(h(1,2,jstate)).gt.thrgen) then
                de=e(ke,1,jstate)+e(kf,2,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(1,2,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2*HALF
                    wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                +hde**2*HALF
                  else
                    wfovl0(   jstate)=wfovl0(   jstate)
     *                +hde**2
                  end if
                end if
              end if
            end do
c
            if(ke.lt.kf) then
              do jstate=1,nstate
c             do is=1,2
c               if(abs(h(is,is,jstate)).gt.thrgen) then
c                 de=e(ke,is,jstate)+e(kf,is,jstate)
c    *              +ejdeti(jstate)-eref(jstate,jstate)
c                 de=de+edshft/de
c                 hde=h(is,is,jstate)/de
c
c                 if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                   if(iwgt.eq.1) then
c                     wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                  +hde**2*HALF
c                     wfovl1(kf,jstate)=wfovl1(kf,jstate)
c    *                  +hde**2*HALF
c                   else
c                     wfovl0(   jstate)=wfovl0(   jstate)
c    *                  +hde**2
c                   end if
c                 end if
c               end if
c             end do
                is=1
                if(abs(h(is,is,jstate)).gt.thrgen) then
                  de=e(ke,is,jstate)+e(kf,is,jstate)
     *              +ejdeti(jstate)-eref(jstate,jstate)
                  de=de+edshft/de
                  hde=h(is,is,jstate)/de
c
                  if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                    if(iwgt.eq.1) then
                      wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                  +hde**2*HALF
                      wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                  +hde**2*HALF
                    else
                      wfovl0(   jstate)=wfovl0(   jstate)
     *                  +hde**2
                    end if
                  end if
                end if
                is=2
                if(abs(h(is,is,jstate)).gt.thrgen) then
                  de=e(ke,is,jstate)+e(kf,is,jstate)
     *              +ejdeti(jstate)-eref(jstate,jstate)
                  de=de+edshft/de
                  hde=h(is,is,jstate)/de
c
                  if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                    if(iwgt.eq.1) then
                      wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                  +hde**2*HALF
                      wfovl1(kf,jstate)=wfovl1(kf,jstate)
     *                  +hde**2*HALF
                    else
                      wfovl0(   jstate)=wfovl0(   jstate)
     *                  +hde**2
                    end if
                  end if
                end if
              end do
            end if
          end if
c
        end do
        end do
  102   continue
      end do
c
      if(last.lt.ncim2) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[(-2)-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,-2),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_p1_1
     *  (numq  ,numrsq,
     *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,
     *   v     ,ejdeti,h     ,list2 ,list4 ,lod2nd)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
      dimension u(nmo,nmo)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl0(nstate), wfovl1(iniwgt:laswgt,nstate)
c
c     v=vi
      dimension v(iniact:lasact,inidoc:lasact,
     *            iniact:lasact,inidoc:lasact)
c
      dimension ejdeti(nstate)
      dimension h(2,nstate)
      dimension list2(2,numq  ), list4(4,numrsq)
c     dimension lod2nd(min(ncip1,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(ncip1)
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** (+1)-ionized ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute (+1)-ionized terms ***************************************
      call seqrew(lunrp1)       ! rewind lunrp1
      last=0
   98 continue
      read(lunrp1) length
      call os_lab_read(lunrp1,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///  read(lunrp1) lod2nd
c
c     do jdeti=1,nstrx(1)
      do jdetx=init+me,last,nproc  ! do jdetx=1,ncip1
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1+me,ncip1,nproc  ! do jdetx=1,ncip1
c///    jdeti=lod2nd(jdetx)
c
        call os_make_cc_rsq(numrsq,numel4,jdeti,list4,lor2rf,jocc)
        call os_make_cc_q  (numq  ,numel2,jdeti,list2,lor2rf,jocc)
        if(numel4.eq.0 .and. numel2.eq.0) go to 104  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do ki=inidoc,lasdoc
          isymi=mos(ki)
          call vclr(h,1,2*nstate)
          do m=1,numel4
            mr   =list4(1,m)
            ms   =list4(2,m)
            mq   =list4(3,m)
            idetr=list4(4,m)
            lr =lso2mo(mr)+nmocor
            ls =lso2mo(ms)+nmocor
            lq =lso2mo(mq)+nmocor
c
            if(ieor(ieor(isymi,mos(lr)),ieor(mos(ls),mos(lq))).ne.0)
     *        go to 100         ! cycle
            if(v(lq,ki,ls,lr).eq.ZERO .and. v(ls,ki,lq,lr).eq.ZERO)
     *        go to 100         ! cycle
c
            isr=mospn (mr)
            iss=mospn (ms)
            isq=mospn (mq)
c
            if(isr.ne.iss .and. isr.ne.isq) go to 100  ! cycle
c
            if(idetr.gt.0) then
              if(isr.eq.iss) then
                do istate=1,nstate
                  h(isq,istate)=h(isq,istate)
     *              -v(lq,ki,ls,lr)*ev( idetr,istate)
                end do
              end if
              if(isr.eq.isq) then
                do istate=1,nstate
                  h(iss,istate)=h(iss,istate)
     *              +v(ls,ki,lq,lr)*ev( idetr,istate)
                end do
              end if
            else
              if(isr.eq.iss) then
                do istate=1,nstate
                  h(isq,istate)=h(isq,istate)
     *              +v(lq,ki,ls,lr)*ev(-idetr,istate)
                end do
              end if
              if(isr.eq.isq) then
                do istate=1,nstate
                  h(iss,istate)=h(iss,istate)
     *              -v(ls,ki,lq,lr)*ev(-idetr,istate)
                end do
              end if
            end if
  100       continue
          end do
c
          do m=1,numel2
            mq   =list2(1,m)
            idetr=list2(2,m)
            lq =lso2mo(mq)+nmocor
c
            if(ieor(isymi,mos(lq)).ne.0) go to 102  ! cycle
            if(u(ki,lq).eq.ZERO)         go to 102  ! cycle
c
            isq=mospn (mq)
c
            if(idetr.gt.0) then
              do istate=1,nstate
                h(isq,istate)=h(isq,istate)-u(ki,lq)*ev( idetr,istate)
              end do
            else
              do istate=1,nstate
                h(isq,istate)=h(isq,istate)+u(ki,lq)*ev(-idetr,istate)
              end do
            end if
  102       continue
          end do
c
          do jstate=1,nstate
c         do is=1,2
c           if(abs(h(is,jstate)).gt.thrgen) then
c             de=-e(ki,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(is,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,1)=heff2(istate,jstate,1)
c    *              -h(is,istate)*hde
c               end do
c             end if
c           end if
c         end do
            is=1
            if(abs(h(is,jstate)).gt.thrgen) then
              de=-e(ki,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(is,istate)*hde
                end do
              end if
            end if
            is=2
            if(abs(h(is,jstate)).gt.thrgen) then
              de=-e(ki,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(is,istate)*hde
                end do
              end if
            end if
          end do
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(is,jstate)).gt.thrgen) then
c               de=-e(ki,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(is,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl0(   jstate)=wfovl0(   jstate)
c    *                +hde**2
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2
c                 end if
c               end if
c             end if
c           end do
              is=1
              if(abs(h(is,jstate)).gt.thrgen) then
                de=-e(ki,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl0(   jstate)=wfovl0(   jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
              is=2
              if(abs(h(is,jstate)).gt.thrgen) then
                de=-e(ki,is,jstate)+ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl0(   jstate)=wfovl0(   jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2
                  end if
                end if
              end if
            end do
          end if
c
        end do
  104   continue
      end do
c
      if(last.lt.ncip1) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[(+1)-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,1),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_p1_2
     *  (numq  ,
     *   ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl1,v     ,ejdeti,
     *   h     ,list  ,lod2nd)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl1(iniwgt:laswgt,nstate)
c
c     v=ve
      dimension v(inipex:laspex,inidoc:lasact,
     *            iniact:lasact,inidoc:lasact)
c
      dimension ejdeti(nstate)
      dimension h(2,2,2,nstate)
      dimension list(2,numq  )
c     dimension lod2nd(min(ncip1,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(ncip1)
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** (+1)-ionized ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute (+1)-ionized terms ***************************************
      call seqrew(lunrp1)       ! rewind lunrp1
      last=0
   98 continue
      read(lunrp1) length
      call os_lab_read(lunrp1,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///  read(lunrp1) lod2nd
c
c     do jdeti=1,nstrx(1)
      do jdetx=init,last
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1,ncip1
c///    jdeti=lod2nd(jdetx)
c
        call os_make_cc_q  (numq  ,numelm,jdeti,list,lor2rf,jocc)
        if(numelm.eq.0) go to 102  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do kj=inidoc,lasdoc
          isymj=mos(kj)
c@@@@   do ki=inidoc,lasdoc
        do ki=inidoc,kj
          isymi=ieor(isymj,mos(ki))
        do ke=inipex,laspex  ! do ke=iniext,lasext
          isyme=ieor(isymi,mos(ke))
          call vclr(h,1,8*nstate)
          do m=1,numelm
            mq   =list(1,m)
            idetr=list(2,m)
            lq =lso2mo(mq)+nmocor
c
            if(ieor(isyme,mos(lq)).ne.0)
     *        go to 100         ! cycle
            if(v(ke,ki,lq,kj).eq.ZERO .and. v(ke,kj,lq,ki).eq.ZERO)
     *        go to 100         ! cycle
c
            isq=mospn (mq)
c
            if(idetr.gt.0) then
              do istate=1,nstate
                h(1,1  ,isq,istate)=h(1,1  ,isq,istate)
     *            +v(ke,ki,lq,kj)*ev( idetr,istate)
                h(2,2  ,isq,istate)=h(2,2  ,isq,istate)
     *            +v(ke,ki,lq,kj)*ev( idetr,istate)
                h(1,isq,1  ,istate)=h(1,isq,1  ,istate)
     *            -v(ke,kj,lq,ki)*ev( idetr,istate)
                h(2,isq,2  ,istate)=h(2,isq,2  ,istate)
     *            -v(ke,kj,lq,ki)*ev( idetr,istate)
              end do
            else
              do istate=1,nstate
                h(1,1  ,isq,istate)=h(1,1  ,isq,istate)
     *            -v(ke,ki,lq,kj)*ev(-idetr,istate)
                h(2,2  ,isq,istate)=h(2,2  ,isq,istate)
     *            -v(ke,ki,lq,kj)*ev(-idetr,istate)
                h(1,isq,1  ,istate)=h(1,isq,1  ,istate)
     *            +v(ke,kj,lq,ki)*ev(-idetr,istate)
                h(2,isq,2  ,istate)=h(2,isq,2  ,istate)
     *            +v(ke,kj,lq,ki)*ev(-idetr,istate)
              end do
            end if
  100       continue
          end do
c
          do jstate=1,nstate
c         do is=1,2
c           if(abs(h(is,1,2,jstate)).gt.thrgen) then
c             de=e(ke,is,jstate)-e(ki,1,jstate)-e(kj,2,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(is,1,2,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,1)=heff2(istate,jstate,1)
c    *              -h(is,1,2,istate)*hde
c               end do
c             end if
c           end if
c         end do
            is=1
            if(abs(h(is,1,2,jstate)).gt.thrgen) then
              de=e(ke,is,jstate)-e(ki,1,jstate)-e(kj,2,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,1,2,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(is,1,2,istate)*hde
                end do
              end if
            end if
            is=2
            if(abs(h(is,1,2,jstate)).gt.thrgen) then
              de=e(ke,is,jstate)-e(ki,1,jstate)-e(kj,2,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,1,2,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(is,1,2,istate)*hde
                end do
              end if
            end if
          end do
c
          if(ki.lt.kj) then
c@@@@
          do jstate=1,nstate
c         do is=1,2
c           if(abs(h(is,2,1,jstate)).gt.thrgen) then
c             de=e(ke,is,jstate)-e(ki,2,jstate)-e(kj,1,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(is,2,1,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,1)=heff2(istate,jstate,1)
c    *              -h(is,2,1,istate)*hde
c               end do
c             end if
c           end if
c         end do
            is=1
            if(abs(h(is,2,1,jstate)).gt.thrgen) then
              de=e(ke,is,jstate)-e(ki,2,jstate)-e(kj,1,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,2,1,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(is,2,1,istate)*hde
                end do
              end if
            end if
            is=2
            if(abs(h(is,2,1,jstate)).gt.thrgen) then
              de=e(ke,is,jstate)-e(ki,2,jstate)-e(kj,1,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(is,2,1,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(is,2,1,istate)*hde
                end do
              end if
            end if
c         end do
c
c         do jstate=1,nstate
c         do ise=1,2
c         do isi=1,2
c           if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
c             de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
c    *          +ejdeti(jstate)-eref(jstate,jstate)
c             de=de+edshft/de
c             hde=h(ise,isi,isi,jstate)/de
c             if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c             if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c               do istate=1,nstate
c                 heff2(istate,jstate,1)=heff2(istate,jstate,1)
c    *              -h(ise,isi,isi,istate)*hde
c               end do
c             end if
c           end if
c         end do
c         end do
            ise=1
            isi=1
            if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(ise,isi,isi,istate)*hde
                end do
              end if
            end if
            ise=1
            isi=2
            if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(ise,isi,isi,istate)*hde
                end do
              end if
            end if
            ise=2
            isi=1
            if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(ise,isi,isi,istate)*hde
                end do
              end if
            end if
            ise=2
            isi=2
            if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
              de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(ise,isi,isi,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,1)=heff2(istate,jstate,1)
     *              -h(ise,isi,isi,istate)*hde
                end do
              end if
            end if
          end do
c
          end if
c
c         Reference weights
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(is,1,2,jstate)).gt.thrgen) then
c               de=e(ke,is,jstate)-e(ki,1,jstate)-e(kj,2,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(is,1,2,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kj,jstate)=wfovl1(kj,jstate)
c    *                +hde**2*HALF
c                 end if
c               end if
c             end if
c           end do
              is=1
              if(abs(h(is,1,2,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)-e(ki,1,jstate)-e(kj,2,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,1,2,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              is=2
              if(abs(h(is,1,2,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)-e(ki,1,jstate)-e(kj,2,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,1,2,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
            end do
c
            if(ki.lt.kj) then
c@@@@
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(is,2,1,jstate)).gt.thrgen) then
c               de=e(ke,is,jstate)-e(ki,2,jstate)-e(kj,1,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(is,2,1,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kj,jstate)=wfovl1(kj,jstate)
c    *                +hde**2*HALF
c                 end if
c               end if
c             end if
c           end do
              is=1
              if(abs(h(is,2,1,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)-e(ki,2,jstate)-e(kj,1,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,2,1,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              is=2
              if(abs(h(is,2,1,jstate)).gt.thrgen) then
                de=e(ke,is,jstate)-e(ki,2,jstate)-e(kj,1,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,2,1,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
c           end do
c
c           do jstate=1,nstate
c           do ise=1,2
c           do isi=1,2
c             if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
c               de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(ise,isi,isi,jstate)/de
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 if(iwgt.eq.1) then
c                   wfovl1(ke,jstate)=wfovl1(ke,jstate)
c    *                +hde**2
c                 else
c                   wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                +hde**2*HALF
c                   wfovl1(kj,jstate)=wfovl1(kj,jstate)
c    *                +hde**2*HALF
c                 end if
c               end if
c             end if
c           end do
c           end do
              ise=1
              isi=1
              if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              ise=1
              isi=2
              if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              ise=2
              isi=1
              if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
              ise=2
              isi=2
              if(abs(h(ise,isi,isi,jstate)).gt.thrgen) then
                de=e(ke,ise,jstate)-e(ki,isi,jstate)-e(kj,isi,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(ise,isi,isi,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl1(ke,jstate)=wfovl1(ke,jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
            end do
            end if
          end if
c
        end do
        end do
        end do
  102   continue
      end do
c
      if(last.lt.ncip1) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[(+1)-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,1),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_p2
     *  (numsq ,
     *   ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,v     ,
     *   ejdeti,h     ,list  ,lod2nd)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Dec 14, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate), eref(nstate,0:nstate)
      dimension lor2rf(ndet), mos(nmo)
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovl0(nstate), wfovl1(iniwgt:laswgt,nstate)
c
c     v=vi
      dimension v(iniact:lasact,inidoc:lasact,
     *            iniact:lasact,inidoc:lasact)
c
      dimension ejdeti(nstate)
      dimension h(2,2,nstate)
      dimension list(3,numsq)
c     dimension lod2nd(min(ncip2,ncibuf))
      dimension lod2nd(*)
c///  dimension lod2nd(ncip2)
c
      logical jocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** (+2)-ionized ***")')
        call ut_init_time
      END IF
c
c     heff2=ZERO  ! @@@@
c
c**** Compute (+2)-ionized terms ***************************************
      call seqrew(lunrp2)       ! rewind lunrp2
      last=0
   98 continue
      read(lunrp2) length
      call os_lab_read(lunrp2,length,lod2nd)
      init  =last+1
      last  =last+length
      initm1=init-1
c///  read(lunrp2) lod2nd
c
c     do jdeti=1,nstrx(2)
      do jdetx=init+me,last,nproc  ! do jdetx=1,ncip2
        jdeti=lod2nd(jdetx-initm1)
c///  do jdetx=1+me,ncip2,nproc  ! do jdetx=1,ncip2
c///    jdeti=lod2nd(jdetx)
c
        call os_make_cc_sq(numsq,numelm,jdeti,list,lor2rf,jocc)
        if(numelm.eq.0) go to 102  ! cycle
c
        do istate=1,nstate
          ejdeti(istate)=ZERO
        end do
        do i=1,nsoact
          if(jocc(i)) then
            lp=lso2mo(i)+nmocor
            is=mospn (i)
            do istate=1,nstate
              ejdeti(istate)=ejdeti(istate)+e(lp,is,istate)
            end do
          end if
        end do
c
        do kj=inidoc,lasdoc
          isymj=mos(kj)
        do ki=inidoc,lasdoc
          isymi=ieor(isymj,mos(ki))
          call vclr(h,1,4*nstate)
          do m=1,numelm
            ms   =list(1,m)
            mq   =list(2,m)
            idetr=list(3,m)
            ls =lso2mo(ms)+nmocor
            lq =lso2mo(mq)+nmocor
c
            if(ieor( ieor(isymi,mos(lq)), mos(ls) ).ne.0)
     *        go to 100         ! cycle
            if(v(lq,ki,ls,kj).eq.ZERO .and. v(ls,ki,lq,kj).eq.ZERO)
     *        go to 100         ! cycle
c
            iss=mospn (ms)
            isq=mospn (mq)
c
            if(idetr.gt.0) then
              do istate=1,nstate
                h(isq,iss,istate)=h(isq,iss,istate)
     *            -v(lq,ki,ls,kj)*ev( idetr,istate)
                h(iss,isq,istate)=h(iss,isq,istate)
     *            +v(ls,ki,lq,kj)*ev( idetr,istate)
              end do
            else
              do istate=1,nstate
                h(isq,iss,istate)=h(isq,iss,istate)
     *            +v(lq,ki,ls,kj)*ev(-idetr,istate)
                h(iss,isq,istate)=h(iss,isq,istate)
     *            -v(ls,ki,lq,kj)*ev(-idetr,istate)
              end do
            end if
  100       continue
          end do
c
          do jstate=1,nstate
            if(abs(h(1,2,jstate)).gt.thrgen) then
              de=-e(ki,1,jstate)-e(kj,2,jstate)
     *          +ejdeti(jstate)-eref(jstate,jstate)
              de=de+edshft/de
              hde=h(1,2,jstate)/de
              if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
              if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                do istate=1,nstate
                  heff2(istate,jstate,2)=heff2(istate,jstate,2)
     *              -h(1,2,istate)*hde
                end do
              end if
            end if
          end do
c
          if(ki.lt.kj) then
            do jstate=1,nstate
c           do is=1,2
c             if(abs(h(is,is,jstate)).gt.thrgen) then
c               de=-e(ki,is,jstate)-e(kj,is,jstate)
c    *            +ejdeti(jstate)-eref(jstate,jstate)
c               de=de+edshft/de
c               hde=h(is,is,jstate)/de
c               if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
c               if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                 do istate=1,nstate
c                   heff2(istate,jstate,2)=heff2(istate,jstate,2)
c    *                -h(is,is,istate)*hde
c                 end do
c               end if
c             end if
c           end do
              is=1
              if(abs(h(is,is,jstate)).gt.thrgen) then
                de=-e(ki,is,jstate)-e(kj,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,is,jstate)/de
                if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  do istate=1,nstate
                    heff2(istate,jstate,2)=heff2(istate,jstate,2)
     *                -h(is,is,istate)*hde
                  end do
                end if
              end if
              is=2
              if(abs(h(is,is,jstate)).gt.thrgen) then
                de=-e(ki,is,jstate)-e(kj,is,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(is,is,jstate)/de
                if(abs(hde).gt.hdemax) hdemax=abs(hde)
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  do istate=1,nstate
                    heff2(istate,jstate,2)=heff2(istate,jstate,2)
     *                -h(is,is,istate)*hde
                  end do
                end if
              end if
            end do
          end if
c
c         Reference weight
c
          if(iwgt.ne.0) then
            do jstate=1,nstate
              if(abs(h(1,2,jstate)).gt.thrgen) then
                de=-e(ki,1,jstate)-e(kj,2,jstate)
     *            +ejdeti(jstate)-eref(jstate,jstate)
                de=de+edshft/de
                hde=h(1,2,jstate)/de
c
                if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                  if(iwgt.eq.1) then
                    wfovl0(   jstate)=wfovl0(   jstate)
     *                +hde**2
                  else
                    wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                +hde**2*HALF
                    wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                +hde**2*HALF
                  end if
                end if
              end if
            end do
c
            if(ki.lt.kj) then
              do jstate=1,nstate
c             do is=1,2
c               if(abs(h(is,is,jstate)).gt.thrgen) then
c                 de=-e(ki,is,jstate)-e(kj,is,jstate)
c    *              +ejdeti(jstate)-eref(jstate,jstate)
c                 de=de+edshft/de
c                 hde=h(is,is,jstate)/de
c
c                 if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
c                   if(iwgt.eq.1) then
c                     wfovl0(   jstate)=wfovl0(   jstate)
c    *                  +hde**2
c                   else
c                     wfovl1(ki,jstate)=wfovl1(ki,jstate)
c    *                  +hde**2*HALF
c                     wfovl1(kj,jstate)=wfovl1(kj,jstate)
c    *                  +hde**2*HALF
c                   end if
c                 end if
c               end if
c             end do
                is=1
                if(abs(h(is,is,jstate)).gt.thrgen) then
                  de=-e(ki,is,jstate)-e(kj,is,jstate)
     *              +ejdeti(jstate)-eref(jstate,jstate)
                  de=de+edshft/de
                  hde=h(is,is,jstate)/de
c
                  if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                    if(iwgt.eq.1) then
                      wfovl0(   jstate)=wfovl0(   jstate)
     *                  +hde**2
                    else
                      wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                  +hde**2*HALF
                      wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                  +hde**2*HALF
                    end if
                  end if
                end if
                is=2
                if(abs(h(is,is,jstate)).gt.thrgen) then
                  de=-e(ki,is,jstate)-e(kj,is,jstate)
     *              +ejdeti(jstate)-eref(jstate,jstate)
                  de=de+edshft/de
                  hde=h(is,is,jstate)/de
c
                  if(abs(de).gt.thrde .and. abs(hde).lt.thrhde) then
                    if(iwgt.eq.1) then
                      wfovl0(   jstate)=wfovl0(   jstate)
     *                  +hde**2
                    else
                      wfovl1(ki,jstate)=wfovl1(ki,jstate)
     *                  +hde**2*HALF
                      wfovl1(kj,jstate)=wfovl1(kj,jstate)
     *                  +hde**2*HALF
                    end if
                  end if
                end if
              end do
            end if
          end if
c
        end do
        end do
  102   continue
      end do
c
      if(last.lt.ncip2) go to 98
c
c**** Debug output *****************************************************
      if(lpout.lt.0 .AND.MASWRK) then
        write(lunout,'(" *** Heff2[(+2)-ionized] ***")')
        call ut_rmat_print_2
     *    (lunout,heff2(1,1,2),' ',nstate,1,nstate,1,nstate,1,1)
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_mcqdpt_read_intrx(inimo,lasmo,label,valint,v)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Nov 14, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
c
      dimension v(inidoc:lasact,inidoc:lasact,iniext:lasext,inimo:lasmo)
c
      dimension label (3,nmoext*(nmodoc+nmoact)**2)
      dimension valint(  nmoext*(nmodoc+nmoact)**2)
c
c**** Read two electron integrals **************************************
c
c     v(j,l,i,k) = (ij|kl)
c
      call vclr(v,1,nmoext*(nmodoc+nmoact)**2*(lasmo-inimo+1))
c
      do k=inimo,lasmo
        read(lunte2) n
        call os_labval_read(lunte2,3*n,n,label,valint)
        do m=1,n
          i=label(1,m)
          j=label(2,m)
          l=label(3,m)
          v(j,l,i,k)=valint(m)
        end do
      end do
c
c**** Clear small ints. ************************************************
      do l=inimo ,lasmo
      do k=iniext,lasext
      do j=inidoc,lasact
      do i=inidoc,lasact
        if(abs(v(i,j,k,l)).lt.threri) v(i,j,k,l)=ZERO
      end do
      end do
      end do
      end do
c
c**** End **************************************************************
      end
      subroutine os_mcqdpt_read_intrx_par(inimo,lasmo,valint,v)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jul 08, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
c
c==== GAMESS common ====================================================
c     parameter (NFTI=9)
c     LOGICAL PACK2E
c     COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
c     COMMON /PCKLAB/ LABSIZ
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
c
      dimension v(inidoc:lasact,inidoc:lasact,inipex:laspex,inimo:lasmo)
      dimension valint(nmoext,nmoext)
c
c**** Read two electron integrals **************************************
c
c     v(j,l,i,k) = (ij|kl)
c
      call vclr
     *  (v,1,(nmodoc+nmoact)**2*(laspex-inipex+1)*(lasmo-inimo+1))
c
c     VOVO
c
      nmoda =nmodoc+nmoact
c     nmocda=nmofzc+nmodoc+nmoact
      do ii=1,nmoda
        iipc=ii+nmofzc
      do jj=1,ii
        jjpc=jj+nmofzc
        ijpc=iipc*(iipc-1)/2+jjpc
        call ddi_get(d_vovo,1,nmoext*nmoext,ijpc,ijpc,valint)
        do jv=1,nmoext
        do iv=1,nmoext
          i=iv+lasact
          j=ii
          k=jv+lasact
          l=jj
c         ivjv=(jv-1)*nmoext+iv
          val=valint(iv,jv)
          if(inipex.le.i .and. i.le.laspex .and.
     *       inimo .le.k .and. k.le.lasmo       ) v(j,l,i,k)=val
          if(inipex.le.k .and. k.le.laspex .and.
     *       inimo .le.i .and. i.le.lasmo       ) v(l,j,k,i)=val
        end do
        end do
      end do
      end do
c
c**** Clear small ints. ************************************************
      do l=inimo ,lasmo
      do k=inipex,laspex
      do j=inidoc,lasact
      do i=inidoc,lasact
        if(abs(v(i,j,k,l)).lt.threri) v(i,j,k,l)=ZERO
      end do
      end do
      end do
      end do
c
c**** End **************************************************************
      end
      subroutine os_mcqdpt_read_intx(u,vi,ve,veff,label,valint)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 30, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
c
      dimension u(nmo,nmo)
      dimension vi(iniact:lasact,inidoc:lasact,
     *             iniact:lasact,inidoc:lasact)
      dimension ve(iniext:lasext,inidoc:lasact,
     *             iniact:lasact,inidoc:lasact)
      dimension veff(nmo,nmo)
      dimension label (3,(nmoact+nmoext)*(nmodoc+nmoact)**2)
      dimension valint(  (nmoact+nmoext)*(nmodoc+nmoact)**2)
c
c**** Read one electron integrals **************************************
      call seqrew(lunhcr)       ! rewind lunhcr
      read(lunhcr) u
      read(lunhcr) veff
c
c**** Add effective 2-body interaction *********************************
      do j=1,nmo
      do i=1,nmo
        u(i,j)=u(i,j)+veff(i,j)
      end do
      end do
c
c     Clear unnecessary part for safety
c
      do j=inifzc,lasext
      do i=inifzc,lasfzc
        u(i,j)=ZERO
      end do
      end do
      do j=inifzc,lasfzc
      do i=inifzc,lasext
        u(i,j)=ZERO
      end do
      end do
      do j=inidoc,lasdoc
      do i=inidoc,lasdoc
        u(i,j)=ZERO
      end do
      end do
      do j=iniext,lasext
      do i=iniext,lasext
        u(i,j)=ZERO
      end do
      end do
c
c**** Read two electron integrals **************************************
c
c     v(i,j,k,l) = (ij|kl)
c
      call vclr(vi,1,
     *  nmoact*(nmodoc+nmoact)*nmoact*(nmodoc+nmoact))
      call vclr(ve,1,
     *  nmoext*(nmodoc+nmoact)*nmoact*(nmodoc+nmoact))
c
      call seqrew(lunte1)       ! rewind lunte1
      do k=iniact,lasact
        read(lunte1) n
        call os_labval_read(lunte1,3*n,n,label,valint)
c       read(lunte1) label(1:3,1:n),valint(1:n)
        do m=1,n
          i         =label (1,m)
          j         =label (2,m)
          l         =label (3,m)
          if(i.le.lasact) then
            vi(i,j,k,l)=valint(  m)
          else
            ve(i,j,k,l)=valint(  m)
          end if
        end do
      end do
c
c**** Clear small ints. ************************************************
      do j=1,nmo
      do i=1,nmo
        if(abs(u(i,j)).lt.threri) u(i,j)=ZERO
      end do
      end do
c
      do l=inidoc,lasact
      do k=iniact,lasact
      do j=inidoc,lasact
        do i=iniact,lasact
          if(abs(vi(i,j,k,l)).lt.threri) vi(i,j,k,l)=ZERO
        end do
        do i=iniext,lasext
          if(abs(ve(i,j,k,l)).lt.threri) ve(i,j,k,l)=ZERO
        end do
      end do
      end do
      end do
c
c**** End **************************************************************
      end
      subroutine os_mcqdpt_read_intx_par(nbuf,u,vi,ve,veff,valint)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 30, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c==== GAMESS common ====================================================
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
c
      dimension u(nmo,nmo)
      dimension vi(iniact:lasact,inidoc:lasact,
     *             iniact:lasact,inidoc:lasact)
      dimension ve(inipex:laspex,inidoc:lasact,
     *             iniact:lasact,inidoc:lasact)
      dimension veff(nmo,nmo)
      dimension valint(nbuf)
c
c**** Read one electron integrals **************************************
      call seqrew(lunhcr)       ! rewind lunhcr
      read(lunhcr) u
      read(lunhcr) veff
c
c**** Add effective 2-body interaction *********************************
      do j=1,nmo
      do i=1,nmo
        u(i,j)=u(i,j)+veff(i,j)
      end do
      end do
c
c     Clear unnecessary part for safety
c
      do j=inifzc,lasext
      do i=inifzc,lasfzc
        u(i,j)=ZERO
      end do
      end do
      do j=inifzc,lasfzc
      do i=inifzc,lasext
        u(i,j)=ZERO
      end do
      end do
      do j=inidoc,lasdoc
      do i=inidoc,lasdoc
        u(i,j)=ZERO
      end do
      end do
      do j=iniext,lasext
      do i=iniext,lasext
        u(i,j)=ZERO
      end do
      end do
c
c**** Read two electron integrals **************************************
      call vclr(vi,1,
     *  nmoact           *(nmodoc+nmoact)*nmoact*(nmodoc+nmoact))
      call vclr(ve,1,
     *  (laspex-inipex+1)*(nmodoc+nmoact)*nmoact*(nmodoc+nmoact))
c
c     OOOO
c
      nmoda =       nmodoc+nmoact
      nmocda=nmofzc+nmodoc+nmoact
      ncdatr=nmocda*(nmocda+1)/2
      call ddi_distrib(d_oooo,me,ilo,ihi,jlo,jhi)
      do ii=1,nmoda
        iipc=ii+nmofzc
      do jj=1,ii
        jjpc=jj+nmofzc
        ij  =(ii  *ii  -ii  )/2+jj
        ijpc=(iipc*iipc-iipc)/2+jjpc
        if(ijpc.ge.jlo .and. ijpc.le.jhi) then
          call ddi_get(d_oooo,1,ncdatr,ijpc,ijpc,valint)
          do kk=1,nmoda
            kkpc=kk+nmofzc
          do ll=1,kk
            llpc=ll+nmofzc
            kl=(kk*kk-kk)/2+ll
            if(ij.ge.kl) then
              klpc=(kkpc*kkpc-kkpc)/2+llpc
              i=kk
              j=ll
              k=ii
              l=jj
              val=valint(klpc)
              if(iniact.le.i .and. iniact.le.k) vi(i,j,k,l)=val
              if(iniact.le.i .and. iniact.le.l) vi(i,j,l,k)=val
              if(iniact.le.j .and. iniact.le.k) vi(j,i,k,l)=val
              if(iniact.le.j .and. iniact.le.l) vi(j,i,l,k)=val
              if(iniact.le.k .and. iniact.le.i) vi(k,l,i,j)=val
              if(iniact.le.k .and. iniact.le.j) vi(k,l,j,i)=val
              if(iniact.le.l .and. iniact.le.i) vi(l,k,i,j)=val
              if(iniact.le.l .and. iniact.le.j) vi(l,k,j,i)=val
            end if
          end do
          end do
        end if
      end do
      end do
      call DDI_GSUMF
     *  (5000,vi,nmoact*(nmodoc+nmoact)*nmoact*(nmodoc+nmoact))
c
c     VOOO
c
c
      nmo3=( nmocda*(nmocda+1)/2 )*nmocda
      init=1
      last=min(init+nbuf-1,nmo3)
  100 continue
        call ddi_get
     *    (d_vooo,inipex-lasact,laspex-lasact,init,last,valint)
        do ii=1,nmoda
          iipc=ii+nmofzc
          iind=iipc*(iipc-1)/2
        do jj=1,ii
          jjpc=jj+nmofzc
          ijind=(iind+jjpc-1)*nmocda
        do kk=1,nmoda
          kkpc=kk+nmofzc
          ijkpc=ijind+kkpc
          if(init.le.ijkpc .and. ijkpc.le.last) then
            ijkind=(ijkpc-init)*(laspex-inipex+1)
            do ll=inipex,laspex
              llma=ll-inipex+1
              ijklin=ijkind+llma
              i=ll
              j=kk
              k=ii
              l=jj
              val=valint(ijklin)
              if(iniact.le.k) ve(i,j,k,l)=val
              if(iniact.le.l) ve(i,j,l,k)=val
            end do
          end if
        end do
        end do
        end do
        init=last+1
        last=min(last+nbuf,nmo3)
      if(init.le.nmo3) go to 100
c
c**** Clear small integrals ********************************************
      do j=1,nmo
      do i=1,nmo
        if(abs(u(i,j)).lt.threri) u(i,j)=ZERO
      end do
      end do
c
      do l=inidoc,lasact
      do k=iniact,lasact
      do j=inidoc,lasact
        do i=iniact,lasact
          if(abs(vi(i,j,k,l)).lt.threri) vi(i,j,k,l)=ZERO
        end do
        do i=inipex,laspex
          if(abs(ve(i,j,k,l)).lt.threri) ve(i,j,k,l)=ZERO
        end do
      end do
      end do
      end do
c
c**** End **************************************************************
      end
      subroutine os_mcqdptx
     *  (ev    ,e     ,edet  ,eref  ,u     ,lrf2or,lor2rf,mos   ,heff2 ,
     *   wfovli,wfovl0,wfovl1,wfovl2)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 02, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension ev(nci,nstate), e(nmo,2,0:nstate)
      dimension edet(nci,0:nstate), eref(nstate,0:nstate)
      dimension u(nmo,nmo)
      dimension lrf2or(nci), lor2rf(ndet)
      dimension mos(nmo)
c
c     Array heff2 is declared heff2(nstate,nstate,0:4) in sub.os_mcqdpt.
c     It should be so treated in routines for sub.os_mcqdpt, that is,
c     os_mcqdpt0, os_mcqdpt_int_calc_sd, and os_mcqdpt0r.
c
c     (* Fixed on Oct. 06, 2007)
c
      dimension heff2(nstate,nstate,-2:2)
c
      dimension wfovli(nstate), wfovl0(nstate)
      dimension wfovl1(iniwgt:laswgt,nstate)
      dimension wfovl2(iniwgt:laswgt,iniwgt:laswgt,nstate)
c
c==== GAMESS common ====================================================
      COMMON /FMCOM / d(1)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout, '(/1x,10(1h*)," Routine os_mcqdptx ",49(1h*))')
        call ut_init_time
      END IF
      if(MASWRK) write(lunout,'(/" *** GMC-QDPT computation")')
c
c**** Read arrays for MC-QDPT calculations *****************************
      call seqrew(luneig)       ! rewind luneig
      read(luneig) ev
c
      call seqrew(luneob)       ! rewind luneob
      read(luneob) e
c
      call seqrew(lunedt)       ! rewind lunedt
      read(lunedt) edet
c
      call seqrew(lunerf)       ! rewind lunerf
      read(lunerf) eref
c
      call seqrew(luno2r)       ! rewind luno2r
      read(luno2r) lor2rf
c
      call seqrew(lunmos)       ! rewind lunmos
      read(lunmos) mos
c
c**** Initialize heff2 *************************************************
      call vclr(heff2,1,nstate*nstate*5)
c
c**** Initialize wfovli, wfovl0, wfovl1, and wfovl2 ********************
      call vclr(wfovli,1,nstate)
      call vclr(wfovl0,1,nstate)
      call vclr(wfovl1,1,nmowgt*nstate)
      call vclr(wfovl2,1,nmowgt**2*nstate)
c
c**** Set nump, numq, numpr, numsq, numprs, and numrsq *****************
      numpq =nelact*(nsoact-nelact+1)
      numq  =nelact+1
      numrsq=(nelact+1)*nelact*(nsoact-nelact+1)/2
      nump  =nsoact-nelact+1
      numprs=(nelact-1)*(nsoact-nelact+2)*(nsoact-nelact+1)/2
      numsq =(nelact+2)*(nelact+1)/2
      numpr =(nsoact-nelact+2)*(nsoact-nelact+1)/2
c
c**** Set inipex and laspex (mainly for parallel) **********************
      if(.not.GOPARR) then
        inipex=iniext
        laspex=lasext
      else
        laspex=lasact
        do i=0,me
          inipex=laspex+1
          laspex=laspex+nmoext/nproc
          if(i .lt. nmoext-(nmoext/nproc)*nproc) laspex=laspex+1
        end do
      end if
c
c***********************************************************************
c**** Internal and one-external terms **********************************
c****                                 **********************************
      if(MASWRK) then
        tcpu0 =ZERO
        twall0=ZERO
      end if
c**** Read internal and 1-ext integrals ********************************
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n01i= n01
      n01e= n01i+ nmoact           *(nmodoc+nmoact)**2*nmoact  ! vi
      n02 = n01e+ (laspex-inipex+1)*(nmodoc+nmoact)**2*nmoact  ! ve
      NEEDIN = n02 - LOADFM - 1
      call GETFM(NEEDIN)
c
          if(MASWRK) call ut_init_time
      if(.not.GOPARR) then
        call VALFM(LOADFM)
        n02 = LOADFM + 1
        n03 = n02 + nmo*nmo                                    ! veff
        n04 = n03 + 3*(nmoact+nmoext)*(nmodoc+nmoact)**2       ! label
        n05 = n04 + (nmoact+nmoext)*(nmodoc+nmoact)**2         ! valint
        NEED = n05 - LOADFM -1
        call GETFM(NEED)
        call os_mcqdpt_read_intx
     *    (       u     ,d(n01i),d(n01e),d(n02),d(n03),d(n04))
        call RETFM(NEED)
      else
        call VALFM(LOADFM)
        call GOTFM(NGOTMX)
        n02 = LOADFM + 1
        n03 = n02 + nmo*nmo                                    ! veff
        nremai = n02 + NGOTMX - n03
        nmocda = nmofzc+nmodoc+nmoact
        nbuf   = max(nmocda*(nmocda+1)/2                   ,
     *               min(nremai,
     *                   nmocda*(nmocda+1)/2*nmocda*(laspex-inipex+1)))
        n04    = n03 + nbuf
        NEED   = n04 - LOADFM -1
        call GETFM(NEED)
        call os_mcqdpt_read_intx_par
     *    (nbuf  ,u     ,d(n01i),d(n01e),d(n02),d(n03))
        call RETFM(NEED)
      end if
          if(MASWRK) then
            call ut_return_time(tcpu,twall)
            write(lunout,'(/" (Integral reading: ",
     *                   " CPU/Wall time =",f15.2," /",f15.2," sec.)")')
     *      tcpu,twall
            call flshbf(lunout)
          end if
c
c**** Compute internal integral contribution to effective Hamiltonian **
      if( (nexcit.lt.nelact .and. nexcit.lt.nsoact-nelact) .or.
     *  thrwgt.ge.ZERO) then                                  ! Skip CAS
        nsddet=nstri(-4)  ! number of walks in the 0-1-0-1-0 space
        if(GOPARR) then
c
c         Distribute NSDDET walks to NPROC processors first
c
          n1=nsddet
          n2=n1/nproc
          n3=mod(n1,nproc)  ! n1=n2*nproc+n3
          lasd=0
          do ime=0,nproc-1
            inid=lasd+1
            lasd=lasd+n2
            if(ime.lt.n3) then
              lasd=min(lasd+1,nsddet)
            else
              lasd=min(lasd  ,nsddet)
            end if
            if(ime.eq.me) then
              inide=inid
              lasde=lasd
            end if
          end do
        else
          inide=1
          lasde=nsddet
        end if
c
        if(MASWRK) then
          write(lunout,'(/" Internal:",i10)')
          write(lunout,
     *      '(" # of macro loops for internal contribution =",i10)')
     *      niloop
        end if
        lasdet=inide-1
        do iiloop=1,niloop
          inidet=lasdet+1
          lasdet=lasdet+(lasde-inide+1-1)/niloop+1
          lasdet=min(lasdet,lasde)
c
          call VALFM(LOADFM)
          n02 = LOADFM + 1
          n03 = n02 + (lasdet-inidet+1)
          NEED1 = n03 - LOADFM - 1
          call GETFM(NEED1)
c
          if(MASWRK) call ut_init_time
          call os_mcqdpt_int_make_sd
     *      (inidet,lasdet,mcisd ,ncisd ,ev    ,lrf2or,d(n02))
          if(MASWRK) call ut_return_time(tcpu1,twall1)
c
c         if(mcisd.gt.0) then
          if(ncisd.gt.0) then
            lengsd= nelact*(nsoact-nelact)
     *        +nelact*(nelact-1)*(nsoact-nelact)*(nsoact-nelact-1)/4
c           lengsd= nelact*(nsoact-nelact+1)
c    *        +nelact*(nelact-1)*(nsoact-nelact+2)*(nsoact-nelact+1)/4
            call VALFM(LOADFM)
            call GOTFM(NGOTMX)
            n03 = LOADFM + 1
            n04 = n03 + lengsd  ! lrec
            n05 = n04 + lengsd  ! vrec
c
            nremai = n03 + NGOTMX - n05
            if(nremai.le.0) then
              if(MASWRK) then
                write(lunout,'(" Remaining memory <= 0"/
     *                         " nremai =",i20)') nremai
              end if
              call abrt
            end if
            nbuf=min(nremai/(nstate+2),ncisd)
c
c     Adjust NBUF to the smallest value among processors because routine
c     OS_MCQDPT_INT_CALC_SD takes GSUM for a length of NBUF*NSTATE
c
c           if(GOPARR) call os_find_minmax_int(nbuf,'min')
c           (not necessary to the current OS_MCQDPT_INT_CALC_SD)
c
            n06 = n05 + nbuf*nstate  ! sdvec
            n07 = n06 + nbuf         ! lsdr2o
            n08 = n07 + nbuf         ! edetsd
            NEED2 = n08 - LOADFM - 1
            call GETFM(NEED2)
c
            if(MASWRK) then
              write(lunout,
     *          '(" # of micro loops for internal contribution =",i10)')
     *          (ncisd-1)/nbuf+1
            end if
            if((ncisd-1)/nbuf+1.gt.50) then
              if(MASWRK) write(lunout,'(" Too many loops.")')
              call abrt
            end if
c
            if(MASWRK) call ut_init_time
            ininsd=1
   98       continue
              ioff=ininsd-1
              lasnsd=min(ioff+nbuf,ncisd)
c
              call os_mcqdpt_int_calc_sd
     *          (inidet,lasdet,ncisd ,lengsd,nbuf  ,ininsd,lasnsd,
     *           ev    ,e     ,eref  ,u     ,lrf2or,heff2 ,
     *           wfovli,d(n01i),d(n02),
     *           d(n03),d(n04) ,d(n05),d(n06),d(n07))
c
              ininsd=ininsd+nbuf
            if(ininsd.le.ncisd) go to 98
            if(MASWRK) call ut_return_time(tcpu2,twall2)
c
            call RETFM(NEED2)
          else
            tcpu2 =ZERO
            twall2=ZERO
          end if
          if(MASWRK) then
            tcpu0 =tcpu0 +tcpu1 +tcpu2
            twall0=twall0+twall1+twall2
            write(lunout,'(" Space construction:",
     *        " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu1,twall1
            write(lunout,'(" Internal terms:    ",
     *        " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu2,twall2
            call flshbf(lunout)
          end if
          call RETFM(NEED1)
        end do
      end if
c
c**** Compute 1-ext integral contribution to effective Hamiltonian *****
c     n03 and n04: not used just due to the convenience in programming
      call VALFM(LOADFM)
      n05 = LOADFM + 1
      n06 = n05 + nstate                                     ! ejdeti
c
      n07 = n06 + 4*nstate                                   ! h
      n08 = n07 + 3*numpq                                    ! list
      n09 = n08 + min(nci00,ncibuf)                          ! lod2nd
c///  n09 = n08 + nci00                                      ! lod2nd
c
      n10 = n06 + 2*nstate                                   ! h
      n11 = n10 + 2*nump                                     ! list2
      n12 = n11 + 4*numprs                                   ! list4
      n13 = n12 + min(ncim1,ncibuf)                          ! lod2nd
c///  n13 = n12 + ncim1                                      ! lod2nd
c
      n14 = n06 + 2*nstate                                   ! h
      n15 = n14 + 2*numq                                     ! list2
      n16 = n15 + 4*numrsq                                   ! list4
      n17 = n16 + min(ncip1,ncibuf)                          ! lod2nd
c///  n17 = n16 + ncip1                                      ! lod2nd
c
      n18 = n06 + 8*nstate                                   ! h
      n19 = n18 + 2*numq                                     ! list
      n20 = n19 + min(ncip1,ncibuf)                          ! lod2nd
c///  n20 = n19 + ncip1                                      ! lod2nd
c
      n21 = n06 + 4*nstate                                   ! h
      n22 = n21 + 3*numsq                                    ! list
      n23 = n22 + min(ncip2,ncibuf)                          ! lod2nd
c///  n23 = n22 + ncip2                                      ! lod2nd
      NEED = max(n09,n13,n17,n20,n23) - LOADFM - 1
c
      call GETFM(NEED)
c
c     0-ionized terms
c
          if(MASWRK) call ut_init_time
      call os_mcqdpt_0
     * (numpq ,
     *  ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl1,d(n01e),
     *  d(n05),d(n06),d(n07),d(n08))
c    * (numpq ,
c    *  ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl1,v      ,
c    *  ejdeti,h     ,list  ,lod2nd)
          if(MASWRK) then
            call ut_return_time(tcpu,twall)
            tcpu0 =tcpu0 +tcpu
            twall0=twall0+twall
            write(lunout,'(/" One-external:"/"   0 -ionized terms:",
     *        " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu,twall
            call flshbf(lunout)
          end if
c
c     (-1)-ionized terms
c
          if(MASWRK) call ut_init_time
      call os_mcqdpt_m1
     *  (nump  ,numprs,
     *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,
     *  d(n01e),d(n05),d(n06),d(n10),d(n11),d(n12))
c    *  (nump  ,numprs,
c    *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,
c    *   v     ,ejdeti,h     ,list2 ,list4 ,lod2nd)
          if(MASWRK) then
            call ut_return_time(tcpu,twall)
            tcpu0 =tcpu0 +tcpu
            twall0=twall0+twall
            write(lunout,
     *        '(" (-1)-ionized terms:",
     *          " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu,twall
            call flshbf(lunout)
          end if
c
c     (+1)-ionized terms (1)
c
          if(MASWRK) call ut_init_time
      call os_mcqdpt_p1_1
     *  (numq  ,numrsq,
     *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,
     *  d(n01i),d(n05),d(n06),d(n14),d(n15),d(n16))
c    *  (numq  ,numrsq,
c    *   ev    ,e     ,eref  ,u     ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,
c    *   v     ,ejdeti,h     ,list2 ,list4 ,lod2nd)
          if(MASWRK) then
            call ut_return_time(tcpu,twall)
            tcpu0 =tcpu0 +tcpu
            twall0=twall0+twall
            write(lunout,
     *        '(" (+1)-ionized terms:",
     *          " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu,twall
            call flshbf(lunout)
          end if
c
c     (+1)-ionized terms (2)
c
          if(MASWRK) call ut_init_time
      call os_mcqdpt_p1_2
     * (numq  ,
     *  ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl1,d(n01e),d(n05),
     *  d(n06),d(n18),d(n19))
c    * (numq  ,
c    *  ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl1,v      ,ejdeti,
c    *  h     ,list  ,lod2nd)
          if(MASWRK) then
            call ut_return_time(tcpu,twall)
            tcpu0 =tcpu0 +tcpu
            twall0=twall0+twall
            write(lunout,
     *        '(" (+1)-ionized terms:",
     *          " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu,twall
            call flshbf(lunout)
          end if
c
c     (+2)-ionized terms
c
          if(MASWRK) call ut_init_time
      call os_mcqdpt_p2
     * (numsq ,
     *  ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,d(n01i),
     *  d(n05),d(n06),d(n21),d(n22))
c    * (numsq ,
c    *  ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,v      ,
c    *  ejdeti,h     ,list  ,lod2nd)
          if(MASWRK) then
            call ut_return_time(tcpu,twall)
            tcpu0 =tcpu0 +tcpu
            twall0=twall0+twall
            write(lunout,
     *        '(" (+2)-ionized terms:",
     *          " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *        tcpu,twall
            call flshbf(lunout)
          end if
c
      call RETFM(NEED)
c
      call RETFM(NEEDIN)
c
c***********************************************************************
c**** Two-external terms ***********************************************
c***                     ***********************************************
c**** Compute 2-ext integral contribution to effective Hamiltonian *****
      call VALFM(LOADFM)
      call GOTFM(NGOTMX)
      n01 = LOADFM + 1
      n02 = n01 + 3*nmoext*(nmodoc+nmoact)**2  ! label
      n03 = n02 + nmoext*(nmodoc+nmoact)**2    ! valint
      if(GOPARR) then
        n02 = n01                              ! label (none)
        n03 = n02 + nmoext*nmoext              ! valint
      end if
c
      n04 = n03 + nstate                       ! trnden
c
      n05 = n04 + nstate                       ! ejdeti
      n06 = n05 + max(2*nump,3*numpr)          ! list
c
      n07 = n06 + 8*nstate                     ! h
c
      n08 = n07 + min(max(ncim1,ncim2),ncibuf) ! lod2nd
c///  n08 = n07 + max(ncim1,ncim2)             ! lod2nd
c
      nremai = n01 + NGOTMX - n08
c     nremai = ncore2 - n08 + 1
      if(nmoext.ne.0) then
c
c       kbuf=nremai
c    *    /(nmoext*(nmodoc+nmoact)**2)
c       kbuf=min(kbuf,nmoext)
        kbuf=nremai
     *    /((laspex-inipex+1)*(nmodoc+nmoact)**2)
        kbuf=min(kbuf,nmoext)
c
        if(kbuf.lt.1) then         ! If no available memory, then stop
          if(MASWRK)
     *      write(lunout,'(" *** Error stop in sub.os_mcqdptx ***"/
     *                     " kbuf =",i10)') kbuf
          call abrt
        end if
      else
        kbuf=0
      end if
c
c     n09 = n08 + nmoext*(nmodoc+nmoact)**2*kbuf        ! v
      n09 = n08 + (laspex-inipex+1)*(nmodoc+nmoact)**2*kbuf ! v
      NEED = n09 - LOADFM - 1
      call GETFM(NEED)
c
          if(MASWRK) write(lunout,'(/" Two-external:")')
c
      inimo=iniext
      call seqrew(lunte2)       ! rewind lunte2
  100 continue
        inimm1=inimo-1
        lasmo =min(inimm1+kbuf,lasext)
c       klen  =lasmo-inimm1
c
        if(.not.GOPARR) then
          call os_mcqdpt_read_intrx
     *      (inimo,lasmo,d(n01),d(n02),d(n08))
        else
          if(inipex.le.laspex)
     *      call os_mcqdpt_read_intrx_par
     *      (inimo,lasmo,       d(n02),d(n08))
        end if
c
            if(MASWRK) call ut_init_time
        call os_mcqdpt_0r
     *  (ev    ,e     ,edet  ,eref  ,mos   ,heff2 ,wfovl1,d(n06),d(n08),
     *   inimo ,lasmo )
c    *  (ev    ,e     ,edet  ,eref  ,mos   ,heff2 ,wfovl1,h     ,v     ,
c    *   inimo ,lasmo )
            if(MASWRK) then
              call ut_return_time(tcpu,twall)
              tcpu0 =tcpu0 +tcpu
              twall0=twall0+twall
              write(lunout,
     *          '("   0 -ionized terms:",
     *            " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *            tcpu,twall
              call flshbf(lunout)
            end if
c
            if(MASWRK) call ut_init_time
        call os_mcqdpt_m1r
     *  (nump  ,
     *   ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl1,d(n04),d(n05),
     *   d(n06),d(n07),d(n08),inimo ,lasmo )
            if(MASWRK) then
              call ut_return_time(tcpu,twall)
              tcpu0 =tcpu0 +tcpu
              twall0=twall0+twall
              write(lunout,
     *          '(" (-1)-ionized terms:",
     *            " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *            tcpu,twall
              call flshbf(lunout)
            end if
c
            if(MASWRK) call ut_init_time
        call os_mcqdpt_m2r
     *  (numpr ,
     *   ev    ,e     ,eref  ,lor2rf,mos   ,heff2 ,wfovl0,wfovl1,d(n04),
     *   d(n05),d(n06),d(n07),d(n08),inimo ,lasmo )
            if(MASWRK) then
              call ut_return_time(tcpu,twall)
              tcpu0 =tcpu0 +tcpu
              twall0=twall0+twall
              write(lunout,
     *          '(" (-2)-ionized terms:",
     *            " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *            tcpu,twall
              call flshbf(lunout)
            end if
c
        inimo=inimo+kbuf
      if(inimo.le.lasext) go to 100
      call RETFM(NEED)
c
          if(MASWRK) then
            write(lunout,
     *        '(/" Total time:        ",
     *           " CPU/Wall time =",f15.2," /",f15.2," sec.")')
     *           tcpu0,twall0
          end if
c
c**** Sum up effective Hamiltonian and weights *************************
      if(GOPARR) then
        call DDI_GSUMF(5000,heff2,nstate*nstate*5)
        if(iwgt.ne.0) then
          call DDI_GSUMF(5000,wfovli,nstate)
          call DDI_GSUMF(5000,wfovl0,nstate)
          call DDI_GSUMF(5000,wfovl1,nmowgt*nstate)
          call DDI_GSUMF(5000,wfovl2,nmowgt**2*nstate)
        end if
      end if
c
c**** Write effective Hamiltonian on file ******************************
      call seqrew(lunhef)       ! rewind lunhef
      write(lunhef) heff2
c
      if(iwgt.ne.0) then
        call seqrew(lunwgt)     ! rewind lunwgt
        write(lunwgt) wfovli,wfovl0,wfovl1,wfovl2
      end if
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(" *** Total time for GMC-QDPT ***")')
        call ut_report_time
      END IF
      end
      subroutine os_mxovlp_pick(lrfocc,ev,ovlp)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 26, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ONE=1.0d+00)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrfocc(2,nci), ev(nci,nstci)
c
c     Working arrays: not counted in memory management
c
      dimension ovlp(nstci)
c
      call seqrew(lunroc)       ! rewind lunroc
      read(lunroc) lrfocc
c
      if(MASWRK) then
        write(lunout,
     *    '(" Maximum overlap sorting to previous solution(s):"/
     *      "     State      Root   Overlap")')
      end if
c
c     do istate=1,nstate
c       kstate(istate)=.false.
c     end do
      do istci=1,nstci
        kstate(istci)=.false.
      end do
c
      call seqrew(lunmol)       ! rewind lunmol
      do istate=1,nstate
c
        call vclr(ovlp,1,nstci)
        read(lunmol) n
        do i=1,n
          read(lunmol) istr1,istr2,ci
          do ici=1,nci
            if(lrfocc(1,ici).eq.istr1 .and. lrfocc(2,ici).eq.istr2) then
              do istci=1,nstci
                ovlp(istci)=ovlp(istci)+ev(ici,istci)*ci
              end do
              go to 100
            end if
          end do
  100     continue
        end do
        istmax=         1
        omax  =abs(ovlp(1))
        do istci=2,nstci
          if(abs(ovlp(istci)).gt.omax) then
            istmax=istci
            omax  =abs(ovlp(istci))
          end if
        end do
        kstate(istmax)=.true.
        if(MASWRK)
     *    write(lunout,'(2i10,1x,f9.6)') istate,istmax,abs(ovlp(istmax))
      end do
c
c     In case maximum overlap sorting fails
c
      n=0
      do istci=1,nstci
        if(kstate(istci)) n=n+1
      end do
      if(n .ne. nstate) then
        if(MASWRK) then
          write(lunout,
     *      '(" *** Warning in maximum overlap sorting ***"/
     *        " Maximum overlap sorting failed."/
     *        " count(kstate) =",i10,"  nstate =",i10)')
     *        n,nstate
          write(lunout,
     *      '(" Semi-maximum overlap sorting:"/
     *        "     State      Root   Overlap")')
        END IF
c
        do istci=1,nstci
          kstate(istci)=.false.
        end do
        call seqrew(lunmol)     ! rewind lunmol
        do istate=1,nstate
          call vclr(ovlp,1,nstci)
          read(lunmol) n
          do i=1,n
            read(lunmol) istr1,istr2,ci
            do ici=1,nci
              if(lrfocc(1,ici).eq.istr1 .and.
     *           lrfocc(2,ici).eq.istr2      ) then
                do istci=1,nstci
                  ovlp(istci)=ovlp(istci)+ev(ici,istci)*ci
                end do
                go to 102
              end if
            end do
  102       continue
          end do
          omax  =-ONE
          do istci=1,nstci
            if(.not.kstate(istci) .and. abs(ovlp(istci)).gt.omax) then
              istmax=istci
              omax  =abs(ovlp(istci))
            end if
          end do
          kstate(istmax)=.true.
          if(MASWRK) write(lunout,'(2i10,1x,f9.6)')
     *      istate,istmax,abs(ovlp(istmax))
        end do
c       write(lunout,
c    *    '(" *** Error stop in maximum overlap sorting ***"/
c    *      " count(kstate) =",i10,"  nstate =",i10)')
c    *        n,nstate
c         call abrt
c       end if
      end if
c
      end
      subroutine os_mxovlp_save(lrfocc,eigvec)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 26, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
c
      dimension lrfocc(2,nci), eigvec(nci,nstate)
c
      thresh=1.0d-03
c
      call seqrew(lunroc)       ! rewind lunroc
      read(lunroc) lrfocc
c
      call seqrew(lunmol)       ! rewind lunmol
      do istate=1,nstate
        n=0
        do ici=1,nci
          if(abs(eigvec(ici,istate)) .gt. thresh) n=n+1
        end do
        write(lunmol) n
        do ici=1,nci
          if(abs(eigvec(ici,istate)) .gt. thresh) write(lunmol)
     *      lrfocc(1,ici),lrfocc(2,ici),eigvec(ici,istate)
        end do
      end do
c
      end
      subroutine os_occ2det(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
c
c     Find index of pattern IOCC and store it into IDET
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      idet=1
      ne  =0
      do iorb=1,nsoact
        if(iocc(iorb)) then
          ne=ne+1
          idet=idet+marcwt(ne,iorb,meldif)
        end if
        if(mwt(ne,iorb,meldif).le.0) then
          idet=-1
          return
        end if
      end do
      end
      subroutine os_occ2det0(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 23, 2005 by HN                 ===
c=======================================================================
c
c     Find index of pattern IOCC and store it into IDET
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      idet=1
      ne  =0
      do iorb=1,nsoact
        if(iocc(iorb)) then
          ne=ne+1
          idet=idet+marcw0(ne,iorb,meldif)
        end if
        if(mwt0(ne,iorb,meldif).le.0) then
          idet=-1
          return
        end if
      end do
      end
      subroutine os_occ2deti(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 23, 2005 by HN                 ===
c=======================================================================
c
c     Find index of pattern IOCC and store it into IDET
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      idet=1
      ne  =0
      do iorb=1,nsoact
        if(iocc(iorb)) then
          ne=ne+1
          idet=idet+marcwi(ne,iorb,meldif)
        end if
        if(mwti(ne,iorb,meldif).le.0) then
          idet=-1
          return
        end if
      end do
      end
      subroutine os_occ2detx(idet,iocc,meldif)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 07, 2006 by HN                 ===
c=======================================================================
c
c     Find index of pattern IOCC and store it into IDET
c
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
c
      logical iocc(nsoact)
      idet=1
      ne  =0
      do iorb=1,nsoact
        if(iocc(iorb)) then
          ne=ne+1
          idet=idet+marcwx(ne,iorb,meldif)
        end if
        if(mwtx(ne,iorb,meldif).le.0) then
          idet=-1
          return
        end if
      end do
      end
      subroutine os_print_string(idet,coef,iocc,kpdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
      logical     iocc  (NSOMAX)
      dimension   istrng(NSOMAX)
      character*1 cstrng(NSOMAX/2)
      logical     kpdet
      if(idform.eq.0) then
        do i=1,nsoact
          if(iocc(i)) then
            istrng(i)=1
          else
            istrng(i)=0
          end if
        end do
        if(kpdet) then
          write(lunout,'(1x,i8,4x,128i1)')
     *      idet,     (istrng(k),k=1,nsoact)
        else
          write(lunout,'(1x,i8,f12.6,2x,128i1)')
     *      idet,coef,(istrng(i),i=1,nsoact)
        end if
      else
        do i=1,nmoact
          i1=lmo2so(1,i)
          i2=lmo2so(2,i)
          if     (     iocc(i1) .and.      iocc(i2)) then
            cstrng(i)='2'
          else if(     iocc(i1) .and. .not.iocc(i2)) then
            cstrng(i)='+'
          else if(.not.iocc(i1) .and.      iocc(i2)) then
            cstrng(i)='-'
          else
            cstrng(i)='0'
          end if
        end do
        if(kpdet) then
          write(lunout,'(1x,i8,4x,64a1)')
     *      idet,     (cstrng(i),i=1,nmoact)
        else
          write(lunout,'(1x,i8,f12.6,2x,64a1)')
     *      idet,coef,(cstrng(i),i=1,nmoact)
        end if
      end if
      end
      subroutine os_read_data(iop)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 22, 2007 by HN                 ===
c=======================================================================
c
c     iop=0: START
c        =1: MCSCF
c        =2: GMC-QDPT
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,ONE=1.0d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c     character*8   char8
c     character*128 chr128
c
c==== GAMESS commons ===================================================
      PARAMETER (MXATM=2000, MXRT=100, MXAO=8192)
c     _gms for avoiding same names
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,S,SZ,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORB,
     *                NA,NB,K,KST_gms,IROOT,IPURES,MAXW1,NITER,MAXP,
     *                  NCI_gms,
     *                IGPDET,KSTSYM,NFTGCI
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
c
      dimension kst(MAXSTA),wst(MAXSTA)
      dimension mstart(NSPCMX)
c     dimension mstart(NSPCMX),mine(NSPCMX),maxe(NSPCMX)
c
      parameter (nnam=46)
      dimension qnam(nnam),kqnam(nnam)
      data qnam/
     *  8hLPOUT   ,8hREFTYP  ,8hNELACT  ,8hNMOFZC  ,8hNMODOC  ,
     *  8hNMOACT  ,8hNMOFZV  ,8hMULT    ,8hSZ      ,8hISTSYM  ,
     *  8hNPDET   ,8hNEXCIT  ,8hMAXBAS  ,8hMXITER  ,8hMDI     ,
     *  8hISPINA  ,8hKNOSPN  ,8hKNOSYM  ,8hTHRENE  ,8hTHRCON  ,
     *  8hKSTATE  ,8hWSTATE  ,8hMOSPN   ,8hIWGT    ,8hKROT    ,
     *  8hKMPART  ,8hTHRDE   ,8hTHRWGT  ,8hCEXCEN  ,8hGSENE   ,
     *  8hEDSHFT  ,8hNMOCOR  ,8hNSPACE  ,8hMSTART  ,8hMINE    ,
     *  8hMAXE    ,8hNSOLUT  ,8hTHRERI  ,8hTHRGEN  ,8hKSZDOE  ,
     *  8hKFORB   ,8hTHRHDE  ,8hMXHOLE  ,8hMXPART  ,8hKSFORB  ,
     *  8hNILOOP  /
      data KQNAM/ 1, 5, 1, 1, 1,
     *            1, 1, 1, 3,31,
     *            1, 1, 1, 1, 1,
     *            1, 0, 0, 3, 3,
     *           -1,-3,-1, 1, 0,
     *            0, 3, 3, 5,23,
     *            3, 1, 1,-1,-1,
     *           -1, 1, 3, 3, 0,
     *            0, 3,-1,-1,-0,
     *            1/
      kqnam(21)=10*MAXSTA + 1
      kqnam(22)=10*MAXSTA + 3
      kqnam(23)=10*NSOMAX + 1
      kqnam(34)=10*NSPCMX + 1
      kqnam(35)=10*NSPCMX + 1
      kqnam(36)=10*NSPCMX + 1
      kqnam(43)=10*NSPCMX + 1
      kqnam(44)=10*NSPCMX + 1
      kqnam(45)=10*NSPCMX + 0
c
c**** Set values *******************************************************
      nbf = NUM
      idform=-1
c
c**** Set default values ***********************************************
      lpout =0
      reftyp='MRX     '
      nelact=-1
      nmofzc=numcor()
      nmodoc=NCORSV-nmofzc
      nmoact=NACT
      nmofzv=0
      mult  =MUL
      sz    =-ONE
      nspin =MUL-1
c     istsym=1
      istsym(1)=1
      istsym(2)=0
      istsym(3)=0
      npdet =0
      nexcit=0
      maxbas=100
      mxiter=200
      mdi   =300
      ispina=0
      knospn=.false.
      knosym=.false.
      threne=-1.0d-12
      thrcon= 1.0d-10
      kst   (1)=1
      wst   (1)=ONE
      do i=2,MAXSTA
        kst(i)=0
        wst(i)=ONE
      end do
c     Temporary mospn, lso2mo, and lmo2so, which will be remade
c     This part is only for routine os_read_data_mrx
      do i=2,NSOMAX,2
        mospn(i-1)=1
        mospn(i  )=2
      end do
      na=0
      nb=0
      do i=1,NSOMAX
        if(mospn(i).eq.1) then
          na=na+1
          lso2mo(i)=na
        else
          nb=nb+1
          lso2mo(i)=nb
        end if
      end do
      do i=1,NSOMAX
        lmo2so(mospn(i),lso2mo(i))=i
      end do
c     Clear mospn
      do i=1,NSOMAX
        mospn(i)=0
      end do
c
      iwgt  =1
      krot  =.true.
      kmpart=.false.
      thrwgt=1.0d-08
      thrde =5.0d-03
      cexcen='ev      '
      gsene (1)=ZERO
      gsene (2)=ZERO
c     edshft=0.02d+00
      edshft=ZERO
      nmocor=-1
      nsolut=-1
      threri=1.0d-12
      thrgen=1.0d-09
      kszdoe=.true.
      kforb =.true.
      thrhde=1.0d+00
      hdemax=ZERO
      do i=1,NSPCMX
        mxhole(i)=0
        mxpart(i)=0
        ksforb(i)=.false.
      end do
      niloop=1
c
c**** Read values ******************************************************
      call nameio(lunin,jret,'GMCPT   ',nnam,qnam,kqnam,
     *  lpout ,reftyp,nelact,nmofzc,nmodoc,
     *  nmoact,nmofzv,mult  ,sz    ,istsym,
     *  npdet ,nexcit,maxbas,mxiter,mdi   ,
     *  ispina,knospn,knosym,threne,thrcon,
     *  kst   ,wst   ,mospn ,iwgt  ,krot  ,
     *  kmpart,thrde ,thrwgt,cexcen,gsene ,
     *  edshft,nmocor,nspace,mstart,mine  ,
     *  maxe  ,nsolut,threri,thrgen,kszdoe,
     *  kforb ,thrhde,mxhole,mxpart,ksforb,
     *  niloop,
     *              0,0,0,0,
     *  0,0,0,0,0,0,0,0,0,0, 0,0,0,0)
c
      if(jret.ne.0) then
        if(MASWRK)
     *    write(lunout,
     *    '(" *** Error reading GMCPT input group ***")')
        call abrt
      end if
c
c**** Set other parameters *********************************************
      if(nmocor.ge.0) then      ! nmocor input
        nmodoc=nmocor-nmofzc
      else                      ! no nmocor input
        nmocor=nmodoc+nmofzc
      end if
c
      if(nelact.lt.0) nelact=NE-2*nmocor
c
      if(sz.lt.ZERO) then
        nspin=mult-1
      else
        nspin=int(sz+sz + 0.1d+00)
      end if
      if(nspin.eq.0) kszdoe=.false.
c
c     Remove frozen core orbs. and (re)define nmoext, nmocor, and nmo
c
      nmoext=NQMT-nmofzc-nmodoc-nmoact-nmofzv
      nmocor=       nmodoc
      nmo   =       nmodoc+nmoact+nmoext
c     nmocor=nmofzc+nmodoc
c     nmo   =nmofzc+nmodoc+nmoact+nmoext
c
      nsoact=nmoact*2
c     nelect=nelact+nmocor*2
c
      inifzc=1
      lasfzc=0
      inidoc=1
      lasdoc=nmodoc
      iniact=nmodoc+1
      lasact=nmodoc+nmoact
      iniext=nmodoc+nmoact+1
      lasext=nmodoc+nmoact+nmoext
c     inifzc=1
c     lasfzc=nmofzc
c     inidoc=nmofzc+1
c     lasdoc=nmofzc+nmodoc
c     iniact=nmofzc+nmodoc+1
c     lasact=nmofzc+nmodoc+nmoact
c     iniext=nmofzc+nmodoc+nmoact+1
c     lasext=nmofzc+nmodoc+nmoact+nmoext
c
      if     (iwgt.eq.1) then
        iniwgt=iniact
        laswgt=lasext
        nmowgt=lasext-iniact+1
      else if(iwgt.eq.-1) then
        iniwgt=inidoc
        laswgt=lasdoc
        nmowgt=lasdoc-inidoc+1
      else
        iniwgt=1
        laswgt=0
        nmowgt=0
      end if
c
      if(MASWRK .and. iop.ne.0) then
        write(lunout,'(/
     *    5x,"-------------------------------------------------"/
     *    5x,"GMC-PT/GMC-QDPT or general MCSCF input parameters"/
     *    5x,"-------------------------------------------------")')
        write(lunout,'(" # of frozen core orbs. =",i10," ->",i10/
     *                 " # of doubly occ. orbs. =",i10/
     *                 " # of active      orbs. =",i10/
     *                 " # of virtual     orbs. =",i10/
     *                 " # of active electrons  =",i10)')
     *  nmofzc,0,nmodoc,nmoact,nmoext,nelact
      end if
c
      if(reftyp.eq.'ORMAS   ' .or. reftyp.eq.'MRXOS   ') nexcit=0
c
c     kstate
c
      nstate=0
      do i=1,MAXSTA
        if(kst(i).ne.0) then
          kstate(i)=.true.
          nstci =i
          nstate=nstate+1
        else
          kstate(i)=.false.
        end if
      end do
c
      if(nsolut.lt.0) then  ! no input case
        nsolut=nstci
        if(.not.knospn .and. ispina.eq.0) nsolut=max(nstci*2,5)
      else                  ! input nsolut
        nsolut=max(nstci,nsolut)
      end if
c
c     avecoe
c
      n=0
      do i=1,nstci
        if(kstate(i)) then
          n=n+1
          avecoe(n)=wst(i)
        else
          wst(i)=ZERO
        end if
      end do
c
      s=ZERO
      do i=1,nstate
        s=s+avecoe(i)
      end do
      do i=1,nstate
        avecoe(i)=avecoe(i)/s
      end do
c
      if(MASWRK .and. iop.ne.0) then
        write(lunout,'(" # of states in CI      =",i10/
     *                 " Highest state in CI    =",i10)') nstate,nstci
        write(lunout,'( " kstate = ",35i2:/
     *                 ("          ",35i2  :) )') (kst   (i),i=1,nstci)
        write(lunout,'( " avecoe = ",10f6.3:/
     *                 ("          ",10f6.3:) )') (avecoe(i),i=1,nstate)
      END IF
c
      if     (reftyp.eq.'MRX     ') then
        call os_read_data_mrx
        ksforb(1)=kforb
        ksforb(2)=.false.
        ksforb(3)=kforb
      else if(reftyp.eq.'MRVX    ' .or. reftyp.eq.'MRXOS   ') then
        do i=1,nspace
          mstart(i)=mstart(i)-nmofzc-nmodoc
        end do
        do i=1,nspace-1
          morb(i)=2*( mstart(i+1)-mstart(i) )
        end do
        morb(nspace)=2*( nmoact+1-mstart(nspace) )
        if(.not.kforb) then
          do i=1,nspace
            ksforb(i)=.false.
          end do
        end if
      else if(reftyp.eq.'ORMAS   ') then
        do i=1,nspace
          mstart(i)=mstart(i)-nmofzc-nmodoc
        end do
        do i=1,nspace-1
          morb(i)=2*( mstart(i+1)-mstart(i) )
        end do
        morb(nspace)=2*( nmoact+1-mstart(nspace) )
        do i=1,nspace
          ksforb(i)=kforb
        end do
      else if(reftyp.eq.'RAS     ') then
        nspace=3
        do i=1,3
          mstart(i)=mstart(i)-nmofzc-nmodoc
        end do
        morb(1)=2*( mstart(2)-mstart(1) )
        morb(2)=2*( mstart(3)-mstart(2) )
        morb(3)=2*( nmoact+1 -mstart(3) )
        mine(1)=max(morb(1)-nexcit,0)
        maxe(1)=    morb(1)
        mine(2)=max(nelact-morb(1)-nexcit,0)
        maxe(2)=min(nelact-morb(1)+nexcit,morb(2))
        mine(3)=0
        maxe(3)=min(nexcit,morb(3))
        do i=1,3
          ksforb(i)=kforb
        end do
      end if
c
c     If no input for mospn, then make it.
      if(mospn(1).eq.0) then
        if(reftyp.eq.'MRVX    ' .or. reftyp.eq.'MRXOS   ') then
          do i=2,nsoact,2
            mospn(i-1)=1
            mospn(i  )=2
          end do
        else if(reftyp.eq.'ORMAS   ' .or. reftyp.eq.'RAS     ') then
          m=0
          do j=1,nspace
            do i=m+1,m+morb(j)/2
              mospn(i)=1
            end do
            do i=m+morb(j)/2+1,m+morb(j)
              mospn(i)=2
            end do
            m=m+morb(j)
          end do
        else if(reftyp.eq.'MRX     ') then
          m=0
          do j=1,3
            do i=m+1,m+morb(j)/2
              mospn(i)=1
            end do
            do i=m+morb(j)/2+1,m+morb(j)
              mospn(i)=2
            end do
            m=m+morb(j)
          end do
          do i=morb(1)+2,morb(1)+morb(2),2
            mospn(i-1)=1
            mospn(i  )=2
          end do
        end if
      end if
c$$$c
c$$$c       RAS1    RAS2       RAS3
c$$$c       1212... 11...22... 1212...
c$$$c
c$$$        do i=2,morb(1),2
c$$$          mospn(i-1)=1
c$$$          mospn(i  )=2
c$$$        end do
c$$$        do i=morb(1)+1,morb(1)+morb(2)/2
c$$$          mospn(i)=1
c$$$        end do
c$$$        do i=morb(1)+morb(2)/2+1,morb(1)+morb(2)
c$$$          mospn(i)=2
c$$$        end do
c$$$        do i=morb(1)+morb(2)+2,morb(1)+morb(2)+morb(3),2
c$$$          mospn(i-1)=1
c$$$          mospn(i  )=2
c$$$        end do
c$$$      end if
c
c     Remake lso2mo, and lmo2so
c
      na=0
      nb=0
      do i=1,nsoact
        if(mospn(i).eq.1) then
          na=na+1
        else
          nb=nb+1
        end if
      end do
      if(na.ne.nb) then
        if(MASWRK) then
          write(lunout,
     *      '(" *** Error stop in os_read_data ***"/
     *        " Numbers of alpha and beta spin-orbitals are not equal."/
     *        " # of alpha orbs. =",i10,"  # of beta orbs. =",i10)')
     *      na,nb
        END IF
        call abrt
      end if
c
      na=0
      nb=0
      do i=1,nsoact
        if(mospn(i).eq.1) then
          na=na+1
          lso2mo(i)=na
        else
          nb=nb+1
          lso2mo(i)=nb
        end if
      end do
c
      do i=1,nsoact
        lmo2so(mospn(i),lso2mo(i))=i
      end do
c
c     mosym
c
      do i=1,nsoact
        j=lso2mo(i)+nmofzc+nmodoc
        mosym(i)=irmon(j)
      end do
c
      if(MASWRK .and. iop.ne.0) then
        write(lunout,'(/" <<<Act. MO sym.: ",128i1)')
     *    (mosym(lmo2so(1,i)),i=1,nmoact)
      END IF
c
      do i=1,nsoact
        mosym(i)=mosym(i)-1
      end do
c
      if(knospn) ispina=0
c
c**** Copy some parameters to common DETWFN for transformation *********
      NCORSV = nmofzc+nmodoc
      NCOR   = nmofzc+nmodoc
      NORB   = nmofzc+nmodoc+nmoact
c     NHIGH = INT(SZ+SZ+0.0001D+00)
c     NB = (NELS-NHIGH)/2
c     NA = NB+NHIGH
c     MA = NA+NCORSV
c     MB = NB+NCORSV
c     NELTOT = 2*NCOR+NA+NB
      nact   = nmoact
c
c**** End **************************************************************
c     if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_read_data_mrx
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 26, 2007 by HN                 ===
c=======================================================================
c
c     Similar to os_make_graph_mrx, but aim of this routine is only
c     making morb
c
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension istrng(NSOMAX)
      logical   iocc  (NSOMAX)
      character*8   char8
c
c**** Read parant determinants *****************************************
      IF(MASWRK) THEN
c
        call seqrew(lunin)      ! rewind lunin
  100   continue
c
C-MWS     read(lunin,*,err=102,end=102) char8
C-MWS   if(char8.ne.'$PDET   ' .and. char8.ne.'$pdet   ' .and.
C-MWS*     char8.ne.'$GDS    ' .and. char8.ne.'$gds    ' .and.
C-MWS*     char8.ne.'$GCS    ' .and. char8.ne.'$gcs    ') go to 100
          read(lunin,fmt='(a8)',err=102,end=102) char8
        if(char8.ne.' $PDET  ' .and. char8.ne.' $pdet  ' .and.
     *     char8.ne.' $GDS   ' .and. char8.ne.' $gds   ' .and.
     *     char8.ne.' $GCS   ' .and. char8.ne.' $gcs   ') go to 100
c
        morb(1)=nsoact
        morb(3)=0
        do ipdet=1,npdet
          call os_read_string(istrng)
          do i=1,nsoact
            if(istrng(i).eq.1) then
              iocc(i)=.true.
            else
              iocc(i)=.false.
            end if
          end do
          call os_occ2det(idet,iocc,0)
          do i=1,nsoact
            if(.not.iocc(i) .and. lso2mo(i).lt.morb(1)) then
              morb(1)=lso2mo(i)
            end if
            if(     iocc(i) .and. lso2mo(i).gt.morb(3)) then
              morb(3)=lso2mo(i)
            end if
          end do
        end do
        nspace=3
        morb(1)=2*(morb(1)-1)
        morb(3)=nsoact-2*morb(3)
        morb(2)=nsoact-morb(1)-morb(3)
c
  102   continue
c
      END IF
c
      if(GOPARR) then
        call DDI_BCAST(5000,'I',nspace,1,MASTER)
        call DDI_BCAST(5000,'I',morb  ,3,MASTER)
      end if
      end
      subroutine os_read_int(hint,gint,ecore,hcore,gjkint,geoin1,geoin2)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,TWO=2.0d+00,HALF=0.5d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
c
      dimension hint(iniact:lasact,iniact:lasact)
      dimension gint(iniact:lasact,iniact:lasact,
     *               iniact:lasact,iniact:lasact)
c
c     Working arrays
c
      dimension hcore(nmo,nmo), gjkint(lasdoc,lasdoc)
      dimension geoin1(nmo,lasact,lasact),geoin2(nmo,lasact,lasact)
c
c**** Read integrals ***************************************************
      call seqrew(lunhcr)       ! rewind lunhcr
      read(lunhcr) hcore
c     if(.not.kmcscf) then  ! kmcscf is set to be F at parent routine.
        call seqrew(lungjk)       ! rewind lungjk
        read(lungjk) gjkint
        call seqrew(lungai)       ! rewind lungai
        read(lungai) gint         ! gint=gaint
        call seqrew(lungeo)       ! rewind lungeo
        read(lungeo) geoin1
        read(lungeo) geoin2
c     end if
c
c**** Compute core energy **********************************************
      ecore=ZERO
      do j=1,lasdoc
        ecore=ecore+TWO*hcore(j,j)
        do i=1,lasdoc
          ecore=ecore+gjkint(i,j)
        end do
      end do
c
c**** Store 1-e integrals **********************************************
      do j=iniact,lasact
      do i=iniact,lasact
        hint(i,j)=hcore(i,j)
      end do
      end do
c
c**** Modify 1-e and 2-e integrals *************************************
      do j=iniact,lasact
      do i=iniact,lasact
        do k=1,lasdoc
          hint(i,j)=hint(i,j)+TWO*geoin1(k,i,j)-geoin2(k,i,j)
        end do
        do k=iniact,lasact
          hint(i,j)=hint(i,j)-gint(i,k,k,j)*HALF
        end do
      end do
      end do
c
      do l=iniact,lasact
      do k=iniact,lasact
      do j=iniact,lasact
      do i=iniact,lasact
        gint(i,j,k,l)=gint(i,j,k,l)*HALF  ! gint(i,j,k,l)=(ij|kl)/2
      end do
      end do
      end do
      end do
c
c**** Clear small ints. ************************************************
      do j=iniact,lasact
      do i=iniact,lasact
        if(abs(hint(i,j)).lt.threri) hint(i,j)=ZERO
      end do
      end do
c
      do l=iniact,lasact
      do k=iniact,lasact
      do j=iniact,lasact
      do i=iniact,lasact
        if(abs(gint(i,j,k,l)).lt.threri) gint(i,j,k,l)=ZERO
      end do
      end do
      end do
      end do
c
c**** End **************************************************************
      end
      subroutine os_read_int_mcscf(hint  ,gint  ,ecore )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 28, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
      dimension hint(nmoact,nmoact), gint(nmoact,nmoact,nmoact,nmoact)
c
      LOGICAL PACK2E_gms,DDITRF
      PARAMETER (MXRT=100)
c     _gms for avoiding same names
      COMMON /DETWFN/ WSTATE_gms(MXRT),SPINS_gms(MXRT),CRIT_gms,
     *                  PRTTOL_gms,S_gms,SZ_gms,
     *                GRPDET_gms,STSYM_gms,GLIST_gms,
     *                NFLGDM_gms(MXRT),IWTS_gms(MXRT), NCORSV, NCOR_gms,
     *                  NACT, NORB_gms,
     *                NA_gms,NB_gms,K_gms,KST_gms,IROOT_gms,IPURES_gms,
     *                  MAXW1_gms,NITER_gms,MAXP_gms,NCI_gms,
     *                IGPDET_gms,KSTSYM_gms,NFTGCI_gms
      COMMON /FMCOM / D(1)
      COMMON /INTFIL/ NINTMX ,NHEX_gms,NTUPL_gms,PACK2E_gms,INTTYP_gms,
     *                  IGRDTYP_gms
c
      common /gmcddi/ DDITRF
c     DDITRF=GOPARR
c
      M1 = NACT
      M2 = (M1*M1+M1)/2
c
      IF(DDITRF) THEN
        NOCC  = NACT + NCORSV
        NOTR  = (NOCC*NOCC+NOCC)/2
        LENXX = NOTR
        LENIXX= 0
      ELSE
        LENXX = NINTMX
        LENIXX= NINTMX
      END IF
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + M2            ! X1
      n03 = n02 + LENXX         ! XX
      n04 = n03 + LENIXX        ! IX
      NEED = n04 - LOADFM - 1
      call GETFM(NEED)
c
      NCORE=NCORSV
      call GMS_RDCI12
     * (hint,gint,DDITRF,ijkt,d(n01),NCORE,M1,M2,d(n02),d(n03),
     *  NINTMX)
c    * (hint,gint,DDITRF,NFT ,X1    ,NCORE,M1,M2,XX    ,IX    ,
c    *  NINTMX)
c
      call RETFM(NEED)
c
c**** Modify 1-e and 2-e integrals *************************************
      do i=1,nmoact
      do j=1,nmoact
        do k=1,nmoact
          hint(i,j)=hint(i,j)-gint(i,k,k,j)*HALF
        end do
      end do
      end do
c
      do l=1,nmoact
      do k=1,nmoact
      do j=1,nmoact
      do i=1,nmoact
        gint(i,j,k,l)=gint(i,j,k,l)*HALF
      end do
      end do
      end do
      end do
c
c**** Screen hint and gint *********************************************
      do j=1,nmoact
      do i=1,nmoact
        if(abs(hint(i,j)).lt.threri) hint(i,j)=ZERO
      end do
      end do
      do l=1,nmoact
      do k=1,nmoact
      do j=1,nmoact
      do i=1,nmoact
        if(abs(gint(i,j,k,l)).lt.threri) gint(i,j,k,l)=ZERO
      end do
      end do
      end do
      end do
c
      ecore=ZERO
c
      end
      subroutine os_read_string(istrng)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 22, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
c
      character*128 chr128
      character*128 tmp128
      dimension   istrng(NSOMAX)
      character*1 cstrng(NSOMAX/2)
c     data idform /-1/
c
      do i=1,128
        chr128(i:i)='0'
      end do
c
C-MWS read(lunin,*) chr128
c
c        next code avoids an unformatted read, while doing the above.
c
      read(lunin,901) tmp128
  901 format(a128)
      do i=1,128
         if(tmp128(i:i).ne.' ') go to 40
      enddo
c           completely blank line?
      kol=128
      go to 50
c
   40 continue
      kol=i
c
   50 continue
      i=0
      do k=kol,128
         i=i+1
         chr128(i:i) = tmp128(k:k)
      enddo
c
  100 continue
      if(idform.eq.0) then
c
c       10 type
c
        read(chr128,'(128i1)') (istrng(i),i=1,nsoact)
      else if(idform.eq.1) then
c
c       2+-0 type
c
        read(chr128,'(64a1)' ) (cstrng(i),i=1,nmoact)
        do i=1,nmoact
          i1=lmo2so(1,i)
          i2=lmo2so(2,i)
          if     (cstrng(i).eq.'2') then
            istrng(i1)=1
            istrng(i2)=1
          else if(cstrng(i).eq.'+') then
            istrng(i1)=1
            istrng(i2)=0
          else if(cstrng(i).eq.'-') then
            istrng(i1)=0
            istrng(i2)=1
          else
            istrng(i1)=0
            istrng(i2)=0
          end if
        end do
      else
        do i=1,nmoact
          if(chr128(i:i).eq.'1') then
            idform=0
            go to 100
          end if
        end do
        do i=1,nmoact
          if(chr128(i:i).eq.'2' .or. chr128(i:i).eq.'+' .or.
     *       chr128(i:i).eq.'-') then
            idform=1
            go to 100
          end if
        end do
c
c       Assume 10 type
c
        idform=0
        go to 100
      end if
c     write(*,'(i10,1x,128i1)') idform,(istrng(i),i=1,nmoact)
c     write(*,'(i10,1x,128a1)') idform,(chr128(i:i),i=1,nmoact)
      end
      subroutine os_remake_graph(kremak,mwtdum,lrfocc)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 26, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (NELAMX=64)
*I64  parameter (NELAMX=128)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSGRAPH/
     *  MWT (0:NELAMX  ,0:NSOMAX,-3:0),MARCWT(0:NELAMX  ,0:NSOMAX,-3:0),
     *  MWT0(0:NELAMX  ,0:NSOMAX,-2:0),MARCW0(0:NELAMX  ,0:NSOMAX,-2:0),
     *  MWTI(0:NELAMX  ,0:NSOMAX,-4:0),MARCWI(0:NELAMX  ,0:NSOMAX,-4:0),
     *  MWTX(0:NELAMX+2,0:NSOMAX,-2:2),MARCWX(0:NELAMX+2,0:NSOMAX,-2:2),
     *  NSTR(-3:0), NSTR0(-2:0), NSTRI(-4:0), NSTRX(-2:2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension mwtdum(0:nelact,0:nsoact), lrfocc(2,nci)
      logical   iocc(NSOMAX), kremak
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_remake_graph ",44(1h*))')
        call ut_init_time
      END IF
c
c**** Save old ndet ****************************************************
      kremak=.false.
c
      ndet0s=ndet
      ndet1s=nstr(-1)
      ndet2s=nstr(-2)
      ndet3s=nstr(-3)
c
c**** Read new reference occupations ***********************************
      call seqrew(lunroc)       ! rewind lunroc
      read(lunroc) lrfocc
c
c**** Reset mwt, marcwt, and nstr arrays in module *********************
      call viclr(mwt   ,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(marcwt,1,(NELAMX+1)*(NSOMAX+1)*4)
      call viclr(nstr  ,1,5)
c
c**** Remake graph from selected reference determinants ****************
      do ici=1,nci
        call os_int2occ(iocc,lrfocc(1,ici))
        call viclr(mwtdum,1,(nelact+1)*(nsoact+1))
        mwtdum(0,0)=1
        n=0
        do j=1,nsoact
          if(iocc(j)) then
            n=n+1
            mwtdum(n,j)=1
          else
            mwtdum(n,j)=1
          end if
        end do
        do j=0,nsoact
        do i=0,nelact
          mwt(i,j,0)=mwt(i,j,0)+mwtdum(i,j)
        end do
        end do
      end do
c
      do j=0,nsoact
      do i=0,nelact
        if(mwt(i,j,0).gt.0) mwt(i,j,0)=1
      end do
      end do
c
c     write(lunout,'(" *** Selected reference graph ***")')
c     do i=nelact,0,-1
c       write(lunout,'(1x,128i1)') (mwt(i,j,0),j=0,nsoact)
c     end do
c
c**** Remake graphs of ionized determinants ****************************
      do k=-1,-3,-1
        if(nelact+k.lt.0) go to 100
        do j=0,nsoact
        do i=0,nelact
          mwt(i,j,k)=mwt(i,j,k+1)
        end do
        end do
        do j=0,nsoact
          mwt(nelact+k+1,j,k)=0
        end do
        do i=0,nelact+k
          do j=i,nsoact-nelact-k+i
            if(mwt(i+1,j,k+1).ne.0) mwt(i,j,k)=mwt(i+1,j,k+1)
          end do
        end do
      end do
  100 continue
c
      do k=0,-3,-1
        if(nelact+k.lt.0) go to 102
        do j=0,nsoact
        do i=0,nelact
          if(mwt(i,j,k).ne.0) mwt(i,j,k)=1
        end do
        end do
        do j=1,nsoact
c         do i=max(1,j-nsoact+nelact+k),min(nelact+k,j)
          do i=1,nelact
            if(mwt(i,j,k).ne.0) mwt(i,j,k)=mwt(i-1,j-1,k)+mwt(i,j-1,k)
          end do
        end do
      end do
  102 continue
c
      if(lpout.lt.0 .AND.MASWRK) then          ! debug output
        do i=0,-3,-1
          write(lunout,'(" *** Weight (",i2,") ***")') i
          call ut_imat_print_2
     *      (lunout,mwt(0,0,i),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end do
      end if
c
c**** Restore dimensions of string spaces ******************************
      do i=0,-3,-1
        if(nelact+i.lt.0) go to 104
        nstr(i)=mwt(nelact+i,nsoact,i)
      end do
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(" *** Dimension of selected ionized spaces ***")')
        do i=0,-3,-1
          write(lunout,'(i3," space: ",i10)') i,nstr(i)
        end do
      END IF
c
  104 continue
c
c**** Remake arc-weights ***********************************************
      do k=0,-3,-1
        if(nelact+k.lt.0) go to 106
        n=nstr(k)
        do i=1,nelact+k
          do j=1,nsoact
            if(mwt(i-1,j-1,k).ne.0) marcwt(i,j,k)=mwt(i,j-1,k)
          end do
        end do
        do i=nelact,1,-1
          do j=nsoact,1,-1
            if(mwt(i,j,k).eq.0 .or. mwt(i-1,j-1,k).eq.0)
     *        marcwt(i,j,k)=-n
          end do
          marcwt(i,0,k)=-n
        end do
        do j=0,nsoact
          if(mwt(0,j,k).eq.0) marcwt(0,j,k)=-n
        end do
        if(lpout.lt.0 .AND.MASWRK) then        ! debug output
          write(lunout,'(" *** Arc-weight (",i2,") ***")') k
          call ut_imat_print_2
     *      (lunout,marcwt(0,0,k),' ',NELAMX+1,0,nelact,0,nsoact,0,0)
        end if
      end do
  106 continue
c
c**** Reset ndet *******************************************************
      ndet=nstr(0)
c
      if( ndet0s.ne.ndet     .or. ndet1s.ne.nstr(-1) .or.
     *    ndet2s.ne.nstr(-2) .or. ndet3s.ne.nstr(-3)      ) then
        kremak=.true.
      end if
c
c     mstr0,1,2,3 are unnecessary for the present version
c
c     mstr0=nstr(-0)
c     mstr1=nstr(-1)
c     mstr2=nstr(-2)
c     mstr3=nstr(-3)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_remake_ref(lrfocc,lrdet)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 26, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrfocc(2,nci),lrdet(nci)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(/1x,10(1h*)," Routine os_remake_ref ",47(1h*))')
        call ut_init_time
      END IF
c
c**** Read new reference occupations ***********************************
      call seqrew(lunroc)       ! rewind lunroc
      read(lunroc) lrfocc
c
c**** Find reference determinants **************************************
      do ici=1,nci
        call os_int2det(lrdet(ici),lrfocc(1,ici),0)
      end do
c
c**** Write reference determinants *************************************
c     if(MASWRK) write(lunout,'(" nci =",i10,"  ndet =",i10)') nci,ndet
      if(MASWRK .and. kprint) then
        write(lunout,'(/" Dimension of reference space =",i10,
     *                  "  (from",i10," walks)")') nci,ndet
      end if
      call seqrew(lunref)       ! rewind lunref
      write(lunref) lrdet
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_s2_calc(nvec,eigvec,s2,v,vnorm2,i2sz)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: sep 03, 2005 by HN                 ===
c=======================================================================
c
c     This routine projects out the higher S**2 components from
c     wavefunctions.
c
c     S**2 = S-S+ + Sz**2 + Sz (= S+S- + Sz**2 -Sz)
c
c
c
c     mult  =2*sz+1=nspin+1
c     multmn=mult+2=nspin+3
c     multmx=min(nelact,nsoact-nelact)+1
c
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,HALF=0.5d+00)
      parameter (MAXSTA=100, NSPCMX=20)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
c
      dimension eigvec(nci,nvec)
      dimension s2    (nvec)
c               ==> actually s = -1/2+sqrt(1+4*s2)/2
c
c     Working arrays
c
      dimension v     (nci,nvec)
c     dimension lrfbab(0:nbab,nci)
      dimension vnorm2(nvec)
      dimension icc0p(NSOMAX), icc0m(NSOMAX), i2sz(nci)
c     dimension icc0p(nelact), icc0m(nelact), i2sz(nci) ! NSOMAX>=nelact
c
      call seqrew(lun2sz)       ! rewind lun2sz
      read(lun2sz) i2sz
c
c==== multmn=nspin+3
c==== multmx=min(nelact,nsoact-nelact)+1
c
c**** Compute norm *****************************************************
      do istci=1,nvec
        vnorm2(istci)=ZERO
        do ici=1,nci
          vnorm2(istci)=vnorm2(istci)+eigvec(ici,istci)**2
        end do
      end do
c
c**** Loop over higher multiplicity to be removed **********************
c     vnrmmn=ONE
c
c==== do imult=multmx,multmn,-1
c
c     Make S-S+|EV>
c
      call vclr(v,1,nci*nvec)
c
      call seqrew(lunccs)       ! rewind lunccs
c
  100 continue
        read(lunccs) np,nm
        if(np.lt.0) go to 102
        call os_lab_read(lunccs,np,icc0p)
        call os_lab_read(lunccs,nm,icc0m)
        do i=1,np
          iref=        icc0p(i)
          do j=1,np
            jref=        icc0p(j)
            do ivec=1,nvec
              v(iref,ivec)=v(iref,ivec)+eigvec(jref,ivec)
            end do
          end do
          do j=1,nm
            jref=        icc0m(j)
            do ivec=1,nvec
              v(iref,ivec)=v(iref,ivec)-eigvec(jref,ivec)
            end do
          end do
        end do
        do i=1,nm
          iref=        icc0m(i)
          do j=1,np
            jref=        icc0p(j)
            do ivec=1,nvec
              v(iref,ivec)=v(iref,ivec)-eigvec(jref,ivec)
            end do
          end do
          do j=1,nm
            jref=        icc0m(j)
            do ivec=1,nvec
              v(iref,ivec)=v(iref,ivec)+eigvec(jref,ivec)
            end do
          end do
        end do
      go to 100
  102 continue
c
c
c     Make S2|EV>=(S-S+ + Sz2 + Sz)|EV>
c
        do ici=1,nci
          sz=dble(i2sz(ici))*HALF
          sz21=sz*sz+sz
          do istci=1,nvec
            v(ici,istci)=v(ici,istci)+sz21*eigvec(ici,istci)
          end do
        end do
c       sz=dble(nspin)*HALF
c       sz21=sz*sz+sz
c
c       do istci=1,nvec
c       do ici=1,nci
c         v(ici,istci)=v(ici,istci)+sz21*eigvec(ici,istci)
c       end do
c       end do
c
c     Get S2
c
      do istci=1,nvec
        s2(istci)=ZERO
        do ici=1,nci
          s2(istci)=s2(istci)+eigvec(ici,istci)*v(ici,istci)
        end do
        s2(istci)=s2(istci)/vnorm2(istci)
      end do
c
c     S2 -> S
c
      do istci=1,nvec
        s2(istci)=sqrt(0.25d+00+s2(istci))-HALF
      end do
c
c**** End **************************************************************
      end
      subroutine os_s2_proj(nvec,eigvec,v,i2sz)
c     subroutine os_s2_proj(nvec,eigvec,s2)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 06, 2007 by HN                 ===
c=======================================================================
c
c     This routine projects out the higher S**2 components from
c     wavefunctions.
c
c     S**2 = S-S+ + Sz**2 + Sz (= S+S- + Sz**2 -Sz)
c
c
c
c     mult  =2*sz+1=nspin+1
c     multmn=mult+2=nspin+3
c     multmx=min(nelact,nsoact-nelact)+1
c
      implicit double precision (a-h,o-z)
      parameter (HALF=0.5d+00)
      parameter (MAXSTA=100, NSPCMX=20)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
c
      dimension eigvec(nci,nvec)
c     dimension s2    (nvec)
c               ==> actually s = -1/2+sqrt(1+4*s2)/2
c
c     Working arrays
c
      dimension v     (nci,nvec)
c     dimension lrfbab(0:nbab,nci)
      dimension icc0p(NSOMAX), icc0m(NSOMAX), i2sz(nci)
c     dimension icc0p(nelact), icc0m(nelact), i2sz(nci) ! NSOMAX>=nelact
c
      call seqrew(lun2sz)       ! rewind lun2sz
      read(lun2sz) i2sz
c
c     multmn=mult+2
      multmn=nspin+1
      multmx=min(nelact,nsoact-nelact)+1
c
c**** Normalize eigvec *************************************************
c     do istci=1,nvec
c       vnorm=ZERO
c       do ici=1,nci
c         vnorm=vnorm+eigvec(ici,istci)*eigvec(ici,istci)
c       end do
c       vnorm=ONE/sqrt(vnorm)
c       do ici=1,nci
c         eigvec(ici,istci)=vnorm*eigvec(ici,istci)
c       end do
c     end do
c
c**** Loop over higher multiplicity to be removed **********************
c     vnrmmn=ONE
c
c     do imult=multmx,multmn,-2
      do imult=multmn,multmx,2
        if(imult.eq.mult) go to 104
c
c     Make S-S+|EV>
c
        call vclr(v,1,nci*nvec)
        call seqrew(lunccs)     ! rewind lunccs
  100   continue
          read(lunccs) np,nm
          if(np.lt.0) go to 102
          call os_lab_read(lunccs,np,icc0p)
          call os_lab_read(lunccs,nm,icc0m)
          do i=1,np
            iref=icc0p(i)
            do j=1,np
              jref=icc0p(j)
              do ivec=1,nvec
                v(iref,ivec)=v(iref,ivec)+eigvec(jref,ivec)
              end do
            end do
            do j=1,nm
              jref=icc0m(j)
              do ivec=1,nvec
                v(iref,ivec)=v(iref,ivec)-eigvec(jref,ivec)
              end do
            end do
          end do
          do i=1,nm
            iref=icc0m(i)
            do j=1,np
              jref=icc0p(j)
              do ivec=1,nvec
                v(iref,ivec)=v(iref,ivec)-eigvec(jref,ivec)
              end do
            end do
            do j=1,nm
              jref=icc0m(j)
              do ivec=1,nvec
                v(iref,ivec)=v(iref,ivec)+eigvec(jref,ivec)
              end do
            end do
          end do
          go to 100
  102   continue
c
c       Make S2|EV>=(S-S+ + Sz2 + Sz)|EV>
c
        do ici=1,nci
          sz=dble(i2sz(ici))*HALF
          sz21=sz*sz+sz
          do istci=1,nvec
            v(ici,istci)=v(ici,istci)+sz21*eigvec(ici,istci)
          end do
        end do
c       sz=dble(nspin)*HALF
c       sz21=sz*sz+sz
c
c       do istci=1,nvec
c       do ici=1,nci
c         v(ici,istci)=v(ici,istci)+sz21*eigvec(ici,istci)
c       end do
c       end do
c
c       Project out S2=S*(S+1)=(imult-1)/2*(imult+1)/2 component
c
        s2del=dble( (imult-1)*(imult+1) )*0.25d+00
        s2rem=dble( ( mult-1)*( mult+1) )*0.25d+00
        do istci=1,nvec
          do ici=1,nci
            eigvec(ici,istci)=(v(ici,istci)-s2del*eigvec(ici,istci))
     *        /(s2rem-s2del)
          end do
        end do
c
  104   continue
c
c     *** Loop end ***
c
      end do
c
c**** End **************************************************************
      end
      subroutine os_select_ref(lrf2or,lrfocc,eigvec)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
*I32  parameter (INTBIT=32)
*I64  parameter (INTBIT=64)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension lrf2or(nci), lrfocc(2,nci)
      dimension eigvec(nci,nstate)
c
c     Clone function(s) for f77
c-f77 logical btest
c-f77 btest(i,j)=iand(1,    ishft(i,-j))
c-f77 ibset(i,j)=ior (i,    ishft(1, j))
c-f77 ibclr(i,j)=iand(i,not(ishft(1, j)))
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,'(/1x,10(1h*)," Routine os_select_ref ",46(1h*))')
        call ut_init_time
      END IF
c
c**** Read refernce determinants and eigenvectors **********************
      call seqrew(lunref)       ! rewind lunref
      read(lunref) lrf2or
      call seqrew(luneig)       ! rewind luneig
      read(luneig) eigvec
c
c**** Re-select reference determinants according to CI coefficients ****
      thrcoe=sqrt(thrwgt)
c
      if(ispina.ne.2) then
c
        do ici=1,nci
          do istate=1,nstate
            if(abs(eigvec(ici,istate)).gt.thrcoe) go to 100
          end do
          lrf2or(ici)=0
  100     continue
        end do
c
      else  ! spin adaptation
c
        call seqrew(lunroc)     ! rewind lunroc
        read(lunroc) lrfocc
c
c
c     Make orbital configurations
c
        do ici=1,nci
          do imo=1,nmoact
            ia=lmo2so(1,imo)-1
            ib=lmo2so(2,imo)-1
            if     (ia.lt. INTBIT .and. ib.lt. INTBIT) then
              if(.not.btest(lrfocc(1,ici),ia   ) .and.
     *                btest(lrfocc(1,ici),ib   )           ) then
                lrfocc(1,ici)=ibset(lrfocc(1,ici),ia       )
                lrfocc(1,ici)=ibclr(lrfocc(1,ici),ib       )
              end if
            else if(ia.lt. INTBIT .and. ib.ge.INTBIT) then
              if(.not.btest(lrfocc(1,ici),ia   ) .and.
     *                btest(lrfocc(2,ici),ib-INTBIT)       ) then
                lrfocc(1,ici)=ibset(lrfocc(1,ici),ia       )
                lrfocc(2,ici)=ibclr(lrfocc(2,ici),ib-INTBIT)
              end if
            else if(ia.ge.INTBIT .and. ib.lt. INTBIT) then
              if(.not.btest(lrfocc(2,ici),ia-INTBIT) .and.
     *                btest(lrfocc(1,ici),ib   )           ) then
                lrfocc(2,ici)=ibset(lrfocc(2,ici),ia-INTBIT)
                lrfocc(1,ici)=ibclr(lrfocc(1,ici),ib       )
              end if
            else
              if(.not.btest(lrfocc(2,ici),ia-INTBIT) .and.
     *                btest(lrfocc(2,ici),ib-INTBIT)       ) then
                lrfocc(2,ici)=ibset(lrfocc(2,ici),ia-INTBIT)
                lrfocc(2,ici)=ibclr(lrfocc(2,ici),ib-INTBIT)
              end if
            end if
          end do
        end do
c
        do ici=1,nci
          if(lrf2or(ici).lt.0) go to 102
          do istate=1,nstate
            if(abs(eigvec(ici,istate)).gt.thrcoe) then
              lrf2or(ici)=-abs(lrf2or(ici))
              do jci=1,nci
                if(lrfocc(1,jci).eq.lrfocc(1,ici) .and.
     *             lrfocc(2,jci).eq.lrfocc(2,ici)      )
     *            lrf2or(jci)=-abs(lrf2or(jci))
              end do
              go to 102
            end if
          end do
  102     continue
        end do
c
        do ici=1,nci
          if(lrf2or(ici).lt.0) then
            lrf2or(ici)=-lrf2or(ici)
          else
            lrf2or(ici)=0
          end if
        end do
c
      end if
c
c**** Reset nci and lrf2or(=lrdet) *************************************
      ncinew=0
c
      do ici=1,nci
        if(lrf2or(ici).ne.0) then
          ncinew=ncinew+1
          lrf2or(ncinew)=lrf2or(ici)
        end if
      end do
c
      nciold=nci
      nci   =ncinew
c
c**** Over-write reference determinants ********************************
      if(MASWRK) then
        write(lunout,
     *    '(/" *** Determinant selection according to CI coefficients"//
     *       " Criterion for CI selection: |Ci| >",1p,d13.6)')
     *       thrcoe
        write(lunout,'(" New Dim. =",i10,"  Old Dim. =",i10,
     *                 "  (from",i10," walks)")') nci,nciold,ndet
      end if
c
      call seqrew(lunref)       ! rewind lunref
      call os_lab_write(lunref,ncinew,lrf2or)
c     write(lunref) lrf2or(1:ncinew)
c
c**** Over-write reference occupations *********************************
      do ici=1,ncinew
        call os_det2int(lrf2or(ici),lrfocc(1,ici),0)
      end do
c
      call seqrew(lunroc)       ! rewind lunroc
      call os_lab_write(lunroc,2*ncinew,lrfocc)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_setup_mcqdpt
     *  (nummx1,
     *   eigvec,den1  ,eorb  ,edet  ,eref  ,hcore ,geoin1,geoin2,list  ,
     *   lrf2or,lor2rf)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Aug 16, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,TWO=2.0d+00,HALF=0.5d+00)
*I32  parameter (NSOMAX=64)
*I64  parameter (NSOMAX=128)
      parameter (MAXSTA=100, NSPCMX=20)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
      COMMON /OSSOMO/
     *  MOSYM(NSOMAX),MOSPN(NSOMAX),LSO2MO(NSOMAX),LMO2SO(2,NSOMAX/2)
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension eigvec(nci,nstate) ! input
c
c     den1(:,:,2,1:nstate) : density matrix for each state
c         (:,:,2,0       ) : state-avaraged density matrix
c
      dimension den1(iniact:lasact,iniact:lasact,2,0:nstate) ! output
      dimension eorb(nmo,2,0:nstate), edet(nci,0:nstate),
     *          eref(nstate,0:nstate)                        ! output
      dimension hcore(nmo,nmo)
      dimension geoin1(nmo,lasact,lasact),geoin2(nmo,lasact,lasact)
c     nummx1=nelact*(nsoact-nelact+1)  Check! Check! Check!
      dimension list(3,nummx1)
      dimension lrf2or(nci) ,lor2rf(ndet)             ! working
c
      logical   iocc(NSOMAX)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_setup_mcqdpt ",44(1h*))')
        call ut_init_time
      END IF
c
      thrcoe=0.10d+00
c
c**** Read eigenvectors and table **************************************
      call seqrew(luneig)       ! rewind luneig
      read(luneig) eigvec
      call seqrew(lunhcr)       ! rewind lunhcr
      read(lunhcr) hcore
      call seqrew(lungeo)       ! rewind lungeo
      read(lungeo) geoin1
      read(lungeo) geoin2
c
c**** Make density matrix **********************************************
c     mstr0=nstr( 0)
c     mstr1=nstr(-1)
      call os_init_cc1(lrf2or,lor2rf)
c
      call vclr(den1,1,nmoact*nmoact*2*(nstate+1))
c
      do jdet=1,nci
c
        call os_make_cc1_v1(nummx1,numelm,jdet ,list,lrf2or,lor2rf)
c
        do m=1,numelm
          lp  =lso2mo( list(1,m) )+nmocor
          lq  =lso2mo( list(2,m) )+nmocor
          is  =mospn ( list(1,m) )
c             =mospn ( list(2,m) )
          idet=list(3,m)
          if(idet.gt.0) then
            do istate=1,nstate
              den1(lp,lq,is,istate)=den1(lp,lq,is,istate)
     *          +eigvec(idet,istate)*eigvec(jdet,istate)
            end do
          else
            idet=-idet
            do istate=1,nstate
              den1(lp,lq,is,istate)=den1(lp,lq,is,istate)
     *          -eigvec(idet,istate)*eigvec(jdet,istate)
            end do
          end if
        end do
      end do
c
      do istate=1,nstate
        do j=iniact,lasact
        do i=iniact,lasact
          den1(i,j,1,0)=den1(i,j,1,0)+avecoe(istate)*den1(i,j,1,istate)
          den1(i,j,2,0)=den1(i,j,2,0)+avecoe(istate)*den1(i,j,2,istate)
        end do
        end do
      end do
c
c     Print density matrix
c
      if(MASWRK) then
      if(.not.kmpart .or. nstate.eq.1) then
        write(lunout,
     *    '(/" Diagonal elements of averaged one-particle density",
     *       " matrix:")')
        init=iniact
  100   continue
          last=min(init+9,lasact)
          write(lunout,'(10i8)') (i,i=init,last)
          write(lunout,'(10f8.4)') (den1(i,i,1,0),i=init,last)
          write(lunout,'(10f8.4)') (den1(i,i,2,0),i=init,last)
          init=last+1
        if(init.le.lasact) go to 100
      else
        write(lunout,
     *    '(/" Diagonal elements of one-particle density matrix:")')
        do istate=1,nstate
          write(lunout,'(/" State #",i5)') istate
          init=iniact
  102     continue
            last=min(init+9,lasact)
            write(lunout,'(10i8)') (i,i=init,last)
            write(lunout,'(10f8.4)') (den1(i,i,1,istate),i=init,last)
            write(lunout,'(10f8.4)') (den1(i,i,2,istate),i=init,last)
            init=last+1
          if(init.le.lasact) go to 102
        end do
      end if
      END IF
c
c**** Compute orbital energies *****************************************
      call vclr(eorb,1,nmo*2*(nstate+1))
c
      do istate=0,nstate
        do i=1,nmo
          do k=inifzc,lasdoc
            eorb(i,1,istate)=eorb(i,1,istate)+TWO*geoin1(i,k,k)
     *                                       -    geoin2(i,k,k)
            eorb(i,2,istate)=eorb(i,2,istate)+TWO*geoin1(i,k,k)
     *                                       -    geoin2(i,k,k)
          end do
          do l=iniact,lasact
          do k=iniact,lasact
            eorb(i,1,istate)=eorb(i,1,istate)
     *        + den1(k,l,1,istate)*(geoin1(i,k,l)-geoin2(i,k,l))
     *        + den1(k,l,2,istate)* geoin1(i,k,l)
            eorb(i,2,istate)=eorb(i,2,istate)
     *        + den1(k,l,2,istate)*(geoin1(i,k,l)-geoin2(i,k,l))
     *        + den1(k,l,1,istate)* geoin1(i,k,l)
          end do
          end do
          eorb(i,1,istate)=eorb(i,1,istate)+hcore(i,i)
          eorb(i,2,istate)=eorb(i,2,istate)+hcore(i,i)
          if(.not.kszdoe) then
            s=(eorb(i,1,istate)+eorb(i,1,istate))*HALF
            eorb(i,1,istate)=s
            eorb(i,2,istate)=s
          end if
        end do
      end do
c
      if(MASWRK) then
      if(.not.kmpart .or. nstate.eq.1) then
        write(lunout,'(/" Orbital energies:")')
        init=max(iniact-10,1)
        last=iniact-1
        if(init.le.last) then
          write(lunout,'(1x,8(1h-),
     *      " Doubly-occupied orbitals (highest several orbs.) ",
     *      7(1h-))')
c
          inicol=init
  104     continue
            lascol=min(inicol+4,last)
            write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
            write(lunout,'(1x,1p,5d13.6)') (eorb(j,1,0),j=inicol,lascol)
            if(kszdoe)
     *      write(lunout,'(1x,1p,5d13.6)') (eorb(j,2,0),j=inicol,lascol)
            inicol=lascol+1
          if(inicol .le. last) go to 104
c
        end if
        write(lunout,'(1x,8(1h-)," Active orbitals ",40(1h-))')
c
        inicol=iniact
  106   continue
          lascol=min(inicol+4,lasact)
          write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
          write(lunout,'(1x,1p,5d13.6)') (eorb(j,1,0),j=inicol,lascol)
          if(kszdoe)
     *    write(lunout,'(1x,1p,5d13.6)') (eorb(j,2,0),j=inicol,lascol)
          inicol=lascol+1
        if(inicol .le. lasact) go to 106
c
        init=lasact+1
        last=min(lasact+10,nmo)
        if(init.le.last) then
          write(lunout,'(1x,8(1h-),
     *      " External orbitals (lowest several orbs.) ",15(1h-))')
c
          inicol=init
  108     continue
            lascol=min(inicol+4,last)
            write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
            write(lunout,'(1x,1p,5d13.6)') (eorb(j,1,0),j=inicol,lascol)
            if(kszdoe)
     *      write(lunout,'(1x,1p,5d13.6)') (eorb(j,2,0),j=inicol,lascol)
            inicol=lascol+1
          if(inicol .le. last) go to 108
c
        end if
      else
        write(lunout,'(/" Orbital energies:")')
        do istate=1,nstate
          write(lunout,'(/" State #",i5)') istate
          init=max(iniact-10,1)
          last=iniact-1
          if(init.le.last) then
            write(lunout,'(1x,8(1h-),
     *        " Doubly-occupied orbitals (highest several orbs.) ",
     *        7(1h-))')
c
            inicol=init
  110       continue
              lascol=min(inicol+4,last)
              write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
              write(lunout,'(1x,1p,5d13.6)')
     *          (eorb(j,1,istate),j=inicol,lascol)
              if(kszdoe)
     *        write(lunout,'(1x,1p,5d13.6)')
     *          (eorb(j,2,istate),j=inicol,lascol)
              inicol=lascol+1
            if(inicol .le. last) go to 110
c
          end if
          write(lunout,'(1x,8(1h-)," Active orbitals ",40(1h-))')
c
          inicol=iniact
  112     continue
            lascol=min(inicol+4,lasact)
            write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
            write(lunout,'(1x,1p,5d13.6)')
     *        (eorb(j,1,istate),j=inicol,lascol)
            if(kszdoe)
     *      write(lunout,'(1x,1p,5d13.6)')
     *        (eorb(j,2,istate),j=inicol,lascol)
            inicol=lascol+1
          if(inicol .le. lasact) go to 112
c
          init=lasact+1
          last=min(lasact+10,nmo)
          if(init.le.last) then
            write(lunout,'(1x,8(1h-),
     *        " External orbitals (lowest several orbs.) ",
     *        15(1h-))')
c
            inicol=init
  114       continue
              lascol=min(inicol+4,last)
              write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
              write(lunout,'(1x,1p,5d13.6)')
     *          (eorb(j,1,istate),j=inicol,lascol)
              if(kszdoe)
     *        write(lunout,'(1x,1p,5d13.6)')
     *          (eorb(j,2,istate),j=inicol,lascol)
              inicol=lascol+1
            if(inicol .le. last) go to 114
c
          end if
        end do
      end if
      END IF
c
c**** Compute zeroth-order energies of reference states and determinants
      call seqrew(lunref)       ! rewind lunref
      read(lunref) lrf2or
c     rewind lunroc
c     read(lunroc) lrfocc
c
      do istate=0,nstate
        ec=ZERO
c       do i=1,lasdoc
c         ec=ec+eorb(i,1,istate)+eorb(i,2,istate)
c       end do
        do i=1,nci
          edet(i,istate)=ec
        end do
        do i=1,nstate
          eref(i,istate)=ec
        end do
      end do
c
      do istate=0,nstate
        do i=1,nci
          call os_det2occ(lrf2or(i),iocc,0)
          do iso=1,nsoact
            if(iocc(iso)) then
              imo=lso2mo( iso )
              is =mospn ( iso )
              edet(i,istate)=edet(i,istate)+eorb(imo+nmocor,is,istate)
            end if
          end do
        end do
      end do
c
      do istate=0,nstate
        do i=1,nstate
          do imo=iniact,lasact
            eref(i,istate)=eref(i,istate)
     *        +den1(imo,imo,1,i)*eorb(imo,1,istate)
     *        +den1(imo,imo,2,i)*eorb(imo,2,istate)
          end do
        end do
      end do
c
      if(lpout.le.-100 .AND.MASWRK) then      ! debug output
        write(lunout,'(" *** 0th-order determiant-energies ***")')
        call ut_rmat_print_2(lunout,edet,' ',nci,1,nci,0,nstate,1,0)
c       call ut_mat_print(edet,'g',1,nci,0,nstate,1,0)
        write(lunout,'(" *** 0th-order reference-energies ***")')
        call ut_rmat_print_2
     *    (lunout,eref,' ',nstate,1,nstate,0,nstate,1,0)
c       call ut_mat_print(eref,'g',1,nstate,0,nstate,1,0)
      end if
c
c**** If multi-partitioning flag is off, copy avaraged energies to all *
      if(.not.kmpart) then
        do istate=1,nstate
          do i=1,nmo
            eorb(i,1,istate)=eorb(i,1,0)
            eorb(i,2,istate)=eorb(i,2,0)
          end do
          do i=1,nci
            edet(i,istate)=edet(i,0)
          end do
          do i=1,nstate
            eref(i,istate)=eref(i,0)
          end do
        end do
      end if
c
c**** Quasi-degeneracy checking ****************************************
      if(thrde.gt.ZERO) then
        thrqdc=thrde
      else
        thrqdc=5.0d-03
      end if
c
      if(MASWRK .and. thrqdc.gt.ZERO) then
c
c     i -> k
c
        write(lunout,
     *    '(/" *** Quasi-degeneracy checking"//
     *      " === Det (|Ci| >",1p,d8.1," and dE <",d8.1,")")')
     *    thrcoe,thrqdc
        write(lunout,
     *    '(/" # of small denominators (single excitations)"/
     *    1x,"State",7x,"dEmin",4("  dE <",1p,d8.1)         /
     *    1x,5(1h-),1x,11(1h-),4(1x,13(1h-))) ')
     *    thrqdc,thrqdc/10,thrqdc/100,thrqdc/1000
        do istate=1,nstate
          n1   =0
          n10  =0
          n100 =0
          n1000=0
          demin=thrqdc
          do idet=1,nci
            ci=eigvec(idet,istate)
            if(abs(ci) .lt. thrcoe) go to 120  ! cycle
            call os_det2occ(lrf2or(idet),iocc,0)
            do ki=inidoc,lasact
            do isi=1,2
              if(ki-lasdoc.ge.1 .and. .not.iocc(lmo2so(isi,ki-lasdoc)))
     *          go to 118       ! cycle
            do ke=iniact,lasext
            do ise=1,2
              if(ke-lasdoc.le.nmoact .and. iocc(lmo2so(ise,ke-lasdoc)))
     *          go to 116       ! cycle
              if( iniact.le.ki .and. ke.le.lasact )
     *          go to 116       ! cycle
              de=eorb(ke,ise,istate)-eorb(ki,isi,istate)
     *          +edet(idet,istate)-eref(istate,istate)
              if(abs(de).lt.thrqdc) then
                n1=n1+1
                if(abs(de).lt.thrqdc*1.0d-01) n10  =n10  +1
                if(abs(de).lt.thrqdc*1.0d-02) n100 =n100 +1
                if(abs(de).lt.thrqdc*1.0d-03) n1000=n1000+1
                if(abs(de).lt.demin) demin=abs(de)
              end if
  116         continue
            end do
            end do
  118         continue
            end do
            end do
  120       continue
          end do
          write(lunout,'(i6,3x,1p,d9.2,4i14)')
     *      istate,demin,n1,n10,n100,n1000
        end do
c
c     ij -> kl
c
        write(lunout,
     *    '(/" # of small denominators (double excitations)"/
     *    1x,"State",7x,"dEmin",4("  dE <",1p,d8.1)         /
     *    1x,5(1h-),1x,11(1h-),4(1x,13(1h-))) ')
     *    thrqdc,thrqdc/10,thrqdc/100,thrqdc/1000
        do istate=1,nstate
          n1   =0
          n10  =0
          n100 =0
          n1000=0
          demin=thrqdc
          do idet=1,nci
            ci=eigvec(idet,istate)
            if(abs(ci) .lt. thrcoe) go to 130  ! cycle
            call os_det2occ(lrf2or(idet),iocc,0)
c
            do ki=inidoc,lasact
            do isi=1,2
              if(ki-lasdoc.ge.1 .and. .not.iocc(lmo2so(isi,ki-lasdoc)))
     *          go to 128       ! cycle
c
            do kj=ki+1  ,lasact
            do isj=1,2
              if(kj-lasdoc.ge.1 .and. .not.iocc(lmo2so(isj,kj-lasdoc)))
     *          go to 126       ! cycle
c
            do ke=iniact,lasext
            do ise=1,2
              if(ke-lasdoc.le.nmoact .and. iocc(lmo2so(ise,ke-lasdoc)))
     *          go to 124       ! cycle
c
            do kf=ke+1  ,lasext
            do isf=1,2
              if(kf-lasdoc.le.nmoact .and. iocc(lmo2so(isf,kf-lasdoc)))
     *          go to 122       ! cycle
              if( iniact.le.ki .and. kf.le.lasact ) go to 122  ! cycle
c                                           excluce internals
              if( (ki.eq.ke .and. isi.eq.ise) .or.
     *            (ki.eq.kf .and. isi.eq.isf) .or.
     *            (kj.eq.ke .and. isj.eq.ise) .or.
     *            (kj.eq.kf .and. isj.eq.isf)     ) go to 122  ! cycle
c                                   exclude singles equvalent
              de=eorb(ke,ise,istate)+eorb(kf,isf,istate)
     *          -eorb(ki,isi,istate)-eorb(kj,isj,istate)
     *          +edet(idet,istate)-eref(istate,istate)
              if(abs(de).lt.thrqdc) then
                if(lpout.lt.0) then
                  write(lunout,'(6i6,5x,f10.6,5x,1p,d10.3)')
     *              istate,idet,ki,kj,ke,kf,abs(ci),de
                end if
                n1=n1+1
                if(abs(de).lt.thrqdc*1.0d-01) n10  =n10  +1
                if(abs(de).lt.thrqdc*1.0d-02) n100 =n100 +1
                if(abs(de).lt.thrqdc*1.0d-03) n1000=n1000+1
                if(abs(de).lt.demin) demin=abs(de)
              end if
  122         continue
            end do
            end do
c
  124         continue
            end do
            end do
c
  126         continue
            end do
            end do
c
  128         continue
            end do
            end do
c
  130       continue
          end do
          write(lunout,'(i6,3x,1p,d9.2,4i14)')
     *      istate,demin,n1,n10,n100,n1000
        end do
      end if
c
c**** Write eorb, edet, and eref ***************************************
      call seqrew(luneob)       ! rewind luneob
      write(luneob) eorb
      call seqrew(lunedt)       ! rewind lunedt
      write(lunedt) edet
      call seqrew(lunerf)       ! rewind lunerf
      write(lunerf) eref
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_shuffle
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
c==== GAMESS commons ===================================================
      COMMON /FMCOM / d(1)
      LOGICAL PACK2E
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
c
      if(MASWRK .and. lpout.eq.1) then
c     if(.not.kmcscf .AND.MASWRK) then  ! because kmcscf is F
        write(lunout, '(/1x,10(1h*)," Routine os_shuffle ",49(1h*))')
        call ut_init_time
      end if
c
c**** Sort internal integrals ******************************************
      if(.NOT.GOPARR) then
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nmo*(nmo+1)/2       ! cfktri
c       n02 = n01 + nbf*(nbf+1)/2       ! cfktri
        n03 = n02 + nmo*nmo             ! cfock
        n04 = n03 + nmo*nmo*(lasdoc+1)  ! veff1
        n05 = n04 + nmo*nmo*(lasdoc+1)  ! veff2
        n06 = n05 + lasdoc*lasdoc       ! gjint
        n07 = n06 + lasdoc*lasdoc       ! gkint
        n08 = n07 + nmoact**4           ! gaint
        n09 = n08 + nmo*lasact*lasact   ! geoin1
        n10 = n09 + nmo*lasact*lasact   ! geoin2
        n11 = n10 + NINTMX              ! ix
        n12 = n11 + NINTMX              ! xx
        NEED = n12 - LOADFM - 1
        call GETFM(NEED)
c
        call os_shuffle_2e_int
     *  (d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10),d(n11))
        call RETFM(NEED)
c
      else
c
        call VALFM(LOADFM)
        n01 = LOADFM + 1
        n02 = n01 + nmo*(nmo+1)/2       ! cfktri
c       n02 = n01 + nbf*(nbf+1)/2       ! cfktri
        n03 = n02 + nmo*nmo             ! cfock
        n04 = n03 + nmo*nmo*(lasdoc+1)  ! veff1
        n05 = n04 + nmo*nmo*(lasdoc+1)  ! veff2
        n06 = n05 + lasdoc*lasdoc       ! gjint
        n07 = n06 + lasdoc*lasdoc       ! gkint
        n08 = n07 + nmoact**4           ! gaint
        n09 = n08 + nmo*lasact*lasact   ! geoin1
        n10 = n09 + nmo*lasact*lasact   ! geoin2
        n11 = n10 + max((nmofzc+nmodoc+nmoact)**2,nmoext*nmoext) ! xx
        NEED = n11 - LOADFM - 1
        call GETFM(NEED)
c
        call os_shuffle_2e_int_par
     *  (d(n01),d(n02),d(n03),d(n04),d(n05),d(n06),d(n07),d(n08),d(n09),
     *   d(n10))
        call RETFM(NEED)
c
      end if
c
c     if(kmcscf) return  ! kmcscf is F at parent routine
c
      if(GOPARR) then
        if(maswrk .and. lpout.eq.1) call ut_report_time
        return
      end if
c
c**** Sort 1-external integrals ****************************************
      call VALFM(LOADFM)
      call GOTFM(NGOTMX)
      n01 = LOADFM + 1
      n02 = n01 + 3*(nmoact+nmoext)*(nmodoc+nmoact)**2  ! labint
      n03 = n02 +   (nmoact+nmoext)*(nmodoc+nmoact)**2  ! valint
      n04 = n03 + NINTMX                                ! ix
      n05 = n04 + NINTMX                                ! xx
c
      nremai = n01 + NGOTMX - n05
c     nremai = ncore - n05 + 1
      if(nmoact.ne.0) then
        klen=min(nremai/( (nmoact+nmoext)*(nmodoc+nmoact)**2 ),nmoact)
      else
        klen=0
      end if
      if(klen.lt.1) stop
c
      n06 = n05 + (nmoact+nmoext)*(nmodoc+nmoact)**2*klen  ! gint
      NEED = n06 - LOADFM - 1
      call GETFM(NEED)
c
      call os_shuffle_2e_1ext(klen,d(n01),d(n02),d(n03),d(n04),d(n05))
      call RETFM(NEED)
c
c**** Sort 2-external integrals ****************************************
      call VALFM(LOADFM)
      call GOTFM(NGOTMX)
      n01 = LOADFM + 1
      n02 = n01 + 3*nmoext*(nmodoc+nmoact)**2  ! labint
      n03 = n02 +   nmoext*(nmodoc+nmoact)**2  ! valint
      n04 = n03 + NINTMX                       ! ix
      n05 = n04 + NINTMX                       ! xx
c
      nremai = n01 + NGOTMX - n05
c     nremai = ncore - n05 + 1
      if(nmoext.ne.0) then
        klen=min(nremai/( nmoext*(nmodoc+nmoact)**2 ),nmoext)
      else
        klen=0
      end if
      if(klen.lt.1) stop
c
      n06 = n05 + nmoext*(nmodoc+nmoact)**2*klen  ! gint
      NEED = n06 - LOADFM - 1
      call GETFM(NEED)
c
      call os_shuffle_2e_2ext(klen,d(n01),d(n02),d(n03),d(n04),d(n05))
      call RETFM(NEED)
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_shuffle_2e_1ext(klen,labint,valint,ix,xx,gint)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
c==== GAMESS common ====================================================
c     parameter (NFTI=9)
      LOGICAL PACK2E
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /PCKLAB/ LABSIZ
c
      dimension labint(3,(nmoact+nmoext)*(nmodoc+nmoact)**2)
      dimension valint(  (nmoact+nmoext)*(nmodoc+nmoact)**2)
      dimension ix(NINTMX), xx(NINTMX)
      dimension gint(iniact:lasext,inidoc:lasact,klen,inidoc:lasact)
c
      call seqrew(lunte1)       ! rewind lunte1
      inik=iniact
c
c****           ********************************************************
c**** Loop head ********************************************************
c****           ********************************************************
  100 continue
        lask=min(inik+klen-1,lasact)
        koff=inik-1
c
        call vclr(gint,1,(nmoact+nmoext)*(nmodoc+nmoact)**2*klen)
c
c**** Read integrals ***************************************************
        call seqrew(IJKT)       ! rewind IJKT
        read(IJKT)
c
  102   continue
          call pread(IJKT,xx,ix,nx,NINTMX)
          if(nx.eq.0) go to 104
          mx=abs(nx)
          do m=1,mx
            val=xx(m)
            npack=m
            if (LABSIZ .eq. 2) then
CI32
*I32          label1 = ix( 2*npack - 1 )
*I32          label2 = ix( 2*npack     )
*I32          ipack = ishft( label1, -16 )
*I32          jpack = iand( label1, 65535 )
*I32          kpack = ishft( label2, -16 )
*I32          lpack = iand( label2, 65535 )
CI32
CI64
*I64          label = ix(npack)
*I64          ipack = ishft( label, -48 )
*I64          jpack = iand( ishft( label, -32 ), 65535 )
*I64          kpack = iand( ishft( label, -16 ), 65535 )
*I64          lpack = iand( label, 65535 )
CI64
            else if (LABSIZ .eq. 1) then
CI32
*I32          label = ix(npack)
*I32          ipack = ishft( label, -24 )
*I32          jpack = iand( ishft( label, -16 ), 255 )
*I32          kpack = iand( ishft( label,  -8 ), 255 )
*I32          lpack = iand( label, 255 )
CI32
CI64
*I64          if ( mod(npack,2) .eq. 0 ) then
*I64            label = ix( npack/2 )
*I64            ipack = iand( ishft( label, -24 ), 255 )
*I64            jpack = iand( ishft( label, -16 ), 255 )
*I64            kpack = iand( ishft( label,  -8 ), 255 )
*I64            lpack = iand( label, 255 )
*I64          else
*I64            label = ix( (npack/2)+1 )
*I64            ipack = ishft( label, -56 )
*I64            jpack = iand( ishft( label, -48 ), 255 )
*I64            kpack = iand( ishft( label, -40 ), 255 )
*I64            lpack = iand( ishft( label, -32 ), 255 )
*I64          end if
CI64
            end if
            i=ipack
            j=jpack
            k=kpack
            l=lpack
c
            if(inidoc.le.i .and. i.le.nmo .and.
     *         inidoc.le.j .and. j.le.nmo .and.
     *         inidoc.le.k .and. k.le.nmo .and.
     *         inidoc.le.l .and. l.le.nmo      ) then
              if(iniact.le.i                 .and.
     *                           j.le.lasact .and.
     *           inik  .le.k .and. k.le.lask   .and.
     *                           l.le.lasact) gint(i,j,k-koff,l)=val
              if(iniact.le.i                 .and.
     *                           j.le.lasact .and.
     *           inik  .le.l .and. l.le.lask   .and.
     *                           k.le.lasact) gint(i,j,l-koff,k)=val
              if(iniact.le.j                 .and.
     *                           i.le.lasact .and.
     *           inik  .le.k .and. k.le.lask   .and.
     *                           l.le.lasact) gint(j,i,k-koff,l)=val
              if(iniact.le.j                 .and.
     *                           i.le.lasact .and.
     *           inik  .le.l .and. l.le.lask   .and.
     *                           k.le.lasact) gint(j,i,l-koff,k)=val
              if(iniact.le.k                 .and.
     *                           l.le.lasact .and.
     *           inik  .le.i .and. i.le.lask   .and.
     *                           j.le.lasact) gint(k,l,i-koff,j)=val
              if(iniact.le.k                 .and.
     *                           l.le.lasact .and.
     *           inik  .le.j .and. j.le.lask   .and.
     *                           i.le.lasact) gint(k,l,j-koff,i)=val
              if(iniact.le.l                 .and.
     *                           k.le.lasact .and.
     *           inik  .le.i .and. i.le.lask   .and.
     *                           j.le.lasact) gint(l,k,i-koff,j)=val
              if(iniact.le.l                 .and.
     *                           k.le.lasact .and.
     *           inik  .le.j .and. j.le.lask   .and.
     *                           i.le.lasact) gint(l,k,j-koff,i)=val
            end if
c
          end do
        if(nx.gt.0) go to 102
  104   continue
c
c**** Write integrals **************************************************
        do k=inik,lask
          n=0
          do l=inidoc,lasact
          do j=inidoc,lasact
          do i=iniact,lasext
            if(abs(gint(i,j,k-koff,l)).gt.threri) then
              n=n+1
              labint(1,n)=i
              labint(2,n)=j
              labint(3,n)=l
              valint(n)=gint(i,j,k-koff,l)
            end if
          end do
          end do
          end do
          write(lunte1) n
          call os_labval_write(lunte1,3*n,n,labint,valint)
c         write(lunte1) labint(1:3,1:n),valint(1:n)
        end do
c****           ********************************************************
c**** Loop tail ********************************************************
c****           ********************************************************
        inik=inik+klen
      if(inik.le.lasact) go to 100
c
c**** End **************************************************************
      end
      subroutine os_shuffle_2e_2ext(klen,labint,valint,ix,xx,gint)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
c==== GAMESS common ====================================================
c     parameter (NFTI=9)
      LOGICAL PACK2E
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /PCKLAB/ LABSIZ
c
      dimension labint(3,        nmoext *(nmodoc+nmoact)**2)
      dimension valint(          nmoext *(nmodoc+nmoact)**2)
      dimension gint(iniext:lasext,inidoc:lasact,klen,inidoc:lasact)
      dimension ix(NINTMX), xx(NINTMX)
c
      call seqrew(lunte2)       ! rewind lunte2
      inik=iniext
c****           ********************************************************
c**** Loop haed ********************************************************
c****           ********************************************************
  100 continue
        lask=min(inik+klen-1,lasext)
        koff=inik-1
c
        call vclr(gint,1,nmoext*(nmodoc+nmoact)**2*klen)
c
c**** Read integrals ***************************************************
        call seqrew(IJKT)       ! rewind IJKT
        read(IJKT)
c
  102   continue
          call pread(IJKT,xx,ix,nx,NINTMX)
          if(nx.eq.0) go to 104
          mx=abs(nx)
          do m=1,mx
            val=xx(m)
            npack=m
            if (LABSIZ .eq. 2) then
CI32
*I32          label1 = ix( 2*npack - 1 )
*I32          label2 = ix( 2*npack     )
*I32          ipack = ishft( label1, -16 )
*I32          jpack = iand( label1, 65535 )
*I32          kpack = ishft( label2, -16 )
*I32          lpack = iand( label2, 65535 )
CI32
CI64
*I64          label = ix(npack)
*I64          ipack = ishft( label, -48 )
*I64          jpack = iand( ishft( label, -32 ), 65535 )
*I64          kpack = iand( ishft( label, -16 ), 65535 )
*I64          lpack = iand( label, 65535 )
CI64
            else if (LABSIZ .eq. 1) then
CI32
*I32          label = ix(npack)
*I32          ipack = ishft( label, -24 )
*I32          jpack = iand( ishft( label, -16 ), 255 )
*I32          kpack = iand( ishft( label,  -8 ), 255 )
*I32          lpack = iand( label, 255 )
CI32
CI64
*I64          if ( mod(npack,2) .eq. 0 ) then
*I64            label = ix( npack/2 )
*I64            ipack = iand( ishft( label, -24 ), 255 )
*I64            jpack = iand( ishft( label, -16 ), 255 )
*I64            kpack = iand( ishft( label,  -8 ), 255 )
*I64            lpack = iand( label, 255 )
*I64          else
*I64            label = ix( (npack/2)+1 )
*I64            ipack = ishft( label, -56 )
*I64            jpack = iand( ishft( label, -48 ), 255 )
*I64            kpack = iand( ishft( label, -40 ), 255 )
*I64            lpack = iand( ishft( label, -32 ), 255 )
*I64          end if
CI64
            end if
            i=ipack
            j=jpack
            k=kpack
            l=lpack
c
            if(inidoc.le.i .and. i.le.nmo .and.
     *         inidoc.le.j .and. j.le.nmo .and.
     *         inidoc.le.k .and. k.le.nmo .and.
     *         inidoc.le.l .and. l.le.nmo      ) then
              if(iniext.le.i                 .and.
     *                           j.le.lasact .and.
     *           inik  .le.k .and. k.le.lask   .and.
     *                           l.le.lasact) gint(i,j,k-koff,l)=val
              if(iniext.le.i                 .and.
     *                           j.le.lasact .and.
     *           inik  .le.l .and. l.le.lask   .and.
     *                           k.le.lasact) gint(i,j,l-koff,k)=val
              if(iniext.le.j                 .and.
     *                           i.le.lasact .and.
     *           inik  .le.k .and. k.le.lask   .and.
     *                           l.le.lasact) gint(j,i,k-koff,l)=val
              if(iniext.le.j                 .and.
     *                           i.le.lasact .and.
     *           inik  .le.l .and. l.le.lask   .and.
     *                           k.le.lasact) gint(j,i,l-koff,k)=val
              if(iniext.le.k                 .and.
     *                           l.le.lasact .and.
     *           inik  .le.i .and. i.le.lask   .and.
     *                           j.le.lasact) gint(k,l,i-koff,j)=val
              if(iniext.le.k                 .and.
     *                           l.le.lasact .and.
     *           inik  .le.j .and. j.le.lask   .and.
     *                           i.le.lasact) gint(k,l,j-koff,i)=val
              if(iniext.le.l                 .and.
     *                           k.le.lasact .and.
     *           inik  .le.i .and. i.le.lask   .and.
     *                           j.le.lasact) gint(l,k,i-koff,j)=val
              if(iniext.le.l                 .and.
     *                           k.le.lasact .and.
     *           inik  .le.j .and. j.le.lask   .and.
     *                           i.le.lasact) gint(l,k,j-koff,i)=val
            end if
c
          end do
        if(nx.gt.0) go to 102
  104   continue
c
c**** Write integrals **************************************************
        do k=inik,lask
          n=0
          do l=inidoc,lasact
          do j=inidoc,lasact
          do i=iniext,lasext
            if(abs(gint(i,j,k-koff,l)).gt.threri) then
              n=n+1
              labint(1,n)=i
              labint(2,n)=j
              labint(3,n)=l
              valint(n)=gint(i,j,k-koff,l)
            end if
          end do
          end do
          end do
          write(lunte2) n
          call os_labval_write(lunte2,3*n,n,labint,valint)
c         write(lunte2) labint(1:3,1:n),valint(1:n)
        end do
c****           ********************************************************
c**** Loop tail ********************************************************
c****           ********************************************************
        inik=inik+klen
      if(inik.le.lasext) go to 100
c
c**** End **************************************************************
      end
      subroutine os_shuffle_2e_int
     * (cfktri,cfock ,veff1 ,veff2 ,gjint ,gkint ,gaint ,geoin1,geoin2,
     *  ix    ,xx    )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,TWO=2.0d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
c==== GAMESS common ====================================================
c     parameter (NFTI=9)
      LOGICAL PACK2E
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /PCKLAB/ LABSIZ
c
      dimension cfktri(nmo*(nmo+1)/2), cfock(nmo,nmo)
c     dimension cfktri(nbf*(nbf+1)/2), cfock(nmo,nmo)
      dimension veff1(nmo,nmo,0:lasdoc), veff2(nmo,nmo,0:lasdoc)
      dimension gjint(lasdoc,lasdoc), gkint(lasdoc,lasdoc)
      dimension gaint(iniact:lasact,iniact:lasact,
     *                iniact:lasact,iniact:lasact)
      dimension geoin1(nmo,lasact,lasact), geoin2(nmo,lasact,lasact)
      dimension ix(NINTMX), xx(NINTMX)
c
      call vclr(veff1 ,1,nmo*nmo*(lasdoc+1))
      call vclr(veff2 ,1,nmo*nmo*(lasdoc+1))
      call vclr(gjint ,1,lasdoc*lasdoc     )
      call vclr(gkint ,1,lasdoc*lasdoc     )
      call vclr(gaint ,1,nmoact**4         )
      call vclr(geoin1,1,nmo*lasact*lasact )
      call vclr(geoin2,1,nmo*lasact*lasact )
c
c**** Read one-electron integrals **************************************
c     rewind 201
c     read(201,*) encsum
c
      call seqrew(IJKT)         ! rewind IJKT
      read(IJKT) cfktri
c
      call vclr(cfock,1,nmo*nmo)
      ij=0
      do i=1,nmo
      do j=1,i
        ij=ij+1
        cfock(i,j)=cfktri(ij)
        cfock(j,i)=cfktri(ij)
      end do
      end do
c
c**** Read 2-electron integrals ****************************************
  100 continue
        call pread(IJKT,xx,ix,nx,NINTMX)
        if(nx.eq.0) go to 102
        mx=abs(nx)
        do m=1,mx
          val=xx(m)
          npack=m
          if (LABSIZ .eq. 2) then
CI32
*I32          label1 = ix( 2*npack - 1 )
*I32          label2 = ix( 2*npack     )
*I32          ipack = ishft( label1, -16 )
*I32          jpack = iand( label1, 65535 )
*I32          kpack = ishft( label2, -16 )
*I32          lpack = iand( label2, 65535 )
CI32
CI64
*I64          label = ix(npack)
*I64          ipack = ishft( label, -48 )
*I64          jpack = iand( ishft( label, -32 ), 65535 )
*I64          kpack = iand( ishft( label, -16 ), 65535 )
*I64          lpack = iand( label, 65535 )
CI64
          else if (LABSIZ .eq. 1) then
CI32
*I32          label = ix(npack)
*I32          ipack = ishft( label, -24 )
*I32          jpack = iand( ishft( label, -16 ), 255 )
*I32          kpack = iand( ishft( label,  -8 ), 255 )
*I32          lpack = iand( label, 255 )
CI32
CI64
*I64          if ( mod(npack,2) .eq. 0 ) then
*I64            label = ix( npack/2 )
*I64            ipack = iand( ishft( label, -24 ), 255 )
*I64            jpack = iand( ishft( label, -16 ), 255 )
*I64            kpack = iand( ishft( label,  -8 ), 255 )
*I64            lpack = iand( label, 255 )
*I64          else
*I64            label = ix( (npack/2)+1 )
*I64            ipack = ishft( label, -56 )
*I64            jpack = iand( ishft( label, -48 ), 255 )
*I64            kpack = iand( ishft( label, -40 ), 255 )
*I64            lpack = iand( ishft( label, -32 ), 255 )
*I64          end if
CI64
          end if
          i=ipack
          j=jpack
          k=kpack
          l=lpack
c
          if(k.eq.l .and. k.le.lasdoc) then ! veff
            veff1(i,j,k)=val
            veff1(j,i,k)=val
          end if
          if(i.eq.j .and. i.le.lasdoc) then ! veff
            veff1(k,l,i)=val
            veff1(l,k,i)=val
          end if
          if(j.eq.k .and. j.le.lasdoc) then ! veff
            veff2(i,l,j)=val
            veff2(l,i,j)=val
          end if
          if(l.eq.i .and. l.le.lasdoc) then ! veff
            veff2(k,j,l)=val
            veff2(j,k,l)=val
          end if
          if(j.eq.l .and. j.le.lasdoc) then
            veff2(i,k,j)=val
            veff2(k,i,j)=val
          end if
          if(i.eq.k .and. i.le.lasdoc) then
            veff2(j,l,i)=val
            veff2(l,j,i)=val
          end if
c
          if(i.eq.j      .and. k.eq.l      .and.
     *       i.le.lasdoc .and. k.le.lasdoc      ) then ! gjkint
            gjint(i,k)=val
            gjint(k,i)=val
          end if
          if(i.eq.l      .and. j.eq.k      .and.
     *       i.le.lasdoc .and. j.le.lasdoc      ) then ! gjkint
            gkint(i,j)=val
            gkint(j,i)=val
          end if
          if(i.eq.k      .and. j.eq.l      .and.
     *       i.le.lasdoc .and. j.le.lasdoc      ) then
            gkint(i,j)=val
            gkint(j,i)=val
          end if
c
          if(iniact.le.i .and. i.le.lasact .and.
     *       iniact.le.j .and. j.le.lasact .and.
     *       iniact.le.k .and. k.le.lasact .and.
     *       iniact.le.l .and. l.le.lasact      ) then ! gaint
            gaint(i,j,k,l)=val
            gaint(j,i,l,k)=val
            gaint(k,l,i,j)=val
            gaint(l,k,j,i)=val
c
            gaint(i,j,l,k)=val
            gaint(j,i,k,l)=val
            gaint(k,l,j,i)=val
            gaint(l,k,i,j)=val
          end if
c
          if(i.eq.j .and. k.le.lasact .and. l.le.lasact) then ! geoint
            geoin1(i,k,l)=val
            geoin1(i,l,k)=val
          end if
          if(k.eq.l .and. i.le.lasact .and. j.le.lasact) then ! geoint
            geoin1(k,i,j)=val
            geoin1(k,j,i)=val
          end if
          if(i.eq.l .and. k.le.lasact .and. j.le.lasact) then ! geoint
            geoin2(i,k,j)=val
            geoin2(i,j,k)=val
          end if
          if(j.eq.k .and. i.le.lasact .and. l.le.lasact) then ! geoint
            geoin2(j,i,l)=val
            geoin2(j,l,i)=val
          end if
          if(i.eq.k .and. j.le.lasact .and. l.le.lasact) then
            geoin2(i,j,l)=val
            geoin2(i,l,j)=val
          end if
          if(j.eq.l .and. i.le.lasact .and. k.le.lasact) then
            geoin2(j,i,k)=val
            geoin2(j,k,i)=val
          end if
c
        end do
      if(nx.gt.0) go to 100
  102 continue
c
      call seqrew(lunhcr)       ! rewind lunhcr
      write(lunhcr) cfock
c
c**** Effective potential **********************************************
      do j=inidoc,lasext
      do i=inidoc,lasext
        veff1(i,j,0)=ZERO
        do k=inifzc,lasdoc
          veff1(i,j,0)=veff1(i,j,0)+TWO*veff1(i,j,k)-veff2(i,j,k)
        end do
      end do
      end do
c     do j=inifzc,lasext
c     do i=inifzc,lasfzc
c       veff1(i,j,0)=ZERO
c     end do
c     end do
c     do j=inifzc,lasfzc
c     do i=inidoc,lasext
c       veff1(i,j,0)=ZERO
c     end do
c     end do
c
c     Write veff
c
      call os_val_write(lunhcr,nmo*nmo,veff1)
c
c**** Integrals for J-K ************************************************
      do j=1,lasdoc
      do i=1,lasdoc
        gjint(i,j)=TWO*gjint(i,j)-gkint(i,j)
      end do
      end do
c
c     Write gjkint
c
      call seqrew(lungjk)       ! rewind lungjk
      write(lungjk) gjint
c
c**** Integrals for active space ***************************************
c
c     Write lungai
c
      call seqrew(lungai)       ! rewind lungai
      write(lungai) gaint
c
c**** Integrals for orbital energies ***********************************
c     do k=1,lasact
c     do j=1,lasact
c     do i=1,nmo
c       geoin1(i,j,k)=TWO*geoin1(i,j,k)-geoin2(i,j,k)
c     end do
c     end do
c     end do
c
c     Write geoint
c
      call seqrew(lungeo)       ! rewind lungeo
      write(lungeo) geoin1
      write(lungeo) geoin2
c
c**** End **************************************************************
      end
      subroutine os_shuffle_2e_int_par
     *  (cfktri,cfock ,veff1 ,veff2 ,gjint ,gkint ,gaint ,geoin1,geoin2,
     *   xx    )
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jun 17, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (ZERO=0.0d+00,TWO=2.0d+00)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
c==== GAMESS common ====================================================
c     parameter (NFTI=9)
c$$$      LOGICAL PACK2E
c$$$      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
c$$$      COMMON /PCKLAB/ LABSIZ
      INTEGER         D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB
      LOGICAL         NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
      COMMON /TRFDMS/ D_OOOO,D_VOOO,D_VVOO,D_VOVO,D_VVVO,D_VVVV,
     *                D_OOOOAB,D_OOOOBB,D_VOOOAB,D_VOOOBA,D_VOOOBB,
     *                D_VVOOAB,D_VVOOBA,D_VVOOBB,D_VOVOAB,D_VOVOBB,
     *                D_U,D_UB,D_E,D_EB,
     *                NDOOOO,NDVOOO,NDVVOO,NDVOVO,NDVVVO,NDVVVV,NDCORE,
     *                NDVVOOBA,NDVVOOAB,NDVVOOBB,NDVOVOAB,NDVOVOBB,
     *                NDVOOOBA,NDVOOOAB,NDVOOOBB,NDOOOOAB,NDOOOOBB
c
      dimension cfktri(nmo*(nmo+1)/2), cfock(nmo,nmo)
c     dimension cfktri(nbf*(nbf+1)/2), cfock(nmo,nmo)
      dimension veff1(nmo,nmo,0:lasdoc), veff2(nmo,nmo,0:lasdoc)
      dimension gjint(lasdoc,lasdoc), gkint(lasdoc,lasdoc)
      dimension gaint(iniact:lasact,iniact:lasact,
     *                iniact:lasact,iniact:lasact)
      dimension geoin1(nmo,lasact,lasact), geoin2(nmo,lasact,lasact)
c     dimension ix(NINTMX), xx(NINTMX)
c     dimension xx(max((nmofzc+nmodoc+nmoact)**2,nmoext*nmoext))
      dimension xx(*)
      logical svdskw
c
      call vclr(veff1 ,1,nmo*nmo*(lasdoc+1))
      call vclr(veff2 ,1,nmo*nmo*(lasdoc+1))
      call vclr(gjint ,1,lasdoc*lasdoc     )
      call vclr(gkint ,1,lasdoc*lasdoc     )
      call vclr(gaint ,1,nmoact**4         )
      call vclr(geoin1,1,nmo*lasact*lasact )
      call vclr(geoin2,1,nmo*lasact*lasact )
c
c**** Read one-electron integrals **************************************
c     rewind 201
c     read(201,*) encsum
c
      svdskw=DSKWRK
      DSKWRK=ordskw
      call seqrew(IJKT)         ! rewind IJKT
c     read(NFTI) cfktri
      lencfk = (nmo*nmo+nmo)/2
      call sqread(IJKT,cfktri,lencfk)
      DSKWRK=svdskw
c
      call vclr(cfock,1,nmo*nmo)
      ij=0
      do i=1,nmo
      do j=1,i
        ij=ij+1
        cfock(i,j)=cfktri(ij)
        cfock(j,i)=cfktri(ij)
      end do
      end do
c
c**** Read 2-electron integrals ****************************************
c
c     OOOO
c
c     ncore =nmofzc
      nmoda =nmodoc+nmoact         ! m1
      nmocda=nmofzc+nmodoc+nmoact  ! nact + ncore
      ncdatr=(nmocda*nmocda+nmocda)/2
c
      call ddi_distrib(d_oooo,me,ilo,ihi,jlo,jhi)
c
      do ii=1,nmoda
        ic=ii+nmofzc
      do jj=1,ii
        jc =jj+nmofzc
        ij =(ii*ii-ii)/2+jj
        ijn=(ic*ic-ic)/2+jc
        if (ijn.ge.jlo .and. ijn.le.jhi) then
          call ddi_get(d_oooo,1,ncdatr,ijn,ijn,xx)
          do kk=1,nmoda
            kn=kk+nmofzc
          do ll=1,kk
            ln=ll+nmofzc
            kl=(kk*kk-kk)/2+ll
            if(ij.ge.kl) then
              kln=(kn*kn-kn)/2+ln
c             ijkl = (ij*ij-ij)/2 + kl
c             x2(ijkl) = xx(kln)
c<<<<
              i=kk
              j=ll
              k=ii
              l=jj
              val=xx(kln)
c
              if(k.eq.l .and. k.le.lasdoc) then ! veff
                veff1(i,j,k)=val
                veff1(j,i,k)=val
              end if
              if(i.eq.j .and. i.le.lasdoc) then ! veff
                veff1(k,l,i)=val
                veff1(l,k,i)=val
              end if
              if(j.eq.k .and. j.le.lasdoc) then ! veff
                veff2(i,l,j)=val
                veff2(l,i,j)=val
              end if
              if(l.eq.i .and. l.le.lasdoc) then ! veff
                veff2(k,j,l)=val
                veff2(j,k,l)=val
              end if
              if(j.eq.l .and. j.le.lasdoc) then
                veff2(i,k,j)=val
                veff2(k,i,j)=val
              end if
              if(i.eq.k .and. i.le.lasdoc) then
                veff2(j,l,i)=val
                veff2(l,j,i)=val
              end if
c
              if(i.eq.j    .and. k.eq.l .and.
     *           i.le.lasdoc .and. k.le.lasdoc   ) then ! gjkint
                gjint(i,k)=val
                gjint(k,i)=val
              end if
              if(i.eq.l    .and. j.eq.k .and.
     *           i.le.lasdoc .and. j.le.lasdoc   ) then ! gjkint
                gkint(i,j)=val
                gkint(j,i)=val
              end if
              if(i.eq.k    .and. j.eq.l .and.
     *           i.le.lasdoc .and. j.le.lasdoc   ) then
                gkint(i,j)=val
                gkint(j,i)=val
              end if
c
              if(iniact.le.i .and. i.le.lasact .and.
     *           iniact.le.j .and. j.le.lasact .and.
     *           iniact.le.k .and. k.le.lasact .and.
     *           iniact.le.l .and. l.le.lasact      ) then ! gaint
                gaint(i,j,k,l)=val
                gaint(j,i,l,k)=val
                gaint(k,l,i,j)=val
                gaint(l,k,j,i)=val
c
                gaint(i,j,l,k)=val
                gaint(j,i,k,l)=val
                gaint(k,l,j,i)=val
                gaint(l,k,i,j)=val
              end if
c
c   geoint
              if(i.eq.j .and. k.le.lasact .and. l.le.lasact) then
                geoin1(i,k,l)=val
                geoin1(i,l,k)=val
              end if
c   geoint
              if(k.eq.l .and. i.le.lasact .and. j.le.lasact) then
                geoin1(k,i,j)=val
                geoin1(k,j,i)=val
              end if
c   geoint
              if(i.eq.l .and. k.le.lasact .and. j.le.lasact) then
                geoin2(i,k,j)=val
                geoin2(i,j,k)=val
              end if
c   geoint
              if(j.eq.k .and. i.le.lasact .and. l.le.lasact) then
                geoin2(j,i,l)=val
                geoin2(j,l,i)=val
              end if
              if(i.eq.k .and. j.le.lasact .and. l.le.lasact) then
                geoin2(i,j,l)=val
                geoin2(i,l,j)=val
              end if
              if(j.eq.l .and. i.le.lasact .and. k.le.lasact) then
                geoin2(j,i,k)=val
                geoin2(j,k,i)=val
              end if
c>>>>
            end if
          end do
          end do
        end if                  ! local stripe
      end do                    ! j
      end do                    ! i
c
c     VOOO
c
c     next  =nmoext
c     m2    =(nmoda*(nmoda+1))/2
c     nooo  =m2*nmoda
c     nvooo =nooo*nmoext
      nmocda=nmoda+nmofzc
c
      call ddi_distrib(d_vooo,me,ilo,ihi,jlo,jhi)
c
      do ii=1,nmoda
        iind=(ii*(ii-1))/2
        ni  =ii+nmofzc
        nind=(ni*(ni-1))/2
      do jj=1,ii
        ij   =iind+jj
        nj   =jj+nmofzc
        ijcol=(nind+nj-1)*nmocda
      do kk=1,nmoda
        nk    =kk+nmofzc
        ijkcol=ijcol+nk
        if (ijkcol.ge.jlo .and. ijkcol.le.jhi) then
          call ddi_get(d_vooo,1,nmoext,ijkcol,ijkcol,xx)
c         kij=(k-1)*m2+ij
          do ie=1,nmoext
c           x2(ie,kij) = xx(ie)
c<<<<
            i=KK
            j=IE+lasact
            k=II
            l=JJ
            val=xx(ie)
c
            if(k.eq.l .and. k.le.lasdoc) then ! veff
              veff1(i,j,k)=val
              veff1(j,i,k)=val
            end if
            if(l.eq.i .and. l.le.lasdoc) then ! veff
              veff2(k,j,l)=val
              veff2(j,k,l)=val
            end if
            if(i.eq.k .and. i.le.lasdoc) then
              veff2(j,l,i)=val
              veff2(l,j,i)=val
            end if
c>>>>
          end do
        end if
      end do                     ! k
      end do                     ! j
      end do                     ! i
c
c     VOVO
c
      nvtr =nmoext*nmoext
c     nvo  =nmoda*nmoext
c     nvovo=(nvo*(nvo+1))/2
c
      call ddi_distrib(d_vovo,me,ilo,ihi,jlo,jhi)
c
      do ii=1,nmoda
        ni  =ii+nmofzc
        nind=(ni*(ni-1))/2
      do jj=1,ii
        nj=jj+nmofzc
        ijcol=nind+nj
        if(ijcol.ge.jlo .and. ijcol.le.jhi) then
          call ddi_get(d_vovo,1,nvtr,ijcol,ijcol,xx)
          do jv=1,nmoext
            jvind2=(jv-1)*nmoext
          do iv=1,jv
            nivjv=jvind2+iv
c           x2(int1) = xx(nivjv)  ! (iv,ii|jv,jj) (ii>=jj,iv<=jv)
c<<<<
            i=IV+lasact
            j=II
            k=JV+lasact
            l=JJ
            val=xx(nivjv)
c
            if(j.eq.l .and. j.le.lasdoc) then
              veff2(i,k,j)=val
              veff2(k,i,j)=val
            end if
c
            if(i.eq.k .and. j.le.lasact .and. l.le.lasact) then
              geoin2(i,j,l)=val
              geoin2(i,l,j)=val
            end if
c>>>>
          end do
          end do
        end if
      end do                     ! j
      end do                     ! i>=j
c
c     VVOO
c
      nvtr = (nmoext*nmoext+nmoext)/2
c
      call ddi_distrib(d_vvoo,me,ilo,ihi,jlo,jhi)
c
      do ii=1,nmoda
        in=ii+nmofzc
      do jj=1,ii
        jn =jj+nmofzc
        ij =(ii*ii-ii)/2+jj
        ijn=(in*in-in)/2+jn
        if(ijn.ge.jlo .and. ijn.le.jhi) then
          call ddi_get(d_vvoo,1,nvtr,ijn,ijn,xx)
          do kk=1,nmoext
          do ll=1,kk
            kl=(kk*kk-kk)/2+ll
c<<<<
            i=II
            j=JJ
            k=kk+lasact
            l=ll+lasact
            val=xx(kl)
c
            if(i.eq.j .and. i.le.lasdoc) then ! veff
              veff1(k,l,i)=val
              veff1(l,k,i)=val
            end if
c
            if(k.eq.l .and. i.le.lasact .and. j.le.lasact) then ! geoint
              geoin1(k,i,j)=val
              geoin1(k,j,i)=val
            end if
c>>>>
          end do
          end do
        end if
      end do
      end do
c
      call DDI_GSUMF(5000,veff1 ,nmo*nmo*(lasdoc+1))
      call DDI_GSUMF(5000,veff2 ,nmo*nmo*(lasdoc+1))
      call DDI_GSUMF(5000,gjint ,lasdoc*lasdoc     )
      call DDI_GSUMF(5000,gkint ,lasdoc*lasdoc     )
      call DDI_GSUMF(5000,gaint ,nmoact**4         )
      call DDI_GSUMF(5000,geoin1,nmo*lasact*lasact )
      call DDI_GSUMF(5000,geoin2,nmo*lasact*lasact )
c
c**** write
c     call seqrew(lunhcr)       ! rewind lunhcr
      rewind lunhcr
      write(lunhcr) cfock
c
c**** Effective potential **********************************************
      do j=inidoc,lasext
      do i=inidoc,lasext
        veff1(i,j,0)=ZERO
        do k=inifzc,lasdoc
          veff1(i,j,0)=veff1(i,j,0)+TWO*veff1(i,j,k)-veff2(i,j,k)
        end do
      end do
      end do
c     do j=inifzc,lasext
c     do i=inifzc,lasfzc
c       veff1(i,j,0)=ZERO
c     end do
c     end do
c     do j=inifzc,lasfzc
c     do i=inidoc,lasext
c       veff1(i,j,0)=ZERO
c     end do
c     end do
c
c     Write veff
c
      call os_val_write(lunhcr,nmo*nmo,veff1)
c
c**** Integrals for J-K ************************************************
      do j=1,lasdoc
      do i=1,lasdoc
        gjint(i,j)=TWO*gjint(i,j)-gkint(i,j)
      end do
      end do
c
c     Write gjkint
c
      call seqrew(lungjk)       ! rewind lungjk
      write(lungjk) gjint
c
c**** Integrals for active space ***************************************
c
c     Write lungai
c
      call seqrew(lungai)       ! rewind lungai
      write(lungai) gaint
c
c**** Integrals for orbital energies ***********************************
c     do k=1,lasact
c     do j=1,lasact
c     do i=1,nmo
c       geoin1(i,j,k)=TWO*geoin1(i,j,k)-geoin2(i,j,k)
c     end do
c     end do
c     end do
c
c     Write geoint
c
      call seqrew(lungeo)       ! rewind lungeo
      write(lungeo) geoin1
      write(lungeo) geoin2
c
c**** End **************************************************************
      end
      subroutine os_sort_energies(diaval,diavec)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jun 24, 2006 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      parameter (MAXSTA=100, NSPCMX=20)
      LOGICAL KSTATE,KNOSPN,KNOSYM,KROT,KMPART,KSFORB
      CHARACTER*8 REFTYP,CEXCEN
      COMMON /OSGMCPT/
     *  AVECOE(MAXSTA),KSTATE(MAXSTA),
     *  MORB  (NSPCMX),MINE  (NSPCMX),MAXE  (NSPCMX),
     *  MXHOLE(NSPCMX),MXPART(NSPCMX),KSFORB(NSPCMX),
     *  REFTYP,CEXCEN,THRENE,THRCON,THRGEN,THRWGT,THRDE ,THRHDE,HDEMAX,
     *  GSENE(2)     ,EDSHFT,NDET  ,NCI   ,NSTATE,NSTCI ,NSOLUT,NPDET ,
     *  NEXCIT,NCIM2 ,NCIM1 ,NCI00 ,NCIP1 ,NCIP2 ,IDFORM,NSPACE,MAXBAS,
     *  MXITER,MDI   ,ISPINA,IWGT  ,KNOSPN,KNOSYM,KROT  ,KMPART,NILOOP,
     *  NCIBUF
c
      dimension diaval(nstate),diavec(nstate,nstate)
c
c     The following code is slow, but NSTATE is usually small.
c
      do i=1,nstate-1
        do j=i+1,nstate
          if(abs(diavec(i,j)).gt.abs(diavec(i,i))) then
            s        =diaval(i)
            diaval(i)=diaval(j)
            diaval(j)=s
            do k=1,nstate
              s          =diavec(k,i)
              diavec(k,i)=diavec(k,j)
              diavec(k,j)=s
            end do
          end if
        end do
      end do
c     dimension lnw2od(nstate)        ! small local array
c     dimension edum (nstate)         ! small local array
c     dimension evdum(nstate,nstate)  ! small local array
c
c     do i=1,nstate
c       lnw2od(i)=i
c     end do
c     do i=1,nstate
c       do j=i+1,nstate
c         if(abs(diavec(i,lnw2od(j))).gt.abs(diavec(i,lnw2od(i)))) then
c           k        =lnw2od(i)
c           lnw2od(i)=lnw2od(j)
c           lnw2od(j)=k
c         end if
c       end do
c     end do
c
c     do i=1,nstate
c       edum (  i)=diaval(  lnw2od(i)  )
c       do j=1,nstate
c         evdum(j,i)=diavec(j,lnw2od(i))
c       end do
c     end do
c
c     do i=1,nstate
c       diaval(i)=edum(i)
c       do j=1,nstate
c         diavec(j,i)=evdum(j,i)
c       end do
c     end do
      end
      subroutine os_sort_mcqdpt(mos)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 08, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
c
      dimension mos(nmo)
c
c==== GAMESS commons ===================================================
      PARAMETER (MXAO=8192)
      COMMON /SOSYM/  EULANG(4,48),GAM(48,48),IRMON(MXAO)
c
      if(MASWRK .and. lpout.eq.1) then
        write(lunout,
     *    '(/1x,10(1h*)," Routine os_sort_mcqdpt ",45(1h*))')
        call ut_init_time
      END IF
c
c**** Write mos ********************************************************
      n=0
      do i=nmofzc+1,nmofzc+nmo
        n=n+1
        mos(n)=IRMON(i)-1
      end do
c
      call seqrew(lunmos)       ! rewind lunmos
      write(lunmos) mos
c
c**** End **************************************************************
      if(MASWRK .and. lpout.eq.1) call ut_report_time
      end
      subroutine os_trans_dip
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jan 25, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
c
c==== GAMESS commons ===================================================
      PARAMETER (MXATM=2000)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /FMCOM / d(1)
c
      call VALFM(LOADFM)
      n01 = LOADFM + 1
      n02 = n01 + num*num                ! cmo
      n03 = n02 + num*(num+1)/2*3        ! daotri
      n04 = n03 + num*num*3              ! daoint
      n05 = n04 + nmoact*nmoact*3        ! dmoint
      NEED = n05 - LOADFM - 1
      call GETFM(NEED)
      call os_trans_dipole(d(n01),d(n02),d(n03),d(n04))
      call RETFM(NEED)
      end
      subroutine os_trans_dipole(cmo,daotri,daoint,dmoint)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Jan 25, 2007 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
      LOGICAL KSZDOE,KFORB,KPRINT,ORDSKW
      COMMON /OSGLOBAL/      ENCSUM,THRERI,NELACT,MULT,NSPIN,ISTSYM(3),
     *  NMOFZC,NMODOC,NMOACT,NMOEXT,NMOFZV,NMOCOR,NMO   ,NSOACT,NBF   ,
     *  INIFZC,LASFZC,INIDOC,LASDOC,INIACT,LASACT,INIEXT,LASEXT,INIPEX,
     *  LASPEX,NMOWGT,INIWGT,LASWGT,KSZDOE,KFORB ,KPRINT,ORDSKW
      LOGICAL GOPARR,DSKWRK,MASWRK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /IOFILE/ IR_GMS,IW_GMS,IP_GMS,IS_GMS,IJKT,
     *                IDAF,NAV,IODA(950)
c
c==== GAMESS commons ===================================================
      PARAMETER (MXATM=2000)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,MA,MB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
c     COMMON /IOFILE/ IR,IW,IP,IS,IJKT,IDAF,NAV,IODA(950)
      dimension cmo(NUM,NUM)
      dimension daotri(NUM*(NUM+1)/2,3)
      dimension daoint(NUM,NUM,3),dmoint(nmoact,nmoact,3)
      logical svdskw
c
      svdskw=DSKWRK
      DSKWRK=ordskw
      ndsize=NUM*NUM
      call DAREAD(IDAF,IODA,cmo        ,ndsize,15,0)
      ndsize=NUM*(NUM+1)/2
      call DAREAD(IDAF,IODA,daotri(1,1),ndsize,95,0)
      call DAREAD(IDAF,IODA,daotri(1,2),ndsize,96,0)
      call DAREAD(IDAF,IODA,daotri(1,3),ndsize,97,0)
      DSKWRK=svdskw
c
      call vclr(dmoint,1,nmoact*nmoact*3)
      do ixyz=1,3
        n=0
        do i=1,NUM
        do j=1,i
          n=n+1
          daoint(i,j,ixyz)=daotri(n,ixyz)
          daoint(j,i,ixyz)=daotri(n,ixyz)
        end do
        end do
      end do
c
c     The following code is not fast.  Change it if it is time-
c     consuming.
c
      nmofd=nmofzc+nmodoc
      do ixyz=1,3
        do l=1,NUM
        do k=1,NUM
          do j=1,nmoact
          do i=1,nmoact
            dmoint(i,j,ixyz)=dmoint(i,j,ixyz)
     *        +cmo(k,i+nmofd)*daoint(k,l,ixyz)*cmo(l,j+nmofd)
          end do
          end do
        end do
        end do
      end do
      call seqrew(lundin)       ! rewind lundin
      write(lundin) dmoint
      end
      subroutine os_val_write(lun,lenval,value)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Sep 03, 2005 by HN                 ===
c=======================================================================
      implicit double precision (a-h,o-z)
      dimension value(lenval)
      write(lun) value
      end
c
c     Utilities
c
      subroutine ut_rmat_print_1(lunout,a,inic,lasc,lcol)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 08, 2007 by HN                 ===
c=======================================================================
c
c     Print double precision 1-D array
c
      implicit double precision (a-h,o-z)
      dimension a(*)
      inicol=inic
  100 continue
        lascol=min(inicol+4,lasc)
        write(lunout,'(1x,5i13)') (j,j=inicol,lascol)
        write(lunout,'(1x,1p,5d13.6)') (a(j-lcol+1),j=inicol,lascol)
        inicol=lascol+1
      if(inicol.le.lasc) go to 100
      end
      subroutine ut_rmat_print_2
     *  (lunout,a,kform,nphysi,inir,lasr,inic,lasc,lrow,lcol)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 08, 2007 by HN                 ===
c=======================================================================
c
c     Print double precision 2-D array
c
      implicit double precision (a-h,o-z)
      dimension a(nphysi,*)
      character*1 kform
c**** Symmetric or lower-trigonal matrix *******************************
      if(kform.eq.'s' .or. kform.eq.'S') then
        inicol=inic
  100   continue
          lascol=min(inicol+4,lasc)
          write(lunout,'(7x,5i13)') (j,j=inicol,lascol)
          do i=inicol,lasr
            k=min(lascol,i)
            write(lunout,'(i6,1x,1p,5d13.6)')
     *        i,(a(i-lrow+1,j-lcol+1),j=inicol,k)
          end do
          inicol=lascol+1
        if(inicol.le.lasc) go to 100
c**** General matrix ***************************************************
      else
        inicol=inic
  102   continue
          lascol=min(inicol+4,lasc)
          write(lunout,'(7x,5i13)') (j,j=inicol,lascol)
          do i=inir,lasr
            write(lunout,'(i6,1x,1p,5d13.6)')
     *        i,(a(i-lrow+1,j-lcol+1),j=inicol,lascol)
          end do
          inicol=lascol+1
        if(inicol.le.lasc) go to 102
      end if
      end
      subroutine ut_imat_print_2
     *  (lunout,l,kform,nphysi,inir,lasr,inic,lasc,lrow,lcol)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 08, 2007 by HN                 ===
c=======================================================================
c
c     Print integer 2-D array
c
      implicit double precision (a-h,o-z)
      dimension l(nphysi,*)
      character*1 kform
c**** Symmetric or lower-trigonal matrix *******************************
      if(kform.eq.'s' .or. kform.eq.'S') then
        inicol=inic
  100   continue
          lascol=min(inicol+4,lasc)
          write(lunout,'(9x,10(i5,"."))') (j,j=inicol,lascol)
          do i=inicol,lasr
            k=min(lascol,i)
            write(lunout,'(i7,".",1x,10i6)')
     *        i,(l(i-lrow+1,j-lcol+1),j=inicol,k)
          end do
          inicol=lascol+1
        if(inicol.le.lasc) go to 100
c**** General matrix ***************************************************
      else
        inicol=inic
  102   continue
          lascol=min(inicol+4,lasc)
          write(lunout,'(9x,10(i5,"."))') (j,j=inicol,lascol)
          do i=inir,lasr
            write(lunout,'(i7,".",1x,10i6)')
     *        i,(l(i-lrow+1,j-lcol+1),j=inicol,lascol)
          end do
          inicol=lascol+1
        if(inicol.le.lasc) go to 102
      end if
      end
      subroutine ut_time
c====================================================================
c===          Coded by H. Nakano (Kyushu University)              ===
c===            Last revision: Oct 08, 2007 by HN                 ===
c====================================================================
c
c     Report CPU and WALL times
c
      implicit double precision (a-h,o-z)
      COMMON /OSLUN/  LPOUT ,LUNIN ,LUNOUT,LUNREF,LUNO2R,LUNROC,LUNOOC,
     *  LUNCC0,LUNHMA,LUNEIG,LUNEOB,LUNEDT,LUNERF,LUNHCR,LUNGJK,LUNGAI,
     *  LUNGEO,LUNTE1,LUNTE2,LUNHEF,LUNMOL,LUNMOS,LUNWGT,LUNRM2,LUNRM1,
     *  LUNR00,LUNRP1,LUNRP2,LUNVEF,LUNDIN,LUN2SZ,LUNCCS
c         GAMESS returns time since job began through this common
      COMMON /TIMING/ gms_CPU,gms_WALL
      dimension tscpu(20),tecpu(20),tswall(20),tewall(20)
      data n /0/
      save tscpu,tecpu,tswall,tewall,n
c
c     ------------------
      entry ut_init_time
c     ------------------
c**** Initialize parameters ********************************************
      n=n+1
c
C-MWS call cpu_time (tscpu (n))
C-MWS call wall_time(tswall(n))
c
      call tsecnd(tim)
      tscpu(n)  = gms_cpu
      tswall(n) = gms_wall
c
      return
c     --------------------
      entry ut_report_time
c     --------------------
c**** Report times *****************************************************
      if(n.eq.0) then
        write(lunout,'(" *** Error stop in sub.ut_report_time ***"/
     *                 " n =",i10)') n
        call abrt
      end if
c
C-MWS call cpu_time (tecpu (n))
C-MWS call wall_time(tewall(n))
c
      call tsecnd(tim)
      tecpu(n)  = gms_cpu
      tewall(n) = gms_wall
c
      write(lunout,'(" (        CPU time =",f15.2," sec.",
     *               "        WALL time =",f15.2," sec.)")')
     *               tecpu(n)-tscpu(n),tewall(n)-tswall(n)
      n=n-1
      return
c     --------------------------------
      entry ut_return_time(tcpu,twall)
c     --------------------------------
c**** Return times *****************************************************
      if(n.eq.0) then
        write(lunout,'(" *** Error stop in sub.ut_return_time ***"/
     *                 " n =",i10)') n
        call abrt
      end if
c
C-MWS call cpu_time (tecpu (n))
C-MWS call wall_time(tewall(n))
c
      call tsecnd(tim)
      tecpu(n)  = gms_cpu
      tewall(n) = gms_wall
c
      tcpu =tecpu (n)-tscpu (n)
      twall=tewall(n)-tswall(n)
      n=n-1
      return
C-MWS end
C-MWS subroutine wall_time(t)
c=======================================================================
c===             Coded by H. Nakano (Kyushu University)              ===
c===               Last revision: Oct 08, 2007 by HN                 ===
c=======================================================================
C-MWS implicit double precision (a-h,o-z)
C-MWS call system_clock(icount,icrate)
C-MWS t=dble(icount)/dble(icrate)
      end
