solc.f

Go to the documentation of this file.

C***************************************************************
C  SUBROUTINE "EVSLV" SOLVES THE MATRIX CIRCUIT EQUATION
C***************************************************************
C  INPUT DATE:
C  **********
C  NLES, NREG, TSTEP0, TSTEP, SIGM, NJ,
C  VOLK(NJ), VOLKP1(NJ), RES(NJ),
C  PSPK(NJ), PSPKP1(NJ), CRPK(NJ), CRPKP1(NJ), CRPKP(NJ),
C  NOUT, NTER, KEYPRI,
C
C  PPIND(NJ,NJ)  - from 'comevl.inc'
C  DPSIDJ(NJ,NJ) - from 'comevl.inc' only for NREG=1
C
C
C  OUTPUT DATE:
C  ***********
C  CRPKP1(NJ) - solution array - currents
C  EREVE      - "nevyazka" of circuit equation solution
C               ( without DPSIDJ*(CRPKP1 - CRPKP) term )
C***************************************************************
C
        SUBROUTINE evslv( NLES, NREG,   TSTEP0, TSTEP,  SIGM,
     *                    nj,   volk,   volkp1, res,
     *                    pspk, pspkp1, crpk,   crpkp1, crpkp,
     *                    nout, nter,   keypri, ereve )

        IMPLICIT REAL*8( a-h, o-z )

        include 'prm.inc'
        include 'comevl.inc'

        dimension   bz(njlim)

        !DIMENSION   RES(*),  VOLK(*),   VOLKP1(*)
        !DIMENSION   PSPK(*), PSPKP1(*)
        !DIMENSION   CRPK(*), CRPKP1(*), CRPKP(*)

        dimension   res(njlim),  volk(njlim),   volkp1(njlim)
        dimension   pspk(njlim), pspkp1(njlim)
        dimension   crpk(njlim), crpkp1(njlim), crpkp(njlim)

        REAL*8      a(nnlim),   rsp(nsp),  b(njlim)
        INTEGER     pp(njlim),  p(njlim),  ip(njlim),
     *              ia(njlim1), ja(nnlim), isp(nsp)

        COMMON /spa_mat/ a, ia, ja
        COMMON /sparsp/ rsp, pp, p, ip

        equivalence(rsp(1),isp(1))

C***************************************************************

        abs(xxx)  = dabs(xxx)
        nflag=0
        nn = nj * nj
C---------------------------------------------------------------

       IF( nles.EQ.0 ) THEN
          npath = 1

          DO i=1,nj
             pp(i)  = i
              p(i)  = i
             ip(i)  = i
          enddo

          ia(1)    = 1
          DO i=2,nj
            ia(i) = ia(i-1) + nj
          enddo
          ia(nj+1) = nn+1

          DO 3 i=1,nj
             ia1 = ia(i)
             ia2 = ia(i+1) - 1
             DO 4 j=ia1,ia2
                jaj   = j - ia1 + 1
                ja(j) = jaj
                a(j)  = ppind(i,jaj)
                IF( nreg.EQ.  1 ) a(j) = a(j) + dpsidj(i,jaj)
                IF( i   .EQ.jaj ) a(j) = a(j) + tstep*sigm*res(i)
    4        CONTINUE
C
    3     CONTINUE
       END IF
C--------------------------------------------------------------------
C
       IF( nles.EQ.1 ) THEN
          npath = 1
          DO 10 i=1,nj
             ia1 = ia(i)
             ia2 = ia(i+1) - 1
             DO 11 j=ia1,ia2
                jaj   = ja(j)
                a(j)  = ppind(i,jaj)
                IF( nreg.EQ.  1 ) a(j) = a(j) + dpsidj(i,jaj)
                IF( i   .EQ.jaj ) a(j) = a(j) + tstep*sigm*res(i)
   11        CONTINUE
   10     CONTINUE
       END IF
C--------------------------------------------------------------------
C
       IF( nles.EQ.2 ) THEN
          npath = 3
          !NPATH = 1
       END IF
C--------------------------------------------------------------------
C
      IF((nles.NE.0).AND.(nles.NE.1).AND.(nles.NE.2)) THEN
          WRITE(*,*) 'PARAMETER NLES = ', nles
          WRITE(*,*) 'IT IS WRONG. PROGRAM INTERRUPT'
          stop
      END IF
