C STG2 - 9 FEB 1987, KAB. - UVA 1991 MAY 9 WE+VKL, MACROED WE'93MAR24 C LATEST UPDATE WE'01NOV02 OSC'03Mar31 stgt'06Mar26 PROGRAM STG2 C INCORPORATES RMATRX STG2 (CPC 14, 367 (1978)) WITH THE C BREIT-PAULI CODE RMATRX STG2R (CPC 25, 347-387 (1982)), C THE DIMENSIONS ARE SET BY PREPROCESSING. RUB'95JUN19: ICHOP M'ED. C C*********************************************************************** C C A NEW VERSION OF C C THE SECOND PART OF C C A GENERAL PROGRAM TO CALCULATE ATOMIC CONTINUUM C C PROCESSES USING THE R-MATRIX METHOD C C O P A C I T Y S T G 2 C C BY C C THE OPACITY PROJECT C C*********************************************************************** C C THIS PROGRAM EVALUATES HAMILTONIAN AND MULTIPOLE MATRIX ELEMENTS C BETWEEN ARBITRARILY COUPLED L-S CONFIGURATIONS FOR ANY ATOMIC OR C IONIC SYSTEM. IT CALCULATES THE ANGULAR CONTRIBUTIONS TO THESE C MATRIX ELEMENTS FROM DATA READ IN BY THE SEGMENT STG2RD AND C OBTAINS THE RADIAL INTEGRALS FROM A TAPE OR DISC FILE CREATED BY C THE FIRST PART OF THE CODE, OPACITY STG1. C C*********************************************************************** C C ROUTINES USED IN OPACITY STG2 C C*********************************************************************** C C STG2 DIRECTING ROUTINE C AIJS CX ALDAIJ C BOUND CX CALEXO,CALORB,CIV3 C CONFIG C CONPED C CONQN C CONSH C CONSTO C CONTST C COPYTP C DA1 C DA2 C DH0 C DMEL C DMELBB C DMELBC C DMELCB C DMELCC C DMELBD C DMELCD C DMELDB C DMELDC C DMELDD C FINBB C FINBC C FINCC1 C FINCC2 C FINMNT C FIN1BB C FIN1BC C FIN1CC C INTECH C MATANS C MATRX CX NAME2, NAMLST C NJLJOD C ODH0 C PNTBG2 C PRNTWT C RDINT C READTP C RECOV1 CX REDRAD C RKWTS C SETCUP C SETDIM C SETFIN C SETINI C SETMX1 C SETMXR CX SHRIEK C SJ1QNT C SJ2QNT C STG2RD C USEEAV C VIJOUT C LIBRARY SUBROUTINES REQUIRED (ALL IN STGLIB NOW) C ORTHOG FROM PROGRAM WEIGHTS C FANO FROM PROGRAM WEIGHTS C RME FROM PROGRAM WEIGHTS C NTAB1 FROM PROGRAM WEIGHTS C MUMDAD FROM PROGRAM WEIGHTS C CFP FROM PROGRAM WEIGHTS C CFPF FROM PROGRAM WEIGHTS C SETJ1 FROM PROGRAM WEIGHTS C J23SPN FROM PROGRAM WEIGHTS C MODJ23 FROM PROGRAM WEIGHTS C J23ANG FROM PROGRAM WEIGHTS C BLOCK DATA FROM PROGRAM WEIGHTS AND (MERGED '95JUNE) CFPD C INTACT FROM PROGRAM WEIGHTS C CHOP FROM PROGRAM WEIGHTS C REDUCE FROM PROGRAM WEIGHTS C MEKEEP FROM PROGRAM WEIGHTS C MEREST FROM PROGRAM WEIGHTS C H0WTS FROM PROGRAM WEIGHTS C SETM FROM PROGRAM WEIGHTS C CFPP FROM PROGRAM CFPP C CFPD FROM PROGRAM CFPD C TENSOR FROM PROGRAM TENSOR C SETUPE FROM PROGRAM TENSOR C NJSYM FROM PROGRAM NJSYM C GENJ45 FROM PROGRAM NJSYM C GENI9 FROM PROGRAM NJSYM C GENSUM FROM PROGRAM NJSYM C DRACAH FROM PROGRAM NJSYM C CG C HSLDR FROM RMATRX STG3 C C*********************************************************************** C C COMMON BLOCKS OCCURING IN OPACITY STG2 C C*********************************************************************** C PARAMETER (LL41= 15*2-1) C PARAMETER (LL43= 21*2+3) C PARAMETER (LL59=1280*2) C PARAMETER (LL61= 15+1) C PARAMETER (LL64= 49+ 5) C PARAMETER (LL65= 5* 5) C PARAMETER (LL68= 8/2) C PARAMETER (LL71= 60+1) C PARAMETER (LL73= 6* 6) PARAMETER (LL75= 21+2) C COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, C 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN C COMMON/BASIN/ EIGENS( 60),ENDS( 49,&L71),DELTA,ETA C COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,&L73) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) C COMMON/BNDINI/MCFGP,JOCCSH(2500),JOCORB( 15,2500), C * JELCSH( 15,2500),L1QNRD(&L41,3,2500) C COMMON/BPSIZE/KFLN,KFL2,KFLM,KDUMMY(6) COMMON/CASES/ MORE,MSKIP,IPOLPH,INAST C COMMON/CONACT/MACT( 21),MNT( 21),JACT,J1QN( 21,3) C COMMON/CONMX/ H0MAT( 60, 60),VMAT( 60, 60) C COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT C COMMON/CPUNCH/NPUNCH,IHOLEH,IHOLEU,KPUNCH,ISTAND,NREAD C COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), C * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) C COMMON/CSTORE/CTABLE(&L67),KPOINT(&L66),LRANG3 COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX C COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), C * LCONAT( 6, 70) C COMMON/CUPPLE/NOPTN,MNAL( 21),MXAL( 21),IBASSH( 148, 21), C 1 NXCITE( 148),JREAD, LOCSH( 148) ! '05Feb LO restored C COMMON/CUT/ NCUT,IKIP(9000),JOCCSH(9000), ITYP(9000) C COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIAG/ NDIAG,LRAN22 C COMMON/DIAGNL/IDIAG,JA,JB ?? C COMMON/DIMEN/ KFL1,KFL2,KFL3,KFL4,KFL5,KFL6,KFL7 C COMMON/DIPMEL/DEL(&L53,&L53),DEV(&L53,&L53) ! not (, 60) '03Mar31 COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 C COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, C 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), C 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) C COMMON/ENAV/ COEFCT(5),NINTS,KVALUE(5) C COMMON/FACT/ GAMMA( 250) COMMON/INFORM/IREAD,IWRITE,IPUNCH C COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH C COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, C * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY C COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8 C COMMON/INSTO2/RKSTO1(5767), C 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), C 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), C 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) C COMMON/INSTO3/ICTBB( 5, 5,&L65),ICTBC( 5, 5,&L62), C 1 ICTCCD( 5, 5,&L63),ICTCCE( 5, 5,&L64), C 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), C 3 ISTBC2( 580),IST1( 5),IST2( 5), C 4 ITAPST( 49, 49),IDPOS1,IDPOS2 C COMMON/INSTO4/IBBPOL( 5, 5,&L68),IBCPOL( 5, 49,&L68), C 1 ICCPOL( 49, 49,&L68) C COMMON/INSTO5/BBINT(1000),IBBI C COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), C 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/KRON/ IDEL(LL75,LL75) C =======> /MEDEFN/, /MSTATE/, /MVALUE/ AND /KRON/ LINK WITH STGLIB <== C COMMON/MEDEFN/IHSH,NJ(&L75),LJ(&L75),NOSH1(&L75),NOSH2(&L75), C 1 J1QN1(&L43,3),J1QN2(&L43,3),IJFUL(&L75) C COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM C COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(&L61,2500), C 1 MELCSH(&L61,2500),M1QNRD(&L42,3,2500),KCFG, C 2 KOCCSH(2500),KOCORB(&L61,2500),KELCSH(&L61,2500), C 3 K1QNRD(&L42,3,2500),MAXOR C COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, C 1 M16,M17,M18,M19,M20 C COMMON/NJLJ/ NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 C COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT C COMMON/POTORB/PV(&L59) C COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, C * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3),JRELOP(3) C COMMON/REMOVE/ICHOP(&L75) C COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT C COMMON/RKSAVE/IRKBC,IRKCC( 49, 49),ICHUNK,ICT(140000), C * ICTDE( 49, 49) C COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) C COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), C 1 NELCSH( 15, 579),J1QNRD(&L41,3, 579),MAXORB, C 2 NJCOMP(&L75),LJCOMP(&L75) C COMMON/SYMTX/ NSTO( 60) !'05Fe10 replaced as function (I-1)*I/2 C COMMON/TERMS/ NROWS,L(18),J(18),N(189) C COMMON/XATION/AMULT(21),BMULT(21),KD1,KD2,KE1,KE2,MULTD,MULTE C (99 99) TMPFIX RUB'95JUL06 !!! C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN OPACITY STG2 C C*********************************************************************** C C IREAD CARD READER - SET IN THE DIRECTING ROUTINE C IWRITE OUTPUT TO LINE PRINTER C IPUNCH CARD PUNCH FOR CONFIGURATION DATA C IDISC1 NOT USED C IDISC2 NOT USED C IDISC3 TEMPORARY STORE FOR MULTIPOLE INTEGRALS C IDISC4 TEMPORARY STORE FOR (N+1)-ELECTRON STATE DATA C ITAPE1 PERMANENT STORE OF RMATRX STG1 INTEGRALS (INPUT) C ITAPE2 PERMANENT STORE OF RMATRX STG2 H-MATRICES (INPUT) C ITAPE3 PERMANENT STORE OF H-MATRICES (OUTPUT) C ITAPE4 PERMANENT STORE OF DIPOLE MATRIX ELEMENTS (OUTPUT) C JREAD CARD READER FOR CONFIGURATION DATA C JDISC1 DA INPUT FILE OF RK INTEGRALS FROM STG1 C JDISC2 NOT USED. C C*********************************************************************** C C STG2 DIRECTING ROUTINE C C*********************************************************************** C 1000 FORMAT(/10X,63(1H*)) 1001 FORMAT(//26H REPEAT STG2 WITH NEW DATA) 1002 FORMAT(//37H READ NEW DATA DEFINING A FINAL STATE) 1003 FORMAT(/55X,11HEND OF STG2/55X,11(1H-)) 1004 FORMAT(/28H DIMENSIONS EXCEEDED IN STG2/) open(5,file='stg2.inp',status='old') open(6,file='stg2.out',status='unknown') open(3,file='s2ham',status='unknown',form='unformatted') open(4,file='s2dip',status='unknown',form='unformatted') open(7,file='s2pun',status='unknown') open(8,file='s2ft8',status='unknown',form='unformatted') open(9,file='s2ft9',status='unknown',form='unformatted') open(10,file='s2ft10',status='unknown',form='unformatted') open(11,file='s2ft11',status='unknown',form='unformatted') C C IREAD IS THE CARD INPUT CHANNEL NUMBER C IREAD=5 C C SET UP DIMENSION TEST INDICES C CALL SETDIM C C READ IN ALL THE DATA REQUIRED TO SPECIFY THE TARGET N-ELECTRON C STATES. THE (N+1)- ELECTRON GROUND AND SCATTERING/EXCITED STATES C MSKIP=-1 C & = 0 ON READIND BASIC INPUT FROM STG1 IN READTB. ICOUNT=1 C C SET UP FACTORIAL AND KRONECKER ARRAYS LOG(GAM) AND IDEL FOR STGLIB C CALL FACTT DO 10 I=1,LL75 DO 9 J=1,LL75 9 IDEL(J,I)=0 10 IDEL(I,I)=1 CP OPEN(ITAPE3,FILE='file2h',ACCESS='sequential',STATUS='unknown') C 1 CALL STG2RD WRITE(IWRITE,1000) IF(IPLACE.GT.0) GO TO 2 C C READ THE TAPE PRODUCED BY STG1 (NCHAN PROVISION RUB'94MAY26) C CALL READTP WRITE(IWRITE,1000) IF(NCHAN.NE.0 .OR. INAST.EQ.0) GO TO 4 INAST=INAST-1 GO TO 2 4 MSKIP=MSKIP+1 IF(NDIAG.eq.0) GO TO 5 CALL BOUND WRITE(IWRITE,1000) NDIAG=0 5 IF(INAST.LE.0) GO TO 6 IF(ICOUNT.GT.ITOTAL) GO TO 2 C C EVALUATE AND STORE THE HAMILTONIAN MATRIX MOST ECONOMICALLY (L23!) C CX IF(JRELOP(3).EQ.0) THEN -- RUB'94APR3-9//MAY25(NEW 16,17 IN MX1!): IF(JRELOP(3).NE.0.AND.( 6.LE.1.OR.NSYMAX+1.LT.MIN(5, 6)))GOTO7 C TST IF(JRELOP(3).NE.0.AND.( 6.LE.1 ))GOTO7 CALL SETMX1 IF (NCFGP.GE.0) GO TO 8 C CASE OF ADDRESS ARRAY KPOS IN SETMX1 TOO SMALL (RUB'96FEB07): 7 CALL SETMXR 8 WRITE(IWRITE,1000) IF(ICOUNT.GT.ITOTAL) GO TO 3 C C EVALUATE THE MULTIPOLE MATRIX ELEMENTS FOR THE R.H.S. OF THE C ASYMPTOTIC EQUATIONS FOR USE IN THE SCATTERING CALCULATION C CALL AIJS WRITE(IWRITE,1000) IF(ICOUNT.GE.ITOTAL) GO TO 3 C C RETURN TO THE BEGINNING TO READ NEW DATA IF MSKIP.LT.INAST C 2 IF(MSKIP.GE.INAST) GO TO 3 IF(IPOLPH.EQ.1) WRITE(IWRITE,1001) IF(IPOLPH.GT.1) WRITE(IWRITE,1002) GO TO 1 C C IF IPOLPH.GE.2 CALCULATE THE DIPOLE MATRIX ELEMENTS FOR USE IN C POLARIZABILITY AND PHOTOIONISATION CALCULATIONS C 3 IF(IPOLPH.LE.1) GO TO 6 CALL DMEL WRITE(IWRITE,1000) C C WRITE OUT ERROR MESSAGE IF A DIMENSION HAS BEEN EXCEEDED C 6 IF(IPLACE.GT.0) WRITE(IWRITE,1004) IF(IPLACE.LE.0) WRITE(IWRITE,1003) STOP END C*********************************************************************** SUBROUTINE AIJS C C - EVALUATES THE LONG-RANGE-FORCE COEFFICIENTS. C THESE ARE WRITTEN ONTO THE STG2 PERMANENT OUTPUT FILE (ITAPE2). C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (TWO=2.,ISPIN=0) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (LL61= 15+1, LL73= 6* 6, LL75= 21+2) DIMENSION VSHELL(LL75), HELP( 300, 300, 8) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INSTO5/BBINT(1000),IBBI COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1001 FORMAT (//31X,12HATOMIC STATE,I3,14H ATOMIC STATE,I3) 1008 FORMAT (6I5,7H RACAH=,F9.6,9H CLEBSCH=,F9.6,7H CFADD=,F10.6) 1009 FORMAT (/' TRIANGLE RELATION NOT SATISFIED IN AIJS -- STOPPING.'/) C C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF READTP C WRITE(IWRITE,'(//53X,15HSUBROUTINE AIJS/53X,15(1H-))') IF(LAMAX.EQ.0) GO TO 34 IF(NCHAN.EQ.0) GO TO 34 IF(ICOUNT.LT.ICOPY1) GO TO 2 IF(ICOUNT.GT.ICOPY2) GO TO 2 DO 1 I=1,NCHAN 1 READ(ITAPE2) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) GO TO 32 C C INITIALISE THE CF ARRAY C 2 DO 3 K=1,LAMAX DO 3 J=1,NCHAN DO 3 I=1,NCHAN 3 CF(I,J,K) = 0. C C READ THE BOUND-BOUND MULTIPOLE INTEGRALS INTO THE RKSTO2 ARRAY IF(IBBI.LE.0) GO TO 29 DO 4 I=1,IBBI 4 RKSTO2(I)=BBINT(I) IF(IBUG6.EQ.1) WRITE(IWRITE,'(//24H **DEBUG PRINT IN AIJS**/)') KK=0 M1=0 ME1=0 ITYP=0 C C LOOP OVER THE ATOMIC STATES ON THE L.H.S. OF THE MATRIX ELEMENT C DO 28 IY=1,NAST IF(NCONAT(IY).LE.0) GO TO 28 IF(ABS(ISAT(IY)-NSPN).EQ.1) GO TO 5 WRITE(IWRITE,1009) C HAPPENS ONLY IN QUB-IP CODE WHEN STG2 TARGET INPUT NOT GROUPED: STOP 5 KN=KK+1 KK=KK+NCONAT(IY) MCFG=NTCON(IY) DO 10 J=1,MCFG NNG=NTYP(IY,J) IG=NOCCSH(NNG) IG1=2*IG-1 DO 7 L=1,3 DO 6 I=1,IG1 6 M1QNRD(I,L,J)=J1QNRD(I,L,NNG) 7 CONTINUE DO 9 K=1,IG MOCORB(K,J)=NOCORB(K,NNG) IF(M1.LT.MOCORB(K,J)) M1=MOCORB(K,J) 9 MELCSH(K,J)=NELCSH(K,NNG) 10 MOCCSH(J)=NOCCSH(NNG) KL=0 JTYP=0 C C LOOP OVER THE ATOMIC STATES ON THE R.H.S. OF THE MATRIX ELEMENT C DO 27 JY=1,IY IF(NCONAT(JY).LE.0) GO TO 27 KM=KL+1 KL=KL+NCONAT(JY) IF(ISAT(JY).NE.ISAT(IY)) GO TO 27 NCFGE=NTCON(JY) DO 15 I=1,NCFGE NNE=NTYP(JY,I) IE=NOCCSH(NNE) IE1=2*IE-1 DO 13 L=1,3 DO 12 J=1,IE1 12 K1QNRD(J,L,I)=J1QNRD(J,L,NNE) 13 CONTINUE DO 14 K=1,IE KOCORB(K,I)=NOCORB(K,NNE) IF(ME1.LT.KOCORB(K,I)) ME1=KOCORB(K,I) 14 KELCSH(K,I)=NELCSH(K,NNE) 15 KOCCSH(I)=NOCCSH(NNE) MAXOR=MAX(M1,ME1) IF(IBUG6.EQ.1) WRITE(IWRITE,1001) IY,JY C C LOOP OVER LAMBDA C DO 26 LDA=1,LAMAX IF(LAT(IY)+LAT(JY).LT.LDA) GO TO 26 IF(ABS(LAT(IY)-LAT(JY)).GT.LDA) GO TO 26 IF(IBUG6.EQ.1) WRITE(IWRITE,'(/41X,7HLAMBDA=,I2)') LDA C C LOOP OVER THE CONFIGURATIONS OF THE TWO ATOMIC STATES C IF (NTYP(IY,1).EQ.ITYP .AND. NTYP(JY,1).EQ.JTYP) GO TO 21 DO 20 I=1,MCFG DO 19 J=1,NCFGE IRHO=0 ISIG=0 CALL SETUPE(I,J,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO.NE.ISIG) GO TO 17 RESULT = 0. IF(IRHO.EQ.0) GO TO 19 DO 16 K=1,IHSH C CALL REDRAD(LDA,K,K,RR): IF(VSHELL(K).EQ.0.) GO TO 16 L=LJ(K) N=NJ(K) CALL FINMNT(N,L,N,L,LDA,RR,RV) RESULT = RME(L,L,LDA)*VSHELL(K)*RR + RESULT 16 CONTINUE GO TO 19 C 17 CALL REDRAD(LDA,IRHO,ISIG,RR) -- '99JAN27: 17 K=LJ(IRHO) L=LJ(ISIG) CALL FINMNT(NJ(IRHO),K,NJ(ISIG),L,LDA,RR,RV) RESULT = RME(K,L,LDA)*VSHELL(1)*RR 19 HELP(J,I,LDA)=RESULT 20 CONTINUE C 21 CFADD = 0. DO 23 I=1,MCFG IF(AIJ(IY,I).EQ.0.0) GO TO 23 DO 22 J=1,NCFGE 22 CFADD = HELP(J,I,LDA)*AIJ(JY,J)*AIJ(IY,I)+CFADD 23 CONTINUE C C LOOP TO PRODUCE ALL MATRIX ELEMENTS COUPLED TO A GIVEN PAIR OF C ATOMIC STATES C DO 25 I=KN,KK LI=L2P(I) IF(JY.EQ.IY) KL=I DO 24 J=KM,KL C 24 CALL ALDAIJ(LDA,I,J,IY,JY,CFADD) -- RUB'94NOV7: C EVALUATE ANGULAR COEFFICIENTS AND HENCE THE ASYMPTOTIC C COEFFICIENTS CF OF MULTIPOLARITY LDA FOR CHANNELS (I,J): L=L2P(J) IF(L+LI.LT.LDA) GO TO 24 IF(MOD(L+LI+LDA,2).NE.0) GO TO 24 IF(ABS(L-LI).GT.LDA) GO TO 24 CLEB=RME(LI,L,LDA) CALL DRACAH(2*LAT(JY),2*LDA,2*LRGL,2*LI,2*LAT(IY),2*L,RAC) CF(J,I,LDA) = CFADD*CLEB*RAC*TWO CF(I,J,LDA) = CF(J,I,LDA) IF(IBUG6.EQ.1) WRITE(IWRITE,1008) * LAT(JY),LDA,LRGL,LI,LAT(IY),L,RAC,CLEB,CFADD 24 CONTINUE 25 CONTINUE C 26 CONTINUE JTYP=NTYP(JY,1) 27 CONTINUE ITYP=NTYP(IY,1) 28 CONTINUE C C WRITE OUT THE COEFFICIENTS C 29 IF(IBUG6.LE.0.AND.IBUG9.EQ.0) GO TO 32 WRITE(IWRITE,'(/29H COEFFICIENT MATRIX CF(I,J,K))') DO 31 K=1,LAMAX WRITE(IWRITE,'(/3H K=,I1,3H J)') K DO 30 J=1,NCHAN 30 WRITE(IWRITE,'(I7,(T9,6F12.7))') J,(CF(I,J,K),I=1,NCHAN) 31 CONTINUE C 32 DO 33 I=1,NCHAN 33 WRITE(ITAPE3) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) 34 WRITE(IWRITE,'(14H TAPE POSITION,I4,17H HAS BEEN REACHED)') ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 GO TO 36 C C WRITE TO ITAPE3 COMPLETED C 35 IF(ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE(IWRITE,'(//26H WRITE TO ITAPE3 COMPLETED)') C 36 MCFG=0 RETURN END C*********************************************************************** SUBROUTINE BOUND C C CALCULATES THE ENERGIES AND EIGENVECTORS OF THE TARGET C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (EPSI=1.0E-9, L85=( 300*( 300+1))/2) ! '02Feb17 PARAMETER (LL41= 15*2-1, LL43= 21*2+3, LL75= 21+2) CHARACTER*1 LIT(0:10), LVALUE(0:6),PAR(0:1),QQ, CLP*2, CAT( 70)*7 DIMENSION IA1( 15),IA2( 15),IB1( 15),IB2( 15), HNP1(L85), * MSYM( 70), AUX( 300,9),X( 300),EN( 300),eco( 300), * ITEC( 300), NCT( 300),INV( 300) ! IPTY( 70) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3),JRELOP(3) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) DATA LVALUE/'S','P','D','F','G','H','?'/, PAR/'e','o'/ * LIT/'0','1','2','3','4','5','6','7','8','9','?'/ C 1000 FORMAT(//52X,16HSUBROUTINE BOUND/52X,16(1H-)//' CALCULATION OF BOU *ND STATE ENERGIES AND TERM EXPANSION COEFFICIENTS'/51X, * 17H(" if IBUG7.ge.0)) 1001 FORMAT(5H TERM,I4,9H: ENAT =,F15.6,I9,A2,3X,1H#,I2,I5,7X,'(',I4, *')') 1002 FORMAT(//29X,'BOUND',I2,A2,' calling MATANS with IT,JT =',2I4) 1003 FORMAT(//' HAMILTONIAN MATRIX',I3,A2,':',I3,' STATE(S) EXTRACTED') C C C DEFINE NUMBER JSYM OF DISTINCT TARGET SYMMETRIES C WRITE(IWRITE,1000) JSYM=0 DO 4 I=1,NAST K=NTCON(I) IF(K.GT.IDMTST(25)) CALL RECOV1(25,K) C VKL'92: CHECK IS BY-PASSED IN STG2RD WHEN NDIAG.GT.0! N = NTYP(I,1) C M = 0; DO 2 J=1,NOCCSH(N); K=NOCORB(J,N) C 2 M=LJCOMP(K)*NELCSH(J,N)+M; IPTY(I) = MOD(M,2) DO 3 J=1,I-1 NS=INV(J) IF(NTYP(J,1).EQ.N) GO TO 4 3 CONTINUE JSYM=JSYM+1 NCT(JSYM)=0 NS = JSYM 4 INV(I)=NS C C JREL1=JRELOP(1); JREL2=JRELOP(2) JREL3=JRELOP(3) IF (JREL3.NE.0) WRITE(ITAPE3) JSYM C C LOOP OVER TARGET STATES - C TWICE BECAUSE STAGE RECUPD NEEDS TERM COUPLING COEFFICIENTS, C WHICH REQUIRE EIGENVECTORS OF THE NON-RELATIVISTIC HAMILTONIAN C DO 99 NS=1,NAST NTC=NTCON(NS) NPTAT = IPTY(NS) CLP = LVALUE(MIN(LAT(NS),6))//PAR(NPTAT) C C CHECK ALL OTHER STATES FOR SAME L, S, PARITY C N=0 NCUP=0 DO 59 I=1,NAST IF (IPTY(I).NE.NPTAT) GO TO 59 IF (LAT(I).NE.LAT(NS)) GO TO 59 IF (ISAT(I).NE.ISAT(NS)) GO TO 59 IF(I.LT.NS) GO TO 70 NCUP=NCUP-1 N=N+1 MBED(I)=MAX(MBED(I),N-NTC) ! cures out-of-range input do 58 J=1,-MBED(I) MSYM(N)=0 58 N=N+1 MSYM(N)=I eco(N)=TEC(I) 59 CONTINUE NSYM = N C C LOOP OVER PAIRS OF TARGET CONFIGURATIONS C IF(IBUG7.GE.3) WRITE(IWRITE,1003) ISAT(NS),CLP, NSYM C IF(JREL3.GE.0) GO TO 60 C JRELOP(1)=MAX(JREL1-1,0); JRELOP(2)=MAX(JREL2-1,0) C '94NOV7: MAX PROVIDES FOR THE UNLIKELY CASE OF S-O ONLY WHEN BP. 60 N=0 DO 64 IT=1,NTC I=NTYP(NS,IT) I4=NOCCSH(I) DO 61 K=1,I4 IA1(K)=NOCORB(K,I) 61 IB1(K)=NELCSH(K,I) N1=N+1 DO 63 JT=IT,NTC J=NTYP(NS,JT) I5=NOCCSH(J) DO 62 K=1,I5 IA2(K)=NOCORB(K,J) 62 IB2(K)=NELCSH(K,J) N=N+1 C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C SET J1QN C IB=NOCCSH(I)+1 CALL SJ2QNT(I,IB,I3,1,1) IB=NOCCSH(J)+1 CALL SJ2QNT(J,IB,I3,1,2) C C SET THE REMAINING QUANTITIES FOR MATRIX C IHSH=I3 NDCT(1)=0 NDCT(2)=0 IF(IBUG9.GE.4) CALL PNTBG2(I,J) IF(IBUG1.NE.0) print 1002, ISAT(NS),CLP, IT,JT CALL MATANS(1) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C 63 HNP1(N)=AME(1,1) C if(IT.le.NSYM) HNP1(N1)=eco(IT)/2.+HNP1(N1) ! '01Oct30/'05Mar07 if(NCUP.eq.0) go to 64 X(IT) = HNP1(N1) ! '06Feb24-6 -- X may not be in energy order: ITEC(IT) = 0 DO J=1,IT K=IT IF(X(J).GT.X(IT)) K=J ITEC(K)=ITEC(K)+1 ENDDO IF(IBUG7.LT.3) GO TO 64 WRITE(IWRITE,'(I5,1H:,(T7,10F11.5))') IT,(HNP1(J),J=N1,N) 64 CONTINUE C DO 65 K=1,NSYM J=1 DO I=1,NTC if(ITEC(I).eq.K) go to 65 J=NTC-I+1+J ENDDO 65 HNP1(J) = eco(K)/2. + HNP1(J) C C JUST OUTPUT THE HAMILTONIAN MATRICES IF RECOUPLING TARGET C C TST print"(/2I5,A2,4(I4,4I3))", NCUP,ISAT(NS),CLP,(MSYM(I),I=1,NSYM) IF(JREL3.EQ.0) GO TO 66 IF(NCUP.NE.0) THEN WRITE(ITAPE3) LAT(NS),ISAT(NS),NPTAT,NCUP,N ! '06Mar24 < NTC0 ELSE WRITE(ITAPE3) (HNP1(J),J=1,N) GO TO 99 ENDIF C C DIAGONALIZE HAMILTONIAN C 66 N1=0 if (NTC.eq.NSYM) N1=1 ! '05Mar08 no trailing correlation terms DO 69 I=N1,NSYM NO = NTC-NSYM+I if(I.eq.0) NO=1 EN(1)=HNP1(1) X(1)=1. NSP=NS IF(N.EQ.1) GO TO 67 if (I.ne.0) then NSP=MSYM(NSYM-I+1) if(NSP.eq.0) go to 69 ! embedded correlation term endif CALL HSLDR(NTC,HNP1,N,EPSI,EN,X,NO,AUX,IDMTST(25)) if (I.eq.0) go to 69 67 ENAT(NSP) = EN(NO) K = NSP-MBED(NSP)*NAST ! '06Mar25 for level-embedding in RECUP IF(JREL3.NE.0) WRITE(ITAPE3) NTC, K, EN(NO), (X(J),J=1,NTC) DO 68 J=1,NTC 68 AIJ(NSP,J)=X(J) if(IBUG7.gt.1) print"(/' ITEC =',(T8,18I4))",(ITEC(J),J=1,NTC) 69 CONTINUE C 70 IF (IBUG7.LT.0) GO TO 71 WRITE(IWRITE,'(/7H NTYP =,(T8,I4,5I11))') (NTYP(NS,J),J=1,NTC) WRITE(IWRITE,'(6H AIJ =,(T7,6F11.7))') (AIJ(NS,J),J=1,NTC) 71 J=INV(NS) NCT(J)=NCT(J)+1 WRITE(IWRITE,1001) NS, ENAT(NS),ISAT(NS),CLP,NCT(J),MBED(NS),NTC if (TEC(NS).ne.0.) WRITE(IWRITE,"(13X,5HTEC =,F15.6, * ' * 2*Ry from input is included')") TEC(NS)/2. C QQ = ' ' K = NCT(J) if (K.ge.10) QQ = LIT(K/10) CAT(NS) = LIT(MIN(ISAT(NS),10))//CLP//' #'//QQ//LIT(MOD(K,10)) INV(NS) = 0 do 72 K=1,NS J = NS if (ENAT(K).gt.ENAT(NS)) J = K 72 INV(J) = INV(J)+1 C IF(NCUP.EQ.0) GO TO 99 ! since HNP1 already on TAPE3 IF(JREL3.EQ.0) GO TO 99 C for temporary option JREL3=-|JREL3|: C JRELOP(1)=JREL1; JRELOP(2)=JREL2 NCUP=0 C n.b. HSLDR overwrote HNP1, expected on TAPE3 in odd position! GO TO 60 99 CONTINUE C C 95 FORMAT(//9X,'TARGET ENERGIES E RELATIVE TO THE GROUND STATE'/ *' 1:',I3,F15.6,7X,'E/RYD',10X,'E/eV',6X,'E*cm/hbar*c',4X,A7) 96 FORMAT(I5,I4,F15.6,F14.6,F14.5,F15.3,4X,A7) DO 98 I=1,NAST do 97 J=1,NAST if (INV(J).ne.I) go to 97 if (I.eq.1) then WRITE(6,95) J,ENAT(J), CAT(J) K = J else RYD = (ENAT(J)-ENAT(K))*2. WRITE(6,96) I,J,ENAT(J),RYD,RYD*13.605804,RYD*109737.32,CAT(J) endif go to 98 97 continue 98 CONTINUE C IF(JREL3.EQ.0) THEN WRITE(ITAPE3) NAST WRITE(ITAPE3) (ENAT(I),I=1,NAST), (LAT(I),I=1,NAST), * (ISAT(I),I=1,NAST),(IPTY(I),I=1,NAST) ENDIF RETURN END C*********************************************************************** SUBROUTINE CONFIG(LRGL,NSPN,NPTY,MAXORB,NJCOMP,LJCOMP,IELC,IBUG, 1 NCFGT) C C TO GENERATE OR READ CONFIGURATION DATA FOR A STATE WITH TOTAL C ANGULAR MOMENTUM, SPIN, PARITY OF LRGL, NSPN, NPTY. C C MAXORB IS THE TOTAL NUMBER OF SHELLS. C NJCOMP AND LJCOMP ARE THE N AND L VALUES FOR THE SHELLS. C IELC IS THE TOTAL NUMBER OF ELECTRONS. C IBUG IS GREATER THAN ZERO FOR A PRINTOUT OF THE CONFIGURATIONS. C C CONFIG CAN BE CALLED A NUMBER OF TIMES FOR A SERIES OF STATES, C AND THE CONFIGURATION DATA CORRESPONDING TO EACH STATE CAN BE C STORED SEQUENTIALLY IN /BNDCON/. C THE READING OF CONFIGURATION DATA FROM JREAD ONLY OCCURS ON THE C FIRST CALL TO CONFIG FOR A SERIES OF STATES. C THE PUNCHING OF CONFIGURATION DATA TO IPUNCH ONLY OCCURS ON THE C LAST CALL TO CONFIG FOR A SERIES OF STATES. C C NCFGT = -1 FOR THE FIRST OF A SERIES OF STATES, C = -2 FOR THE LAST OF A SERIES OF STATES. C = -3 IF THERE IS ONLY ONE STATE. C C ON RETURN NCFGT CONTAINS THE NUMBER OF CONFIGURATIONS STORED C FOR THE CURRENT STATE. C LOGICAL FIRST DIMENSION NJCOMP(MAXORB),LJCOMP(MAXORB), NI( 21),NTOTI( 21) COMMON/CUPPLE/NOPTN,MNAL( 21),MXAL( 21),IBASSH( 148, 21), 1 NXCITE( 148),JREAD,LOCSH( 148) ! LOC restored '05Feb C+SP * NXCITE( 148),IXCITE( 148,6),JREAD,LOCSH( 148) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/RECOV/ IPLACE,IDMTST(50) C 1000 FORMAT(/52X,17HSUBROUTINE CONFIG/52X,17(1H-)) 1001 FORMAT(12I5) 1002 FORMAT(/50H * WARNING * ONLY TWO ELECTRONS ALLOWED IN SHELL,I3, 1 9H WITH L =,I3) 1003 FORMAT(//32H * PROGRAM STOPS IN CONFIG * L =,I5,8H 2S+1 =,I5, 1 10H PARITY =,I5/) 1004 FORMAT(//34H * PROGRAM STOPS IN CONFIG * SHELL,I5,8H HAS N =,I5, 1 4H L =,I5/) 1005 FORMAT(//' * PROGRAM STOPS IN CONFIG * MXN(I) IS NOT SUFFICIENT F *OR IELC =',I4/) 1006 FORMAT(//42H * PROGRAM STOPS IN CONFIG * CONFIGURATION,I4, 1 9H REQUIRES,I4,21H ELECTRON EXCITATIONS/) 1007 FORMAT(/51X,31HPOSSIBLE ELECTRON DISTRIBUTIONS//) 1008 FORMAT(/47H NUMBER OF TERMS CSL STORED FOR THIS SYMMETRY =,I5) 1009 FORMAT(/24H CARD PUNCHING COMPLETED/) C NREAD=0 NWRITE=0 IF(IBUG.GT.0) NWRITE=IWRITE NPUNCH=0 ICFGT=0 C C IF NCFGT = -1 OR -3, THIS IS THE FIRST OR ONLY CALL TO CONFIG. C IF JREAD.GT.0, CALL CONSTO TO READ CONFIGURATION DATA FROM JREAD. C FIRST=.FALSE. IF(NCFGT.NE.-1.AND.NCFGT.NE.-3) GO TO 1 FIRST=.TRUE. NCUP=0 ICFG=0 NCON=0 IF(JREAD.EQ.0) GO TO 1 NREAD=JREAD CALL CONSTO NREAD=0 NOPTN=-2 ICFGT=0 FIRST=.FALSE. C C SET AND CHECK THE INPUT DATA C 1 ITOTL=LRGL ITOTS=NSPN IPTY=NPTY NSHELL=MAXORB NELC=IELC IF(ITOTL.LT.0.OR.ITOTS.LT.1) GO TO 2 IF(IPTY.EQ.0.OR.IPTY.EQ.1) GO TO 3 2 WRITE(IWRITE,1003)ITOTL,ITOTS,IPTY STOP 3 NSPARE=NELC DO 5 I=1,NSHELL NJ(I)=NJCOMP(I) L=LJCOMP(I) LJ(I)=L IF(L.GE.0.AND.L.LT.NJ(I)) GO TO 4 WRITE(IWRITE,1004)I,NJ(I),L STOP 4 IF(NOPTN.EQ.-2) GO TO 5 NSPARE=NSPARE-MNAL(I) IF(NSPARE.GE.0) GO TO 5 WRITE(IWRITE,1005)NELC STOP 5 CONTINUE C C CHECK TO SEE IF CONFIGURATIONS CORRESPONDING TO THE CURRENT L,S, C AND PARITY HAVE ALREADY BEEN STORED C IOPTN=-2 IF(.NOT.FIRST) CALL CONSTO IF(ICFGT.GT.0.OR.JREAD.GT.0) GO TO 17 IOPTN=NOPTN C C ONLY 2 ELECTRONS ALLOWED IN SHELLS WITH L.GE.3 C IF(IOPTN.EQ.-2) GO TO 17 DO 7 I=1,NSHELL L=LJ(I) NE=MIN(L*4+2,MNAL(I)+NSPARE,MXAL(I)) !?'05Feb11:,MXAL(I)) '07Mar28 IF(L.LT.3) GO TO 6 IF(NE.GT.2) WRITE(IWRITE,1002)I,L NE=MIN(NE,2) 6 MXAL(I)=NE 7 MXN (I)=NE+1 C C --- STORE LAST OCCUPIED SHELL FOR EACH BASIC CONFIGURATION C IF(IOPTN.LE.0) GO TO 10 DO 9 M=1,IOPTN DO 8 I=1,MAXORB J = MAXORB-I+1 IF (IBASSH(M,J).EQ.0) GO TO 8 LOCSH(M) = J ! restoration/modification for CONPED '05Feb11 GO TO 9 8 CONTINUE 9 CONTINUE C C TO GENERATE THE CONFIGURATIONS CALL CONPED: C LOOP OVER ALL POSSIBLE ELECTRON DISTRIBUTIONS C 10 I=0 11 I=I+1 NI(I)=0 12 NI(I)=NI(I)+1 NSTOP=I MI=MXN(I)-NI(I) IF(MI.LT.MNAL(NSTOP)) GO TO 15 NTOT=MI IF(I.GT.1) NTOT=NTOT+NTOTI(I-1) NTOTI(I)=NTOT MN(I)=MI IF(NTOT-NELC) 14,13,15 13 CALL CONPED 14 IF(I-NSHELL) 11,15,17 15 IF(NI(I).LT.MXN(I)) GO TO 12 16 I=I-1 IF(I.GT.0) GO TO 15 C C IF NCFGT = -2 OR -3, THIS IS THE LAST OR ONLY CALL TO CONFIG. C CHECK DIMENSIONS. C IF IPUNCH.GT.0, CALL CONSTO TO PUNCH CONFIGURATION DATA TO IPUNCH C 17 WRITE(IWRITE,1008) ICFGT if (ICFGT.eq.0 .and. NCFGT.ne.-3) then print "(/' inconsistent FORT.5 input -- stopping')" STOP endif IF(NCFGT.NE.-2.AND.NCFGT.NE.-3) GO TO 18 IF(IPLACE.EQ.0) IPLACE=-1 IF(NCUP.GT.IDMTST(28)) CALL RECOV1(28,NCUP) IF(ICFG.GT.IDMTST(13)) CALL RECOV1(13,ICFG) IF(IPLACE.EQ.-1) IPLACE=0 IF(IPUNCH.LE.0) GO TO 18 NPUNCH=IPUNCH CALL CONSTO WRITE(IWRITE,1009) C 18 NCFGT=ICFGT RETURN END C*********************************************************************** SUBROUTINE CONPED C C TO DETERMINE THE POSSIBLE ELECTRON DISTRIBUTIONS CONSISTENT WITH C PARITY ETC. C COMMON/CONACT/MACT( 21),MNT( 21),JACT,J1QN( 21,3) COMMON/CUPPLE/NOPTN,MNAL( 21),MXAL( 21),IBASSH( 148, 21), 1 NXCITE( 148),JREAD,LOCSH( 148) ! '05Feb LOC restored COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/INFORM/IREAD,IWRITE,IPUNCH C 1000 FORMAT(//38H *** RUNAWAY-STOP IN CONPED -- NCON =,I6,5H ***//) C JACT=0 C C TEST FOR EMPTY EXCITED SHELLS AND PARITY C L = 0 DO 3 I=1,NSTOP M=MN(I) IF(M.LT.MNAL(I)) GO TO 13 IF(M.LE.0) GO TO 3 JACT=JACT+1 ! ACTive shells MACT(JACT)=I MNT(JACT)=M L = LJ(I)*M+L 3 CONTINUE IF(MOD(L,2).NE.IPTY) GO TO 13 IF(MN(NSTOP).EQ.0) GO TO 13 C C TEST FOR EXCITATION ALLOWED FROM THE BASIC CONFIGURATIONS C IF(NOPTN.LE.0) GO TO 11 6 DO 10 M=1,NOPTN NEX=0 *C-SP IF(MA.LT.MB) NEX=NEX+MB-MA -- RUB'94FEB28: PASCHI-MODIFICATION: * 7 NEX=ABS(IBASSH(M,I)-MN(I))+NEX DO 7 I=1,LOCSH(M) ! '05Feb11: modification a la OP-stg2.u of 1994 MA=MN(I) MB=IBASSH(M,I) IF (I.GT.NSTOP) THEN NEX = NEX+MB ELSE IF (MA.LT.MB) THEN NEX=NEX+MB-MA ENDIF 7 CONTINUE IF(NEX.LE.NXCITE(M)) GO TO 11 ! M)*2 ? 10 CONTINUE GO TO 13 C C LIMIT SET ON NCON TO AVOID POSSIBLE RUN-AWAY C 11 NCON=NCON+1 IF(NCON.LE.2999) GO TO 12 ! from 1000 '02Feb17 WRITE(IWRITE,1000)NCON STOP C 12 CALL CONQN 13 RETURN END C*********************************************************************** SUBROUTINE CONQN C C TO DETERMINE THE QUANTUM NUMBERS FOR EACH SHELL C--------------------------------------------------------------------- C C EXTENDED TO COPE WITH 2 ELECTRONS IN L>2 SHELLS. C C (NO NEED TO EXTEND THE /TERMS/ ARRAYS, SINCE THESE ARE USED IN THE C FANO PACKAGE BY FUNCTION NTAB1, WHERE ONLY PARENTS ARE CONSIDERED, C AND PARENTS WILL STILL HAVE NO MORE THAN 1 ELECTRON IN L>2 SHELLS. C C---------------------------------------------------------------------- C DIMENSION IFSH( 21),MXS( 21),MCS( 21),NI( 21), LS(11) COMMON/CONACT/MACT( 21),MNT( 21),JACT,J1QN( 21,3) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/TERMS/ NROWS,L(18),J(18),N(189) DATA LS/1,3,6,11,12,13,14,15,16,17,18/ C DO 3 I=1,JACT NN=MACT(I) LL=LJ(NN) LL1=LL+LL+1 LK1=LL+1 M=MNT(I) K=M IF(M.GT.LL1) K=2*LL1-M IF(K.EQ.0) GO TO 1 C-------------------------------------------------------------------- IF(LL.GE.3.AND.K.EQ.2) THEN MXS(I)=LL1 MCS(I)=-1 GO TO 3 ENDIF C------------------------------------------------------------------- IFSH(I)=LS(LK1)+K-1 GO TO 2 1 IFSH(I)=2 2 KI=IFSH(I) MXS(I)=L(KI) MCS(I)=J(KI) 3 CONTINUE C C LOOP OVER THE ALLOWED QUANTUM NUMBERS FOR EACH SHELL C I=0 4 I=I+1 NI(I)=0 5 NI(I)=NI(I)+1 C------------------------------------------------------------------ IF(MCS(I).EQ.-1) THEN J1QN(I,1)=2 IF(NI(I).EQ.1) J1QN(I,1)=0 J1QN(I,2)=2*NI(I)-1 J1QN(I,3)=1 IF(MOD(NI(I),2).EQ.0) J1QN(I,3)=3 IF(I-JACT) 4,6,8 ! not in OSC-IP/stg2.u!? '05Feb11 ENDIF C---------------------------------------------------------------- MI=MCS(I)+(NI(I)-1)*3 J1QN(I,1)=N(MI+1) J1QN(I,2)=N(MI+2) J1QN(I,3)=N(MI+3) IF(I-JACT) 4,6,8 6 CALL CONSH 7 IF(NI(I).LT.MXS(I)) GO TO 5 I=I-1 IF(I) 8,8,7 C 8 RETURN END C*********************************************************************** SUBROUTINE CONSH C C TO DETERMINE THE COUPLING BETWEEN THE SHELLS C LOGICAL OK DIMENSION LI( 21),LLL( 21),LLH( 21),LSP( 21),LSL( 21), * LSH( 21) COMMON/CONACT/MACT( 21),MNT( 21),JACT,J1QN( 21,3) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C JACTM1=JACT-1 IF(JACTM1.GT.0) GO TO 1 CALL CONTST(OK) IF(OK) CALL CONSTO RETURN C 1 DO 2 I=1,JACTM1 2 J1QN1(I,1)=0 LS0=J1QN(1,3)-1 LL0=(J1QN(1,2)-1)/2 LLL(1)=ABS(LL0-(J1QN(2,2)-1)/2) LLH(1)=LL0+(J1QN(2,2)-1)/2+1 LSL(1)=ABS(LS0-J1QN(2,3)+1)-1 LSH(1)=LS0+J1QN(2,3) C C LOOP OVER ALL POSSIBLE COUPLINGS BETWEEN THE SHELLS C I=0 3 I=I+1 LI(I)=LLL(I) 4 LI(I)=LI(I)+1 LLI=LI(I)-1 J1QN1(I,2)=2*LLI+1 IF(I.GE.JACTM1) GO TO 6 LLL(I+1)=ABS(LLI-(J1QN(I+2,2)-1)/2) LLH(I+1)=LLI+(J1QN(I+2,2)-1)/2+1 6 LSP(I)=LSL(I) 7 LSP(I)=LSP(I)+2 LSI=LSP(I)-1 J1QN1(I,3)=LSI+1 IF(I-JACTM1) 9,8,11 8 CALL CONTST(OK) IF(OK) CALL CONSTO GO TO 10 9 LSL(I+1)=ABS(LSI-J1QN(I+2,3)+1)-1 LSH(I+1)=LSI+J1QN(I+2,3) GO TO 3 10 IF(LSP(I).LT.LSH(I)) GO TO 7 IF(LI(I).LT.LLH(I)) GO TO 4 I=I-1 IF(I.GT.0) GO TO 10 C 11 RETURN END C*********************************************************************** SUBROUTINE CONSTO C C TO READ/WRITE/STORE/PUNCH THE CONFIGURATION DATA. C LOGICAL OK,OMIT PARAMETER (LL41= 15*2-1) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/CONACT/MACT( 21),MNT( 21),JACT,J1QN( 21,3) COMMON/CUT/ NCUT,IKIP(9000),JOCCSH(9000), ITYP(9000) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/RECOV/ IPLACE,IDMTST(50) C 1001 FORMAT(/14H CONFIGURATION,I5) 1002 FORMAT(6X,21HOCCUPIED ORBITALS ARE,32X,20I3) 1003 FORMAT(6X,49HNUMBER OF ELECTRONS IN RESPECTIVE OCCUPIED SHELLS, 1 4X,20I3) 1004 FORMAT(6X,15HCOUPLING SCHEME/(T2,9(3X,3I3))) 1006 FORMAT(7X,8(3X,3I3)) 1007 FORMAT(/25H CONFIGURATION NOT STORED) C C THE FOLLOWING FORMAT STATEMENT IS USED TO READ/PUNCH CARD DATA C 2000 FORMAT(12I5) C C IF NREAD.GT.0 READ THE COUPLING SCHEME DATA FROM NREAD C IF(NPUNCH.GT.0) GO TO 21 IF(NREAD.EQ.0) GO TO 5 READ(NREAD,*) JCFG IF(JCFG.LE.0) GO TO 19 IF(JCFG.GT.IDMTST(28)) CALL RECOV1(28,JCFG) READ(NREAD,*) (JOCCSH(I),I=1,JCFG) 2 IF(NCUP.GE.JCFG) GO TO 30 NCUP=NCUP+1 JACT=JOCCSH(NCUP) IF(JACT.GT.IDMTST(11)) CALL RECOV1(11,JACT) READ(NREAD,*) (MACT(J),J=1,JACT) READ(NREAD,*) (MNT (J),J=1,JACT) IF(JACT.GT.1) GO TO 4 READ(NREAD,*) (J1QN(1,K),K=1,3) GO TO 6 4 READ(NREAD,*) ((J1QN(J,K),K=1,3),J=1,JACT), 1 ((J1QN1(J,K),K=1,3),J=1,JACT-1) C evasive action '05Feb12-13 for fatal input from CIV3 in VKL's C 2-electron case Li+ declaring empty 1s shells as ACTive: if(MNT(1).ne.0) go to 6 JACT=JACT-1 JOCCSH(NCUP)=JACT do 3 J=1,JACT MNT(J)=MNT(J+1) MACT(J)=MACT(J+1) do 3 K=1,3 IF(J.GT.1) J1QN1(J,K)=J1QN1(J+1,K) ! evtl if NELC.gt.2 3 J1QN(J,K)=J1QN(J+1,K) GO TO 6 C C IF NCUT.GT.0 STORE ONLY THOSE CONFIGURATIONS WITH IKIP(NCUP)=1 C 5 IF(IOPTN.EQ.-2) GO TO 21 NCUP=NCUP+1 6 IF(NCUT.LE.0) GO TO 9 7 IF(NCUP.GT.NCUT) GO TO 8 IF(IKIP(NCUP).EQ.1) GO TO 9 8 OMIT=.TRUE. GO TO 10 9 OMIT=.FALSE. ICFG=ICFG+1 ICFGT=ICFGT+1 C C IF NWRITE.GT.0 PRINT THE COUPLING SCHEME DATA C 10 IF(NWRITE.LE.0) GO TO 15 11 IF(OMIT) GO TO 12 WRITE(NWRITE,1001)ICFG GO TO 13 12 WRITE(NWRITE,1007) 13 WRITE(NWRITE,1002)(MACT(J),J=1,JACT) WRITE(NWRITE,1003)(MNT (J),J=1,JACT) WRITE(NWRITE,1004) ((J1QN(J,K),K=1,3),J=1,JACT) IF(JACT.LE.1) GO TO 15 WRITE(NWRITE,1006)((J1QN1(J,K),K=1,3),J=1,JACT-1) C C IF OMIT=.FALSE. STORE THE COUPLING SCHEME DATA IN /BNDCON/ C 15 IF(OMIT) GO TO 19 IF(ICFGT.GT.IDMTST(28)) CALL RECOV1(28,ICFGT) ! '07Mar28 IF(ICFG.LE.IDMTST(28)) JOCCSH(ICFG)=JACT IF(ICFG.GT.IDMTST(13)) GO TO 19 ITYP(ICFGT)=ICFG IOCCSH(ICFG)=JACT IF(JACT.GT.IDMTST(11)) CALL RECOV1(11,JACT) IF(JACT.GT.IDMTST(11)) GO TO 19 DO 18 J=1,JACT IOCORB(J,ICFG)=MACT(J) IELCSH(J,ICFG)=MNT(J) DO 17 K=1,3 IF(J.LT.JACT) I1QNRD(J+JACT,K,ICFG)=J1QN1(J,K) 17 I1QNRD(J,K,ICFG)=J1QN(J,K) 18 CONTINUE C 19 NCFGP=ICFG 20 IF(NREAD) 30,30,2 C C IF NPUNCH.GT.0 OR IOPTN=-2, FIND COUPLING SCHEME DATA IN /BNDCON/ C 21 IF(NPUNCH.GT.0) WRITE(NPUNCH,2000)ICFG IF(ICFG.LE.0) GO TO 30 IF(NPUNCH.GT.0) WRITE(NPUNCH,2000)(JOCCSH(I),I=1,ICFG) DO 29 I=1,ICFG JACT=IOCCSH(I) LP=0 DO 25 J=1,JACT MACT(J)=IOCORB(J,I) MNT (J)=IELCSH(J,I) DO 24 K=1,3 IF(J.LT.JACT) J1QN1(J,K)=I1QNRD(J+JACT,K,I) 24 J1QN(J,K)=I1QNRD(J,K,I) M=MACT(J) 25 LP=LP+LJ(M)*MNT(J) C IF(NPUNCH.GT.0) GO TO 26 IF(MOD(LP,2).NE.IPTY) GO TO 29 CALL CONTST(OK) IF(.NOT.OK) GO TO 29 ICFGT=ICFGT+1 ITYP(ICFGT)=I GO TO 29 26 WRITE(NPUNCH,2000)(MACT(J),J=1,JACT) WRITE(NPUNCH,2000)(MNT(J),J=1,JACT) WRITE(NPUNCH,2000)((J1QN(J,K),K=1,3),J=1,JACT), * ((J1QN1(J,K),K=1,3),J=1,JACT-1) 29 CONTINUE C 30 RETURN END C*********************************************************************** SUBROUTINE CONTST(OK) C C OK IS SET .TRUE. ONLY IF THE CONFIGURATION HAS THE TOTAL C ANGULAR MOMENTUM AND SPIN OF THE GIVEN STATE. C LOGICAL OK COMMON/CONACT/MACT( 21),MNT( 21),JACT,J1QN( 21,3) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ( 21),LJ( 21),MN( 21),MXN( 21),LA( 21), 2 J1QN1( 21,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C IF(JACT.LE.1) THEN LL=J1QN(JACT,2) LS=J1QN(JACT,3) ELSE LL=J1QN1(JACT-1,2) LS=J1QN1(JACT-1,3) ENDIF OK = LL-1.EQ.ITOTL*2 .AND. LS.EQ.ITOTS RETURN END C*********************************************************************** SUBROUTINE COPYTP(ITAPE) C C READS THE PERMANENT STG2 BINARY INPUT FILE ITAPE. C WHEN ITAPE=ITAPE2, THE INPUT FILE IS POSITIONED IN PREPARATION C FOR COPYING HAMILTONIAN MATRIX BLOCKS FROM ITAPE2 TO ITAPE3 IN C SETMX1 AND AIJS. C C IMPLICIT REAL*8(A-H,O-Z) DIMENSION COEFF(3, 49) PARAMETER (LL41= 15*2-1, LL59=1280*2, LL71= 60+1, LL75= 21+2) PARAMETER (MXD1= 60, MXD2=2500) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/ EIGENS( 60),ENDS( 49,LL71),DELTA,ETA COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/CASES/ MORE,MSKIP,IPOLPH,INAST COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/DIAG/ NDIAG,LRAN22 COMMON/DIPMEL/HNP1(LL53,LL53),DUMMY(LL53,LL53) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/POTORB/PV(LL59) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3),JRELOP(3) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) DIMENSION MAXNC( 49) C 1000 FORMAT(//52X,17HSUBROUTINE COPYTP/52X,17(1H-)) 1001 FORMAT(29H READ OF BASIC DATA COMPLETED) 1002 FORMAT(13H PARTIAL-WAVE,I3,16H HAS BEEN COPIED) 1003 FORMAT(/7H LRGL =,I3,8H NSPN =,I3,8H NPTY =,I3,9H NCFGP =,I5, 1 8H IPOLPH=,I2) 1004 FORMAT(/32H THERE IS NO MORE DATA ON ITAPE3) 1005 FORMAT(7H NELC =,I3,6H NZ =,I3,10H LRANG1 =,I3,10H LRANG2 =,I3, 1 10H NRANG2 =,I3,9H LAMAX =,I3,7H LAM =,I2) 1006 FORMAT(/97H THE INPUT ON ITAPE2 MAY BE IN THE FORMAT OF THE 1974 V 1ERSION OF STG2 ... IF SO, USE ITAPE2.GE.20/) C C ICOUNT IS A COUNT ON THE DATA BLOCKS ON TAPE. C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM TAPE, CALL RECOV1 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C ICOUNT=1 IF(ITOTAL.LE.0) RETURN IPLACE=0 WRITE(IWRITE,1000) REWIND ITAPE C C READ THE BASIC DATA FROM TAPE C READ(ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,NPOT *,(JRELOP(I),I=1,3) LRAN22=LRANG2 IF(LRANG1.GT.IDMTST(16)) WRITE(IWRITE,1006) WRITE(IWRITE,1005)NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM IF(LRANG1.GT.IDMTST(16)) CALL RECOV1(16,LRANG1) IF(LRANG2.GT.IDMTST(15)) CALL RECOV1(15,LRANG2) IF(NRANG2.GT.IDMTST(7)) CALL RECOV1(7,NRANG2) IF(LAMAX.GT.IDMTST(18)) CALL RECOV1(18,LAMAX) READ(ITAPE) (MAXNHF(L),L=1,LRANG1),(MAXNLG(L),L=1,LRANG1) *,(MAXNC(L),L=1,LRANG1) DO 1 L=1,LRANG2 READ(ITAPE) (EIGENS(N),N=1,NRANG2) READ(ITAPE) (ENDS(L,N),N=1,NRANG2) 1 CONTINUE READ(ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX IF(NIX.GT.IDMTST(17)) CALL RECOV1(17,NIX) READ(ITAPE) (IHX(I),I=1,NIX),(IRX(I),I=1,NIX) IF(IRX(NIX).GT.IDMTST(9)) CALL RECOV1(9,IRX(NIX)) IPTS=2*IRX(NIX) READ(ITAPE) (PV(I),I=1,IPTS) DO 4 LP=1,LRANG1 NBT=MAXNLG(LP)-LP+1 IF(NBT.LE.0) GO TO 4 IF(NBT.GT.IDMTST(28)) CALL RECOV1(28,NBT) DO 3 K=1,NBT 3 READ(ITAPE) (PV(I),I=1,IPTS) 4 CONTINUE READ(ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) C 7 WRITE(IWRITE,1001) READ(ITAPE) NAST NDIAG=0 IF(NAST.LT.0) THEN NDIAG=1 NAST=-NAST ENDIF IF(NAST.GT.IDMTST(14)) CALL RECOV1(14,NAST) READ(ITAPE) (ENAT(I),I=1,NAST),(LAT(I),I=1,NAST), 1 (ISAT(I),I=1,NAST),(IPTY(I),I=1,NAST) IF(JRELOP(3).NE.0) THEN READ(ITAPE) NCFG,(NOCCSH(I),I=1,NCFG) DO 23 I=1,NCFG IL=NOCCSH(I) ILL=2*IL-1 23 READ(ITAPE) (NOCORB(J,I),J=1,IL),(NELCSH(J,I),J=1,IL), * ((J1QNRD(J,K,I),K=1,3),J=1,ILL) READ(ITAPE) MAXORB,(NJCOMP(J),J=1,MAXORB),(LJCOMP(J),J=1,MAXORB) READ(ITAPE) (NTCON(J),J=1,NAST) DO 24 I=1,NAST NT=NTCON(I) 24 READ(ITAPE) (NTYP(I,J),J=1,NT),(AIJ(I,J),J=1,NAST) ENDIF IF(ICOUNT.GE.ICOPY1-1) GO TO 21 IF(ICOUNT.GE.ITOTAL) GO TO 21 8 ICOUNT=ICOUNT+1 C C THE FOLLOWING DATA DEPENDS ON LRGL, NSPN ETC. C 9 READ(ITAPE) LRGL,NSPN,NPTY,NCFGP,NPOLPH WRITE(IWRITE,1003)LRGL,NSPN,NPTY,NCFGP,NPOLPH READ(ITAPE) MNP1,NCONHP,NCHAN IF(NCHAN.GT.IDMTST(5)) CALL RECOV1(5,NCHAN) READ(ITAPE) (NCONAT(I),I=1,NAST) READ(ITAPE) (L2P(I),I=1,NCHAN) READ(ITAPE) MORE C C READ THE HAMILTONIAN MATRIX C C READ CONTINUUM-CONTINUUM BLOCKS INTO HNP1 C DO 11 M=1,NCHAN DO 10 L=1,M 10 READ(ITAPE) ((HNP1(I,J),J=1,NRANG2),I=1,NRANG2) 11 CONTINUE WRITE(IWRITE,1002)ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 21 IF(ICOUNT.GE.ITOTAL) GO TO 21 ICOUNT=ICOUNT+1 IF(NCFGP) 18,18,13 C C READ BOUND-CONTINUUM BLOCKS INTO HNP1 C 13 IF(NCFGP.GT.IDMTST(13)) CALL RECOV1(13,NCFGP) DO 14 M=1,NCHAN 14 READ(ITAPE) ((HNP1(I,J),J=1,NCFGP),I=1,NRANG2) WRITE(IWRITE,1002)ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 21 IF(ICOUNT.GE.ITOTAL) GO TO 21 ICOUNT=ICOUNT+1 C C READ BOUND-BOUND ELEMENTS INTO HNP1 C DO 16 I=1,NCFGP 16 READ(ITAPE) (HNP1(1,J),J=I,NCFGP) WRITE(IWRITE,1002)ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 21 IF(ICOUNT.GE.ITOTAL) GO TO 21 ICOUNT=ICOUNT+1 C C READ THE ASYMPTOTIC COEFFICIENTS, IF NECESSARY. C 18 IF(LAMAX.GT.0) THEN DO 17 I=1,NCHAN 17 READ(ITAPE) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) ENDIF WRITE(IWRITE,1002)ICOUNT IF(MORE) 20,20,19 19 IF(ICOUNT.GE.ICOPY1-1) GO TO 21 IF(ICOUNT-ITOTAL) 8,21,21 20 WRITE(IWRITE,1004) ICOPY2=ICOUNT C 21 RETURN END C*********************************************************************** SUBROUTINE DA1(KEY,KOUNT,K) C C NOTE THAT EACH BLOCK ON THE DA FILE IS OF LENGTH NRANG2**2, C AND THAT THERE ARE AT MOST (IDMTST(5)*(IDMTST(5)+1))/2 BLOCKS. C C KEY=0 TO INITIALIZE FILE (KOUNT=POSITION IN FILE, AND WILL BE C INITIALIZED, K**2=BLOCK LENGTH) C = 1 WRITE ONE BLOCK TO FILE (KOUNT=POSITION IN FILE, AND WILL C BE DEFINED, K=BLOCK IN HNPS) C =-1 READ ONE BLOCK FROM FILE (KOUNT=POSITION IN FILE, AND IS C INPUT, K=BLOCK IN HNPS) C C IMPLICIT REAL*8(A,S) PARAMETER (A0=1.,A1=1.E-9,IDA1=13, LL73= 6* 6) COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) SAVE LENGTH IF(KEY) 3,1,2 1 KOUNT=0 LENGTH=K IRECL = LENGTH*LENGTH*4 S=A0+A1 IF(S.NE.A0) IRECL=IRECL*2 OPEN(UNIT=IDA1,STATUS='SCRATCH',ACCESS='DIRECT',RECL=IRECL) RETURN 2 KOUNT=KOUNT+1 WRITE(IDA1,REC=KOUNT) ((HNPS(I,J,K),I=1,LENGTH),J=1,LENGTH) RETURN 3 READ(IDA1,REC=KOUNT) ((HNPS(I,J,K),I=1,LENGTH),J=1,LENGTH) RETURN END C*********************************************************************** SUBROUTINE DA2(KEY,IREC,JDISC,LENGTH,ARRAY) C C TO STORE A LARGE ARRAY IN A DA FILE. CRAY VERSION. C C KEY = 1 FOR READ, = 2 FOR WRITE, C = 0 FOR FINDING NUMBER OF DA RECORDS A GIVEN ARRAY TAKES. C IREC= (ON CALL) POINTER TO FIRST DA RECORD FOR ARRAY, C = 0 FOR OPENING DA FILE, C = (ON RETURN) POINTER TO NEXT AVAILABLE DA RECORD. C JDISC = DA FILE UNIT NUMBER. C ARRAY(LENGTH) = ARRAY TO READ OR WRITE. C C IMPLICIT REAL*8(A,S) CHARACTER STA*3 PARAMETER (A0=1.,A1=1.E-9, LREC=512) DIMENSION ARRAY(LENGTH) C IF(IREC.GT.0) GO TO 10 IRECL = LREC*4 S=A0+A1 IF(S.NE.A0) IRECL=LREC*8 STA='OLD' IF(KEY.EQ.2) STA='NEW' OPEN(JDISC,STATUS=STA,FILE='RK',ACCESS='DIRECT',RECL=IRECL) IREC=1 C 10 IF(LENGTH.EQ.0) RETURN I2=0 20 I1=I2+1 I2=MIN(I2+LREC,LENGTH) IF(KEY.EQ.0) GO TO 30 IF(KEY.EQ.2) THEN WRITE(JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ELSE READ(JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ENDIF 30 IREC=IREC+1 IF(I2.LT.LENGTH) GO TO 20 RETURN END C*********************************************************************** SUBROUTINE DH0 C IMPLICIT REAL*8(A-H,O-Z) C C THERE ARE SEVERAL VERSIONS OF THIS SUBROUTINE C THIS VERSION IS FOR THE R-MATRIX PROGRAM C C EVALUATES THE ONE-ELECTRON INTEGRALS WHEN THE CONFIGURATIONS C ARE IDENTICAL C PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/CONMX/ H0MAT( 60, 60),VMAT( 60, 60) COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT C IHSHM1 = IHSH-1 H0SUM = 0.0 IF(IHSH.EQ.1) GO TO 2 C C FINDS AND SUMS ALL INTEGRALS TO THE BOUND ORBITALS IF ANY C DO 1 J=1,IHSHM1 NOSHIJ = NOSH1(J) IF(NOSHIJ.EQ.0) GO TO 1 N1=NJ(J) L1=LJ(J)+1 CALL FIN1BB(N1,N1,L1,ALBVAL) TIMES = NOSHIJ H0SUM = H0SUM+ALBVAL*TIMES 1 CONTINUE C C NOW CALCULATE THE INTEGRAL FOR THE LAST ORBITAL C 2 N1 = NJ(IHSH) L1=LJ(IHSH)+1 TIMES = NOSH1(IHSH) IF(N1.EQ.999) GO TO 3 C C THE LAST ORBITAL IS BOUND C CALL FIN1BB(N1,N1,L1,ALBVAL) H0MAT(1,1) = H0SUM+ALBVAL*TIMES RETURN C C THE LAST ORBITAL IS CONTINUUM. FORM THE DIAGONAL ELEMENTS OF HOMAT C 3 DO 4 I=1,ILIMIT N2=ND(1,I) CALL FIN1CC(N2,N2,L1,ALBVAL) 4 H0MAT(I,I)=H0SUM+ALBVAL*TIMES C RETURN END C*********************************************************************** SUBROUTINE DMEL C C CALCULATES THE DIPOLE MATRIX ELEMENTS IN LENGTH FORM AND VELOCITY C FORM BETWEEN AN INITIAL AND FINAL STATE BOTH EXPRESSED IN TERMS C OF A CONTINUUM BASIS PLUS BOUND TERMS. THESE ARE WRITTEN TO C TAPE IN BLOCKS DML AND DMV RESPECTIVELY, BEING REQUIRED IN C POLARIZABILITY AND PHOTOIONISATION CALCULATIONS IN STG3. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (ISPIN=0) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) PARAMETER (LL61= 15+1, LL68= 8/2, LL73= 6* 6, LL75= 21+2) C DIMENSION AXL( 60),AXV( 60), VSHELL(LL75) DIMENSION AC( 520, 520),BLC( 520, 520),BVC( 520, 520), CGC(0:19) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/BNDINI/MCFGP,JOCCSH(2500),JOCORB( 15,2500), * JELCSH( 15,2500),L1QNRD(LL41,3,2500) COMMON/CASES/ MORE,MSKIP,IPOLPH,INAST COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1000 FORMAT(///53X,15HSUBROUTINE DMEL/53X,15(1H-)//76H CALCULATE AND ST *ORE (ON THE OUTPUT DATA TAPE) THE RADIATIVE MATRIX ELEMENTS) 1001 FORMAT(8F15.7) 1002 FORMAT(//) 1003 FORMAT(//9X,66HCONTINUUM-CONTINUUM MULTIPOLE LENGTH M.E. FROM FINA *L STATE CHANNEL,I4/50X,25HAND INITIAL STATE CHANNEL,I4/) 1004 FORMAT( 10X,65HCONTINUUM-CONTINUUM DIPOLE VELOCITY M.E. FROM FINAL * STATE CHANNEL,I4/50X,25HAND INITIAL STATE CHANNEL,I4/) 1005 FORMAT(//6X,59HCONTINUUM-BOUND DIPOLE LENGTH M.E. FROM FINAL STATE * CHANNEL,I4/) 1006 FORMAT(6X,61HCONTINUUM-BOUND DIPOLE VELOCITY M.E. FROM FINAL STATE * CHANNEL,I4/) 1007 FORMAT(//6X,61HBOUND-CONTINUUM DIPOLE LENGTH M.E. FROM INITIAL STA *TE CHANNEL,I4/) 1008 FORMAT( 6X, 63HBOUND-CONTINUUM DIPOLE VELOCITY M.E. FROM INITIAL * STATE CHANNEL,I4/) 1009 FORMAT(//5X,41HBOUND-BOUND DIPOLE LENGTH MATRIX ELEMENTS/) 1010 FORMAT(5X,43HBOUND-BOUND DIPOLE VELOCITY MATRIX ELEMENTS/) 1011 FORMAT(//6X,59HCONTINUUM-CONTINUUM MULTIPOLE M.E. FROM FINAL STATE * CHANNEL,I4/40X,25HAND INITIAL STATE CHANNEL,I4,10H ARE ZERO//) 1013 FORMAT(/57H RADIATIVE MATRIX ELEMENTS NOW STORED ON OUTPUT DATA TA *PE) 1014 FORMAT(/ 19X,14HFINAL STATE (,I2,1H),21X,16HINITIAL STATE (,I2, * 1H)/4X,6HLRGL =,I3,9H NSPN =,I3,8H NPTY =,I3,7X,7HLLRGL =,I3, * 9H NNSPN =,I3,8H MPTY =,I3) C1015 FORMAT(/100H CANNOT FORM DIPOLE MATRIX ELEMENTS BETWEEN GIVEN FINA C *L AND INITIAL STATES- SELECTION RULES VIOLATED) 1016 FORMAT(/8H MAXM0 =,I2,7H CGC =,(T18,5F12.7)) 1017 FORMAT(/' THE A COEFFICIENTS'/) 1018 FORMAT(/' THE B LENGTH COEFFICIENTS'/) 1019 FORMAT(/' THE B VELOCITY COEFFICIENTS'/) C WRITE(IWRITE,1000) C C C READ IN THE MULTIPOLE INTEGRALS FROM IDISC3 C REWIND IDISC3 READ(IDISC3) IRK8 IF(IRK8.LE.0) GO TO 78 READ(IDISC3) (RKSTO2(K),K=1,IRK8) C C READ DATA FROM SCRATCH DISC C REWIND IDISC4 DO 77 MJ=1,MSKIP MK=0 C C BLOCKS FROM SCRATCH DISC ARE READ IN AND OVERWRITTEN IN CORE C UNTIL THE BLOCKS CORRESPONDING TO THE REQUIRED SETS OF TOTAL C ORBITAL ANGULAR MOMENTUM, SPIN AND PARITY ARE LOCATED. C DO 75 MI=1,MJ C C DATA DEFINING IONIC STATES CORRESPONDING TO THE INITIAL STATE C ARE READ FROM DISC. THE DIMENSIONS OF ARRAYS IN /INITI/ ARE THE C SAME AS THOSE OF THE EQUIVALENT ARRAYS IN /CUPMAT/ AND /STATED/. C 1 READ(IDISC4) MAST,(MTCON(I),I=1,MAST),(MCONAT(I),I=1,MAST), * LLRGL,NNSPN,MPTY MCHAN=0 DO 2 I=1,MAST NT=MTCON(I) NC=MCONAT(I) READ(IDISC4) (MTYP(I,J),J=1,NT),(BIJ(I,J),J=1,NT), * (KCONAT(J,I),J=1,NC) 2 MCHAN = NC+MCHAN C = TOTAL NUMBERS OF CHANNELS C C THE BOUND CONFIGURATIONS CORRESPONDING TO THE INITIAL STATE ARE C READ. THE DIMENSIONS OF ARRAYS IN /BNDINI/ ARE THE SAME AS C THOSE OF THE EQUIVALENT ARRAYS IN /BNDCON/. C READ(IDISC4) MCFGP,(JOCCSH(I),I=1,MCFGP) DO 3 I=1,MCFGP IL=JOCCSH(I) ILL=2*IL-1 READ(IDISC4) (JOCORB(J,I),J=1,IL),(JELCSH(J,I),J=1,IL), * ((L1QNRD(J,K,I),K=1,3),J=1,ILL) 3 CONTINUE IF (MK.NE.0) GO TO 9 C C DATA DEFINING IONIC STATES CORRESPONDING TO THE FINAL STATE C LRGL=LLRGL NSPN=NNSPN NPTY=MPTY NAST=MAST DO 6 I=1,NAST NC=MCONAT(I) NCONAT(I)=NC DO 5 J=1,NC 5 LCONAT(J,I)=KCONAT(J,I) NT=MTCON(I) NTCON(I)=NT DO 6 J=1,NT C BIJ(I,J) NTYP(I,J)=MTYP(I,J) 6 CONTINUE NCHAM=MCHAN C AND THE BOUND CONFIGURATIONS CORRESPONDING TO THE FINAL STATE: NCFGP=MCFGP DO 8 I=1,NCFGP IL=JOCCSH(I) IOCCSH(I)=IL ILL=2*IL-1 DO 7 J=1,ILL I1QNRD(J,1,I)=L1QNRD(J,1,I) I1QNRD(J,2,I)=L1QNRD(J,2,I) 7 I1QNRD(J,3,I)=L1QNRD(J,3,I) DO 8 J=1,IL IOCORB(J,I)=JOCORB(J,I) IELCSH(J,I)=JELCSH(J,I) 8 CONTINUE IF (MJ.EQ.1) GO TO 9 REWIND IDISC4 MK=1 GO TO 1 C C CHECK THE SELECTION RULES ARE SATISFIED C 9 IF(NSPN.NE.NNSPN) GO TO 75 LDA=1 IF (NPTY.EQ.MPTY) THEN IF(IPOLPH.LT.3) GO TO 75 LDA=2 ENDIF IF(LRGL+LLRGL.LT.LDA) GO TO 75 IF (ABS(LRGL-LLRGL).GT.LDA) GO TO 75 WRITE(IWRITE,1014) MJ,MI, LRGL,NSPN,NPTY, LLRGL,NNSPN,MPTY IF(LAM.EQ.1) GO TO 39 C C EACH CHANNEL COUPLED TO A SPECIFIC IONIC OR ATOMIC STATE TO GIVE C A FINAL STATE CONTRIBUTION IS CONSIDERED IN TURN. C LCS=0 DO 38 IA=1,NAST NCA=NCONAT(IA) IF(NCA.EQ.0) GO TO 38 DO 37 IAA=1,NCA LCH=LCS+IAA C C SIMILARLY EACH COUPLED CHANNEL GIVING AN INITIAL STATE C CONTRIBUTION IS LOOPED. C KCS=0 DO 20 IB=1,MAST MCA=MCONAT(IB) IF(MCA.EQ.0) GO TO 20 DO 19 IBB=1,MCA KCH=KCS+IBB C C MATRIX ELEMENTS BETWEEN THE CONTINUUM BASIS COFIGURATIONS FOR THE C INITIAL AND FINAL STATES ARE CALCULATED. C CALL DMELCC(LDA,ISPIN,IA,IAA,IB,IBB,IVSH,ACOEF,BLCOEF,BVCOEF) C C PLACE THE A AND B COEFFICIENTS IN APPROPRIATE PLACES IN THE AC C BLC AND BVC ARRAYS C AC(LCH,KCH) = ACOEF BLC(LCH,KCH)= BLCOEF BVC(LCH,KCH)= BVCOEF C C THE BLOCKS OF MATRIX ELEMENTS ARE WRITTEN TO TAPE AND PRINTED OUT C WRITE(ITAPE4)((DEL(I,J),J=1,NRANG2),I=1,NRANG2) WRITE(ITAPE4)((DEV(I,J),J=1,NRANG2),I=1,NRANG2) IF(IBUG8.EQ.0) GO TO 19 IF(IVSH .EQ.0) GO TO 18 C WRITE(IWRITE,1003) LCH,KCH JUP=0 14 JLO=JUP+1 JUP=MIN(JUP+8,NRANG2) DO 15 I=1,NRANG2 15 WRITE(IWRITE,1001) (DEL(I,J),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.NRANG2) GO TO 14 WRITE(IWRITE,1004) LCH,KCH JUP=0 16 JLO=JUP+1 JUP=MIN(JUP+8,NRANG2) DO 17 I=1,NRANG2 17 WRITE(IWRITE,1001) (DEV(I,J),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.NRANG2) GO TO 16 GO TO 19 18 WRITE(IWRITE,1011) LCH,KCH 19 CONTINUE KCS=KCS+MCA 20 CONTINUE C C MCHAN EQUALS TOTAL NUMBER OF CHANNELS IN THE INITIAL STATE C IF(MCHAN.NE.KCS) PRINT *,'MCHAN(YY)=',MCHAN,'KCS(KTT)=',KCS MCHAN = KCS C C C MATRIX ELEMENTS BETWEEN THE CONTINUUM BASIS CONFIGURATIONS FOR C THE FINAL STATE AND BOUND CONFIGURATIONS FOR THE INITIAL STATE C ARE CONSIDERED. FIRST, ARRAYS FOR THE BOUND CONFIGURATIONS ARE C SET UP. C IF(MCFGP.EQ.0) GOTO 35 DO 24 IM=1,MCFGP MOCCSH(IM)=JOCCSH(IM) IG=JOCCSH(IM) IG1=2*IG-1 DO 22 L=1,3 DO 22 K=1,IG1 22 M1QNRD(K,L,IM)=L1QNRD(K,L,IM) DO 23 K=1,IG MOCORB(K,IM)=JOCORB(K,IM) 23 MELCSH(K,IM)=JELCSH(K,IM) 24 CONTINUE C C THE CONTINUUM-BOUND MATRIX ELEMENTS ARE CALCULATED. C CALL DMELCB(LDA,ISPIN,IA,IAA) C C THE CONTINUUM-BOUND BLOCKS ARE WRITTEN TO TAPE AND PRINTED OUT C WRITE(ITAPE4) ((DEL(I,J),J=1,NRANG2),I=1,MCFGP ) WRITE(ITAPE4) ((DEV(I,J),J=1,NRANG2),I=1,MCFGP ) IF(IBUG8.EQ.0) GO TO 35 WRITE(IWRITE,1005) LCH JUP=0 25 JLO=JUP+1 JUP=MIN(JUP+8,NRANG2) DO 27 I=1,MCFGP 27 WRITE(IWRITE,1001) (DEL(I,J),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.NRANG2) GO TO 25 WRITE(IWRITE,1006) LCH JUP=0 30 JLO=JUP+1 JUP=MIN(JUP+8,NRANG2) DO 32 I=1,MCFGP 32 WRITE(IWRITE,1001) (DEV(I,J),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.NRANG2) GO TO 30 C C THE CONTINUUM-BUTTLE MATRIX ELEMENTS ARE CALCULATED. C 35 CALL DMELCD(LDA,ISPIN,IA,IAA) WRITE(ITAPE4)((DEL(I,J),I=1,NRANG2),J=1,MCHAN) WRITE(ITAPE4)((DEV(I,J),I=1,NRANG2),J=1,MCHAN) C 37 CONTINUE LCS=LCS+NCA 38 CONTINUE C C NCHAN EQUALS THE TOTAL NUMBER OF CHANNELS IN THE FINAL STATE C IF(NCHAM.NE.LCS) PRINT *,'NCHAM(YY)=',NCHAM,'LCS(KTT)=',LCS NCHAN = LCS C C MATRIX ELEMENTS BETWEEN THE BOUND CONFIGURATIONS FOR THE FINAL C STATE AND THE CONTINUUM BASIS CONFIGURATIONS FOR THE INITIAL C STATE ARE CONSIDERED. FIRST, SET UP ARRAYS FOR THE BOUND C CONFIGURATIONS. C 39 IF(NCFGP.EQ.0) GOTO 67 DO 42 IK=1,NCFGP KOCCSH(IK)=IOCCSH(IK) IE=IOCCSH(IK) IE1=2*IE-1 DO 40 L=1,3 DO 40 KE=1,IE1 40 K1QNRD(KE,L,IK)=I1QNRD(KE,L,IK) DO 41 K=1,IE KOCORB(K,IK)=IOCORB(K,IK) 41 KELCSH(K,IK)=IELCSH(K,IK) 42 CONTINUE IF(LAM.EQ.1) GO TO 57 C C THE BOUND-CONTINUUM MATRIX ELEMENTS ARE CALCULATED C KCS=0 DO 56 IB=1,MAST MCA=MCONAT(IB) IF(MCA.EQ.0) GOTO 56 DO 55 IBB=1,MCA KCH=KCS+IBB CALL DMELBC(LDA,ISPIN,IB,IBB) C C THE BOUND-CONTINUUM BLOCKS ARE WRITTEN TO TAPE AND PRINTED OUT C WRITE(ITAPE4)((DEL(J,I),J=1,NCFGP ),I=1,NRANG2) WRITE(ITAPE4)((DEV(J,I),J=1,NCFGP ),I=1,NRANG2) IF(IBUG8.EQ.0) GO TO 55 WRITE(IWRITE,1007) KCH JUP=0 45 JLO=JUP+1 JUP=MIN(JUP+8,NCFGP) DO 47 I=1,NRANG2 47 WRITE(IWRITE,1001)(DEL(J,I),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.NCFGP) GO TO 45 48 WRITE(IWRITE,1008) KCH JUP=0 50 JLO=JUP+1 JUP=MIN(JUP+8,NCFGP) DO 53 I=1,NRANG2 53 WRITE(IWRITE,1001)(DEV(J,I),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.NCFGP) GO TO 50 55 CONTINUE KCS=KCS+MCA 56 CONTINUE C C ARRAYS FOR THE BOUND CONFIGURATIONS OF THE INITIAL STATE ARE SET C UP AND THE BOUND-BOUND MATRIX ELEMENTS CALCULATED. C 57 IF(MCFGP.EQ.0) GOTO 66 DO 60 IM=1,MCFGP MOCCSH(IM)=JOCCSH(IM) IG=JOCCSH(IM) IG1=2*IG-1 DO 58 K=1,IG1 DO 58 L=1,3 58 M1QNRD(K,L,IM)=L1QNRD(K,L,IM) DO 59 K=1,IG MOCORB(K,IM)=JOCORB(K,IM) 59 MELCSH(K,IM)=JELCSH(K,IM) 60 CONTINUE MAXOR=MAXORB C C IF NCFGP EXCEEDS THE VALUE OF NRANG2, THE SECOND DIMENSION OF C THE DEL AND DEV ARRAYS, CALCULATE AND STORE THE MATRIX ELEMENTS C IN BLOCKS. C NDIMEN=NRANG2 NTIMES=1+(NCFGP-1)/NDIMEN I2=0 DO 65 M=1,NTIMES I1=I2+1 I2=MIN(M*NDIMEN,NCFGP) CALL DMELBB(LDA,ISPIN,I1,I2) C C THE BOUND-BOUND BLOCKS ARE WRITTEN TO TAPE AND PRINTED OUT. C I3=I2-I1+1 WRITE(ITAPE4)((DEL(I,J),J=1,I3 ),I=1,MCFGP ) WRITE(ITAPE4)((DEV(I,J),J=1,I3 ),I=1,MCFGP ) IF(IBUG8.EQ.0) GO TO 65 WRITE(IWRITE,1009) JUP=0 61 JLO=JUP+1 JUP=MIN(JUP+8,I3) DO 62 I=1,MCFGP 62 WRITE(IWRITE,1001) (DEL(I,J),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.I3) GO TO 61 WRITE(IWRITE,1010) JUP=0 63 JLO=JUP+1 JUP=MIN(JUP+8,I3) DO 64 I=1,MCFGP 64 WRITE(IWRITE,1001) (DEV(I,J),J=JLO,JUP) WRITE(IWRITE,1002) IF(JUP.LT.I3) GO TO 63 65 CONTINUE C C THE BOUND-BUTTLE MATRIX ELEMENTS ARE CALCULATED. C 66 IF(LAM.EQ.1) GO TO 67 CALL DMELBD(LDA,ISPIN) WRITE(ITAPE4)((DEL(I,J),I=1,NCFGP),J=1,MCHAN) WRITE(ITAPE4)((DEV(I,J),I=1,NCFGP),J=1,MCHAN) C C THE BUTTLE-CONTINUUM MATRIX ELEMENTS ARE CALCULATED. C 67 IF(LAM.EQ.1) GO TO 75 DO 68 IB=1,MAST DO 68 IBB=1,MCONAT(IB) CALL DMELDC(LDA,ISPIN,IB,IBB) WRITE(ITAPE4)((DEL(I,J),I=1,NCHAM),J=1,NRANG2) 68 WRITE(ITAPE4)((DEV(I,J),I=1,NCHAM),J=1,NRANG2) C C THE BUTTLE-BOUND MATRIX ELEMENTS ARE CALCULATED. THIS BLOCK C IS TRANSPOSED IN DEL AND DEV TO AVOID DIMENSION OVERFLOWS. C IF(MCFGP.EQ.0) GOTO 69 CALL DMELDB(LDA,ISPIN) WRITE(ITAPE4)((DEL(J,I),I=1,NCHAM),J=1,MCFGP) WRITE(ITAPE4)((DEV(J,I),I=1,NCHAM),J=1,MCFGP) C C THE BUTTLE-BUTTLE MATRIX ELEMENTS ARE CALCULATED. C 69 CALL DMELDD(LDA,ISPIN) WRITE(ITAPE4)((DEL(I,J),I=1,NCHAM),J=1,MCHAN) WRITE(ITAPE4)((DEV(I,J),I=1,NCHAM),J=1,MCHAN) C C EVALUATE THE CLEBSCH-GORDAN COEFFICIENTS REQUIRED IN THE C POLARIZABILITY CALCULATION IN STG3 C MAXM0 = MIN(LRGL,LLRGL) DO 70 M=0,MAXM0 70 CGC(M) = CG(LLRGL,LDA,LRGL,M,0,M)/SQRT(REAL(LRGL+LRGL+1)) WRITE(ITAPE4) MAXM0+1,(CGC(M),M=0,MAXM0) C C WRITE TO ITAPE4 THE ARRAYS OF A AND B COEFFICIENTS NECESSARY C FOR THE EVALUATION OF THE DIPOLE MATRIX ELEMENT CONTRIBUTION C FROM OUTSIDE THE R-MATRIX BOUNDARY C WRITE(ITAPE4) ((AC( I, J), J =1,MCHAN),I =1,NCHAN) WRITE(ITAPE4) ((BLC(I, J), J =1,MCHAN),I =1,NCHAN) WRITE(ITAPE4) ((BVC(I, J), J =1,MCHAN),I =1,NCHAN) IF(IBUG8 .EQ. 0) GO TO 75 WRITE(IWRITE,1016) MAXM0, (CGC(M),M=0,MAXM0) WRITE(6,1017) DO 71 I = 1, NCHAN 71 WRITE(6,1001) (AC(I,J), J = 1,MCHAN) WRITE(6,1018) DO 72 I = 1, NCHAN 72 WRITE(6,1001) (BLC(I,J), J = 1,MCHAN) WRITE(6,1019) DO 73 I = 1, NCHAN 73 WRITE(6,1001) (BVC(I,J), J = 1,MCHAN) WRITE(6,1002) 75 CONTINUE 77 CONTINUE C WRITE(IWRITE,1013) 78 RETURN END C*********************************************************************** SUBROUTINE DMELBB(LDA,ISPIN,I1,I2) C C CALCULATES THE BOUND-BOUND DIPOLE MATRIX ELEMENTS C C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN. C I1 AND I2 ARE THE FIRST AND LAST ELEMENTS IN THE CURRENT BLOCK. C PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (MXD1= 60,MXD2=2500) ! max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) PARAMETER (LL61= 15+1, LL68= 8/2, LL75= 21+2) C DIMENSION VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/BNDINI/MCFGP,JOCCSH(2500),JOCORB( 15,2500), * JELCSH( 15,2500),L1QNRD(LL41,3,2500) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 C COMMON/DIPMEL/DEL(&L53, 60),DEV(&L53, 60) -- OSU'03Mar28/31: COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1000 FORMAT(/41X,31HDEBUGGING PRINT OUT FROM DMELBB/) 1001 FORMAT(' FINAL BOUND CONFIGURATION',I5,', INITIAL BOUND CONFIGURAT *ION',I5/' irho,isig,VSHELL =',2I5,(T35,5F9.5)) 1002 FORMAT(45H THE RELEVANT B-B RADIAL DIPOLE INTEGRALS ARE,2F14.7) C IF(IBUG8.EQ.2) WRITE(IWRITE,1000) I3=0 C DO 2 IK=I1,I2 I3=I3+1 DO 1 IM=1,MCFGP DEL(IM,I3)=0.0 DEV(IM,I3)=0.0 IRHO=0 ISIG=0 CALL SETUPE(IM,IK,NJCOMP,LJCOMP) C print '(" setupe in B-B: (NJ,LJ) =",10I5)', (NJ(I),LJ(I),I=1,IHSH) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.ISIG) THEN IF(IRHO.EQ.0) GO TO 1 DO 3 I=1,IHSH IF (VSHELL(I).EQ.0.) GO TO 3 N=NJ(I) L=LJ(I) COEF=RME(L,L,LDA)*VSHELL(I) CALL FINMNT(N,L,N,L,LDA,XL,XV) DEL(IM,I3)=COEF*XL+DEL(IM,I3) DEV(IM,I3)=COEF*XV+DEV(IM,I3) 3 CONTINUE N=IHSH ELSE L1=LJ(IRHO) L2=LJ(ISIG) RMANG=RME(L1,L2,LDA) IF(ABS(RMANG).LT.TINY) GO TO 1 COEF = VSHELL(1)*RMANG CALL FINMNT(NJ(IRHO),L1,NJ(ISIG),L2,LDA,XL,XV) IF(IBUG8.EQ.2) WRITE(IWRITE,1002)XL,XV DEL(IM,I3)=COEF*XL DEV(IM,I3)=COEF*XV N=1 ENDIF IF(IBUG8.EQ.2) WRITE(IWRITE,1001)IK,IM,irho,isig,(VSHELL(I),I=1,N) 1 CONTINUE 2 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE DMELBC(LDA,ISPIN,IB,IBB) C C CALCULATES THE BOUND-CONTINUUM DIPOLE MATRIX ELEMENTS; C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN, C IB AND IBB DEFINE THE IONIC STATE AND COUPLED CHANNEL. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) PARAMETER (LL61= 15+1, LL68= 8/2, LL73= 6* 6, LL75= 21+2) C DIMENSION AXL( 60),AXV( 60), VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1000 FORMAT(/41X,31HDEBUGGING PRINT OUT FROM DMELBC/) 1001 FORMAT(' FINAL BOUND CONFIGURATION',I4/' INITIAL CONFIGURATION',I4 *,' IN THE CONFIGURATION ARRAY: VSHELL =',F12.7) 1003 FORMAT(45H THE RELEVANT B-C RADIAL DIPOLE INTEGRALS ARE//(7F11.7)) C IF(IBUG8.EQ.2) WRITE(IWRITE,1000) C C INITIALIZE THE DIPOLE MATRIX ELEMENTS TO ZERO. C DO 2 I=1,NRANG2 DO 2 IK=1,NCFGP DEL(IK,I)=0.0 2 DEV(IK,I)=0.0 C MCFGE=MTCON(IB) DO 7 IM=1,MCFGE I4=MTYP(IB,IM) C C SETINI IS CALLED. L4 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETINI(IB,I4,IBB,L4) MAXOR=MAXORB+1 IOD=NOCCSH(I4)+1 MOCORB(IOD,I4)=MAXOR NJCOMP(MAXOR)=999 LJCOMP(MAXOR)=L4 C DO 6 IK=1,NCFGP IRHO=0 ISIG=0 CALL SETUPE(I4,IK,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO+ISIG.EQ.0) GO TO 6 IF(IBUG8.EQ.2) WRITE(IWRITE,1001)IK,I4,VSHELL(1) N2=NJ(ISIG) L2=LJ(ISIG) RMANG=RME(L4,L2,LDA) IF(ABS(RMANG).LT.TINY) GO TO 6 COEF = VSHELL(1)*RMANG*AIJ(IB,IM) C C LOCATE THE BOUND CONTINUUM RADIAL INTEGRALS IN RKSTO2. C II = IBCPOL(L2+1,L4+1,1) + (3-LDA)*(N2-L2-1)*NRANG2 DO 3 IC=1,NRANG2 AXL(IC)=RKSTO2(II) IF(LDA.NE.1) GO TO 3 II=II+1 AXV(IC)=-RKSTO2(II) 3 II=II+1 IF(IBUG8.EQ.2) WRITE(IWRITE,1003) (AXL(IC),AXV(IC),IC=1,NRANG2) DO 5 IC=1,NRANG2 DEL(IK,IC)=DEL(IK,IC)+COEF*AXL(IC) 5 DEV(IK,IC)=DEV(IK,IC)+COEF*AXV(IC) 6 CONTINUE 7 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE DMELCB(LDA,ISPIN,IA,IAA) C C CALCULATES THE CONTINUUM-BOUND DIPOLE MATRIX ELEMENTS; C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN, C IA AND IAA DEFINE THE IONIC STATE AND COUPLED CHANNEL. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) PARAMETER (LL61= 15+1, LL68= 8/2, LL73= 6* 6, LL75= 21+2) C DIMENSION AXL( 60),AXV( 60), VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/BNDINI/MCFGP,JOCCSH(2500),JOCORB( 15,2500), * JELCSH( 15,2500),L1QNRD(LL41,3,2500) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1000 FORMAT(/41X,31HDEBUGGING PRINT OUT FROM DMELCB/) 1001 FORMAT(20H FINAL CONFIGURATION,I4,26H IN THE CONFIGURATION ARAY/ * 28H INITIAL BOUND CONFIGURATION,I4,': VSHELL,IBCPOL =', * F12.7,I9) 1003 FORMAT(45H THE RELEVANT C-B RADIAL DIPOLE INTEGRALS ARE//(7F11.7)) C IF(IBUG8.EQ.2) WRITE(IWRITE,1000) C C INITIALIZE THE DIPOLE MATRIX ELEMENTS TO ZERO. C DO 2 J=1,NRANG2 DO 2 IM=1,MCFGP DEL(IM,J)=0.0 2 DEV(IM,J)=0.0 C DO 7 IK=1,NTCON(IA) I3=NTYP(IA,IK) C C SETFIN IS CALLED. L3 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETFIN(IA,I3,IAA,L3) C DO 6 IM=1,MCFGP C C SETUPE, TENSOR AND RME ARE CALLED TO EVALUATE THE ANGULAR C COEFFICIENT. C IRHO=0 ISIG=0 CALL SETUPE(IM,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO+ISIG.EQ.0) GO TO 6 N1=NJ(IRHO) L1=LJ(IRHO) C C LOCATE THE BOUND CONTINUUM RADIAL INTEGRALS IN RKSTO2 C II = IBCPOL(L1+1,L3+1,1) + (3-LDA)*(N1-L1-1)*NRANG2 IF(IBUG8.EQ.2) WRITE(IWRITE,1001)I3,IM,VSHELL(1), II RMANG=RME(L1,L3,LDA) IF(ABS(RMANG).LT.TINY) GO TO 6 COEF = VSHELL(1)*RMANG*AIJ(IA,IK) DO 3 IC=1,NRANG2 AXL(IC)=RKSTO2(II) IF(LDA.NE.1) GO TO 3 II=II+1 AXV(IC)=RKSTO2(II) 3 II=II+1 IF(IBUG8.EQ.2) WRITE(IWRITE,1003) (AXL(IC),AXV(IC),IC=1,NRANG2) DO 5 IC=1,NRANG2 DEL(IM,IC)=DEL(IM,IC)+COEF*AXL(IC) 5 DEV(IM,IC)=DEV(IM,IC)+COEF*AXV(IC) 6 CONTINUE 7 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE DMELCC(LDA,ISPIN,IA,IAA,IB,IBB,IVSH,ACOEF,BLCOEF, 1 BVCOEF) C C CALCULATES THE CONTINUUM-CONTINUUM DIPOLE MATRIX ELEMENTS; C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN, C IA AND IAA, IB AND IBB DEFINE THE TARGET STATES AND COUPLED C CHANNELS. C IVSH IS SET ZERO IF THE ANGULAR AND SPIN INTEGRAL IS ZERO. C C THE A AND B COEFFICIENTS NECESSARY TO THE CALCULATION OF THE C OUTER REGION CONTRIBUTION TO DIPOLE MATRIX ELEMENTS ARE ALSO C OBTAINED. C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1,LL42= 15*2+1,LL43= 21*2+3, LL61= 15+1) PARAMETER (LL68= 8/2, LL71= 60+1, LL73= 6* 6, LL75= 21+2) PARAMETER (MXD1= 60,MXD2=2500) ! max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) C DIMENSION VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/EIGEN( 60),ENDS( 49,LL71),DELTA,ETA COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1000 FORMAT(/41X,31HDEBUGGING PRINT OUT FROM DMELCC//2I5,' TARGET COMP *ONENTS ASSOCIATED WITH THE FINAL AND THE INITIAL CHANNEL.') 1001 FORMAT(/' FINAL TERM COMPONENT IS',I4,5X,'INITIAL INDEX IS',I4, * ' IN THE CONFIGURATION ARRAY'/ * ' FINAL INTERACTION SHELL ISIG =',I3,', INITIAL INTERACTION * SHELL IRHO =',I3/' N,L:VSHELL=',(T13,4(I5,I3,':',F8.5))) 1003 FORMAT(/80H THE FINAL AND INITIAL CHANNEL CONTINUUM ELECTRONS HAVE * THE SAME ANGULAR MOMENTA/ * 38H THE RELEVANT B-B RADIAL INTEGRALS ARE,2F14.7) 1004 FORMAT(' ORBITAL QUANTUM NUMBER IN FINAL CHANNEL AND THE INITIAL C *HANNEL IS',2I3/' THE FIRST RELEVANT DIPOLE LENGTH C-C RADIAL INTEG *RAL IS IN RKSTO2 POSITION',I5) C C NCFGE=NTCON(IA) MCFGE=MTCON(IB) IF(IBUG8.EQ.2) WRITE(IWRITE,1000)NCFGE,MCFGE C C INITIALIZE THE DIPOLE OR QUADRUPOLE MATRIX ELEMENTS C AND THE A AND B COEFFICIENTS TO ZERO C DO 2 J=1,NRANG2 DO 2 I=1,NRANG2 DEL(I,J)=0.0 2 DEV(I,J)=0.0 ACOEF = 0.0 BLCOEF= 0.0 BVCOEF= 0.0 IVSH=0 C C DO 14 IK=1,NCFGE I3=NTYP(IA,IK) C C SETFIN IS CALLED TO SET UP THE COUPLING ARRAYS FOR THE FINAL C STATE CONFIGURATION. L3 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETFIN(IA,I3,IAA,L3) C DO 13 IM=1,MCFGE I4=MTYP(IB,IM) TCF = AIJ(IA,IK)*AIJ(IB,IM) C C SETINI IS CALLED TO SET UP THE COUPLING ARRAYS FOR THE INITIAL C STATE CONFIGURATION. L4 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETINI(IB,I4,IBB,L4) C C THE CASE OF THE CONTINUUM ELECTRONS HAVING EQUAL ANGULAR C MOMENTA IS CONSIDERED C IF(L3.NE.L4) GO TO 3 IOD=NOCCSH(I4)+1 MAXOR=MAXORB+1 MOCORB(IOD,I4)=MAXOR C C SETUPE TENSOR AND RME ARE CALLED TO EVALUATE THE ANGULAR C COEFFICIENT C 3 IRHO=0 ISIG=0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO+ISIG.EQ.0) GO TO 13 IF(IBUG8.EQ.2) WRITE(IWRITE,1001) I3,I4, ISIG,IRHO, * (NJ(I),LJ(I),VSHELL(I),I=1,IHSH) COEF = 0. IF (ISIG.EQ.IRHO) THEN CL = 0. CV = 0. DO 4 I=1,IHSH IF(VSHELL(I).EQ.0.) GO TO 4 IVSH=1 N=NJ(I) L=LJ(I) RMANG=RME(L,L,LDA)*VSHELL(I) IF(N.EQ.999) THEN COEF = RMANG*TCF GO TO 4 ENDIF CALL FINMNT(N,L,N,L,LDA,XL,XV) IF(IBUG8.EQ.2) PRINT *,' I,XL,XV =',I,XL,XV CL = RMANG*XL + CL CV = RMANG*XV + CV 4 CONTINUE ELSE IF (VSHELL(1).EQ.0.) GO TO 13 IVSH=1 N=NJ(IRHO) L1=LJ(IRHO) L2=LJ(ISIG) RMANG = RME(L1,L2,LDA)*VSHELL(1) IF(ABS(RMANG).LT.TINY) GO TO 13 IF(N.EQ.999) THEN COEF=RMANG*TCF GO TO 7 ENDIF C TWO BOUND-BOUND RADIAL INTEGRALS(LENGTH AND VELOCITY) ARE C EXTRACTED FROM THE RKSTO2 ARRAY: CALL FINMNT(N,L1,NJ(ISIG),L2,LDA,XL,XV) IF(IBUG8.EQ.2) WRITE(IWRITE,1003)XL,XV CL = RMANG*XL CV = RMANG*XV ENDIF C BLCOEF = CL*TCF + BLCOEF BVCOEF = CV*TCF + BVCOEF DO 6 I=1,NRANG2 DEL(I,I) = CL*TCF+DEL(I,I) 6 DEV(I,I) = CV*TCF+DEV(I,I) IF(COEF.EQ.0.) GO TO 13 C C 7 L1 = MIN(L3,L4) L2 = L3+L4-L1 C C THE POSITION OF THE FIRST RELEVANT DIPOLE LENGTH C-C INTEGRAL IN C THE RKSTO2 ARRAY IS STORED IN L (L1 AND L2 GIVING STANDARD ORDER) C L = ICCPOL(L1+1,L2+1,1) IF(IBUG8.EQ.2) WRITE(IWRITE,1004) L3,L4, L C C THE RELEVANT MULTIPOLE LENGTH AND VELOCITY RADIAL INTEGRALS ARE C MULTIPLIED BY THE COMMON ANGULAR CONTRIBUTION. ACCOUNT IS TAKEN C OF POSSIBLE INTERCHANGE OF L3 AND L4. C NST=NRANG2 DO 12 I=1,NRANG2 IF(L4.EQ.L3) NST=I DO 11 J=1,NST XL=RKSTO2(L) IF(LDA.EQ.1) THEN L=L+1 XV=RKSTO2(L) ENDIF N=J M=I IF(L3.LT.L4) THEN N=I M=J IF(LDA.EQ.1) XV=ENDS(L4+1,M)*ENDS(L3+1,N)-XV ENDIF DEL(M,N)=DEL(M,N)+COEF*XL IF(LDA.EQ.1) DEV(M,N)=DEV(M,N)+COEF*XV IF(L4.NE.L3) GO TO 11 DEL(N,M)=DEL(M,N) DEV(N,M)=DEV(M,N) 11 L=L+1 12 CONTINUE ACOEF = ACOEF + COEF C 13 CONTINUE 14 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE DMELBD(LDA,ISPIN) C C CALCULATES THE BOUND-BUTTLE DIPOLE MATRIX ELEMENTS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1,LL42= 15*2+1,LL43= 21*2+3, LL61= 15+1) PARAMETER (LL75= 21+2) PARAMETER (MXD1= 60,MXD2=2500) ! max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) C DIMENSION VSHELL(LL75) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C KCH=0 DO 1 IB=1,MAST DO 2 IBB=1,MCONAT(IB) KCH=KCH+1 DO 7 J=1,NCFGP DEL(J,KCH)=0. 7 DEV(J,KCH)=0. C DO 3 IM=1,MTCON(IB) if (BIJ(IB,IM).eq.0.) go to 3 I4=MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) MAXOR=MAXORB+1 IOD=NOCCSH(I4)+1 MOCORB(IOD,I4)=MAXOR NJCOMP(MAXOR)=999 LJCOMP(MAXOR)=L4 C DO 4 IK=1,NCFGP IRHO=0 ISIG=0 CALL SETUPE(I4,IK,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO.EQ.0.AND.ISIG.EQ.0) GOTO 4 L2=LJ(ISIG) LCT=JBCPOL(L2+1,L4+1) if (LCT.eq.0) go to 4 ! '05Feb24/26 following rstg1 LCT = (NJ(ISIG)-L2-1)*2+LCT C COEF = VSHELL(1)*RME(L4,L2,LDA)*BIJ(IB,IM) DEL(IK,KCH) = DEL(IK,KCH)+COEF*SKSTO2(LCT) DEV(IK,KCH) = DEV(IK,KCH)-COEF*SKSTO2(LCT+1) C 4 CONTINUE 3 CONTINUE 2 CONTINUE 1 CONTINUE RETURN END C********************************************************************** SUBROUTINE DMELCD(LDA,ISPIN,IA,IAA) C C CALCULATES THE CONTINUUM-BUTTLE DIPOLE MATRIX ELEMENT C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL43= 21*2+3, LL71= 60+1, LL75= 21+2) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) C DIMENSION VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/EIGEN( 60),ENDS( 49,LL71),DELTA,ETA COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C KCH=0 DO 1 IB=1,MAST DO 2 IBB=1,MCONAT(IB) KCH=KCH+1 DO 3 I=1,NRANG2 DEL(I,KCH)=0. 3 DEV(I,KCH)=0. C DO 4 IK=1,NTCON(IA) if (AIJ(IA,IK).eq.0.) go to 4 I3=NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 5 IM=1,MTCON(IB) if (BIJ(IB,IM).eq.0.) go to 5 I4=MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) C IF(L3.EQ.L4) GOTO 5 ! '05Feb24 as |L3-L4|.ne.1,2 following rstg1: INP=JCCPOL(L3+1,L4+1) if (INP.eq.0) go to 5 C IRHO=0 ISIG=0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG=VSHELL(1) IF(ABS(CANG).GT.TINY) IVSH=1 RMANG=RME(L4,L3,LDA) IF(ABS(RMANG).LT.TINY) GOTO 4 COEF=CANG*RMANG*AIJ(IA,IK)*BIJ(IB,IM) C DO 6 I=1,NRANG2 DEL(I,KCH) = DEL(I,KCH)+COEF*SKSTO2(INP) DEV(I,KCH) = DEV(I,KCH)+COEF* * ENDS(L3+1,I)*ENDS(L4+1,NRANG2+1)-SKSTO2(INP+1) 6 INP=INP+2 C 5 CONTINUE 4 CONTINUE 2 CONTINUE 1 CONTINUE RETURN END C********************************************************************* SUBROUTINE DMELDB(LDA,ISPIN) C C CALCULATES THE BUTTLE-BOUND DIPOLE MATRIX ELEMENTS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL43= 21*2+3, LL75= 21+2) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) C DIMENSION VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BNDINI/MCFGP,JOCCSH(2500),JOCORB( 15,2500), * JELCSH( 15,2500),L1QNRD(LL41,3,2500) COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C LCH=0 DO 1 IA=1,NAST NCFGE=NTCON(IA) DO 2 IAA=1,NCONAT(IA) LCH=LCH+1 DO 7 J=1,MCFGP DEL(J,LCH)=0. 7 DEV(J,LCH)=0. C DO 3 IK=1,NCFGE if (AIJ(IA,IK).eq.0.) go to 3 I3=NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 4 IM=1,MCFGP IRHO=0 ISIG=0 CALL SETUPE(IM,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF(IRHO.EQ.0.AND.ISIG.EQ.0) GOTO 4 L1=LJ(IRHO) LCT=JBCPOL(L1+1,L3+1) if (LCT.eq.0) go to 4 ! '05Feb24 SIGTRAP, see rstg1 LCT = (NJ(IRHO)-L1-1)*2+LCT C COEF = VSHELL(1)*RME(L1,L3,LDA) * AIJ(IA,IK) DEL(IM,LCH) = DEL(IM,LCH) + COEF*SKSTO2(LCT) DEV(IM,LCH) = DEV(IM,LCH) + COEF*SKSTO2(LCT+1) C 4 CONTINUE 3 CONTINUE 2 CONTINUE 1 CONTINUE RETURN END C********************************************************************* SUBROUTINE DMELDC(LDA,ISPIN,IB,IBB) C C CALCULATES THE BUTTLE-CONTINUUM DIPOLE MATRIX ELEMENTS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL43= 21*2+3, LL75= 21+2) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) C DIMENSION VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C LCH=0 DO 1 IA=1,NAST DO 2 IAA=1,NCONAT(IA) LCH=LCH+1 DO 3 I=1,NRANG2 DEL(LCH,I)=0. 3 DEV(LCH,I)=0. C DO 4 IK=1,NTCON(IA) if (AIJ(IA,IK).eq.0.) go to 4 I3=NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 5 IM=1,MTCON(IB) if (BIJ(IB,IM).eq.0) go to 5 I4=MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) C IF(L3.EQ.L4) GOTO 5 ! '05Feb24 as |L3-L4|.ne.1,2 following rstg1: INP=JCCPOL(L4+1,L3+1) if (INP.eq.0) go to 5 C IRHO=0 ISIG=0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG=VSHELL(1) IF(ABS(CANG).GT.TINY) IVSH=1 RMANG=RME(L4,L3,LDA) IF(ABS(RMANG).LT.TINY) GOTO 4 COEF=CANG*RMANG*AIJ(IA,IK)*BIJ(IB,IM) C DO 6 I=1,NRANG2 DEL(LCH,I) = DEL(LCH,I)+COEF*SKSTO2(INP) DEV(LCH,I) = DEV(LCH,I)+COEF*SKSTO2(INP+1) 6 INP=INP+2 C 5 CONTINUE 4 CONTINUE 2 CONTINUE 1 CONTINUE RETURN END C********************************************************************* SUBROUTINE DMELDD(LDA,ISPIN) C IMPLICIT REAL*8(A-H,O-Z) C C THIS SUBROUTINE CALCULATES THE BUTTLE-BUTTLE DIPOLE MATRIX C ELEMENTS. SPECIAL CASE OF DIPOLE TRANSITION TAKING PLACE IN C THE TARGET IS CONSIDERED. C PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (LL61= 15+1, LL71= 60+1, LL75= 21+2) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) C DIMENSION VSHELL(LL75) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/EIGENS( 60),ENDS( 49,LL71),DELTA,ETA COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,TINY COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DIPMEL/DEL(LL53,LL53),DEV(LL53,LL53) COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C LCH=0 DO 1 IA=1,NAST NCFGE=NTCON(IA) DO 2 IAA=1,NCONAT(IA) LCH=LCH+1 C KCH=0 DO 3 IB=1,MAST MCFGE=MTCON(IB) DO 4 IBB=1,MCONAT(IB) KCH=KCH+1 DEL(LCH,KCH)=0. DEV(LCH,KCH)=0. C DO 5 IK=1,NCFGE I3=NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 6 IM=1,MCFGE I4=MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) IF(L3.EQ.L4) THEN IOD=NOCCSH(I4)+1 MAXOR=MAXORB+1 MOCORB(IOD,I4)=MAXOR ENDIF C IRHO=0 ISIG=0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG=VSHELL(1) IF(ABS(CANG).GT.TINY) IVSH=1 IF(IRHO.EQ.0.AND.ISIG.EQ.0) GOTO 6 N1=NJ(IRHO) L1=LJ(IRHO) N2=NJ(ISIG) L2=LJ(ISIG) RMANG=RME(L1,L2,LDA) IF(ABS(RMANG).LT.TINY) GOTO 5 COEF=CANG*RMANG*AIJ(IA,IK)*BIJ(IB,IM) C IF(L3.EQ.L4) THEN CALL FINMNT(N1,L1,N2,L2,LDA,XL,XV) RNTL=XL*BNORM(L3+1) RNTV=XV*BNORM(L3+1) ELSE LH=MAX(L3,L4)+1 LL=MIN(L3,L4)+1 INP=JCCPOL(LH,LL)-2 RNTL=SKSTO2(INP) INP=INP+1 RNTV=SKSTO2(INP) IF(L4+1.EQ.LH) RNTV=ENDS(LL,NRANG2+1)*ENDS(LH,NRANG2+1)-RNTV ENDIF DEL(LCH,KCH)=DEL(LCH,KCH)+COEF*RNTL DEV(LCH,KCH)=DEV(LCH,KCH)+COEF*RNTV C 6 CONTINUE 5 CONTINUE 4 CONTINUE 3 CONTINUE 2 CONTINUE 1 CONTINUE RETURN END C*********************************************************************** SUBROUTINE FINBB(IDORIE,LAM) C C FINDS A BOUND-BOUND RK INTEGRAL FROM THE RKSTO1 ARRAY C AND STORES IN RKMAT(1,1). C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) ! LL63=min(NXD1,NXD2): PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5) C COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/NJLJ/ NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT C 1000 FORMAT(48H THE BOUND-BOUND RK INTEGRAL CANNOT BE FOUND FOR/ 1 8H N1,L1=,2I2,8H N2,L2=,2I2,8H N3,L3=,2I2,8H N4,L4=,2I2) C C THE BOUND-BOUND RK INTEGRAL CORRESPONDING TO THE FOLLOWING NL C VALUES IS FOUND C N1=NQ1 N2=NQ2 N3=NQ3 N4=NQ4 LRHO=LQ1 LSIG=LQ2 LRHOP=LQ3 LSIGP=LQ4 C C FIRST INTERCHANGE (N1,LRHO) AND (N2,LSIG) FOR EXCHANGE INTEGRAL C THEN PLACE N1,N2,N3,N4,LRHO,LSIG,LRHOP,LSIGP IN THE ORDER C REQUIRED BY SYMMETRY CONDITIONS, I.E. LSIG GE LRHO,LRHOP GE LRHO C LSIGP GE LSIG. WHEN LRHO=LSIG, N1 GE N2, WHEN LRHOP=LRHO, C N1 GE N3 AND WHEN LSIG = LSIGP, N2 GE N4 C IF(IDORIE.EQ.2) CALL INTECH(N1,LRHO,N2,LSIG,0) C C PUT THE SMALLEST ANGULAR MOMENTUM IN LRHO AND ENSURE THAT C LSIGP.GE.LSIG C 1 I=1 L=LRHO IF(L.LE.LSIG) GO TO 3 I=2 L=LSIG 3 IF(L.LE.LRHOP) GO TO 5 I=3 L=LRHOP 5 IF(L.LE.LSIGP) GO TO 7 I=4 L=LSIGP 7 GO TO(11,8,9,10),I 8 CALL INTECH(N1,LRHO,N2,LSIG,0) CALL INTECH(N3,LRHOP,N4,LSIGP,0) GO TO 11 9 CALL INTECH(N1,LRHO,N3,LRHOP,0) GO TO 11 10 CALL INTECH(N1,LRHO,N4,LSIGP,0) CALL INTECH(N2,LSIG,N3,LRHOP,0) 11 IF(LSIGP.LT.LSIG) CALL INTECH(N2,LSIG,N4,LSIGP,0) C C THE ANGULAR MOMENTUM CONDITIONS ARE SATISFIED.NOW ENSURE C THAT THE PRINCIPAL QUANTUM NUMBERS SATISFY THE REQUIRED C CONDITIONS C IF(LSIG.NE.LSIGP) GO TO 12 IF(N2.GE.N4) GO TO 12 CALL INTECH(N2,LSIG,N4,LSIGP,1) 12 IF(LRHO.NE.LRHOP) GO TO 13 IF(N1.GE.N3) GO TO 13 CALL INTECH(N1,LRHO,N3,LRHOP,1) 13 IF(LRHO.NE.LSIG) GO TO 14 IF(N1.GE.N2) GO TO 14 CALL INTECH(N1,LRHO,N2,LSIG,1) CALL INTECH(N3,LRHOP,N4,LSIGP,0) C C NOW CALCULATE THE LOCATION OF THE BOUND INTEGRAL C 14 LP=LRHOP*LRANG1+LSIGP+1 IRK4=ICTBB(LRHO+1,LSIG+1,LP) 15 IF(ISTBB1(IRK4).EQ.LAM) GO TO 16 IRK4=IRK4+1 GO TO 15 16 IRK1=ISTBB2(IRK4)-1 C N3M=MAXNHF(LRHOP+1) N4M=MAXNHF(LSIGP+1) NP1=LRHO+1 17 IF(LSIG.NE.LRHO) GO TO 19 N2M=NP1 GO TO 20 19 N2M=MAXNHF(LSIG+1) 20 NP2=LSIG+1 IF(LRHOP.EQ.LRHO) N3M=NP1 21 NP3=LRHOP+1 IF(LSIGP.EQ.LSIG) N4M=NP2 C C******************************************************* C C THE FOLLOWING CODING WAS REPLACED BY KAB, 15 JUN 1988 C C 22 NP4=LSIGP+1 C 23 IRK1=IRK1+1 C IF(NP1.EQ.N1.AND.NP2.EQ.N2.AND.NP3.EQ.N3.AND.NP4.EQ.N4) GO TO 28 C C NP4=NP4+1 C IF(NP4-N4M) 23,23,24 C 24 NP3=NP3+1 C IF(NP3-N3M) 22,22,25 C C HERE IS THE REPLACEMENT, IT IS FASTER .... C IF(NP1.NE.N1.OR.NP2.NE.N2) THEN IRK1=IRK1+(N3M-LRHOP)*(N4M-LSIGP) ELSE IRK1=IRK1+(N3-LRHOP-1)*(N4M-LSIGP)+(N4-LSIGP) GO TO 28 ENDIF C C***************************************************** C 25 NP2=NP2+1 IF(NP2.LE.N2M) GO TO 21 NP1=NP1+1 IF(NP1.LE.MAXNHF(LRHO+1)) GO TO 17 C C IF THE INTEGRAL CANNOT BE FOUND PRINT OUT AN ERROR MESSAGE C WRITE(IWRITE,1000) N1,LRHO,N2,LSIG,N3,LRHOP,N4,LSIGP C 28 RKMAT(1,1)=RKSTO1(IRK1) RETURN END C*********************************************************************** SUBROUTINE FINBC(IDORIE,LAM) C C FINDS THE BOUND-CONTINUUM RK INTEGRALS FROM THE RKSTO2 ARRAY C AND STORES IN RKMAT(1,I),I=1,JLIMIT C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5, LL73= 6* 6) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8 COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/NJLJ/ NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT NSTO(NML) = ((NML-1)*NML)/2 C N1= NQ1 N2=NQ2 N3=NQ3 N4=NQ4 LRHO=LQ1 LSIG=LQ2 LRHOP=LQ3 LSIGP=LQ4 C C FIRST INTERCHANGE (N1,LRHO) AND (N2,LSIG) FOR EXCHANGE INTEGRAL C THEN PLACE N1,N3 AND LRHO,LRHOP IN THE ORDER REQUIRED BY C SYMMETRY CONDITIONS,I.E. LRHOP GE LRHO,WHEN LRHO= LRHOP,N1 GE N3 C IF(IDORIE.EQ.2) CALL INTECH(N1,LRHO,N2,LSIG,0) C 1 IF(LRHO-LRHOP) 4,3,2 2 CALL INTECH(N1,LRHO,N3,LRHOP,0) GO TO 4 3 IF(N3.GT.N1) CALL INTECH(N1,LRHO,N3,LRHOP,1) C C NOW CALCULATE THE LOCATION OF THE BOUND-CONTINUUM INTEGRALS C 4 LP=LRANG1*LSIGP+LRHOP+1 I1=ICTBC(LRHO+1,LSIG+1,LP) 5 IF(ISTBC1(I1).EQ.LAM) GO TO 7 I1=I1+1 GO TO 5 7 IF(LRHO.EQ.LRHOP) GO TO 8 I2=(N1-LRHO-1)*(MAXNHF(LSIG+1)-LSIG)+N2-LSIG-1 I3=(I2*(MAXNHF(LRHOP+1)-LRHOP)+N3-LRHOP-1)*NRANG2 GO TO 9 8 I3=(NSTO(N1-LRHO)*(MAXNHF(LSIG+1)-LSIG)+(N2-LSIG-1)*(N1-LRHO)+N3-L 1RHOP-1)*NRANG2 9 I4=I3+ISTBC2(I1)-1 DO 10 I5=1,JLIMIT 10 RKMAT(1,I5)=RKSTO2(I5+I4) C RETURN END C*********************************************************************** SUBROUTINE FINCC1(IDORIE,LAM,JUMP) C C FINDS THE CONTINUUM-CONTINUUM RK INTEGRALS FROM THE RKSTO2 ARRAY. C THIS CASE CORRESPONDS TO THE DIAGONAL ELEMENTS (KI=KJ) BUT THE C CONTINUUM L VALUES MAY BE DIFFERENT. WHEN THEY ARE THE SAME THE C CASE MAY JUST INVOLVE BOUND ORBITALS WHEN FINBB IS CALLED. THE C RESULT IS STORED IN RKMAT(I,I),I=1,ILIMIT C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C JUMP =1 IF ENTRY IS DIRECT C JUMP =2 IF ENTRY IS FROM FINCC2. IN THIS CASE JUMP IS SET ON C RETURN EQUAL TO THE LOCATION OF THE CONTINUUM-CONTINUUM C INTEGRALS IN THE RKSTO2 ARRAY C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5, LL73= 6* 6) C COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8 COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/NJLJ/ NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT NSTO(NML) = ((NML-1)*NML)/2 C N1= NQ1 N2=NQ2 N3=NQ3 N4=NQ4 LRHO=LQ1 LSIG=LQ2 LRHOP=LQ3 LSIGP=LQ4 C C CHECK N4 TO SEE IF A PROPER CONTINUUM-CONTINUUM CASE OR IF IT C CORRESPONDS TO A BOUND-BOUND INTEGRAL WHICH CAN ONLY OCCUR C WHEN THE CONTINUUM L VALUES ARE THE SAME C IF(N4.EQ.999) GO TO 4 C C THIS CASE IS A BOUND-BOUND INTEGRAL SO CALL FINBB C CALL FINBB(IDORIE,LAM) IF(ILIMIT.EQ.1) RETURN 2 DO 3 I5=2,ILIMIT 3 RKMAT(I5,I5)=RKMAT(1,1) RETURN C C THIS IS A PROPER CONTINUUM-CONTINUUM INTEGRAL C 4 IF (IDORIE.GT.1) GO TO 9 IF(LRHO-LRHOP) 8,7,6 6 CALL INTECH(N1,LRHO,N3,LRHOP,0) GO TO 8 7 IF(N3.GT.N1) CALL INTECH(N1,LRHO,N3,LRHOP,0) I1=ICTCCD(LRHO+1,LRHOP+1,LAM+1) I2=NSTO(N1-LRHO)+N3-LRHOP-1 GO TO 11 8 I1=ICTCCD(LRHO+1,LRHOP+1,LAM+1) GO TO 10 9 IF(LSIG.GT.LSIGP) CALL INTECH(N1,LRHO,N3,LRHOP,0) I1=ICTCCE(LRHO+1,LRHOP+1,LAM+1) 10 I2=(N1-LRHO-1)*(MAXNHF(LRHOP+1)-LRHOP)+N3-LRHOP-1 11 IF(LSIG.NE.LSIGP) GO TO 13 I2=(I2*NRANG2*(NRANG2+1))/2 GO TO 14 13 I2=I2*NRANG2*NRANG2 14 IF (JUMP.LE.1) GO TO 16 C C RETURN TO SUBROUTINE FINCC2 WITH LOCATION OF CONTINUUM ORBITAL C IN JUMP C JUMP=I1+I2 RETURN 16 DO 19 I5=1,ILIMIT IF(LSIG.EQ.LSIGP) GO TO 18 I4=I1+I2+(I5-1)*NRANG2+I5-1 GO TO 19 18 I4=I1+I2+NSTO(I5)+I5-1 19 RKMAT(I5,I5)=RKSTO2(I4) C RETURN END C*********************************************************************** SUBROUTINE FINCC2(IDORIE,LAM) C C FINDS THE CONTINUUM-CONTINUUM RK INTEGRALS FROM THE RKSTO2 ARRAY. C THIS CASE CORRESPONDS TO THE OFF-DIAGONAL ELEMENTS (KI NE KJ) C THE RESULT IS STORED IN RKMAT(I,J),I=1,ILIMIT,J=1,JLIMIT C WHERE I IS NOT EQUAL TO J. C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5, LL73= 6* 6) C COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8 COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/NJLJ/ NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT NSTO(NML) = ((NML-1)*NML)/2 C N1=NQ1 N2=NQ2 N3=NQ3 N4=NQ4 LRHO=LQ1 LSIG=LQ2 LRHOP=LQ3 LSIGP=LQ4 C C FIRST CALCULATE THE CASE WHEN THE CONTINUUM ORBITALS HAVE C DIFFERENT ANGULAR MOMENTA C C JUMP IS SET READY TO ENTER SUBROUTINE FINCC1 IF REQUIRED C JUMP=2 IF(LSIG.EQ.LSIGP) GO TO 9 C C THE CONTINUUM ANGULAR MOMENTA ARE DIFFERENT SO SUBROUTINE FINCC1 C CAN BE USED TO DETERMINE THE POSITION IN THE RKSTO2 ARRAY WHERE C THE CONTINUUM INTEGRALS ARE FOUND C CALL FINCC1(IDORIE,LAM,JUMP) 2 DO 8 I5=1,ILIMIT DO 7 J5=1,JLIMIT IF(I5.EQ.J5) GO TO 6 I4=JUMP+(I5-1)*NRANG2+J5-1 IF(LSIG.GT.LSIGP) GO TO 5 RKMAT(J5,I5)=RKSTO2(I4) GO TO 7 5 RKMAT(I5,J5)=RKSTO2(I4) GO TO 7 6 RKMAT(I5,J5)=0. 7 CONTINUE 8 CONTINUE RETURN C C THE CONTINUUM ORBITALS HAVE THE SAME ANGULAR MOMENTA. IN THIS C CASE ONLY THE LOWER TRIANGLE OF THE CONTINUUM ORBITALS FOR ANY C PAIR OF BOUND-STATE ORBITALS IS STORED SO TWO ENTRIES TO THE C RKMAT MATRIX MUST BE MADE C 9 IF (IDORIE.LE.1) GO TO 11 I1=ICTCCE(LRHO+1,LRHOP+1,LAM+1) GO TO 15 11 IF(LRHO-LRHOP) 14,13,12 12 CALL INTECH(N1,LRHO,N3,LRHOP,0) GO TO 14 13 IF(N3.GT.N1) CALL INTECH(N1,LRHO,N3,LRHOP,1) I1=ICTCCD(LRHO+1,LRHOP+1,LAM+1) I2=(NSTO(N1-LRHO)+N3-LRHOP-1)*(NRANG2*(NRANG2+1))/2 GO TO 16 14 I1=ICTCCD(LRHO+1,LRHOP+1,LAM+1) 15 I2=((N1-LRHO-1)*(MAXNHF(LRHOP+1)-LRHOP)+N3-LRHOP-1)*(NRANG2*(NRANG 12+1))/2 16 RKMAT(1,1)=0. IF(ILIMIT.LE.1) GO TO 26 DO 21 I5=2,ILIMIT RKMAT(I5,I5)=0. I51=I5-1 I4=I1+I2+NSTO(I5)-1 DO 17 I6=1,I51 17 RKMAT(I5,I6)=RKSTO2(I4+I6) IF(IDORIE.EQ.2) GO TO 21 DO 18 I6=1,I51 18 RKMAT(I6,I5)=RKMAT(I5,I6) 21 CONTINUE IF (IDORIE.LE.1) GO TO 26 I1=ICTCCE(LRHOP+1,LRHO+1,LAM+1) I2=((N3-LRHOP-1)*(MAXNHF(LRHO+1)-LRHO)+N1-LRHO-1)*(NRANG2*(NRANG2+ 11))/2 DO 25 I5=2,ILIMIT I4=I1+I2+NSTO(I5)-1 DO 24 I6=1,I5-1 24 RKMAT(I6,I5)=RKSTO2(I4+I6) 25 CONTINUE C 26 RETURN END C*********************************************************************** SUBROUTINE FINMNT(N1,L1,N2,L2,K,X,Y) C C FINDS THE MULTIPOLE INTEGRALS IN THE RKSTO2 ARRAY C C N1,N2 ARE THE PRINCIPAL QUANTUM NUMBERS C L1,L2 ARE ANGULAR MOMENTUM QUANTUM NUMBERS C K IS THE MULTIPOLE ORDER C IF K.EQ.1 X CONTAINS THE DIPOLE LENGTH AND Y THE DIPOLE VELOCITY C INTEGRALS ON EXIT C IF K.GT.1 X CONTAINS THE KTH POLE LENGTH INTEGRAL ON EXIT C AND Y IS SET EQUAL TO ZERO C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL68= 8/2, LL73= 6* 6) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ NSTO(NML) = ((NML-1)*NML)/2 C C TEST THAT THE TRIANGULAR RELATIONS ARE SATISFIED C IF(K.GE.ABS(L1-L2).AND.K.LE.L1+L2.AND.MOD(L1+L2+K,2).EQ.0) GO TO 1 X=0. Y=0. RETURN C 1 LK=(K-ABS(L1-L2)+2)/2 IF(L1.EQ.L2) LK=K/2 I1=1 IF(K.EQ.1) I1=2 I2=1 IF(N1.LE.MAXNHF(L1+1)) I2=I2+1 IF(N2.LE.MAXNHF(L2+1)) I2=I2+1 C C DEFINE N3,L3,N4,L4 IN A STANDARD ORDER C IF(I2.EQ.2) GO TO 5 IF(L1.EQ.L2) GO TO 4 IF(L1.LT.L2) GO TO 3 2 N3=N2 L3=L2+1 N4=N1 L4=L1+1 GO TO 6 3 N3=N1 L3=L1+1 N4=N2 L4=L2+1 GO TO 6 4 IF(N1.GE.N2) GO TO 3 GO TO 2 5 IF(N1.LE.MAXNHF(L1+1))GO TO 3 GO TO 2 C C FIND THE LOCATION IN RKSTO2 WHERE THE INTEGRALS ARE STORED C 6 IF (I2-2) 7,9,10 C C THE CONTINUUM-CONTINUUM INTEGRALS C 7 I3=N3-MAXNHF(L3)-1 I4=N4-MAXNHF(L4)-1 IF(L3.EQ.L4) GO TO 8 M1=ICCPOL(L3,L4,LK)+I1*(I3*NRANG2+I4) GO TO 12 8 M1=ICCPOL(L3,L4,LK)+I1*(NSTO(I3+1)+I4) GO TO 12 C C THE BOUND-CONTINUUM INTEGRALS C 9 M1=IBCPOL(L3,L4,LK)+I1*((N3-L3)*NRANG2+N4-MAXNHF(L4)-1) GO TO 12 C C THE BOUND-BOUND INTEGRALS C 10 I3=N3-L3 I4=N4-L4 IF(L3.EQ.L4) GO TO 11 M1=IBBPOL(L3,L4,LK)+I1*(I3*(MAXNHF(L4)-L4+1)+I4) GO TO 12 11 M1=IBBPOL(L3,L4,LK)+I1*(NSTO(I3+1)+I4) C C PICK OUT THE INTEGRALS FROM RKSTO2 C 12 X=RKSTO2(M1) Y=0. IF(K.EQ.1) THEN Y=RKSTO2(M1+1) IF(L1.GT.L2) Y=-Y ENDIF RETURN END C*********************************************************************** SUBROUTINE FIN1BB(N1,N2,L1,ALBVAL) C C FINDS A BOUND-BOUND ONE ELECTRON INTEGRAL C C N1,N2 ARE THE PRINCIPAL QUANTUUM NUMBERS C L1 IS THE ANGULAR MOMENTUM PLUS ONE C ALBVAL CONTAINS THE INTEGRAL ON RETURN C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) ! min: PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5) C COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/REL/ IRELOP(3),JRELOP(3) NSTO(NML) = ((NML-1)*NML)/2 C I1=IST1(L1) IF(N1.GE.N2) THEN I2 = NSTO(N1-L1+1) +I1+N2-L1 ELSE I2 = NSTO(N2-L1+1) +I1+N1-L1 ENDIF ALBVAL=ONEST1(I2) C C ADD IN THE RELATIVISTIC CORRECTIONS IF REQUIRED C IF(JRELOP(1).GT.0) ALBVAL=ALBVAL+RMASS1(I2) IF(JRELOP(2).GT.0.AND.L1.EQ.1) ALBVAL=ALBVAL+RDAR1(I2) RETURN END C*********************************************************************** SUBROUTINE FIN1BC(N1,N2,L1,ALBVAL) C C FINDS A BOUND-CONTINUUM ONE ELECTRON INTEGRAL C C N1,N2 ARE THE PRINCIPAL QUANTUUM NUMBERS C L1 IS THE ANGULAR MOMENTUM PLUS ONE C ALBVAL CONTAINS THE INTEGRAL ON RETURN C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) ! min: PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5) C COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/REL/ IRELOP(3),JRELOP(3) C I2 = IST2(L1) + (N1-L1)*NRANG2+N2-MAXNHF(L1)-1 ALBVAL = ONEST2(I2) C C ADD IN THE RELATIVISTIC CORRECTIONS IF REQUIRED C IF(JRELOP(1).GT.0) ALBVAL=ALBVAL+RMASS2(I2) IF(JRELOP(2).GT.0.AND.L1.EQ.1) ALBVAL=ALBVAL+RDAR2(I2) RETURN END C*********************************************************************** SUBROUTINE FIN1CC(N1,N2,L1,ALBVAL) C C FINDS A CONTINUUM-CONTINUUM ONE ELECTRON INTEGRAL C N1,N2 ARE THE PRINCIPAL QUANTUUM NUMBERS C L1 IS THE ANGULAR MOMENTUM PLUS ONE C ALBVAL CONTAINS THE INTEGRAL ON RETURN C C IMPLICIT REAL*8(A-H,O-Z) COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/REL/ IRELOP(3),JRELOP(3) NSTO(NML) = ((NML-1)*NML)/2 C IF(N1.GE.N2) GO TO 2 I1=N2-MAXNHF(L1) I2=NSTO(I1)+N1-MAXNHF(L1) GO TO 3 2 I1=N1-MAXNHF(L1) I2=NSTO(I1)+N2-MAXNHF(L1) 3 ALBVAL = ONEST3(I2,L1) C ADD IN THE RELATIVISTIC CORRECTIONS IF REQUIRED C IF(JRELOP(1).GT.0) ALBVAL=ALBVAL+RMASS3(I2,L1) IF(JRELOP(2).GT.0.AND.L1.EQ.1) ALBVAL=ALBVAL+RDAR3(I2) C RETURN END C*********************************************************************** SUBROUTINE INTECH(N1,L1,N2,L2,I) C C INTERCHANGE TWO SETS OF NUMBERS (N1,L1) AND (N2,L2) C I= 1 INTERCHANGE N1 AND N2 ONLY C I=-1 INTERCHANGE L1 AND L2 ONLY C I= 0 INTERCHANGE BOTH N1,N2 AND L1,L2 C IF(I.GE.0) THEN K=N1 N1=N2 N2=K ENDIF IF(I.LE.0) THEN K=L1 L1=L2 L2=K ENDIF C RETURN END C*********************************************************************** SUBROUTINE MATANS(IMATX) C C SETS UP THE CALL TO MATRX FOR THE BOUND-BOUND C (IMATX=1), BOUND-CONTINUUM (IMATX=2), AND CONTINUUM-CONTINUUM C DIAGONAL AND OFF-DIAGONAL (IMAIX=3) MATRIX ELEMENTS. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT C IF(IMATX-2) 1,2,3 C C BOUND-BOUND C 1 ISAMEK=1 ILIMIT=1 JLIMIT=1 CALL MATRX RETURN C C BOUND-CONTINUUM C 2 ISAMEK=2 ILIMIT=1 JLIMIT=NDCT(2) CALL MATRX RETURN C C CONTINUUM-CONTINUUM. OFF DIAGONAL I.E. KI.NE.KJ C 3 ILIMIT=NDCT(1) JLIMIT=NDCT(2) IF(LJ(IHSH).EQ.LJ(IHSH-1)) GO TO 5 C C CONTINUUM-CONTINUUM. DIAGONAL I.E. KI= KJ IF L.NE.LP (I.E.LJ(IHSH C -1).NE.LJ(IHSH)). CALL MATRX AGAIN WITH SAME COUPLING SCHEMES C ISAMEK=0 CALL MATRX RETURN C C CONTINUUM-CONTINUUM. DIAGONAL I.E. KI=KJ BUT NOW L=LP. HENCE C CONTRACTION OF COUPLING SCHEMES SINCE THE TWO CONTINUUM ORBITALS C ARE IDENTICAL C 5 ISAMEK=4 CALL MATRX ISAMEK=3 ILIMIT=MIN(NDCT(1),NDCT(2)) JLIMIT=ILIMIT I10=IHSH IHSH=IHSH-1 I11=2*IHSH-2 I12=I11+1 NOSH2(IHSH)=1 J1QN2(IHSH,1)=1 J1QN2(IHSH,2)=2*LJ(IHSH)+1 J1QN2(IHSH,3)=2 IF(I11.LT.I10) I11=I10 DO 6 K=1,3 DO 6 J=I10,I11 J1QN1(J,K)=J1QN1(J+1,K) 6 J1QN2(J,K)=J1QN2(J+1,K) C J1QN1(I12,1)=0 J1QN1(I12,2)=2*LRGL+1 J1QN1(I12,3)=NSPN J1QN2(I12,1)=0 J1QN2(I12,2)=2*LRGL+1 J1QN2(I12,3)=NSPN C C NOW CALL MATRX WITH CONTRACTED COUPLING SCHEMES C CALL MATRX RETURN END C*********************************************************************** SUBROUTINE MATRX C IMPLICIT REAL*8(A-H,O-Z) C C CALLS THE ROUTINES H0WTS AND RKWTS FOR EACH TYPE OF R-MATRIX C ELEMENT I.E. BOUND-BOUND, BOUND-CONTINUUM AND CONTINUUM-CONTINUUM C PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/CONMX/ H0MAT( 60, 60),VMAT( 60, 60) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIAGNL/IDIAG,JA,JB ! ?? COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT C 1000 FORMAT(//16H AME FROM MATRIX) 1001 FORMAT(1X,6F13.6) C C INITIALISE H0MAT AND VMAT - THE ARRAYS WHICH HOLD THE ONE- C ELECTRON AND TWO-ELECTRON CONTRIBUTIONS TO THE MATRIX ELEMENTS C DO 1 J=1,JLIMIT DO 1 I=1,ILIMIT VMAT(I,J)=0. H0MAT(I,J)=0. 1 RKMAT(I,J)=0. C C TEST FOR SIMPLE POSSIBILITIES OF ZERO MATRIX ELEMENT C CALL ORTHOG(LET) IF(LET.EQ.0) GO TO 17 C C TEST TO SEE IF THE CONFIGURATIONS OF THE (N+1)-ELECTRONS ARE C IDENTICAL I.E. THE SAME NUMBER OF ELECTRONS IN EACH SHELL AND C THE SAME COUPLING SCHEMES C N1=IHSH+IHSH-1 DO 3 I=1,IHSH IF(NOSH1(I).NE.NOSH2(I)) GO TO 4 3 CONTINUE GO TO 5 4 IDIAG=0 GO TO 8 5 DO 6 K=1,3 DO 6 J=1,N1 IF(J1QN1(J,K).NE.J1QN2(J,K)) GO TO 4 6 CONTINUE IDIAG=1 C C EVALUATE THE TWO-ELECTRON CONTRIBUTIONS TO THE MATRIX ELEMENTS C 8 CALL CHOP CALL RKWTS C C EVALUATE THE ONE-ELECTRON CONTRIBUTIONS TO THE MATRIX ELEMENTS C IF(IDIAG.EQ.0) GO TO 9 CALL DH0 GO TO 10 9 CALL H0WTS(ISIG,ISIGP,Y,ICAL) CALL ODH0(ISIG,ISIGP,Y,ICAL) C C FILL THE AME ARRAY WHICH HOLDS THE HAMILTONIAN MATRIX ELEMENTS C FOR TWO N-ELECTRON CONFIGURATIONS C 10 IF(ISAMEK-3) 11,12,13 11 DO 14 J=1,JLIMIT DO 14 I=1,ILIMIT 14 AME(I,J)=H0MAT(I,J)+VMAT(I,J) GO TO 19 12 DO 15 I=1,ILIMIT 15 AME(I,I)=H0MAT(I,I)+VMAT(I,I) GO TO 19 13 DO 16 J=1,JLIMIT DO 16 I=1,ILIMIT IF(I.NE.J) AME(I,J)=H0MAT(I,J)+VMAT(I,J) 16 CONTINUE GO TO 19 C C AME IS ZEROISED BECAUSE OF SIMPLE ORTHOGONALITY C 17 DO 18 J=1,JLIMIT DO 18 I=1,ILIMIT 18 AME(I,J)=0. 19 IF(IBUG9.LT.4) RETURN C WRITE(IWRITE,1000) DO 20 I=1,ILIMIT 20 WRITE(IWRITE,1001) (AME(I,J),J=1,JLIMIT) C RETURN END C*********************************************************************** SUBROUTINE NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C ORDERS ALL THE OCCUPIED SHELLS OF THE TWO CONFIGURATIONS C APPEARING IN A GIVEN MATRIX ELEMENT. C C I4,IA1,IB1 ARE, RESPECTIVELY, THE NUMBER OF OCCUPIED SHELLS, C THE NUMBERS INDICATING WHICH SHELLS ARE OCCUPIED, AND THE NUMBERS C OF ELECTRONS IN EACH OCCUPIED SHELL, FOR THE CONFIGURATION ON THE C L.H.S OF THE MATRIX ELEMENT. C I5,IA2,IB2 ARE THE EQUIVALENT NUMBERS FOR THE R.H.S OF THE MATRIX C ELEMENT. C C I3 CONTAINS ON RETURN THE TOTAL NUMBER OF OCCUPIED SHELLS. C PARAMETER (LL41= 15*2-1, LL43= 21*2+3, LL75= 21+2) DIMENSION IA1( 15),IA2( 15),IB1( 15),IB2( 15) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C DEFINE THE NJ AND LJ ARRAYS AS THE N,L VALUES OF EACH SHELL, C AND I3 AS THE HIGHEST OCCUPIED SHELL. C I6 = 0 I9 = 0 DO 4 I2 = 1,I4 I7 = IA1(I2) 1 I6 = I6+1 IF (I6 .GT. I5) GO TO 3 I8 = IA2(I6) IF (I8.GT.I7) GO TO 3 I9 = I9+1 NJ(I9) = NJCOMP(I8) LJ(I9) = LJCOMP(I8) IF (I8 .LT. I7) GO TO 1 GO TO 4 3 I9 = I9+1 NJ(I9) = NJCOMP(I7) LJ(I9) = LJCOMP(I7) I6 = I6-1 4 CONTINUE C IF (I6 .GE. I5) GO TO 6 I7 = I6+1 DO 5 I2 = I7,I5 I9 = I9+1 I8 = IA2(I2) NJ(I9) = NJCOMP(I8) 5 LJ(I9) = LJCOMP(I8) C C DEFINE THE NOSH ARRAYS AS THE NUMBER OF ELECTRONS IN EACH SHELL C FOR EACH OF THE TWO CONFIGURATIONS. C 6 I3=I9 DO 20 I1 = 1,2 DO 7 I2 = 1,I3 7 NOSH(I2,I1) = 0 IF (I1.GT.1) GO TO 9 I6 = I4 GO TO 10 9 I6 = I5 10 DO 19 I7 = 1,I6 IF (I1.GT.1) GO TO 12 I8 = IA1(I7) GO TO 13 12 I8 = IA2(I7) 13 DO 15 I9 = 1,I3 I91 = I9 IF (NJ(I9).NE.NJCOMP(I8)) GO TO 15 IF (LJ(I9).EQ.LJCOMP(I8)) GO TO 16 15 CONTINUE 16 IF (I1.GT.1) GO TO 18 NOSH(I91,I1) = IB1(I7) GO TO 19 18 NOSH(I91,I1) = IB2(I7) 19 CONTINUE 20 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE ODH0(ISIG,ISIGP,TIMES,ICAL) C C EVALUATES THE ONE-ELECTRON INTEGRALS WHERE THE CONFIGURATIONS C DIFFER BY ONE ORBITAL C C ISIG,ISIGP DEFINE THE DIFFERENT ORBITALS C TIMES CONTAINS THE ANGULAR AND SPIN FACTORS C ICAL=0 IF TIMES HAS NOT BEEN CALCULATED C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/CONMX/ H0MAT( 60, 60),VMAT( 60, 60) COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT C IF(ICAL.EQ.0) RETURN N1=NJ(ISIG) N2=NJ(ISIGP) L1=LJ(ISIG)+1 GO TO (1,2,4,6),ISAMEK C C ISAMEK = 1 BOUND-BOUND C 1 CALL FIN1BB(N1,N2,L1,ALBVAL) H0MAT(1,1)= TIMES*ALBVAL RETURN C C ISAMEK = 2 BOUND-CONTINUUM C 2 DO 3 J=1,JLIMIT N3=ND(2,J) CALL FIN1BC(N1,N3,L1,ALBVAL) 3 H0MAT(1,J) = TIMES*ALBVAL RETURN C C ISAMEK = 3 CONTINUUM-CONTINUUM. DIAGONAL MATRIX ELEMENTS C THIS ONLY OCCURS WHEN TWO BOUND ORBITALS DIFFER C 4 CALL FIN1BB(N1,N2,L1,ALBVAL) DO 5 I=1,ILIMIT 5 H0MAT(I,I) = TIMES*ALBVAL RETURN C C ISAMEK = 4 CONTINUUM-CONTINUUM . OFF DIAGONAL MATRIX ELEMENTS C 6 DO 8 I=1,ILIMIT N3=ND(1,I) DO 7 J=1,JLIMIT IF(I.EQ.J) GO TO 7 N4=ND(2,J) CALL FIN1CC(N3,N4,L1,ALBVAL) H0MAT(I,J)=TIMES*ALBVAL 7 CONTINUE 8 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE PNTBG2(I,J) C C PRINTS OUT THE ANGULAR MOMENTUM COUPLING IN EACH STAGE OF SETMX C C I AND J SPECIFY THE TWO INTERACTING CONFIGURATIONS. C C IMPLICIT REAL*8(A-H,O-Z) COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/INFORM/IREAD,IWRITE,IPUNCH C 1000 FORMAT(/45H DIMENSION OF AME IN THIS MATRIX ELEMENT IS,I5,I8) 1001 FORMAT(20I5) C I1=NDCT(1) IF(I1.LE.0) I1=1 J1=NDCT(2) IF(J1.LE.0) J1=1 CALL VIJOUT(I,J) WRITE(IWRITE,1000) I1,J1 DO 1 I4=1,2 I5=NDCT(I4) IF(I5.LE.0) GO TO 1 WRITE(IWRITE,1001) (ND(I4,I6),I6=1,I5) 1 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE PRNTWT(IRHO,ISIG,IRHOP,ISIGP) C C THIS VERSION OF SLATER FINDS THE REQUIRED RK INTEGRALS FROM THE C ARRAYS HELD IN CORE BY CALLING THE FIN ROUTINES C IRHO AND ISIG SPECIFY THE TWO ORBITALS ON THE L.H.S. OF THE RK C INTEGRALS C IRHOP AND ISIGP SPECIFY THE TWO ORBITALS ON ITS R.H.S. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL DTEST,ETEST,MTEST1,MTEST2 CHARACTER*4 XK COMMON/CONMX/ H0MAT( 60, 60),VMAT( 60, 60) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, 1 M16,M17,M18,M19,M20 COMMON/NJLJ/ NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RKMATX/RKMAT( 60, 60),ISAMEK,ILIMIT,JLIMIT COMMON/XATION/AMULT(99),BMULT(99),KD1,KD2,KE1,KE2,MULTD,MULTE C 1000 FORMAT(//23H INTERACTING SHELLS ARE,5X,6H RHO =,I3,4X,6H SIG =,I3, * 4X,7H RHOP =,I3,4X,7H SIGP =,I3/) 1001 FORMAT(22X,30HEVALUATION OF SLATER INTEGRALS) 1002 FORMAT(/12X,3HK =,I2,13H MULTIPLIER =,F11.6,14H, INTEGRAL IS ,A4, * I2,1H,,I2,1H)//6X,5HRKMAT,(T12,6F11.6)) 1003 FORMAT(/12X,3HK =,I2,13H MULTIPLIER =,F11.6,18H, INTEGRAL IS RK(, * I2,1H,,I2,1H/,I2,1H,,I2,1H)//6X,5HRKMAT,(T12,6F11.6)) 1004 FORMAT((7F11.6)) 1005 FORMAT((T12,6F11.6)) C C DEFINITION OF ISAMEK C ISAMEK = 0 C-C ELEMENTS OF RKMAT WITH L.NE.LP C ISAMEK = 1 BOUND-BOUND RK INTEGRALS C ISAMEK = 2 BOUND-CONTINUUM. THE CONTINUUM ORBITAL IS ALWAYS C IN N4 C ISAMEK = 3 CONTINUUM-CONTINUUM DIAGONAL ELEMENTS OF RKMAT C ISAMEK = 4 CONTINUUM-CONTINUUM OFF-DIAGONAL ELEMENTS OF RKMAT C C PRINTS OUT THE COEFFICIENTS OF SLATER INTEGRALS C DEFINITION OF IBUG2 - INITIALLY,IBUG2 IS SET EQUAL TO 2 IN RKWTS. C THE FIRST TIME THE PRESENT SUBROUTINE IS ENTERED FOR EACH MATRIX C ELEMENTS,IBUG2 HAS THIS VALUE. ONCE FORMAT 1001 HAS BEEN WRITTEN, C IBUG2 ASSUMES THE VALUE OF IBUG1. IF IBUG1=0, THERE WILL BE NO C PRINT-OUT AT ALL. IF IBUG1=1, FORMAT 1001 IS OUTPUT ONLY FOR THE C FIRST ENTRY OF PRNTWT AND THUS THE ONLY PRINT-OUT FOR THE MATRIX C ELEMENT AFTER THE FIRST FORMAT 1001 IS A LIST OF COEFFICIENTS C AND THE APPROPRIATE SLATER INTEGRALS-FK,GK,RK. IF IBUG1.GT.1, C FORMAT 1001 IS OUTPUT FOR EACH SET OF IRHO,ISIG,IRHOP,ISIGP C IF(IBUG1.LT.2) GO TO 1 WRITE(IWRITE,1000) IRHO,ISIG,IRHOP,ISIGP IF(IBUG1.NE.0) WRITE(IWRITE,1001) ! IF?? IBUG2=IBUG1 C 1 DTEST=MULTD.EQ.0 ETEST=MULTE.EQ.0 MTEST1=.FALSE. MTEST2=.FALSE. IF(M1+M2.NE.0) MTEST1=.TRUE. IF(M19.NE.0.OR.M20.NE.0) MTEST2=.TRUE. C C DIRECT INTEGRALS C MULTD=0 MEANS NO NON-ZERO =DIRECT =COEFFICIENTS C IF(DTEST) GO TO 16 DO 15 JK1=KD1,KD2,2 K=JK1-1 ID=1 IF(ISAMEK.EQ.0) GO TO 5 GO TO (2,3,4,5),ISAMEK 2 CALL FINBB(ID,K) GO TO 6 3 CALL FINBC(ID,K) GO TO 6 4 JUMP=1 CALL FINCC1(ID,K,JUMP) GO TO 6 5 CALL FINCC2(ID,K) C 6 A=AMULT(JK1) IF(IBUG1.EQ.0) GO TO 12 IF(MTEST2) GO TO 7 XK = ' FK(' I = ISIG GO TO 8 7 IF(MTEST1) GO TO 9 XK = ' GK(' I = IRHOP 8 WRITE(IWRITE,1002) K,A, XK,IRHO,I, * (RKMAT(1,J),J=1,JLIMIT) GO TO 10 9 WRITE(IWRITE,1003) K,A, IRHO,ISIG,IRHOP,ISIGP, * (RKMAT(1,J),J=1,JLIMIT) 10 DO 11 I=2,ILIMIT 11 WRITE(IWRITE,1005) (RKMAT(I,J),J=1,JLIMIT) C 12 IF(ISAMEK.NE.0) GO TO 13 JUMP=1 CALL FINCC1(ID,K,JUMP) ! (over)writing RKMAT(I,I) 13 DO 14 J=1,JLIMIT DO 14 I=1,ILIMIT 14 VMAT(I,J)=VMAT(I,J)+RKMAT(I,J)*A 15 CONTINUE C C EXCHANGE INTEGRALS C MULTE=0 MEANS NO NON-ZERO =EXCHANGE =COEFFICIENTS C 16 IF(ETEST) GO TO 29 DO 28 JK1=KE1,KE2,2 K=JK1-1 IE=2 IF(ISAMEK.EQ.0) GO TO 20 GO TO (17,18,19,20),ISAMEK 17 CALL FINBB(IE,K) GO TO 21 18 CALL FINBC(IE,K) GO TO 21 19 JUMP=1 CALL FINCC1(IE,K,JUMP) GO TO 21 20 CALL FINCC2(IE,K) C 21 B=BMULT(JK1) IF(IBUG1.EQ.0) GO TO 25 IF(MTEST2) GO TO 22 WRITE(IWRITE,1002) K,B, ' GK(', IRHO,ISIG GO TO 23 22 WRITE(IWRITE,1003) K,B, IRHO,ISIG,ISIGP,IRHOP 23 DO 24 I=1,ILIMIT 24 WRITE(IWRITE,1004) (RKMAT(I,J),J=1,JLIMIT) C 25 IF(ISAMEK.NE.0) GO TO 26 JUMP=1 CALL FINCC1(IE,K,JUMP) ! (over)writing RKMAT(I,I) 26 DO 27 J=1,JLIMIT DO 27 I=1,ILIMIT 27 VMAT(I,J)=VMAT(I,J)+RKMAT(I,J)*B 28 CONTINUE C 29 RETURN END C*********************************************************************** SUBROUTINE RDINT(IJUMP,LOT1,LOT2) C C***** NEW CODING FOR IMPROVING I/O ***** FEB 1986, KAB. C READING RK INTEGRALS DIRECT FROM A NEW STG1 DA FILE. C C IF IJUMP=1, READ BOUND-CONTINUUM RK INTEGRALS INTO RKSTO2. C IF IJUMP=2, READ CONTINUUM-CONTINUUM RK INTEGRALS INTO RKSTO2. C C LOT1 AND LOT2 ARE THE ANGULAR MOMENTUM VALUES PLUS ONE FOR C THE CONTINUUM-CONTINUUM INTEGRALS. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) ! LL63=min(NXD1,NXD2): PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5, LL73= 6* 6) C COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8 COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RKSAVE/IRKBC,IRKCC( 49, 49),ICHUNK,ICT(140000), * ICTDE( 49, 49) C IF (IJUMP.GT.1) GO TO 2 C C POSITION THE READING HEADS AND / OR READ THE BOUND-CONTINUUM C INTEGRALS C IDPOS1 = 0 IDPOS2 = 0 IREC=1 IRK2=IRKBC CALL DA2(1,IREC,JDISC1,IRKBC,RKSTO2) RETURN C C READ THE CONTINUUM-CONTINUUM INTEGRALS C 2 IREC=ITAPST(LOT1,LOT2) IF(IREC.EQ.0) RETURN IRK2=IRKCC(LOT1,LOT2) LOOPCC=1+IRK2/ICHUNK JSTART=1 JRK2=ICHUNK DO 3 L=1,LOOPCC IF(L.EQ.LOOPCC) JRK2=MOD(IRK2,ICHUNK) IF(JRK2.EQ.0) GO TO 3 CALL DA2(1,IREC,JDISC1,JRK2,RKSTO2(JSTART)) JSTART=JSTART+JRK2 3 CONTINUE C I1=MIN(2*LRANG1-1,LOT1+LOT2-1) I2=MIN(LRANG1+LOT1,LRANG1+LOT2)-1 IC=ICTDE(LOT1,LOT2)-1 DO 5 K=1,I1 DO 5 J=1,LRANG1 DO 4 I=1,LRANG1 4 ICTCCD(I,J,K)=ICT(IC+I) IC=IC+LRANG1 5 CONTINUE DO 7 K=1,I2 DO 7 J=1,LRANG1 DO 6 I=1,LRANG1 6 ICTCCE(I,J,K)=ICT(IC+I) IC=IC+LRANG1 7 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE READTP C C READS THE MULTIPOLE INTEGRALS AND THE ONE AND TWO ELECTRON C INTEGRALS FROM TAPE AND WRITES THOSE REQUIRED ONTO SCRATCH DISC C ITAPE1 IS THE INPUT TAPE FILE AND IDISC1, IDISC2 AND IDISC3 ARE C THE SCRATCH DISC FILES C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL FIRST,ALLCOP PARAMETER (L44=199) PARAMETER (LL41=2* 15-1, LL42=2* 15+1, LL59=2*1280, LL61= 15+1) PARAMETER (MXD1= 49* 5, MXD2= 5*(( 5-1)*3+1)) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL62=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) PARAMETER (NXD1= 5*2-1, NXD2= 49+ 5+1) ! LL63=min(NXD1,NXD2): PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL63=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (LL64= 49+ 5, LL65= 5* 5) PARAMETER (LXD1= 49,LXD2= 5) ! LL66=max(LXD1,LXD2)**2: PARAMETER (LXT1=LXD1/LXD2,LXT2=LXD2/LXD1,LXT0=LXT1+LXT2) PARAMETER (LL00=LXD1*LXT1/LXT0+LXD2*LXT2/LXT0) PARAMETER (LL66=LL00*LL00, LL67=LL66*LL00) PARAMETER (LL68= 8/2, LL71= 60+1, LL73= 6* 6, LL75= 21+2) C DIMENSION COEFF(3, 49),HNP1(1), KSLP(L44) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/ EIGENS( 60),ENDS( 49,LL71),DELTA,ETA COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/CASES/ MORE,MSKIP,IPOLPH,INAST COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CSTORE/CTABLE(LL67),KPOINT(LL66),LRANG3 COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DIAG/ NDIAG,LRAN22 COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON /FACT/GAMMA( 250) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8 COMMON/INSTO2/RKSTO1(5767), 1 ONEST1( 56),ONEST2( 820),ONEST3(1830, 49), 2 RMASS1( 56),RMASS2( 820),RMASS3(1830, 49), 3 RDAR1( 35),RDAR2( 210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL65),ICTBC( 5, 5,LL62), 1 ICTCCD( 5, 5,LL63),ICTCCE( 5, 5,LL64), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 580), 3 ISTBC2( 580),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), * ICCPOL( 49, 49,LL68) COMMON/INSTO5/BBINT(1000),IBBI COMMON/JNSTO/ BNORM( 49),SKSTO2(2400), 1 JRK8,JBCPOL( 5, 49),JCCPOL( 49, 49) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/POTORB/PV(LL59) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3),JRELOP(3) COMMON/RKSAVE/IRKBC,IRKCC( 49, 49),ICHUNK,ICT(140000), * ICTDE( 49, 49) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) DIMENSION MAXNC( 49) SAVE KSLP C 1001 FORMAT( 57H READ OF THE MULTIPOLE INTEGRALS COMPLETED (LAMIND,IRK8 * =,I2,I7,1H)) 1002 FORMAT(45H READ OF THE ONE ELECTRON INTEGRALS COMPLETED) 1003 FORMAT(' BOUND-BOUND INTEGRALS READ, READING BOUND-CONTINUUM INTEG *RALS IF LRANG2.NE.0') 1004 FORMAT(52H READ OF THE CONTINUUM CONTINUUM INTEGRALS COMPLETED) 1008 FORMAT(7H NELC =,I3,6H NZ =,I3,10H LRANG1 =,I3,10H LRANG2 =,I3, * 10H NRANG2 =,I3,9H LAMAX =,I3,7H LAM =,I2/ * 17H MASS-CORRECTION(,I1,2H),,13H DARWIN-TERM(,I1,2H),, * 12H SPIN-ORBIT(,I1,1H)) 1009 FORMAT(/8H NCHAN =,I4,9H NCONHP =,I6,7H MNP1 =,I6) 1010 FORMAT(/' COMPUTING FACTORIALS UP TO ARGUMENT',I5) 1013 FORMAT(29H READ OF BASIC DATA COMPLETED) 1014 FORMAT(5H RA =,F10.5,1P,8H BSTO =,E12.4) 1016 FORMAT(/7X,43H**RELATIVISTIC OPTIONS ARE NOT CONSISTENT**) C C ICOPY1 = POSITION OF FIRST BLOCK OF DATA TO BE COPIED FROM ITAPE2 C TO ITAPE3. C ICOPY2 = POSITION OF LAST BLOCK OF DATA TO BE COPIED FROM ITAPE2 C TO ITAPE3. C ITOTAL = TOTAL NUMBER OF DATA BLOCKS REQUIRED ON ITAPE3. C C IF ITOTAL=0, THE PARTIAL-WAVE SYMMETRIES ARE C LOOPED WITHOUT CALCULATING ANY H-MATRICES ... C THUS ONLY DIPOLE MATRICES ARE CALCULATED. C C ICOUNT IS A COUNT ON THE DATA BLOCKS ON TAPE. C C ALLCOP =.TRUE.IF ALL DATA BLOCKS CAN BE COPIED FOR THIS SYMMETRY. C NCHAN = 0 WRITE(IWRITE,'(//52X,17HSUBROUTINE READTP/52X,17(1H-))') FIRST=MSKIP.LT.0 CX ALLCOP=.NOT.FIRST.AND.ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2-3 IF(.NOT.FIRST) GO TO 10 WRITE(IWRITE,'(/29H READ THE DATA TAPE FROM STG1/)') C C READ IN THE BASIC NUMBERS, THE ORBITAL EIGENENERGIES AND C AMPLITUDES AT RA, THE INTEGRATION MESH, THE POTENTIAL PARAMETERS C AND THE ATOMIC ORBITAL PARAMETERS C C NOTE THAT NELC MUST NOT BE OVERWRITTEN BY STG1 VALUE (IDUM2) C WHEN MODEL POTENTIALS ARE BEING USED. C REWIND ITAPE1 READ(ITAPE1) IDUM2,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,NPOT *,(IRELOP(I),I=1,3) WRITE(IWRITE,1008)IDUM2,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM,IRELOP IF(LRANG1.GT.IDMTST(16)) CALL RECOV1(16,LRANG1) IF(LRANG2.GT.IDMTST(15)) CALL RECOV1(15,LRANG2) IF(NRANG2.GT.IDMTST(7)) CALL RECOV1(7,NRANG2) IF(LAMAX.GT.IDMTST(18)) CALL RECOV1(18,LAMAX) C C CHECK THAT RELATIVISTIC OPTIONS REQUESTED ARE AVAILABLE C DO 6 I=1,3 IF (IRELOP(I).NE.0) GO TO 6 IF (JRELOP(I).EQ.0) GO TO 6 WRITE(IWRITE,1016) STOP 6 CONTINUE MSKIP=0 ICODE=21 C ICODE=SIGN(21,IPOLPH) IF(IPOLPH.GT.2) ICODE=-21 C INDICATING E2+M1 DATA! READ(ITAPE1) (MAXNHF(L),L=1,LRANG1),(MAXNLG(L),L=1,LRANG1) *,(MAXNC(L),L=1,LRANG1) WRITE(IWRITE,'(9H MAXNHF =,20I3)') (MAXNHF(L),L=1,LRANG1) WRITE(IWRITE,'(9H MAXNLG =,20I3)') (MAXNLG(L),L=1,LRANG1) IF(ITOTAL.LE.0) GO TO 2 REWIND ITAPE3 WRITE(ITAPE3)IDUM2,NZ,LRANG1,LRANG2,NRANG2,LAMAX, * ICODE,LAM,NPOT,JRELOP WRITE(ITAPE3)(MAXNHF(L),L=1,LRANG1), * (MAXNLG(L),L=1,LRANG1),(MAXNC(L),L=1,LRANG1) 2 DO 1 L=1,LRANG2 READ(ITAPE1) (EIGENS(N),N=1,NRANG2) READ(ITAPE1) (ENDS(L,N),N=1,NRANG2+1) IF(ITOTAL.LE.0) GO TO 1 WRITE(ITAPE3)(EIGENS(N),N=1,NRANG2) WRITE(ITAPE3)(ENDS(L,N),N=1,NRANG2+1) 1 CONTINUE READ(ITAPE1) RA,BSTO,HINT,DELTA,ETA,NIX WRITE(IWRITE,1014)RA,BSTO IF(ITOTAL.GT.0) WRITE(ITAPE3)RA,BSTO,HINT,DELTA,ETA,NIX IF(NIX.LE.0) GO TO 5 IF(NIX.GT.IDMTST(17)) CALL RECOV1(17,NIX) READ(ITAPE1) (IHX(I),I=1,NIX),(IRX(I),I=1,NIX) IF(IRX(NIX).GT.IDMTST(9)) CALL RECOV1(9,IRX(NIX)) IPTS=2*IRX(NIX) READ(ITAPE1) (PV(I),I=1,IPTS) IF(ITOTAL.LE.0) GO TO 7 WRITE(ITAPE3)(IHX(I),I=1,NIX),(IRX(I),I=1,NIX) WRITE(ITAPE3)(PV(I),I=1,IPTS) 7 DO 4 L=1,LRANG1 NBT=MAXNLG(L)-L+1 IF(NBT.LE.0) GO TO 4 DO 3 K=1,NBT READ(ITAPE1) (PV(I),I=1,IPTS) IF(ITOTAL.GT.0) WRITE(ITAPE3)(PV(I),I=1,IPTS) 3 CONTINUE 4 CONTINUE 5 READ(ITAPE1) ((COEFF(I,L),I=1,3),L=1,LRANG2) IF(ITOTAL.GT.0) WRITE(ITAPE3) ((COEFF(I,L),I=1,3),L=1,LRANG2) WRITE(IWRITE,1013) IF(IPOLPH.LE.1) GO TO 10 REWIND IDISC3 REWIND IDISC4 C C EVALUATE AND WRITE OUT THE COUPLED CHANNELS C 10 IF(INAST.LE.0) GO TO 14 IF(ICOUNT.LT.ICOPY1.OR.ICOUNT.GT.ICOPY2) THEN CALL SETCUP NCONHP=NRANG2*NCHAN MNP1 =NCONHP+NCFGP ELSE READ(ITAPE2) LRGL,NSPN,NPTY,NCFGP,IPOLPH IF(IPOLPH.GE.2) CALL SETCUP READ(ITAPE2) MNP1,NCONHP,NCHAN IF(NCHAN.GT.IDMTST(5)) CALL RECOV1(5,NCHAN) READ(ITAPE2) (NCONAT(I),I=1,NAST) READ(ITAPE2) (L2P(I),I=1,NCHAN) READ(ITAPE2) MORE IF(MORE.EQ.0) ICOPY2=MIN(ICOPY2,ICOUNT+3) IF(JRELOP(3).EQ.0) THEN IF(FIRST.AND.NDIAG.NE.0) THEN READ(ITAPE2) NAST READ(ITAPE2) (ENAT(I),I=1,NAST), * (LAT(I),I=1,NAST),(ISAT(I),I=1,NAST) ENDIF ELSE IF(NCFGP.GT.0.AND.LRANG2.GT.0) THEN READ(ITAPE2) (IOCCSH(I),I=1,NCFGP) DO 51 I=1,NCFGP IL=IOCCSH(I) ILL=2*IL-1 51 READ(ITAPE2)(IOCORB(J,I),J=1,IL),(IELCSH(J,I),J=1,IL), * ((I1QNRD(J,K,I),K=1,3),J=1,ILL) ENDIF IF(FIRST) THEN READ(ITAPE2) IRK5 READ(ITAPE2) (IST1(I),I=1,LRANG1),(PV(I),I=1,IRK5) READ(ITAPE2) IRK6 READ(ITAPE2) (IST2(I),I=1,LRANG1),(PV(I),I=1,IRK6) print "(' READTP test: LRAN22 =',I4)", LRAN22 DO 53 L=1,LRAN22 READ(ITAPE2) IRK7 53 READ(ITAPE2) (PV(I),I=1,IRK7) IF(NDIAG.EQ.0) THEN READ(ITAPE2) JSYM DO 54 I=1,JSYM READ(ITAPE2) LR,NS,NP,NTC,N 54 READ(ITAPE2) HNP1(1) ENDIF ENDIF ENDIF ENDIF C WRITE(IWRITE,1009) NCHAN,NCONHP,MNP1 C IF(NCHAN.EQ.0) GO TO -- ZHL'93MAY3-->WE'93MAY7-->RUB'94MAY28/JUN17 J=(1-2*NPTY)*(NSPN*1000+LRGL) DO 55 I=1,MSKIP IF(KSLP(I).NE.J) GO TO 55 NCHAN=0 PRINT *,'*** SKIPPED AS DUPLICATE TO SYMMETRY ',I RETURN 55 CONTINUE IF(MSKIP.LT.L44) THEN KSLP(MSKIP+1)=J ELSE NCHAN=0 PRINT *,'*** SKIPPED: ENLARGE PARAM L44 IN ROUTINE READTP!' ENDIF IF(NCHAN.EQ.0) RETURN 14 IF(ITOTAL.EQ.0) GO TO 66 IF(MSKIP.NE.0) GO TO 45 J=NAST IF(NDIAG.NE.0) J=-J WRITE(ITAPE3) J WRITE(ITAPE3)(ENAT(I),I=1,NAST),(LAT(I),I=1,NAST), * (ISAT(I),I=1,NAST),(IPTY(I),I=1,NAST) IF(JRELOP(3).EQ.0) GO TO 45 WRITE(ITAPE3) NCFG,(NOCCSH(I),I=1,NCFG) DO 15 I=1,NCFG IL=NOCCSH(I) ILL=2*IL-1 15 WRITE(ITAPE3)(NOCORB(J,I),J=1,IL),(NELCSH(J,I),J=1,IL), * ((J1QNRD(J,K,I),K=1,3),J=1,ILL) WRITE(ITAPE3) MAXORB,(NJCOMP(J),J=1,MAXORB), * (LJCOMP(J),J=1,MAXORB) WRITE(ITAPE3) (NTCON(J),J=1,NAST) DO 17 I=1,NAST NT=NTCON(I) 17 WRITE(ITAPE3)(NTYP(I,J),J=1,NT),(AIJ(I,J),J=1,NT) C N.B. WE'94MAR: AIJ NOT YET KNOWN HERE! HENCE REPEAT IN BOUND. C 45 WRITE(ITAPE3)LRGL,NSPN,NPTY,NCFGP,IPOLPH WRITE(ITAPE3)MNP1,NCONHP,NCHAN WRITE(ITAPE3) (NCONAT(I),I=1,NAST) WRITE(ITAPE3) (L2P(I),I=1,NCHAN) MORE2=1 IF(MSKIP+1.GE.INAST.OR.ICOUNT.GE.ITOTAL-3) MORE2=0 WRITE(ITAPE3)MORE2 IF(JRELOP(3).EQ.0.OR.NCFGP.LE.0) GO TO 66 WRITE(ITAPE3) (IOCCSH(I),I=1,NCFGP) DO 46 I=1,NCFGP IL=IOCCSH(I) ILL=2*IL-1 46 WRITE(ITAPE3)(IOCORB(J,I),J=1,IL),(IELCSH(J,I),J=1,IL), * ((I1QNRD(J,K,I),K=1,3),J=1,ILL) C C STORE THE ATOMIC OR RESIDUAL IONIC STATE DATA ON IDISC4, C THESE ARE ALSO REQUIRED IN SUBROUTINE DMEL. C 66 IF(IPOLPH.LE.1) GO TO 8 WRITE(IDISC4) NAST,(NTCON(I),I=1,NAST),(NCONAT(I),I=1,NAST), 1 LRGL,NSPN,NPTY DO 23 I=1,NAST NT=NTCON(I) NC=NCONAT(I) 23 WRITE(IDISC4) (NTYP(I,J),J=1,NT),(AIJ(I,J),J=1,NT), * (LCONAT(J,I),J=1,NC) C -- AIJ (FOR BUTTLE IN DMEL) UNKNOWN BEFORE CALLING BOUND! WRITE(IDISC4) NCFGP,(IOCCSH(I),I=1,NCFGP) DO 24 I=1,NCFGP IL=IOCCSH(I) ILL=2*IL-1 24 WRITE(IDISC4) (IOCORB(J,I),J=1,IL),(IELCSH(J,I),J=1,IL), * ((I1QNRD(J,K,I),K=1,3),J=1,ILL) 8 IF(MSKIP.NE.0) RETURN C C C SET UP THE FACTORIAL ARRAY, CHECK RANGE OF GAMMA *** J=MAX( (MAX(LRANG1,LRANG2)-1)*2),LAMAX)+L+2 C LRANG3=MAX(LRANG1,LRANG2) L=(LRANG3-1)*2 J=MAX(L,LAMAX)+L+2 IF(J.GT.IDMTST(8)) CALL RECOV1(8,J) WRITE(6,1010) J-1 C CALL SHRIEK(IDMTST(8)) -- QUB'92JUL09 FOR THE BENEFIT OF THE VAX: C CALL SHRIEK(J): GAMMA(I+1)=FACTORIAL I GAMMA(1)=1 DO 19 I=2,J 19 GAMMA(I) = (I-1)*GAMMA(I-1) C C EXTEND THE MAXNHF ARRAY IF NECESSARY C DO 11 L=LRANG1+1,LRANG2 11 MAXNHF(L)=L-1 C C C READ THE MULTIPOLE INTEGRALS FROM ITAPE1 AND STORE THEM ON IDISC3 C FOR USE IN SUBROUTINE DMEL. C FIRST=.TRUE. IBBI=0 READ(ITAPE1) IRK8,JRK8 IF (IPOLPH.GT.1) WRITE(IDISC3)IRK8 IF(IRK8.EQ.0) GO TO 22 IF(IRK8.GT.IDMTST(2)) CALL RECOV1(2,IRK8) LAMIND=(LAMAX+1)/2 READ(ITAPE1) (((IBBPOL(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,LAMIND), 1 (((IBCPOL(I,J,K),I=1,LRANG1),J=1,LRANG2),K=1,LAMIND), 2 (((ICCPOL(I,J,K),I=1,LRANG2),J=1,LRANG2),K=1,LAMIND) 3 ,(RKSTO2(I),I=1,IRK8) IF (IPOLPH.GT.1) WRITE(IDISC3)(RKSTO2(I),I=1,IRK8) WRITE(IWRITE,1001) LAMIND,IRK8 IF(JRK8.GT.0) THEN READ(ITAPE1)((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2), 1 ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2), 2 (SKSTO2(J),J=1,JRK8), (BNORM(J),J=1,LRANG2) WRITE(IWRITE,*)'READ OF BLOCK 1+1/2 COMPLETED' ENDIF C C READ THE BOUND-BOUND MULTIPOLE INTEGRALS INTO THE TEMPORARY C BBINT ARRAY FOR USE IN SUBROUTINE AIJS. C DO 18 K=1,LAMIND DO 18 J=1,LRANG2 DO 13 I=1,LRANG1 IP=IBCPOL(I,J,K) IF(IP.GT.0) GO TO 20 13 CONTINUE DO 16 I=1,LRANG2 IP=ICCPOL(I,J,K) IF(IP.GT.0) GO TO 20 16 CONTINUE 18 CONTINUE IP=IRK8+1 20 IBBI=IP-1 IF(IBBI.GT.IDMTST(30)) CALL RECOV1(30,IBBI) DO 21 I=1,IBBI 21 BBINT(I)=RKSTO2(I) C C READ THE ONE-ELECTRON INTEGRALS FROM ITAPE1. C 22 READ(ITAPE1) IRK5 IF(IRK5.GT.IDMTST(19)) CALL RECOV1(19,IRK5) READ(ITAPE1) (IST1(I),I=1,LRANG1),(ONEST1(I),I=1,IRK5) IF(IRELOP(1).GT.0) READ(ITAPE1) (RMASS1(I),I=1,IRK5) IF(IRELOP(3).GT.0) READ(ITAPE1) (PV(I),I=1,IRK5) C IF(IRELOP(3).GT.0.AND.FIRST) THEN -- RUB'94JUN5: IF(JRELOP(3).NE.0) THEN WRITE(ITAPE3) IRK5 WRITE(ITAPE3)(IST1(I),I=1,LRANG1),(PV(I),I=1,IRK5) ENDIF IF(IRELOP(2).GT.0) THEN READ(ITAPE1) IRK9 IF(IRK9.GT.IDMTST(31)) CALL RECOV1(31,IRK9) READ(ITAPE1) (RDAR1(I),I=1,IRK9) ENDIF READ(ITAPE1) IRK6 IF(IRK6.GT.IDMTST(20)) CALL RECOV1(20,IRK6) READ(ITAPE1) (IST2(I),I=1,LRANG1),(ONEST2(I),I=1,IRK6) IF(IRELOP(1).GT.0) READ(ITAPE1) (RMASS2(I),I=1,IRK6) IF(IRELOP(3).GT.0) READ(ITAPE1) (PV(I),I=1,IRK6) IF(JRELOP(3).NE.0) THEN WRITE(ITAPE3) IRK6 WRITE(ITAPE3)(IST2(I),I=1,LRANG1),(PV(I),I=1,IRK6) ENDIF IF(IRELOP(2).GT.0) THEN READ(ITAPE1) IRK10 IF(IRK10.GT.IDMTST(32)) CALL RECOV1(32,IRK10) READ(ITAPE1) (RDAR2(I),I=1,IRK10) ENDIF DO 26 L=1,LRANG2 READ(ITAPE1) IRK7 IF(IRK7.GT.IDMTST(21)) CALL RECOV1(21,IRK7) READ(ITAPE1) (ONEST3(I,L),I=1,IRK7) IF(IRELOP(1).GT.0) READ(ITAPE1) (RMASS3(I,L),I=1,IRK7) IF(IRELOP(3).GT.0.AND.L.GT.1) READ(ITAPE1) (PV(I),I=1,IRK7) IF(JRELOP(3).NE.0.AND. L.GT.1) THEN WRITE(ITAPE3) IRK7 WRITE(ITAPE3) (PV(I),I=1,IRK7) ENDIF IF(IRELOP(2).GT.0.AND.L.EQ.1) READ(ITAPE1)(RDAR3(I),I=1,IRK7) 26 CONTINUE WRITE(IWRITE,1002) C C READ THE RK INTEGRALS FROM ITAPE1 C C FIRST READ THE BOUND-BOUND AND THE BOUND-CONTINUUM RK INTEGRALS C I1=LRANG1*LRANG1 READ(ITAPE1) IRK1,IRK4 IF(IRK1.GT.IDMTST(1)) CALL RECOV1(1,IRK1) IF(IRK4.GT.IDMTST(4)) CALL RECOV1(4,IRK4) READ(ITAPE1) (((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), 1 (ISTBB1(I),I=1,IRK4),(ISTBB2(I),I=1,IRK4) 2 ,(RKSTO1(I),I=1,IRK1) WRITE(IWRITE,1003) IF(LRANG2.EQ.0) GO TO 44 I1 = MIN(LRANG2,(LRANG1-1)*3+1) * LRANG1 READ(ITAPE1) IRK2,IRK3 IF(IRK2.GT.IDMTST(2)) CALL RECOV1(2,IRK2) IF(IRK3.GT.IDMTST(3)) CALL RECOV1(3,IRK3) READ(ITAPE1) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), 1 (ISTBC1(I),I=1,IRK3),(ISTBC2(I),I=1,IRK3) C***** NEW CODING FOR IMPROVING I/O IN READTP ***** FEB 1986, KAB. IRKBC=IRK2 IREC=0 CALL DA2(0,IREC,JDISC1,IRKBC,RKSTO2) C C SET CONTINUUM-CONTINUUM RK INTEGRAL POINTERS C I3=0 DO 28 I=1,LRANG2 DO 27 J=1,LRANG2 ictde(I,J)=0 ictde(J,I)=0 ITAPST(I,J)=0 27 IRKCC(I,J)=0 28 CONTINUE C C WRITE(IWRITE,'(43H THE FOLLOWING ANGULAR MOMENTA ARE REQUIRED)') ISTART=1 ICHUNK=1 LAST=-1 LASTP=-1 29 READ(ITAPE1) JRK2,L,LP IF(L.EQ.LAST.AND.LP.EQ.LASTP) GO TO 30 ITAPST(L+1,LP+1)=IREC ITAPST(LP+1,L+1)=IREC LAST=L LASTP=LP 30 IRK2=ABS(JRK2) IF(IRK2.EQ.0) GO TO 34 ICHUNK=MAX(ICHUNK,IRK2) IRKCC(L+1,LP+1)=IRKCC(L+1,LP+1)+IRK2 IRKCC(LP+1,L+1)=IRKCC(L+1,LP+1) IF(IRKCC(L+1,LP+1).GT.IDMTST(2)) CALL RECOV1(2,IRKCC(L+1,LP+1)) CALL DA2(0,IREC,JDISC1,IRK2,RKSTO2) IF(JRK2.LT.0) GO TO 29 I1 = MIN(2*LRANG1-1,L+LP+1) I2 = MIN(L,LP) + LRANG1 IEND=ISTART-1+LRANG1*LRANG1*(I1+I2) IF(IEND.GT.IDMTST(22)) CALL RECOV1(22,IEND) READ(ITAPE1) (ICT(K),K=ISTART,IEND) ICTDE(L+1,LP+1)=ISTART ICTDE(LP+1,L+1)=ISTART C print "(' READTP test: L,LP,ISTART =',3I5)",L,LP,ISTART !'05Nov05 ISTART=IEND+1 34 IF(L.LT.LRANG2-1.OR.LP.LT.LRANG2-1) GO TO 29 35 WRITE(IWRITE,1004) C***** END OF NEW CODING FOR IMPROVING I/O ***** C C **** NEW CODE. CALCULATE AND STORE COEFFICIENTS (L//C(K)//LP) C - NOT USED! RUB'94JUN5 LPOINT=0 DO 43 L1=0,LRANG3-1 DO 42 L2=0,LRANG3-1 KD1=ABS(L1-L2) KLIM=(L1+L2-KD1)/2 KPOINT(L1*LRANG3+L2+1)=LPOINT DO 41 J=0,KLIM LPOINT=LPOINT+1 IF(LPOINT.GT.LL67) THEN PRINT *,' READTP WARNING: CTABLE TOO SMALL IF IT WERE USED' GO TO 44 ENDIF K=J*2+KD1 41 CTABLE(LPOINT)=RME(L1,L2,K) 42 CONTINUE 43 CONTINUE 44 RETURN END C*********************************************************************** SUBROUTINE RECOV1(I,ID) C C THIS ROUTINE IS CALLED ONLY IN THE CASE OF ARRAY OVERFLOW. C IF IPLACE=0 THE PROGRAM STOPS HERE, OTHERWISE THE PROGRAM RETURNS C TO THE CALLING ROUTINE AFTER SETTING IPLACE=I. C C I IS THE POSITION IN THE IDMTST ARRAY, WHICH HOLDS THE CURRENT C ARRAY DIMENSIONS C ID IS THE ARRAY SIZE REQUIRED BY THE DATA C COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/RECOV/ IPLACE,IDMTST(50) C 1000 FORMAT(/19H * ARRAY OVERFLOW */45H MUST INCREASE ARRAYS ASSOCIATED * WITH IDMTST(,I2,2H)=,I7/20H TO AT LEAST IDMTST(,I2,2H)=,I7) 1001 FORMAT(/29H PROGRAM TERMINATES IN RECOV1/) 1002 FORMAT(/54H CHECK TO SEE IF OTHER ARRAYS ARE GOING TO BE EXCEEDED) C WRITE(IWRITE,1000) I,IDMTST(I),I,ID IF(IPLACE) 2,1,3 1 WRITE(IWRITE,1001) STOP C 2 WRITE(IWRITE,1002) 3 IPLACE=I ID=IDMTST(I) RETURN END C*********************************************************************** SUBROUTINE RKWTS PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), C REPLACE CARDS 548,577,673,867,1494,2262,2309,2355 BY A COPY OF C THE NEXT CARD * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, 1 M16,M17,M18,M19,M20 COMMON/REMOVE/ICHOP(LL75) C C THE MATRIX ELEMENT OF THE TWO-ELECTRON POTENTIAL BETWEEN TWO C STATES (LABELLED 1 AND 2) MAY BE EXPRESSED AS A SUM OF WEIGHTED C RK (SLATER) INTEGRALS. THIS SUBROUTINE, TOGETHER WITH THOSE C CALLED BY IT DETERMINES THESE WEIGHTS, WHICH ARISE FROM AN C INTEGRATION OVER THE ANGULAR AND SPIN CO-ORDINATES; C FOR DETAILS, SEE U. FANO, PHYS. REV.,140,A67,(1965) C C THE =INTERACTING= SHELLS ARE DESIGNATED IRHO,ISIG,IRHOP,ISIGP. C THE FIRST TWO REFER TO THE L.H.S. OF (PSI/V/PSIP) , WHILE C THE SECOND TWO REFER TO THE R.H.S. FOR DIAGONAL AND CERTAIN OFF- C DIAGONAL MATRIX ELEMENTS, THESE MAY NOT BE UNIQUE, AND EACH C POSSIBILITY MUST BE CONSIDERED IN TURN C THE CONDITION =IRHO .LE. ISIG , IRHOP .LE. ISIGP= IS TO BE C SATISFIED C 61 FORMAT(//17H RKWTS: IRHO =,I3,3X,6HISIG =,I3,3X, * 7HIRHOP =,I3,9H ISIGP =,I3) C C === DETERMINE THE INTERACTING SHELLS AS FAR AS POSSIBLE BY C CONSIDERING THE DIFFERENCES BETWEEN PSI AND PSIP C IBUG2=2 IX=0 IRHO=0 ISIG=0 IRHOP=0 ISIGP=0 DO 4 J=1,IHSH N=NOSH1(J)-NOSH2(J) IF(ABS(N).GT.2) GO TO 1 IF(N) 7,4,6 6 IF(N.GT.1) GO TO 9 C C --- TO SATISFY =IRHO.LE.ISIG= IRHO IS SET FIRST, ETC. C IF(IRHO.GT.0) GO TO 11 IRHO = J GO TO 17 11 ISIG=J GO TO 17 9 IRHO=J GO TO 15 7 IF(N+1) 13,14,4 14 IF(IRHOP.GT.0) GO TO 16 IRHOP = J GO TO 17 16 ISIGP=J 17 IX=IX+1 GO TO 4 13 IRHOP=J 15 IX=IX+2 4 CONTINUE C C IX MEASURES THE TOTAL NUMBER OF ELECTRONS IN EITHER CONFIGURATION C WHICH DO NOT OCCUR IN THE OTHER. THEN IF IX IS GREATER THAN 4, C ORTHOGONALITY OF THE ORBITALS PREVENTS A NON-ZERO MATRIX ELEMENT. C IF IX IS LESS THAN 4, THEN WE DIVIDE IX BY 2 AND NOW IX MEASURES C THE NUMBER OF ELECTRONS WHICH HAVE BEEN CHANGED IN GOING FROM PSI C TO PSIP. IF NOW IX=0, WE HAVE A DIAGONAL MATRIX ELEMENT. RHO AND C SIG MAY TAKE ON ANY VALUES LESS THAN IHSH. IF IX=1, ONE INTER- C ACTING SHELL ON EACH SIDE IS FIXED, WHILE THE OTHER MAY VARY. IF C IX=2, ALL INTERACTING SHELLS ARE DETERMINED C IF(IX.GT.4) GO TO 1 IX=IX/2 IF(IX-1) 19,20,21 C C === UNIQUE SPECIFICATION OF INTERACTING SHELLS C 21 IF(ISIG.EQ.0) ISIG=IRHO IF(ISIGP.EQ.0) ISIGP = IRHOP IF(IBUG1.GT.1) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP C C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS C 70 CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) C REPLACE CARDS 758 AND 759 BY THE NEXT CARD CALL SETM 75 CALL FANO(IRHO,ISIG,IRHOP,ISIGP) IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) RETURN C C === ONE INTERACTING SHELL SPECIFIED ON EACH SIDE. SUMMATION OVER OTHER C 20 IRSTO=IRHO IRPSTO=IRHOP DO 125 K1=1,IHSH IF(NOSH1(K1).EQ.0) GO TO 125 ISIG=K1 IF(NOSH2(K1).EQ.0) GO TO 125 ISIGP = K1 IRHO=IRSTO IRHOP=IRPSTO C C ORTHOGONALITY OF THE ORBITALS REQUIRES THAT THE VARYING INTER- C ACTING SHELL BE THE SAME ON BOTH SIDES OF THE MATRIX ELEMENT C C --- IRHO.LE.ISIG, IRHOP.LE.ISIGP C IF(IRHO-ISIG) 27,127,227 227 ISTO=IRHO IRHO=ISIG ISIG = ISTO GO TO 27 127 IF(NOSH1(ISIG).LE.1) GO TO 125 27 IF(IRHOP-ISIGP) 30,130,31 31 ISTO=IRHOP IRHOP = ISIGP ISIGP = ISTO GO TO 30 130 IF(NOSH2(ISIGP).LE.1) GO TO 125 30 IF(IBUG1.GT.1) WRITE(IWRITE,61) IRHO,ISIG,IRHOP,ISIGP C C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS C CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) C REPLACE CARDS 799 AND 800 BY THE NEXT CARD CALL SETM CALL FANO(IRHO,ISIG,IRHOP,ISIGP) IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) 125 CONTINUE RETURN C C === NO INTERACTING SHELLS SPECIFIED C SUMMATION OVER ALL POSSIBLE COMBINATIONS C IN THIS CASE, ORTHOGONALITY OF ORBITALS PRECLUDES ALL CASES C EXCEPT IRHO=IRHOP AND ISIG=ISIGP C 19 DO 32 K1=1,IHSH IF(NOSH1(K1).EQ.0) GO TO 32 ISIG=K1 DO 33 K2=1,K1 IF(NOSH1(K2).EQ.0) GO TO 33 IRHO=K2 IF(IRHO.NE.ISIG) GO TO 50 IF(NOSH1(ISIG).LE.1) GO TO 33 50 IRHOP=IRHO ISIGP=ISIG IF(IBUG1.GT.1) WRITE(IWRITE,61) IRHO,ISIG,IRHO,ISIG C C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS C IF(LJ(IRHO).GT.4) GO TO 74 IF(LJ(ISIG).GT.4) GO TO 74 IF(ICHOP(K1).EQ.1.OR.ICHOP(K2).EQ.1) GO TO 34 74 CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) C REPLACE CARDS 828 AND 829 BY THE NEXT CARD CALL SETM CALL FANO(IRHO,ISIG,IRHOP,ISIGP) IF(LESSEN.NE.0) CALL MEREST(IRHO,ISIG,IRHOP,ISIGP) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) GO TO 33 34 CALL USEEAV(IRHO,ISIG) 33 CONTINUE 32 CONTINUE 1 RETURN C DELETE CARDS 838 THROUGH 857 END C*********************************************************************** SUBROUTINE SETCUP C C - EVALUATES COUPLING MATRICES NCONOB,LCONOB,NCONAT AND LCONAT. C IT ALSO DETERMINES THE NUMBER OF COUPLED EQUATIONS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL75= 21+2) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C COMMON/REL/ IRELOP(3),JRELOP(3) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C1000 FORMAT(//52X,17HSUBROUTINE SETCUP/52X,17(1H-)) 1001 FORMAT(/' WARNING:',I8,' COMPONENTS DROPPED, BECAUSE' * /' ******* LMAX=',I2,' .GE. LRANG2=',I2,' -- SEE STG1!') 1010 FORMAT(/54H *** WARNING *** NO COUPLED CHANNELS FOR THIS SYMMETRY) C LMAX=0 LCHN=0 DO 6 I1=1,NCFG NCONOB(I1)=0 I2=2*NOCCSH(I1)-1 IF(ABS(J1QNRD(I2,3,I1)-NSPN).NE.1) GO TO 6 L1=(J1QNRD(I2,2,I1)-1)/2 C C DETERMINE THE PARITY OF THE ATOMIC CONFIGURATION C NPTAT=0 DO 2 J=1,NOCCSH(I1) I2=NOCORB(J,I1) 2 NPTAT=NELCSH(J,I1)*LJCOMP(I2)+NPTAT C C DETERMINE THE ANGULAR MOMENTA OF INCIDENT ELECTRON COUPLED TO C THE ATOMIC CONFIGURATIONS C L = ABS(LRGL-L1) + MOD(LRGL+L1+NPTAT+NPTY,2) L1MAX = LRGL+L1 3 IF(L.GT.L1MAX) GO TO 6 IF(L.LT.LRANG2) GO TO 4 LMAX=MAX(L,LMAX) LCHN=LCHN+1 GO TO 5 4 I2=NCONOB(I1)+1 NCONOB(I1)=I2 LCONOB(I2,I1)=L 5 L=L+2 GO TO 3 6 CONTINUE C C DETERMINE THE NUMBER OF COUPLED CHANNELS FOR EACH ATOMIC STATE C NCONAT(I) AND ALSO THE TOTAL NUMBER OF COUPLED CHANNELS NCHAN C I1=0 NCHAN=0 NSYMAX=1 DO 8 I=1,NAST I0=I1 I1=NTYP(I,1) ! I2=2*NOCCSH(I1)-1 WAS A RECODING RELIC WE'94MAR02 NCONAT(I)=NCONOB(I1) C ?XX IF(JRELOP(3).NE.0) NCONAT(I)=NCONOB(I) <=== CONFLICTING DO 6 " I2=NCONAT(I) IF (I2 .LE. 0) GO TO 8 DO 7 J=1,I2 LCONAT(J,I)=LCONOB(J,I1) C XX? IF(JRELOP(3).NE.0) LCONAT(J,I)=LCONOB(J,I) <=== '' 7 L2P(J+NCHAN)=LCONAT(J,I) NCHAN=NCHAN+I2 IF(I1.EQ.I0) THEN M=M+1 NSYMAX=MAX(M,NSYMAX) ELSE M=1 ENDIF 8 CONTINUE C C WRITE OUT CHANNEL LISTS C IF(IBUG6.EQ.0) THEN WRITE(IWRITE,'(/9H NCONAT =,(T10,20I3))') (NCONAT(I),I=1,NAST) WRITE(IWRITE,'(/6H L2P =,(T7,20I3))') (L2P(I),I=1,NCHAN) ELSE WRITE(IWRITE,'(/9H NCONOB =,(T10,20I3))') (NCONOB(I),I=1,NCFG) WRITE(IWRITE,'(/14H TERM LCONAT)') DO 9 I=1,NAST I1=NCONAT(I) IF (I1 .LE. 0) GO TO 9 WRITE(IWRITE,'(I5,(T10,20I3))') I,(LCONAT(I2,I),I2=1,I1) 9 CONTINUE WRITE(IWRITE,'(/29H NUMBER OF COUPLED CHANNELS =,I3)') NCHAN ENDIF IF(LCHN.GT.0) WRITE(IWRITE,1001) LCHN,LMAX,LRANG2 IF(NCHAN.NE.0) GO TO 10 WRITE(IWRITE,1010) RETURN 10 IF(NCHAN.GT.IDMTST(5)) CALL RECOV1(5,NCHAN) RETURN END C*********************************************************************** SUBROUTINE SETDIM C C SETS THE IDMTST ARRAY. THE ELEMENTS OF THIS ARRAY C CONTAINS THE DIMENSIONS OF THE ARRAYS IN THE PROGRAM AND ARE C USED TO TEST ARRAY OVERFLOW. C C ONLY THOSE ARRAYS WHICH APPEAR IN STG2 ARE SPECIFIED HERE C TOGETHER WITH THE ARRAYS APPEARING IN THE NJSYM PACKAGE, C WHOSE DIMENSIONS ARE SPECIFIED BY THE PARAMETERS IN /DIMEN/. C COMMON/RECOV/ IPLACE,IDMTST(50) C+ COMMON/DIMEN/ KFL1,KFL2,KFL3,KFL4,KFL5,KFL6,KFL7 C IDMTST(1)=5767 C =5767 IS THE LENGTH OF THE ARRAY RKSTO1 IN /INSTO2/ C IDMTST(2)=1180800 C =746496 IS THE LENGTH OF THE ARRAY RKSTO2 IN /BIG1/ C IDMTST(3)= 580 C =588 SPECIFIES THE LENGTH OF ISTBC1 AND ISTBC2 IN /INSTO3/ C IDMTST(4)= 112 C =112 SPECIFIES THE LENGTH OF ISTBB1 AND ISTBB2 IN /INSTO3/ C IDMTST(5)= 520 C =75 SPECIFIES THE ARRAYS CONTAINING THE NUMBER OF C CHANNELS IN /CROSEC/; ALSO RANGE OF ARRAYS AC, BLC AND BVC C IN SUBROUTINE DMEL, AND KPOS IN SUBROUTINE SETMX1. C C IDMTST(7) CONTAINS THE DIMENSIONS OF THE ARRAYS C CONTAINING THE NUMBER OF CONTINUUM ORBITALS FOR EACH ANGULAR C MOMENTUM IN /BASIN/, /CONMX/, /ELEMS/, /RKMATX/ C NOTE THAT THE size parameters in THE ARRAYS IN /DIPMEL/ are C DEFINED BY THE LARGEST OF IDMTST(7) AND IDMTST(13). C ALSO CHANGE DIMENSION OF AXL & AXV IN THE DMEL ROUTINES. C C N. B. C ______ C C SECOND DIMENSION OF ENDS IN /BASIN/ IS SET = IDMTST(7)+1 IDMTST(7)= 60 C =48 C C IDMTST(8) SPECIFIES THE LENGTH OF THE ARRAY GAMMA IN /FACT/ C 99 ALLOWED BY DIM - BUT PERHAPS NOT BY MACHINE: '90MAR: IDMTST(8)=MIN( 250,500) C IDMTST(9)=1280 C =1000 IS RESIDUALLY USED AS 2*IDMTST(9) = SIZE OF PV IN /POTORB/ C IDMTST(10) = 6 C =6 SPECIFIED THE SIZE OF IPOT, CPOT, AND XPOT IN /POTEN/ C XPOT IN /POTEN/ C IDMTST(11)= 15 C =15 SPECIFIES THE ARRAYS CONTAINING THE C NUMBER OF OCCUPIED SHELLS IN A GIVEN CONFIGURATION IN /BNDCON/, C /STATES/ (EXCEPT THE NJCOMP AND LJCOMP ARRAYS, SEE IDMTST(24)) C AND IN DIMENSIONS IN SUBROUTINES NJLJOD AND SETMX1. DIMENSIONS IN C /MSTATE/ ARE DEFINED BY IDMTST(11)+1 TO ALLOW FOR A CONTINUUM C ELECTRON IN SUBROUTINES SETFIN AND SETINI. NOTE THAT THE NUMBER C OF OCCUPIED SHELLS (IDMTST(11)) MUST BE LESS THAN OR EQUAL TO C THE TOTAL NUMBER OF SHELLS AVAILABLE (IDMTST(24)). C IDMTST(12)= 579 C =200 SPECIFIES THE ARRAYS NOCCSH, NOCORB, NELCSH, J1QNRD C IN /STATES/ AND ALSO ARRAYS IN /CUPMAT/. NOTE THAT THE CONFIG C PACKAGE REQUIRES THAT IDMTST(12) MUST NOT EXCEED IDMTST(13). C IDMTST(13)=2500 C =600 GIVES THE SIZE OF THE ARRAYS CONTAINING THE C NUMBER OF (N+1)-ELECTRON CONFIGURATIONS IN /BNDCON/, /BNDINI/, C /MSTATE/. ALSO SEE COMMENTS FOR IDMTST(7) & IDMTST(12). C IDMTST(14)= 70 C =63 SPECIFIES THE ARRAYS CONTAINING THE C NUMBER OF ATOMIC STATES IN /CROSEC/, /CUPMAT/,/STATED/, /INITI/ C C IDMTST(15) SPECIFIES THE ARRAYS CONTAINING THE NUMBER OF CONTI- C NUUM ANGULAR MOMENTA IN /BASIN/, INSTO3/, /INSTO4/ AND /RADIAL/; C ALSO THE SECOND DIMENSION OF THE ARRAY ONEST3 IN /INSTO2/, C AND COEFF IN SUBROUTINE READTP. IDMTST(15)= 49 C =20 ??????? '93MAR24 C IDMTST(16)= 5 C =5 SPECIFIES THE ARRAYS CONTAINING THE C NUMBER OF BOUND ANGULAR MOMENTA IN /INSTO3/ AND /INSTO4/. C IDMTST(17) = 9 C = 8 IS THE LENGTH OF THE ARRAYS IHX,IRX WHICH C DEFINE THE INTEGRATION MESH IN /INIT/. C IDMTST(18) = 8 C =8 DECLARES ARRAYS WHICH DEFINE C THE NUMBER OF MULTIPOLES IN THE POTENTIAL IN /CROSEC/. C NOTE THAT THE THIRD DIMENSION OF THE ARRAYS IN /INSTO4/ ARE C DEFINED BY IDMTST(18)/2 C IDMTST(19)= 56 C =56 SPECIFIES THE ARRAY ONEST1 IN /INSTO2/ AND RMASS1 C IDMTST(20)= 820 C =820 SPECIFIES THE ARRAY ONEST2 IN /INSTO2/ AND RMASS2 C IDMTST(21)=1830 C =1275 SPECIFIES THE ARRAY ONEST3 IN /INSTO2/ C AND RMASS3 AND RDAR3. C IDMTST(22)=100*1400 C =60000 IS THE LENGTH OF THE LINEAR ARRAY ICT IN C /RKSAVE/ WHICH HOLDS THE ICTCCD AND ICTCCE POINTER MATRICES. C IDMTST(23)= 6 C = 5 IS THE MAXIMUM NUMBER OF STATES WHICH CAN BE PUT INTO C EACH SYMMETRY GROUP. NOTE THE THIRD DIMENSION OF THE ARRAY C HNPS IN /BIG1/ IN SETMX1 IS DEFINED BY IDMTST(23)**2 C C IDMTST(24) GIVES THE SIZE OF THE ARRAYS CONTAINING THE C TOTAL NUMBER OF BOUND SHELLS AVAILABLE IN DIMENSIONS IN THE C CONFIG PACKAGE AND INCLUDING /CONACT/, /CUPPLE/ AND /DISTIB/. C C IDMTST(24)+2 THUS CONTAINS THE DIMENSION OF THE ARRAYS CONTAINING C THE TOTAL NUMBER OF SHELLS ARISING IN A MATRIX ELEMENT, INCLUDING C TWO CONTINUUM ELECTRONS, REQUIRED IN THE RKWTS PACKAGE, IE... C /INTERM/, /KRON/, /MEDEFN/, /REMOVE/ AND DIMENSIONS IN SUBROUTINE C FANO AND SETUPE. ALSO THE NJCOMP AND LJCOMP ARRAYS IN /STATES/. C IDMTST(24)= 21 C = 21; NOTE THAT KFL2 IN THE NJSYM PACKAGE IS DEFINED BELOW AS C IDMTST(24)+4, AND AFFECTS /COUPLE/ AND DIMENSIONS IN GENSUM. C IDMTST(25)= 300 C =50 DECLARES THE ARRAYS CONTAINING THE C MAXIMUM NUMBER OF CONFIGURATIONS IN ANY ATOMIC STATE IN /STATED/ C IDMTST(26)= 30 C = 30 DECLARES THE LENGTH OF NCO IN /RADIAL/ C IDMTST(27)= 300 C =300 IS THE LENGTH OF C, ZE AND IRAD IN /RADIAL/ C IDMTST(28)=9000 C =600 SPECIFIES THE SIZE OF THE ARRAYS CONTAINING THE C TOTAL NUMBER OF CONFIGURATIONS IN /CUT/, AND MAY EXCEED THE C NUMBER OF CONFIGURATIONS FINALLY STORED IN /BNDCON/. C IDMTST(29)= 148 C = 2 SPECIFIES ARRAYS CONTAINING THE C NUMBER OF BASIC CONFIGURATIONS IN /CUPPLE/. C IDMTST(30)=1000 C =1000 SPECIFIES THE ARRAY CONTAINING THE C NUMBER OF BOUND-BOUND MULTIPOLE INTEGRALS IN /INSTO5/. C IDMTST(31)= 35 C =15 GIVES THE SIZE OF RDAR1 IN /INSTO2/ C IDMTST(32)= 210 C =210 SPECIFIES THE SIZE OF RDAR2 IN /INSTO2/ C IDMTST(37)=2400 C =2400 IS USED FOR SKSTO2 IN /JNSTO/ C C KFL1,KFL2,KFL3,KFL4,KFL5,KFL6,KFL7 IN /DIMEN/ CONTAIN C THE DIMENSIONS OF THE ARRAYS APPEARING IN THE NJSYM PACKAGE. C C+ KFL1=5 = ? C PARAMETER (LL74= 21+4) C+ KFL2=25 =&L74 ONCE STGLIB BECOMES PREPRPCESSABLE C+ KFL3=20 = 35 IN OP CODE! C+ KFL4=100= 210 C+ KFL5=200=&L33 C+ KFL6=12 =&L34 C+ KFL7=100=&L35 RETURN END C*********************************************************************** SUBROUTINE SETFIN(IA,I3,IAA,L3) C C SETS UP THE COUPLING ARRAYS TO INCLUDE A C CONTINUUM ELECTRON, LEADING TO A FINAL STATE CONFIGURATION. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL61= 15+1, LL75= 21+2) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C IE=NOCCSH(I3) IE1=2*IE-1 C C THE NUMBER OF OCCUPIED SHELLS IS INCREASED BY ONE TO ACCOMMODATE C THE CONTINUUM STATE C IOC=IE+1 IOC1=2*IOC-1 KOCCSH(I3)=IOC DO 1 K=1,3 DO 1 J=1,IE 1 K1QNRD(J,K,I3)=J1QNRD(J,K,I3) C C IF IE1 EQUALS ONE THERE ARE NO COUPLED ANGULAR MOMENTA TO BE C SHIFTED C IF(IE1.EQ.1) GOTO 5 C C SHIFT THE POSITIONS OF THE COUPLED ANGULAR MOMENTA TO THE C PROPER PLACES C DO 3 K=1,3 DO 3 J=IOC,IE1 3 K1QNRD(J+1,K,I3)=J1QNRD(J,K,I3) C C PUT THE TOTAL (N+1)-ELECTRON ORBITAL AND SPIN ANGULAR MOMENTA C INTO THE PROPER PLACES C 5 K1QNRD(IOC1,1,I3)=0 K1QNRD(IOC1,2,I3)=2*LRGL+1 K1QNRD(IOC1,3,I3)=NSPN DO 6 K=1,IE KOCORB(K,I3)=NOCORB(K,I3) 6 KELCSH(K,I3)=NELCSH(K,I3) C C THE LAST SHELL HAS ONE ELECTRON C KELCSH(IOC,I3)=1 MAXOR=MAXORB+1 KOCORB(IOC,I3)=MAXOR NJCOMP(MAXOR)=999 C C THE CORRECT CHANNEL ANGULAR MOMENTUM IS FOUND. C L3=LCONAT(IAA,IA) LJCOMP(MAXOR)=L3 C C THE ORBITAL AND SPIN ANGULAR MOMENTA OF THE LAST CONTINUUM C OCCUPIED SHELL ARE PUT IN APPROPRIATE PLACES C K1QNRD(IOC,1,I3)=1 K1QNRD(IOC,2,I3)=2*L3+1 K1QNRD(IOC,3,I3)=2 RETURN END C*********************************************************************** SUBROUTINE SETINI(IB,I4,IBB,L4) C C PERFORMS ANALOGOUS OPERATIONS TO THOSE IN SUBROUTINE SETFIN C BUT LEADING TO AN INITIAL STATE CONFIGURATION. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL61= 15+1, LL75= 21+2) COMMON/INITI/ BIJ( 70, 300),MTCON( 70),MTYP( 70, 300),MAST, * MCONAT( 70),KCONAT( 6, 70),LLRGL,NNSPN,MPTY COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C IG=NOCCSH(I4) IG1=2*IG-1 C C THE NUMBER OF OCCUPIED SHELLS IS INCREASED BY ONE TO ACCOMMODATE C THE CONTINUUM STATE C IOD=IG+1 IOD1=2*IOD-1 MOCCSH(I4)=IOD DO 1 K=1,3 DO 1 J=1,IG 1 M1QNRD(J,K,I4)=J1QNRD(J,K,I4) C C IF IE1 EQUALS ONE THERE ARE NO COUPLED ANGULAR MOMENTA TO BE C SHIFTED C IF(IG1.EQ.1) GOTO 5 C C SHIFT THE POSITIONS OF THE COUPLED ANGULAR MOMENTA TO THE C PROPER PLACES C DO 3 K=1,3 DO 3 J=IOD,IG1 3 M1QNRD(J+1,K,I4)=J1QNRD(J,K,I4) C C PUT THE TOTAL (N+1)-ELECTRON ORBITAL AND SPIN ANGULAR MOMENTA C INTO THE PROPER PLACES C 5 M1QNRD(IOD1,1,I4)=0 M1QNRD(IOD1,2,I4)=2*LLRGL+1 M1QNRD(IOD1,3,I4)=NNSPN DO 6 K=1,IG MOCORB(K,I4)=NOCORB(K,I4) 6 MELCSH(K,I4)=NELCSH(K,I4) C C THE LAST SHELL HAS ONE ELECTRON C MELCSH(IOD,I4)=1 MAXOR=MAXORB+2 MOCORB(IOD,I4)=MAXOR NJCOMP(MAXOR)=999 C C THE CORRECT CHANNEL ANGULAR MOMENTUM IS FOUND. C L4=KCONAT(IBB,IB) LJCOMP(MAXOR)=L4 C C THE ORBITAL AND SPIN ANGULAR MOMENTA OF THE LAST CONTINUUM C OCCUPIED SHELL ARE PUT IN APPROPRIATE PLACES. C M1QNRD(IOD,1,I4)=1 M1QNRD(IOD,2,I4)=2*L4+1 M1QNRD(IOD,3,I4)=2 RETURN END C*********************************************************************** C*********************************************************************** C REPLACEMENT STG2 ROUTINE SETMX1. MAY 1982. C TO ALLOW FOR ORDERING STATES ACCORDING TO SYMMETRY FOR EFFICIENCY C*********************************************************************** SUBROUTINE SETMX1 C C EVALUATES THE (N+1)-ELECTRON HAMILTONIAN MATRIX HNP1 C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL TRANS PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) PARAMETER (LL61= 15+1, LL73= 6* 6, LL75= 21+2) PARAMETER (LL83=( 520*( 520+1)/2)* 6) C DIMENSION IA1( 15),IA2( 15),IB1( 15),IB2( 15) DIMENSION KPOS( 520, 520),IPOS(LL83), ! (&L83L84) * ISYM( 70) ! IS LOCAL, (63) MACROED ONLY RUB'94APR1. DIMENSION MPOS( 520,(2500-1)/NRANG2+1) ! '05Aug04: KPOS for CB! COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BIG1/ RKSTO2(1180800),HNPS( 60, 60,LL73) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 C COMMON/DIPMEL/HNP1( 60,&L53),DUMMY( 60,&L53) -- '03Mar31: COMMON/DIPMEL/HNP1(LL53,LL53),DUMMY(LL53,LL53) COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3),JRELOP(3) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) 1001 FORMAT(// 69H CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN MAT *RIX FROM CHANNELS,I3,4H AND,I3/) 1002 FORMAT((1X,6F13.7)) 1003 FORMAT(//) 1004 FORMAT(/37H ENTER CONTINUUM BOUND LOOP OF SETMX1) 1005 FORMAT(// 6X,63HBOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN MATRIX 1 FROM CHANNEL,I4/) 1006 FORMAT(/33H ENTER BOUND BOUND LOOP OF SETMX1) 1007 FORMAT(/ 6X,65HBOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM * CONFIGURATION,I4/(1X,6F13.7)) 1008 FORMAT(/62H CALCULATE AND STORE ON THE OUTPUT TAPE THE HAMILTONIAN * MATRIX) 1009 FORMAT(/41H ENTER CONTINUUM-CONTINUUM LOOP OF SETMX1) 1010 FORMAT(14H TAPE POSITION,I5,17H HAS BEEN REACHED) 1011 FORMAT(//26H WRITE TO ITAPE3 COMPLETED) 1022 FORMAT(/11H CHOSEN ARE,I4,' TARGET SYMMETRY GROUPS; NUMBER OF STAT *ES IN EACH GROUP ='/(38X,10I4)) 1023 FORMAT(/' IDMTST(23) WILL ALLOW ONLY UP TO',I3,' STATES IN EACH SY *MMETRY GROUP'/36X,'A VALUE .LT. 4 CAN SLOW DOWN COMPUTATION!') 1024 FORMAT(/' POINTER ARRAY IPOS IN SETMX1 TOO SMALL: L83 LT',I9) c1025 FORMAT(/' WARNING: SETMX1 SWITCHES TO SLOW SETMXR FOR CB AND BB SI c *NCE'/' NTIMES =',I5,'/(NRANG2+1) >',I5': RUN WITH LARGER NRANG2?') C DATA LPOS,NDIM2,NDIM1/LL83,LL73, 60/ C IDMTST(23) IS THE MAXIMUM NUMBER OF STATES WHICH CAN BE PUT INTO C EACH SYMMETRY GROUP; NOTE THE THIRD DIMENSION OF THE ARRAY C HNPS IN /BIG1/ IS DEFINED BY (AMP)L73=IDMTST(23)**2 C WRITE(IWRITE,'(//52X,17HSUBROUTINE SETMX1/52X,17(1H-))') C C DETERMINE HOW MANY TARGET STATES OF EACH SYMMETRY: C CURRENT CODE WILL GROUP SUITABLE CHANNELS ONLY IF THEY ARE C ADJACENT - THIS CAN BE IMPROVED BY TARGET INPUT ORDERING! C ITSYM=0 K=0 L=0 DO 3 I=1,NAST J=K K=NTYP(I,1) IF(K.NE.J) GO TO 2 IF(ISYM(ITSYM).LT. 6) GO TO 3 IF(L.NE.0) GO TO 2 L=1 WRITE(IWRITE,1023) IDMTST(23) 2 ITSYM=ITSYM+1 ISYM(ITSYM)=0 3 ISYM(ITSYM)=ISYM(ITSYM)+1 WRITE(IWRITE,1022) ITSYM,(ISYM(J),J=1,ITSYM) C C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF READTP. C POSITION THE SCRATCH DISCS CONTAINING THE RADIAL INTEGRALS. C IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2-2) GO TO 6 WRITE(IWRITE,1008) LTT1=0 LTT2=0 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EVALUATE THE CONTINUUM-CONTINUUM CONTRIBUTIONS TO HNP1 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 6 WRITE(IWRITE,1009) NTIMES=(NCFGP-1)/NRANG2+1 C MOVED UP '05Mar11; MISSING 'BOUND' TEST INSERTED '95JUN/'96FEB06: c out IF(NTIMES.GT. 520) WRITE(IWRITE,1025) NCFGP-1, 520 *!! if(LTT1.eq.0) print "(' >>> SETMX1-test: CC and BC skipped <<<')" *!! go to 61 !! NDCT(1) = NRANG2 NDCT(2) = NRANG2 NROW=0 NCF=0 IF=0 C C ---- OUTER LOOP OVER TARGET SYMMETRIES ON LHS OF MATRIX ELEMENT ---- C DO 36 IS=1,ITSYM C C INITIALIZE NBLOCK, THE DIRECT ACCESS FILE POINTER C KOUNT=0 CALL DA1(0,NBLOCK,NRANG2) IE=IF+1 IF=IF+ISYM(IS) IF(NCONAT(IE).LE.0) GO TO 36 NCS=NCF+1+(ISYM(IS)-1)*NCONAT(IE) NCF=NCS+NCONAT(IE)-1 NTC=NTCON(IE) IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 20 C C ---- LOOP OVER CHANNELS COUPLED TO CURRENT SYMMETRY ON LHS. C DO 19 NCH1=NCS,NCF I1 = L2P(NCH1)+1 MCF=0 IH=0 NCOL=0 C C ---- LOOP OVER TARGET SYMMETRIES ON RHS (K-RANGE SET IN DO 3) C DO 18 IT=1,IS IG=IH+1 IH=IH+ISYM(IT) IF(NCONAT(IG).LE.0) GO TO 18 KMAX=ISYM(IS)*ISYM(IT) MCS=(ISYM(IT)-1)*NCONAT(IG)+MCF+1 MCF=MCS+NCONAT(IG)-1 MTC=NTCON(IG) IF(IS.EQ.IT) MCF=NCH1 C C ---- LOOP OVER CHANNELS COUPLED TO CURRENT SYMMETRY ON RHS. C DO 17 NCH2=MCS,MCF DO 9 K=1,KMAX DO 9 J=1,NDIM1 DO 9 I=1,NDIM1 9 HNPS(I,J,K)=0. I2 = L2P(NCH2)+1 IF (I1.EQ.LTT1 .AND. I2.EQ.LTT2) GO TO 8 C C READ THE RK INTEGRALS FROM JDISC1. C LTT1 = I1 LTT2 = I2 CALL RDINT(2,I1,I2) DO 7 K=1,NRANG2 ND(1,K) = MAXNHF(I1)+K 7 ND(2,K) = MAXNHF(I2)+K C C INITIALIZE THE HNPS MATRIX. KMAX=LARGEST VALUE OF THIRD DIMENSION C C C ---- LOOP OVER CONFIGURATIONS WITH SAME SYMMETRY ON LHS, THEN RHS C 8 DO 15 IC1=1,NTC I=NTYP(IE,IC1) I4 = NOCCSH(I) DO 11 K=1,I4 IA1(K) = NOCORB(K,I) 11 IB1(K) = NELCSH(K,I) DO 14 IC2=1,MTC J=NTYP(IG,IC2) C C CALCULATE RAW MATRIX ELEMENT AME C C FIRST SET UP THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ C I5 = NOCCSH(J) DO 12 K=1,I5 IA2(K) = NOCORB(K,J) 12 IB2(K) = NELCSH(K,J) C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C NOW SET J1QN C IB=NOCCSH(I)+1 CALL SJ1QNT(I,IB,I3,3,1) IB=NOCCSH(J)+1 CALL SJ1QNT(J,IB,I3,3,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITALS C IHSH = I3+2 I31=I3+1 I32=I31+1 I2M=2*I3+2 I3M=I2M+1 LJ(I31) = LTT1-1 LJ(I32) = LTT2-1 NOSH(I31,1)=1 NOSH(I32,1)=0 NOSH(I31,2)=0 NOSH(I32,2)=1 J1QN(I31,1,1)=1 J1QN(I31,2,1)=2*LTT1-1 J1QN(I31,3,1)=2 J1QN(I32,1,1)=0 J1QN(I32,2,1)=1 J1QN(I32,3,1)=1 J1QN(I2M,1,1)=0 J1QN(I2M,2,1)=2*LRGL+1 J1QN(I2M,3,1)=NSPN J1QN(I3M,1,1)=0 J1QN(I3M,2,1)=2*LRGL+1 J1QN(I3M,3,1)=NSPN J1QN(I31,1,2)=0 J1QN(I31,2,2)=1 J1QN(I31,3,2)=1 J1QN(I32,1,2)=1 J1QN(I32,2,2)=2*LTT2-1 J1QN(I32,3,2)=2 K=1 IF(I3.GT.1) K=I2M-1 J1QN(I2M,1,2)=0 J1QN(I2M,2,2)=J1QN(K,2,2) J1QN(I2M,3,2)=J1QN(K,3,2) J1QN(I3M,1,2)=0 J1QN(I3M,2,2)=2*LRGL+1 J1QN(I3M,3,2)=NSPN NJ(I31) = 999 NJ(I32) = 999 IF(IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(3) C C RESULT IN AME (BY MATRX VIA MATANS) IS USED FOR HNPS MATRICES: C C ---- LOOP OVER TARGET STATES WITH SAME SYMMETRY ON LHS, THEN RHS C C STORE MATRIX ELEMENTS IN HNPS C DO 13 NS1=IE,IF DO 13 NS2=IG,IH A = AIJ(NS1,IC1)*AIJ(NS2,IC2) K = (NS2-IG)*ISYM(IS) + NS1-IE+1 DO 13 J=1,NRANG2 DO 13 II=1,NRANG2 13 HNPS(II,J,K)=HNPS(II,J,K)+AME(II,J)*A 14 CONTINUE 15 CONTINUE C C WRITE THE HAMILTONIAN BLOCKS IN HNPS TO A DIRECT ACCESS FILE C*170 KPOS(NCH1,NCH2)=KOUNT CX IF((KOUNT+KMAX).GT.LPOS) CALL RECOV1(23,LPOS) -- CORR'94MAR31WE: IF(KOUNT+KMAX.GT.LPOS) GO TO 69 DO 16 K=1,KMAX CALL DA1(1,NBLOCK,K) KOUNT=KOUNT+1 16 IPOS(KOUNT)=NBLOCK 17 CONTINUE 18 CONTINUE 19 CONTINUE C print *,' CC test: IS,KOUNT,LPOS = ', is,kount,lpos C C ---- END OF LOOPS FOR WRITING TO DIRECT ACCESS FILE. C C READ THE HAMILTONIAN BLOCKS FROM DIRECT ACCESS FILE AND ORDER C ON SEQUENTIAL OUTPUT TAPE C C ---- LOOP OVER STATES, THEN CHANNELS, WITH SAME TARGET SYMMETRY ON LHS C 20 DO 35 NS1=IE,IF DO 35 NCH1=NCS,NCF NROW=NROW+1 NCOL=0 MCF=0 IH=0 C C ---- LOOP OVER TARGET SYMMETRIES ON RHS. C DO 35 IT=1,IS IG=IH+1 IH=IH+ISYM(IT) IF(NCONAT(IG).LE.0) GO TO 35 MCS=MCF+1+(ISYM(IT)-1)*NCONAT(IG) MCF=MCS+NCONAT(IG)-1 IF(IS.EQ.IT) IH=NS1 C C ---- LOOP OVER STATES, THEN CHANNELS, WITH SAME TARGET SYMMETRY ON RHS C DO 34 NS2=IG,IH IF(NS1.EQ.NS2) MCF=NCH1 DO 33 NCH2=MCS,MCF NCOL=NCOL+1 TRANS=NCH1.LT.NCH2 IF(TRANS) GO TO 21 K = NS1-IE+1 + ISYM(IS)*(NS2-IG) KOUNT=KPOS(NCH1,NCH2) GO TO 22 C WHEN BOTH SIDES OF THE MATRIX ELEMENT HAVE STATES OF SAME SYMMETRY C BUT DIFFERENT CHANNEL ANGULAR MOMENTA, THE MATRIX ELEMENTS ARE C CALCULATED ABOVE WITH LHS CHANNEL-L .GE. RHS CHANNEL-L. C BUT THE ORDERING BELOW ON THE OUTPUT TAPE ASSUMES THAT THE LHS C STATE .GE. RHS STATE. C SO CASES WILL OCCUR WHEN THE CHANNEL COUPLED TO THE LHS STATE C HAS A LOWER L THAN THE CHANNEL COUPLED TO THE RHS STATE C (I.E. NCH1.LT.NCH2). C IN THIS CASE JUST RETRIEVE THE REVERSE OF THE MATRIX ELEMENT, C I.E. SWAP NS1/NS2 AND NCH1/NCH2 AND TRANSPOSE THE H-MATRIX BLOCK. 21 K = NS2-IE+1 + ISYM(IS)*(NS1-IG) KOUNT=KPOS(NCH2,NCH1) 22 NBLOCK=IPOS(KOUNT+K) IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 29 C C READ APPROPRIATE BLOCK FROM DA FILE INTO HNPS, COPY INTO HNP1 C CALL DA1(-1,NBLOCK,K) C MAKE SETMX1 ALSO USABLE IN INTERMEDIATE COUPLING - RUB'94MAY25: IF(JRELOP(3).EQ.0) GO TO 23 C RETAINING MIS-TRANSPOSITION IN THE LS-COUPLED CASE ICODE=21; C BUT USE PROPER H-MATRICES (ICODE=23 SET IN RECUPD) IN BP CASE: IF(L2P(NCH1).NE.L2P(NCH2).AND.TRANS) GO TO 25 IF(L2P(NCH1).NE.L2P(NCH2)) GO TO 27 GO TO 24 C 23 IF(L2P(NCH1).EQ.L2P(NCH2).AND.NROW.NE.NCOL) GO TO 25 24 IF(TRANS) GO TO 27 25 DO 26 I=1,NRANG2 DO 26 J=1,NRANG2 26 HNP1(J,I)=HNPS(J,I,K) C WHEN CALLED FROM IF(...)GO TO 25 THEN... C **** HNP1(J,I) CORRESPONDS TO THE 1974 AND 1978 CPC VERSIONS. C BUT THESE CPC VERSIONS CONTAIN A 'TRANSPOSING' ERROR IN STG2 C WHICH WAS CORRECTED BY A FIX IN SUBROUTINE TAPERD IN THE CORRE- C SPONDING CPC VERSIONS OF STG3. SINCE THE ERROR IS ACTUALLY IN C STG2, IT WOULD BE MORE CONSISTENT TO GO TO 27 C AND TO REMOVE THE FIX IN STG3 (WHICH CHECKS THE VALUE OF ICODE). GO TO 30 27 DO 28 I=1,NRANG2 DO 28 J=1,NRANG2 28 HNP1(I,J)=HNPS(J,I,K) GO TO 30 29 READ(ITAPE2) ((HNP1(I,J),J=1,NRANG2),I=1,NRANG2) 30 WRITE(ITAPE3) ((HNP1(I,J),J=1,NRANG2),I=1,NRANG2) IF(IBUG9.LT.3) GO TO 33 WRITE(IWRITE,1001) NROW,NCOL JUP=0 31 JLO=JUP+1 JUP=MIN(JUP+6,NRANG2) DO 32 I=1,NRANG2 32 WRITE(IWRITE,1002)(HNP1(I,J),J=JLO,JUP) WRITE(IWRITE,1003) IF(JUP.LT.NRANG2) GO TO 31 33 CONTINUE 34 CONTINUE 35 CONTINUE 36 CONTINUE C C ---- END OF OUTER LOOP OVER TARGET SYMMETRIES ON LHS ---- C WRITE(IWRITE,1010) ICOUNT c out IF(NTIMES.LE. 520) GO TO 37 C TST IF(NCFGP.EQ.0) GO TO 37 c out NCFGP=-NCFGP C SO THAT MAIN CALLS SETMXR FOR THE REST OF THE TASK c out GO TO 71 C 37 IF(ICOUNT.GE.ITOTAL) GO TO 70 ICOUNT=ICOUNT+1 C CBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCB C C NOW EVALUATE THE CONTINUUM-BOUND CONTRIBUTION TO HNP1 C CBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCB C NDCT(1) = 0 C NDCT(2) = NRANG2 IF(NCFGP.LE.0.OR.NCHAN.LE.0) GO TO 61 WRITE(IWRITE,1004) C C READ IN THE BOUND-CONTINUUM INTEGRALS FROM FILE JDISC1 C CALL RDINT(1,0,0) NROW=0 NCF=0 IF=0 C C ---- OUTER LOOP OVER TARGET SYMMETRIES ON LHS OF MATRIX ELEMENT ---- C DO 60 IS=1,ITSYM C C INITIALIZE NBLOCK, THE DIRECT ACCESS FILE POINTER C KOUNT=0 CALL DA1(0,NBLOCK,NRANG2) IE=IF+1 IF=IF+ISYM(IS) IF(NCONAT(IE).LE.0) GO TO 60 NCS=NCF+1+(ISYM(IS)-1)*NCONAT(IE) NCF=NCS+NCONAT(IE)-1 NTC=NTCON(IE) IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 50 C C ---- LOOP OVER CHANNELS COUPLED TO CURRENT SYMMETRY ON LHS C DO 49 NCH1=NCS,NCF LTT1=L2P(NCH1)+1 DO 38 K =1,NRANG2 38 ND(2,K) = MAXNHF(LTT1)+K ND(1,1) = 0 I2=0 C C THE HNPS ARRAY CAN IN GENERAL ONLY CARRY PART OF THE B-C SECTION C OF THE MATRIX (SINCE THE NUMBER OF BOUND TERMS MAY EXCEED THE C NUMBER OF CONTINUUM TERMS). THE HNPS MATRIX IS THEN FILLED AND C EMPTIED INTO THE DA FILE SEVERAL TIMES. C ---- LOOP OVER NTIMES, THE NUMBER OF TIMES THIS HAS TO BE DONE C DO 48 II=1,NTIMES C C INITIALIZE THE HNPS MATRIX C KMAX=ISYM(IS) DO 39 K=1,KMAX DO 39 J=1,NDIM1 DO 39 I=1,NDIM1 39 HNPS(I,J,K)=0.0 I1=I2+1 I2=MIN(II*NRANG2,NCFGP) C C ---- LOOP OVER BOUND TERMS FOR THIS LOOP OF II. C DO 46 J=I1,I2 I4=IOCCSH(J) DO 40 K=1,I4 IA1(K) = IOCORB(K,J) 40 IB1(K) = IELCSH(K,J) C C ---- LOOP OVER CONFIGURATIONS WITH SAME SYMMETRY ON LHS C DO 45 IC1=1,NTC I=NTYP(IE,IC1) C C SET THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ C I5=NOCCSH(I) DO 41 K=1,I5 IA2(K) = NOCORB(K,I) 41 IB2(K) = NELCSH(K,I) C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C SET J1QN C IB=IOCCSH(J)+1 CALL SJ1QNT(J,IB,I3,2,1) IB=NOCCSH(I)+1 CALL SJ1QNT(I,IB,I3,2,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITAL C IHSH=I3+1 I31=I3+1 I1M=2*I3+1 LJ(I31)=LTT1-1 NOSH(I31,1)=0 NOSH(I31,2)=1 J1QN(I31,1,1)=0 J1QN(I31,2,1)=1 J1QN(I31,3,1)=1 J1QN(I1M,1,1)=0 J1QN(I1M,2,1)=2*LRGL+1 J1QN(I1M,3,1)=NSPN J1QN(I31,1,2)=1 J1QN(I31,2,2)=2*LTT1-1 J1QN(I31,3,2)=2 J1QN(I1M,1,2)=0 J1QN(I1M,2,2)=2*LRGL+1 J1QN(I1M,3,2)=NSPN NJ(I31) = 999 IF(IBUG9.GE.4) CALL PNTBG2(J,I) CALL MATANS (2) C C RESULT IN AME IS STORED IN HNPS MATRICES C C ---- LOOP OVER TARGET STATES WITH SAME SYMMETRY ON LHS. C C STORE MATRIX ELEMENT IN HNPS C DO 44 NS1=IE,IF A=AIJ(NS1,IC1) DO 43 K=1,NRANG2 43 HNPS(K,J-I1+1,NS1-IE+1) = HNPS(K,J-I1+1,NS1-IE+1)+AME(1,K)*A 44 CONTINUE 45 CONTINUE 46 CONTINUE C C WRITE OUT BLOCKS IN HNPS TO A DIRECT ACCESS FILE C MPOS(NCH1,II)=KOUNT CX IF((KOUNT+KMAX).GT.LPOS) CALL RECOV1(23,LPOS) -- CORR'94MAR31WE: IF(KOUNT+KMAX.GT.LPOS) GO TO 69 DO 47 K=1,KMAX CALL DA1(1,NBLOCK,K) KOUNT=KOUNT+1 47 IPOS(KOUNT)=NBLOCK 48 CONTINUE 49 CONTINUE C print *,' CB test: IS,KOUNT,LPOS = ', is,kount,lpos C C ---- END OF LOOPS FOR WRITING TO DIRECT ACCESS FILE. C C READ THE HAMILTONIAN BLOCKS FROM DIRECT ACCESS FILE AND ORDER C ON SEQUENTIAL OUTPUT TAPE C C ---- LOOP OVER STATES, THEN CHANNELS, FOR SAME TAGET SYMMETRY ON LHS C 50 DO 59 NS1=IE,IF K = NS1-IE+1 DO 58 NCH1=NCS,NCF NROW=NROW+1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 54 I2=0 C C ---- LOOP OVER NTIMES, AND THEN THE NUMBER OF BOUND TERMS C DO 53 II=1,NTIMES KOUNT=MPOS(NCH1,II) NBLOCK=IPOS(KOUNT+K) C C READ APPROPRIATE BLOCKS FROM DA FILE INTO HNPS, C COPY INTO APPROPRIATE PLACE IN HNP1 C CALL DA1(-1,NBLOCK,K) I1=I2+1 I2=MIN(II*NRANG2,NCFGP) DO 52 J=I1,I2 DO 51 I=1,NRANG2 51 HNP1(I,J)=HNPS(I,J-I1+1,K) 52 CONTINUE 53 CONTINUE GO TO 55 54 READ(ITAPE2) ((HNP1(I,J),J=1,NCFGP),I=1,NRANG2) 55 WRITE(ITAPE3) ((HNP1(I,J),J=1,NCFGP),I=1,NRANG2) C IF(IBUG9.LT.2.OR.(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2))GO TO 58 WRITE(IWRITE,1005) NROW JUP=0 56 JLO=JUP+1 JUP=MIN(JUP+6,NCFGP) DO 57 I=1,NRANG2 57 WRITE(IWRITE,1002)(HNP1(I,J),J=JLO,JUP) WRITE(IWRITE,1003) IF(JUP.LT.NCFGP) GO TO 56 58 CONTINUE 59 CONTINUE 60 CONTINUE C C ---- END OF OUTER LOOP OVER TARGET SYMMETRIES ON LHS ---- C 61 WRITE(IWRITE,1010) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 70 ICOUNT=ICOUNT+1 C CBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB C C NOW EVALUATE THE BOUND-BOUND CONTRIBUTION TO HNP1 C CBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB C IF(NCFGP.LE.0.OR.NCHAN.LE.0) GO TO 68 WRITE(IWRITE,1006) NDCT(1) = 0 NDCT(2) = 0 DO 67 I=1,NCFGP IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 65 I4 = IOCCSH(I) DO 62 K = 1,I4 IA1(K) = IOCORB(K,I) 62 IB1(K) = IELCSH(K,I) C DO 64 J= I,NCFGP C C SET NJ AND LJ C I5 = IOCCSH(J) DO 63 K = 1,I5 IA2(K) = IOCORB(K,J) 63 IB2(K) = IELCSH(K,J) C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C SET J1QN, PREPARE MATRIX CASE NDCT(1)=NDCT(2)=0 C IB=IOCCSH(I)+1 CALL SJ1QNT(I,IB,I3,1,1) IB=IOCCSH(J)+1 CALL SJ1QNT(J,IB,I3,1,2) IHSH = I3 IF(IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(1) C C MATRIX ELEMENT IN AME NOW STORED IN HNP1 MATRIX C 64 HNP1(1,J)=AME(1,1) C GO TO 66 65 READ(ITAPE2) (HNP1(1,J),J=I,NCFGP) 66 WRITE(ITAPE3)(HNP1(1,J),J=I,NCFGP) IF(IBUG9.LE.0.OR.(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2))GO TO 67 WRITE(IWRITE,1007) I, (HNP1(1,J),J=I,NCFGP) 67 CONTINUE C 68 WRITE(IWRITE,1010) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 70 ICOUNT=ICOUNT+1 GO TO 71 C C WRITE TO ITAPE3 COMPLETE C 69 WRITE(IWRITE,1024) KMAX+KOUNT STOP 70 IF(ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE(IWRITE,1011) *!!71 print "(/' end of SETMX1: stopping')"; stop !!!!! 71 RETURN END C*********************************************************************** SUBROUTINE SETMXR C C EVALUATES THE (N+1)-ELECTRON HAMILTONIAN MATRIX HNP1, FOR BP ONLY C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL43= 21*2+3) PARAMETER (MXD1= 60,MXD2=2500) ! LL53=max(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL53=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0) PARAMETER (LL61= 15+1, LL75= 21+2, LL83=( 520*( 520+1)/2)* 6) C DIMENSION IA1( 15),IA2( 15),IB1( 15),IB2( 15) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPMAT/NCONOB( 579),LCONOB( 6, 579),NCONAT( 70), * LCONAT( 6, 70) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIPMEL/HNP1(LL53,LL53),DUMMY(LL53,LL53) COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/ELEMS/ AME( 60, 60),ND(2, 60),NDCT(2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C 1001 FORMAT(// 69H CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN MAT *RIX FROM CHANNELS,I3,4H AND,I3/) 1002 FORMAT((1X,6F13.7)) 1003 FORMAT(//) 1004 FORMAT(/37H ENTER CONTINUUM BOUND LOOP OF SETMXR) 1005 FORMAT(// 6X,63HBOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN MATRIX 1 FROM CHANNEL,I4/) 1006 FORMAT(/33H ENTER BOUND BOUND LOOP OF SETMXR) 1007 FORMAT(/ 6X,65HBOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM * CONFIGURATION,I4/(1X,6F13.7)) 1008 FORMAT(/62H CALCULATE AND STORE ON THE OUTPUT TAPE THE HAMILTONIAN * MATRIX) 1009 FORMAT(/41H ENTER CONTINUUM-CONTINUUM LOOP OF SETMXR) 1010 FORMAT(14H TAPE POSITION,I5,17H HAS BEEN REACHED) 1011 FORMAT(//26H WRITE TO ITAPE3 COMPLETED) C IF (NCFGP.LT.0) GO TO 37 C SO AS TO COMPLETE SETMX1 JOB (RUB'96FEB07). WRITE(IWRITE,'(//52X,17HSUBROUTINE SETMXR/52X,17(1H-))') C C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF READTP. C POSITION THE SCRATCH DISCS CONTAINING THE RADIAL INTEGRALS. C IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2-2) GO TO 6 WRITE(IWRITE,1008) LTT1=0 LTT2=0 C C C EVALUATE THE CONTINUUM-CONTINUUM CONTRIBUTIONS TO HNP1 C 6 WRITE(IWRITE,1009) 7 NCF=0 NDCT(1) = NRANG2 NDCT(2) = NRANG2 DO 36 NS1=1,NAST IF (NCONAT(NS1) .LE. 0) GO TO 36 NTC=NTCON(NS1) NCS = NCF+1 NCF = NCF+NCONAT(NS1) DO 35 NCH1=NCS,NCF LOT1=L2P(NCH1)+1 MCF = 0 DO 34 NS2=1,NS1 IF (NCONAT(NS2) .LE. 0) GO TO 34 MCS = MCF+1 MCF = MCF+NCONAT(NS2) IF(NS1.EQ.NS2) MCF=NCH1 MTC = NTCON(NS2) DO 33 NCH2=MCS,MCF IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 27 LOT2=L2P(NCH2)+1 IF(LOT1.EQ.LTT1.AND.LOT2.EQ.LTT2) GO TO 8 C C READ THE RK INTEGRALS FROM FILE JDISC1. C LTT1=LOT1 LTT2=LOT2 CALL RDINT(2,LOT1,LOT2) 8 DO 10 J=1,NRANG2 DO 9 I=1,NRANG2 9 HNP1(I,J) = 0. ND(1,J) = MAXNHF(LTT1)+J 10 ND(2,J) = MAXNHF(LTT2)+J DO 26 IC1=1,NTC IF(AIJ(NS1,IC1).EQ.0.0) GO TO 26 I=NTYP(NS1,IC1) I4 = NOCCSH(I) DO 11 K=1,I4 IA1(K) = NOCORB(K,I) 11 IB1(K) = NELCSH(K,I) DO 25 IC2=1,MTC IF(AIJ(NS2,IC2).EQ.0.0) GO TO 25 J=NTYP(NS2,IC2) C C FIRST SET UP THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ. C I5 = NOCCSH(J) DO 12 K=1,I5 IA2(K) = NOCORB(K,J) 12 IB2(K) = NELCSH(K,J) C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C NOW SET J1QN C IB=NOCCSH(I)+1 CALL SJ1QNT(I,IB,I3,3,1) IB=NOCCSH(J)+1 CALL SJ1QNT(J,IB,I3,3,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITALS C IHSH = I3+2 I31=I3+1 I32=I3+2 LJ(I31) = LTT1-1 LJ(I32) = LTT2-1 I2M=2*I3+2 I3M=I2M+1 NOSH(I31,1)=1 NOSH(I32,1)=0 NOSH(I31,2)=0 NOSH(I32,2)=1 J1QN(I31,1,1)=1 J1QN(I31,2,1)=2*LTT1-1 J1QN(I31,3,1)=2 J1QN(I32,1,1)=0 J1QN(I32,2,1)=1 J1QN(I32,3,1)=1 J1QN(I2M,1,1)=0 J1QN(I2M,2,1)=2*LRGL+1 J1QN(I2M,3,1)=NSPN J1QN(I3M,1,1)=0 J1QN(I3M,2,1)=2*LRGL+1 J1QN(I3M,3,1)=NSPN J1QN(I31,1,2)=0 J1QN(I31,2,2)=1 J1QN(I31,3,2)=1 J1QN(I32,1,2)=1 J1QN(I32,2,2)=2*LTT2-1 J1QN(I32,3,2)=2 K=1 IF(I3.GT.1) K=I2M-1 J1QN(I2M,1,2)=0 J1QN(I2M,2,2)=J1QN(K,2,2) J1QN(I2M,3,2)=J1QN(K,3,2) J1QN(I3M,1,2)=0 J1QN(I3M,2,2)=2*LRGL+1 J1QN(I3M,3,2)=NSPN NJ(I31) = 999 NJ(I32) = 999 IF(IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(3) C C RESULT IN AME IS STORED IN HNP1 MATRIX C DO 23 J=1,NRANG2 DO 23 K=1,NRANG2 23 HNP1(K,J)=HNP1(K,J)+AIJ(NS1,IC1)*AIJ(NS2,IC2)*AME(K,J) C C RETURN TO SET UP THE NEXT MATRIX ELEMENT C 25 CONTINUE 26 CONTINUE C C DUE TO ERROR IN STG2R THIS LOWER HALF BLOCK HAS BEEN CALCULATED C AS ITS TRANSPOSE. TO BE CONSISTENT WITH THE OTHER BLOCKS C WE WRITE OUT ITS TRANSPOSE. C IF(L2P(NCH1).EQ.L2P(NCH2)) GO TO 28 WRITE(ITAPE3) ((HNP1(J,K),J=1,NRANG2),K=1,NRANG2) GO TO 72 C 27 READ(ITAPE2) ((HNP1(K,J),J=1,NRANG2),K=1,NRANG2) 28 WRITE(ITAPE3)((HNP1(K,J),J=1,NRANG2),K=1,NRANG2) 72 IF(IBUG9.LT.3.OR.(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2))GO TO 33 WRITE(IWRITE,1001) NCH1,NCH2 JUP=0 29 JLO=JUP+1 JUP=MIN(JUP+6,NRANG2) DO 31 I=1,NRANG2 IF(L2P(NCH1).EQ.L2P(NCH2)) THEN WRITE(IWRITE,1002)(HNP1(I,J),J=JLO,JUP) ELSE WRITE(IWRITE,1002)(HNP1(J,I),J=JLO,JUP) ENDIF 31 CONTINUE WRITE(IWRITE,1003) IF(JUP.LT.NRANG2) GO TO 29 33 CONTINUE 34 CONTINUE 35 CONTINUE 36 CONTINUE WRITE(IWRITE,1010) ICOUNT GO TO 38 C 37 NCFGP=-NCFGP 38 IF(ICOUNT.GE.ITOTAL) GO TO 70 ICOUNT=ICOUNT+1 C C NOW EVALUATE THE CONTINUUM-BOUND CONTRIBUTION TO HNP1 C NDCT(1) = 0 IF(NCFGP.LE.0.OR.NCHAN.LE.0) GO TO 57 WRITE(IWRITE,1004) C C READ IN THE BOUND-CONTINUUM INTEGRALS FROM FILE JDISC1 C CALL RDINT(1,0,0) NCF=0 DO 56 NS1=1,NAST IF(NCONAT(NS1).LE.0) GO TO 56 NTC = NTCON(NS1) NCS = NCF+1 NCF = NCF+NCONAT(NS1) DO 55 NCH1=NCS,NCF IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 50 LOT1=L2P(NCH1)+1 DO 41 I=1,NRANG2 DO 40 J=1,NCFGP 40 HNP1(I,J) = 0. 41 ND(2,I) = MAXNHF(LOT1)+I ND(1,1) = 0 DO 49 IC1=1,NTC IF(AIJ(NS1,IC1).EQ.0.0) GO TO 49 I=NTYP(NS1,IC1) I5=NOCCSH(I) DO 43 K=1,I5 IA2(K) = NOCORB(K,I) 43 IB2(K) = NELCSH(K,I) DO 48 J=1,NCFGP C C SET THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ. C I4=IOCCSH(J) DO 42 K=1,I4 IA1(K) = IOCORB(K,J) 42 IB1(K) = IELCSH(K,J) C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C SET J1QN C IB=IOCCSH(J)+1 CALL SJ1QNT(J,IB,I3,2,1) IB=NOCCSH(I)+1 CALL SJ1QNT(I,IB,I3,2,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITAL C IHSH=I3+1 I31=I3+1 I1M=2*I3+1 LJ(I31)=L2P(NCH1) NOSH(I31,1)=0 NOSH(I31,2)=1 J1QN(I31,1,1)=0 J1QN(I31,2,1)=1 J1QN(I31,3,1)=1 J1QN(I1M,1,1)=0 J1QN(I1M,2,1)=2*LRGL+1 J1QN(I1M,3,1)=NSPN J1QN(I31,1,2)=1 J1QN(I31,2,2)=2*LJ(I31)+1 J1QN(I31,3,2)=2 J1QN(I1M,1,2)=0 J1QN(I1M,2,2)=2*LRGL+1 J1QN(I1M,3,2)=NSPN NJ(I31) = 999 IF(IBUG9.GE.4) CALL PNTBG2(J,I) CALL MATANS (2) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C DO 47 K=1,NRANG2 47 HNP1(K,J)=HNP1(K,J)+AME(1,K)*AIJ(NS1,IC1) 48 CONTINUE 49 CONTINUE GO TO 51 C 50 READ(ITAPE2) ((HNP1(K,J),J=1,NCFGP),K=1,NRANG2) 51 WRITE(ITAPE3)((HNP1(K,J),J=1,NCFGP),K=1,NRANG2) IF(IBUG9.LT.2.OR.(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2))GO TO 55 WRITE(IWRITE,1005) NCH1 JUP=0 52 JLO=JUP+1 JUP=MIN(JUP+6,NCFGP) DO 54 I=1,NRANG2 54 WRITE(IWRITE,1002)(HNP1(I,J),J=JLO,JUP) WRITE(IWRITE,1003) IF(JUP.LT.NCFGP) GO TO 52 55 CONTINUE 56 CONTINUE 57 WRITE(IWRITE,1010) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 70 ICOUNT=ICOUNT+1 C C NOW EVALUATE THE BOUND-BOUND CONTRIBUTION TO HNP1 C IF(NCFGP.LE.0.OR.NCHAN.LE.0) GO TO 68 WRITE(IWRITE,1006) DO 67 I=1,NCFGP IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 65 I4 = IOCCSH(I) DO 60 K = 1,I4 IA1(K) = IOCORB(K,I) 60 IB1(K) = IELCSH(K,I) DO 64 J= I,NCFGP C C SET NJ AND LJ C I5 = IOCCSH(J) DO 61 K = 1,I5 IA2(K) = IOCORB(K,J) 61 IB2(K) = IELCSH(K,J) C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C SET J1QN C IB=IOCCSH(I)+1 CALL SJ1QNT(I,IB,I3,1,1) IB=IOCCSH(J)+1 CALL SJ1QNT(J,IB,I3,1,2) C C SET REMAINING QUANTITIES FOR MATRIX C IHSH = I3 NDCT(2) = 0 IF(IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS (1) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C 64 HNP1(1,J)=AME(1,1) GO TO 66 65 READ(ITAPE2) (HNP1(1,J),J=I,NCFGP) 66 WRITE(ITAPE3)(HNP1(1,J),J=I,NCFGP) IF(IBUG9.LT.1.OR.(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2))GO TO 67 WRITE(IWRITE,1007) I, (HNP1(1,J),J=I,NCFGP) 67 CONTINUE 68 WRITE(IWRITE,1010) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 70 ICOUNT=ICOUNT+1 GO TO 71 C C WRITE TO ITAPE3 COMPLETED C 70 IF(ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE(IWRITE,1011) 71 RETURN END C*********************************************************************** SUBROUTINE SJ1QNT(IA,IB,IC,ID,IE) C C A ROUTINE TO SET UP THE COUPLING OF THE ATOMIC SHELLS LEAVING C SPACES FOR THE CONTINUUM ELECTRON SHELLS WHERE APPROPRIATE C C IA = THE N OR N+1 ELECTRON CONFIGURATION BEING CONSIDERED C C IB = THE STARTING POINT FOR THE INTERMEDIATE COUPLING IN C THE I1QNRD OR J1QNRD ARRAYS C C IC = THE HIGHEST OCCUPIED SHELL NUMBER BETWEEN BOTH COUPLING C SCHEMES C C ID = 1 FOR BOUND-BOUND, = 2 FOR BOUND-CONTINUUM, = 3 FOR C CONTINUUM-CONTINUUM C C IE = 1 FOR THE BRA COUPLING, = 2 FOR THE KET COUPLING C PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL61= 15+1, LL75= 21+2) PARAMETER (LL43= 21*2+3) COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C I6= GIVES THE POSITION OF THE CURRENT INTERMEDIATE COUPLING IN C J1QN C C I7=IS INCREMENTED FROM 1 AS EACH OCCUPIED ORBITAL IS ENCOUNTERED C C I8=IS INCREMENTED EVERY TIME A DUMMY SHELL IS ENCOUNTERED C I1=IA I2=IB I3=IC I4=ID I5=IE I6=IC+ID I7=1 I8=1 C C LOOP OVER SHELLS C DO 27 I9=1,I3 I10=I8 C C TEST IF SHELL IS DUMMY C IF(NOSH(I9,I5).NE.0) GO TO 3 C C FILL J1QN FOR THE DUMMY SHELL C J1QN(I9,1,I5)=0 J1QN(I9,2,I5)=1 J1QN(I9,3,I5)=1 C C SIGNIFY THAT A DUMMY SHELL HAS JUST BEEN ENCOUNTERED C I8=I8+1 C C TEST IF FIRST, SECOND OR OTHER SHELL C 2 IF(I9-2) 27,10,24 C C FILL UP J1QN ARRAY FROM J1QNRD OR I1QNRD C 3 IF(I4-2) 4,7,8 4 DO 5 K=1,3 5 J1QN(I9,K,I5)=I1QNRD(I7,K,I1) C C SIGNIFY THAT AN OCCUPIED SHELL HAS BEEN MET C 6 I7=I7+1 GO TO 2 7 IF(I5.LE.1) GO TO 4 8 DO 9 K=1,3 9 J1QN(I9,K,I5)=J1QNRD(I7,K,I1) GO TO 6 C C THE SECOND SHELL HAS BEEN FILLED,NOW FILL FIRST INTERMEDIATE C COUPLING C 10 IF(I8.GT.1) GO TO 19 C C NEITHER OF FIRST TWO SHELLS WAS A DUMMY C 11 IF(I4-2) 12,16,17 12 DO 13 K=1,3 13 J1QN(I6,K,I5)=I1QNRD(I2,K,I1) 14 I2=I2+1 15 I6=I6+1 GO TO 27 16 IF(I5.LE.1) GO TO 12 17 DO 18 K=1,3 18 J1QN(I6,K,I5)=J1QNRD(I2,K,I1) GO TO 14 C C ONE OR BOTH OF SHELLS WERE DUMMY C 19 IF(I10.EQ.I8) GO TO 23 I11=I9-1 21 DO 22 K=1,3 22 J1QN(I6,K,I5)=J1QN(I11,K,I5) GO TO 15 26 IF(I7.NE.2) GO TO 11 23 I11=I9 GO TO 21 C C FILL INTERMEDIATE J1QN FOR AN OCCUPIED SHELL C 24 IF(I10.EQ.I8) GO TO 26 I11=I6-1 GO TO 21 27 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE SJ2QNT(IA,IB,IC,ID,IE) C C A ROUTINE TO SET UP THE COUPLING OF THE ATOMIC SHELLS FOR C THE N-ELECTRON TARGET CONFIGURATIONS (BASED ON SUB. SJ1QNT) C C IA = THE N ELECTRON CONFIGURATION BEING CONSIDERED C C IB = THE STARTING POINT FOR THE INTERMEDIATE COUPLING IN C THE J1QNRD ARRAYS C C IC = THE HIGHEST OCCUPIED SHELL NUMBER BETWEEN BOTH COUPLING C SCHEMES C C ID = 1 FOR BOUND-BOUND C C IE = 1 FOR THE BRA COUPLING, = 2 FOR THE KET COUPLING C PARAMETER (LL41= 15*2-1, LL43= 21*2+3, LL75= 21+2) COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH(LL75,2), * J1QN(LL43,3,2),IJFUL(LL75) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) C C I6= GIVES THE POSITION OF THE CURRENT INTERMEDIATE COUPLING IN C J1QN C C I7=IS INCREMENTED FROM 1 AS EACH OCCUPIED ORBITAL IS ENCOUNTERED C C I8=IS INCREMENTED EVERY TIME A DUMMY SHELL IS ENCOUNTERED C I1=IA I2=IB I3=IC I4=ID I5=IE I6=IC+ID I7=1 I8=1 C C LOOP OVER SHELLS C DO 27 I9=1,I3 I10=I8 C C TEST IF SHELL IS DUMMY C IF(NOSH(I9,I5).NE.0) GO TO 4 C C FILL J1QN FOR THE DUMMY SHELL C J1QN(I9,1,I5)=0 J1QN(I9,2,I5)=1 J1QN(I9,3,I5)=1 C C SIGNIFY THAT A DUMMY SHELL HAS JUST BEEN ENCOUNTERED C I8=I8+1 C C TEST IF FIRST, SECOND OR OTHER SHELL C 2 IF(I9-2) 27,10,24 C C FILL UP J1QN ARRAY FROM J1QNRD C 4 DO 5 K=1,3 5 J1QN(I9,K,I5)=J1QNRD(I7,K,I1) C C SIGNIFY THAT AN OCCUPIED SHELL HAS BEEN MET C I7=I7+1 GO TO 2 C C THE SECOND SHELL HAS BEEN FILLED, NOW FILL FIRST INTERMEDIATE C COUPLING C 10 IF(I8.GT.1) GO TO 19 C C NEITHER OF FIRST TWO SHELLS WAS A DUMMY C 12 DO 13 K=1,3 13 J1QN(I6,K,I5)=J1QNRD(I2,K,I1) I2=I2+1 15 I6=I6+1 GO TO 27 C C ONE OR BOTH OF SHELLS WERE DUMMY C 19 IF(I10.EQ.I8) GO TO 23 I11=I9-1 21 DO 22 K=1,3 22 J1QN(I6,K,I5)=J1QN(I11,K,I5) GO TO 15 26 IF(I7.NE.2) GO TO 12 23 I11=I9 GO TO 21 C C FILL INTERMEDIATE J1QN FOR AN OCCUPIED SHELL C 24 IF(I10.EQ.I8) GO TO 26 I11=I6-1 GO TO 21 27 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE STG2RD C C READS IN AND WRITES OUT THE INPUT DATA C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*1 LVALUE(0:6),PAR(0:1) CHARACTER*4 TITLE(18),PARITY(0:1), IOS(2)*6, SPIN(8)*8 PARAMETER(L13=2500,L24= 21) PARAMETER (LL41= 15*2-1, LL42= 15*2+1, LL61= 15+1, LL75= 21+2) DIMENSION NORDER(LL75),NTAPE(4) COMMON/BASIC/ BSTO,ETOT,RA,W1,WINT,WMAX,WMIN, 1 LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BNDCON/NCFGP,IOCCSH(2500),IOCORB( 15,2500), * IELCSH( 15,2500),I1QNRD(LL41,3,2500) COMMON/BPSIZE/KFLN,KFL2,KFLM,KDUMMY(6) COMMON/CASES/ MORE,MSKIP,IPOLPH,INAST COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CROSEC/CF( 520, 520, 8),ET( 520),ENAT( 70), TEC( 70), * ISAT( 70),LAT( 70),L2P( 520),IPTY( 70),MBED( 70) COMMON/CUPINT/MNP1,NCONHP,NCHAN,NSYMAX COMMON/CUPPLE/NOPTN,MNAL( 21),MXAL( 21),IBASSH( 148, 21), 1 NXCITE( 148),JREAD, LOCSH( 148) ! '05Feb LO restored COMMON/CUT/ NCUT,IKIP(9000),JOCCSH(9000), ITYP(9000) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DIAG/ NDIAG,LRAN22 COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, 1 ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MSTATE/MCFG,MOCCSH(2500),MOCORB(LL61,2500), 1 MELCSH(LL61,2500),M1QNRD(LL42,3,2500),KCFG, 2 KOCCSH(2500),KOCORB(LL61,2500),KELCSH(LL61,2500), 3 K1QNRD(LL42,3,2500),MAXOR COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 300),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3),JRELOP(3) COMMON/STATED/AIJ( 70, 300),NTCON( 70),NTYP( 70, 300) COMMON/STATES/NCFG,NOCCSH( 579),NOCORB( 15, 579), 1 NELCSH( 15, 579),J1QNRD(LL41,3, 579),MAXORB, 2 NJCOMP(LL75),LJCOMP(LL75) SAVE NORDER,NKEY,IKEY,ICUT DATA LVALUE/'S','P','D','F','G','H','?'/, PARITY/'EVEN',' ODD'/, * SPIN/' SINGLET',' DOUBLET',' TRIPLET',' QUARTET',' QUINTET', * ' SEXTET ',' SEPTET',' OCTET'/, PAR/'e','o'/, * NTAPE/1,2,3,4/, IOS/' INPUT','OUTPUT'/ C 1000 FORMAT(//52X,17HSUBROUTINE STG2RD/52X,17(1H-)) 1001 FORMAT(//' RSTG2 ABORTING'/' (AMP)L11=',I4,' MUST EQUAL KFLN=',I4/ *' (AMP)L24=',I4,10X,'KFL2-4=',I4,'-4'/' (AMP)L13=',I4,12X,'KFLM=', * I4//' RECOMPILE RSTG2 (OR STGLIB)!'/) 1002 FORMAT(//8X,71(1H-)//8X,18A4//8X,71(1H-)/// 1//25X,53HSSSSSSSS TTTTTTTTTT GGGGGGGG 22222222 2/24X,55HSSSSSSSSSS TTTTTTTTTT GGGGGGGGGG 2222222222 3/24X,55HSS TT GG GG 22 22 4/24X,55HSS TT GG 22 5/24X,54HSS TT GG 22 6/24X,52HSSSSSSSSS TT GG 22 7/24X,50H SSSSSSSSS TT GG GGGG 22 8/24X,48H SS TT GG GGGG 22 9/24X,47H SS TT GG GG 22 1/24X,47H SS TT GG GG 22 2/24X,55HSSSSSSSSSS TT GGGGGGGGGG 2222222222 3/25X, 54HSSSSSSSS TT GGGGGGGG 2222222222) 1003 FORMAT(/29H INPUT-OUTPUT CHANNEL NUMBERS/12I5/ * 17H DEBUG PARAMETERS/12I5) 1004 FORMAT(11H BASIC DATA//9H MAXORB =,I3,10H NELC =,I3, 1 9H NAST =,I4,8H NKEY =,I3,8H NCUT =,I4 2 /25X,9H INAST =,I4,8H IKEY =,I3,8H ICUT =,I4,9H NDIAG =,I2) 1005 FORMAT(' SEQUENTIAL ',A6,' CHANNEL FOR ANGULAR INTEGRALS =',I3) 1006 FORMAT(8H ORBITAL,I3,2H =,I2,A1) 1007 FORMAT(11H IKIP ARRAY/(40I2)) 1008 FORMAT(/6X,22HOPTION CHOSEN, NOPTN =,I5) 1009 FORMAT(57H THE MINIMUM NUMBER OF ELECTRONS ALLOWED IN EACH SHELL I *S,(T62,6I3)) 1010 FORMAT(57H THE MAXIMUM NUMBER OF ELECTRONS ALLOWED IN EACH SHELL I *S,(T62,6I3)) 1011 FORMAT(20H BASIC CONFIGURATION,I5,2H (,I2,' ELECTRON EXCITATIONS R *EQUIRED)',(T62,6I3)) 1013 FORMAT(/4H L =,I3,3X,A8,3X,A4/1X,24(1H-)) 1016 FORMAT(53X,19HINPUT CHANNEL ITAPE,I1,2H =,I4) 1017 FORMAT(52X,20HOUTPUT CHANNEL ITAPE,I1,2H =,I4) 1018 FORMAT(8H ICOPY =,I3,10H ITOTAL =,I4,10H IPOLPH =,I3/ * 17H MASS-CORRECTION(,I1,2H),,13H DARWIN-TERM(,I1,2H),, * 12H SPIN-ORBIT(,I2,1H)/53X,19HINPUT CHANNEL ITAPE,I1,2H =,I4) 1019 FORMAT(/53H POSITION THE INPUT TAPE FOR COPYING SINCE ICOPY.GT.0) 1020 FORMAT(6H AIJ =,(T7,8F14.7)) 1021 FORMAT(6H ENAT=,8F14.7) 1022 FORMAT(44H WARNING - THE NORMALIZATION OF THE STATE IS,F14.7, 1 32H THE STATE IS BEING RENORMALIZED) 1023 FORMAT(/10X,64(1H*)//43X,31HTARGET OR CORE STATE INPUT DATA/ * /10X,64(1H*)) 1024 FORMAT(/10X,64(1H*)//49X,23HSCATTERED ELECTRON DATA//10X,64(1H*)) 1025 FORMAT(7H NTCON=,12I5/(7X,12I5)) 1026 FORMAT(/33H TOTAL NUMBER OF CONFIGURATIONS =,I5) 1027 FORMAT(/6H NTYP=,I6,7I14/(6X,I6,7I14)) 1028 FORMAT(28H TOTAL NUMBER OF ELECTRONS =,I5,12X,12HORBITALS ARE, 1 (T62,6I3)) 1029 FORMAT(/I3,1X,A1/3X,A1) C C THE FOLLOWING FORMAT STATEMENTS ARE TO READ THE CARD INPUT DATA C 2000 FORMAT(12I5) 2001 FORMAT(5F14.7) 2002 FORMAT(18A4) C C FOLLOWING FORMAT WRITES CURRENT COMPILED DIMENSIONS C 6002 FORMAT(//10X,'COMPILED FOR DIMENSIONS'// + 15X,'LENGTH OF RKST01 IN /INSTO2/ (AMP)L.1 = 5767'/ + 15X,'LENGTH OF RKSTO2 IN /INSTO2/ (AMP)L.2 = 1180800'/ + 15X,'ISTBC1 + ISTBC2 IN /INSTO3/ (AMP)L.3 = 580'/ + 15X,'ISTBB1 + ISTBB2 IN /INSTO3/ (AMP)L.4 = 112'/ + 15X,'MAX. NUMBER OF CHANNELS (AMP)L.5 = 520'/ + 15X,'MAXIMUM VALUE OF NRANG2 (AMP)L.7 = 60'/ + 15X,'LENGTH OF FACTORIAL ARRAY IN /FACT/ (AMP)L.8 = 250'/ + 15X,'TAB.POINTS, *2 USED FOR PV IN /POTORB/ (AMP)L.9 = 1280'/ + 15X,'IPOT,CPOT,XPOT TRANSIT IN /POTEN/ (AMP)L10 = 6'/ + 15X,'MX OCC. SHELLS IN /BNDCON/ ETC KFLN===>(AMP)L11 = 15'/ + 15X,'SIZE OF NOCCSH... IN /STATES/... (AMP)L12 = 579'/ + 15X,' (N+1) CONFIGS IN /BNDCON/ KFLM===>(AMP)L13 = 2500'/ + 15X,'TARGET TERMS (IN /CROSEC/ ETC) (AMP)L14 = 70'/ + 15X,'NO OF CONTINUUM ANG. MOM. (AMP)L15 = 49'/ + 15X,'NO OF BOUND ANG. MOM. (AMP)L16 = 5'/ + 15X,'IHX AND IRX IN /INIT/ (AMP)L17 = 9'/ + 15X,'NO OF MULTIPOLES IN POTENTIAL (AMP)L18 = 8'/ + 15X,'ONEST1,RMASS1 IN /INSTO2/ (AMP)L19 = 56'/ + 15X,'ONEST2,RMASS2 IN /INSTO2/ (AMP)L20 = 820') 6003 FORMAT( + 15X,'ONEST3,RMASS3 IN /INSTO2/ (AMP)L21 = 1830'/ + 15X,"POINTER ARRAY ICT IN /RKSAVE/ 100*(AMP)L22 = 1400'00"/ + 15X,'PARTITIONING ALONG SYMMETRIES SL (4-5) (AMP)L23 = 6'/ + 15X,'SET MAX(L11,L24) FOR PREPRO KFL2-4===>(AMP)L24 = 21'/ + 15X,'MAX. COMPONENTS FOR ONE SLP SYMMETRY (AMP)L25 = 300'/ + 15X,'LENGTH OF NCO IN /RADIAL/ (AMP)L26 = 30'/ + 15X,'C, ZE AND IRAD IN /RADIAL/ (AMP)L27 = 300'/ + 15X,'NO OF CONFIGS IN /CUT/ (AMP)L28 = 9000'/ + 15X,'NO OF CONFIGS. IN /CUPPLE/ (AMP)L29 = 148'/ + 15X,'B-B MULTIPOLE INTEGRALS IN /INSTO5/ (AMP)L30 = 1000'/ + 15X,'KFL3 --- RATHER FOR RDAR1 (AMP)L31 = 35'/ + 15X,'KFL4 --- RATHER FOR RDAR1 (AMP)L32 = 210'/ + 15X,'KFL1...7 ONCE STGLIB BECOMES PREPROCESSIBLE'/ C + 15X,'KFL5 (AMP)L33 = &L33'/ C + 15X,'KFL6 (AMP)L34 = &L34'/ C + 15X,'KFL7 (AMP)L35 = &L35'/ + 15X,' (AMP)L36 = 6'/ + 15X,' (AMP)L37 = 2400'//) C + 15X,'NUMBER OF (N+1)-ELECTRON SYMMETRIES SLP(AMP)L44 = &L44'//) C C IN CASE OF ARRAY OVERFLOW WHEN READING THE DATA CALL RECOV1 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C IPLACE=0 C C IF MSKIP.GT.1, STG2 IS BEING REPEATED FOR NEW (N+1)-ELECTRON DATA C SO IT IS NOT NECESSARY TO READ IN THIS FIRST SET OF DATA AGAIN: C IF(MSKIP.GE.0) GO TO 29 READ(IREAD,2002) TITLE CX IF(TITLE(1).EQ.'CIV3') THEN C IF(TITLE(1).EQ.'STG1'.OR.TITLE(1).EQ.'/EOF') THEN C 101 READ(IREAD,2002) TITLE(1); IF(TITLE(1).NE.'STG2') GO TO 101 C ENDIF READ(IREAD,*) IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3,IDISC4, 1 ITAPE1,ITAPE2,ITAPE3,ITAPE4,JREAD,JDISC1 WRITE(IWRITE,1002) TITLE C C WRITE OUT CURRENT COMPILED DIMENSIONS C WRITE(IWRITE,6002) WRITE(IWRITE,6003) WRITE(IWRITE,1000) READ(IREAD,*)IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 WRITE(IWRITE,1003)IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3,IDISC4, * ITAPE1,ITAPE2,ITAPE3,ITAPE4,JREAD,JDISC1, * IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 IF(IDMTST(11).NE.KFLN.OR.L24.NE.KFL2-4) GO TO 88 IF(L13.NE.KFLM) GO TO 88 C C READ IN WHICH RELATIVISTIC OPERATORS ARE TO BE INCLUDED: C C JRELOP(1).GT.0 FOR MASS-CORRECTION (.GT.1 FOR SPECIAL TCC!), C JRELOP(2).GT.0 FOR DARWIN-TERM (" WHEN M AND INCLUDED IN LS-H/) C JRELOP(3).NE.0 FOR SPIN-ORBIT (.LT.0 NOT ACTIVATED AS TCC OPTION) C READ(IREAD,*) ICOPY,ITOTAL,IPOLPH, JRELOP ICOPY1=1 ICOPY2=ICOPY WRITE(IWRITE,1018) ICOPY,ITOTAL,IPOLPH, JRELOP, NTAPE(1),ITAPE1 IF(IPOLPH.LT.0) IPOLPH=3 C FOR DEFINITION BEFORE '97FEB19. IF(ICOPY2.GT.0) GO TO 2 WRITE(IWRITE,1017)NTAPE(3),ITAPE3 IF(ITAPE4.GT.0) WRITE(IWRITE,1017)NTAPE(4),ITAPE4 GO TO 3 C C POSITION THE INPUT TAPE FOR COPYING, IF NECESSARY. C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF READTP. C 2 WRITE(IWRITE,1016)NTAPE(2),ITAPE2 WRITE(IWRITE,1017)NTAPE(3),ITAPE3 IF(ITAPE4.GT.0) WRITE(IWRITE,1016)NTAPE(4),ITAPE4 WRITE(IWRITE,1019) CALL COPYTP(ITAPE2) WRITE(IWRITE,1000) C C READ AND WRITE BASIC DATA C C MAXORB ..... THE TOTAL NUMBER OF POSSIBLE SHELLS. C NELC ....... THE TOTAL NUMBER OF ELECTRONS. C NAST ....... THE TOTAL NUMBER OF ATOMIC OR IONIC STATES. c'01Oct30: negative when correction read in for transfer via BOUND C'05Mar06 and for skipping embedded correlation configurations C NKEY ....... =-1 FOR MINIMUM CARD INPUT DATA. AS FOR NKEY=0, C BUT THE VALUE OF NOPTN IS NOT READ IN. C = 0 FOR AUTOMATIC GENERATION OF THE CONFIGURATION C DATA, USING THE SAME CRITERIA FOR EACH STATE. C = 1 FOR AUTOMATIC GENERATION OF THE CONFIGURATION C DATA, USING DIFFERENT CRITERIA FOR EACH STATE. C = 2 FOR READING THE CONFIGURATION DATA FROM JREAD. C NCUT ....... THE TOTAL NUMBER OF CONFIGURATIONS GENERATED OR READ C IF NOT ALL OF THEM ARE TO BE STORED, C = 0 IF ALL THE CONFIGURATIONS ARE TO BE STORED. C C INAST ...... AS FOR NAST, BUT FOR THE (N+1)-ELECTRON STATES. C IKEY ....... AS FOR NKEY, BUT FOR THE (N+1)-ELECTRON STATES. C ICUT ....... AS FOR NCUT, BUT FOR THE (N+1)-ELECTRON STATES. C C NDIAG ...... = 0 (DEFAULT) IF TARGET CONFIGURATION COEFFICIENTS C ARE TO BE READ IN, AS IN CPC VERSION; C = 1 IF COEFFICIENTS & ENERGIES ARE TO BE CALCULATED C BY DIAGONALIZING THE TARGET HAMILTONIAN. C C KAB1 ....... = 0 (DEFAULT) NO ACTION ON STORING ANGULAR INTEGRALS C .GT.0 CHANNEL NUMBER FOR WRITING ANGULAR INTEGRALS, C SEQUENTIALLY AS THEY ARE GENERATED; C .LT.0 CHANNEL NUMBER FOR READING ANGULAR INTEGRALS C FROM PREVIOUS ISO-ELECTRONIC RUN. C 3 READ(IREAD,*)MAXORB,NELC,NAS0,NKEY,NCUT,INAST,IKEY,ICUT,NDIAG,KAB1 WRITE(IWRITE,1004)MAXORB,NELC,NAS0,NKEY,NCUT,INAST,IKEY,ICUT,NDIAG NAST=ABS(NAS0) L=2 IF(KAB1) 81,83,82 81 L=1 82 N=ABS(KAB1) WRITE(IWRITE,1005) IOS(L),N REWIND N 83 N=ABS(MAXORB) IF(N.GT.IDMTST(24)) CALL RECOV1(24,N) IF(NKEY.LT.2.AND.IKEY.LT.2) JREAD=0 C C IF MAXORB.LT.0 THE N,L VALUES FOR THE (-MAXORB) SHELLS ARE C AUTOMATICALLY ORDERED AS 1S,2S,2P,3S,...... C IF MAXORB.GT.0 THE N,L VALUES FOR THE (MAXORB) SHELLS ARE READ IN C C NJCOMP(I),LJCOMP(I) ..... THE N,L VALUES FOR THE I-TH SHELL. C IF(MAXORB.GT.0) GO TO 5 MAXORB=-MAXORB N=1 L=0 DO 4 I=1,MAXORB NJCOMP(I)=N LJCOMP(I)=L L=L+1 IF(L.LT.N) GO TO 4 N=N+1 L=0 4 CONTINUE GO TO 6 5 READ(IREAD,*) (NJCOMP(I),LJCOMP(I),I=1,MAXORB) 6 DO 7 I=1,MAXORB WRITE(IWRITE,1006) I,NJCOMP(I),LVALUE(MIN(LJCOMP(I),6)) 7 NORDER(I)=I C C DEFINE THE N-ELECTRON STATES C IELC=NELC WRITE(IWRITE,1023) C C IF(NCUT.GT.0 READ IN THE ARRAY IKIP(I),I=1,NCUT C C IKIP(I) .... = 0 IF THE I-TH CONFIGURATION IS NOT TO BE STORED, C = 1 IF THE I-TH CONFIGURATION IS TO BE STORED. C IF(NCUT.EQ.0) GO TO 8 IF(NCUT.GT.IDMTST(28)) CALL RECOV1(28,NCUT) READ(IREAD,*) (IKIP(I),I=1,NCUT) WRITE(IWRITE,1007) (IKIP(I),I=1,NCUT) 8 N=0 NCFGP=0 C C LOOP OVER N, THE ATOMIC OR IONIC STATES. C FOR THE DEFINITION OF NCFGT, SEE THE DESCRIPTION OF CONFIG. C 9 N=N+1 IF(N.GT.IDMTST(14)) CALL RECOV1(14,NAST) IF(N.EQ.1) NCFGT=-1 IF(N.EQ.NAST) NCFGT=-2 IF(NAST.EQ.1) NCFGT=-3 IBUG=IBUG7 IF(NKEY.EQ.2) GO TO 16 C C READ DATA INTO THE COMMON BLOCK /CUPPLE/. C C NOPTN ...... =-2 FOR NO CONFIGURATIONS FOR THIS STATE. C =-1 FOR MINIMUM CARD INPUT DATA. AS FOR NOPTN=0 C BUT THE ARRAY MXAL(I) IS NOT READ IN. C = 0 FOR NO RESTRICTION ON THE NUMBER OF ELECTRONS C EXCITED. C .GT.0 FOR A RESTRICTION ON THE NUMBER OF ELECTRONS C EXCITED FROM GIVEN BASIC CONFIGURATIONS. C THE VALUE OF IOPTN IS THE TOTAL NUMBER OF SUCH C BASIC CONFIGURATIONS. C MNAL(I) .... THE MINIMUM NUMBER OF ELECTRONS IN THE I-TH SHELL. C MXAL(I) .... THE MAXIMUM NUMBER OF ELECTRONS IN THE I-TH SHELL. C IBASSH(M,I) .... THE NUMBER OF ELECTRONS IN THE I-TH SHELL OF THE C M-TH BASIC CONFIGURATION. C NXCITE(M) .. THE MAXIMUM NUMBER OF ELECTRONS TO BE EXCITED FROM C THE M-TH BASIC CONFIGURATION. C IF(NKEY) 10,11,12 10 NOPTN=-1 11 IF(N.GT.1) GO TO 16 IF(NKEY) 13,12,12 12 READ(IREAD,*) NOPTN 13 WRITE(IWRITE,1008) NOPTN IF(NOPTN.EQ.-2) GO TO 16 WRITE(IWRITE,1028)IELC,(NORDER(I),I=1,MAXORB) READ(IREAD,*) (MNAL(I),I=1,MAXORB) WRITE(IWRITE,1009) (MNAL(I),I=1,MAXORB) DO 14 I=1,MAXORB 14 MXAL(I)=999 IF(NOPTN.EQ.-1) GO TO 16 READ(IREAD,*) (MXAL(I),I=1,MAXORB) WRITE(IWRITE,1010) (MXAL(I),I=1,MAXORB) IF(NOPTN.EQ.0) GO TO 16 IF(NOPTN.GT.IDMTST(29)) CALL RECOV1(29,NOPTN) DO 15 M=1,NOPTN READ(IREAD,*) (IBASSH(M,I),I=1,MAXORB),NXCITE(M) if (IBUG7.lt.0) go to 15 WRITE(IWRITE,1011) M, NXCITE(M), (IBASSH(M,I),I=1,MAXORB) 15 CONTINUE C C LL ......... THE TOTAL ANGULAR MOMENTUM OF THE STATE. C LSPN ....... = 2S+1, WHERE S IS THE TOTAL SPIN. C LPTY ....... THE PARITY, = 0 IF EVEN, = 1 IF ODD. C 16 if (NAS0.ge.0.or.ielc.gt.nelc) then READ(IREAD,*) LL,LSPN,LPTY eco=0. mbd=0 else READ(IREAD,*) LL,LSPN,LPTY, mbd, eco endif LS=MIN(LSPN,8) IF(LSPN.LT.1.OR.LPTY.LT.0.OR.LPTY.GT.1) STOP L=MIN(LL,6) IF(IELC.EQ.NELC) WRITE(IWRITE,1029)LSPN,PAR(LPTY),LVALUE(L) IF(IELC.GT.NELC) WRITE(IWRITE,1013)LL,SPIN(LS),PARITY(LPTY) CALL CONFIG(LL,LSPN,LPTY,MAXORB,NJCOMP,LJCOMP,IELC,IBUG,NCFGT) IF(IELC.EQ.NELC+1) GO TO 33 IF(NAST.GT.IDMTST(14)) CALL RECOV1(14,NAST) IF(NCFGT.GT.IDMTST(25)) CALL RECOV1(25,NCFGT) ! '05Feb28: not (12) NTCON(N)=NCFGT DO 20 I2=1,NCFGT 20 NTYP(N,I2)=ITYP(I2) LAT(N)=LL ISAT(N)=LSPN IPTY(N)=LPTY MBED(N)=MIN(mbd,0) ! to jump terms with this symmetry TEC(N)=eco ! correcting diagonal element of target hamiltonian IF(N.LT.NAST) GO TO 9 C C STORE THE N-ELECTRON CONFIGURATION DATA IN /STATES/ C NCFG=NCFGP WRITE(IWRITE,1026)NCFG IF(NCFG.GT.IDMTST(12)) CALL RECOV1(12,NCFG) DO 24 I=1,NCFG JACT=IOCCSH(I) DO 23 J=1,JACT DO 22 K=1,3 J1QNRD(J,K,I)=I1QNRD(J,K,I) IF(J.LT.JACT) J1QNRD(J+JACT,K,I)=I1QNRD(J+JACT,K,I) 22 CONTINUE NOCORB(J,I)=IOCORB(J,I) 23 NELCSH(J,I)=IELCSH(J,I) 24 NOCCSH(I)=JACT C C READ IN THE CONFIGURATION COEFFICIENTS AND ENERGIES C CX IF(JRELOP(3).NE.0.AND.NDIAG.GE.0) THEN C NPOSI=0 C DO 99 I=1,NAST C DO 98 J=1,NTCON(I) C 98 AIJ(I,J)=0.0 C IF(NTYP(I,1).NE.NPOSI) JSYM=1 C AIJ(I,JSYM)=1.0 C JSYM=JSYM+1 C NPOSI=NTYP(I,1) C 99 ENAT(I)=-1.0 C GO TO 28 CX ENDIF IF(NDIAG.EQ.0) READ(IREAD,2000) (NTCON(I),I=1,NAST) WRITE(IWRITE,1025)(NTCON(I),I=1,NAST) IF(NDIAG.ne.0) GO TO 28 DO 27 I=1,NAST I1=NTCON(I) IF(I1.GT.IDMTST(25)) CALL RECOV1(25,I1) WRITE(IWRITE,1027)(NTYP(I,I2),I2=1,I1) READ(IREAD,*) (AIJ(I,I2),I2=1,I1),ENAT(I) WRITE(IWRITE,1020) (AIJ(I,I2),I2=1,I1) ANORM=0. DO 25 I2=1,I1 25 ANORM=ANORM+AIJ(I,I2)**2 IF(ABS(ANORM-1.0).LT.1.E-4) GO TO 27 WRITE(IWRITE,1022) ANORM DO 26 I2=1,I1 26 AIJ(I,I2)=AIJ(I,I2)/SQRT(ANORM) WRITE(IWRITE,1020)(AIJ(I,I2),I2=1,I1) 27 WRITE(IWRITE,1021)ENAT(I) C C DEFINE THE (N+1)-ELECTRON STATE C 28 NCHAN=0 NCFGP=0 IF(INAST.LE.0) RETURN WRITE(IWRITE,1024) 29 IF(MSKIP.GT.0) WRITE(IWRITE,1000) IELC=NELC+1 C C IF ICUT.GT.0 READ IN THE ARRAY IKIP(I),I=1,ICUT. C IF(ICUT.LE.0) GO TO 30 IF(MSKIP.GT.0) READ(IREAD,*) ICUT IF(ICUT.GT.IDMTST(28)) CALL RECOV1(28,ICUT) READ(IREAD,*) (IKIP(I),I=1,ICUT) WRITE(IWRITE,1007) (IKIP(I),I=1,ICUT) 30 NCUT=ICUT NCFGP=0 NCFGT=-3 IBUG=IBUG7-1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) IBUG=0 IF(IKEY.EQ.2) GO TO 16 JREAD=0 IF(IKEY) 31,32,12 31 NOPTN=-1 32 IF(MSKIP.GE.0) GO TO 16 IF(IKEY) 13,12,12 33 LRGL=LL NSPN=LSPN NPTY=LPTY RETURN 88 WRITE(IWRITE,1001) IDMTST(11),KFLN, L24,KFL2, L13,KFLM STOP END C*********************************************************************** SUBROUTINE USEEAV(IRHO,ISIG) C C VERSION FOR R-MATRIX CODE C C PERFORMS THE SAME FUNCTION AS FANO FOR CASES IN WHICH C THE TWO-ELECTRON PART OF THE HAMILTONIAN MATRIX ELEMENT IS C DETERMINED PURELY BY AVERAGE ENERGY EXPRESSIONS C C IRHO AND ISIG SPECIFY THE TWO INTERACTING SHELLS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/ENAV/ COEFCT(5),NINTS,KVALUE(5) COMMON/MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,MU3,M14,M15, 1 M16,M17,M18,M19,M20 COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) COMMON/NJLJ/ NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON/XATION/AMULT(99),BMULT(99),KD1,KD2,KE1,KE2,MULTD,MULTE C C DETERMINE THE INTERACTION ENERGY C N1=NOSH1(IRHO) N2=NOSH2(ISIG) M1=ISIG-IRHO IF(M1.EQ.0) GO TO 1 IEQUIV=2 AC2=N1*N2 GO TO 2 1 IEQUIV=1 AC2=(N1*(N1-1)/2) 2 LRHO=LJ(IRHO) LSIG=LJ(ISIG) IF(LRHO.GT.4.OR.LSIG.GT.4) GO TO 9 CALL INTACT(LRHO,LSIG,IEQUIV) GO TO 10 9 CALL FANO(IRHO,ISIG,IRHO,ISIG) GO TO 8 10 M2=M1 M19=0 M20=0 NRHO=NJ(IRHO) NSIG=NJ(ISIG) NRHOP=NRHO NSIGP=NSIG LRHOP=LRHO LSIGP=LSIG KD1=1 MULTD=1 AMULT(1)=AC2 IF(NINTS.EQ.0) GO TO 6 IF(IEQUIV.EQ.1) GO TO 4 KE1=KVALUE(1)+1 KE2=KVALUE(NINTS)+1 KD2=1 MULTE=1 DO 3 N=1,NINTS K=KVALUE(N)+1 3 BMULT(K)=AC2*COEFCT(N) GO TO 8 4 DO 5 N=1,NINTS K=KVALUE(N)+1 5 AMULT(K)=AC2*COEFCT(N) KD2=KVALUE(NINTS)+1 GO TO 7 6 KD2=1 7 MULTE=0 KE1=1 KE2=1 8 CALL PRNTWT(IRHO,ISIG,IRHO,ISIG) C RETURN END C*********************************************************************** SUBROUTINE VIJOUT(JA,JB) C C PRINTS OUT THE QUANTUM NUMBERS AND COUPLING SCHEMES C FOR EACH MATRIX ELEMENT DEFINED BY SETUP. C IT IS ENTERED ONLY IF IBUG9 IS GREATER THAN ZERO. C C JA AND JB SPECIFY THE TWO INTERACTING CONFIGURATIONS C PARAMETER (LL43= 21*2+3, LL75= 21+2) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MEDEFN/IHSH,NJ(LL75),LJ(LL75),NOSH1(LL75),NOSH2(LL75), * J1QN1(LL43,3),J1QN2(LL43,3),IJFUL(LL75) C 1001 FORMAT(//8H (CONFIG,I3,9H/V/CONFIG,I3,1H)//7H NJ,LJ ,12(I6,I3)) 1002 FORMAT(/48H L.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY/ * /6H NOSH ,10I4) 1003 FORMAT(/48H R.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY/ * /6H NOSH ,10I4) 1004 FORMAT(6H J1QN ,10(I5,2I3)) C WRITE(IWRITE,1001) JA,JB, (NJ(I),LJ(I),I=1,IHSH) WRITE(IWRITE,1002) (NOSH1(J),J=1,IHSH) I2HSH=2*IHSH-1 WRITE(IWRITE,1004) ((J1QN1(J,K),K=1,3),J=1,I2HSH) WRITE(IWRITE,1003) (NOSH2(J),J=1,IHSH) WRITE(IWRITE,1004) ((J1QN2(J,K),K=1,3),J=1,I2HSH) RETURN END