anchor.diff:  *./ORBINP/ : NACOB used
   *
   c      INCLUDE 'mxpdim.inc'
  -      INCLUDE 'wrkspc.inc'
  -      INCLUDE 'orbinp.inc'
  -      INCLUDE 'cicisp.inc'
  -      INCLUDE 'strbas.inc'
  -      INCLUDE 'glbbas.inc'
  -      INCLUDE 'cstate.inc' 
  -      INCLUDE 'strinp.inc'
  -      INCLUDE 'stinf.inc'
  -      INCLUDE 'csm.inc'
  -      INCLUDE 'cprnt.inc'
  -      INCLUDE 'crun.inc'
  -      INCLUDE 'oper.inc'
  -*
  -      INCLUDE 'cands.inc'
  -      INCLUDE 'cintfo.inc'
  -*
  -      DIMENSION VECIN(*)
  -* ======
  -*.Output
  -* ======
  -      DIMENSION VECOUT(*)
  -      CALL QENTER('DIATR')
  -*
  -** Specifications of internal space
  -*
  -      NTEST = 0
  -      NTEST = MAX(NTEST,IPRDIA)
  -*
  -*. Perturbation operator
  -*
  -      IF(IPART.EQ.1) THEN
  -*. Moller-Plesset partitioning
  -        I12 = 1
  -        IPERTOP = 1
  -      ELSE IF(IPART.EQ.2) THEN
  -*. Epstein-Nesbet Partitioning
  -       I12 = 2
  -       IPERTOP = 0
  -      END IF
  -*
  -      ISM = ICSM
  -      ISPC = ICSPC
  -*
  -      IATP = IASTFI(ISPC)
  -      IBTP = IBSTFI(ISPC)
  -      NAEL = NELEC(IATP)
  -      NBEL = NELEC(IBTP)
  -      IF(NTEST.GE.10) THEN
  -        WRITE(6,*) ' ================'
  -        WRITE(6,*) ' DIATRM speaking '
  -       WRITE(6,*) ' ================'
  -        WRITE(6,*) ' IATP IBTP NAEL NBEL '
  -        WRITE(6,*)   IATP,IBTP,NAEL,NBEL
  -        WRITE(6,*) ' I12,IPERTOP',I12,IPERTOP
  -      END IF
  - 
  -      NOCTPA = NOCTYP(IATP)
  -      NOCTPB = NOCTYP(IBTP)
  -      MNRS1C = MNR1IC(ISPC)
  -      MXRS3C = MXR3IC(ISPC)
  -      IF(NTEST.GE.10) THEN
  -        write(6,*) ' NOCTPA NOCTPB MNRS1C,MXRS3C'
  -        write(6,*)   NOCTPA,NOCTPB,MNRS1C,MXRS3C
  -      END IF
  -*
  -**. Local memory
  -*
  -      CALL MEMMAN(IDUMMY,IDUMMY,'MARK  ',IDUM,'DIATRM')
  -      CALL MEMMAN(KLJ   ,NTOOB**2,'ADDL  ',2,'KLJ   ')
  -      CALL MEMMAN(KLK   ,NTOOB**2,'ADDL  ',2,'KLK   ')
  -      CALL MEMMAN(KLSCR2,2*NTOOB**2,'ADDL  ',2,'KLSC2 ')
  -      CALL MEMMAN(KLXA  ,NACOB,   'ADDL  ',2,'KLXA  ')
  -      CALL MEMMAN(KLXB  ,NACOB,   'ADDL  ',2,'KLXB  ')
  -      CALL MEMMAN(KLSCR ,2*NACOB, 'ADDL  ',2,'KLSCR ')
  -      CALL MEMMAN(KLH1D ,NTOOB,   'ADDL  ',2,'KLH1D ')
  -      CALL MEMMAN(KLSMOS,NSMST,   'ADDL  ',2,'KLSMOS')
  -      CALL MEMMAN(KLBLTP,NSMST,   'ADDL  ',2,'KLSMOS')
  -      CALL MEMMAN(KLIOIO,NOCTPA*NOCTPB,   'ADDL  ',2,'KLIOIO')
  -      IF(IDC.EQ.3.OR.IDC.EQ.4) THEN
  -        CALL MEMMAN(KLSVST,NSMST,   'ADDL  ',2,'KLSVST')
  -      ELSE
  -        KLSVST = 1
  -      END IF
  -      MAXA = IMNMX(WORK(KNSTSO(IATP)),NSMST*NOCTPA,2)
  -      CALL MEMMAN(KLRJKA,MAXA,'ADDL  ',2,'KLRJKA')
  -*
  -** Info on block structure of internal state
  -*
  -      IF(IDC.EQ.3.OR.IDC.EQ.4)
  -     &CALL SIGVST(WORK(KLSVST),NSMST)
  -      CALL ZBLTP(ISMOST(1,ISM),NSMST,IDC,WORK(KLBLTP),WORK(KLSVST))
  -      STOP ' Update call to IAIBCM_GAS '
  -      CALL IAIBCM_GAS(MNRS1C,MXRS3C,NOCTPA,NOCTPB,
  -     &     WORK(KEL1(IATP)),WORK(KEL3(IATP)),
  -     &     WORK(KEL1(IBTP)),WORK(KEL3(IBTP)),WORK(KLIOIO),IPRDIA)
  -*
  -**. Diagonal of one-body integrals and coulomb and exchange integrals
  -*
  -      IF(IPERTOP.NE.0) CALL SWAPVE(WORK(KFI),WORK(KINT1),NINT1) 
  -      CALL GT1DIA(WORK(KLH1D))
  -      WRITE(6,*) ' DIA0.. , IPERTOP = ', IPERTOP
  -      IF(IPERTOP.NE.0) CALL SWAPVE(WORK(KFI),WORK(KINT1),NINT1) 
  -      ECORES = 0.0D0
  -      IF(I12.EQ.2)
  -     &CALL GTJK(WORK(KLJ),WORK(KLK),NTOOB,WORK(KLSCR2),IREOTS)
  -*
  -      CALL DIATRMS(NAEL,WORK(KOCSTR(IATP)),NBEL,WORK(KOCSTR(IBTP)),
  -     &             NACOB,NSMST,WORK(KLH1D),
  -     &             ISMOST(1,ISM),WORK(KLBLTP),
  -     &             WORK(KLXA),WORK(KLXB),WORK(KLSCR),WORK(KLJ),
  -     &             WORK(KLK),WORK(KNSTSO(IATP)),WORK(KNSTSO(IBTP)),
  -     &             WORK(KLIOIO),NOCTPA,NOCTPB,WORK(KISTSO(IATP)),
  -     &             WORK(KISTSO(IBTP)),ECORES,
  -     &             PLSIGN,PSSIGN,IPRDIA,NTOOB,ICISTR,
  -     &             WORK(KLRJKA),I12,
  -     &             ITASK,VECIN,VECOUT,LUIN,LUOUT,FACTOR)
  -*.Flush local memory
  -      CALL MEMMAN(IDUMMY,IDUMMY,'FLUSM ',IDUMMY,'DIATRM')
  -      CALL QEXIT('DIATR')
  -*
  -      RETURN
  -      END
  -      SUBROUTINE DIATRM(ITASK,LUIN,LUOUT,VECIN,VECOUT,FACTOR)
  -*
  -*
  -* Direct calculation of diagonal terms for complete operator
  -*
  -* Itask = 1 : VEC2 = (Diag + Factor )    VEC1
  -* Itask = 2 : VEC2 = (Diag + factor ) -1 VEC1
  -* 
  -* if ICISTR.NE.1 VECOUT is LUOUT, VECIN is LUIN
  -*
  -*. Type of CI space is taken from CANDS (as ISSPC) 
  -*
  -*. Modified Sept. 2004 - for the ICCI project , Jeppe Olsen
  -
  -* =====
  -*.Input
  -* =====
  -*
  -*./ORBINP/ : NACOB used
  -*
  -c      INCLUDE 'mxpdim.inc'
  -      INCLUDE 'wrkspc.inc'
  -      INCLUDE 'orbinp.inc'
  -      INCLUDE 'cicisp.inc'
  -      INCLUDE 'strbas.inc'
  -      INCLUDE 'glbbas.inc'
  -      INCLUDE 'cstate.inc' 
  -      INCLUDE 'strinp.inc'
  -      INCLUDE 'stinf.inc'
  -      INCLUDE 'csm.inc'
  -      INCLUDE 'cprnt.inc'
  -      INCLUDE 'crun.inc'
  -*
  -      INCLUDE 'cands.inc'
  -      INCLUDE 'cintfo.inc'
  -*
  -      DIMENSION VECIN(*)
  -* ======
  -*.Output
  -* ======
  -      DIMENSION VECOUT(*)
  -      CALL QENTER('DIATR')
  -*. Complete operator
  -      I12 = 2
  -      IPERTOP = 0
  -*
  -** Specifications of internal space
  -*
  -      NTEST = 0
  -      NTEST = MAX(NTEST,IPRDIA)
  -*
  -      ISM = ICSM
  -      ISPC = ICSPC
  -*
  -      IATP = IASTFI(ISPC)
  -      IBTP = IBSTFI(ISPC)
  -      NAEL = NELEC(IATP)
  -      NBEL = NELEC(IBTP)
  -      IF(NTEST.GE.10) THEN
  -        WRITE(6,*) ' ================'
  -        WRITE(6,*) ' DIATRM speaking '
  -        WRITE(6,*) ' ================'
  -        WRITE(6,*) ' IATP IBTP NAEL NBEL '
  -        WRITE(6,*)   IATP,IBTP,NAEL,NBEL
  -        WRITE(6,*) ' I12,IPERTOP',I12,IPERTOP
  -      END IF
  - 
  -      NOCTPA = NOCTYP(IATP)
  -      NOCTPB = NOCTYP(IBTP)
  -      MNRS1C = MNR1IC(ISPC)
  -      MXRS3C = MXR3IC(ISPC)
  -      IF(NTEST.GE.10) THEN
  -        write(6,*) ' NOCTPA NOCTPB MNRS1C,MXRS3C'
  -        write(6,*)   NOCTPA,NOCTPB,MNRS1C,MXRS3C
  -      END IF
  -*
  -**. Local memory
  -*
  -      CALL MEMMAN(IDUMMY,IDUMMY,'MARK  ',IDUM,'DIATRM')
  -      CALL MEMMAN(KLJ   ,NTOOB**2,'ADDL  ',2,'KLJ   ')
  -      CALL MEMMAN(KLK   ,NTOOB**2,'ADDL  ',2,'KLK   ')
  -      CALL MEMMAN(KLSCR2,2*NTOOB**2,'ADDL  ',2,'KLSC2 ')
  -      CALL MEMMAN(KLXA  ,NACOB,   'ADDL  ',2,'KLXA  ')
  -      CALL MEMMAN(KLXB  ,NACOB,   'ADDL  ',2,'KLXB  ')
  -      CALL MEMMAN(KLSCR ,2*NACOB, 'ADDL  ',2,'KLSCR ')
  -      CALL MEMMAN(KLH1D ,NTOOB,   'ADDL  ',2,'KLH1D ')
  -      CALL MEMMAN(KLSMOS,NSMST,   'ADDL  ',2,'KLSMOS')
  -      CALL MEMMAN(KLBLTP,NSMST,   'ADDL  ',2,'KLSMOS')
  -      CALL MEMMAN(KLIOIO,NOCTPA*NOCTPB,   'ADDL  ',2,'KLIOIO')
  -      IF(IDC.EQ.3.OR.IDC.EQ.4) THEN
  -        CALL MEMMAN(KLSVST,NSMST,   'ADDL  ',2,'KLSVST')
  -      ELSE
  -        KLSVST = 1
  -      END IF
  -      MAXA = IMNMX(WORK(KNSTSO(IATP)),NSMST*NOCTPA,2)
  -      CALL MEMMAN(KLRJKA,MAXA,'ADDL  ',2,'KLRJKA')
  -*
  -** Info on block structure of internal state
  -*
  -      IF(IDC.EQ.3.OR.IDC.EQ.4)
  -     &CALL SIGVST(WORK(KLSVST),NSMST)
  -      CALL ZBLTP(ISMOST(1,ISM),NSMST,IDC,WORK(KLBLTP),WORK(KLSVST))
  -      CALL IAIBCM(ISSPC,WORK(KLIOIO))
  -*
  -**. Diagonal of one-body integrals and coulomb and exchange integrals
  -*
  -      IF(IPERTOP.NE.0) CALL SWAPVE(WORK(KFI),WORK(KINT1),NINT1) 
  -      CALL GT1DIA(WORK(KLH1D))
  -      IF(IPERTOP.NE.0) CALL SWAPVE(WORK(KFI),WORK(KINT1),NINT1) 
  -      ECORES = 0.0D0
  -      IF(I12.EQ.2)
  -     &CALL GTJK(WORK(KLJ),WORK(KLK),NTOOB,WORK(KLSCR2),IREOTS)
  -*
  -      CALL DIATRMS(NAEL,WORK(KOCSTR(IATP)),NBEL,WORK(KOCSTR(IBTP)),
  -     &             NACOB,NSMST,WORK(KLH1D),
  -     &             ISMOST(1,ISM),WORK(KLBLTP),
  -     &             WORK(KLXA),WORK(KLXB),WORK(KLSCR),WORK(KLJ),
  -     &             WORK(KLK),WORK(KNSTSO(IATP)),WORK(KNSTSO(IBTP)),
  -     &             WORK(KLIOIO),NOCTPA,NOCTPB,WORK(KISTSO(IATP)),
  -     &             WORK(KISTSO(IBTP)),ECORES,
  -     &             PLSIGN,PSSIGN,IPRDIA,NTOOB,ICISTR,
  -     &             WORK(KLRJKA),I12,
  -     &             ITASK,VECIN,VECOUT,LUIN,LUOUT,FACTOR)
  -*.Flush local memory
  -      CALL MEMMAN(IDUMMY,IDUMMY,'FLUSM ',IDUMMY,'DIATRM')
  -      CALL QEXIT('DIATR')
  -*
  -      RETURN
  -      END
  -      SUBROUTINE DIATRMS(NAEL,IASTR,NBEL,IBSTR,
  -     &                  NORB,NSMST,H,
  -     &                  ISMOST,IBLTP,XA,XB,SCR,RJ,RK,
  -     &                  NSSOA,NSSOB,IOCOC,NOCTPA,NOCTPB,
  -     &                  ISSOA,ISSOB,ECORE,
  -     &                  PLSIGN,PSSIGN,IPRNT,NTOOB,ICISTR,RJKAA,I12,
  -     &                  ITASK,VECIN,VECOUT,LUIN,LUOUT,FACTOR)
  -*
  -* ITASK = 1 : OUT = (DIAG + FACTOR )       * IN
  -* ITASK = 2 : OUT = (DIAG + FACTOR ) ** -1 * IN
  -*
  -*
  -* ========================
  -* General symmetry version
  -* ========================
  -*
  -* Jeppe Olsen, February 1994 , obtained from CIDIA4
  -*
  -* I12 = 1 => only one-body part
  -*     = 2 =>      one+two-body part
  -*
  -      IMPLICIT REAL*8           (A-H,O-Z)
  -*.General input
  -      DIMENSION NSSOA(NOCTPA,*),NSSOB(NOCTPB,* )
  -      DIMENSION ISSOA(NOCTPA,*),ISSOB(NOCTPB,*)
  -      DIMENSION IASTR(NAEL,*),IBSTR(NBEL,*)
  -      DIMENSION H(NORB)
  -*. Specific input
  -      DIMENSION IOCOC(NOCTPA,NOCTPB)
  -      DIMENSION ISMOST(*),IBLTP(*)
  -      DIMENSION VECIN(*)
  -*. Scratch
  -      DIMENSION RJ(NTOOB,NTOOB),RK(NTOOB,NTOOB)
  -      DIMENSION XA(NORB),XB(NORB),SCR(2*NORB)
  -      DIMENSION RJKAA(*)
  -*. Output
  -      DIMENSION VECOUT(*)
  -*
  -      NTEST =  0
  -      NTEST = MAX(NTEST,IPRNT)
  -*
  -      IOFF = 0
  -*
  -      IF( NTEST .GE. 20 ) THEN
  -        WRITE(6,*) ' Diagonal one electron integrals'
  -        CALL WRTMAT(H,1,NORB,1,NORB)
  -        IF(I12.EQ.2) THEN
  -          WRITE(6,*) ' Coulomb and exchange integrals '
  -          CALL WRTMAT(RJ,NORB,NORB,NTOOB,NTOOB)
  -          WRITE(6,*)
  -          CALL WRTMAT(RK,NORB,NORB,NTOOB,NTOOB)
  -        END IF
  -      END IF
  -*
  -**3 Diagonal elements according to Handys formulae
  -*   (corrected for error)
  -*
  -*   DIAG(IDET) = HII*(NIA+NIB)
  -*              + 0.5 * ( J(I,J)-K(I,J) ) * NIA*NJA
  -*              + 0.5 * ( J(I,J)-K(I,J) ) * NIB*NJB
  -*              +         J(I,J) * NIA*NJB
  -*
  -*. K goes to J - K
  -      IF(I12.EQ.2) 
  -     &CALL VECSUM(RK,RK,RJ,-1.0D0,+1.0D0,NTOOB **2)
  -      IDET = 0
  -      ITDET = 0
  -      DO 1000 IASM = 1, NSMST
  -        IBSM = ISMOST(IASM)
  -        IF(IBSM.EQ.0.OR.IBLTP(IASM).EQ.0) GOTO 1000
  -        IF(IBLTP(IASM).EQ.2) THEN
  -          IREST1 = 1
  -        ELSE
  -          IREST1 = 0
  -        END IF
  -*
  -        DO 999  IATP = 1,NOCTPA
  -          IF(IREST1.EQ.1) THEN
  -            MXBTP = IATP
  -          ELSE
  -            MXBTP = NOCTPB
  -          END IF
  -*
  -*. Will strings of this type be used ?
  -*
  -          IUSED = 0
  -          DO IBTP = 1, MXBTP
  -            IF( NSSOB(IBTP,IBSM).NE.0.AND.
  -     &      IOCOC(IATP,IBTP).NE.0) IUSED = 1
  -          END DO 
  -          IF( IUSED .EQ. 0 ) GOTO 987
  -*
  -*. Construct array RJKAA(*) =   SUM(I) H(I)*N(I) +
  -*                           0.5*SUM(I,J) ( J(I,J) - K(I,J))*N(I)*N(J)
  -*
  -          IOFF =  ISSOA(IATP,IASM)
  -          DO IA = IOFF,IOFF+NSSOA(IATP,IASM)-1
  -            EAA = 0.0D0
  -            DO IEL = 1, NAEL
  -              IAEL = IASTR(IEL,IA)
  -              EAA = EAA + H(IAEL)
  -              IF(I12.EQ.2) THEN
  -                DO JEL = 1, NAEL
  -                  EAA =   EAA + 0.5D0*RK(IASTR(JEL,IA),IAEL )
  -                END DO   
  -              END IF
  -            END DO
  -            RJKAA(IA-IOFF+1) = EAA 
  -          END DO
  -  987     CONTINUE
  -*
  -          DO 900 IBTP = 1,MXBTP
  -          IF(IOCOC(IATP,IBTP) .EQ. 0 ) GOTO 900
  -          IBSTRT = ISSOB(IBTP,IBSM)
  -          IBSTOP = IBSTRT + NSSOB(IBTP,IBSM)-1
  -*
  -*. Construct this block of dets
  -          IBOFF = IDET +1
  -          LBLOCK  = 0
  -          DO 899 IB = IBSTRT,IBSTOP
  -            IBREL = IB - IBSTRT + 1
  -*
  -*. Terms depending only on IB
  -*
  -            HB = 0.0D0
  -            RJBB = 0.0D0
  -            CALL SETVEC(XB,0.0D0,NORB)
  -*
  -            DO 990 IEL = 1, NBEL
  -              IBEL = IBSTR(IEL,IB)
  -              HB = HB + H(IBEL )
  -*
  -              IF(I12.EQ.2) THEN
  -                DO 980 JEL = 1, NBEL
  -                  RJBB = RJBB + RK(IBSTR(JEL,IB),IBEL )
  -  980           CONTINUE
  -*
  -                DO 970 IORB = 1, NORB
  -                  XB(IORB) = XB(IORB) + RJ(IORB,IBEL)
  -  970           CONTINUE
  -              END IF
  -  990       CONTINUE
  -            EB = HB + 0.5D0*RJBB + ECORE
  -*
  -            IF(IREST1.EQ.1.AND.IATP.EQ.IBTP) THEN
  -              IASTRT = ISSOA(IATP,IASM) - 1 + IBREL
  -            ELSE
  -              IASTRT = ISSOA(IATP,IASM)
  -            END IF
  -            IASTOP = ISSOA(IATP,IASM) + NSSOA(IATP,IASM) - 1
  -            DO 800 IA = IASTRT,IASTOP
  -              LBLOCK = LBLOCK + 1
  -              IDET = IDET + 1
  -              ITDET = ITDET + 1
  -              X = EB + RJKAA(IA-IOFF+1)
  -              DO 890 IEL = 1, NAEL
  -                X = X +XB(IASTR(IEL,IA)) 
  -  890         CONTINUE
  -              VECOUT(IDET) = X
  -  800       CONTINUE
  -  899     CONTINUE
  -          IF(Ntest.ge.1000) THEN
  -             WRITE(6,*) ' Next batch of diagonal elements '
  -             CALL WRTMAT(VECOUT(IBOFF),1,LBLOCK,1,LBLOCK)
  -          END IF
  -*
  -*. Yet a RAS block of the diagonal has been constructed, use it !
  -*
  -          IF(ICISTR.GE.2) THEN
  -            CALL IFRMDS(LDET,1,-1,LUIN)
  -            CALL FRMDSC(VECIN(IBOFF),LDET,-1,LUIN,IMZERO,IAMPACK)
  -          END IF
  -*
  -          IF(ITASK.EQ.1) THEN
  -C                 VVTOV(VECIN1,VECIN2,VECUT,NDIM)
  -             CALL VVTOV(VECIN(IBOFF),VECOUT(IBOFF),VECOUT(IBOFF),
  -     &                  LBLOCK)
  -             CALL VECSUM(VECOUT(IBOFF),VECIN(IBOFF),VECOUT(IBOFF),
  -     &                   FACTOR,1.0D0,LBLOCK)
  -          ELSE IF ( ITASK .EQ. 2 ) THEN
  -C                  DIAVC2(VECOUT,VECIN,DIAG,SHIFT,NDIM)
  -             CALL DIAVC2(VECOUT(IBOFF),VECIN(IBOFF),VECOUT(IBOFF),
  -     &                   FACTOR,LBLOCK)
  -          END IF
  -*
  -           IF(ICISTR.GE.2) THEN
  -             CALL ITODS(LDET,1,-1,LUOUT)
  -             CALL TODSC(VECOUT(IBOFF),LDET,-1,LUOUT)
  -             IDET = 0
  -           END IF
  -*
  -  900   CONTINUE
  -  999   CONTINUE
  -*
  - 1000 CONTINUE
  - 
  -*
  -      IF(NTEST .GE.1000) THEN
  -        WRITE(6,*) ' Output vector FROM DIATRMS'
  -        IF(ICISTR.LE.1 ) THEN
  -          CALL WRTMAT(VECOUT(1),1,IDET,1,IDET)
  -        ELSE
  -          LBLK = -1
  -          CALL WRTVCD(VECOUT,LUOUT,1,LBLK)
  -        END IF
  -      END IF
  -*
  -      IF ( ICISTR.GE.2 ) CALL ITODS(-1,1,-1,LUOUT)
  -*
  -      RETURN
  -      END
  -      SUBROUTINE DIABLK(IASM,IATP,IBSM,IBTP,IFULL,DIAG)
  -*
  -* Obtain diagonal block of determinant block 
  -* IASM,IATP,IBSM,IBTP
  -*
  -*
  -*. Type of operator is taken from OPER
  -*. Type of CI space is taken from CANDS
  -*
  -c      IMPLICIT REAL*8(A-H,O-Z)
  -* =====
  -*.Input
  -* =====
  -*
  -*./ORBINP/ : NACOB used
  -*
  -c      INCLUDE 'mxpdim.inc'
  +#include "errquit.fh"
  +#include "mafdecls.fh"
  +#include "global.fh"
         INCLUDE 'wrkspc.inc'
         INCLUDE 'orbinp.inc'
         INCLUDE 'cicisp.inc'
  
