      SUBROUTINE S2PROJ(ICORE,MAXCOR,IUHF,SINGLE)
C
C THIS ROUTINE CALCULATES THE PROJECTED VALUE OF THE
C  NORMAL ORDERED S**2 OPERATOR, WHICH REPRESENTS THE
C  CORRELATION CORRECTION TO THE S**2.  THE FORMULA USED
C  IS:
C
C  <0|S**2 exp(T)|0> = SUM T(A,I) * P(A,I) - SUM T(a,i) * P(a,i)
C
C                     - T(Ab,Ij) * DELTA(b,I) * DELTA(A,j)
C
C WHERE:
C
C                 P(A,I) = SUM DELTA(J,e) * DELTA(e,A)
C                           e
C
C                 P(a,i) = SUM DELTA(a,J) * DELTA(J,i)
C      
C AND DELTA(p,Q) ARE ELEMENTS OF THE VIRTUAL-OCCUPIED ALPHA-BETA
C  MO OVERLAP MATRIX.
C
CEND
      IMPLICIT INTEGER (A-Z)
      LOGICAL SINGLE
      DOUBLE PRECISION S2PRJ,S2T2,S2T12,S1A,S1B,S2SCF,SDOT,ONE,ZILCH
      DOUBLE PRECISION S2P,Z
      DIMENSION ICORE(MAXCOR),NSIZOO(8),NSIZVO(8),NSIZOV(8),NSIZVV(8)
      COMMON /MACHSP/ IINTLN,IFLTLN,IINTFP,IALONE,IBITWD
      COMMON /SYM/ POP(8,2),VRT(8,2),NT(2),NFMI(2),NFEA(2)
      COMMON /SYMINF/ NSTART,NIRREP,IRREPS(255,2),DIRPRD(8,8)
      COMMON /SYMPOP/ IRPDPD(8,22),ISYTYP(2,500),ID(18)
      DATA ONE /1.0/
      DATA ZILCH /0.0/
      DATA ONEM/-1.0/
      IF(IUHF.EQ.0)RETURN
C
C LOAD OVERLAP MATRICES INTO BOTTOM OF CORE
C
      NSZOOT=0
      NSZVOT=0
      NSZOVT=0
      NSZVVT=0
      DO 10 IRREP=1,NIRREP
       ITMPOO=POP(IRREP,1)*POP(IRREP,2)
       ITMPVO=VRT(IRREP,1)*POP(IRREP,2)
       ITMPOV=POP(IRREP,1)*VRT(IRREP,2)
       ITMPVV=VRT(IRREP,1)*VRT(IRREP,2)
       NSIZOO(IRREP)=NSZOOT
       NSIZVO(IRREP)=NSZVOT
       NSIZOV(IRREP)=NSZOVT
       NSIZVV(IRREP)=NSZVVT
       NSZOOT=NSZOOT+ITMPOO
       NSZVOT=NSZVOT+ITMPVO
       NSZOVT=NSZOVT+ITMPOV
       NSZVVT=NSZVVT+ITMPVV
10    CONTINUE
      I000=1
      I010=I000+IINTFP*NSZOOT
      I020=I010+IINTFP*NSZVOT
      I030=I020+IINTFP*NSZOVT
      I040=I030+IINTFP*NSZVVT
      CALL GETLST(ICORE(I000),1,1,1,5,90)
      CALL GETLST(ICORE(I010),1,1,1,6,90)
      CALL GETLST(ICORE(I020),1,1,1,7,90)
      CALL GETLST(ICORE(I030),1,1,1,8,90)
      IF(SINGLE)THEN
       I050=I040+IINTFP*NT(1)
       I060=I050+IINTFP*NT(2)
       CALL GETLST(ICORE(I040),1,1,1,1,90)
       CALL GETLST(ICORE(I050),1,1,1,2,90)
      ELSE
       I060=I040
      ENDIF
