C=======TO SOLVE RPAE-EQUATION================================
C====    FOR DIPOLE MATRIX ELEMENTS===========
C        ON      MASS SURFACE
      SUBROUTINE RPADM(NC,ALFA,BET,H,RPAE,NE,S,NW1,
     *       LLLK,LLK,SSK,IZ,KZ,K,K1,
     *       LI,LK,LV,I3,CLS,B1,LAMI,IMIN,
     *       D3,D4,D5,D6,XMAXK,XK0,DELXK,
     *       LAMK,LAMI1,FME,FMEA,A,
     *       OM2,QQ,AL,BL,IAL,MA,SPI,
     *       C,Q,DV1,DV2,ARB,ARB1,ARB2,
     *       R1,R2,R3,R4,R5,R6,R7,R9,R8)

      INTEGER SSS,S,QQ,
     *        LI(*),
     *        LLK(*),SSK(*),K1(*),KZ(*),
     *        K(*),IZ(*),I3(*),IMIN(*),
     *        LV(*),LK(*),
     *        SPI(*),IAL(*)
      REAL*8 BET,H,ALFA,
     *       OM,OM1,SA,A,B,A1,A2,A3,Y1,
     *       BBK1,LAM1,OM2(NC,*),
     *       D3(NC,*),D4(NC,*),
     *       D5(NC,*),D6(NC,*),
     *       FME(NC*NW1),FMEA(NC*NW1),
     *       LAMK(NC,*),LAMI1(*),
     *       CLS(*),B1(*),LAMI(*),
     *       XMAXK(*),XK0(*),DELXK(*),
     *       AL(*),BL(*),
     *       C(*),Q(*),DV1(*),DV2(*),
     *       ARB(*),ARB1(*),ARB2(*),
     *       MA(*),BK(2),AK(2),
     *       R1(*),R2(*),R3(*),R4(*),
     *       R5(*),R6(*),R7(*),R9(*),R8(NE+15,*)
      DO 1 I=1,NC
      LLK(I)=0
      SSK(I)=0
      CLS(I)=1.
      B1(I)=0.5
      SPI(I)=0
   1  CONTINUE
      DO 5 I=1,NC*(NC+1)/2
      LV(I)=2
      AL(I)=1.D 00
    5 BL(I)=0.5
      LLL=0
      SSS=1
      LLLK=1
      J1=NC
      J3=NC
      J5=NC
      NE5=NE+15
      NN1=0
      DO 60 I=1,NC
       NN1=NN1+K(I)
  60   CONTINUE
       N7=0
       NN1=NN1*2
C  === CALCULATIONS OF DIPOLE MATRIX ELEMENTS=======
C      N7=0
C     NN1=(KZ(NC)+K(NC)-S-1)*2
C      NN1=NN1*2
      DO 110  I=1,NC
         N1=K(I)
         N2=KZ(I)
         N3=IZ(I)
         N4=LI(N3)
         N5=LK(I)
         N6=KZ(I)-S
         N8=I-1
         WRITE(6, 105)I
         WRITE(*, 105)I
  105    FORMAT( 60('=')/
     *   ' CHANNAL ',I3,' DIPOLE MATRIX ELEMENTS ')