positive.code:            WRITE(6,*)
           END DO
        END IF
  *
        RETURN
        END
        SUBROUTINE H1STR(H,ISTRSM,ISTRTP,ISTRGP,
       &                  IOBSM,IOBTP,JOBSM,JOBTP,MXSXST,
       *                  IEXSTR,FACSTR,NEX,IH2TRM,NTESTG)
  *                                                                       
  * Obtain one-electron string matrix elements sum(ij) h(ij) <J!e(ij)!I>
  * with orbital i and j restricted to given orbital TS subsets
  *
  * from strings of symmetry ISTRSM and class ISTRTP
  *
  *
  * =====                                                             
  * Input                                                             
  * =====                                                             
  *
  
  *   ISTRSM,ISTTP,ISTRGP :  symmetry, type and group  of input string 
  *   IOBSM,IOBTP : symmetry and type of orbital i
  *   JOBSM,JOBTP : symmetry and type of orbital j
  *   MXSXST      : Max number of single excitations for given string
  *   H           : one-electron integrals for subsets of orbitals 
  *   IH2TRM      : ne 0 => include diagonal and one-electron 
  *                 operators from two body operator 
  *                                                                       
  * ======                                                            
  * Output                                                            
  * ======                                                            
  *
  *     NEX(ISTR)        : Number of excitations
  *     IEXSTR(IEX,ISTR) : Number of excited string ( relative to offset )
  *     FACSTR(IEX,ISTR)     : Phase factor of excitation.
  *                                                                       
  *     Jeppe Olsen, March 1994, LUCIA version 
  *
  c      IMPLICIT REAL*8(A-H,O-Z)
  *. a few include blocks
  c      INCLUDE 'mxpdim.inc'
        INCLUDE 'wrkspc.inc'
        INCLUDE 'orbinp.inc'
        INCLUDE 'strinp.inc'
        INCLUDE 'stinf.inc'
        INCLUDE 'strbas.inc'
        INCLUDE 'glbbas.inc'
  C     COMMON/GLBBAS/KINT1,KINT2,KPINT1,KPINT2,KLSM1,KLSM2,KRHO1,
  C    &              KSBEVC,KSBEVL,KSBIDT,KSBCNF,KH0,KH0SCR,
  C    &              KSBIA,KSBIB,KVEC3,KPNIJ,KIJKK
        
        DIMENSION H(*)
  *. A bit of local scratch
        DIMENSION IACAR(2),ITPAR(2)
  *
        NTESTL = 000
        NTEST = MAX(NTESTG,NTESTL)
        IF(NTEST.GE.1000) THEN
          WRITE(6,*) ' ***************** '
          WRITE(6,*) ' Output from H1STR '
          WRITE(6,*) ' ***************** '
        END IF
  *
  *. Number of orbitals and offsets
        NI   = NOBPTS(IOBTP,IOBSM)
        IOFF = IBTSOB(IOBTP,IOBSM)
  *
        NJ   = NOBPTS(JOBTP,JOBSM)
        JOFF = IBTSOB(JOBTP,JOBSM)
        IF(NTEST.GE.1000) THEN
          write(6,*) ' iobtp,iobsm,jobtp,jobsm',
       &               iobtp,iobsm,jobtp,jobsm
          write(6,*) ' NI NJ IOFF JOFF ', NI,NJ,IOFF,JOFF
        END IF
  *
  *. Offset for input string
        ISTROF = IFRMR(WORK,KISTSO(ISTRGP),
       &         (ISTRSM-1)*NOCTYP(ISTRGP)+ISTRTP)
  *. Number of input strings  
        NIST = IFRMR(WORK,KNSTSO(ISTRGP),
       &         (ISTRSM-1)*NOCTYP(ISTRGP)+ISTRTP)
  *. Group of output strings
        IACAR(1) = 2
        IACAR(2) = 1
  *
        ITPAR(1) = IOBTP
        ITPAR(2) = JOBTP
        CALL NEWTYP(ISTRGP,ISTRTP,IACAR,ITPAR,2,KSTRGP,KSTRTP)
  *. Symmetry of output strings
        CALL SYMCOM(3,0,IOBSM,JOBSM,IJSXSM)
        CALL SYMCOM(3,0,ISTRSM,IJSXSM,KSTRSM)
  C     WRITE(6,*) ' ISTRSM,IJSXSM KSTRSM',ISTRSM,IJSXSM,KSTRSM
  C     SYMCOM(ITASK,IOBJ,I1,I2,I12)
  *. Offset for output strings
        KSTROF = IFRMR(WORK,KISTSO(ISTRGP),
       &         (KSTRSM-1)*NOCTYP(ISTRGP)+KSTRTP)
  C     WRITE(6,*) ' off set for output strings ', KSTROF
  *
  *. Type of mappings
  *
  *. Nel => Nel - 1 electrons
        IF(ISTAC(ISTRGP,1).NE.0.AND.ISTAC(ISTRGP,2).NE.0) THEN
  *. full list
          IM1FUL = 1
          LM1    = NACOB
        ELSE
  *. Truncated list
          IM1FUL = 0
          LM1 = NELEC(ISTRGP)
        END IF
  *. Nel -1 => Nel mapping, not so simple anymore   
        NIEL = NELEC(ISTRGP)
        IF(ISTAC(ISTRGP+1,1).NE.0.AND.ISTAC(ISTRGP+1,2).NE.0) THEN
          IP1FUL = 1
          LP1 = NACOB
        ELSE
          IP1FUL = 0
          LP1 = -1
        END IF
          
        CALL  H1STRS(H,ISTROF,NIST,KSTROF,             
       &              NI,IOFF,NJ,JOFF,
       &              WORK(KSTSTM(ISTRGP,1)),WORK(KSTSTM(ISTRGP,2)),
       &              LM1,IM1FUL,
       &              WORK(KSTSTM(ISTRGP+1,1)),WORK(KSTSTM(ISTRGP+1,2)),
       &              WORK(KSTSTMI(ISTRGP+1)), WORK(KSTSTMN(ISTRGP+1)),
       &              LP1,IP1FUL,
       &              MXSXST,IEXSTR,FACSTR,NEX,IH2TRM,WORK(KPNIJ),
       &              WORK(KIJKK),WORK(KOCSTR(ISTRGP)),NIEL,
       &              NTOOB,NTEST)
  
  *
        RETURN
        END
  
negative.code:       ELSE
          KLSVST = 1
        END IF
        MAXA = IMNMX(int_mb(KNSTSO(IAGP)),NSMST*NOCTPA,2)
        CALL MEMMAN(KLRJKA,MAXA,'ADDL  ',2,'KLRJKA')
  *
  ** Info on block structure of internal state
  