      SUBROUTINE ROTATE (NI,NJ,XI,XJ,W,KR,E1B,E2A,ENUC,CUTOFF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C***********************************************************************
C
C..IMPROVED SCALAR VERSION
C..WRITTEN BY ERNEST R. DAVIDSON, INDIANA UNIVERSITY.
C
C
C   ROTATE CALCULATES THE TWO-PARTICLE INTERACTIONS.
C
C   ON INPUT  NI     = ATOMIC NUMBER OF FIRST ATOM.
C             NJ     = ATOMIC NUMBER OF SECOND ATOM.
C             XI     = COORDINATE OF FIRST ATOM.
C             XJ     = COORDINATE OF SECOND ATOM.
C
C ON OUTPUT W      = ARRAY OF TWO-ELECTRON REPULSION INTEGRALS.
C           E1B,E2A= ARRAY OF ELECTRON-NUCLEAR ATTRACTION INTEGRALS,
C                    E1B = ELECTRON ON ATOM NI ATTRACTING NUCLEUS OF NJ.
C           ENUC   = NUCLEAR-NUCLEAR REPULSION TERM.
C
C
C *** THIS ROUTINE COMPUTES THE REPULSION AND NUCLEAR ATTRACTION
C     INTEGRALS OVER MOLECULAR-FRAME COORDINATES.  THE INTEGRALS OVER
C     LOCAL FRAME COORDINATES ARE EVALUATED BY SUBROUTINE REPP AND
C     STORED AS FOLLOWS (WHERE P-SIGMA = O,   AND P-PI = P AND P* )
C     IN RI
C     (SS/SS)=1,   (SO/SS)=2,   (OO/SS)=3,   (PP/SS)=4,   (SS/OS)=5,
C     (SO/SO)=6,   (SP/SP)=7,   (OO/SO)=8,   (PP/SO)=9,   (PO/SP)=10,
C     (SS/OO)=11,  (SS/PP)=12,  (SO/OO)=13,  (SO/PP)=14,  (SP/OP)=15,
C     (OO/OO)=16,  (PP/OO)=17,  (OO/PP)=18,  (PP/PP)=19,  (PO/PO)=20,
C     (PP/P*P*)=21,   (P*P/P*P)=22.
C
C***********************************************************************
      COMMON /NUMCAL/ NUMCAL
      SAVE ANALYT, ICALCN
      COMMON /MOLMEC/ HTYPE(4),NHCO(4,20),NNHCO,ITYPE
      CHARACTER*241 KEYWRD
      LOGICAL SI,SJ, ANALYT
      COMMON /NATORB/ NATORB(107)
      COMMON /TWOEL3/ F03(107)
      COMMON /ALPHA3/ ALP3(153)
      COMMON /ALPHA / ALP(107)
      COMMON /CORE  / TORE(107)
      COMMON /IDEAS / FN1(107,10),FN2(107,10),FN3(107,10)
      COMMON /ALPTM / ALPTM(30), EMUDTM(30)
      COMMON /ROTDUM/ CSS1,CSP1,CPPS1,CPPP1,CSS2,CSP2,CPPS2,CPPP2
      COMMON /ROTDU2/ X(3),Y(3),Z(3)
      COMMON /KEYWRD/ KEYWRD
      DIMENSION XI(3),XJ(3),W(100),E1B(10),E2A(10)
      DIMENSION RI(22),CCORE(4,2), BORON1(3,4), BORON2(3,4), BORON3(3,4)
      EQUIVALENCE (CCORE(1,1),CSS1)
      DATA ICALCN/0/
      DATA BORON1/  0.182613D0,  0.118587D0, -0.073280D0,
     1              0.412253D0, -0.149917D0,  0.000000D0,
     2              0.261751D0,  0.050275D0,  0.000000D0,
     3              0.359244D0,  0.074729D0,  0.000000D0/
      DATA BORON2/  6.D0,  6.D0,  5.D0,
     1             10.D0,  6.D0,  0.D0,
     2              8.D0,  5.D0,  0.D0,
     3              9.D0,  9.D0,  0.D0/
      DATA BORON3/  0.727592D0,  1.466639D0,  1.570975D0,
     1              0.832586D0,  1.186220D0,  0.000000D0,
     2              1.063995D0,  1.936492D0,  0.000000D0,
     3              0.819351D0,  1.574414D0,  0.000000D0/
C
      IF(ICALCN.NE.NUMCAL)THEN
         ICALCN=NUMCAL
         ANALYT=(INDEX(KEYWRD,'ANALYT') .NE. 0)
         IF(ANALYT)THEN
            OPEN(UNIT=2,STATUS='SCRATCH',FORM='UNFORMATTED')
            REWIND 2
         ENDIF
      ENDIF
C
      X(1)=XI(1)-XJ(1)
      X(2)=XI(2)-XJ(2)
      X(3)=XI(3)-XJ(3)
      RIJ=X(1)*X(1)+X(2)*X(2)+X(3)*X(3)
      IF (RIJ.LT.0.00002D0) THEN
C
C     SMALL RIJ CASE
C
         DO 10 I=1,10
            E1B(I)=0.D0
            E2A(I)=0.D0
   10    CONTINUE
         W(KR)=0.D0
         ENUC=0.D0
C
      ELSE IF (ITYPE.EQ.4) THEN
C
C     MINDO CASE
C
         SUM=14.399D0/SQRT(RIJ+(7.1995D0/F03(NI)+7.1995D0/F03(NJ))**2)
         W(1)=SUM
         KR=KR+1
         DO 20 L=1,10
            E1B(L)=0.D0
            E2A(L)=0.D0
   20    CONTINUE
         E1B(1) = -SUM*TORE(NJ)
         E1B(3) = E1B(1)
         E1B(6) = E1B(1)
         E1B(10)= E1B(1)
         E2A(1) = -SUM*TORE(NI)
         E2A(3) = E2A(1)
         E2A(6) = E2A(1)
         E2A(10)= E2A(1)
         II = MAX(NI,NJ)
         NBOND = (II*(II-1))/2+NI+NJ-II
         RIJ = SQRT(RIJ)
         IF(NBOND.LT.154) THEN
            IF(NBOND.EQ.22 .OR. NBOND .EQ. 29) THEN
C              NBOND = 22 IS C-H CASE
C              NBOND = 29 IS N-H CASE
               SCALE=ALP3(NBOND)*EXP(-RIJ)
            ELSE
C              NBOND < 154  IS NI < 18 AND NJ < 18 CASE
               SCALE=EXP(-ALP3(NBOND)*RIJ)
            ENDIF
         ELSE
C              NBOND > 154 INVOLVES NI OR NJ > 18
            SCALE = 0
            IF(NATORB(NI).EQ.0) SCALE=      EXP(-ALP(NI)*RIJ)
            IF(NATORB(NJ).EQ.0) SCALE=SCALE+EXP(-ALP(NI)*RIJ)
         ENDIF
         IF (ABS(TORE(NI)).GT.20.D0 .AND. ABS(TORE(NJ)).GT.20.D0) THEN
            ENUC=0.D0
         ELSE IF (RIJ.LT.1.D0 .AND. NATORB(NI)*NATORB(NJ).EQ.0) THEN
            ENUC=0.D0
         ELSE
            ENUC = TORE(NI)*TORE(NJ)*SUM
     1       + ABS(TORE(NI)*TORE(NJ)*(14.399D0/RIJ-SUM)*SCALE)
         ENDIF
C
C     MNDO AND AM1 CASES
C
C *** THE REPULSION INTEGRALS OVER MOLECULAR FRAME (W) ARE STORED IN THE
C     ORDER IN WHICH THEY WILL LATER BE USED.  IE.  (I,J/K,L) WHERE
C     J.LE.I  AND  L.LE.K     AND L VARIES MOST RAPIDLY AND I LEAST
C     RAPIDLY.  (ANTI-NORMAL COMPUTER STORAGE)
C
      ELSE
C
         RIJX = SQRT(RIJ)
         RIJ = MIN(RIJX,CUTOFF)
C
C *** COMPUTE INTEGRALS IN DIATOMIC FRAME
C
         CALL REPP(NI,NJ,RIJ,RI,CCORE)
         IF(ANALYT)WRITE(2)(RI(I),I=1,22)
C
         GAM = RI(1)
         A=1.D0/RIJX
         X(1) = X(1)*A
         X(2) = X(2)*A
         X(3) = X(3)*A
         IF (ABS(X(3)).GT.0.99999999D0) THEN
            X(3) = SIGN(1.D0,X(3))
            Y(1) = 0.D0
            Y(2) = 1.D0
            Y(3) = 0.D0
            Z(1) = 1.D0
            Z(2) = 0.D0
            Z(3) = 0.D0
         ELSE
            Z(3)=SQRT(1.D0-X(3)*X(3))
            A=1.D0/Z(3)
            Y(1)=-A*X(2)*SIGN(1.D0,X(1))
            Y(2)=ABS(A*X(1))
            Y(3)=0.D0
            Z(1)=-A*X(1)*X(3)
            Z(2)=-A*X(2)*X(3)
         ENDIF
         SI = (NATORB(NI).GT.1)
         SJ = (NATORB(NJ).GT.1)
         IF ( SI .OR. SJ) THEN
            XX11 = X(1)*X(1)
            XX21 = X(2)*X(1)
            XX22 = X(2)*X(2)
            XX31 = X(3)*X(1)
            XX32 = X(3)*X(2)
            XX33 = X(3)*X(3)
            YY11 = Y(1)*Y(1)
            YY21 = Y(2)*Y(1)
            YY22 = Y(2)*Y(2)
            ZZ11 = Z(1)*Z(1)
            ZZ21 = Z(2)*Z(1)
            ZZ22 = Z(2)*Z(2)
            ZZ31 = Z(3)*Z(1)
            ZZ32 = Z(3)*Z(2)
            ZZ33 = Z(3)*Z(3)
            YYZZ11 = YY11+ZZ11
            YYZZ21 = YY21+ZZ21
            YYZZ22 = YY22+ZZ22
            XY11 = 2.D0*X(1)*Y(1)
            XY21 =      X(1)*Y(2)+X(2)*Y(1)
            XY22 = 2.D0*X(2)*Y(2)
            XY31 =      X(3)*Y(1)
            XY32 =      X(3)*Y(2)
            XZ11 = 2.D0*X(1)*Z(1)
            XZ21 =      X(1)*Z(2)+X(2)*Z(1)
            XZ22 = 2.D0*X(2)*Z(2)
            XZ31 =      X(1)*Z(3)+X(3)*Z(1)
            XZ32 =      X(2)*Z(3)+X(3)*Z(2)
            XZ33 = 2.D0*X(3)*Z(3)
            YZ11 = 2.D0*Y(1)*Z(1)
            YZ21 =      Y(1)*Z(2)+Y(2)*Z(1)
            YZ22 = 2.D0*Y(2)*Z(2)
            YZ31 =      Y(1)*Z(3)
            YZ32 =      Y(2)*Z(3)
         ENDIF
C
C     (S S/S S)
         W(1)=RI(1)
         KI = 1
         IF (SJ) THEN
C     (S S/PX S)
            W(2)=RI(5)*X(1)
C     (S S/PX PX)
            W(3)=RI(11)*XX11+RI(12)*YYZZ11
C     (S S/PY S)
            W(4)=RI(5)*X(2)
C     (S S/PY PX)
            W(5)=RI(11)*XX21+RI(12)*YYZZ21
C     (S S/PY PY)
            W(6)=RI(11)*XX22+RI(12)*YYZZ22
C     (S S/PZ S)
            W(7)=RI(5)*X(3)
C     (S S/PZ PX)
            W(8)=RI(11)*XX31+RI(12)*ZZ31
C     (S S/PZ PY)
            W(9)=RI(11)*XX32+RI(12)*ZZ32
C     (S S/PZ PZ)
            W(10)=RI(11)*XX33+RI(12)*ZZ33
            KI = 10
         ENDIF
C
         IF (SI) THEN
C     (PX S/S S)
            W(11)=RI(2)*X(1)
            IF (SJ) THEN
C     (PX S/PX S)
               W(12)=RI(6)*XX11+RI(7)*YYZZ11
C     (PX S/PX PX)
               W(13)=X(1)*(RI(13)*XX11+RI(14)*YYZZ11)
     1           +RI(15)*(Y(1)*XY11+Z(1)*XZ11)
C     (PX S/PY S)
               W(14)=RI(6)*XX21+RI(7)*YYZZ21
C     (PX S/PY PX)
               W(15)=X(1)*(RI(13)*XX21+RI(14)*YYZZ21)
     1           +RI(15)*(Y(1)*XY21+Z(1)*XZ21)
C     (PX S/PY PY)
               W(16)=X(1)*(RI(13)*XX22+RI(14)*YYZZ22)
     1           +RI(15)*(Y(1)*XY22+Z(1)*XZ22)
C     (PX S/PZ S)
               W(17)=RI(6)*XX31+RI(7)*ZZ31
C     (PX S/PZ PX)
               W(18)=X(1)*(RI(13)*XX31+RI(14)*ZZ31)
     1           +RI(15)*(Y(1)*XY31+Z(1)*XZ31)
C     (PX S/PZ PY)
               W(19)=X(1)*(RI(13)*XX32+RI(14)*ZZ32)
     1           +RI(15)*(Y(1)*XY32+Z(1)*XZ32)
C     (PX S/PZ PZ)
               W(20)=X(1)*(RI(13)*XX33+RI(14)*ZZ33)
     1           +RI(15)*(          Z(1)*XZ33)
C     (PX PX/S S)
               W(21)=RI(3)*XX11+RI(4)*YYZZ11
C     (PX PX/PX S)
               W(22)=X(1)*(RI(8)*XX11+RI(9)*YYZZ11)
     1           +RI(10)*(Y(1)*XY11+Z(1)*XZ11)
C     (PX PX/PX PX)
               W(23) =
     1     (RI(16)*XX11+RI(17)*YYZZ11)*XX11+RI(18)*XX11*YYZZ11
     2     +RI(19)*(YY11*YY11+ZZ11*ZZ11)
     3     +RI(20)*(XY11*XY11+XZ11*XZ11)
     4     +RI(21)*(YY11*ZZ11+ZZ11*YY11)
     5     +RI(22)*YZ11*YZ11
C     (PX PX/PY S)
               W(24)=X(2)*(RI(8)*XX11+RI(9)*YYZZ11)
     1           +RI(10)*(Y(2)*XY11+Z(2)*XZ11)
C     (PX PX/PY PX)
               W(25) =
     1     (RI(16)*XX11+RI(17)*YYZZ11)*XX21+RI(18)*XX11*YYZZ21
     2     +RI(19)*(YY11*YY21+ZZ11*ZZ21)
     3     +RI(20)*(XY11*XY21+XZ11*XZ21)
     4     +RI(21)*(YY11*ZZ21+ZZ11*YY21)
     5     +RI(22)*YZ11*YZ21
C     (PX PX/PY PY)
               W(26) =
     1     (RI(16)*XX11+RI(17)*YYZZ11)*XX22+RI(18)*XX11*YYZZ22
     2     +RI(19)*(YY11*YY22+ZZ11*ZZ22)
     3     +RI(20)*(XY11*XY22+XZ11*XZ22)
     4     +RI(21)*(YY11*ZZ22+ZZ11*YY22)
     5     +RI(22)*YZ11*YZ22
C     (PX PX/PZ S)
               W(27)=X(3)*(RI(8)*XX11+RI(9)*YYZZ11)
     1           +RI(10)*(         +Z(3)*XZ11)
C     (PX PX/PZ PX)
               W(28) =
     1      (RI(16)*XX11+RI(17)*YYZZ11)*XX31
     2     +(RI(18)*XX11+RI(19)*ZZ11+RI(21)*YY11)*ZZ31
     3     +RI(20)*(XY11*XY31+XZ11*XZ31)
     4     +RI(22)*YZ11*YZ31
C     (PX PX/PZ PY)
               W(29) =
     1      (RI(16)*XX11+RI(17)*YYZZ11)*XX32
     2     +(RI(18)*XX11+RI(19)*ZZ11+RI(21)*YY11)*ZZ32
     3     +RI(20)*(XY11*XY32+XZ11*XZ32)
     4     +RI(22)*YZ11*YZ32
C     (PX PX/PZ PZ)
               W(30) =
     1      (RI(16)*XX11+RI(17)*YYZZ11)*XX33
     2     +(RI(18)*XX11+RI(19)*ZZ11+RI(21)*YY11)*ZZ33
     3     +RI(20)*XZ11*XZ33
C     (PY S/S S)
               W(31)=RI(2)*X(2)
C     (PY S/PX S)
               W(32)=RI(6)*XX21+RI(7)*YYZZ21
C     (PY S/PX PX)
               W(33)=X(2)*(RI(13)*XX11+RI(14)*YYZZ11)
     1           +RI(15)*(Y(2)*XY11+Z(2)*XZ11)
C     (PY S/PY S)
               W(34)=RI(6)*XX22+RI(7)*YYZZ22
C     (PY S/PY PX)
               W(35)=X(2)*(RI(13)*XX21+RI(14)*YYZZ21)
     1           +RI(15)*(Y(2)*XY21+Z(2)*XZ21)
C     (PY S/PY PY)
               W(36)=X(2)*(RI(13)*XX22+RI(14)*YYZZ22)
     1           +RI(15)*(Y(2)*XY22+Z(2)*XZ22)
C     (PY S/PZ S)
               W(37)=RI(6)*XX32+RI(7)*ZZ32
C     (PY S/PZ PX)
               W(38)=X(2)*(RI(13)*XX31+RI(14)*ZZ31)
     1           +RI(15)*(Y(2)*XY31+Z(2)*XZ31)
C     (PY S/PZ PY)
               W(39)=X(2)*(RI(13)*XX32+RI(14)*ZZ32)
     1           +RI(15)*(Y(2)*XY32+Z(2)*XZ32)
C     (PY S/PZ PZ)
               W(40)=X(2)*(RI(13)*XX33+RI(14)*ZZ33)
     1           +RI(15)*(         +Z(2)*XZ33)
C     (PY PX/S S)
               W(41)=RI(3)*XX21+RI(4)*YYZZ21
C     (PY PX/PX S)
               W(42)=X(1)*(RI(8)*XX21+RI(9)*YYZZ21)
     1           +RI(10)*(Y(1)*XY21+Z(1)*XZ21)
C     (PY PX/PX PX)
               W(43) =
     1     (RI(16)*XX21+RI(17)*YYZZ21)*XX11+RI(18)*XX21*YYZZ11
     2     +RI(19)*(YY21*YY11+ZZ21*ZZ11)
     3     +RI(20)*(XY21*XY11+XZ21*XZ11)
     4     +RI(21)*(YY21*ZZ11+ZZ21*YY11)
     5     +RI(22)*YZ21*YZ11
C     (PY PX/PY S)
               W(44)=X(2)*(RI(8)*XX21+RI(9)*YYZZ21)
     1           +RI(10)*(Y(2)*XY21+Z(2)*XZ21)
C     (PY PX/PY PX)
               W(45) =
     1     (RI(16)*XX21+RI(17)*YYZZ21)*XX21+RI(18)*XX21*YYZZ21
     2     +RI(19)*(YY21*YY21+ZZ21*ZZ21)
     3     +RI(20)*(XY21*XY21+XZ21*XZ21)
     4     +RI(21)*(YY21*ZZ21+ZZ21*YY21)
     5     +RI(22)*YZ21*YZ21
C     (PY PX/PY PY)
               W(46) =
     1     (RI(16)*XX21+RI(17)*YYZZ21)*XX22+RI(18)*XX21*YYZZ22
     2     +RI(19)*(YY21*YY22+ZZ21*ZZ22)
     3     +RI(20)*(XY21*XY22+XZ21*XZ22)
     4     +RI(21)*(YY21*ZZ22+ZZ21*YY22)
     5     +RI(22)*YZ21*YZ22
C     (PY PX/PZ S)
               W(47)=X(3)*(RI(8)*XX21+RI(9)*YYZZ21)
     1           +RI(10)*(         +Z(3)*XZ21)
C      (PY PX/PZ PX)
               W(48) =
     1     (RI(16)*XX21+RI(17)*YYZZ21)*XX31
     2     +(RI(18)*XX21+RI(19)*ZZ21+RI(21)*YY21)*ZZ31
     3     +RI(20)*(XY21*XY31+XZ21*XZ31)
     4     +RI(22)*YZ21*YZ31
C      (PY PX/PZ PY)
               W(49) =
     1     (RI(16)*XX21+RI(17)*YYZZ21)*XX32
     2     +(RI(18)*XX21+RI(19)*ZZ21+RI(21)*YY21)*ZZ32
     3     +RI(20)*(XY21*XY32+XZ21*XZ32)
     4     +RI(22)*YZ21*YZ32
C      (PY PX/PZ PZ)
               W(50) =
     1     (RI(16)*XX21+RI(17)*YYZZ21)*XX33
     2     +(RI(18)*XX21+RI(19)*ZZ21+RI(21)*YY21)*ZZ33
     3     +RI(20)*XZ21*XZ33
C     (PY PY/S S)
               W(51)=RI(3)*XX22+RI(4)*YYZZ22
C     (PY PY/PX S)
               W(52)=X(1)*(RI(8)*XX22+RI(9)*YYZZ22)
     1           +RI(10)*(Y(1)*XY22+Z(1)*XZ22)
C      (PY PY/PX PX)
               W(53) =
     1     (RI(16)*XX22+RI(17)*YYZZ22)*XX11+RI(18)*XX22*YYZZ11
     2     +RI(19)*(YY22*YY11+ZZ22*ZZ11)
     3     +RI(20)*(XY22*XY11+XZ22*XZ11)
     4     +RI(21)*(YY22*ZZ11+ZZ22*YY11)
     5     +RI(22)*YZ22*YZ11
C     (PY PY/PY S)
               W(54)=X(2)*(RI(8)*XX22+RI(9)*YYZZ22)
     1           +RI(10)*(Y(2)*XY22+Z(2)*XZ22)
C      (PY PY/PY PX)
               W(55) =
     1     (RI(16)*XX22+RI(17)*YYZZ22)*XX21+RI(18)*XX22*YYZZ21
     2     +RI(19)*(YY22*YY21+ZZ22*ZZ21)
     3     +RI(20)*(XY22*XY21+XZ22*XZ21)
     4     +RI(21)*(YY22*ZZ21+ZZ22*YY21)
     5     +RI(22)*YZ22*YZ21
C      (PY PY/PY PY)
               W(56) =
     1     (RI(16)*XX22+RI(17)*YYZZ22)*XX22+RI(18)*XX22*YYZZ22
     2     +RI(19)*(YY22*YY22+ZZ22*ZZ22)
     3     +RI(20)*(XY22*XY22+XZ22*XZ22)
     4     +RI(21)*(YY22*ZZ22+ZZ22*YY22)
     5     +RI(22)*YZ22*YZ22
C     (PY PY/PZ S)
               W(57)=X(3)*(RI(8)*XX22+RI(9)*YYZZ22)
     1           +RI(10)*(         +Z(3)*XZ22)
C      (PY PY/PZ PX)
               W(58) =
     1     (RI(16)*XX22+RI(17)*YYZZ22)*XX31
     2     +(RI(18)*XX22+RI(19)*ZZ22+RI(21)*YY22)*ZZ31
     3     +RI(20)*(XY22*XY31+XZ22*XZ31)
     4     +RI(22)*YZ22*YZ31
C      (PY PY/PZ PY)
               W(59) =
     1     (RI(16)*XX22+RI(17)*YYZZ22)*XX32
     2     +(RI(18)*XX22+RI(19)*ZZ22+RI(21)*YY22)*ZZ32
     3     +RI(20)*(XY22*XY32+XZ22*XZ32)
     4     +RI(22)*YZ22*YZ32
C      (PY PY/PZ PZ)
               W(60) =
     1     (RI(16)*XX22+RI(17)*YYZZ22)*XX33
     2     +(RI(18)*XX22+RI(19)*ZZ22+RI(21)*YY22)*ZZ33
     3     +RI(20)*XZ22*XZ33
C     (PZ S/SS)
               W(61)=RI(2)*X(3)
C     (PZ S/PX S)
               W(62)=RI(6)*XX31+RI(7)*ZZ31
C     (PZ S/PX PX)
               W(63)=X(3)*(RI(13)*XX11+RI(14)*YYZZ11)
     1           +RI(15)*(         +Z(3)*XZ11)
C     (PZ S/PY S)
               W(64)=RI(6)*XX32+RI(7)*ZZ32
C     (PZ S/PY PX)
               W(65)=X(3)*(RI(13)*XX21+RI(14)*YYZZ21)
     1           +RI(15)*(         +Z(3)*XZ21)
C     (PZ S/PY PY)
               W(66)=X(3)*(RI(13)*XX22+RI(14)*YYZZ22)
     1           +RI(15)*(         +Z(3)*XZ22)
C     (PZ S/PZ S)
               W(67)=RI(6)*XX33+RI(7)*ZZ33
C     (PZ S/PZ PX)
               W(68)=X(3)*(RI(13)*XX31+RI(14)*ZZ31)
     1           +RI(15)*(         +Z(3)*XZ31)
C     (PZ S/PZ PY)
               W(69)=X(3)*(RI(13)*XX32+RI(14)*ZZ32)
     1           +RI(15)*(         +Z(3)*XZ32)
C     (PZ S/PZ PZ)
               W(70)=X(3)*(RI(13)*XX33+RI(14)*ZZ33)
     1           +RI(15)*(         +Z(3)*XZ33)
C     (PZ PX/S S)
               W(71)=RI(3)*XX31+RI(4)*ZZ31
C     (PZ PX/PX S)
               W(72)=X(1)*(RI(8)*XX31+RI(9)*ZZ31)
     1           +RI(10)*(Y(1)*XY31+Z(1)*XZ31)
C      (PZ PX/PX PX)
               W(73) =
     1     (RI(16)*XX31+RI(17)*ZZ31)*XX11+RI(18)*XX31*YYZZ11
     2     +RI(19)*ZZ31*ZZ11
     3     +RI(20)*(XY31*XY11+XZ31*XZ11)
     4     +RI(21)*ZZ31*YY11
     5     +RI(22)*YZ31*YZ11
C     (PZ PX/PY S)
               W(74)=X(2)*(RI(8)*XX31+RI(9)*ZZ31)
     1           +RI(10)*(Y(2)*XY31+Z(2)*XZ31)
C      (PZ PX/PY PX)
               W(75) =
     1     (RI(16)*XX31+RI(17)*ZZ31)*XX21+RI(18)*XX31*YYZZ21
     2     +RI(19)*ZZ31*ZZ21
     3     +RI(20)*(XY31*XY21+XZ31*XZ21)
     4     +RI(21)*ZZ31*YY21
     5     +RI(22)*YZ31*YZ21
C      (PZ PX/PY PY)
               W(76) =
     1     (RI(16)*XX31+RI(17)*ZZ31)*XX22+RI(18)*XX31*YYZZ22
     2     +RI(19)*ZZ31*ZZ22
     3     +RI(20)*(XY31*XY22+XZ31*XZ22)
     4     +RI(21)*ZZ31*YY22
     5     +RI(22)*YZ31*YZ22
C     (PZ PX/PZ S)
               W(77)=X(3)*(RI(8)*XX31+RI(9)*ZZ31)
     1           +RI(10)*(         +Z(3)*XZ31)
C     (PZ PX/PZ PX)
               W(78) =
     1      (RI(16)*XX31+RI(17)*ZZ31)*XX31
     2     +(RI(18)*XX31+RI(19)*ZZ31)*ZZ31
     3     +RI(20)*(XY31*XY31+XZ31*XZ31)
     4     +RI(22)*YZ31*YZ31
C      (PZ PX/PZ PY)
               W(79) =
     1      (RI(16)*XX31+RI(17)*ZZ31)*XX32
     2     +(RI(18)*XX31+RI(19)*ZZ31)*ZZ32
     3     +RI(20)*(XY31*XY32+XZ31*XZ32)
     4     +RI(22)*YZ31*YZ32
C      (PZ PX/PZ PZ)
               W(80) =
     1      (RI(16)*XX31+RI(17)*ZZ31)*XX33
     2     +(RI(18)*XX31+RI(19)*ZZ31)*ZZ33
     3     +RI(20)*XZ31*XZ33
C     (PZ PY/S S)
               W(81)=RI(3)*XX32+RI(4)*ZZ32
C     (PZ PY/PX S)
               W(82)=X(1)*(RI(8)*XX32+RI(9)*ZZ32)
     1           +RI(10)*(Y(1)*XY32+Z(1)*XZ32)
C      (PZ PY/PX PX)
               W(83) =
     1     (RI(16)*XX32+RI(17)*ZZ32)*XX11+RI(18)*XX32*YYZZ11
     2     +RI(19)*ZZ32*ZZ11
     3     +RI(20)*(XY32*XY11+XZ32*XZ11)
     4     +RI(21)*ZZ32*YY11
     5     +RI(22)*YZ32*YZ11
C     (PZ PY/PY S)
               W(84)=X(2)*(RI(8)*XX32+RI(9)*ZZ32)
     1           +RI(10)*(Y(2)*XY32+Z(2)*XZ32)
C      (PZ PY/PY PX)
               W(85) =
     1     (RI(16)*XX32+RI(17)*ZZ32)*XX21+RI(18)*XX32*YYZZ21
     2     +RI(19)*ZZ32*ZZ21
     3     +RI(20)*(XY32*XY21+XZ32*XZ21)
     4     +RI(21)*ZZ32*YY21
     5     +RI(22)*YZ32*YZ21
C      (PZ PY/PY PY)
               W(86) =
     1     (RI(16)*XX32+RI(17)*ZZ32)*XX22+RI(18)*XX32*YYZZ22
     2     +RI(19)*ZZ32*ZZ22
     3     +RI(20)*(XY32*XY22+XZ32*XZ22)
     4     +RI(21)*ZZ32*YY22
     5     +RI(22)*YZ32*YZ22
C     (PZ PY/PZ S)
               W(87)=X(3)*(RI(8)*XX32+RI(9)*ZZ32)
     1           +RI(10)*(         +Z(3)*XZ32)
C      (PZ PY/PZ PX)
               W(88) =
     1      (RI(16)*XX32+RI(17)*ZZ32)*XX31
     2     +(RI(18)*XX32+RI(19)*ZZ32)*ZZ31
     3     +RI(20)*(XY32*XY31+XZ32*XZ31)
     4     +RI(22)*YZ32*YZ31
C      (PZ PY/PZ PY)
               W(89) =
     1      (RI(16)*XX32+RI(17)*ZZ32)*XX32
     2     +(RI(18)*XX32+RI(19)*ZZ32)*ZZ32
     3     +RI(20)*(XY32*XY32+XZ32*XZ32)
     4     +RI(22)*YZ32*YZ32
C       (PZ PY/PZ PZ)
               W(90) =
     1      (RI(16)*XX32+RI(17)*ZZ32)*XX33
     2     +(RI(18)*XX32+RI(19)*ZZ32)*ZZ33
     3     +RI(20)*XZ32*XZ33
C     (PZ PZ/S S)
               W(91)=RI(3)*XX33+RI(4)*ZZ33
C     (PZ PZ/PX S)
               W(92)=X(1)*(RI(8)*XX33+RI(9)*ZZ33)
     1           +RI(10)*(          Z(1)*XZ33)
C       (PZ PZ/PX PX)
               W(93) =
     1     (RI(16)*XX33+RI(17)*ZZ33)*XX11+RI(18)*XX33*YYZZ11
     2     +RI(19)*ZZ33*ZZ11
     3     +RI(20)*XZ33*XZ11
     4     +RI(21)*ZZ33*YY11
C     (PZ PZ/PY S)
               W(94)=X(2)*(RI(8)*XX33+RI(9)*ZZ33)
     1           +RI(10)*(         +Z(2)*XZ33)
C       (PZ PZ/PY PX)
               W(95) =
     1     (RI(16)*XX33+RI(17)*ZZ33)*XX21+RI(18)*XX33*YYZZ21
     2     +RI(19)*ZZ33*ZZ21
     3     +RI(20)*XZ33*XZ21
     4     +RI(21)*ZZ33*YY21
C       (PZ PZ/PY PY)
               W(96) =
     1     (RI(16)*XX33+RI(17)*ZZ33)*XX22+RI(18)*XX33*YYZZ22
     2     +RI(19)*ZZ33*ZZ22
     3     +RI(20)*XZ33*XZ22
     4     +RI(21)*ZZ33*YY22
C     (PZ PZ/PZ S)
               W(97)=X(3)*(RI(8)*XX33+RI(9)*ZZ33)
     1           +RI(10)*(         +Z(3)*XZ33)
C       (PZ PZ/PZ PX)
               W(98) =
     1      (RI(16)*XX33+RI(17)*ZZ33)*XX31
     2     +(RI(18)*XX33+RI(19)*ZZ33)*ZZ31
     3     +RI(20)*XZ33*XZ31
C       (PZ PZ/PZ PY)
               W(99) =
     1      (RI(16)*XX33+RI(17)*ZZ33)*XX32
     2     +(RI(18)*XX33+RI(19)*ZZ33)*ZZ32
     3     +RI(20)*XZ33*XZ32
C       (PZ PZ/PZ PZ)
               W(100) =
     1      (RI(16)*XX33+RI(17)*ZZ33)*XX33
     2     +(RI(18)*XX33+RI(19)*ZZ33)*ZZ33
     3     +RI(20)*XZ33*XZ33
               KI = 100
            ELSE
C     (PX S/S S)
               W(2)=RI(2)*X(1)
C     (PX PX/S S)
               W(3)=RI(3)*XX11+RI(4)*YYZZ11
C     (PY S/S S)
               W(4)=RI(2)*X(2)
C     (PY PX/S S)
               W(5)=RI(3)*XX21+RI(4)*YYZZ21
C     (PY PY/S S)
               W(6)=RI(3)*XX22+RI(4)*YYZZ22
C     (PZ S/SS)
               W(7)=RI(2)*X(3)
C     (PZ PX/S S)
               W(8)=RI(3)*XX31+RI(4)*ZZ31
C     (PZ PY/S S)
               W(9)=RI(3)*XX32+RI(4)*ZZ32
C     (PZ PZ/S S)
               W(10)=RI(3)*XX33+RI(4)*ZZ33
               KI = 10
            END IF
         END IF
C
C *** NOW ROTATE THE NUCLEAR ATTRACTION INTEGRALS.
C *** THE STORAGE OF THE NUCLEAR ATTRACTION INTEGRALS  CORE(KL/IJ) IS
C     (SS/)=1,   (SO/)=2,   (OO/)=3,   (PP/)=4
C
         E1B(1)=-CSS1
         IF(NATORB(NI).EQ.4) THEN
            E1B(2) = -CSP1 *X(1)
            E1B(3) = -CPPS1*XX11-CPPP1*YYZZ11
            E1B(4) = -CSP1 *X(2)
            E1B(5) = -CPPS1*XX21-CPPP1*YYZZ21
            E1B(6) = -CPPS1*XX22-CPPP1*YYZZ22
            E1B(7) = -CSP1 *X(3)
            E1B(8) = -CPPS1*XX31-CPPP1*ZZ31
            E1B(9) = -CPPS1*XX32-CPPP1*ZZ32
            E1B(10)= -CPPS1*XX33-CPPP1*ZZ33
         END IF
         E2A(1)=-CSS2
         IF(NATORB(NJ).EQ.4) THEN
            E2A(2) = -CSP2 *X(1)
            E2A(3) = -CPPS2*XX11-CPPP2*YYZZ11
            E2A(4) = -CSP2 *X(2)
            E2A(5) = -CPPS2*XX21-CPPP2*YYZZ21
            E2A(6) = -CPPS2*XX22-CPPP2*YYZZ22
            E2A(7) = -CSP2 *X(3)
            E2A(8) = -CPPS2*XX31-CPPP2*ZZ31
            E2A(9) = -CPPS2*XX32-CPPP2*ZZ32
            E2A(10)= -CPPS2*XX33-CPPP2*ZZ33
         END IF
         IF(ABS(TORE(NI)).GT.20.D0.AND.ABS(TORE(NJ)).GT.20.D0) THEN
C SPARKLE-SPARKLE INTERACTION
            ENUC=0.D0
            RETURN
         ELSEIF (RIJ.LT.1.D0.AND.NATORB(NI)*NATORB(NJ).EQ.0) THEN
            ENUC=0.D0
            RETURN
         ENDIF
         SCALE = EXP(-ALP(NI)*RIJ)+EXP(-ALP(NJ)*RIJ)
C
         IF (NI.EQ.24.AND.NJ.EQ.24) THEN
            SCALE = EXP(-ALPTM(NI)*RIJ)+EXP(-ALPTM(NJ)*RIJ)
         ENDIF
C
         NT=NI+NJ
         IF(NT.EQ.8.OR.NT.EQ.9) THEN
            IF(NI.EQ.7.OR.NI.EQ.8) SCALE=SCALE+(RIJ-1.D0)*EXP(-ALP(NI)*R
     1IJ)
            IF(NJ.EQ.7.OR.NJ.EQ.8) SCALE=SCALE+(RIJ-1.D0)*EXP(-ALP(NJ)*R
     1IJ)
         ENDIF
         ENUC = TORE(NI)*TORE(NJ)*GAM
         SCALE=ABS(SCALE*ENUC)
         IF(ITYPE.EQ.2.AND.(NI.EQ.5.OR.NJ.EQ.5))THEN
C
C   LOAD IN AM1 BORON GAUSSIANS
C
            NK=NI+NJ-5
C   NK IS THE ATOMIC NUMBER OF THE NON-BORON ATOM
            NL=1
            IF(NK.EQ.1)NL=2
            IF(NK.EQ.6)NL=3
            IF(NK.EQ.9.OR.NK.EQ.17.OR.NK.EQ.35.OR.NK.EQ.53)NL=4
            DO 30 I=1,3
               FN1(5,I)=BORON1(I,NL)
               FN2(5,I)=BORON2(I,NL)
   30       FN3(5,I)=BORON3(I,NL)
         ENDIF
         IF(ITYPE.EQ.2.OR.ITYPE.EQ.3) THEN
            DO 40 IG=1,10
               IF(ABS(FN1(NI,IG)).GT.0.D0) THEN
                  AX = FN2(NI,IG)*(RIJ-FN3(NI,IG))**2
                  IF(AX .LE. 25.D0) THEN
                     SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ*FN1(NI,IG)*EXP(-
     1AX)
                  ENDIF
               ENDIF
               IF(ABS(FN1(NJ,IG)).GT.0.D0) THEN
                  AX = FN2(NJ,IG)*(RIJ-FN3(NJ,IG))**2
                  IF(AX .LE. 25.D0) THEN
                     SCALE=SCALE +TORE(NI)*TORE(NJ)/RIJ*FN1(NJ,IG)*EXP(-
     1AX)
                  ENDIF
               ENDIF
   40       CONTINUE
         ENDIF
         ENUC=ENUC+SCALE
C
         IF(NATORB(NI)*NATORB(NJ).EQ.0)KI=0
         KR=KR+KI
C
C
      ENDIF
      RETURN
      END


!******************************************************************************
! Copyright c 2013, The Ames Laboratory, Iowa State University, and Rutgers
! University*.  All rights reserved.
!
! This software was authored by Yongxin Yao, Nicola Lanata*, Gabriel Kotliar*,
! Cai-Zhuang Wang, and Kai-Ming Ho, at The Ames Laboratory and
! Rutgers University and was supported by the U.S.
! Department of Energy (DOE), Office of Science,
! Basic Energy Sciences, Materials Science and Engineering Division.
! The Ames Laboratory is operated by Iowa State University for DOE
! under U.S. Government contract DE-AC02-07CH11358.
! The U.S. Government has the rights to use, reproduce, and
! distribute this software.
! NEITHER THE GOVERNMENT, THE AMES LABORATORY, IOWA STATE UNIVERSITY,
! NOR RUTGERS UNIVERSITY MAKES ANY WARRANTY,
! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE.
! If software is modified to produce derivative works,
! such modified software should be clearly marked,
! so as to not confuse it with the version available from
! The Ames Laboratory and Rutgers University.
!
! Additionally, redistribution and use in source and binary forms,
! with or without modification,
! are permitted provided that the following conditions are met:
!
!     Redistribution of source code must retain the above copyright notice,
!     this list of conditions, and the following disclaimer.
!
!     Redistribution in binary form must reproduce the above copyright notice,
!     this list of conditions, and the following disclaimer
!     in the documentation and/or other materials provided with distribution.
!
!     Neither the name of The Ames Laboratory, Iowa State University,
!     Rutgers University, the U.S. Government, nor the names of
!     its contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE AMES LABORATORY, IOWA STATE UNIVERSITY,
! RUTGERS UNIVERSITY, AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY
! AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE GOVERNMENT, THE AMES LABORATORY,
! IOWA STATE UNIVERSITY, RUTGERS UNIVERSITY, OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
! HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
! OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!******************************************************************************

module warehouse
    use gprec
    use gutil
    use gconstant, only: zi,small
    use corrorb
    use hdf5
    use ghdf5_base
    implicit none

    type frozen
        integer :: nsorb,nelect
        integer,pointer :: idx_orb(:)
    end type frozen

    type matrix_basis
        integer :: dimhst=0,dimhsmax=0,dimhs1123
        !< dimension of the matrix basis for each atom
        integer,pointer :: dim_hs(:)
        complex(q),pointer :: hs(:)=>null() ! matrix basis
        integer,pointer :: m_struct(:)=>null() ! self-energy structure
    end type matrix_basis

    type ware_house
        integer :: num_imp,ntyp
        integer,allocatable :: ityp_imp(:), & !< type of the impurity.
                &imap_imp(:), & !< equiv. impurity map index. imap_imp(i)<=i.
                &na2_imp(:), & !< impurity spin-orbital dimension list
                !< Index to whether calculate it on local core.
                &local_imp(:),naso_imp(:), &
                &nval_bot_ityp(:),nval_top_ityp(:)
        real(q),allocatable :: et1(:),eu2(:)
        integer :: na2112,na2max,nasomax,nasotot
        integer :: iso,ispin,ispin_in,ispo,rspo,nspin,ivext=1
        type(corr_orb),allocatable::co(:)
        type(frozen),pointer::fz(:)

        real(q) :: ef,edcla1,symerr=0._q
        integer :: r_factor=2
        complex(q),pointer :: r(:),r0(:),d(:),d0(:),la1(:),la2(:),z(:), &
                &copy(:),nks(:),nc_var(:),nc_phy(:),h1e(:),isimix(:), &
                &vext(:)=>null(),&
                &sx(:)=>null(),sy(:)=>null(),sz(:)=>null(), &
                &lx(:)=>null(),ly(:)=>null(),lz(:)=>null(),r_coef(:), &
                ! additional rotations for bare hamiltonian.
                ! complex
                &db2sab(:)=>null() ! complex spherical
        real(q),pointer :: nks_coef(:),la1_coef(:),ncv_coef(:)
        !> hermitian matrix basis, (hermitian) maxtrix basis with
        !! selective mott localization.
        type (matrix_basis) :: hm, hm_l, hm_r
    end type ware_house

    type(ware_house) :: wh

    contains

    subroutine init_warehouse(io)
    integer,intent(in)::io

    logical lexist

    call gh5_open_r('GPARAM.h5',f_id)
    !< Get num_imp, ityp_imp, imap_imp and na2_imp
    call set_impurities_index()
    call write_impurities_index(io)
    call gh5_read_wh_hs('/dim_hs_imp','/HS','/SIGMA_STRUCT',wh%hm)
    call set_wh_db2sab(io)
    call set_wh_sl_vec()
    allocate(wh%co(wh%num_imp))
    call set_v2e_list(io)
    call gh5_close(f_id)

    inquire(file='GVEXT.h5',exist=lexist)
    if(lexist)then
        call gh5_open_r('GVEXT.h5',f_id)
        call set_wh_vext(io)
        call gh5_read(wh%ivext, '/givext', f_id)
        call gh5_close(f_id)
    endif

    inquire(file='GMOTT.h5',exist=lexist)
    if(lexist)call gh5_open_r('GMOTT.h5',f_id)
    call set_wh_hs('/dim_hs_r_imp',"/HS_R","/SIGMA_STRUCT_R",wh%hm_r,lexist)
    call set_wh_hs('/dim_hs_l_imp',"/HS_L","/SIGMA_STRUCT_L",wh%hm_l,lexist)
    call set_mott_localized_orbitals(lexist)
    if(lexist)call gh5_close(f_id)
    call output_mott_localized_orbitals(io)
    call alloc_warehouse()
    call link_co_warehouse()
    return

    end subroutine init_warehouse

    !< Impurities should be ordered according to types.
    subroutine set_v2e_list(io)
    integer,intent(in)::io

    integer i,imap,na2

    do i=1,wh%num_imp
        imap=wh%imap_imp(i)
        if(imap/=i)then
            wh%co(i)%v2e=>wh%co(imap)%v2e
            wh%co(i)%v_j2e=>wh%co(imap)%v_j2e
        else
            na2=wh%na2_imp(i)
            allocate(wh%co(i)%v2e(na2,na2,na2,na2))
            call gh5_read(wh%co(i)%v2e,na2,na2,na2,na2,'/IMPURITY_'// &
                    &trim(int_to_str(i))//'/V2E',f_id)
            if(io>0)then
                write(io,'(" imp = ",I2," v2e(1,1,1,1) = ",f0.2)')i,&
                    &real(wh%co(i)%v2e(1,1,1,1))
            endif
            allocate(wh%co(i)%v_j2e(na2,na2,na2,na2))
            call get_coul_exchange(na2,wh%co(i)%v2e,wh%co(i)%v_j2e)
        endif
    enddo
    return

    end subroutine set_v2e_list

    subroutine calc_la1_hf_list()
    integer i

    do i=1,wh%num_imp
        call calc_co_la1_hf(wh%co(i))
    enddo
    return

    end subroutine calc_la1_hf_list

    subroutine link_co_warehouse()
    integer i,na2,na22,naso,nasoo,dim_hs,ibase,jbase

    ibase=0; jbase=0
    do i=1,wh%num_imp
        na2=wh%na2_imp(i)
        na22=na2*na2
        wh%co(i)%dim2=na2; wh%co(i)%dim=na2/2
        naso=na2*wh%iso/2
        wh%co(i)%dimso=naso
        nasoo=wh%co(i)%dimso**2
        wh%co(i)%dim_hs_l = wh%hm_l%dim_hs(i)
        wh%co(i)%nks   (1:na2,1:na2) => wh%nks   (ibase+1:ibase+na22)
        wh%co(i)%isimix(1:na2,1:na2) => wh%isimix(ibase+1:ibase+na22)
        wh%co(i)%nc_var(1:na2,1:na2) => wh%nc_var(ibase+1:ibase+na22)
        wh%co(i)%nc_phy(1:na2,1:na2) => wh%nc_phy(ibase+1:ibase+na22)
        wh%co(i)%r     (1:na2,1:na2) => wh%r     (ibase+1:ibase+na22)
        wh%co(i)%r0    (1:na2,1:na2) => wh%r0    (ibase+1:ibase+na22)
        wh%co(i)%z     (1:na2,1:na2) => wh%z     (ibase+1:ibase+na22)
        wh%co(i)%d0    (1:na2,1:na2) => wh%d0    (ibase+1:ibase+na22)
        wh%co(i)%d     (1:na2,1:na2) => wh%d     (ibase+1:ibase+na22)
        wh%co(i)%la1   (1:na2,1:na2) => wh%la1   (ibase+1:ibase+na22)
        wh%co(i)%la2   (1:na2,1:na2) => wh%la2   (ibase+1:ibase+na22)
        wh%co(i)%h1e   (1:na2,1:na2) => wh%h1e   (ibase+1:ibase+na22)

        if(associated(wh%vext))then
            wh%co(i)%vext(1:na2,1:na2) => wh%vext(ibase+1:ibase+na22)
        endif

        if(associated(wh%sx))then
            wh%co(i)%sx(1:na2,1:na2) => wh%sx(ibase+1:ibase+na22)
            wh%co(i)%sy(1:na2,1:na2) => wh%sy(ibase+1:ibase+na22)
        endif
        if(associated(wh%sz))then
            wh%co(i)%sz(1:na2,1:na2) => wh%sz(ibase+1:ibase+na22)
        endif
        if(associated(wh%lx))then
            wh%co(i)%lx(1:na2,1:na2) => wh%lx(ibase+1:ibase+na22)
            wh%co(i)%ly(1:na2,1:na2) => wh%ly(ibase+1:ibase+na22)
        endif
        if(associated(wh%lz))then
            wh%co(i)%lz(1:na2,1:na2) => wh%lz(ibase+1:ibase+na22)
        endif
        if(associated(wh%db2sab))then
            wh%co(i)%db2sab(1:na2,1:na2) => &
                &wh%db2sab(ibase+1:ibase+na22)
        endif

        wh%co(i)%m_struct(1:na2,1:na2) => wh%hm%m_struct(ibase+1:ibase+na22)

        dim_hs=wh%hm_l%dim_hs(i)
        if(dim_hs>0)then
            wh%co(i)%hs_l(1:na2,1:na2,1:dim_hs) => wh%hm_l%hs(jbase+1: &
                    &jbase+na22*dim_hs)
        endif
        jbase=jbase+na22*dim_hs
        ibase=ibase+na22
    enddo
    return

    end subroutine link_co_warehouse

    ! \sum_ij \lambda_ij <c^\dagger_i c_j>
    subroutine calc_edcla1()

    wh%edcla1=real(sum(wh%la1*wh%nks),q)
    return

    end subroutine calc_edcla1

    subroutine set_wh_hs_dimtot(mb)
    type(matrix_basis),intent(inout)::mb

    integer i

    mb%dimhsmax=maxval(mb%dim_hs)
    mb%dimhst=0
    mb%dimhs1123=0
    do i=1,wh%num_imp
        mb%dimhs1123=mb%dimhs1123+wh%na2_imp(i)**2*mb%dim_hs(i)
        if(wh%imap_imp(i)==i)then
            mb%dimhst=mb%dimhst+mb%dim_hs(i)
        endif
    enddo
    return

    end subroutine set_wh_hs_dimtot

    subroutine set_impurities_index()
    logical lexist

    call gh5_read(wh%iso,'/iso',f_id)
    call gh5_read(wh%ispin,'/ispin',f_id)
    call gh5_read(wh%num_imp,'/num_imp',f_id)
    allocate(wh%ityp_imp(wh%num_imp), wh%imap_imp(wh%num_imp), &
            &wh%na2_imp(wh%num_imp),wh%naso_imp(wh%num_imp))
    call gh5_read(wh%ityp_imp,wh%num_imp,'/ITYP_IMP',f_id)
    call gh5_read(wh%imap_imp,wh%num_imp,'/IMAP_IMP',f_id)
    call gh5_read(wh%na2_imp,wh%num_imp,'/na2_imp',f_id)

    wh%ispo=max(wh%iso,wh%ispin)
    wh%rspo=3-wh%ispo
    wh%nspin=max(1,wh%ispin/wh%iso)
    wh%na2max=maxval(wh%na2_imp)
    wh%nasomax=wh%na2max*wh%iso/2
    wh%na2112=sum(wh%na2_imp**2)
    wh%nasotot=sum(wh%na2_imp)*wh%iso/2
    wh%naso_imp=wh%na2_imp*wh%iso/2
    wh%ntyp=maxval(wh%ityp_imp)

    call h5lexists_f(f_id,'/nval_bot_ityp',lexist,gh5_err)
    if(lexist)then
        allocate(wh%nval_bot_ityp(wh%ntyp),wh%nval_top_ityp(wh%ntyp))
        call gh5_read(wh%nval_bot_ityp,wh%ntyp,'/nval_bot_ityp',f_id)
        call gh5_read(wh%nval_top_ityp,wh%ntyp,'/nval_top_ityp',f_id)
    endif
    return

    end subroutine set_impurities_index

    subroutine wh_set_local_imp(local_imp)
    integer,intent(in)::local_imp(wh%num_imp)

    allocate(wh%local_imp(wh%num_imp))
    wh%local_imp=local_imp
    return

    end subroutine wh_set_local_imp

    subroutine write_impurities_index(io)
    integer,intent(in)::io

    if(io<0)return
    write(io,'(" total number of impurities = ",I4)')wh%num_imp
    write(io,'(" impurity type indices:")')
    write(io,'(4x,10I4)')wh%ityp_imp
    write(io,'(" impurity imap indices:")')
    write(io,'(4x,10I4)')wh%imap_imp
    write(io,'(" impurity num_spin_orbitals:")')
    write(io,'(4x,10I4)')wh%na2_imp
    return

    end subroutine write_impurities_index

    subroutine alloc_warehouse()

    allocate(wh%r(wh%na2112), wh%r0(wh%na2112), &
            &wh%z(wh%na2112), wh%d(wh%na2112), &
            &wh%d0(wh%na2112), wh%la1(wh%na2112), &
            &wh%la2(wh%na2112), wh%nks(wh%na2112), &
            &wh%isimix(wh%na2112), wh%nc_var(wh%na2112), &
            &wh%nc_phy(wh%na2112), wh%copy(wh%na2112), &
            &wh%h1e(wh%na2112), &
            &wh%nks_coef(wh%hm_l%dimhst),wh%la1_coef(wh%hm_l%dimhst), &
            &wh%ncv_coef(wh%hm_l%dimhst),wh%r_coef(wh%hm_r%dimhst), &
            &wh%et1(wh%num_imp), wh%eu2(wh%num_imp))
    wh%r=0; wh%r0=0; wh%z=0; wh%d=0; wh%d0=0; wh%la1=0; wh%la2=0
    wh%nks=0; wh%isimix=0; wh%nc_var=0; wh%nc_phy=0
    return

    end subroutine alloc_warehouse

    subroutine init_wh_x(io,r_default)
    integer,intent(in)::io
    real(q),intent(in)::r_default

    logical lexist

    inquire(file='WH_RL_INP.h5',exist=lexist)
    if(lexist)then
        call gh5_read_wh_rl()
    else
        wh%la1=wh%h1e
        call set_diagonal_r(r_default)
        if(wh%ivext==0.and.associated(wh%vext))then
            wh%la1=wh%la1+wh%vext
        endif
    endif
    call modify_r_la1_frozen(0, 30._q)
    call calc_r_pp(io,'r-inp')
    call calc_la1_pp(io,'la1-inp')
    return

    end subroutine init_wh_x

    subroutine set_diagonal_r(r_default)
    real(q),intent(in)::r_default

    integer i,j

    do i=1,wh%num_imp
        do j=1,wh%na2_imp(i)
            wh%co(i)%r(j,j)=r_default
        enddo
    enddo
    return

    end subroutine set_diagonal_r

    !*************************************************************************
    subroutine gh5_wrt_wh_matrix_list(apath, a)
    character(*),intent(in)::apath
    complex(q),target,intent(in)::a(wh%na2112)

    integer i,na2,na22,ibase
    complex(q),pointer::p_a(:,:)

    ibase=0
    do i = 1,wh%num_imp
        na2=wh%na2_imp(i)
        na22=na2**2
        p_a(1:na2,1:na2)=>a(ibase+1:ibase+na22)
        call gh5_write(p_a,na2,na2,'/IMPURITY_'//trim(int_to_str(i))// &
                &apath,f_id)
        ibase=ibase+na22
    enddo
    nullify(p_a)
    return

    end subroutine gh5_wrt_wh_matrix_list

    subroutine calc_isimix(io)
    integer,intent(in)::io

    integer i,imap

    do i=1,wh%num_imp
        imap=wh%imap_imp(i)
        if(imap==i)then
            call calc_co_isimix(wh%co(i))
        else
            wh%co(i)%isimix=wh%co(imap)%isimix
        endif
    enddo
    if(io>0)then
        call output_matrices('isimix-var',wh%isimix,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif
    return

    end subroutine calc_isimix

    subroutine eval_sl_vec_all(mode,io)
    integer,intent(in)::mode,io

    integer i
    character name_*12

    if(.not.associated(wh%sx))return
    if(mode==1)then
        name_='var-hf-only'
    else
        name_='physical'
    endif
    do i=1,wh%num_imp
        call eval_co_sl_vec(wh%co(i),mode)
        if(io>0)then
            write(io,'(" imp =",i4," s_xyz(",a12,") =",3f12.5)')i,name_, &
                &wh%co(i)%s_val(:,mode)
            write(io,'(10x," l_xyz(",a12,") =",3f12.5)')name_, &
                &wh%co(i)%l_val(:,mode)
        endif
    enddo
    return

    end subroutine eval_sl_vec_all

    subroutine gh5_read_wh_h1e(nspin_in)
    integer,intent(in)::nspin_in

    integer i,naso,na22,ibase
    complex(q),allocatable::h1e(:,:)

    wh%h1e=0
    do i=1,wh%num_imp
        naso=wh%naso_imp(i)
        if(i>1)then
            if(wh%naso_imp(i-1)/=naso)then
                deallocate(h1e)
                allocate(h1e(naso,naso))
            endif
        else
            allocate(h1e(naso,naso))
        endif
        call gh5_read(h1e,naso,naso,'/IMPURITY_'//trim(int_to_str(i))// &
                &"/H1E_SPIN1",f_id)
        wh%co(i)%h1e(1:naso,1:naso)=h1e
        if(wh%iso==1)then
            if(nspin_in==2)then
                call gh5_read(h1e,naso,naso,'/IMPURITY_' &
                        &//trim(int_to_str(i))//"/H1E_SPIN2",f_id)
            endif
            wh%co(i)%h1e(1+naso:,1+naso:)=h1e
        endif
    enddo
    deallocate(h1e)
    return

    end subroutine gh5_read_wh_h1e

    subroutine gh5_read_wh_matrix_list(apath, dim_imp, a)
    character(*),intent(in)::apath
    integer,intent(in)::dim_imp(*)
    complex(q),target,intent(out)::a(*)

    integer i,na2,na22,ibase
    complex(q),pointer::p_a(:,:)

    ibase=0
    do i = 1,wh%num_imp
        na2=dim_imp(i)
        na22=na2**2
        p_a(1:na2,1:na2)=>a(ibase+1:ibase+na22)
        call gh5_read(p_a,na2,na2,'/IMPURITY_'//trim(int_to_str(i))// &
                &apath,f_id)
        ibase=ibase+na22
    enddo
    nullify(p_a)
    return

    end subroutine gh5_read_wh_matrix_list

    !*************************************************************************
    subroutine gh5_wrt_wh_rl(fname)
    character(*) fname

    call gh5_open_w(fname, f_id)
    call gh5_create_impurity_groups(f_id)
    call gh5_wrt_wh_matrix_list('/R',wh%r)
    call gh5_wrt_wh_matrix_list('/LAMBDA',wh%la1)
    call gh5_close(f_id)
    return

    end subroutine gh5_wrt_wh_rl

    !*************************************************************************
    subroutine gh5_read_wh_rl()
    logical lexist

    call gh5_open_r('WH_RL_INP.h5', f_id)
    call gh5_read_wh_matrix_list('/LAMBDA',wh%na2_imp,wh%la1)
    call h5lexists_f(f_id,'/IMPURITY_1/R',lexist,gh5_err)
    if(lexist)then
        call gh5_read_wh_matrix_list('/R',wh%na2_imp,wh%r)
    else
        call set_diagonal_r(0.999_q)
    endif
    call gh5_close(f_id)
    return

    end subroutine gh5_read_wh_rl

    !*************************************************************************
    ! read [s_x, s_y, s_z] and [l_x, l_y, l_z]
    !*************************************************************************
    subroutine set_wh_sl_vec()
    integer i
    logical lexist

    call h5lexists_f(f_id,'/IMPURITY_1/SZ',lexist,gh5_err)
    if(lexist)then
        allocate(wh%sz(wh%na2112))
        call gh5_read_wh_matrix_list('/SZ',wh%na2_imp,wh%sz)
    endif
    call h5lexists_f(f_id,'/IMPURITY_1/LZ',lexist,gh5_err)
    if(lexist)then
        allocate(wh%lz(wh%na2112))
        call gh5_read_wh_matrix_list('/LZ',wh%na2_imp,wh%lz)
    endif
    call h5lexists_f(f_id,'/IMPURITY_1/SX',lexist,gh5_err)
    if(lexist)then
        allocate(wh%sx(wh%na2112),wh%sy(wh%na2112), &
                &wh%lx(wh%na2112),wh%ly(wh%na2112))
        call gh5_read_wh_matrix_list('/SX',wh%na2_imp,wh%sx)
        call gh5_read_wh_matrix_list('/SY',wh%na2_imp,wh%sy)
        call gh5_read_wh_matrix_list('/LX',wh%na2_imp,wh%lx)
        call gh5_read_wh_matrix_list('/LY',wh%na2_imp,wh%ly)
    endif
    return

    end subroutine set_wh_sl_vec

    subroutine gh5_read_wh_hs(dpath,hpath,spath,mb)
    character(*),intent(in)::dpath,hpath,spath
    type(matrix_basis),intent(inout)::mb

    integer na2,dim_hs,na223,i,ibase,jbase
    complex(q),pointer::mb_hs(:,:,:)
    integer,pointer::mb_m_struct(:,:)

    allocate(mb%dim_hs(wh%num_imp))
    call gh5_read(mb%dim_hs,wh%num_imp,dpath,f_id)
    call set_wh_hs_dimtot(mb)
    allocate(mb%hs(mb%dimhs1123),mb%m_struct(wh%na2112))
    mb%m_struct=0

    ibase=0; jbase=0
    do i=1,wh%num_imp
        na2=wh%na2_imp(i)
        dim_hs=mb%dim_hs(i)
        na223=na2**2*dim_hs
        if(na223>0)then
            mb_hs(1:na2,1:na2,1:dim_hs)=>mb%hs(ibase+1:ibase+na223)
            call gh5_read(mb_hs,na2,na2,dim_hs,'/IMPURITY_'// &
                    &trim(int_to_str(i))//hpath,f_id)
            ibase=ibase+na223
            mb_m_struct(1:na2,1:na2)=>mb%m_struct(jbase+1:jbase+na2**2)
            call gh5_read(mb_m_struct,na2,na2,'/IMPURITY_'// &
                    &trim(int_to_str(i))//spath,f_id)
        endif
        jbase=jbase+na2**2
    enddo
    nullify(mb_hs,mb_m_struct)
    return

    end subroutine gh5_read_wh_hs

    !*************************************************************************
    subroutine set_wh_hs(dpath,hpath,spath,mb,lopen)
    character(*),intent(in) :: dpath,hpath,spath
    type(matrix_basis),intent(inout)::mb
    logical,intent(in)::lopen

    logical lexist

    if(lopen)then
        call h5lexists_f(f_id,dpath,lexist,gh5_err)
    else
        lexist=.false.
    endif
    if(lexist)then
        call gh5_read_wh_hs(dpath,hpath,spath,mb)
    else
        mb%dim_hs=>wh%hm%dim_hs
        mb%hs=>wh%hm%hs
        mb%dimhsmax=wh%hm%dimhsmax
        mb%dimhst=wh%hm%dimhst
        mb%dimhs1123=wh%hm%dimhs1123
    endif
    return

    end subroutine set_wh_hs

    ! Convention:
    ! iso=1 -> {{complext spherical harmonics (CSH)}_up}
    ! to symmetry adapted basis (SAB);
    ! iso=2 -> relativistic harmonmics to SAB;
    subroutine set_wh_db2sab(io)
    integer,intent(in)::io

    logical lexist

    call h5lexists_f(f_id,'/IMPURITY_1/DB_TO_SAB',lexist,gh5_err)
    if(lexist)then
        allocate(wh%db2sab(wh%na2112))
        call gh5_read_wh_matrix_list('/DB_TO_SAB',wh%na2_imp,wh%db2sab)
        if(io>0)then
            write(io,'(" transformation db_to_sab read in.")')
        endif
    endif
    return

    end subroutine set_wh_db2sab

    ! read in a list of local external potentials.
    subroutine set_wh_vext(io)
    integer,intent(in)::io

    allocate(wh%vext(wh%na2112))
    call gh5_read_wh_matrix_list('/VEXT',wh%na2_imp,wh%vext)
    if(io>0)then
        write(io,'(" list of local vext read in.")')
        call output_matrices('v_ext',wh%vext,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif
    return

    end subroutine set_wh_vext

    !*************************************************************************
    ! Mott localized spin-orbital information
    !*************************************************************************
    subroutine set_mott_localized_orbitals(lopen)
    logical,intent(in)::lopen

    integer i,i_
    logical lexist

    allocate(wh%fz(wh%num_imp))
    if(lopen)then
        call h5lexists_f(f_id,'/IMPURITY_1/num_mott_orbitals',lexist,gh5_err)
    else
        lexist=.false.
    endif
    if(.not.lexist)then
        wh%fz(:)%nsorb=0; wh%fz(:)%nelect=0
    else
        do i=1,wh%num_imp
            call gh5_read(wh%fz(i)%nsorb,'/IMPURITY_'//trim(int_to_str(i))// &
                    &'/num_mott_orbitals', f_id)
            call gh5_read(wh%fz(i)%nelect,'/IMPURITY_'//trim(int_to_str(i))// &
                    &'/num_mott_electrons', f_id)
            if(wh%fz(i)%nsorb>0)then
                allocate(wh%fz(i)%idx_orb(wh%fz(i)%nsorb))
                call gh5_read(wh%fz(i)%idx_orb,wh%fz(i)%nsorb, &
                        &'/IMPURITY_'//trim(int_to_str(i))//&
                        &'/mott_orbital_indices', f_id)
            endif
        enddo
    endif
    return

    end subroutine set_mott_localized_orbitals

    !*************************************************************************
    subroutine output_mott_localized_orbitals(io)
    integer,intent(in)::io

    integer i

    if(io<0)return
    write(io,'(" mott localized orbital info:")')
    do i=1,wh%num_imp
        write(io,'(" i=",i3," nsorb=",i2," nelect=",i2)')i, &
                &wh%fz(i)%nsorb,wh%fz(i)%nelect
        if(wh%fz(i)%nsorb>0)then
            write(io,'("    idx_orb=",14i3)')wh%fz(i)%idx_orb
        endif
    enddo
    return

    end subroutine output_mott_localized_orbitals

    !*************************************************************************
    subroutine modify_r_la1_frozen(mode,val)
    integer,intent(in)::mode
    real(q),intent(in)::val

    integer i,j,j_

    do i=1,wh%num_imp
        do j=1,wh%fz(i)%nsorb
            j_=wh%fz(i)%idx_orb(j)
            wh%co(i)%r(j_,:)=0
            wh%co(i)%la1(j_,:)=0; wh%co(i)%la1(:,j_)=0
            if(mode>0)then
                wh%co(i)%la1(j_,j_)=val
            endif
        enddo
    enddo
    return

    end subroutine modify_r_la1_frozen

    !*************************************************************************
    !< post processing: print and symmetizations.
    !*************************************************************************
    subroutine calc_nks_pp(io,lchk)
    integer,intent(in)::io
    logical,optional,intent(in)::lchk

    real(q) maxerr

    if(io>0)then
        call output_matrices('nks-unsym',wh%nks,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
    endif
    wh%copy=wh%nks
    call symm_dm_across_atoms(wh%nks)
    ! Get expansion coefficients only
    call hm_expand_all_herm(wh%nks,wh%nks_coef,wh%hm_l,1,.true.)
    ! Symmetrization (note non-zero diagonals)
    call hm_expand_all_sym(wh%nks,wh%hm,.true.,.true.)
    maxerr=maxval(abs(wh%nks-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices('nks-sym',wh%nks,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
        write(io,'(" max error due to symmetrization = ",f12.6)') maxerr
    endif
    call chk_eigens_matrix_list('nks',wh%nks,wh%na2112,wh%num_imp, &
            &wh%na2_imp,io,0)
    call calc_nks_tot(io)
    if(.not.present(lchk))then
        call chk_nks_tiny()
    endif
    return

    end subroutine calc_nks_pp

    subroutine symm_dm_across_atoms(dm)
    complex(q),intent(inout)::dm(wh%na2112)

    integer i,j,isum,nbase,na22
    complex(q) dms(wh%na2max*wh%na2max)

    dms=0; isum=0; nbase=0
    do i=1,wh%num_imp
        na22=wh%na2_imp(i)**2
        nbase=nbase+na22
        if(isum==0)then
            dms(1:na22)=dm(nbase-na22+1:nbase)
        else
            dms(1:na22)=dms(1:na22)+dm(nbase-na22+1:nbase)
        endif
        isum=isum+1
        if(i<wh%num_imp)then
            if(wh%imap_imp(i)==wh%imap_imp(i+1))cycle
        endif
        if(isum>1)then
            dms=dms/isum
            do j=1,isum
                dm(nbase-j*na22+1:nbase-(j-1)*na22)=dms(1:na22)
            enddo
        endif
        isum=0; dms=0
    enddo

    end subroutine symm_dm_across_atoms

    subroutine calc_nks_tot(io)
    integer,intent(in)::io

    integer i
    real(q) res

    do i=1,wh%num_imp
        if(wh%ispin_in==1)then
            ! case of lda
            res = trace_a(wh%co(i)%nks,wh%co(i)%dim2)
            wh%co(i)%net=res/2
        else
            ! case of lsda
            call calc_co_net(wh%co(i))
        endif
    enddo
    if(io>0)then
        write(io,'(" nele_loc total:")')
        write(io,'(4x,2(2f10.5,3x))')(wh%co(i)%net,i=1,wh%num_imp)
    endif
    return

    end subroutine calc_nks_tot

    subroutine calc_ncvar_pp(io)
    integer,intent(in)::io

    real(q) maxerr

    if(io>0)then
        call output_matrices('ncv-unsym',wh%nc_var,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
    endif
    wh%copy=wh%nc_var
    ! Get expansion coefficients only
    call hm_expand_all_herm(wh%nc_var,wh%ncv_coef,wh%hm_l,1,.true.)
    ! Symmetrization (note non-zero diagonals)
    call hm_expand_all_sym(wh%nc_var,wh%hm,.true.,.true.)
    maxerr=maxval(abs(wh%nc_var-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices('ncv-sym',wh%nc_var,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
        write(io,'(" max error due to symmetrization = ",f12.6)')maxerr
    endif
    return

    end subroutine calc_ncvar_pp

    subroutine chk_nks_tiny()
    integer i,i1
    real(q) res

    do i=1,wh%num_imp
        do i1=1,wh%co(i)%dim2
            res=real(wh%co(i)%nks(i1,i1),q)
            if(res<small)then
                write(0,'(" warning in chk_nks_tiny: too small diagonal &
                        &elements",2f16.5)')wh%co(i)%nks(i1,i1)
            endif
            wh%co(i)%nks(i1,i1)=max(real(wh%co(i)%nks(i1,i1),q),small)
        enddo
    enddo
    return

    end subroutine chk_nks_tiny

    subroutine calc_ncphy_pp(io)
    integer,intent(in)::io

    integer i
    real(q) maxerr

    if(io>0)then
        call output_matrices('ncp-unsym',wh%nc_phy,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
    endif
    wh%copy=wh%nc_phy
    call hm_expand_all_sym(wh%nc_phy,wh%hm,.true.,.true.)
    maxerr=maxval(abs(wh%nc_phy-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices('ncp-sym',wh%nc_phy,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
        write(io,'(" max error due to symmetrization = ",f12.6)')maxerr
    endif
    call renorm_ncphy(io)
    if(io>0)then
        call output_matrices('ncp-renorm',wh%nc_phy,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,1)
    endif
    return

    end subroutine calc_ncphy_pp

    ! for wh%h1e, etc.
    subroutine calc_herm_matrices_pp(matrices,sname,mb,ltrans,io,mode)
    complex(q),intent(inout)::matrices(wh%na2112)
    character,intent(in)::sname*3
    type(matrix_basis),intent(in)::mb
    logical,intent(in)::ltrans
    integer,intent(in)::io,mode

    real(q) maxerr

    if(io>0)then
        call output_matrices(sname//'-unsym',matrices,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,mode)
    endif
    wh%copy=matrices
    call symm_dm_across_atoms(matrices)
    call hm_expand_all_sym(matrices,mb,ltrans,.true.)
    maxerr=maxval(abs(matrices-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices(sname//'-sym',matrices,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,mode)
        write(io,'(" max error due to symmetrization = ",f12.6)')maxerr
    endif
    return

    end subroutine calc_herm_matrices_pp

    subroutine calc_r01_pp(io)
    integer,intent(in)::io

    integer i

    ! r0 -> r
    forall(i=1:wh%num_imp)wh%co(i)%r=matmul(transpose(wh%co(i)%isimix), &
            &wh%co(i)%r0)

    if(io>0)then
        call output_matrices('r0-out',wh%r0,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif

    call  calc_r_pp(io,'r-out')

    ! r-> z=r^\dagger r
    do i=1,wh%num_imp
        call annxb('c',wh%co(i)%r,wh%co(i)%r,wh%co(i)%z, &
                &wh%na2_imp(i),wh%na2_imp(i))
    enddo

    if(io>0)then
        call output_matrices('z-out-sym',wh%z,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif

    call chk_eigens_matrix_list('z',wh%z,wh%na2112,wh%num_imp, &
            &wh%na2_imp,io,0)
    return

    end subroutine calc_r01_pp

    subroutine calc_r_pp(io,sname)
    integer,intent(in)::io
    character,intent(in)::sname*5

    integer i
    real(q) maxerr

    if(io>0)then
        call output_matrices(sname,wh%r,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif
    wh%copy=wh%r
    call hm_expand_all_general(wh%r,wh%r_coef,wh%hm_r,0,.false.)
    maxerr=maxval(abs(wh%r-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices(sname//'-sym',wh%r,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
        write(io,'(" max error due to symmetrization = ",f12.6)')maxerr
    endif
    return

    end subroutine calc_r_pp

    subroutine calc_la1_pp(io,sname)
    integer,intent(in)::io
    character,intent(in)::sname*7

    integer i
    real(q) maxerr

    if(io>0)then
        call output_matrices(sname,wh%la1,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif
    wh%copy=wh%la1
    call hm_expand_all_herm(wh%la1,wh%la1_coef,wh%hm_l,0,.false.)
    maxerr=maxval(abs(wh%la1-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices(sname//'-sym',wh%la1,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
        write(io,'(" max error due to symmetrization = ",f12.6)')maxerr
    endif
    return

    end subroutine calc_la1_pp

    subroutine calc_lambdac(io)
    integer,intent(in) :: io

    integer i

    do i=1,wh%num_imp
        call calc_co_lambdac(wh%co(i))
    enddo

    if(io>0)then
        call output_matrices('la2',wh%la2,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif
    return

    end subroutine calc_lambdac

    !*************************************************************************
    subroutine calc_da0_pp(io)
    integer,intent(in)::io

    integer i
    real(q) maxerr

    if(io>0)then
        call output_matrices('d0-unsym',wh%d0,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
    endif
    wh%copy=wh%d0
    call symm_dm_across_atoms(wh%d0)
    call hm_expand_all_sym(wh%d0,wh%hm_r,.false.,.false.)
    maxerr=maxval(abs(wh%d0-wh%copy))
    wh%symerr=max(wh%symerr,maxerr)
    if(io>0)then
        call output_matrices('d0-sym',wh%d0,wh%na2112,wh%num_imp, &
                &wh%na2_imp,io,0)
        write(io,'(" max error due to symmetrization = ",f12.6)')maxerr
    endif
    return

    end subroutine calc_da0_pp

    !*************************************************************************
    subroutine calc_da(io)
    integer,intent(in)::io

    call calc_da0_pp(io)
    call d0_to_d()
    if(io>0)then
       call output_matrices('d-sym',wh%d,wh%na2112,wh%num_imp, &
            &wh%na2_imp,io,0)
    endif
    return

    end subroutine calc_da

    !*************************************************************************
    !< mode>0: get c; mode<0: get a; mode=0: symmetrization (get c then a)
    !*************************************************************************
    subroutine hm_expand_all_herm(a,c,mb,mode,ltrans)
    type(matrix_basis),intent(in)::mb
    complex(q),target,intent(inout)::a(wh%na2112)
    real(q),intent(inout)::c(mb%dimhst)
    integer,intent(in)::mode
    logical,intent(in)::ltrans

    integer i,ibase,imap,abase,hsbase,dim_hs,na2,na22,ibase_list(wh%num_imp)
    complex(q),pointer::p_a(:,:),p_hs(:,:,:)
    complex(q) c1(mb%dimhsmax)

    ibase=0
    abase=0
    hsbase=0
    do i=1,wh%num_imp
        na2=wh%na2_imp(i)
        na22=na2**2
        dim_hs=mb%dim_hs(i)
        imap=wh%imap_imp(i)
        if(imap==i)then
            ibase_list(i)=ibase
        else
            ibase_list(i)=ibase_list(imap)
        endif
        p_a(1:na2,1:na2)=>a(abase+1:abase+na22)
        if(dim_hs>0)then
            p_hs(1:na2,1:na2,1:dim_hs)=>mb%hs(hsbase+1:hsbase+na22*dim_hs)
            if(mode<=0)then
                c1(1:dim_hs)=c(ibase_list(i)+1:ibase_list(i)+dim_hs)
            endif
            call get_hm_expand(p_a,p_hs,na2,dim_hs,c1(1:dim_hs), &
                    &mode,ltrans,.true.)
            if(imap==i)then
                if(mode>=0)then
                    c(ibase+1:ibase+dim_hs)=c1(1:dim_hs)
                endif
                ibase=ibase+dim_hs
            endif
        endif
        abase=abase+na22
        hsbase=hsbase+na22*dim_hs
    enddo
    return

    end subroutine hm_expand_all_herm

    subroutine hm_expand_all_general(a,c,mb,mode,ltrans)
    type(matrix_basis),intent(in)::mb
    complex(q),target,intent(inout)::a(wh%na2112)
    complex(q),intent(inout)::c(mb%dimhst)
    integer,intent(in)::mode
    logical,intent(in)::ltrans

    integer i,imap,ibase,abase,hsbase,nbase,dim_hs,na2,na22
    complex(q),pointer::p_a(:,:),p_hs(:,:,:)

    ibase=0
    abase=0
    hsbase=0
    do i=1,wh%num_imp
        na2=wh%na2_imp(i)
        na22=na2**2
        dim_hs=mb%dim_hs(i)
        if(dim_hs>0)then
            p_a(1:na2,1:na2)=>a(abase+1:abase+na22)
            p_hs(1:na2,1:na2,1:dim_hs)=>mb%hs(hsbase+1:hsbase+na22*dim_hs)
            imap=wh%imap_imp(i)
            if(imap==i)then
                call get_hm_expand(p_a,p_hs,na2,dim_hs, &
                        &c(ibase+1:ibase+dim_hs),mode,ltrans,.false.)
                ibase=ibase+dim_hs
            elseif(mode<=0)then
                nbase=sum(wh%na2_imp(1:imap-1)**2)
                a(abase+1:abase+na22)=a(nbase+1:nbase+na22)
            endif
        elseif(mode<0)then
            a(abase+1:abase+na22)=0
        endif
        abase=abase+na22
        hsbase=hsbase+na22*dim_hs
    enddo
    return

    end subroutine hm_expand_all_general

    subroutine hm_expand_all_sym(a,mb,ltrans,lherm)
    complex(q),target,intent(inout)::a(wh%na2112)
    type(matrix_basis),intent(in)::mb
    logical,intent(in)::ltrans,lherm

    integer i,abase,hsbase,dim_hs,na2,na22
    complex(q),pointer::p_a(:,:),p_hs(:,:,:)

    abase=0
    hsbase=0
    do i=1,wh%num_imp
        na2=wh%na2_imp(i)
        na22=na2**2
        dim_hs=mb%dim_hs(i)
        if(dim_hs>0)then
            p_a(1:na2,1:na2)=>a(abase+1:abase+na22)
            p_hs(1:na2,1:na2,1:dim_hs)=>mb%hs(hsbase+1:hsbase+na22*dim_hs)
            call get_hm_expand(p_a,p_hs,na2,dim_hs,ltrans,lherm)
        endif
        abase=abase+na22
        hsbase=hsbase+na22*dim_hs
    enddo
    return

    end subroutine hm_expand_all_sym

    !*************************************************************************
    ! renormalize nc_phy
    !*************************************************************************
    subroutine renorm_ncphy(io)
    integer,intent(in)::io

    integer i
    real(q) sum_ks,sum_phy,sum_var

    do i=1,wh%num_imp
        sum_ks =trace_a(wh%co(i)%nks   , wh%co(i)%dim2)
        sum_phy=trace_a(wh%co(i)%nc_phy, wh%co(i)%dim2)
        sum_var=trace_a(wh%co(i)%nc_var, wh%co(i)%dim2)
        if(io>0)then
            write(io,'(" imp=",i3," sum_phy-sum_var=",f16.8)') &
                    &i,sum_phy-sum_var
            write(io,'(7x       ," sum_phy-sum_ks =",f16.8, &
                    &" would be renormalized!")')sum_phy-sum_ks
        endif
        if(sum_phy<1.e-16_q)then
            wh%co(i)%nc_phy = 0._q
        else
            wh%co(i)%nc_phy=wh%co(i)%nc_phy/sum_phy*sum_ks ! renormalized
        endif
    enddo
    return

    end subroutine renorm_ncphy

    !*************************************************************************
    subroutine d0_to_d()
    integer i

    do i=1,wh%num_imp
        call co_d0_to_d(wh%co(i))
    enddo
    return

    end subroutine d0_to_d

    subroutine gh5_create_impurity_groups(fid)
    integer(hid_t),intent(in)::fid

    integer i

    if(fid<0)return
    do i = 1, wh%num_imp
        call gh5_create_group("/IMPURITY_"//trim(int_to_str(i)),f_id)
    enddo
    return

    end subroutine gh5_create_impurity_groups

    subroutine calc_et1_list()
    integer i

    do i=1,wh%num_imp
        wh%et1(i)=sum(wh%co(i)%h1e*wh%co(i)%nc_phy)
    enddo
    return

    end subroutine calc_et1_list

    subroutine calc_eu2_hf_list()
    integer i

    do i=1,wh%num_imp
        call calc_co_eu2_hf(wh%co(i), wh%eu2(i))
    enddo
    return

    end subroutine calc_eu2_hf_list

    subroutine output_energies_wh(io)
    integer,intent(in)::io

    integer i

    write(io,'(" impurity-wise interaction energy:")')
    write(io,'(4x,5f12.5)')(wh%eu2(i), i=1,wh%num_imp)
    write(io,'(" total impurity interaction energy = ",f0.7)') &
            &sum(wh%eu2)
    write(io,'(" impurity-wise one-body part energy:")')
    write(io,'(4x,5f12.5)')(wh%et1(i), i=1,wh%num_imp)
    write(io,'(" total impurity one-body part energy = ",f0.7)') &
            &sum(wh%et1)
    write(io,'(" total lambda-dc energy = ",f0.7)') wh%edcla1
    return

    end subroutine output_energies_wh

end module warehouse


MODULE shared_data
!
!  Purpose:
!    To declare data to share between two routines.

IMPLICIT NONE
SAVE

INTEGER, PARAMETER :: num_vals = 5       ! Max number of values in array
REAL, DIMENSION(num_vals) :: values      ! Data values

END MODULE shared_data


Subroutine pythia
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Save /lujets/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Common /pysubs/msel, msub(200), kfin(2, -40:40), ckin(200)
  Save /pysubs/
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Save /pypars/
  Common /pyint1/mint(400), vint(400)
  Save /pyint1/
  Common /pyint2/iset(200), kfpr(200, 2), coef(200, 20), icol(40, 4, 2)
  Save /pyint2/
  Common /pyint5/ngen(0:200, 3), xsec(0:200, 3)
  Save /pyint5/
  mint(7) = 0
  mint(8) = 0
  novl = 1
  If (mstp(131)/=0) Call pyovly(2)
  If (mstp(131)/=0) novl = mint(81)
  mint(83) = 0
  mint(84) = mstp(126)
  mstu(70) = 0
  Do iovl = 1, novl
    If (mint(84)+100>=mstu(4)) Then
      Call luerrm(11, '(PYTHIA:) no more space in LUJETS for overlayed events')
      If (mstu(21)>=1) Goto 200
    End If
    mint(82) = iovl
    100 Continue
    If (iovl==1) ngen(0, 2) = ngen(0, 2) + 1
    mint(31) = 0
    mint(51) = 0
    Call pyrand
    isub = mint(1)
    If (iovl==1) Then
      ngen(isub, 2) = ngen(isub, 2) + 1
      Do j = 1, 200
        msti(j) = 0
        pari(j) = 0.
      End Do
      msti(1) = mint(1)
      msti(2) = mint(2)
      msti(11) = mint(11)
      msti(12) = mint(12)
      msti(15) = mint(15)
      msti(16) = mint(16)
      msti(17) = mint(17)
      msti(18) = mint(18)
      pari(11) = vint(1)
      pari(12) = vint(2)
      If (isub/=95) Then
        Do j = 13, 22
          pari(j) = vint(30+j)
        End Do
        pari(33) = vint(41)
        pari(34) = vint(42)
        pari(35) = pari(33) - pari(34)
        pari(36) = vint(21)
        pari(37) = vint(22)
        pari(38) = vint(26)
        pari(41) = vint(23)
      End If
    End If
    If (mstp(111)==-1) Goto 160
    If (isub<=90 .Or. isub>=95) Then
      Call pyscat
      If (mint(51)==1) Goto 100
      ipu1 = mint(84) + 1
      ipu2 = mint(84) + 2
      If (mstp(61)>=1 .And. mint(43)/=1 .And. isub/=95) Call pysspa(ipu1, ipu2)
      nsav1 = n
      If (mstp(81)>=1 .And. mint(43)==4 .And. isub/=95) Call pymult(6)
      mint(1) = isub
      nsav2 = n
      Call pyremn(ipu1, ipu2)
      If (mint(51)==1) Goto 100
      nsav3 = n
      ipu3 = mint(84) + 3
      ipu4 = mint(84) + 4
      If (mstp(71)>=1 .And. isub/=95 .And. k(ipu3,1)>0 .And. k(ipu3,1)<=10 .And. k(ipu4,1)>0 .And. k(ipu4,1)<=10) Then
        qmax = sqrt(parp(71)*vint(52))
        If (isub==5) qmax = sqrt(pmas(23,1)**2)
        If (isub==8) qmax = sqrt(pmas(24,1)**2)
        Call lushow(ipu3, ipu4, qmax)
      End If
      If (iovl==1) Then
        pari(65) = 2.*pari(17)
        Do i = mstp(126) + 1, n
          If (k(i,1)<=0 .Or. k(i,1)>10) Goto 130
          pt = sqrt(p(i,1)**2+p(i,2)**2)
          pari(69) = pari(69) + pt
          If (i<=nsav1 .Or. i>nsav3) pari(66) = pari(66) + pt
          If (i>nsav1 .And. i<=nsav2) pari(68) = pari(68) + pt
        130 End Do
        pari(67) = pari(68)
        pari(71) = vint(151)
        pari(72) = vint(152)
        pari(73) = vint(151)
        pari(74) = vint(152)
      End If
      If (mstp(41)>=1 .And. isub/=95) Call pyresd
    Else
      Call pydiff
      If (iovl==1) Then
        pari(65) = 2.*pari(17)
        pari(66) = pari(65)
        pari(69) = pari(65)
      End If
    End If
    If (mstp(113)>=1) Then
      Do i = mint(83) + 1, n
        If (k(i,1)>0 .And. k(i,1)<=10) p(i, 4) = sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
      End Do
    End If
    mstu(28) = 0
    Call luprep(mint(84)+1)
    If (mstp(112)==1 .And. mstu(28)==3) Goto 100
    If (mstp(125)==0 .Or. mstp(125)==1) Then
      Do i = mint(84) + 1, n
        If (k(i,2)/=94) Goto 150
        k(i+1, 3) = mod(k(i+1,4)/mstu(5), mstu(5))
        k(i+2, 3) = mod(k(i+2,4)/mstu(5), mstu(5))
      150 End Do
      Call luedit(12)
      Call luedit(14)
      If (mstp(125)==0) Call luedit(15)
      If (mstp(125)==0) mint(4) = 0
    End If
    If (iovl==1 .And. mstp(125)<=0) Then
      mstu(70) = 1
      mstu(71) = n
    Else If (iovl==1) Then
      mstu(70) = 3
      mstu(71) = 2
      mstu(72) = mint(4)
      mstu(73) = n
    End If
    If (mstp(111)>=1) Call luexec
    If (mstp(125)==0 .Or. mstp(125)==1) Call luedit(14)
    160 If (iovl==1) Then
      If (mstp(111)/=-1) ngen(isub, 3) = ngen(isub, 3) + 1
      ngen(0, 3) = ngen(0, 3) + 1
      xsec(0, 3) = 0.
      Do i = 1, 200
        If (i==96) Then
          xsec(i, 3) = 0.
        Else If (msub(95)==1 .And. (i==11 .Or. i==12 .Or. i==13 .Or. i==28 .Or. i==53 .Or. i==68)) Then
          xsec(i, 3) = xsec(96, 2)*ngen(i, 3)/max(1., float(ngen(96,1))*float(ngen(96,2)))
        Else If (ngen(i,1)==0) Then
          xsec(i, 3) = 0.
        Else If (ngen(i,2)==0) Then
          xsec(i, 3) = xsec(i, 2)*ngen(0, 3)/(float(ngen(i,1))*float(ngen(0,2)))
        Else
          xsec(i, 3) = xsec(i, 2)*ngen(i, 3)/(float(ngen(i,1))*float(ngen(i,2)))
        End If
        xsec(0, 3) = xsec(0, 3) + xsec(i, 3)
      End Do
      If (msub(95)==1) Then
        ngens = ngen(91, 3) + ngen(92, 3) + ngen(93, 3) + ngen(94, 3) + ngen(95, 3)
        xsecs = xsec(91, 3) + xsec(92, 3) + xsec(93, 3) + xsec(94, 3) + xsec(95, 3)
        xmaxs = xsec(95, 1)
        If (msub(91)==1) xmaxs = xmaxs + xsec(91, 1)
        If (msub(92)==1) xmaxs = xmaxs + xsec(92, 1)
        If (msub(93)==1) xmaxs = xmaxs + xsec(93, 1)
        If (msub(94)==1) xmaxs = xmaxs + xsec(94, 1)
        fac = 1.
        If (ngens<ngen(0,3)) fac = (xmaxs-xsecs)/(xsec(0,3)-xsecs)
        xsec(11, 3) = fac*xsec(11, 3)
        xsec(12, 3) = fac*xsec(12, 3)
        xsec(13, 3) = fac*xsec(13, 3)
        xsec(28, 3) = fac*xsec(28, 3)
        xsec(53, 3) = fac*xsec(53, 3)
        xsec(68, 3) = fac*xsec(68, 3)
        xsec(0, 3) = xsec(91, 3) + xsec(92, 3) + xsec(93, 3) + xsec(94, 3) + xsec(95, 1)
      End If
      mint(5) = mint(5) + 1
      msti(3) = mint(3)
      msti(4) = mint(4)
      msti(5) = mint(5)
      msti(6) = mint(6)
      msti(7) = mint(7)
      msti(8) = mint(8)
      msti(13) = mint(13)
      msti(14) = mint(14)
      msti(21) = mint(21)
      msti(22) = mint(22)
      msti(23) = mint(23)
      msti(24) = mint(24)
      msti(25) = mint(25)
      msti(26) = mint(26)
      msti(31) = mint(31)
      pari(1) = xsec(0, 3)
      pari(2) = xsec(0, 3)/mint(5)
      pari(31) = vint(141)
      pari(32) = vint(142)
      If (isub/=95 .And. mint(7)*mint(8)/=0) Then
        pari(42) = 2.*vint(47)/vint(1)
        Do is = 7, 8
          pari(36+is) = p(mint(is), 3)/vint(1)
          pari(38+is) = p(mint(is), 4)/vint(1)
          i = mint(is)
          pr = max(1E-20, p(i,5)**2+p(i,1)**2+p(i,2)**2)
          pari(40+is) = sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),1E20)), p(i,3))
          pr = max(1E-20, p(i,1)**2+p(i,2)**2)
          pari(42+is) = sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),1E20)), p(i,3))
          pari(44+is) = p(i, 3)/sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
          pari(46+is) = ulangl(p(i,3), sqrt(p(i,1)**2+p(i,2)**2))
          pari(48+is) = ulangl(p(i,1), p(i,2))
        End Do
      End If
      pari(61) = vint(148)
      If (iset(isub)==1 .Or. iset(isub)==3) Then
        mstu(161) = mint(21)
        mstu(162) = 0
      Else
        mstu(161) = mint(21)
        mstu(162) = mint(22)
      End If
    End If
    msti(41) = iovl
    If (iovl>=2 .And. iovl<=10) msti(40+iovl) = isub
    If (mstu(70)<10) Then
      mstu(70) = mstu(70) + 1
      mstu(70+mstu(70)) = n
    End If
    mint(83) = n
    mint(84) = n + mstp(126)
  End Do
  If (mstp(131)==1 .And. mstp(133)>=1) Then
    pari(91) = vint(132)
    pari(92) = vint(133)
    pari(93) = vint(134)
    If (mstp(133)==2) pari(93) = pari(93)*xsec(0, 3)/vint(131)
  End If
  200 Call pyfram(mstp(124))
  Return
End Subroutine pythia