*//////////////////////////////////////////////////////////////////*
      SUBROUTINE Dhfci3(NSH,IOS,Ipc,NA,NB,NX,KD,NL,Lin,
     *       Mi3,Mr,NT, MLN,LK,LC,
     *       ZF,EI,HA,HB,AS,AD,RZ,RZ2,RZ3,
     *       AMC,AMS,AMP,PHA, AHF,BHF, AA,BB,VV,UU,WW,GG,B,BZ,
     *       R,X,XC,CN,CX,WC,DD,CX1, PQV,PP,QQ,Z,XT,PT,QX,Wep,Wrk)
*  -  -------------------------------------------------------------*
      IMPLICIT    REAL*8 (A-H,O-Z)
      DIMENSION   MLN(3,*),LK(*),LC(*), AMC(NX,*),AMS(NX,*),
     *        AMP(NX,*),PHA(NX,*),AHF(NX),BHF(NX),
     *        AA(NA,*),BB(NA,*),VV(NA,*),UU(NA,*),WW(NA,*),
     *      GG(2,*),B(4),BZ(3), R(NB,*),X(NB,*),XC(NB,*), CN(*),
     *        CX(NA,*),WC(NA,NA),DD(NX,NX),CX1(NX),
     *        PQV(NB,*),PP(NB,NX,NX),QQ(NB,NX),
     *        Z(NB,*),XT(NT,*),PT(*),
     *        F(99),CNC(50),CU(5000),AM0(50),RT(4000),D(500),
     *        CXI(500),CXJ(500),    QQC(50000),WK(50000)
     *        ,AXP(20),   R8(2000),  QX(NB,NX,*),
     *      Wep(NB,NX,*), Wrk(NB,NX,*)
* === =============================================================*
c         write(10,*) ' mi3 1',Mi3
      MD=MLN(1,NSH)-MLN(1,IOS)
      M=MLN(1,NSH)
      L0=MLN(2,NSH)
      B(1)=1.D+00
      C=12.D 00/HB**2
      PI2=-2.D 00*3.14159D 00
      EPS=1.D-05
      Z0=0.D 00
       MII=0
      CALL VEQC(20,0.D 00,AXP)
      CALL VEQC(NB*NX*NX,Z0,PP)
      CALL VEQC(NB*NX*2,Z0,QQ)
      CALL VEQC(NX*NX,Z0,DD)
      CALL VEQC(NX,Z0,CXJ)
         CR8=RZ*DSQRT(3.14159265D 00/3.D00)
         DO 1 I=1,NB
    1       R8(I)=CR8*R(I,1)*R(I,6)
c    1       R8(I)=CR8*DSQRT(R(I,2)-1.D 00)*R(I,6)
        LM=MLN(2,NSH)
        NZ=NX+4
        ERJ=0.D 00
        IHF=0
      CALL MASH(NB,M,L0,NX,KD,98,AS,AD,PQV,R,F,DD,PP)
       C1=PI2*RZ2
      DO 5 JI=1,NSH
c         write(*,*) ' dir is= ',JI
C         IF(JI.EQ.ISH) GOTO 5
        IF(DABS(AHF(JI)).LT.1.D-03) GOTO 5
      NLI=LK(JI)
         C4=-RZ2*AHF(JI)/CN(JI)
         II=LK(JI)
          M1=MLN(1,JI)
          LD1=MLN(2,JI)
