SUBROUTINE
DCHOLK(H,S,M,N,ER,IT,KE,W,ES,TS,EH,TH)
00000001
C ********************************************************************
00000002
C * PEEHE OOEHHO POEM COCTBEHHX
HAEH PMTOBO * 00000004
C * MATP H PMTOBO OOTEHO
OPEEEHHO MATP S *
00000005
C * CXOHE MATP MATP COCTBEHHX
BEKTOPOB MET H * 00000006
C * COMPLEX*16, A BEKTOP COCTBEHHX
HAEH - H REAL*8 *
00000007
C *
B X O H E A P A M E T P :
* 00000008
C * MACCB H S - PMTOB MATP
(S OOTEHO OPEEEHA) * 00000009
C * EPEMEHHA M - O'BEHHA PAMEPHOCT
MATP: CXOHX H S, * 00000010
C *
COCTBEHHX BEKTOPOB, COCTBEHHX HAEH
* 00000011
C * EPEMEHHA N - AKTECKA PAMEPHOCT
EPECEHHX MATP * 00000012
C * EPEMEHHA ER - TOHOCT BCEH
COCTBEHHX HAEH *
00000013
C * EPEMEHHA IT - OCTMOE CO
AOB P AOHAA *
00000014
C * EPEMEHHA KE - OPEEET: P
KE.EQ.1 PACCTBATC TOKO * 00000015
C *
COCTBEHHE HAEH, P KE.EQ.0 BCTC *
00000016
C *
COCTBEHHE HAEH COCTBEHHE BEKTOP *
00000017
C * MACCB W - PAO MACCB PAMEPHOCT
CXOHX MATP S H * 00000018
C *
B X O H E A P A M E T P :
* 00000019
C * MACCB ES - BEKTOP COCTBEHHX
HAEH MATP S
* 00000020
C * MACCB TS - MATPA COCTBEHHX
BEKTOPOB MATP S
* 00000021
C * MACCB EH - BEKTOP COCTBEHHX
HAEH CXOHO AA
* 00000022
C * MACCB TH - MATPA COCTBEHHX
BEKTOPOB CXOHO AA *
00000023
C *
B B A E M E O P O P A M M :
* 00000024
C *
<< DJACOB
>> , << DCMULM
>> , << DHERMT
>>
* 00000025
C ********************************************************************
00000027
C
00000028
IMPLICIT REAL*8 (A-H,O-Z), INTEGER*4
(I-N)
00000029
COMPLEX*16 H,S,W,TS,TH,DCMPLX,V
00000030
DIMENSION H(M,M),S(M,M),W(M,M),ES(M),
00000031
,
EH(M),TS(M,M),TH(M,M),U(2,1)
00000032
EQUIVALENCE (V,U(1,1))
00000033
C
00000034
IF (N.LT.2) GO TO 519
00000035
MS=2*M
00000036
EP=ER*ER
00000037
IF (KE.EQ.1) KE=2
00000038
IS=IT
00000039
C
00000040
C AOHAA MATP S C BCEHEM
COCTBEHHX BEKTOPOB
00000041
C
00000042
CALL DJACOB(S,MS,M,N,ER,IS,0,0,ES,TS)
00000043
C
00000044
IF (IS.LT.0) GO TO 521
00000045
C MHOEHE MATP COCTBEHHX BEKTOPOB
MATP S HA
00000046
C AOHAH MATP COCTBEHHX
HAEH S B CTEEH -1/2
00000047
DO 511 J=1,N
00000048
IF (ES(J).LT.EP) GO TO 531
00000049
V=DCMPLX(1.D
0/DSQRT(ES(J)),0.D 0)
00000050
DO 511 I=1,N
00000051
511 S(I,J)=TS(I,J)*V
00000052
C
00000053
C PMTOBO COPEHE OEHHO MATP
00000054
C
00000055
CALL DHERMT(S,M,N,W,M,N)
00000056
C
00000057
C MHOEHE MATP H HA OEHHOE
POBEEHE
00000058
C
00000059
CALL DCMULM(H,M,N,S,M,N,TH,M,N)
00000060
C
00000061
C MHOEHE PMTOBO COPEHHHO MATP
HA POBEEHE
00000062
C
00000063
CALL DCMULM(W,M,N,TH,M,N,H,M,N)
00000064
C
00000065
C AOHAA OEHHOO POBEEH
MATP
00000066
C
00000067
CALL DJACOB(H,MS,M,N,ER,IT,KE,0,EH,W)
00000068
C
00000069
IF (IT.LT.0) GO TO 541
00000070
IF (KE.NE.0) RETURN
00000071
C BCEHE COCTBEHHX BEKTOPOB CXOHO
AA
00000072
C
00000073
CALL DCMULM(S,M,N,W,M,N,TH,M,N)
00000074
C
00000075
RETURN
00000076
C PAMEPHOCT MATP PABHA 1
00000077
519 V=H(1,1)/S(1,1)
00000078
EH(1)=U(1,1)
00000079
RETURN
00000080
C OPAOTKA OOHX CTA P
BOHEH POPAMM
00000081
521 WRITE (6,966)
00000082
WRITE (6,976) IS
00000083
STOP
00000084
531 WRITE (6,966)
00000085
WRITE (6,986) (ES(I),I=1,N)
00000086
STOP
00000087
541 WRITE (6,966)
00000088
WRITE (6,996) IT
00000089
STOP
00000090
C
00000091
966 FORMAT(//,30X,'*** OKA P PEEH OOEHHO',
00000092
,
' POEM COCTBEHHX HAEH ***')
00000093
976 FORMAT(/,30X,'CO AOB P AOHAA OOTEHO',
00000094
,
' OPEEEHHO MATP PABHO ',I4/)
00000095
986 FORMAT(/,30X,'CXOHA MATPA HE BETC OOTEHO',
00000096
,
' OPEEEHHO, COCTBEHHE HAEH'//,(1X,9E14.5))
00000097
996 FORMAT(/,30X,'CO AOB P AOHAA',
00000098
,
' PMTOBO MATP PABHO ',I4,/)
00000099
END
00000100