C******************************************************************

         DO 6 i=1,nj

           rs1 = 0.d0
           rs2 = 0.d0
           DO 7 j=1,nj
                              rs1 = rs1 + crpk(j)  * ppind(i,j)
              IF( nreg.EQ.1 ) rs2 = rs2 + crpkp(j) * dpsidj(i,j)
    7      CONTINUE

           b(i)  = - tstep*res(i)*(1.d0-sigm)*crpk(i)
     *             + tstep*(sigm*volkp1(i)+(1.d0-sigm)*volk(i))
     *             + rs1
     *             - (pspkp1(i) - pspk(i)) * tstep/tstep0

           IF( nreg.EQ.1 ) b(i) = b(i) + rs2

           bz(i) = b(i)

    6   CONTINUE

C******************************************************************


          call sdrvd(nj,p,ip,ia,ja,a,b,crpkp1,nsp,
     *              isp,rsp,nesp,npath,nflag)



!      CALL CDRVD( NJ,  PP,P,IP,  IA,JA,A,  B,CRPKP1,
 !    *            NSP,ISP,RSP,  NESP,NPATH,NFLAG )
C
C.      WRITE(NOUT,*) '****************************************** '
C.      WRITE(NOUT,*) 'FROM SUBROUTINE "EVSLV" AFTER "CALL CDRVD" '
C.      WRITE(NOUT,*) 'NSP  =',NSP,' ESP  =',NESP,' FLAF =',NFLAG
C.      WRITE(NOUT,*) 'PATH =',NPATH,' NLES =',NLES
C.      WRITE(NOUT,*) 'NREG =',NREG
C
C       CALL TCONTR( 0, A,JA,IA,NJ,CRPKP1,B, 0,0, BZ, ERR)
C
C       IF( KEYPRI.EQ.1 )  THEN
C       WRITE(NOUT,*) 'NEVYAZKA OF LINEAR  SYSTEM:  ERR   =', ERR
C       WRITE(NTER,*) 'NEVYAZKA OF LINEAR  SYSTEM:  ERR   =', ERR
C       END IF
C
          ereve = 0.0d0
          DO 66 i=1,nj
C
             rs1 = 0.d0
             DO 777 j=1,nj
                rs1 = rs1 + (crpkp1(j) - crpk(j)) * ppind(i,j)
  777        CONTINUE
C
             bzz   = -   res(i)*tstep*(1.d0 - sigm)* crpk(i)
     *               -   res(i)*tstep*        sigm * crpkp1(i)
     *               +          tstep*(1.d0 - sigm)* volk(i)
     *               +          tstep*        sigm * volkp1(i)
     *               - rs1
     *               - (pspkp1(i) - pspk(i)) * tstep / tstep0
C
             ttt   = abs(bzz)
             IF( ttt.GT.ereve )   ereve = ttt
   66     CONTINUE
C
C       IF( KEYPRI.EQ.1 )  THEN
C       WRITE(NOUT,*) 'NEVYAZKA OF EVOL. EQUATION:  EREVE =', EREVE
C       WRITE(NOUT,*) '****************************************** '
C       END IF
C       WRITE(NTER,*) 'NEVYAZKA OF EVOL. EQUATION:  EREVE =', EREVE
C       WRITE(NTER,*) '****************************************** '
C
      IF( nesp.LT.0 ) THEN
          WRITE(*,*) 'ATTENTION ESP(SDRVD) = ', nesp
          WRITE(*,*) 'IT IS WRONG. PROGRAM INTERRUPT'
          !WRITE(NOUT,*) 'PARAMETER PATH(SDRVD) = ', NPATH
          !WRITE(NTER,*) 'ATTENTION ESP(SDRVD) = ', NESP
          !WRITE(NTER,*) 'IT IS WRONG. PROGRAM INTERRUPT'
          !WRITE(NTER,*) 'PARAMETER PATH(SDRVD) = ', NPATH
          stop
      END IF
      IF( nflag.NE.0 ) THEN
          WRITE(*,*) 'ATTENTION FLAG(SDRVD) = ', nflag
          WRITE(*,*) 'IT IS WRONG. PROGRAM INTERRUPT'
          !WRITE(NOUT,*) 'PARAMETER PATH(SDRVD) = ', NPATH
          !WRITE(NTER,*) 'ATTENTION FLAG(SDRVD) = ', NFLAG
          !WRITE(NTER,*) 'IT IS WRONG. PROGRAM INTERRUPT'
          !WRITE(NTER,*) 'PARAMETER PATH(SDRVD) = ', NPATH
          stop
      END IF
C
      RETURN
      END
C***************************************************************