C*         CALL ZIJK(NA,NB,NX,NX,NZ,M1,M1,LD1,LD1,0,KD,C1,C,BZ,
C*     *     R(1,2),F,X(1,II),X(1,II),GG,B,AA,BB,VV,UU,WW,WC,
C*     *     CX,PQV,Z)
         CALL ZIJK(NA,NB,NX,NX,NZ,M1,M1,LD1,LD1,0,KD,C1,C,BZ,
     *     R(1,2),F,XC(1,II),XC(1,II),GG,B,AA,BB,VV,UU,WW,WC,
     *     CX,PQV,Z)
         DO 10 I=1,NX
            L1=KD*(I-1)+LM
            DO 15 I1=1,NX
               K=KD*(I1-1)+LM
               CALL SUMA(NB,NZ,0,M,KD,0,K,L1,
     *                 C4,R(1,2),Z,F,PQV(1,6),PQV(1,2))
               DO 20 J=1,NB
   20           PP(J,I1,I)=PP(J,I1,I)+R(J,3)*R(J,6)*PQV(J,2)
   15          CONTINUE
   10       CONTINUE
    5    CONTINUE
*      CALL VEVR(NB*NX*NX,PP,PPH)
*  300 IF(IHF.EQ.0) GOTO 302
*      CALL VEVR(NB*NX*NX,PPH,PP)
  300   CALL VEQC(NB*NX,0.D 00,QQ)
  302   WRITE(*,*) IHF

      Job=0
c02      DO 205 LL0=1,NL
      DO 205 LLi=Lin+1,NL
        LL0=LLi
c         write(10,*) ' mi3 2',Mi3
        IF(Mi3.NE.0) LL0=Mi3-(LLi-1)
c         write(10,*) ' mi3,LL0',Mi3,LL0
*         IF(LL0.EQ.1) GOTO 301
         JHF=0
         MII=0
       CALL VEQC(NX,0.D 00,AM0)
       AM0(LL0)=1.D 00
  303     CALL VEQC(NB*NX,0.D 00,QQ)

       M=MLN(1,NSH)
*      NLI=NLQ(6,ISH)
      NLI=LK(NSH)
      DO 25 JI=1,NSH
c         write(*,*) ' exch is= ',JI
         IF(DABS(BHF(JI)).LT.1.D-03) GOTO 26
C         IF(DABS(BHF(JI)).LT.1.D-03) GOTO 25
*         IF(DABS(CN(JI)).LT.1.D-03) GOTO 25
  507     FORMAT(' FCM,=',5I5)
         C4=RZ2*BHF(JI)/CN(JI)
C         IF(JI.EQ.ISH) C4=C4/CN(JI)
         II=LK(JI)
         M2=MLN(1,JI)
C         LM1=MLN(2,JI)
C         MS=IABS(M-M2)
C         MS1=MS+1
C         LD2=LM+LM1

         II1=LC(LL0)
* * *  ** * * * * * * * * * * *
         LM1=MLN(2,JI)
         MS=IABS(M-M2)
         MS1=MS+1
c         LD2=LM+LM1
         LD2=IABS(LM-LM1)
C         IF(JI.EQ.ISH) LD2=0
         IF(LD2.LT.MS) LD2=LD2+2

***************************************
   26   IF(M2.GT.0.AND.M.GT.0.AND.DABS(CN(JI)).GT.1.D-06)  THEN
**   26   IF(M2.GT.0.AND.DABS(CN(JI)).GT.1.D-06)  THEN
          MS3=M+M2+1
**          LMZ=M+M2
          LMZ=IABS(LM-LM1)
          M3=M+M2
          IF(LMZ.LT.M3) LMZ=LMZ+2
c       write(*,*) 'zijk_beg'
c       pause
        CALL ZIJK(NA,NB,NX,NX,NX,M,-M2,LM,LM1,LMZ,KD,-C1,C,bz,
     *    R(1,2),F,X(1,II1),XC(1,II),GG(1,MS3),B,AA(1,MS3),
     *       BB(1,MS3),VV(1,MS3),UU,WW,WC,CX,PQV,Z)
