
*\ = \===============================================================*
      SUBROUTINE Dms_00(NSH,NA,NB,MMA,Ios,MLN,LK,JOR,Mi,Z1,Z2,RZ, Eps,
     *             Fcc,RP,AHF,BHF,AA,BB,UU,VV,WW,E,CN,CX,WC, Prt,
     *             RR,X,PP,PPS,PQV,QQ,Z)
*\___\_______________________________________________________________*

      IMPLICIT    REAL*8 (A-H,O-Z)
      CHARACTER Prt(*)*65
      DIMENSION   MLN(3,*),LK(*),JOR(NSH,*),Mi(*),
     *    RP(*),AHF(NSH,NSH),BHF(NSH,NSH),
     *    AA(NA,MMA),BB(NA,MMA),UU(NA,*),VV(NA,MMA),
     *    WW(NA,NA),WC(NA,NA),CX(NA,3),
     *    RR(NB,*),X(NB,*),PQV(NB,*),PP(*),PPS(*),QQ(*),Z(*),
     *    E(16), E1(20), CX1(2500),B(4),G(50), DD(400),
     *    CN(16),  BZ(5)
     *     ,x0(400000)
*\___\_______________________________________________________________*

      NA1=NA+1
c16      CALL Veqc(NSH,E,E1)
      CALL Vevr(NSH,E,E1)
C===================
         NX=MLN(3,1)
        CALL VEVR(NB*NX,X(1,LK(6)),X0)
c        CALL VEVR(NB*NX*NSH,X,X0)

C===================

c01      IF(MI(1).EQ.1)  CALL HAFE1(NA1,NB,HB,RP,RR)

      IF(Mi(1).EQ.0)  CALL Cotr0(NA1,NB,HB,RP,RR)
c01      IF(MI(1).EQ.3)  CALL HAFE3(NA1,NB,HB,RP,RR)
C      IF(MI(1).EQ.4)  CALL HAFE4(NA1,NB,HB,RP,RR)
      CALL HAFA0(NA,NB,MMA,RP(1),HA,RR,AA,BB,UU,VV,G,BZ)
      IF(Mi(1).GE.3) CALL VEQC(3,0.0D+00,BZ)

      WRITE(10,500) (Prt(I),I=1,3),Z1,Z2,RZ,NSH
      DO 10 I=1,NSH
   10    WRITE(10,505) I,(MLN(J,I),J=1,3)
      WRITE(10,510)
      DO 15 I=1,NSH
   15    WRITE(10,515) I,(AHF(J,I),J=1,NSH)
      DO 20 I=1,NSH
   20    WRITE(10,520) I,(BHF(J,I),J=1,NSH)
        RMA=RP(2)*RZ/2.D 00
      WRITE(10,525) RMA,NB,RP(1),NA,EPS
C      WRITE(10,525) RP(2),NB,RP(1),NA,EPS
      CALL VEVR(NA*NA,UU,WW)
      CALL INVM(NA,DET,WW)
      KD=2
      IF(DABS(Z1-Z2).GT.1.D-05) KD=1
      RZ2=RZ*RZ/2.D 00
      RZ3=RZ2*RZ/4.D 00
      AS=RZ*(Z1+Z2)
      AD=RZ*(Z2-Z1)
      IF(DABS(AD).GT.1.D-05) KD=1

c6       e(1) = -1.5d0
       e(1) = - (z1+z2)**(1.5d0) /2.d0