C
C DO T2 + T1**2 CONTRIBUTION TO S**2
C
      LISTT=46
      I070=I060+IINTFP*NSZVOT
      CALL IZERO(ICORE(I060),NSZVOT*IINTFP)
      DO 100 IRREPDO=1,NIRREP
       NT2DSZ=IRPDPD(IRREPDO,ISYTYP(1,LISTT))
       NT2DIS=IRPDPD(IRREPDO,ISYTYP(2,LISTT))
       I080=I070+IINTFP*NT2DIS*NT2DSZ
       I090=I080+IINTFP*NT2DSZ
       CALL GETLST(ICORE(I070),1,NT2DIS,1,IRREPDO,LISTT)
       IF(SINGLE)THEN
        CALL FTAU(ICORE(I070),ICORE(I040),ICORE(I050),NT2DSZ,
     &            NT2DIS,POP(1,1),POP(1,2),VRT(1,1),VRT(1,2),
     &            IRREPDO,3,ONE)
       ENDIF
       I100=I090+IINTFP*NSZOVT
       CALL SYMTRA(1,POP(1,1),VRT(1,2),1,ICORE(I020),ICORE(I090))
       CALL DOT24(IRREPDO,ICORE(I060),ICORE(I090),ICORE(I070),
     &            ICORE(I080),NT2DSZ,VRT(1,1),POP(1,2),
     &            VRT(1,1),VRT(1,2),POP(1,1),POP(1,2),'TSST')
100   CONTINUE
      S2T2=-SDOT(NSZVOT,ICORE(I010),1,ICORE(I060),1)
      S2T12=0.0
C
C GET EASY PART FOR CCSD, QCISD, ETC.
C
      IF(SINGLE)THEN
       I070=I060+IINTFP*NT(1)
       I080=I070+IINTFP*NT(2)
       IOFF1=0
       IOFF2=0
       IOFFD1=I030
       IOFFD2=I020
       IOFFD3=I020
       IOFFD4=I000
       DO 300 IRREP=1,NIRREP
        POPI=POP(IRREP,1)
        VRTE=VRT(IRREP,2)
        VRTA=VRT(IRREP,1)
C
C  P(A,I) = SUM DELTA(A,e) * DELTA(I,e)
C
        CALL XGEMM('N','T',VRTA,POPI,VRTE,ONE,ICORE(IOFFD1),VRTA,
     &             ICORE(IOFFD2),POPI,ZILCH,ICORE(I060+IOFF1),VRTA)
        IOFF1=IOFF1+VRTA*POPI*IINTFP
        IOFFD1=IOFFD1+VRTA*VRTE*IINTFP
        IOFFD2=IOFFD2+POPI*VRTE*IINTFP
        POPJ=POP(IRREP,1)
        VRTA=VRT(IRREP,2)
        POPI=POP(IRREP,2)
C
C  P(a,i) = SUM DELTA(J,a) * DELTA(J,i)
C
        CALL XGEMM('T','N',VRTA,POPI,POPJ,ONE,ICORE(IOFFD3),POPJ,
     &             ICORE(IOFFD4),POPJ,ZILCH,ICORE(I070+IOFF2),VRTA)
        IOFF2=IOFF2+VRTA*POPI*IINTFP
        IOFFD3=IOFFD3+POPJ*VRTA*IINTFP
        IOFFD4=IOFFD4+POPJ*POPI*IINTFP
300    CONTINUE
       S1A=SDOT(NT(1),ICORE(I060),1,ICORE(I040),1)
       S1B=SDOT(NT(2),ICORE(I070),1,ICORE(I050),1)
       S2T12=S1A-S1B
      ENDIF
      S2P=S2T2+S2T12
      CALL GETREC(20,'JOBARC','S2SCF   ',IINTFP,S2SCF)
      WRITE(6,698)
      WRITE(6,697)
      WRITE(6,698)
      WRITE(6,699)S2SCF
      IF(.NOT.SINGLE)THEN
       WRITE(6,700)S2T2
      ELSE
       WRITE(6,701)S2T2
       WRITE(6,702)S2T12
      ENDIF
      WRITE(6,703)S2P+S2SCF
      Z=0.5*(-1.0+SQRT(1.0+4.0*(S2P+S2SCF)))
      WRITE(6,704)2.0*Z+1.0
      WRITE(6,698)
697   FORMAT(T20,'  Projected spin multiplicities: ')
698   FORMAT(T13,46('-'))
699   FORMAT(T13,' <0|S^2|0> ',T40,' = ',F15.10,'.')
700   FORMAT(T13,' <0|S^2 T2|0> ',T40,' = ',F15.10,'.')
701   FORMAT(T13,' <0|S^2 (T2+T1**2) |0> ',T40,' = ',F15.10,'.')
702   FORMAT(T13,' <0|S^2 T1|0> ',T40,' = ',F15.10,'.')
703   FORMAT(T13,' Projected <0|S^2 exp(T)|0>',T40,' = ',F15.10,'.')
704   FORMAT(T13,' Approximate spin mult.',T40,' = ',F15.10,'.')
      RETURN
      END