c       write(*,*) 'zijk_end'
c       pause
       CC4=RZ2/CN(JI)
         DO 80 I=1,NX
            L1=LM+KD*(I-1)
            DO 85 I1=1,NX
               K=LM1+KD*(I1-1)
                CALL SUMA(NB,NX,M3,-M2,KD,LMZ,K,L1,
     *                 CC4,R(1,2),Z,F,PQV(1,6),PQV(1,2))
                I2=LK(JI)+I1-1
             DO 90  J=1,NB
   90           QQ(J,I)=QQ(J,I)-R(J,3)*R(J,6)*PQV(J,2)*XC(J,I2)
C*   90           QQ(J,I)=QQ(J,I)-R(J,3)*R(J,6)*PQV(J,2)*X(J,I2)
C   90           PP(J,I1,I)=PP(J,I1,I)+R(J,3)*R(J,6)*PQV(J,2)
   85          CONTINUE
   80       CONTINUE
c       write(*,*) 'QQ_end1'
c       pause
           END IF
         IF(DABS(BHF(JI)).LT.1.D-03) GOTO 25
**************************************
C         MSS=-MS
C         IF(M2.EQ.0) MSS=MS
          MSS=M-M2
       write(*,*) 'zij_QQ_beg'
c       pause
         CALL ZIJK(NA,NB,NX,NX,NZ,M,M2,LM,LM1,LD2,KD,C1,C,BZ,
     *     R(1,2),F,X(1,II1),XC(1,II),GG(1,MS1),B,AA(1,MS1),
     *     BB(1,MS1),VV(1,MS1),UU,WW,WC,CX,PQV,Z)
       write(*,*) 'zij_QQ_end'
c       pause
         DO 30 I=1,NX
            L1=LM+KD*(I-1)
            DO 35 I1=1,NX
               K=LM1+KD*(I1-1)
               CALL SUMA(NB,NZ,MSS,M2,KD,LD2,K,L1,
     *                 C4,R(1,2),Z,F,PQV(1,6),PQV(1,2))
               IF(JI.EQ.NSH) THEN
                DO 40 J=1,NB
   40           PP(J,I1,I)=PP(J,I1,I)+R(J,3)*R(J,6)*PQV(J,2)
                GOTO 35
                END IF
*               I2=NLQ(6,JI)+I1-1
               I2=LK(JI)+I1-1
               DO 45 J=1,NB
   45           QQ(J,I)=QQ(J,I)-R(J,3)*R(J,6)*PQV(J,2)*XC(J,I2)
C*   45           QQ(J,I)=QQ(J,I)-R(J,3)*R(J,6)*PQV(J,2)*X(J,I2)
   35          CONTINUE
   30       CONTINUE
c       write(*,*) 'QQ_end'
c       pause
   25    CONTINUE
C*        WRITE(*,800) ISH
  800   FORMAT( 'ISH=',2I3)
         MC=IABS(M+1)
c01       WRITE(*,*) KD,M,L0
c       pause

c      WRITE(10,*) ' AMC=',MII
c      DO 61 JI=1,3
c        write(10,514) (Amc(ix,JI),IX=1,nx)
c   61   CONTINUE

      IF(Ipc.EQ.0) THEN
        CALL Ofdpf(NSH-1,NA,NB,NX,KD, IOS, MLN,MLN(1,NSH),LK,
     *                HA,HB,RZ2,RZ3,C1,C,
     *                DD,BZ,F,GG,B, AA,BB,VV,UU,WW,WC,CX,
     *              R(1,2),R(1,3),R(1,6),QQC,X,X(1,LC(LL0)),QQ,WK,Z)