C     WRITE(6, 111,N2,N3,N1,N4,N5,N6,N8,NN1
 111  FORMAT(8I6)
         CALL MAEL1(ALFA,BET,NE5,H,N2,N3,N1,N4,N5,1,
     *        FME(N6),FMEA(N6),R1,R2,R5,R6,R8)
      DO 112 J=1,N1
  112    WRITE(6, 121)LAMK(I,J),FME(N6+J-1),FMEA(N6+J-1)
  121 FORMAT(' E ',F8.4,'   R FORM ',F8.4,'   V FORM ',F8.4)
C      IF(SPI(I).NE.0) CLS(I)=1.D 00/DSQRT(2.D 00)
      DO 113 J=1,N1
         FME(N6+J-1)=FME(N6+J-1)*CLS(I)
  113    FMEA(N6+J-1)=FMEA(N6+J-1)*CLS(I)
        N6=2*N6
C        IF(RPAE.EQ.0) GOTO 110
C =====COLUMB MATRIX ====================
        DO 130  J=1,NC
          N10=IZ(J)
          WRITE(6, 131)I,J
          WRITE(*, 131)I,J
  131  FORMAT('   CHANNELS  ',2I4)
           IF(I.EQ.J) THEN
            NN2=N1
            NN3=LV(I)-1
          BBK1=B1(I)
          AL(I)=AL(I)*CLS(I)*CLS(I)
      CALL MAELO2(ALFA,BET,NE5,H,NN1,NN3,N1,N1,S,
     *                  IZ(I),IZ(J),LI(N3),LK(I),
     *                  LI(N10),LK(J),LAMI(N3),LAMI(N10),
     *                  AL(I),BK,BBK1,MA,KZ(I),KZ(J),
     *                  SSK(I),SSK(J),LLLK,1,
     *                  R1,R2,R3,R4,R5,R6,R7,R9,R8)
               ELSE
              NN2=K(J)
               IF(J.GT.I) THEN
                NN4=N7+J-I
                   ELSE
                  NN4=N8
                   N8=N8+NC-1-J
               END IF
              NN3=LV(NN4+NC)-1
C       IF(SPI(N3).NE.SPI(N10)) THEN
C         BBK1=0.D 00
C         BK(1)=0.D 00
C           ELSE
           BBK1=B1(J)
           BK(1)=BL(NN4)
C         END IF
           AK(1)=AL(NN4+NC)*CLS(I)*CLS(I)
      CALL MAELO2(ALFA,BET,NE5,H,NN1,NN3,N1,NN2,S,
     *        IZ(I),IZ(J),LI(N3),LK(I),
     *        LI(N10),LK(J),LAMI(N3),LAMI(N10),
     *        AK,BK,BBK1,MA,KZ(I),KZ(J),
     *        SSK(I),SSK(J),LLLK,1,
     *        R1,R2,R3,R4,R5,R6,R7,R9,R8)
            END IF
 130       CONTINUE
         N7=N7+NC-I
 110  CONTINUE
C     ==========================================
C     NN2=KZ(NC)+K(NC)-S-1
C     N1=2*NN2
C       DO 131  I=1,NN1
C131       WRITE(6,132) (MA(J,I),J=1,NN1)
C132     FORMAT(10E12.3)

      DO 140 I=1,NC
         J=K(I)
         J1=K1(I)
C     WRITE(6,*) LAMK(I,J),LAMK(I,J1+1),LAMK(I,J-1),J,J1
         IF(J.GT.J1+1) THEN
           XMAXK(I)=DSQRT(LAMK(I,J))
             ELSE
             XMAXK(I)=1.D-05
             XK0(I)=1.D-05
             DELXK(I)=1.D-05
           END IF
  140  CONTINUE
C=======RPAE         ========================
      QQ=0
      N8=0
      N9=NC
  150 DO 160 JN=1,N9
         I2=JN
         NF=0
         JJ1=QQ
         IF(N8.EQ.0) JJ1=K(JN)
C              IF(RPAE.EQ.0)  GOTO 195
         IF(N8.EQ.1) I2=I3(JN)
         WRITE(6, 141)I2
         WRITE(*, 141)I2
  141    FORMAT( 60('=')/' CHANNAL     ',I6/
     *          '   DIPOLE MATRIX ELEMENTS WITH CORREL.'/
     *          '   PHOTON    RE L-FORM RE V-FORM ',
     *          'IM L-FORM IM V-FORM  DETER. '/
     *          '   ENERGY ')
C        IF(JN.EQ.1.AND.N8.EQ.1) THEN
C          DO 180 I=1,NC
C             DO 190 J=1,K1(I)
C 190            LAMK(I,J)=LADK(I,J)
C 180      CONTINUE
C          END IF
  195      CONTINUE
C              =================
         DO 200 JJ=1,JJ1
            IC1=0
            IF(N8.EQ.0) THEN
              JN1=JN
              A1=LAMK(JN,JJ)
              A2=LAMI(IZ(JN))
              A3=LAMK(JN,JJ+1)
C             OM=A1-A2
              OM=OM2(JN,JJ)
              J2=JJ
              OM1=OM
C     WRITE(6, 201,OM,JN
C 201 FORMAT(' OM  JJ =',E15.4,I4)
              IF(JJ.GT.K1(JN)) OM=OM+(-1)**NF*5.D-02*(A3-A1)
              IF(A1.LT.0.D 00) IC1=JJ
              GOTO 210
              END IF
            IC1=0
            I2=I3(JN)
            JN1=I2
            LAM1=LAMI1(I2)
            KI=K(I2)
            KI1=K1(I2)
C           OM=OM2+(OM3-OM2)*JJ/DFLOAT(QQ+1)
            OM1=OM
            A=DABS(OM-LAMK(I2,KI1+1)+LAM1)
            DO 220 I=KI1+1,KI
               B=DABS(OM-LAMK(I2,I)+LAM1)
               IF(B.LE.A) THEN
                 J2=I
                 A=B
                 END IF
  220          CONTINUE
            A1=LAMK(I2,J2)
C  210         IF(RPAE.EQ.0)  GOTO 230
 210        IF(JJ.EQ.IC1) THEN
              J3=0
C         WRITE(6, 211) OM,OM1,A,SA,IC1,J2,NC,JN1,NN1
          DO 213 I=1,NC
 213     WRITE(6, 212)IMIN(I),LAMI1(I),XK0(I),DELXK(I),XMAXK(I),
     *              KZ(I),K1(I),K(I)
C211  FORMAT('  DISN',4F7.3,5I5)
 212  FORMAT(I5,4F7.3,3I5)
              CALL DISNN(OM,OM1,A,SA,J2,NC,JN1,NN1,K,K1,
     *        IMIN,LAMI1,LAMK,XK0,DELXK,XMAXK,LLLK,R8,R8(1,30),MA,
     *        C,Q,DV1,DV2,ARB,ARB1,ARB2)
        WRITE(6, 214)OM,SA,A
  214   FORMAT(' OM NEW ',F10.5,' A,1-B ',2F10.5)
              IF(DABS((OM-OM1-SA)/OM1).GT.1D 00.AND.J3.LT.5) THEN
                J3=J3+1
                GOTO 210
                END IF
              END IF
            CALL CQDN(OM,0.0,NC,JN1,K,K1,XK0,DELXK,
     *                XMAXK,LAMI1,LAMK,J2,C,Q,DV1,DV2)
            CALL INVMAN(K,K1,XK0,DELXK,XMAXK,LAMI1,
     *                  IMIN,OM,LLLK,J2,NC,JN1,NN1,C,Q,DV1,DV2,
     *                  MA,Y1,R8(1,1),R8(1,30),ARB,ARB1,ARB2)
C           IF(J2.LE.K1(JN).AND.JN.LE.NC) LADK(JN,J2)=OM+LAMI1(JN)
C           CALL MECO1(K,JN,NC,NW1,FME,FMEA,R8(1,1),R8(1,30),
C    *     D3,D4,D5,D6,NN1)
C       WRITE(6, 215,OM1,
C    *     D3(JN,JJ,JJ),D4(JN,JJ,JJ),D5(JN,JJ,JJ),D6(JN,JJ,JJ),Y1
C215   FORMAT(6F10.5)
             CALL MECO(K,NC,IMIN(JN1),FME,FMEA,R8(1,1),R8(1,30),
     *                 D3(JN,JJ),D4(JN,JJ),D5(JN,JJ),D6(JN,JJ),NN1)
        WRITE(6, 215)OM1,D3(JN,JJ),D4(JN,JJ),D5(JN,JJ),D6(JN,JJ),Y1
  215   FORMAT(' ',6F10.5)
 230           CONTINUE
      IF(JJ.GT.K1(JN).AND.JN.LE.NC) NF=NF+1
  200  CONTINUE
  160  CONTINUE
        RETURN
      END