c6      if (z
c6        e(1) = - ( z1+z2 )/2.0 * dsqrt (Nsh) * 1.5d0
c6      endif

        Ici=0
  300   DE=0.D 00
c        write (10,*) '1 Ici, itr = ',Ici,itr,de
c        pause

cc      do 24 Ish=1,Nsh
      DO 25 I=1,NSH
        write(*,*) 'cn = '
        write(*,535) (CN(j),j=1,nsh)
        write(*,*) ' E = '
        write(*,535) (E(j),j=1,nsh)

c04        CALL VEVR(NB*NX,X(1,LK(6)),X0)
         IF(MI(3).EQ.1) THEN
           WRITE(*,*) ' I = ',I
           WRITE(*,518)
 518       FORMAT('  IS = ? ')
           READ(*,*) IS
             ELSE
             IS=I
           END IF
        CALL VEVR(NB*NX,X(1,LK(IS)),X0)
c         IF(IS.LE.0) GOTO 27
         IF(IS.LE.0) GOTO 28

         NX=MLN(3,IS)

        itr = mi(3)
c        if (mi(5).eq.0 .and. Ici .eq. 0) itr =2
        if (mi(5).eq.0 .and. I .eq. 1) itr =2

c16         CALL Dhfsi0(NSH,IS,NA,NB,NX,KD,mi(3),Ios,MLN,LK, EPS,Fcc,
         CALL Dhfsi0(NSH,IS,NA,NB,NX,KD, itr ,Ios,MLN,LK, EPS,Fcc,
     *          E(IS),HB,HA,AS,AD,RZ2,RZ3,AHF(1,IS),BHF(1,IS),
     *          AA,BB,VV,UU,WW, G,B,BZ,RR,X,CN,CX,WC,DD,CX1,
     *          PQV,PP,PPS,QQ,Z,Jor)

            NLS=LK(IS)

c        write (10,*) '2 Ici, itr = ',Ici,itr,Nsh

         IF(Mi(4).EQ.1) THEN
           DO 26 IK=1,NSH
              IF(IS.NE.IK.AND.JOR(IK,IS).EQ.1) THEN
                NLK=LK(IK)
                CSK=FOVI(NX,NX,NA,NB,HA,HB,RZ3,DD,RR(1,2),RR(1,7),
     *                    PQV(1,5),PQV(1,6),X(1,NLS),X(1,NLK))
                WRITE(*,*) CSK,CN(IS),CN(IK)
                CC=CSK/CN(IK)
                DO 64 IN=1,NX
                   KS=NLS+IN-1
                   KK=NLK+IN-1
                   DO 65 J=1,NB
   65                 X(J,KS)=X(J,KS)-CC*X(J,KK)
   64              CONTINUE
      C12=FOVI(NX,NX,NA,NB,HA,HB,RZ3,
     *   DD,RR(1,2),RR(1,7),PQV(1,5),PQV(1,6),X(1,NLK),X(1,NLS))
                CN(IS)=FOVI(NX,NX,NA,NB,HA,HB,RZ3,
     *                      DD,RR(1,2),RR(1,7),
     *                      PQV(1,5),PQV(1,6),X(1,NLS),X(1,NLS))
  310           WRITE(*,*) C12,CN(IS)
                END IF
   26         CONTINUE
           END IF


      IF(MI(2).EQ.1) THEN
cc         DO 35 II=1,NSH
         DO 35 II=IS,IS
            C12=1.D 00/DSQRT(CN(II))
            CN(II)=1.D 00
            NX=MLN(3,II)
   35       CALL VCM1(NX*NB,C12,X(1,LK(II)))
         END IF
C       if(is.ge.0) goto 25
   27    CONTINUE
C=============
c                 IF(IS.GE.5) Mi(3)=0
         write(*,*) ' Mi(3) -?'
c                 IF(IS.EQ.5.OR.IS.EQ.8) read(*,*) Mi(3)
c                 IF(IS.EQ.5) read(*,*) Mi(3)
c                 IF(IS.EQ.0) read(*,*) Mi(3)
c                 IF(IS.EQ.8) read(*,*) Mi(3)
c                IF(IS.GE.10.AND.IS.LE.12) read(*,*) Mi(3)
ccc                IF(IS.LE.5.AND.IS.GE.3) read(*,*) Mi(3)
cc                IF(IS.GE.9) read(*,*) Mi(3)
c                IF(IS.EQ.5.OR.IS.EQ.4) read(*,*) Mi(3)
c                 IF(IS.EQ.5.OR.IS.GE.8) read(*,*) Mi(3)
C====================
   25    CONTINUE

        Ici=Ici+1
c        write (10,*) ' Ici, itr = ',Ici,itr,de

   28    CONTINUE
        write(*,*) 'cn = '
        write(*,535) (CN(j),j=1,nsh)
  535 FORMAT( 5E15.7)
        write(*,*) ' E = '
        write(*,535) (E(j),j=1,nsh)
c        pause

      DO 40 IS=1,NSH
   40   DE=DE+DABS(E1(IS)-E(IS))
       IF(DABS(DE).GE.EPS) THEN
         DO 45 IS=1,NSH
   45      E1(IS)=E(IS)
         GOTO 300
         END IF
  305  CONTINUE
      DO 30 IS=1,NSH
  30     WRITE(10,530) IS,E(IS)
C=========================
c        CALL Vvsr(NB*NX,0.5D 00,X0,X(1,LK(10)))
cc        CALL Vvsr(NB*NX*NSH,0.5D 00,X0,X)
C=========================
         CALL WIFB(NSH,NB,MLN,LK,E,CN,X,11)
C  500 FORMAT( 20X' DIATOMIC MOLECULE'/15X,
C     *    ' HARTREE-FORK WAVE FUNCTIONS',/18X,
C     *    ' SELF CONSISTENT FIELD',//
  500 FORMAT( 3(A65/),
     *    ' NUCLEI CHARGES:       Z1 =',
     *      F6.3/23X,'Z2 =',F6.3//
     *    ' INTERNUCLEI DISTANCE: RZ  =',F7.4/
     *    ' NUMBER OF THE SHELLS: NSH =',I3//
     *    ' IDENTIFICATION OF THE SHELLS :'//
     *    5X,'N SHELL    M    L0   N OF P.W.'/)
  505 FORMAT(4X,I4,3X,3(I6))
  510 FORMAT(/' HARTREE-FOCK COEFFICIENTS:')
  515 FORMAT(/' A(',I2,', *)',3E15.5/,2(10X,3E15.5/))
  520 FORMAT(/' B(',I2,', *)',3E15.5/,2(10X,3E15.5/))
  525 FORMAT(//' INTEGRATION UP TO',10X,'RB =',F7.2/
     *    ' NO. INTEGRATION POINTS     NB =',I5//
     *    ' ANALITICAL APPROXIMATION :'/
     *    ' UP TO',20X,'  RA =',F9.3/
     *    ' WITH NUMBER OF POINTS      NA =',I5/
     *    '   ACCURACY   '10X'    EPS=',E10.2/60('=')/7X,
     *    ' R E S U L T S :'//3X,'N SHELL',10X,'ENEGIES')
  530 FORMAT(4X,I3,7X,E16.8)
      END