C      CALL DESYR(NX,NA,NB,3,JHF, LK,
        ELSE
          CALL Ofprc(NSH-1,NA,NB,NX,KD, IOS, Job,MLN,MLN(1,NSH),LK,
     *                HA,HB,RZ2,RZ3,C1,C,
     *                DD,BZ,F,GG,B, AA,BB,VV,UU,WW,WC,CX,
     *      R(1,2),R(1,3),R(1,6),QQC,X,XC,X(1,LC(LL0)),QQ,WK,Z,Wep,
     *       Wrk(1,1,1),Wrk(1,1,2),Wrk(1,1,3),Wrk(1,1,4))
c02          CALL Ofdpr(NSH-1,NA,NB,NX,KD, IOS, MLN,MLN(1,NSH),LK,
c02     *                HA,HB,RZ2,RZ3,C1,C,
c02     *                DD,BZ,F,GG,B, AA,BB,VV,UU,WW,WC,CX,
c02     *          R(1,2),R(1,3),R(1,6),QQC,X,XC,X(1,LC(LL0)),QQ,WK,Z)
        END IF

       Mij=Mii
c02       IF(Mii.LE.2) Mij=0
c02       IF(Mr.LT.0) Mij=0
       WRITE(*,513) Ei,Mii
  513  FORMAT( ' EE =',E13.4,',   Iteration - ',i3)
c       pause
c         write(10,*) ' mi3,LL0 1',Mi3,LL0

      CALL Desyc3(NX,NA,NB,LL0,Mij, Mr,LK,
     *       EI,C, RZ2,ZF,
     *       AA(1,MC),BB(1,MC),VV(1,MC),UU,WW, DD,GG(1,MC), WC,
     *       AM0,AMC(1,LL0),AMS(1,LL0),AMP(1,LL0),PHA(1,LL0),
     *       GK1,GK2,
     *       CU,CX,CX1,CXI,CNC(LL0), QX,PP,QQ,PQV,R,X(1,LC(LL0)))


c       pause
      IF(Mr.GT.0) MII=Mij
      MII=MII+1

c      WRITE(10,*) ' AMC=',MII
  514  FORMAT( 6E12.3)

      DCX=0.D 00
      SCX=0.D 00
      DAX=0.D 00
      SAX=0.D 00
      DO 60 IX=1,NX
c03         DCX=DCX+DABS(CXI(IX)-CXJ(IX))
c03         SCX=SCX+DABS(CXI(IX)+CXJ(IX))
         DCX=DCX+DABS(CXI(IX)-AM0(IX))
         SCX=SCX+DABS(CXI(IX)+AM0(IX))
         DAX=DAX+DABS(AXP(IX)-AMP(IX,LL0))
         SAX=SAX+DABS(AXP(IX)+AMP(IX,LL0))
         AXP(IX)=AMP(IX,LL0)
   60    CXJ(IX)=CXI(IX)

c      DO 62 JI=1,3
c        write(10,514) (Amc(ix,JI),IX=1,nx)
c   62   CONTINUE

      JHF=1
      IF(DCX/SCX.LT.1.D-06.AND.DAX/SAX.LT.1.D-06) JHF=0
c01        WRITE(*,*) IHF
c01 225     WRITE(*,512)
 512  FORMAT('  JHF= ')


       IF(JHF.NE.0) GOTO 303

       write(10,505) Mii
       WRITE(10,*) CNC(LL0)
  205    CONTINUE

      AS1=RZ*ZF
      Li=1
      IF(Mi3.NE.0) Li=Mi3-NL+1
      CALL Tailn(NB,NT,NX,NL, M,L0,KD, EI,AS1,AD,RZ2 ,ZF,
     *           R, F, PT,QQ,RT,DD,CNC(Li),
     *           AMC(1,Li),AMS(1,Li),AMP(1,Li),PHA(1,Li),  
     *           Z,D,X(1,LC(Li)),XT)
      CALL Orto0(NX,NB,NL,LC(Li),EI,RZ,GK1,GK2,
     *        Amc(1,Li),Ams(1,Li),AMP(1,Li),PHA(1,Li),CNC(Li),X)

      DO 206 LLi=1,NL
        LL0=LLi
        IF(Mi3.NE.0) LL0=Mi3-NL+LLi
        DO 95 JI=1,NSH-1
          CNS=FOVI(NX,NX,NA,NB,HA,HB,RZ3,
     *                      DD,R(1,2),R(1,7),
     *             PQV(1,5),PQV(1,6),X(1,LK(JI)),X(1,LC(LL0)))
          WRITE(10,*) JI,LK(JI),LC(LL0),CNS
   95     CONTINUE
        WRITE(10,500)
  206   CONTINUE

      DO 207 LLi=1,NL
        LL0=LLi
        IF(Mi3.NE.0) LL0=Mi3-NL+LLi
       DO 97 JI=1,NSH-1
          CLB1=FCULD(NA,NB,MLN(1,IOS),MLN(1,NSH),MLN(1,JI),MLN(1,JI),
     *       KD,MD,HA,HB,RZ2,RZ3,C1,C,BZ,F,GG,B,AA,BB,VV,UU,WW,WC,
     *         CX,R(1,2),R(1,3),R8,X(1,LK(IOS)),X(1,LC(LL0)),
     *            X(1,LK(JI)),X(1,LK(JI)),QQC,WK,Z)
c          CLB2=FCULD(NA,NB,MLN(1,NSH),MLN(1,IOS),MLN(1,JI),MLN(1,JI),
c     *       KD,-MD,HA,HB,RZ2,RZ3,C1,C,BZ,F,GG,B,AA,BB,VV,UU,WW,WC,
c     *         CX,R(1,2),R(1,3),R8,X(1,LC(LL0)),X(1,LK(IOS)),
c     *            Xc(1,LK(JI)),Xc(1,LK(JI)),QQC,WK,Z)
          CLB2=FCULD(NA,NB,MLN(1,NSH),MLN(1,IOS),MLN(1,JI),MLN(1,JI),
     *       KD,-MD,HA,HB,RZ2,RZ3,C1,C,BZ,F,GG,B,AA,BB,VV,UU,WW,WC,
     *         CX,R(1,2),R(1,3),R8,X(1,LC(LL0)),X(1,LK(IOS)),
     *            X(1,LK(JI)),X(1,LK(JI)),QQC,WK,Z)
      IF(Ji.EQ.Ios) CLB3= CLB2
      IF(Ji.NE.Ios) CLB3=-CLB2+CLB1
           WRITE(10,805) JI,CLB1,CLB2,CLB3
          CLB1=FCULD(NA,NB,MLN(1,Ji),MLN(1,NSH),MLN(1,JI),MLN(1,Ios),
     *       KD,MD,HA,HB,RZ2,RZ3,C1,C,BZ,F,GG,B,AA,BB,VV,UU,WW,WC,
     *         CX,R(1,2),R(1,3),R8,X(1,LK(Ji)),X(1,LC(LL0)),
     *            X(1,LK(JI)),X(1,LK(Ios)),QQC,WK,Z)
          CLB2=FCULD(NA,NB,MLN(1,Ji),MLN(1,IOS),MLN(1,JI),MLN(1,Nsh),
     *       KD,-MD,HA,HB,RZ2,RZ3,C1,C,BZ,F,GG,B,AA,BB,VV,UU,WW,WC,
     *         CX,R(1,2),R(1,3),R8,Xc(1,Lk(Ji)),X(1,LK(IOS)),
     *            Xc(1,LK(JI)),X(1,Lc(LL0)),QQC,WK,Z)
      IF(Ji.EQ.Ios) CLB3= (CLB2-Clb1)
      IF(Ji.NE.Ios) CLB3=2*(CLB2-Clb1)
           WRITE(10,806) JI,CLB1,CLB2,CLB3
        WRITE(10,500)
   97     CONTINUE
        WRITE(10,500)
  207     CONTINUE
 805  FORMAT( ' JI=',I2,' Exch: =',2E12.4,';  M.e.Dif=',E12.4)
 806  FORMAT( ' JI=',I2,' Dir.: =',2E12.4,';  M.e.Dif=',E12.4)

  500 Format( 60('-')/)
  505 FORMAT( ' Number of iterations = ',I3)
      RETURN
      END