C STG1 - LAST UPDATES KAB'87DEC; & RPS+WE'90MAR, WE/HES+PJS'93FEB3 C INCORPORATES RMATRX STG1 (CPC 14(1978)367-412) WITH BREIT-PAULI C CODE RMATRX STG1R (CPC 25(1982)347-387, 92(1995)290-420); C THE ARRAY SIZES ARE SET BY PREPROCESSING. C LIMEX back to pre-2000 infty (99) 01Apr04, (1:NRANG2)STGT'01Apr20 C 2-body magnetic integrals, with CGX...'03Apr6,Jul22/Dec8;'05Aug10 C*********************************************************************** C C A NEW VERSION OF C C THE FIRST 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 1 C C BY C C THE OPACITY PROJECT C C*********************************************************************** C C GENERATES THE BOUND AND CONTINUUM ORBITALS AND THEN CALCULATES C THE MULTIPOLE INTEGRALS, THE ONE ELECTRON INTEGRALS AND THE RK C INTEGRALS AND STORES THEM ON FILES. C C ALSO CALCULATES ONE-BODY BREIT-PAULI CORRECTIONS, AND ALLOWS C FOR NUMERICAL ORBITAL INPUT AND FOR MODEL POTENTIAL INPUT. C C*********************************************************************** C C ROUTINES USED IN RSTG1 C C*********************************************************************** C C STG1 DIRECTING ROUTINE C ABNORM C BASORB C BLOCK DATA C BUTFIT C CALEXO C CALORB C CHEKTP C CIV3 C COEFF C CORECT C DA2 C DERINT C EVAL C EVALUE C FINDER C GEN1BB C gen2bb C GEN1BC C gen2bc C GEN1CC C gen2cc C GENBB C GENBC C GENCC C GENINT C GENMBB C GENMBC C GENMCC C LSQ C MA01A C MESH C NAME C NEWBUT C ONEELE C ORINT C ORNO C PHASE C POTF C RADINT C RDAR C RECOV1 C RMASS C ROOT C RS C SCHMDT C SKIPER C SPNORB C SS C STG1RD C TABORB C WRITAP C COMPUTER PHYSICS COMMUNICATIONS PROGRAMS USED C BASFUN FROM PROGRAM BASFUN C DERFUN FROM PROGRAM BASFUN C DEVGL FROM PROGRAM BASFUN C C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN RSTG1 C C*********************************************************************** C C IREAD CARD READER - SET IN THE DIRECTING ROUTINE C IWRITE OUTPUT TO LINE PRINTER C IPUNCH VACANT C IDISC1 TEMPORARY STORE FOR ORBITALS C IDISC2 TEMPORARY STORE FOR BOUND ORBITALS C IDISC3 VACANT -> for magnetic 2-body MK_dir C ITAPE2 INPUT STORE OF STG1 INTEGRALS (OPTIONAL RESTART) C ITAPE3 OUTPUT STORE OF STG1 INTEGRALS C ITAPE4 VACANT -> for magnetic 2-body MK_seq C JDISC1 OUTPUT DA-FILE OF RK INTEGRALS (OPEN IN ROUTINE DA2) C JDISC2 INPUT DA-FILE OF RK INTEGRALS (OPTIONAL RESTART) C C*********************************************************************** C C STG1 DIRECTING ROUTINE C C -- WITH ALL COMMON BLOCKS OCCURRING IN RSTG1 C C*********************************************************************** C CCCCC IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999) PARAMETER (LL68= 8/2) PARAMETER (LL53= 5* 5) PARAMETER (LL56= 49+ 5) PARAMETER (LL57= 60+ 4) PARAMETER (LL74= 60+ 4+ 7) PARAMETER (LL90= 7+1) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! LL55=min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) C COMMON/BASDER/FM,TLC,WR,ITST,JR,KM,MMM,NBTP1,NG C COMMON/BASIC/ BSTO,RA,NELC,NRANG2 C COMMON/BASIN/ EIGENS( 60, 49),ENDS( 60, 49),DELTA,ETA C COMMON/BNDORB/P( 7,LL59),RACOR( 128) C COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR C COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT C COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), C * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX C COMMON/CPUNCH/NPUNCH,IHOLEH,IHOLEU,KPUNCH,ISTAND,NREAD COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 C COMMON/FACT/GAMMA( 57) C COMMON/FUNVAL/FRH(LL90),U(LL90),X COMMON/INFORM/IREAD,IWRITE,IPUNCH C COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH C COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), C 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), C 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), C 3 RDAR1( 25),RDAR2(210),RDAR3(1830) C COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), C MK_1 ICTCCD( 5, 5,LL55),ICTCCE( 5, 5,LL56), C 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), C 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), C 3 ISTBC2( 600),IST1( 5),IST2( 5), C 4 ITAPST( 49, 49),IDPOS1,IDPOS2 C COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), C 1 ICCPOL( 49, 49,LL68) C COMMON/INSTO6/RSPOR1( 56),RSPOR2( 600),RSPOR3(1830) C COMMON/JNSTO/ SKSTO2(50000),BNORM( 49),JRK8,JBCPOL( 5, 49), C * JCCPOL( 49, 49) C COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) C COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C COMMON/ORBOUT/ORB(1999),DORB(1999),EIGEN,ALAMDA(LL90),BVALUE C COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) C COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT C COMMON/POTVAL/POVALU(LL59),PX(1999) C COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, C * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C COMMON/REL1/ RLAMDA( 49, 60,LL90) C COMMON/REL/ IRELOP(3) C COMMON/SCOEFF/B(LL57,LL57),OVRLAP( 60, 4),TEMP(LL74) C COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS C COMMON/SKIP/ L1STO,L2STO,LPOS,NBORBS C COMMON/SPZETA/ZESP( 5),IZESP C COMMON/YKSTOR/YK(1999),RK(1999),RK1(1999),JN2,JL2,JN4,JL4,JKM C 1000 FORMAT(/10X,62(1H*)/) 1001 FORMAT(/28H DIMENSIONS EXCEEDED IN STG1/) 1002 FORMAT(55X,11HEND OF STG1/55X,11(1H-)) C C open(5,file='stg1.inp',status='old') open(14,file='zsspnl',status='old') open(6,file='stg1.out',status='unknown') open(2,file='s1fors2',status='unknown',form='unformatted') open(8,file='scr8',status='unknown',form='unformatted') open(9,file='scr9',status='unknown',form='unformatted') c C IREAD IS THE CARD INPUT CHANNEL NUMBER C IREAD=5 IWRITE=6 C C SET UP DIMENSION TEST INDICES C C CALL SETDIM -- NOW PART OF BLOCK DATA -- WE'90MAR18 C C READ IN AND WRITE OUT THE BASIC DATA C NBUG7=1 CORRESPONDS TO A DIMENSION TEST RUN ONLY C CALL STG1RD WRITE(IWRITE,1000) IF(NBUG7.EQ.1) GO TO 2 C C EVALUATE AND STORE THE POTENTIAL FUNCTION C CALL POTF C C EVALUATE THE BOUND AND CONTINUUM ORBITALS C THE CONTINUUM ORBITALS ARE STORED ON DISC C 2 CALL BASORB WRITE(IWRITE,1000) IF(NBUG7.EQ.1) GO TO 1 C C WRITE BASIC QUANTITIES TO OUTPUT TAPE C CALL WRITAP C C EVALUATE THE MULTIPOLE INTEGRALS THE ONE ELECTRON INTEGRALS AND C THE RK INTEGRALS AND STORE ON TAPE C 1 CALL GENINT WRITE(IWRITE,1000) C C FOR DEBUGGING PURPOSES CHECK THE TAPE CONTENTS C IF(NBUG7.EQ.2) CALL CHEKTP(ITAPE3) IF(NBUG7.EQ.2) WRITE(IWRITE,1000) C C WRITE OUT ERROR MESSAGE IF A DIMENSION HAS BEEN EXCEEDED C IF(IPLACE.GT.0) WRITE(IWRITE,1001) IF(IPLACE.LE.0) WRITE(IWRITE,1002) STOP END C*********************************************************************** SUBROUTINE ABNORM(N1,L1,N2,L2,BRAKET) C C EVALUATES THE OVERLAP INTEGRAL BETWEEN TWO NUMERICAL ORBITALS C SPECIFIED BY THE QUANTUM NUMBERS (N1,L1-1) AND (N2,L2-1). C CARRY OUT THE INTEGRATION USING SIMPSONS RULE. C THE RESULT IS STORED IN BRAKET ON RETURN. C N.B. /INIT/ USED WHILE /SIMP/ YET UNDEFINED WHEN CALLED FROM SS. C C IMPLICIT REAL*8(A-H,O-Z) COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) C K1=IPOS(N1,L1) K2=IPOS(N2,L2) BRAKET=0. C NEW BRAKET=ORINT(K1,K2,L1,L2,0) C TST PRINT *, ' ORINT FROM ABNORM K1,K2,L1,L2,0 = ',K1,K2,L1,L2, BRAKET IST=2 MI=4 DO 4 I=1,NIX B=0. IFI=IRX(I)+1 DO 3 J=IST,IFI IF(J.EQ.IFI) MI=1 B=MI*UJ(J,K1)*UJ(J,K2)+B IF(MI.EQ.4) GO TO 2 MI=4 GO TO 3 2 MI=2 3 CONTINUE BRAKET=(IHX(I)*HINT)*B/3+BRAKET MI=1 4 IST=IFI C RETURN END C*********************************************************************** SUBROUTINE BASORB C C EVALUATES BOTH THE BOUND AND THE CONTINUUM ORBITALS AND STORES C THE LATTER ON THE SCRATCH DISC IDISC1. C THE BOUND ORBITALS ARE STORED ON THE SCATCH DISC IDISC2. C THE CONTINUUM ORBITALS ARE ORTHOGONALISED TO THE BOUND ORBITALS C WHOSE PRINCIPAL QUANTUM NUMBERS ARE LESS THAN OR EQUAL TO C MAXNLG(L) BY THE METHOD OF LAGRANGE UNDETERMINED MULTIPLIERS C IN SUBROUTINE BASFUN. C THE CONTINUUM ORBITALS ARE SCHMIDT ORTHOGONALISED TO THE C REMAINING BOUND ORBITALS IN SUBROUTINE SCHMDT. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL RESTAR PARAMETER (PI=3.1415926, LL57= 60+ 4, LL59=2*1999) PARAMETER (LL71= 60+1, LL74= 60+ 4+ 7, LL90= 7+1) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBOUT/ORB(1999),DORB(1999),EIGEN,ALAMDA(LL90),BVALUE COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL1/ RLAMDA( 49, 60,LL90) COMMON/SCOEFF/B(LL57,LL57),OVRLAP( 60, 4),TEMP(LL74) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS COMMON/SKIP/ L1STO,L2STO,LPOS,NBORBS C 1000 FORMAT(//52X,17HSUBROUTINE BASORB/52X,17(1H-)) 1001 FORMAT(//17H ORBITALS FOR L =,I2) 1002 FORMAT(/16H AMPLITUDE AT RA,5X,16HEIGENVALUE (RYD),5X,5HNODES,12X, 1 5HPHASE/) 1003 FORMAT(F13.5,F21.4,I11,F19.4) 1004 FORMAT(/16H AMPLITUDE AT RA,4X,17H EIGENVALUE (RYD),4X,6H NODES/) 1005 FORMAT(/34H OVERLAP INTEGRALS BETWEEN THE N =,I2,14H BOUND ORBITAL */59H AND EACH CONTINUUM ORBITAL BEFORE SCHMIDT ORTHOGONALIZING:/ */(8F9.5)) 1007 FORMAT(/38H AFTER THE SCHMIDT ORTHOGONALISATION:) 1008 FORMAT(/47H OVERLAP INTEGRALS BETWEEN THE ORBITALS FOR L =,I2/) 1009 FORMAT(1X,1P,10E11.2) 1010 FORMAT(/ 7X,3HL =,I2, ' BOUND AND CONTINUUM ORBITALS AS A FUNCTION * OF RADIUS IN UNITS OF A0') 1011 FORMAT(/ 7X,3HL =,I3, ' CONTINUUM ORBITALS AS A FUNCTION OF RADIUS * IN UNITS OF A0') 1012 FORMAT(/29H SCHMIDT COEFFICIENTS FOR L =,I2/) 1013 FORMAT(/1X,9(1H*),' SCHMDT FAILS; NRANG2 REDUCED TO',I4,1X,9(1H*)) 1014 FORMAT(' THE FIRST',I3,' CONTINUUM TERMS ARE TREATED AS BOUND') 1015 FORMAT (//' ORBITAL',I3,' IS MOST DIFFUSE, AT RA IT HAS DECAYED TO * RELATIVE MAGNITUDE',1PE8.2E1/ *' TARGET ORBITALS O.K. IF .LT. 0.002') C C NPTS=IRX(NIX)+1 IS THE NUMBER OF TABULATION POINTS C NBOUND IS A COUNT ON THE BOUND ORBITALS. C IPTS=(NPTS-1)*2 WRITE(IWRITE,1000) 24 IF(NRANG2.GT.IDMTST(7)) CALL RECOV1(7,NRANG2) REWIND IDISC1 REWIND IDISC2 IF(NCOEFF.NE.0) NBOUND=0 C C LOOP OVER THE CONTINUUM ANGULAR MOMENTA C DO 20 LP=1,MAX(LRANG1,LRANG2) L1=LP-1 WRITE(IWRITE,1001) L1 NBT=0 MAXHF=L1 ITEST=0 NFIRST=NBOUND+1 IF(LP.GT.LRANG1) GO TO 1 C C EVALUATE THE BOUND ORBITALS AND STORE IN THE UJ-ARRAY. C ALSO STORE THE FIRST NBT=MAXNLG(L)-L+1 ORBITALS AT THE HALF C INTERVALS IN THE P-ARRAY, AND STORE THEM ON SCRATCH DISC IDISC2. C MAXLG=MAXNLG(LP) NBT=MAXLG-L1 IF(NCOEFF.GT.0) CALL EVALUE(LP,NBOUND) IF(NBUG7.EQ.1) GO TO 20 IF(NCOEFF.EQ.0) CALL EVAL(LP) IF(NBT.GT.0) WRITE(IDISC2)((P(K,I),K=1,NBT),I=1,IPTS) IF(LP.GT.LRANG2) GO TO 20 C C NOW EVALUATE THE CONTINUUM ORBITALS FOR A GIVEN ANGULAR MOMENTUM C MAXHF=MAXNHF(LP) ITEST=MAXHF-MAXLG 1 NRANG2=NRANG2+MAXNCB(LP) NRANGB=NRANG2+1 IF(NBUG7.EQ.1) GO TO 18 IF(L1.GT.2. OR.NELC.NE.NZ) WRITE(IWRITE,1004) IF(L1.LE.2.AND.NELC.EQ.NZ) WRITE(IWRITE,1002) * * NEW ALGORITHM FOR FINDING STARTING VALUES FOR FINDER * IF(LP.EQ.1) THEN IF(NELC.EQ.NZ) THEN ETRIAL=PI*PI/(4.0*RA*RA) ELSE ETRIAL=REAL(NELC-NZ)*PI/(RA+RA) ENDIF ELSE ETRIAL=EIGENS(1,L1) ENDIF C C LOOP TO GENERATE THE CONTINUUM ORBITALS C DO 5 N=1,NRANG2 NQ=NBOUND+N IPOS(N+MAXHF,LP)=NQ NODES=MAXHF-ITEST-LP+N RESTAR=LP.LE.LINPUT.AND.MAXNCB(LP).EQ.0 IF(RESTAR) ETRIAL=EIGENS(N,LP) CALL FINDER(NBT,L1,NODES,RESTAR,ETRIAL) * * CALCULATION OF A NEW ENERGY ESTIMATE FOR THE NEX ORBITAL * IF(ETRIAL.LE.0.0) THEN ETRIAL=ETRIAL+(PI/RA)**2 ELSE ETRIAL=(SQRT(ETRIAL)+PI/RA)**2 ENDIF C C RELATIVISTIC CASE: C ALAMDA CONTAINS THE NORMALISED LAGRANGE MULTIPLIERS. C IF(N.LE.MAXNCB(LP)) GO TO 3 C OUT IF(LP.EQ.1) RNORM(N-MAXNCB(LP))=ALAMDA(NBT+1) IF(NBT.EQ.0) GO TO 3 DO 28 I=1,NBT 28 RLAMDA(LP,N-MAXNCB(LP),I)=ALAMDA(I) C C FOR EACH CONTINUUM ORBITAL, STORE THE FUNCTION IN UJ AND THE C EIGENVALUE IN EIGENS. WRITE OUT THE BOUNDARY AMPLITUDE, C THE EIGENVALUE, THE NUMBER OF NODES, AND THE ZERO-ORDER PHASE C FOR THE S-,P- OR D-ORBITALS. C 3 EIGENS(N,LP)=EIGEN DO 4 I=1,NPTS 4 UJ(I,NQ)=ORB(I) ENDS(N,LP)=ORB(NPTS) IF(L1.LE.2.AND.NELC.EQ.NZ) THEN EPHASE=PHASE(LP,EIGEN) WRITE(IWRITE,1003) ORB(NPTS),EIGEN,NODES,EPHASE ELSE WRITE(IWRITE,1003) ORB(NPTS),EIGEN,NODES ENDIF C C TREAT THE FIRST MAXNCB CONTINUUM ORBITALS AS BOUND C AND STORE THE ONE-ELECTRON FUNCTIONS Q IN DUJ C IF(N.GT.MAXNCB(LP)) GO TO 5 DUJ(1,NQ)=-2*NZ*UJ(1,NQ) DO 47 I=2,NPTS 47 DUJ(I,NQ) = (EIGEN-PX(I)/WT(I))*UJ(I,NQ) IF(NBT.EQ.0) GO TO 5 DO 48 K=1,NBT J=IPOS(K+L1,LP) DO 48 I=2,NPTS 48 DUJ(I,NQ)=DUJ(I,NQ)-UJ(I,J)*ALAMDA(K) 5 CONTINUE C C C EVALUATE BUTTLE CORRECTIONS FOR L=LP-1 AND APPEND TO C END OF CONTINUUM ORBITAL LOCATION C C BUTTLE CORRECTIONS ARE FITTED IN THE FOLLOWING ENERGY RANGE: IF(LP.EQ.1) EK2MAX=0.5*EIGENS(NRANG2,LP) IF(EIGEN.LE.0.) THEN PRINT *,' BASORB: NRANG2 TOO SMALL, ALL EIGENVALUES NEGATIVE' NRANG2=NRANG2+1 GO TO 24 ENDIF Z=NZ-NELC N=1 IF(NELC.GE.2) N=2 IF(NELC.GE.10)N=3 IF(NELC.GE.28)N=4 N=MAX(N,LP) EK2MIN=-(Z/N)**2 CALL NEWBUT(LP) NQ=NQ+1 IPOS(NRANGB+MAXHF,LP)=NQ DO 22 I=1,NPTS 22 UJ(I,NQ)=ORB(I) C C IF MAXNLG(L).NE.MAXNHF(L), SCHMIDT ORTHOGONALISE THE CONTINUUM C ORBITALS TO THOSE BOUND ORBITALS WHICH ARE NOT INCLUDED IN THE C ORTHOGONALISATION IN SUBROUTINE BASFUN. C FIRST WRITE OUT THE OVERLAP INTEGRALS BETWEEN THESE BOUND C ORBITALS AND THE CONTINUUM ORBITALS, AND STORE IN OVRLAP C IF(ITEST.LE.0) GO TO 8 DO 7 N1=1,ITEST N3=MAXLG+N1 DO 6 N=1,NRANG2 N4=MAXHF+N CALL ABNORM(N3,LP,N4,LP,RESULT) 6 OVRLAP(N,N1)=RESULT 7 WRITE(IWRITE,1005) N3, (OVRLAP(N,N1),N=1,NRANG2) C C SCHMIDT ORTHOGONALISE THE ORBITALS AND STORE THE SCHMIDT C COEFFICIENTS AND OVERLAP INTEGRALS ON SCRATCH DISC C N2=LP CALL SCHMDT(N2) IF(N2.GT.0) GO TO 23 NRANG2=-N2-1 C AS A STOP-GAP -- WE'90MAR16 WRITE(IWRITE,1013) NRANG2 GO TO 24 23 N5=NRANG2+ITEST WRITE(IDISC1)((B(I,J),I=1,N5),J=1,N5), 1 ((OVRLAP(N,N1),N=1,NRANG2),N1=1,ITEST) C N.B. SCHMIDT PROCESSING BUTTLE-ORB NOT MEANINGFUL. 8 DO 9 N=1,NRANGB NQ=IPOS(N+MAXHF,LP) 9 ENDS(N,LP)=UJ(NPTS,NQ) C C WRITE OUT THE CONTINUUM ORBITALS ONTO SCRATCH DISC C N1=NBOUND+1+MAXNCB(LP) N2=NBOUND+NRANGB WRITE(IDISC1) ((UJ(I,J),I=1,NPTS),J=N1,N2) C C IF NBUG5.GT.0, CALCULATE AND WRITE OUT THE OVERLAP INTEGRALS C BETWEEN THE BOUND AND CONTINUUM ORBITALS AFTER ORTHOGONALIZATION. C 10 IF(NBUG5.LE.0) GO TO 18 IF(ITEST.GT.0) WRITE(IWRITE,1007) WRITE(IWRITE,1008) L1 N2=MAXHF+NRANG2 DO 12 N1=LP,N2 DO 11 N=LP,N1 CALL ABNORM(N1,LP,N,LP,RESULT) 11 TEMP(N-L1)=RESULT J=N1-L1 12 WRITE(IWRITE,1009) (TEMP(I),I=1,J) C C IF NBUG5.GT.0, WRITE OUT ALL THE ORBITALS AT EVERY M-TH POINT IN C THE INTEGRATION MESH. C ALSO WRITE OUT ANY SCHMIDT COEFFICIENTS. C M=2 N=0 NTOT=NRANG2+NBOUND WRITE(IWRITE,'(/)') 13 IF(N.GT.MAXHF-LP) GO TO 14 IF(NCOEFF.EQ.0) GO TO 14 WRITE(IWRITE,1010) L1 GO TO 15 14 WRITE(IWRITE,1011) L1 15 N3=NFIRST+N N=N+10 N4=MIN(NFIRST-1+N,NTOT) DO 16 J=1,NPTS,M 16 WRITE(IWRITE,'(F10.6,1P,10E10.3)') XR(J), (UJ(J,N1),N1=N3,N4) IF(N4.LT.NTOT) GO TO 13 IF(ITEST.LE.0) GO TO 18 WRITE(IWRITE,1012) L1 DO 17 I=1,N5 17 WRITE(IWRITE,'(5X,10F10.6)') (B(I,J),J=1,N5) C C TREAT THE FIRST MAXNCB CONTINUUM ORBITALS AS BOUND, C INCREMENT NBOUND, ADJUST MAXNHF AND LRANG1. C 18 N1=MAXNCB(LP) IF(N1.EQ.0) GO TO 20 WRITE(IWRITE,1014) N1 NBOUND=NBOUND+N1 IF(LP.LE.LRANG1) THEN MAXNHF(LP)=MAXNHF(LP)+N1 MAXPN (LP)=MAXPN (LP)+N1 ELSE MAXNHF(LP)=LP-1+N1 MAXPN (LP)=LP-1+N1 LRANG1=LP ENDIF DO 19 N=N1+1,NRANG2 EIGENS(N-N1,LP)=EIGENS(N,LP) 19 ENDS (N-N1,LP)=ENDS (N,LP) ENDS(NRANG2-N1+1,LP)=ENDS(NRANG2+1,LP) NRANG2=NRANG2-N1 20 CONTINUE C C C CHECK THAT THE NUMBER OF ORBITALS WHICH HAVE TO BE STORED DOES C NOT EXCEED THE SIZE OF UJ. WE'91JUN27 PRINT BOUND ORBITAL INFO C NBORBS=NBOUND RESULT = 0. DO 26 N=1,NBORBS TWOZ = 0. DO 25 I=2,NPTS IF(ABS(UJ(I,N)).GT.TWOZ) TWOZ = ABS(UJ(I,N)) 25 CONTINUE ETRIAL=RACOR(N) IF(NCOEFF.EQ.0) ETRIAL=UJ(NPTS,N) IF(ABS(ETRIAL).LE.RESULT*TWOZ) GO TO 26 RESULT = ABS(ETRIAL/TWOZ) M = N 26 CONTINUE WRITE(IWRITE,1015) M,RESULT IF(LRANG2.GT.1 .AND. NBORBS+2*NRANGB.GT.IDMTST(22)) 1 CALL RECOV1(22,NBORBS+2*NRANGB) IF(IPLACE.GT.0) NBUG7=1 REWIND IDISC1 RETURN END C*********************************************************************** BLOCK DATA C IMPLICIT REAL*8(A-H,O-Z) C C COMMON/CONSTS/ZERO,ONE ,PT01 ,PT001,PT0001,TINY ,PI ,FSC , C 1 TWO ,THREE,FOUR ,FIVE ,SIX ,EIGHT ,TEN ,TWELVE, C 2 HALF,THIRD,FOURTH,FIFTH,SIXTH ,EIGHTH,TENTH COMMON/RECOV/ IPLACE,IDMTST(50) C C SET UP THE MOST COMMONLY USED REAL CONSTANTS IN /CONSTS/ C THIS MAKES IT EASIER TO CHANGE THE PRECISION OF THE PROGRAM C - NO LONGER RETAINED, AS IT CAN SLOW DOWN EXECUTION C C DATA ZERO,ONE ,PT01 ,PT001 ,PT0001,TINY ,PI ,FSC , C 1 TWO ,THREE,FOUR ,FIVE ,SIX ,EIGHT ,TEN ,TWELVE, HALF, C 2 THIRD,FOURTH,FIFTH ,SIXTH ,EIGHTH,TENTH / C 3 0.0,1.0,1.0E-2,1.0E-3,1.0E-4,1.0E-6,3.14159 , 7.29732E-3, C 4 2.0, 3.0, 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.5, C 5 0.333333333333333, 0.25, 0.2, 0.166666666666667, 0.125, 0.1/ C C THIS SECTION SETS THE IDMTST ARRAY. THE ELEMENTS OF THIS ARRAY C CONTAIN THE ARRAY SIZES IN THE PROGRAM AND ARE C USED TO TEST SIZE OVERFLOW. C C ONLY THOSE ARRAYS WHICH APPEAR IN STG1 ARE SPECIFIED HERE. C C C IDMTST(1-2) SPECIFY THE LENGTH OF THE ARRAY RKSTO1 AND RKSTO2 C IN /INSTO2/ C IDMTST(1)=3778 C IDMTST(2)=327408 DATA IDMTST(1)/4000/, IDMTST(2)/1180800/, C C IDMTST(3-4) SPECIFY THE LENGTH OF THE ARRAYS ISTBC1 AND ISTBC2 C AND OF THE ARRAYS ISTBB1 AND ISTBB2 IN /INSTO3/ C IDMTST(3)=588 C IDMTST(4)=112 * IDMTST(3)/ 600/, IDMTST(4)/ 112/, C C IDMTST(7) SPECIFIES THE LENGTH OF THE ARRAYS CONTAINING THE C NUMBER OF CONTINUUM ORBITALS FOR EACH ANGULAR MOMENTUM. C IN /BASIN/ AND /SCOEFF/. ALSO SEE COMMENTS FOR IDMTST(24): C IDMTST(7)=50 * IDMTST(7)/ 60/, C C IDMTST(8) CONTAINS THE SIZE OF THE ARRAY GAMMA IN /FACT/ C IDMTST(8)=32 * IDMTST(8)/ 57/, C C IDMTST(9) SPECIFIES THE LENGTH OF THE ARRAYS CONTAINING THE C NUMBER OF INTEGRATION POINTS IN /ORBOUT/, /ORBTLS/, /YKSTOR/ AND C ALSO IN DIMENSION STATEMENTS IN THE BASFUN PACKAGE. C NOTE THAT THE DIMENSION OF THE ARRAYS IN /BNDORB/ AND C /POTVAL/ ARE DEFINED BY 2*IDMTST(9): C IDMTST(9)=799 * IDMTST(9)/1999/, C C IDMTST(10) GIVES THE LENGTH OF IPOT,CPOT,AND XPOT IN /POTEN/ C IDMTST(10) = 6 * IDMTST(10)/ 6/, C C IDMTST(15) SPECIFIES THE LENGTH OF THE ARRAYS CONTAINING THE C NUMBER OF CONTINUUM ANGULAR MOMENTA IN /BASIN/,/INSTO3/,/INSTO4/, C /ORBTLS/ AND /RADIAL/: C IDMTST(15)=20 * IDMTST(15)/ 49/, C C IDMTST(16) CONTAINS THE DIMENSIONS OF THE ARRAYS CONTAINING THE C NUMBER OF BOUND ANGULAR MOMENTA IN /INSTO3/, /INSTO4/ AND IN THE C ARRAY LVALUE IN SUBROUTINE STG1RD: C IDMTST(16)=5 * IDMTST(16)/ 5/, C C IDMTST(17) CONTAINS THE DIMENSIONS OF THE ARRAYS IHX,IRX WHICH C DEFINE THE INTEGRATION MESH IN /INIT/ C IDMTST(17) = 6 * IDMTST(17)/ 9/, C C IDMTST(18) CONTAINS THE DIMENSIONS OF THE ARRAYS WHICH DEFINE C THE NUMBER OF MULTIPOLES IN THE POTENTIAL. NOTE THAT THE THIRD C DIMENSION OF THE ARRAYS IN /INSTO4/ ARE DEFINED BY IDMTST(18)/2 C IDMTST(18) = 8 * IDMTST(18)/ 8/, C C IDMTST(19) SPECIFIES THE LENGTH OF THE ARRAY ONEST1 IN /INSTO2/ C AND ARRAY RMASS1, ALSO RSPOR1 IN /INSTO6/; AND IDMTST(20-21) FOR C THE CORRESPONDING ARRAYS ENDING IN 2 AND 3 RATHER THAN 1 C (BUT FOR RSPOR1 OR RSPOR2 READ RDAR3): C IDMTST(19)=56 C IDMTST(20)=820 C IDMTST(21)=1275 * IDMTST(19)/ 56/, IDMTST(20)/ 600/, IDMTST(21)/1830/, C C IDMTST(22-23) SPECIFY THE LENGTH OF THE ARRAY UJ C CONTAINING MAXIMUM NUMBER OF FUNCTIONS WHICH CAN BE STORED C AND OF ARRAY IPOS IN /ORBTLS/: C IDMTST(22)=113 C IDMTST(23)=64 * IDMTST(22)/ 128/, IDMTST(23)/ 108/, C C IDMTST(24) CONTAINS THE DIMENSION OF OVRLAP IN /SCOEFF/, AND IS C THE MAXIMUM NUMBER OF BOUND ORBITALS WHICH CAN BE USED IN THE C SCHMIDT PROCEDURE FOR EACH ANGULAR MOMENTUM. NOTE THAT THE C DIMENSIONS OF THE B-MATRIX ARE DEFINED BY IDMTST(7)+IDMTST(24). C NOTE ALSO THAT THE DIMENSION OF TEMP IN /SCOEFF/ IS DEFINED C BY IDMTST(7)+IDMTST(24)+IDMTST(28): C IDMTST(24)=4 * IDMTST(24)/ 4/, C C IDMTST(26-27) SPECIFY THE LENGTH OF NCO C AND OF C, ZE AND IRAD IN /RADIAL/: C IDMTST(26)=30 C IDMTST(27)=300 * IDMTST(26)/ 40/, IDMTST(27)/ 300/, C C IDMTST(28) CONTAINS THE DIMENSION OF THE ARRAYS IN /BNDORB/, AND C IS THE MAXIMUM NUMBER OF BOUND ORBITALS WHICH CAN BE USED IN THE C LAGRANGE ORTHOGONALIZATION FOR EACH ANGULAR MOMENTUM. ALSO C AFFECTS ARRAYS IN /ORBOUT/ AND THE BASFUN PACKAGE. C ALSO SEE COMMENTS FOR IDMTST(24): C IDMTST(28)=6 * IDMTST(28)/ 7/, C C IDMTST(29) CONTAINS THE DIMENSION OF THE ARRAY SKSTO2 IN /JNSTO/: C IDMTST(29)=2400 * IDMTST(29)/50000/, C C IDMTST(30) SPECIFIES THE SIZE OF ARRAYS IN /ORBTLS/ C AND IS THE TOTAL NUMBER OF NUMERICAL BOUND ORBITALS: C IDMTST(30)=15 * IDMTST(30)/ 25/, C C IDMTST(31-32) SPECIFY THE LENGTH OF ARRAY RDAR1 C AND OF RDAR2 IN /INSTO2/ * IDMTST(31)/ 25/, IDMTST(32)/210/, C C IDMTST(33) CONTAINS THE DIMENSION OF ARRAY POTHAM IN /CORE/ C AND REPRESENTS THE NUMBER OF L DEPENDENT MODEL POTENTIALS * IDMTST(33)/4/ C END C*********************************************************************** C SUBROUTINE BUTFIT(IMAX,E,F,RA,EMAX,ALPHA,BETA,NBUT,DELTA) C " REPLACED BY OP-VERSION IN STG1S: NO NBUT-CUTOFF -- WE'90MAR19: C C FITTING OF BUTTLE CORRECTIONS -- M J SEATON, J.PHYS.B20(1987)L69-72. C C IMAX = NUMBER OF POINTS FOR WHICH CORRECTION CALCULATED. C E(I) = ENERGY POINTS C F(I) = BUTTLE CORRECTION C RA = BOUNDARY RADIUS C EMAX = EIGENS(NRANG2,L) C ALPHA, BETA = FIT PARAMETERS, NBUT =... C DELTA = ACCURACY ACHIEVED C C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL POLE DIMENSION E(IMAX),F(IMAX) C C C INITIALISATIONS C D=RA*RA DO 1 I=1,IMAX 1 E(I)=E(I)*D NBUT=.5+RA*SQRT(EMAX)/3.141592654 DELTA=1.E30 ALPHA=1. BETA=0. C C C C START ITERATIONS FOR FIT C DO 1000 KK=1,5 C X11=0. X12=0. X22=0. Y1=0. Y2=0. DELTA0=DELTA DELTA=0. C C START SUM OVER POINTS I C DO 100 I=1,IMAX U=BETA+E(I) C C CALCULATE FUNCTIONS B(U) AND C(U) C B=0. C=0. C CASE OF U.GT.0.04 IF(U.GT..04)THEN FK=SQRT(U) POLE=.FALSE. G=-1.5707963 DO 10 N=0,NBUT G=G+3.141592654 IF(ABS(FK-G).GT..3)THEN A=1./(U-G*G) B=B+A C=C-A*A ELSE POLE=.TRUE. D1=FK-G ENDIF 10 CONTINUE IF(POLE)THEN D2=D1*D1 D=.33333333*D1*(1.+.066666667*D2*(1.+.0952381*D2)) A=1./(2.*FK-D1) BB=(D+A)/FK D=.33333333*(1.+D2*(.2+.031746032*D2)) C=2.*C+.5*(D-A*A-BB)/U B=2.*B+BB ELSE T=TAN(FK) TK=T/FK B=2.*B+TK C=2.*C+.5*(1.+T*T-TK)/U ENDIF C C SUM FOR U.LE..04 ELSE G=-1.5707963 DO 20 N=0,NBUT G=G+3.141592654 A=1./(U-G*G) B=B+A 20 C=C-A*A C C CASE OF U.LT..04 AND U.GT.-.04 IF(U.GT.-.04)THEN B=(.4*U+1.)*U*.33333333+B*2.+1. C=((.48571429*U+.8)*U+1.)*.33333333+C*2. C C CASE OF U.LT.-.04 ELSE FK=SQRT(-U) T=TANH(FK) TK=T/FK B=2.*B+TK C=2.*C+.5*(1.-T*T-TK)/U ENDIF C ENDIF C C INCREMENT MATRICES X AND Y DF=F(I)-ALPHA*B DD=ABS(DF) IF(DELTA.LT.DD)DELTA=DD X11=X11+B*B X12=X12+B*C X22=X22+C*C Y1=Y1+DF*B Y2=Y2+DF*C C 100 CONTINUE C C SOLVE EQUATIONS AND INCREMENT ALPHA AND BETA C C+++ MODIFICATIONS MADE BY MJS, 22.12.86. CJZ X12=ALPHA*X12 DET=1./(X11*X22-X12*X12) CJZ BETA=BETA+DET*(-X12*Y1+X11*Y2) BETA=BETA+DET*(-X12*Y1+X11*Y2)/ALPHA C+++ END MODIFICATIONS ALPHA=(X22*Y1-X12*Y2)*DET+ALPHA C C CHECK CONVERGENCE C IF(DELTA.LT.1.E-4) GO TO 99 C C END ITERATIONS C 1000 CONTINUE NBUT=-NBUT IF(DELTA.GT.DELTA0) NBUT=0 C AS PROCEDURE NOT CONVERGED OR DISTINCTLY DIVERGING - WE'88NOV17. C 99 RETURN END C********************************************************************** SUBROUTINE CALEXO(N,L,NONCON) C C GENERATES A NORMALIZED ORBITAL WHICH IS ORTHOGONAL TO ORBITALS C WITH THE SAME L-VALUE BUT SMALLER N-VALUE C C IMPLICIT REAL*8(A-H,O-Z) COMMON/CPUNCH/NPUNCH,IHOLEH,IHOLEU,KPUNCH,ISTAND,NREAD COMMON/FACT/GAMMA( 57) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNEX( 49),MAXNHF( 49),NCOEFF,NLIMIT,NZ 4 FORMAT(5(I5,F9.5)) 5 FORMAT(12I5) 8 FORMAT(5F14.7) 9 FORMAT(8F9.5) 13 FORMAT(///50H THE VARIABLE NCOEFF IS TOO SMALL - FAIL IN CALEXO/) C M1=NLIMIT*(L-1)+N M2=NCOEFF*(M1-1) M4=N-L C C --- READ IN BASIS FUNCTIONS DEFINING THE ORBITAL C ICLEM=0 IF(NONCON.NE.0) GO TO 6 C ICLEM=1 IMPLIES CLEMENTI COEFFICIENTS READ(IREAD,5) M,ICLEM GO TO 7 6 M=M4+1 7 NCO(M1)=M M21=M2+1 M2M=M2+M IF(M.LE.NCOEFF) GO TO 12 C WRITE(IWRITE,13) STOP 12 IF(ISTAND.EQ.0) GO TO 1 READ(IREAD,5) (IRAD(J),J=M21,M2M) READ(IREAD,8) (ZE(J),J=M21,M2M) GO TO 2 1 READ(IREAD,4) (IRAD(J),ZE(J),J=M21,M2M) 2 MP=M-M4 C C IF THE NUMBER OF BASIS FUNCTIONS EXCEEDS THE NUMBER OF C ORTHONORMALITY CONDITIONS, READ IN COEFFICIENTS OF BASIC FUNCTIONS C IF(MP.EQ.1) GO TO 3 M2P=M2+MP IF(ISTAND.EQ.0) GO TO 10 READ(IREAD,8) (C(J),J=M21,M2P) GO TO 11 10 READ(IREAD,9) (C(J),J=M21,M2P) GO TO 11 3 C(M2+1)=1.0 11 IF(ICLEM.EQ.0) GO TO 15 C TRANSFORM CLEMENTI COEFFICIENTS TO SLATER COEFFICIENTS DO 16 J=M21,M2P IR=IRAD(J) ZR=ZE(J) Z1=ZR+ZR C(J)=C(J)* SQRT(Z1/GAMMA(IR+IR+1))*Z1**IR 16 CONTINUE 15 CALL COEFF(N,L,M,M1,M2,M4,MP) RETURN END C*********************************************************************** SUBROUTINE CALORB C C READS IN AND RENORMALIZES THE HARTREE-FOCK ORBITALS, AND GENERATES C FUNCTIONS FOR MORE EXCITED ORBITALS BY EXTENDING THE ORTHONORMAL SET C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL77= 40+ 300+1) DIMENSION ISTO(LL77),ZESTO(LL77),CSTO(LL77) COMMON/CPUNCH/NPUNCH,IHOLEH,IHOLEU,KPUNCH,ISTAND,NREAD COMMON/NBUG/ IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/FACT/GAMMA( 57) COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNEX( 49),MAXNHF( 49),NCOEFF,NLIMIT,NZ C LTR COMMON/RECOV/ IPLACE,IDMTST(50) 3 FORMAT(12I5) 4 FORMAT(5(I5,F9.5)) 6 FORMAT(8F9.5) 7 FORMAT(5F14.7) 17 FORMAT(///50H THE VARIABLE NCOEFF IS TOO SMALL - FAIL IN CALORB/) C BODY OF ROUTINE COPIED FROM OP SOURCE STG1S -- WE'90MAR19: C C WILL THE NUMBER OF ORTHONORMALITY CONDITIONS DETERMINE THE C NUMBER OF BASIC FUNCTIONS C READ(IREAD,3) NONCON C C HARTREE-FOCK-TYPE ORBITALS. FOR EACH L-VALUE, A COMMON SET OF C BASIS FUNCTIONS IS ASSUMED. IF THIS NOT THE CASE, THESE C ORBITALS MUST BE INPUT AS ADDITIONAL ORBITALS (SEE BELOW) C DO 1 L=1,LRANG1 JI=MAXNHF(L) IF(L.GT.JI) GO TO 1 READ(IREAD,3) M IF(M.LE.NCOEFF) GO TO 16 WRITE(IWRITE,17) STOP 16 IF(ISTAND.EQ.0) GO TO 12 READ(IREAD,3) (ISTO(J),J=1,M) READ(IREAD,7) (ZESTO(J),J=1,M) GO TO 13 12 READ(IREAD,4) (ISTO(J),ZESTO(J),J=1,M) 13 DO 2 N=L,JI IF(ISTAND.EQ.0) GO TO 14 READ(IREAD,7) (CSTO(J),J=1,M) GO TO 15 14 READ(IREAD,6) (CSTO(J),J=1,M) C C --- RENORMALIZATION BEGINS C 15 M1=(L-1)*NLIMIT+N J1=(M1-1)*NCOEFF NCO(M1)=M X=0.0 DO 5 J=1,M IR=ISTO(J) IRAD(J+J1)=IR ZE(J+J1)=ZESTO(J) Y=ZESTO(J)+ZESTO(J) CSTO(J)=CSTO(J)*SQRT(Y/GAMMA(IR+IR+1))*Y**IR 5 X=CSTO(J)*ORNO(J,N,N,L)+X Y=1.0/SQRT(X) DO 9 J=1,M 9 C(J+J1)=CSTO(J)*Y 2 CONTINUE 1 CONTINUE C C --- INPUT ADDITIONAL ORBITALS C DO 10 L=1,LRANG2 NLOWER=MAX(MAXNHF(L)+1,L) NUPPER=MAXNEX(L) IF(NLOWER.GT.NUPPER) GO TO 10 DO 11 N=NLOWER,NUPPER 11 CALL CALEXO(N,L,NONCON) 10 CONTINUE RETURN END C*********************************************************************** SUBROUTINE CHEKTP(ITAPE) C C READS THE PERMANENT STG1 BINARY INPUT OR OUTPUT FILE, ITAPE. C WHEN ITAPE=ITAPE2, THE INPUT FILE IS POSITIONED IN PREPARATION C FOR COPYING INTEGRAL BLOCKS FROM ITAPE2 TO ITAPE3 IN GENINT. C WHEN ITAPE=ITAPE3 A FULL PRINTOUT OF THE CONTENTS OF THE OUTPUT C FILE IS PRODUCED. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL NPRINT PARAMETER (LL53= 5* 5, LL56= 49+ 5, LL59=2*1999) PARAMETER (LL68= 8/2, LL71= 60+1) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXD1/NXD2+NXD2/NXD1) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXD1/MXD2+MXD2/MXD1) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), 1 ICCPOL( 49, 49,LL68) COMMON/INSTO6/RSPOR1( 56),RSPOR2( 600),RSPOR3(1830) COMMON/JNSTO/ SKSTO2(50000),BNORM( 49),JRK8,JBCPOL( 5, 49), * JCCPOL( 49, 49) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) C 1000 FORMAT(//52X,17HSUBROUTINE CHEKTP/52X,17(1H-)) 1001 FORMAT(/24H THE MULTIPOLE INTEGRALS/' CHEKTP IRK8 = ',I5) 1002 FORMAT(/7H IBBPOL) 1003 FORMAT(15I5) 1004 FORMAT(/7H IBCPOL) 1005 FORMAT(/7H ICCPOL) 1006 FORMAT(/(5F14.7)) 1007 FORMAT(/39H THE BOUND-BOUND ONE ELECTRON INTEGRALS) 1008 FORMAT(/43H THE BOUND-CONTINUUM ONE ELECTRON INTEGRALS) 1009 FORMAT(/47H THE CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS) 1010 FORMAT(/29H THE BOUND-BOUND RK INTEGRALS) 1011 FORMAT(/33H THE BOUND-CONTINUUM RK INTEGRALS) 1012 FORMAT(/37H THE CONTINUUM-CONTINUUM RK INTEGRALS) 1013 FORMAT(/3H L=,I2,5H LP=,I2,5X,'IRK2=',I6/) 1015 FORMAT(/3H L=,I2,7H IRK7=,I5) 1016 FORMAT(/29H PRINT THE CONTENTS OF ITAPE3/) 1017 FORMAT(14H TAPE POSITION,I4,17H HAS BEEN REACHED) 1018 FORMAT(/97H THE INPUT ON ITAPE2 MAY BE IN THE FORMAT OF THE 1974 V *ERSION OF STG1 ... IF SO, USE ITAPE2.GE.20/) C C ICOUNT IS A COUNT ON THE INTEGRAL BLOCKS ON TAPE C C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM TAPE, CALL RECOV1 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C ICOUNT=0 IF(ITOTAL.LE.0) RETURN IPLACE=0 IF(ITAPE.EQ.ITAPE3) ICOPY1=ITOTAL+1 C C NPRINT IS .TRUE. IF NO PRINTOUT OF INTEGRALS IS REQUIRED C NPRINT =ITAPE.EQ.ITAPE2 WRITE(IWRITE,1000) IF(.NOT.NPRINT) WRITE(IWRITE,1016) REWIND ITAPE C C READ THE BASIC DATA FROM TAPE C READ(ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,NPOT *,(IRELOP(I),I=1,3) WRITE(IWRITE,7001) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM 7001 FORMAT(' CHEKTP NELC',7I5) IF(LRANG1.GT.IDMTST(16)) WRITE(IWRITE,1018) 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) WRITE(IWRITE,7002) (MAXNHF(L),L=1,LRANG1),(MAXNLG(L),L=1,LRANG1) 7002 FORMAT(' CHEKTP MXNHF,MXNLG'/(10I3)) DO 1 L=1,LRANG2 READ(ITAPE) (EIGENS(N,L),N=1,NRANG2) READ(ITAPE) (ENDS(N,L),N=1,NRANG2+1) WRITE(IWRITE,7003) (EIGENS(N,L),N=1,NRANG2) 1 WRITE(IWRITE,7003) (ENDS(N,L),N=1,NRANG2+1) 7003 FORMAT(' CHEKTP EIGEN:',(T16,1P,5E13.5)) READ(ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX WRITE(IWRITE,7004) RA,BSTO,HINT,DELTA,ETA,NIX 7004 FORMAT(' CHEKTP RA',1P,5E13.6,I5) 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) WRITE(IWRITE,7005) (IHX(I),I=1,NIX),(IRX(I),I=1,NIX),IPTS 7005 FORMAT(' CHEKTP IHX',(T14,10I5)) IPTSM=IPTS-10 READ(ITAPE) (POVALU(I),I=1,IPTS) WRITE(IWRITE,7006) (POVALU(I),I=IPTSM,IPTS) 7006 FORMAT(' CHEKTP POVALU'/(1X,1P,6E13.5)) 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 READ(ITAPE) (P(K,I),I=1,IPTS) 3 WRITE(IWRITE,7007) NBT,K,(P(K,I),I=IPTSM,IPTS) 7007 FORMAT(' CHEKTP NBT,K P',2I5/(1X,1P,6E13.5)) 4 CONTINUE READ(ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) 7 IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ AND PRINT QUANTITIES ASSOCIATED WITH THE MULTIPOLE INTEGRALS C READ(ITAPE) IRK8,JRK8 WRITE(IWRITE,1001) IRK8 IF(IRK8.EQ.0) GO TO 9 IF(IRK8.GT.IDMTST(2)) CALL RECOV1(2,IRK8) LAMIND=(LAMAX+1)/2 READ(ITAPE) (((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) 9 IF(NPRINT) GO TO 16 IF(IRK8.EQ.0) GO TO 16 WRITE(IWRITE,1002) DO 10 K=1,LAMIND DO 10 J=1,LRANG1 10 WRITE(IWRITE,1003) (IBBPOL(I,J,K),I=1,LRANG1) WRITE(IWRITE,1004) DO 12 K=1,LAMIND DO 12 J=1,LRANG2 12 WRITE(IWRITE,1003) (IBCPOL(I,J,K),I=1,LRANG1) WRITE(IWRITE,1005) DO 14 K=1,LAMIND DO 14 J=1,LRANG2 14 WRITE(IWRITE,1003) (ICCPOL(I,J,K),I=1,LRANG2) WRITE(IWRITE,1006) (RKSTO2(I),I=1,IRK8) 16 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ QUANTITIES FOR BUTTLE CORRECTIONS C IF(JRK8.GT.0) *READ(ITAPE) ((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2), + ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2), + (SKSTO2(J),J=1,JRK8),(BNORM(J),J=1,LRANG2) IF(.NOT.NPRINT) WRITE(IWRITE,'(8H JRK8 = ,I6)') JRK8 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ AND PRINT QUANTITIES ASSOCIATED WITH THE BOUND-BOUND ONE C ELECTRON INTEGRALS C WRITE(IWRITE,1007) READ(ITAPE) IRK5 IF(IRK5.GT.IDMTST(19)) CALL RECOV1(19,IRK5) READ(ITAPE) (IST1(I),I=1,LRANG1),(ONEST1(I),I=1,IRK5) IF (IRELOP(1).GT.0) READ(ITAPE) (RMASS1(I),I=1,IRK5) IF (IRELOP(3).GT.0) READ(ITAPE) (RSPOR1(I),I=1,IRK5) IF (IRELOP(2).EQ.0) GO TO 19 READ(ITAPE) IRK9 IF (IRK9.GT.IDMTST(31)) CALL RECOV1(31,IRK9) READ(ITAPE) (RDAR1(I),I=1,IRK9) 19 IF(NPRINT) GO TO 18 WRITE(IWRITE,1003) IRK5 WRITE(IWRITE,1003) (IST1(I),I=1,LRANG1) WRITE(IWRITE,1006) (ONEST1(I),I=1,IRK5) IF (IRELOP(1).GT.0) WRITE(IWRITE,1006) (RMASS1(I),I=1,IRK5) IF (IRELOP(3).GT.0) WRITE(IWRITE,1006) (RSPOR1(I),I=1,IRK5) IF (IRELOP(2).EQ.0) GO TO 18 WRITE(IWRITE,'(/I5,16H DARWIN TERMS 1://(1X,6F13.7))') IRK9, * (RDAR1(I),I=1,IRK9) 18 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ AND PRINT QUANTITIES ASSOCIATED WITH THE BOUND-CONTINUUM C ONE ELECTRON INTEGRALS C WRITE(IWRITE,1008) READ(ITAPE) IRK6 IF(IRK6.GT.IDMTST(20)) CALL RECOV1(20,IRK6) READ(ITAPE) (IST2(I),I=1,LRANG1),(ONEST2(I),I=1,IRK6) IF (IRELOP(1).GT.0) READ(ITAPE) (RMASS2(I),I=1,IRK6) IF(IRELOP(3).GT.0) READ(ITAPE) (RSPOR2(I),I=1,IRK6) IF (IRELOP(2).EQ.0) GO TO 21 READ(ITAPE) IRK10 IF (IRK10.GT.IDMTST(32)) CALL RECOV1(32,IRK10) READ(ITAPE) (RDAR2(I),I=1,IRK10) 21 IF(NPRINT) GO TO 20 WRITE(IWRITE,1003) IRK6 WRITE(IWRITE,1003) (IST2(I),I=1,LRANG1) WRITE(IWRITE,1006) (ONEST2(I),I=1,IRK6) IF (IRELOP(1).GT.0) WRITE(IWRITE,1006) (RMASS2(I),I=1,IRK6) IF (IRELOP(3).GT.0) WRITE(IWRITE,1006) (RSPOR2(I),I=1,IRK6) IF (IRELOP(2).EQ.0) GO TO 20 WRITE(IWRITE,'(/I5,16H DARWIN TERMS 2://(1X,6F13.7))') IRK10, * (RDAR2(I),I=1,IRK10) 20 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ AND PRINT QUANTITIES ASSOCIATED WITH THE CONTINUUM-CONTINUUM C ONE ELECTRON INTEGRALS C WRITE(IWRITE,1009) DO 22 L=1,LRANG2 L1=L-1 READ(ITAPE) IRK7 WRITE(IWRITE,1015) L1,IRK7 IF(IRK7.GT.IDMTST(21)) CALL RECOV1(21,IRK7) READ(ITAPE) (ONEST3(I),I=1,IRK7) IF (IRELOP(1).GT.0) READ(ITAPE) (RMASS3(I),I=1,IRK7) IF (IRELOP(3).GT.0 .AND. L1.NE.0) READ(ITAPE) (RSPOR3(I),I=1,IRK7) IF (IRELOP(2).NE.0 .AND. L1.EQ.0) READ(ITAPE) (RDAR3(I),I=1,IRK7) IF(NPRINT) GO TO 22 WRITE(IWRITE,1006) (ONEST3(I),I=1,IRK7) IF (IRELOP(1).GT.0) WRITE(IWRITE,1006) (RMASS3(I),I=1,IRK7) IF (L1.EQ.0) GO TO 23 IF (IRELOP(3).GT.0) WRITE(IWRITE,1006)(RSPOR3(I),I=1,IRK7) 23 IF (IRELOP(2).EQ.0.OR.L.GT.1) GO TO 22 WRITE(IWRITE,1006) (RDAR3(I),I=1,IRK7) 22 CONTINUE WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ AND PRINT QUANTITIES ASSOCIATED WITH THE BOUND-BOUND RK C INTEGRALS C WRITE(IWRITE,1010) READ (ITAPE) IRK1,IRK4 IF(IRK1.GT.IDMTST(1)) CALL RECOV1(1,IRK1) IF(IRK4.GT.IDMTST(4)) CALL RECOV1(4,IRK4) I1=LRANG1*LRANG1 READ (ITAPE) (((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) IF(NPRINT) GO TO 24 WRITE(IWRITE,1003) IRK1,IRK4 WRITE(IWRITE,1003)(((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), 1 (ISTBB1(I),I=1,IRK4),(ISTBB2(I),I=1,IRK4) WRITE(IWRITE,1006) (RKSTO1(I),I=1,IRK1) 24 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 IF(ITAPE.EQ.ITAPE3) THEN IREC=1 JDISC=JDISC1 ELSE IREC=0 JDISC=JDISC2 ENDIF C C READ AND PRINT QUANTITIES ASSOCIATED WITH BOUND-CONTINUUM RK C INTEGRALS C IF(LRANG2.EQ.0) GO TO 35 WRITE(IWRITE,1011) READ(ITAPE) IRK2,IRK3 IF(IRK2.GT.IDMTST(2)) CALL RECOV1(2,IRK2) IF(IRK3.GT.IDMTST(3)) CALL RECOV1(3,IRK3) I1=MIN(LRANG1*LRANG2,LRANG1*((LRANG1-1)*3+1)) READ (ITAPE) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), 1 (ISTBC1(I),I=1,IRK3),(ISTBC2(I),I=1,IRK3) CALL DA2('RK',1,IREC,JDISC,IRK2,RKSTO2) IF(NPRINT) GO TO 26 WRITE(IWRITE,1003) IRK2,IRK3 WRITE(IWRITE,1003)(((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), 1 (ISTBC1(I),I=1,IRK3),(ISTBC2(I),I=1,IRK3) WRITE(IWRITE,1006) (RKSTO2(I),I=1,IRK2) 26 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 27 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 C C READ AND PRINT QUANTITIES ASSOCIATED WITH THE CONTINUUM- C CONTINUUM RK INTEGRALS C WRITE(IWRITE,1012) 29 READ(ITAPE) JRK2,L,LP IRK2=ABS(JRK2) WRITE(IWRITE,1013) L,LP, IRK2 IF(IRK2.EQ.0) GO TO 31 IF(IRK2.GT.IDMTST(2)) CALL RECOV1(2,IRK2) I1=MIN(2*LRANG1-1,L+LP+1) I2=MIN(LRANG1+L,LRANG1+LP) IF(JRK2.GT.0) *READ (ITAPE) (((ICTCCD(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), 1 (((ICTCCE(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I2) CALL DA2('RK',1,IREC,JDISC,IRK2,RKSTO2) IF(NPRINT) GO TO 31 IF(JRK2.GT.0) *WRITE(IWRITE,1003)(((ICTCCD(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1) 1 ,(((ICTCCE(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I2) WRITE(IWRITE,'(/(20(1X,6F13.8/)))') (RKSTO2(I),I=1,IRK2) 31 WRITE(IWRITE,1017) ICOUNT IF(ICOUNT.GE.ICOPY1-1) GO TO 35 IF(ICOUNT.GE.ITOTAL) GO TO 35 ICOUNT=ICOUNT+1 IF(JRK2) 29,34,33 33 IF(LP.LT.LRANG2-1) GO TO 29 34 IF( L.LT.LRANG2-1) GO TO 29 C 35 IF(ITAPE.EQ.ITAPE3) REWIND ITAPE RETURN END C*********************************************************************** SUBROUTINE CIV3 C C READS ORBITAL DATA FROM CHANNEL INDATA IN CIV3 FORMAT C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 MINUS COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CPUNCH/NPUNCH,IHOLEH,IHOLEU,KPUNCH,ISTAND,NREAD COMMON/INFORM/ IREAD,IWRITE,JPUNCH COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNEX( 49),MAXNHF( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) DIMENSION ZETA( 49),NOCCSH(200),NOCORB(15),NELCSH(15) C 1 FORMAT(14I5) 22 FORMAT(5F14.7) 37 FORMAT(18A4) 1001 FORMAT(12I5) 1002 FORMAT(24I3) C C READ IN BASIC PARAMETERS DEFINING USE OF PROGRAM C READ(IREAD,1) IVYEXP,IHYPF,IOSCI,IXTEND,IPARTN,ISUBD,ISO,IFNCTN, 1 NPUNCH,ISTAND,KPUNCH,IDTAIL,NREAD,ICSTAS,ITENPR,IPUNCH C WRITE(IWRITE,11) IVYEXP,IHYPF,IOSCI,IXTEND,IPARTN,ISUBD,ISO, C 1 IFNCTN,NPUNCH,ISTAND,KPUNCH,IDTAIL,NREAD,ICSTAS,ITENPR,IPUNCH IF(ISO.EQ.0) GO TO 61 READ(IREAD,1) NOZS C WRITE(IWRITE,62) NOZS 61 IF(IDTAIL.EQ.0) GO TO 85 READ(IREAD,1) NFNGO,NFNEND C WRITE(IWRITE,12) NFNGO,NFNEND GO TO 82 85 NFNGO=-1 NFNEND=-1 IF(ITENPR.EQ.0) GO TO 82 READ(IREAD,1) ISPORB,ISCORB,ISPSPN,IMASS,IDAR,ICM1 C WRITE(IWRITE,1013) ISPORB,ISCORB,ISPSPN,IMASS,IDAR,ICM1 C C READ IN DEBUG PARAMETERS C 82 READ(IREAD,1) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, 1 IBUG9,ISTCFG C WRITE(IWRITE,24) IBUG1,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 IF(IHYPF.EQ.0.AND.IOSCI.EQ.0.AND.ITENPR.EQ.0) GO TO 79 READ(IREAD,1) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9,IWFN C WRITE(IWRITE,78) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, C 1 NBUG9,IWFN C 79 READ(IREAD,1) LRANG1,LRANG2,NCOEFF,NZ C WRITE(IWRITE,13) LRANG1,LRANG2,NCOEFF,NZ C READ(IREAD,1) (MAXNHF(I),I=1,LRANG1) C WRITE(IWRITE,28) (MAXNHF(I),I=1,LRANG1) C C (MAXNHF(L)=L-1),L=LRANG1+1,LRANG2 -- IN STG1RD READ(IREAD,1) (MAXNEX(I),I=1,LRANG2) C WRITE(IWRITE,14) (MAXNEX(I),I=1,LRANG2) NLIMIT=0 DO 32 L=1,LRANG2 MAXN=MAXNEX(L) IF(NLIMIT.GE.MAXN) GO TO 32 NLIMIT=MAXN 32 CONTINUE C C --- READ IN RADIAL FUNCTIONS C C WRITE(IWRITE,9) CALL CALORB C IF(ISPORB.NE.2) GO TO 21 READ(IREAD,22) (ZETA(I),I=1,LRANG2) C WRITE(IWRITE,23) (ZETA(I),I=1,LRANG2) C C READ CONFIGURATION DATA TO FIND NUMBER OF ELECTRONS C 21 IF(ISTAND.EQ.0) GO TO 25 READ(IREAD,1001) NCFG READ(IREAD,1001) (NOCCSH(I),I=1,NCFG) N=NOCCSH(1) READ(IREAD,1001) (NOCORB(J),J=1,N) READ(IREAD,1001) (NELCSH(J),J=1,N) GO TO 26 25 READ(IREAD,1002) NCFG READ(IREAD,1002) (NOCCSH(I),I=1,NCFG) N=NOCCSH(1) READ(IREAD,1002) (NOCORB(J),J=1,N) READ(IREAD,1002) (NELCSH(J),J=1,N) 26 NELC=0 DO 27 J=1,N 27 NELC=NELC+NELCSH(J) C DO 99 I=1,999 READ(IREAD,1003,END=100) MINUS 1003 FORMAT(A4) IF(MINUS.EQ.'----')RETURN 99 CONTINUE 100 RETURN END C*********************************************************************** SUBROUTINE COEFF(N,L,M,M1,M2,M4,MP) C C DETERMINES THE COEFFICIENTS OF THE BASIS FUNCTIONS OF THE (N,L-1) C =EXCITED= ORBITAL FROM ORTHONORMALITY CONDITIONS C M4 = NUMBER OF ORTHOGONALITY CONDITIONS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (NSIMEQ=8,NQSQ=NSIMEQ*NSIMEQ) DIMENSION A(NQSQ),B(NSIMEQ) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNEX( 49),MAXNHF( 49),NCOEFF,NLIMIT,NZ 2 FORMAT(/78H PROGRAM HALTED IN COEFF BECAUSE NUMBER OF SIMULTANEOUS * EQUATIONS IS TOO LARGE/' INCREASE THE VALUE OF PARAMETER NSIMEQ') IF(M4.GT.NSIMEQ) GO TO 1 IF(M4-1) 14,15,16 C C --- MORE THAN ONE ORTHOGONALITY CONDITIONS RESULTS IN SOLUTION OF C SIMULTANEOUS EQUATIONS USING MA01A -- NO CHECK FOR L92 YET! C 16 DO 8 K=1,M4 KL1=K+L-1 DO 19 J=1,M4 KK=NSIMEQ*(J-1)+K 19 A(KK)=ORNO(J+MP,KL1,N,L) X=0.0 DO 10 J=1,MP 10 X=X+ORNO(J,KL1,N,L)*C(M2+J) 8 B(K)=-X CALL MA01A(A,B,M4,1,0,NSIMEQ,1) M3=M2+MP DO 11 J=1,M4 11 C(J+M3)=B(J) GO TO 14 C C --- ONLY ONE ORTHOGONALITY CONDITION, THEREFORE ONLY ONE EQUATION C TO BE SOLVED C 15 X=0.0 DO 17 J=1,MP 17 X=X+C(M2+J)*ORNO(J,L,N,L) C(M2+M)=-X/ORNO(M,L,N,L) C C --- DETERMINATION OF OVER-ALL NORMALIZATION FACTOR C 14 X=0.0 DO 12 J=1,M 12 X=X+C(M2+J)*ORNO(J,N,N,L) Y=1.0/SQRT(X) DO 18 J=1,M 18 C(J+M2)=Y*C(J+M2) RETURN 1 WRITE(IWRITE,2) STOP END C*********************************************************************** C SUBROUTINE CORECT(N,LP,R0,SIGMA,C1) C C CALCULATES THE PARAMETERS ASSOCIATED WITH THE GAUSSIAN C CORRECTION TO BE APPLIED TO THE BOUND ORBITAL SPECIFIED BY THE C QUANTUM NUMBERS (N,LP-1). C CORRECTION TO ORBITAL AT RADIUS R IS -C1*EXP(-((R-R0)/SIGMA)**2). C C IMPLICIT REAL*8(A-H,O-Z) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ PARAMETER (S=2.) C C DEFINITION OF S - THE GAUSSIAN IS REQUIRED TO FALL TO EXP(-S**2) C OF ITS MAXIMUM VALUE BY R=0.9*RA. C M1=NLIMIT*(LP-1)+N J1=(M1-1)*NCOEFF+1 M=NCO(M1)+J1-1 C C CALCULATE THE FUNCTION AND ITS DERIVATIVE AT R=RA. C PA=0.0 DP=0.0 DO 1 J=J1,M TERM=C(J)*RA**IRAD(J)*EXP(-ZE(J)*RA) PA=TERM+PA 1 DP=(IRAD(J)/RA-ZE(J))*TERM+DP C C FIND PARAMETERS SIGMA, R0, C1 FROM THE LOGARITHMIC DERIVATIVE B C B=RA*DP/PA SIGMA=RA*(S-SQRT(S*S-B*0.2))/B R0=S*SIGMA+RA*0.9 C1=PA*EXP(((RA-R0)/SIGMA)**2) RETURN END C*********************************************************************** SUBROUTINE DA2(NAMD,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 NAMD*6,STA*3 PARAMETER (LREC=512, A0=1.,A1=1.E-9) DIMENSION ARRAY(LENGTH) C IF(IREC.GT.0) GO TO 10 LWORD=4 S=A0+A1 IF(S.NE.A0) LWORD=8 IRECL=LWORD*LREC STA='OLD' IF(KEY.EQ.2) STA='NEW' * OPEN(JDISC,STATUS=STA,FILE='RK',ACCESS='DIRECT',RECL=) -- 01Apr04: OPEN(JDISC,STATUS='UNKNOWN',FILE=NAMD,ACCESS='DIRECT',RECL=IRECL) IREC=1 C 10 IF(LENGTH.EQ.0) GO TO 90 I2=0 20 I1=I2+1 I2=MIN(I2+LREC,LENGTH) IF(KEY-1) 50,40,30 30 WRITE(JDISC,REC=IREC) (ARRAY(I),I=I1,I2) GO TO 50 40 READ(JDISC,REC=IREC) (ARRAY(I),I=I1,I2) 50 IREC=IREC+1 IF(I2.LT.LENGTH) GO TO 20 90 RETURN END C*********************************************************************** SUBROUTINE DERINT(N11,L11,N12,L12,RESULT) C C EVALUATES THE RADIAL INTEGRAL OF THE GRADIENT OPERATOR BETWEEN C TWO ORBITALS SPECIFIED BY THE QUANTUM NUMBERS (N11,L11-1) AND C (N12,L12-1), AND STORES THE INTEGRAL IN RESULT. C WHEN ONE OR BOTH ORBITALS ARE BOUND THEN ANALYTIC C DIFFERENTIATION OF THE BOUND ORBITAL IS USED. C SEE COMMENTS IN EVALUE AND CORECT FOR DETAILS OF THE C CORRECTION APPLIED TO THE BOUND ORBITALS. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (GSMAX=12.0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS COMMON/YKSTOR/ Y(1999),RK(1999),RI(1999),JN2,JL2,JN4,JL4,JKM C JN2=0 N2 = N12 L2 = L12 K2 = IPOS(N2,L2) MAXHF2=L2-1 IF(L2.LE.LRANG1) MAXHF2=MAXNHF(L2) N1 = N11 IF(N1.LE.0) GO TO 1 L1 = L11 MAXHF1=L1-1 IF(L1.LE.LRANG1) MAXHF1=MAXNHF(L1) ALF=-L2 IF(L1.EQ.L2-1) ALF=L1 C C FIND IF ONE ORBITAL IS BOUND. IF SO PUT IT INTO THE SECOND C POSITION SO THAT THE ORBITAL DEFINED BY (N2,L2) IS BOUND. C RESULT = 0.0 SUM = 0. SIGN=1.0 IF(N2.LE.MAXHF2) GO TO 2 IF(N1.GT.MAXHF1) GO TO 10 N2=N11 L2=L11 K2 = IPOS(N2,L2) N1=N12 L1=L12 SIGN=-1.0 1 IF(N2.GT.MAXHF2) GO TO 10 2 IF(NCOEFF.EQ.0) GO TO 5 C C ANALYTIC FIRST DERIVATIVE OF STO'S C CALL CORECT(N2,L2,R0,SIGMA,C1) M=(L2-1)*NLIMIT+N2 M1=(M-1)*NCOEFF+1 M2=NCO(M)+M1-1 DO 4 I=2,NPTS R=XR(I) C DETERMINE THE CONTRIBUTION FROM THE ALPHA/R PV=0.0 ALPHA=(R-R0)/SIGMA IF(-ALPHA.LT.GSMAX) PV=(2.0*ALPHA/SIGMA)*C1*EXP(-ALPHA*ALPHA) C DETERMINE THE CONTIBUTION INVOLVING THE FIRST DERIVATIVE C ACTING ON THE BOUND ORBITAL DO 3 J=M1,M2 3 PV=(IRAD(J)/R-ZE(J))*EXP(-ZE(J)*R)*R**IRAD(J)*C(J) + PV 4 Y(I)=PV GO TO 8 C C OTHERWISE CALCULATE FIRST DERIVATIVE FROM FUNCTION AND C SECOND DERIVATIVE AT TWO ADJACENT POINTS C 5 ALL2=((L2-1)*L2) ANZ=2*NZ HP=XR(2) DR2=(ALL2/XR(2)-ANZ)/XR(2)*UJ(2,K2)-DUJ(2,K2) DR3=(ALL2/XR(3)-ANZ)/XR(3)*UJ(3,K2)-DUJ(3,K2) C COR Y(2)=(UJ(3,K2)-UJ(2,K2))/HP-(DR2+DR2+DR3)*H/SIX -MLD'95FEB15: H=HP Y(2)=(UJ(3,K2)-UJ(2,K2))/HP-(DR2+DR2+DR3)*HP/6.0 DO 7 I=3,NPTS H=HP DR1=DR2 DR2=DR3 IF(I.EQ.NPTS) GO TO 6 DR3=(ALL2/XR(I+1)-ANZ)/XR(I+1)*UJ(I+1,K2)-DUJ(I+1,K2) HP=XR(I+1)-XR(I) IF(HP.GT.H*1.01) GO TO 6 Y(I)=((UJ(I+1,K2)-UJ(I-1,K2))/H+(DR1-DR3)*H/6.0)*0.5 GO TO 7 6 Y(I)=(UJ(I,K2)-UJ(I-1,K2))/H+(DR2+DR2+DR1)*H/6.0 7 CONTINUE C NXT Y(2)= (L2-(L2+1)*NZ*XR(2)/L2)*UJ(1,K2)*XR(2)**(L2-1) GO TO 8 C C BOTH ORBITALS ARE CONTINUUM ORBITALS: LAGRANGE DIFFERENTIATION C C 10 K1 = IPOS(N1,L1) --- MOVED DOWN, CM-COR RUB'96FEB19 10 DO 19 M=2,NPTS-1 M1=MAX(M-3,1) M2=MIN(M+3,NPTS) C NOT M1=M2-6 PV=0. HP=0. DO 18 I=M1,M2 IF(I.NE.1) HP=UJ(I,K2) IF(I.NE.M) GO TO 16 H=0. DO 15 J=M1,M2 IF(J.EQ.M) GO TO 15 H=1./(XR(M)-XR(J))+H 15 CONTINUE GO TO 18 16 H=1./(XR(I)-XR(M)) DO 17 J=M1,M2 IF(J.EQ.I) GO TO 17 IF(J.EQ.M) GO TO 17 H=(XR(M)-XR(J))*H/(XR(I)-XR(J)) 17 CONTINUE 18 PV=HP*H+PV 19 Y(M)=PV Y(NPTS)=UJ(NPTS,K2)*BSTO C C COMPUTE DIPOLE VELOCITY INTEGRAL USING SIMPSONS RULE C 8 IF (N1.GT.0) THEN K1 = IPOS(N1,L1) DO 9 I=2,NPTS 9 SUM=(UJ(I,K2)*ALF/XR(I)+SIGN*Y(I))*UJ(I,K1)*WT(I)+SUM RESULT = SUM C ELSE Y(1)=0. IF(L2.EQ.1) Y(1)=UJ(1,K2) ENDIF C RETURN END C*********************************************************************** SUBROUTINE EVAL(LP) C C **** A MODIFICATION TO EVALUE FOR NUMERICAL ORBITALS C C INTERPOLATES THE NUMERICAL FUNCTIONS STORED FOR A GIVEN VALUE OF C THE ANGULAR MOMENTUM (LP-1) IN THE UJ-ARRAY C THE FIRST MAXNLG(LP)-LP+1 ORBITALS ARE REQUIRED AT HALF-MESH C POINTS IN THE P-ARRAY: INTERPOLATION USES THE FUNCTION C AND SECOND DERIVATIVE AT TWO ADJACENT POINTS. C NQ IS A COUNT ON THE ORBITALS STORED. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999) COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS C C MAXLG=MAXNLG(LP) IF(MAXLG.LT.LP) GO TO 9 KT=0 ALL2=(LP-1)*LP ANZ = 2*NZ C C LOOP OVER THE BOUND ORBITALS FOR LAGRANGE ORTHOGONALIZATION C FOR THE GIVEN ANGULAR MOMENTUM C DO 8 N=LP,MAXLG N1=IPOS(N,LP) KT=KT+1 C C INTERPOLATE THE BOUND ORBITAL AT THE HALF-MESH POINTS C Y=0.0 DR1=0.0 DO 5 K=2,NPTS R=XR(K) DR2=((ALL2/R-ANZ)/R)*UJ(K,N1)-DUJ(K,N1) H=(R-XR(K-1))*0.25 P(KT,2*K-3)=(UJ(K,N1)+Y)*0.5-(DR2+DR1)*H*H Y=UJ(K,N1) P(KT,2*K-2)=Y 5 DR1=DR2 8 CONTINUE 9 RETURN END C*********************************************************************** SUBROUTINE EVALUE(LP,NQ) C C EVALUATES AND STORES ALL THE BOUND-ORBITAL FUNCTIONS P AND Q FOR C A GIVEN VALUE OF THE ANGULAR MOMENTUM LP-1 IN THE ARRAYS UJ,DUJ. C IN THE P-ARRAY THE FIRST MAXNLG(LP)-LP+1 ORBITALS ARE ALSO STORED C AT THE MIDPOINTS; RACOR IS USED IN BASORB FOR MAGNITUDE PRINTOUT. C NQ IS A COUNT ON THE ORBITALS STORED. C C A GAUSSIAN CORRECTION FROM CORECT IS SUBTRACTED FROM EACH BOUND C ORBITAL TO GIVE CORRECT BOUNDARY CONDITIONS. C THE ORBITAL IS THEN RENORMALIZED BY AMENDING THE ARRAYS, C AND THE SLATER COEFFICIENT ARRAY, C IN /RADIAL/ C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999, GSMAX=12.0) COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS C 1000 FORMAT(/25H BOUND ORBITALS CORRECTED) 1001 FORMAT(4H N =,I2,6H R0 =,F9.5,9H SIGMA =,E12.5,6H C1 =,E12.5, 1 6H AN =,F9.5) C MAXHF = MAXNHF(LP) IF(MAXHF.LT.LP) GO TO 5 MAXLG = MAXNLG(LP) IF(NBUG5.EQ.1) WRITE(IWRITE,1000) ALSQ=(LP-1)*LP ZN = (NZ+NZ) KT = 0 C C LOOP OVER ALL THE BOUND ORBITALS FOR THE GIVEN ANGULAR MOMENTUM C DO 9 N=LP,MAXHF CALL CORECT(N,LP,R0,SIGMA,C1) KT = KT+1 NQ = NQ+1 IPOS(N,LP) = NQ M1=(LP-1)*NLIMIT+N J1=(M1-1)*NCOEFF+1 M=NCO(M1)+J1-1 C C EVALUATE THE BOUND ORBITAL P, AND Q, FOR ALL VALUES OF THE RADIUS C DO 6 I=2,NPTS R=XR(I) J=2*I-2 C DETERMINE THE CONTRIBUTION INVOLVING THE SECOND DERIVATIVE C ACTING ON THE BOUND-ORBITAL PW=0.0 H=(R0-R)/SIGMA IF(H.LT.GSMAX) PW=(1.0-2.0*H*H)*(2.0/(SIGMA*SIGMA))*C1*EXP(-H*H) DO 1 K=J1,M IR=IRAD(K) ZEX=-ZE(K)*R 1 PW=((IR-1)*IR+(IR*2+ZEX)*ZEX) * EXP(ZEX)*R**(IR-2) * C(K) + PW 2 PV=0.0 H=(R-R0)/SIGMA IF(-H.LT.GSMAX) PV=-C1*EXP(-H*H) AN=PV DO 3 K=J1,M 3 PV=C(K)*R**IRAD(K)*EXP(-ZE(K)*R)+PV C CHECK WHETHER THE ORBITAL IS REQUIRED AT THE MIDPOINTS, C STORE IN THE UJ ARRAY AND IN THE P-ARRAY AS APPROPRIATE IF(N.GT.MAXLG) GO TO 4 P(KT,J) = PV IF(MOD(J,2).NE.0) GO TO 6 4 UJ(I,NQ)=PV OLDEND=AN C ADD THE ANGULAR MOMENTUM AND NUCLEAR CHARGE TERMS TO SECOND C DERIVATIVE, STORE Q FUNCTION IN DUJ ARRAY H=1.0/R DUJ(I,NQ) = (ALSQ*H-ZN)*H*PV - PW J=J-1 R=(XR(I-1)+R)*0.5 IF(N.LE.MAXLG) GO TO 2 6 CONTINUE C C RENORMALIZE THE ORBITAL C CALL ABNORM(N,LP,N,LP,H) AN=1.0/SQRT(H) PV=0.0 PW=0.0 H=0.0 DO 8 J=J1,M C(J)=C(J)*AN IF(IRAD(J).EQ.LP) PV=C(J)+PV IF(LP.NE.1) GO TO 8 IF(IRAD(J).EQ.1) PW=C(J)*ZE(J)+PW IF(IRAD(J).EQ.2) H = C(J) + H 8 CONTINUE UJ(1,NQ)=PV DUJ(1,NQ)=(H-PW)*2.0 C HOLDING SLOPE OF 2ND DERIVATIVE, AS QBAR IS INFINITE FOR STO'S. IF(NBUG5.EQ.1) WRITE(IWRITE,1001) N,R0,SIGMA,C1,AN DO 7 I=2,NPTS DUJ(I,NQ)=DUJ(I,NQ)*AN IF(N.GT.MAXLG) GO TO 7 P(KT,I-1)=P(KT,I-1)*AN P(KT,I+NPTS-2)=P(KT,I+NPTS-2)*AN 7 UJ(I,NQ)=UJ(I,NQ)*AN 9 RACOR(NQ)=OLDEND*AN C 5 RETURN END C*********************************************************************** SUBROUTINE FINDER(NBT,LC,NODES,RESTAR,ETRIAL) C ADAPTATION TO WORK WITH OP VERSION OF RMATRX CODE - WE'88NOV25. C SUBROUTINE FINDER(NBT,LC,NODES,RESTAR,ETRIAL) * A NEW FINDER ROUTINE WRITTEN AT MUENSTER...AUGUST 1983 * NBT..... THE NUMBER OF BOUND ORBITALS TO ORTHOGONALISE TO. * LC ..... THE L VALUE. * NODES... THE REQUIRED NUMBER OF NODES IN THE EIGENFUNCTION. * RESTAR.. LOGICAL VARIABLE - IF TRUE THEN THIS IS A RESTART RUN. * (DISABLED) - IF FALSE THIS IS NOT A RESTART RUN. * ETRIAL.. INITIAL ESTIMATE OF THE EIGENENERGY. C IMPLICIT REAL*8(A-H,O-Z) LOGICAL RESTAR PARAMETER (THREE=3.0,PI=3.14159, * ERROR=1.0E-6) PARAMETER (LL90= 7+1) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBOUT/ORB(1999),DORB(1999),EIGEN,ALAMDA(LL90),BVALUE * * FORMAT STATEMENTS * 100 FORMAT(/' DEBUG FROM NEW FINDER'/3X,21(1H=)) 101 FORMAT(' NODE=',I2,' NODES=',I3,' BVALUE=',1P,E11.4, * ' EIGEN=',E13.6,' ETRIAL=',E13.6) 102 FORMAT(' STOP IN NEW FINDER.......CANNOT FIND THE CORRECT NUMBER * OF NODES') 103 FORMAT(' ERROR IN ROOT...IFLAG =',I6) 104 FORMAT(' ERROR IN NEW FINDER...BASFUN ITERATION ENTERED BUT INCOR *RECT NUMBER OF NODES FOUND') * * INITIALISE VARIABLES. * IF (NBUG4.GT.0) WRITE(IWRITE,100) DEL=PI/RA DEL2=DEL*DEL DELL=DEL ISUM=0 10 CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,0.0,0.0) IF (NBUG4.GT.0) WRITE(IWRITE,101) NODE,NODES,BVALUE,EIGEN,ETRIAL * * FIRST CHECK WHETHER THIS IS A RESTART RUN * C IF (RESTAR) GO TO 99 * * CHECK THAT THE FUNCTION HAS THE CORRECT NUMBER OF NODES. * IF (NODE.NE.NODES) THEN * * FUNCTION HAS NOT THE CORRECT NUMBER OF NODES, MODIFY ENERGY * ACCORDINGLY. * IF (ISUM.GT.0) THEN IF (NODE-NODES.EQ.NHOLD) THEN DELL=DELL*0.5 DEL2=DEL2*0.5 ETRIAL=EHOLD ELSE NHOLD=NODES-NODE ENDIF ELSE NHOLD=NODES-NODE ENDIF EHOLD=ETRIAL ISUM = ABS(NODES-NODE)+ISUM REALNN = NODES-NODE IF (ETRIAL.LT.0.0 .OR. SQRT(ABS(ETRIAL))+REALNN*DELL.LT.0.0) * THEN ETRIAL = ETRIAL+ABS(REALNN)*REALNN*DEL2 ELSE ETRIAL=(REAL(NODES-NODE)*DELL+SQRT(ABS(ETRIAL)))**2 ENDIF IF (ISUM.GE.100) THEN WRITE(IWRITE,102) GO TO 98 ELSE GOTO 10 ENDIF ELSE * * FUNCTION HAS THE CORRECT NUMBER OF NODES. * IF (BVALUE.LT.BSTO) THEN * * WE HAVE AN UPPER BOUND TO THE ENERGY,NOW FIND LOWER BOUND. * EHIGH=ETRIAL BLOW=BVALUE DEL1=DEL/THREE DEL2=DEL2/THREE EHOLD=ETRIAL 20 IF (ETRIAL.LT.0.0 .OR. SQRT(ABS(ETRIAL))-DEL1.LT.0.0) THEN ETRIAL=ETRIAL-DEL2 ELSE ETRIAL = (SQRT(ABS(ETRIAL))-DEL1)**2 ENDIF CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,0.0,0.0) IF (NBUG4.GT.0) * WRITE(IWRITE,101) NODE,NODES,BVALUE,EIGEN,ETRIAL IF (NODE.NE.NODES) THEN * * ENERGY DECREASED TOO FAR, DECREASE INCREMENT * DEL1=DEL1/THREE DEL2=DEL2/THREE ETRIAL=EHOLD GOTO 20 ELSE IF (BVALUE.LT.BSTO) THEN * * BETTER UPPER BOUND TO THE ENERGY FOUND, TRY AGAIN * FOR A LOWER BOUND. * EHIGH=ETRIAL BLOW=BVALUE EHOLD=ETRIAL GOTO 20 ELSE * * LOWER BOUND TO THE ENERGY NOW FOUND. * ELOW=ETRIAL BHIGH=BVALUE ENDIF ENDIF ELSE * * LOWER BOUND TO THE ENERGY FOUND,NOW TRY FOR AN UPPER BOUND. * ELOW=ETRIAL BHIGH=BVALUE DEL1=DEL/THREE DEL2=DEL2/THREE EHOLD=ETRIAL 30 IF (ETRIAL.LT.0.0) THEN ETRIAL=ETRIAL+DEL2 ELSE ETRIAL = (SQRT(ABS(ETRIAL))+DEL1)**2 ENDIF CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,0.0,0.0) IF (NBUG4.GT.0) * WRITE(IWRITE,101) NODE,NODES,BVALUE,EIGEN,ETRIAL IF (NODE.NE.NODES) THEN * * ENERGY INCREASED TOO FAR, DECREASE INCREMENT. * DEL1=DEL1/THREE DEL2=DEL2/THREE ETRIAL=EHOLD GOTO 30 ELSE IF (BVALUE.GE.BSTO) THEN * * BETTER LOWER BOUND TO THE ENERGY FOUND, TRY AGAIN * FOR THE UPPER BOUND. * ELOW=ETRIAL BHIGH=BVALUE EHOLD=ETRIAL ISUM = ISUM+1 ! Claudio's dead loop 2002 Jan/Feb16 IF(ISUM.GT.50) THEN WRITE(IWRITE,"(/' FINDER: slope stays too high')") STOP " in FINDER: BSTO failure" ENDIF GOTO 30 ELSE * * UPPER BOUND TO THE ENERGY FOUND. * EHIGH=ETRIAL BLOW=BVALUE ENDIF ENDIF ENDIF ENDIF * * WE NOW HAVE UPPER AND LOWER BOUNDS TO THE EIGENENERGY, * NOW USE ROOT FINDING ROUTINE TO GET A BETTER ESTIMATE. * IFLAG=1 ABSERR=0.0 RELERR=ERROR*0.1 B=ELOW C=EHIGH IF(ETRIAL.EQ.ELOW) THEN FT=BHIGH-BSTO ELSE FT=BLOW-BSTO ENDIF 40 CALL ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG) IF (IFLAG.LT.0) THEN * * STILL NOT CLOSE ENOUGH TO THE ROOT * IF (T.EQ.ELOW) THEN FT=BHIGH-BSTO GOTO 40 ELSE IF (T.EQ.EHIGH) THEN FT=BLOW-BSTO GOTO 40 ELSE ETRIAL=T CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,0.0,0.0) IF (NBUG4.GT.0) * WRITE(IWRITE,101) NODE,NODES,BVALUE,EIGEN,ETRIAL FT=BVALUE-BSTO * * IF ABS(FT) IS LESS THAN ERROR..SOLUTION FOUND * IF (ABS(FT).LT.ERROR) GO TO 50 GO TO 40 ENDIF ELSE IF (IFLAG.GT.1) THEN * * ERROR IN ROOT * WRITE(IWRITE,103) IFLAG GO TO 98 ELSE * * IFLAG=1...ROOT SUCESSFULLY LOCATED TO REQUIRED ACCURACY * ETRIAL=B CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,0.0,0.0) IF (NBUG4.GT.0) * WRITE(IWRITE,101) NODE,NODES,BVALUE,EIGEN,ETRIAL GOTO 50 ENDIF 50 IF (NODE.EQ.NODES) GO TO 99 * * ALL IS WELL...EIGENVALUE FOUND WITH CORRECT NUMBER * OF NODES. * * INCORRECT NUMBER OF NODES.....GIVE UP * WRITE(IWRITE,104) 98 STOP 99 RETURN END C*********************************************************************** SUBROUTINE GEN1BB C C GENERATES AND STORES ALL THE BOUND-BOUND ONE ELECTRON INTEGRALS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! LL55=min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO6/RSPOR1( 56),RSPOR2( 600),RSPOR3(1830) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) C IRK5=0 IRK9=0 DO 6 L1=1,LRANG1 IST1(L1)=0 MAXHF = MAXNHF(L1) C C THERE IS NO VALENCE ORBITAL WITH THIS ANGULAR MOMENTUM C N1=MAXNC(L1) IF(N1.EQ.MAXHF) GO TO 6 IST1(L1)=IRK5+1 C C SET THE PRINCIPAL QUANTUM NUMBERS. C 5 N1=N1+1 IF(N1.GT.MAXHF) GO TO 6 N2=MAXNC(L1) 2 N2=N2+1 IRK5=IRK5+1 IF (IRELOP(2).NE.0 .AND. L1.EQ.1) IRK9=IRK9+1 IF (IRK9.GT.IDMTST(31).OR.IRK5.GT.IDMTST(19)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 4 3 CALL ONEELE(N1,L1,N2,L1,ALBVAL) ONEST1(IRK5)=ALBVAL C C EVALUATE THE MASS-CORRECTION TERM C IF (IRELOP(1).EQ.0) GO TO 7 CALL RMASS(N1,L1,N2,L1,RLBVAL) RMASS1(IRK5)=RLBVAL C C EVALUATE THE ONE-BODY DARWIN TERM C 7 IF (IRELOP(2).EQ.0) GO TO 8 IF (L1.GT.1) GO TO 8 CALL RDAR(N1,L1,N2,L1,RLBVAL) RDAR1(IRK9)=RLBVAL C C EVALUATE THE SPIN-ORBIT INTERACTION C 8 IF(IRELOP(3).EQ.0) GO TO 4 CALL SPNORB(N1,L1,N2,L1,RLBVAL) RSPOR1(IRK5)=RLBVAL 4 IF(N2-N1) 2,5,5 6 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE GEN2BB C C GENERATES AND STORES ALL THE BOUND-BOUND magnetic integrals N & V C C IMPLICIT REAL*8(A-H,O-Z) parameter (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) CHARACTER*2 TYPE(-1:1) COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO7/NBUG,INK1,INK4,LRANG3,NMIN(0: 5) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) DATA TYPE/'V(','??','N('/ NLG(n,l) = ((n-1)*n)/2+l+1 C C ZEROIZE VARIABLES AND ARRAYS C IRUN=0 INK1=0 INK4=0 DO 1 K=1,LRANG1*LRANG1 DO 1 J=1,LRANG1 DO 1 I=1,LRANG1 1 ICTBB(I,J,K)=0 C C SET THE INITIAL ANGULAR MOMENTA OF THE BOUND ORBITALS C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C L1=0 4 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 34 L2=0 5 IF(MAXNC(L2+1).EQ.MAXNHF(L2+1)) GO TO 33 L3=0 6 IF(MAXNC(L3+1).EQ.MAXNHF(L3+1)) GO TO 32 L4=0 7 IF(MAXNC(L4+1).EQ.MAXNHF(L4+1)) GO TO 31 K = L1+L2+L3+L4 IF(K-MAX(L1,L2,L3,L4).EQ.0) GO TO 31 if(MOD(K,2).NE.0) go to 31 C C SET THE VALUE OF LAMBDA C LP = L3*LRANG1+1 LAM = MAX(ABS(L1-L3),ABS(L2-L4))-2 IF(LAM.LT.-1) LAM = 0 12 IF(LAM.gt.L1+L3) go to 31 IF(LAM.gt.L2+L4) go to 31 K = 1-2*MOD(L1+L3+LAM,2) IF (K.LT.0 .AND. LAM.LT.0) GO TO 28 INK4=INK4+1 IF(INK4.GT.IDMTST(4)) NBUG=1 C C COMPUTE and STORE LOCATION OF MK INTEGRALS IN ISTBB1 AND ISTBB2 C IF(LP.EQ.0) GO TO 14 ICTBB(L1+1,L2+1,LP+L4) = INK4 LP = 0 14 IF(NBUG.NE.0) GO TO 15 ISTBB1(INK4) = LAM ISTBB2(INK4) = INK1 C 15 DO 27 N1=NMIN(L1),MAXNHF(L1+1) DO 26 N2=NMIN(L2),MAXNHF(L2+1) DO 25 N3=NMIN(L3),MAXNHF(L3+1) DO 24 N4=NMIN(L4),MAXNHF(L4+1) C IF (NLG(N2,L2).LT.NLG(N4,L4)) GO TO 24 IF (K.GT.0 .AND. NLG(N1,L1).LT.NLG(N3,L3)) GO TO 24 INK1=INK1+1 IF(INK1.LE.IDMTST(1)) THEN IRUN=INK1 ELSE NBUG=1 IRUN=1 ENDIF CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,N4,L4+1,LAM,K,VAL) C n.b. for V integrals (K=-1) derivative in 3rd nl position! RKSTO1(IRUN)=VAL C IF (NBUG2.LE.0) GO TO 24 C if(IRUN.gt.100) go to 24 print "(I9,4X,A2,4(I3,I2),I4,')',F12.5,F18.9)", INK1,TYPE(K), * n1,l1,n2,l2,n3,l3,n4,l4, LAM, VAL, .000013312*VAL ! alpha^2/4 C 24 continue 25 continue 26 continue 27 continue C is C INCREMENT THE VALUE OF LAMBDA C 28 LAM=LAM+1 GO TO 12 C C INCREMENT THE ANGULAR MOMENTA C 31 L4=L4+1 IF(L4+1.LE.LRANG1) GO TO 7 32 L3=L3+1 IF(L3+1.LE.LRANG1) GO TO 6 33 L2=L2+1 IF(L2+1.LE.LRANG1) GO TO 5 34 L1=L1+1 IF(L1+1.LE.LRANG1) GO TO 4 RETURN END C*********************************************************************** SUBROUTINE GEN1BC C C GENERATES AND STORES ALL THE BOUND-CONTINUUM ONE ELECTRON C INTEGRALS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO6/RSPOR1( 56),RSPOR2( 600),RSPOR3(1830) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) C IRK6=0 IRK10=0 L=MIN(LRANG1,LRANG2) DO 7 L1=1,L IST2(L1)=0 MAXHF = MAXNHF(L1) C C THERE IS NO VALENCE ORBITAL WITH TIHS ANGULAR MOMENTUM. C IF(MAXNC(L1).EQ.MAXHF) GO TO 7 IF(NBUG7.EQ.1) GO TO 1 CALL SKIPER(L1,0) 1 IST2(L1)=IRK6+1 C C SET THE PRINCIPAL QUANTUM NUMBER OF THE BOUND ORBITAL. C N1=MAXNC(L1)+1 2 N2=1 3 IRK6=IRK6+1 IF (IRELOP(2).NE.0.AND.L1.EQ.1) IRK10=IRK10+1 IF (IRK10.GT.IDMTST(32)) NBUG7=1 N3=MAXHF+N2 IF(IRK6.GT.IDMTST(20)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 5 4 CALL ONEELE(N1,L1,N3,L1,ALBVAL) ONEST2(IRK6)=ALBVAL C C EVALUATE THE MASS-CORRECTION TERM C IF (IRELOP(1).EQ.0) GO TO 8 CALL RMASS(N1,L1,N3,L1,RLBVAL) RMASS2(IRK6)=RLBVAL C C EVALUATE THE ONE-BODY DARWIN TERM C 8 IF (IRELOP(2).EQ.0 .OR. L1.GT.1) GO TO 9 CALL RDAR(N1,L1,N3,L1,RLBVAL) RDAR2(IRK10)=RLBVAL C C EVALUATE THE SPIN-ORBIT INTERACTION C 9 IF(IRELOP(3).EQ.0) GO TO 5 CALL SPNORB(N1,L1,N3,L1,RLBVAL) RSPOR2(IRK6)=RLBVAL 5 N2=N2+1 IF(N2.LE.NRANG2) GO TO 3 N1=N1+1 IF(N1.LE.MAXHF) GO TO 2 7 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE GEN2BC C C - COMPUTES THE N AND V TYPE BOUND-CONTINUUM MAGNETIC INTEGRALS MK C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO7/NBUG,INK1,INK4,LRANG3,NMIN(0: 5) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE VARIABLES AND ARRAYS C IRUN=0 INK1=0 INK4=0 DO 1 K=1,ABS(LRANG3)*LRANG1 DO 1 J=1,LRANG1 DO 1 I=1,LRANG1 1 ICTBC(I,J,K)=0 C C SET THE INITIAL ANGULAR MOMENTA C READ THE CONTINUUM ORBITALS FROM DISC C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C L=0 4 IF(NBUG.EQ.1) GO TO 5 CALL SKIPER(L+1,0) 5 L1=0 6 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 28 L2=0 7 IF(MAXNC(L2+1).EQ.MAXNHF(L2+1)) GO TO 27 L3=0 8 IF(MAXNC(L3+1).EQ.MAXNHF(L3+1)) GO TO 26 K = L1+L2+L3+L IF(MOD(K,2).NE.0) GO TO 26 IF(K-MAX(L1,L2,L3,L).EQ.0) GO TO 26 C C LOOP THROUGH LAMBDA C LP=LRANG1*L+L3+1 LAM=MAX(ABS(L-L2),ABS(L1-L3))-2 IF(LAM.LT.-1) LAM=0 C print"(22X,'INK4, LL1:LL4,LAM0 =',2I6,4I3)",INK4,L1,L2,L3,L,LAM 10 IF(LAM.GT.L2+L) GO TO 26 IF(LAM.GT.L1+L3) GO TO 26 INK4=INK4+1 C C STORE THE LOCATION OF THE INTEGRALS MK IN ISTBC1 AND ISTBC2 C IF(LP.EQ.0) GO TO 12 IF(NBUG2.GT.0) * print "(9X,'setting ICTBC(',3I3,') =',I5)",L1+1,L2+1,LP,INK4 ICTBC(L1+1,L2+1,LP)=INK4 LP=0 12 IF(INK4.GT.IDMTST(3)) GO TO 13 ISTBC1(INK4) = LAM ISTBC2(INK4) = INK1 C C RUN THROUGH PRINCIPAL QUANTUM NUMBERS C 13 K = 1-2*MOD(L1+L3+LAM,2) DO 24 N1=NMIN(L1),MAXNHF(L1+1) do 23 N2=NMIN(L2),maxnhf(L2+1) do 22 N3=NMIN(L3),maxnhf(L3+1) C IF (K.GT.0 .AND. NLG(N1,L1).LT.NLG(N3,L3)) GO TO 21 DO 21 N=1,NRANG2 C IRUN=INK1+1 INK1=IRUN+1 IF(INK1.GT.IDMTST(2)) NBUG=2 IF(NBUG.GT.0) GO TO 21 CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,MAXNHF(L+1)+N,L+1,LAM,K,VAL1) RKSTO2(IRUN) = VAL1 CALL RS(N2,L2+1,N1,L1+1,MAXNHF(L+1)+N,L+1,N3,L3+1,LAM,K,VAL2) C EXPLOITING M(B,A,D,C)=M(A,B,C,D) (n.b. derivative at 3rd orb.) RKSTO2(INK1) = VAL2 C IF (NBUG2.LE.0) GO TO 21 if (irun.gt.2000) go to 21 if (N.gt.4 .and. N.ne.NRANG2) go to 21 C if(IRUN.gt.40*NRANG2.and.irun.le.1500) go to 21 ! for NeIII+e C Ne3 print "(I8,' K=',I2,4(I4,I2),I5,2F12.5,I7,I4)", IRUN,K, C Ne3* N1,L1,N2,L2,N3,L3,-N,L,LAM,VAL1,VAL2, INK1,INK4 C 21 CONTINUE 22 continue 23 continue 24 continue C LAM=LAM+1 GO TO 10 C C INCREMENT THE ANGULAR MOMENTA C 26 L3=L3+1 IF(L3.LT.LRANG1) GO TO 8 27 L2=L2+1 IF(L2.LT.LRANG1) GO TO 7 28 L1=L1+1 IF(L1.LT.LRANG1) GO TO 6 L=L+1 IF(L.LT.ABS(LRANG3)) GO TO 4 RETURN END C*********************************************************************** SUBROUTINE GEN1CC(L) C C GENERATES AND STORES ALL CONTINUUM-CONTINUUM ONE ELECTRON C INTEGRALS FOR THE ANGULAR MOMENTUM (L-1) C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO6/RSPOR1( 56),RSPOR2( 600),RSPOR3(1830) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) C IRK7=0 MAXHF = MAXNHF(L) IF(NBUG7.EQ.1) GO TO 1 CALL SKIPER(L,0) 1 N1=1 2 N3=MAXHF+N1 N2=1 3 IRK7=IRK7+1 N4=MAXHF+N2 IF(IRK7.GT.IDMTST(21)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 5 4 CALL ONEELE(N3,L,N4,L,ALBVAL) ONEST3(IRK7)= ALBVAL C C EVALUATE THE MASS-CORRECTION TERM C IF (IRELOP(1).EQ.0) GO TO 8 CALL RMASS(N3,L,N4,L,RLBVAL) RMASS3(IRK7)=RLBVAL C C EVALUATE THE ONE-BODY DARWIN TERM C 8 IF (IRELOP(2).EQ.0 .OR. L.GT.1) GO TO 9 CALL RDAR(N3,L,N4,L,RLBVAL) RDAR3(IRK7)=RLBVAL C C EVALUATE THE SPIN-ORBIT INTERACTION C 9 IF (IRELOP(3).EQ.0 .OR. L.EQ.1) GO TO 5 CALL SPNORB(N3,L,N4,L,RLBVAL) RSPOR3(IRK7)=RLBVAL 5 N2=N2+1 IF(N2.LE.N1) GO TO 3 N1=N1+1 IF(N1.LE.NRANG2) GO TO 2 RETURN END C*********************************************************************** SUBROUTINE GEN2CC(L,LP) C C - COMPUTE AND STORE CONTINUUM-CONTINUUM MK INTEGRALS Nlam and Vlam C WITH CONTINUUM ANGULAR MOMENTA L AND LP; NOLeftC added '04Jun21 C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL CRUX, LPRT PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO7/NBUG,INK1,INK4,LRANG3,NMIN(0: 5) COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C NLG(n,l) = ((n-1)*n)/2+l C LPRT = (L.ne.2.and.L.ne.1) .or. (LP.ne.3.and.LP.ne.1) C IRK2=0 ccc LOOP=0 I1=MIN(2*LRANG1-1,L+LP+1) I2=MIN(L,LP)+LRANG1 DO 4 I=1,LRANG1 DO 4 J=1,LRANG1 DO 2 K=0,I1 2 ICTCCD(I,J,K)=-1 DO 3 K=0,I2 3 ICTCCE(I,J,K)=-1 4 CONTINUE C C C SET THE INITIAL VALUE OF LAMBDA AND ANGULAR MOMENTA FOR THE C DIRECT (IT=0, vs exchange: IT=1) INTEGRALS C INCREMENT THE LAMBDA VALUE, RESET FOR EXCHANGE C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA L1 = 0 6 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 32 L3 = 0 7 I = L1+L+L3+LP IF(I-MAX(L1,L,L3,LP).EQ.0) GO TO 31 IF(MOD(I,2).NE.0) GO TO 31 IF(MAXNC(L3+1).EQ.MAXNHF(L3+1)) GO TO 31 C IT = 0 LMA = MAX(L1,L3)+MAX(L,LP) ! not =MIN(L1+L3,L+LP) '06Jun5 9 LAM = -1 ! not MAX(ABS(L3-L1)-2,ABS(L-LP)-2,-1) along Coulomb C C ADDRESS ARRAYS ICTCCD AND ICTCCE OF DIRECT AND EXCHANGE INTEGRALS: C 10 IF(IT.EQ.0) THEN ICTCCD(L1+1,L3+1,LAM+1)=IRK2 ! +LOOP*IDMTST(2) M=L3 ELSE ICTCCE(L1+1,L3+1,LAM+1)=IRK2 !+LOOP*IDMTST(2) M=LP ENDIF C IRUN = IRK2 K = 1-2*MOD(L1+M+LAM+2,2) IF (L.eq.2.and.LP/2.eq.1) * print "(/' GEN2CC: K,LAM,LMA,L1,M=',5I4)", K,LAM,LMA,L1,M IF (K.LT.0 .AND. LAM.LT.0) GO TO 30 DO 29 N1=NMIN(L1),MAXNHF(L1+1) DO 28 N3=NMIN(L3),MAXNHF(L3+1) ***** IF(IT.EQ.0 .AND. K.GT.0 .AND. NLG(N3,L3).GT.NLG(N1,L1)) GO TO 28 CRUX = LP.EQ.L 13 DO 27 N=1,NRANG2 DO 26 NP=1,NRANG2 C C CALCULATE AND STORE EITHER A DIRECT OR AN EXCHANGE MK INTEGRAL C (K=+1: N TYPE, K=-1: V TYPE; also use LIMEX from GENCC) ***** IRUN=IRUN+1 IF(NBUG.NE.0) GO TO 26 IF(IRUN.GE.IDMTST(2)) NBUG=1 !GO TO 43 ccc IF(LOOP-LOOPCC) 26,22,44 *** REV = 0. IF(IT.EQ.0) THEN ! direct: CALL RS(N1,L1+1,MAXNHF(L+1)+N,L+1, * N3,L3+1,MAXNHF(LP+1)+NP,LP+1, LAM,K,VAL) CALL RS(MAXNHF(L+1)+N,L+1,N1,L1+1, * MAXNHF(LP+1)+NP,LP+1,N3,L3+1, LAM,K,REV) IF(CRUX) THEN ! (cDaB) and (DcBa) CALL RS(N3,L3+1,MAXNHF(LP+1)+NP,LP+1, * N1,L1+1,MAXNHF(L+1)+N,L+1, LAM,K,VAL) CALL RS(MAXNHF(LP+1)+NP,LP+1,N3,L3+1, * MAXNHF(L+1)+N,L+1,N1,L1+1, LAM,K,REV) ENDIF ELSE ! exchange: VAL = 0. IF (LAM.GE.LIMEX(N) .OR. LAM.GE.LIMEX(NP)) GO TO 25 CALL RS(N1,L1+1,MAXNHF(L+1)+N,L+1, * MAXNHF(LP+1)+NP,LP+1,N3,L3+1, LAM,K,VAL) CALL RS(MAXNHF(L+1)+N,L+1,N1,L1+1, * N3,L3+1,MAXNHF(LP+1)+NP,LP+1, LAM,K,REV) IF(CRUX) THEN CALL RS(MAXNHF(LP+1)+NP,LP+1,N3,L3+1, * N1,L1+1,MAXNHF(L+1)+N,L+1, LAM,K,VAL) CALL RS(N3,L3+1,MAXNHF(LP+1)+NP,LP+1, * MAXNHF(L+1)+N,L+1,N1,L1+1, LAM,K,REV) ENDIF ENDIF c 25 IRUN=IRUN+1 IF ((L.eq.2.and.LP/2.eq.1) .and. (N.le.3.and.NP.le.3)) * print "(' I,IT,CX: a-d, CX,V =', * I5,I3,L3,':',2(I3,I2,I4,I2),I4,2F10.5)", * IRUN,IT,CRUX, N1,L1,-N,L,N3,L3,-NP,LP,LAM,VAL, REV !,I=1,-K) c RKSTO2(IRUN) = VAL *** IF(K.GT.0) GO TO 26 IRUN=IRUN+1 RKSTO2(IRUN) = REV c IF (NBUG2.LE.0) GO TO 26 if(N.GT.4.or.NP.gt.3) GO TO 26 c tout if(L.ne.2.or.LP.ne.3 .or. IRUN.GT.2500) go to 26 if (LPRT .or. IRUN.GT.2500) go to 26 print"(I9,' K,IT = ',2I2,2X,L1,2X,4(I4,I2),I5,2F12.5)",IRUN, * K,IT,CRUX,N1,L1,-N,L,N3,L3,-NP,LP,LAM, RKSTO2(IRUN) C 26 CONTINUE 27 CONTINUE CRUX=.NOT.CRUX IF(CRUX) GO TO 13 28 CONTINUE 29 CONTINUE IRK2 = IRUN C C INCREMENT THE MULTIPOLARITY LAMBDA AND THE ANGULAR MOMENTA C 30 LAM = LAM+1 IF(LAM.LE.LMA) GO TO 10 IT=IT+1 IF(IT.EQ.1) GO TO 9 C 31 L3=L3+1 IF(L3.LT.LRANG1) GO TO 7 32 L1=L1+1 IF(L1.LT.LRANG1) GO TO 6 ccc GO TO 42 c*c IRK2 HAS REACHED THE END OF THE RKSTO2 ARRAY. RETURN TO c*c WRITE OUT THE ARRAY IF GENCC HAS BEEN LOOPED OVER LOOPCC TIMES. ccc43 IRK2=1; LOOP=LOOP+1; IF(LOOP-LOOPCC) 26,22,44; 44 IRK2=-IDMTST(2) 42 RETURN END C*********************************************************************** SUBROUTINE GENBB C C GENERATES AND STORES ALL THE BOUND-BOUND SLATER INTEGRALS RK C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE VARIABLES AND ARRAYS C IRK1=0 IRK4=0 I1=LRANG1*LRANG1 DO 1 K=1,I1 DO 1 J=1,LRANG1 DO 1 I=1,LRANG1 1 ICTBB(I,J,K)=0 C C SET THE INITIAL ANGULAR MOMENTA OF THE BOUND ORBITALS C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C L1=0 4 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 34 L2=L1 5 IF(MAXNC(L2+1).EQ.MAXNHF(L2+1)) GO TO 33 L3=L1 6 IF(MAXNC(L3+1).EQ.MAXNHF(L3+1)) GO TO 32 L4=MOD(L1+L2+L3,2) C C CHECK TRIANGULAR RELATIONS C 7 IF(MAXNC(L4+1).EQ.MAXNHF(L4+1)) GO TO 31 IF(L4.GE.L2) GO TO 9 L4=L4+2 GO TO 7 9 IF(L4.GT.LRANG1-1) GO TO 32 C C SET THE VALUE OF LAMBDA C LP = L3*LRANG1+L4+1 LAM = MAX(ABS(L1-L3),ABS(L2-L4)) 11 IF(LAM.GT.L1+L3) GO TO 31 IF(LAM.GT.L2+L4) GO TO 31 IRK4=IRK4+1 IF(IRK4.GT.IDMTST(4)) NBUG7=1 C C STORE LOCATION OF RK INTEGRALS IN ISTBB1 AND ISTBB2 C IF(LP.EQ.0) GO TO 14 ICTBB(L1+1,L2+1,LP)=IRK4 LP = 0 14 IF(NBUG7.EQ.1) GO TO 15 ISTBB1(IRK4) = LAM ISTBB2(IRK4) = IRK1+1 C C SET THE INITIAL PRINCIPAL QUANTUM NUMBERS OF THE BOUND ORBITALS C 15 N3M=MAXNHF(L3+1) N4M=MAXNHF(L4+1) N1=MAXNC(L1+1)+1 16 NST = N1 IF(L2.NE.L1) NST=MAXNHF(L2+1) N2=MAXNC(L2+1)+1 IF(L3.EQ.L1) N3M=N1 20 N3=MAXNC(L3+1)+1 IF(L4.EQ.L2) N4M=N2 21 N4=MAXNC(L4+1)+1 C C EVALUATE AND STORE AN RK INTEGRAL IN RKSTO1 C 22 IRK1=IRK1+1 IF(IRK1.GT.IDMTST(1)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 24 23 CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,N4,L4+1,LAM,0,RKVAL) RKSTO1(IRK1)=RKVAL C C INCREMENT PRINCIPAL QUANTUM NUMBERS C 24 N4=N4+1 IF(N4.LE.N4M) GO TO 22 N3=N3+1 IF(N3.LE.N3M) GO TO 21 N2=N2+1 IF(N2.LE.NST) GO TO 20 N1=N1+1 IF(N1.LE.MAXNHF(L1+1)) GO TO 16 C C INCREMENT THE VALUE OF LAMBDA C LAM=LAM+2 GO TO 11 C C INCREMENT THE ANGULAR MOMENTA C 31 L4=L4+2 IF(L4.LT.LRANG1) GO TO 7 32 L3=L3+1 IF(L3.LT.LRANG1) GO TO 6 33 L2=L2+1 IF(L2.LT.LRANG1) GO TO 5 34 L1=L1+1 IF(L1.LT.LRANG1) GO TO 4 RETURN END C*********************************************************************** SUBROUTINE GENBC C C GENERATES AND STORES ALL THE BOUND CONTINUUM RK INTEGRALS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE VARIABLES AND ARRAYS C IRK2=0 IRK3=0 DO 1 K=1,MIN(LRANG1*LRANG2,LRANG1*((LRANG1-1)*3+1)) DO 1 J=1,LRANG1 DO 1 I=1,LRANG1 1 ICTBC(I,J,K)=0 C C SET THE INITIAL ANGULAR MOMENTA C READ THE CONTINUUM ORBITALS FROM DISC C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C L=0 4 IF(NBUG7.EQ.1) GO TO 5 CALL SKIPER(L+1,0) 5 L1=0 6 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 28 L2=0 7 IF(MAXNC(L2+1).EQ.MAXNHF(L2+1)) GO TO 27 L3=MOD(L+L1+L2,2) IF(L3.LT.L1) GO TO 26 8 IF(MAXNC(L3+1).EQ.MAXNHF(L3+1)) GO TO 26 C C SET THE INITIAL VALUE OF LAMBDA C LAM=MAX(ABS(L-L2),ABS(L1-L3)) LP=LRANG1*L+L3+1 10 IF(LAM.GT.L1+L3) GO TO 26 IF(LAM.GT.L2+L) GO TO 26 IRK3=IRK3+1 IF(IRK3.GT.IDMTST(3)) NBUG7=1 C C STORE THE LOCATION OF THE RK INTEGRALS IN ISTBC1 AND ISTBC2 C IF(LP.EQ.0) GO TO 12 ICTBC(L1+1,L2+1,LP)=IRK3 LP=0 12 IF(NBUG7.EQ.1) GO TO 13 ISTBC1(IRK3)=LAM ISTBC2(IRK3) = IRK2+1 C C SET THE INITIAL PRINCIPAL QUANTUM NUMBERS C 13 N1=MAXNC(L1+1)+1 14 N2=MAXNC(L2+1)+1 N3M=MAXNHF(L3+1) IF(L3.EQ.L1) N3M=N1 15 N3=MAXNC(L3+1)+1 16 N=1 C C CALCULATE AND STORE AN RK INTEGRAL IN RKSTO2 C 17 IRK2=IRK2+1 IF(IRK2.GT.IDMTST(2)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 19 18 CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,MAXNHF(L+1)+N,L+1,LAM,0,RKVAL) RKSTO2(IRK2) = RKVAL C C INCREMENT THE PRINCIPAL QUANTUM NUMBERS C 19 N=N+1 IF(N.LE.NRANG2) GO TO 17 N3=N3+1 IF(N3.LE.N3M) GO TO 16 N2=N2+1 IF(N2.LE.MAXNHF(L2+1)) GO TO 15 N1=N1+1 IF(N1.LE.MAXNHF(L1+1)) GO TO 14 C C INCREMENT THE VALUE OF LAMBDA C LAM=LAM+2 GO TO 10 C C INCREMENT THE ANGULAR MOMENTA C 26 L3=L3+2 IF(L3.LT.LRANG1) GO TO 8 27 L2=L2+1 IF(L2.LT.LRANG1) GO TO 7 28 L1=L1+1 IF(L1.LT.LRANG1) GO TO 6 L=L+1 IF(L-3*LRANG1.GT.3) GO TO 31 IF(L.LT.LRANG2) GO TO 4 31 RETURN END C*********************************************************************** SUBROUTINE GENCC(L,LP) C C GENERATES AND STORES ALL THE CONTINUUM-CONTINUUM RK INTEGRALS C WITH CONTINUUM ANGULAR MOMENTA L AND LP C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL53= 5* 5, LL56= 49+ 5) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE VARIABLES AND ARRAYS C IRK2=0 LOOP=0 I1=MIN(2*LRANG1-1,L+LP+1) I2=MIN(L,LP)+LRANG1 DO 3 I=1,LRANG1 DO 3 J=1,LRANG1 DO 1 K=1,I1 1 ICTCCD(I,J,K)=0 DO 2 K=1,I2 2 ICTCCE(I,J,K)=0 3 CONTINUE C C IT = 0 MEANS CALCULATE THE DIRECT INTEGRALS C IT = 1 MEANS CALCULATE THE EXCHANGE INTEGRALS C IT=0 C C SET THE INITIAL VALUE OF LAMBDA AND ANGULAR MOMENTA FOR THE C DIRECT INTEGRAL C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C LAM = ABS(L-LP) 5 L1=0 6 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 9 L1P=ABS(L1-LAM) 7 IF(L1P.LT.L1) GO TO 30 IF(L1P-L1.GT.LAM) GO TO 9 IF(L1P.LT.LRANG1) GO TO 12 C C INCREMENT THE LAMBDA VALUE AND THE ANGULAR MOMENTA FOR THE C DIRECT INTEGRAL C 9 L1=L1+1 IF(L1.LT.LRANG1) GO TO 6 LAM=LAM+2 IF(LAM-L.GT.LP) GO TO 31 IF(LAM-2*LRANG1) 5,31,31 C C STORE THE LOCATION OF THE DIRECT R-K INTEGRALS IN ICTCCD C 12 IF(MAXNC(L1P+1).EQ.MAXNHF(L1P+1)) GO TO 30 ICTCCD(L1+1,L1P+1,LAM+1)=IRK2+1+LOOP*IDMTST(2) C C SET THE INITIAL PRINCIPAL QUANTUM NUMBERS FOR BOTH THE DIRECT AND C THE EXCHANGE INTEGRALS C 13 N1PM=MAXNHF(L1P+1) N1=MAXNC(L1+1)+1 14 N1P=MAXNC(L1P+1)+1 IF(IT.NE.0) GO TO 16 IF(L1P.EQ.L1) N1PM=N1 16 N=1 17 NP=1 NST=NRANG2 IF(L.EQ.LP) NST = N C C CALCULATES AND STORES EITHER A DIRECT OR AN EXCHANGE RK INTEGRAL C RUB'96FE22: KAB METHOD TO TERMINATE AT ONSET OF EXCHANGE INSTABILITY C 21 IRK2=IRK2+1 IF(NBUG7.EQ.1) GO TO 26 IF(IRK2.GT.IDMTST(2)) GO TO 43 IF(LOOP-LOOPCC) 26,22,44 22 IF(IT.NE.0) GO TO 24 CALL RS(N1,L1+1,MAXNHF(L+1)+N,L+1,N1P,L1P+1,MAXNHF(LP+1)+NP,LP+1, * LAM,0,RKVAL) GO TO 25 24 RKVAL=0.0 IF (LAM.GE.LIMEX(N) .OR. LAM.GE.LIMEX(NP)) GO TO 25 CALL RS(MAXNHF(L+1)+N,L+1,N1,L1+1,N1P,L1P+1,MAXNHF(LP+1)+NP,LP+1, * LAM,0,RKVAL) IF(LP.NE.L) GO TO 25 IF(NP.NE.N) GO TO 25 IF(N1P.NE.N1) GO TO 25 IF(L1P.NE.L1) GO TO 25 IF(RKVAL.lt.-1.E-10) THEN IF(NBUG9.NE.0) THEN PRINT "(' *** NEG-TRAP at n,l,N,L,lam =',I3,I2,I4,2I3, * ': X turning negative:',1P,E9.1' ***')", N1,L1,N,L,LAM,RKVAL ELSE WRITE(6,"(' >>>> NEG-CUT OF EXCHANGE-RK AT LAM,N = ',I6,',', * I8,' <<<<')") LAM,N ENDIF LIMEX(N) = LAM RKVAL = 0. GO TO 25 ENDIF IF(L1.NE.LRANG1-1) GO TO 25 IF(N1.NE.N1PM) GO TO 25 IF(LIMEX(N).LE.LAM) GO TO 25 IF(LAM.NE.L+L1) GO TO 25 C IF(L+LRANG1.LT. 9) GO TO 25 C TST PRINT *,' ==> TEST: EXLIM AT LAM =',LAM, RKVAL C IF(ABS(RKVAL).GT.EXLIM*1.2) C RE-WRITTEN WITH EXLIM AND LIMEX AS ARRAYS -- STGT'01APR11-3: EXLIM(1,N) = EXLIM(2,N) EXLIM(2,N) = EXLIM(3,N) EXLIM(3,N) = RKVAL IF (L.LT.2) GO TO 25 IF (RKVAL.GT.EXLIM(2,N)) THEN IF (LIMEX(N).GT.99) THEN LIMEX(N) = LAM WRITE(6,"(' >>> POS-CUT OF EXCHANGE-RK AT LAM,N = ',I6,',', * I8,' <<<')") LAM,N RKVAL = 0. IF (NBUG9.EQ.0) GO TO 25 PRINT"(6X,'when EXLIM(1:3) =',1P,3E11.3)",(EXLIM(I,N),I=1,3) ENDIF ELSEIF (EXLIM(2,N)-EXLIM(1,N).LT.EXLIM(3,N)-EXLIM(2,N) * .AND. EXLIM(0,N).EQ.0.) THEN EXLIM(0,N) = RKVAL IF (NBUG9.EQ.0) GO TO 25 PRINT"(' >> downward inflection at LAM,N =',2I4/25X, * 'EXLIM(1:3) ='1P,3E12.4,' <<')", LAM,N,(exlim(I,N),I=1,3) ENDIF 25 RKSTO2(IRK2)=RKVAL C C INCREMENT THE PRINCIPAL QUANTUM NUMBERS FOR BOTH THE DIRECT AND C THE EXCHANGE INTEGRALS C 26 NP = NP+1 IF(NP.LE.NST) GO TO 21 N=N+1 IF(N.LE.NRANG2) GO TO 17 N1P=N1P+1 IF(N1P.LE.N1PM) GO TO 16 N1=N1+1 IF(N1.LE.MAXNHF(L1+1)) GO TO 14 30 L1P=L1P+2 IF(IT) 36,7,36 C C SET THE INITIAL VALUE OF LAMBDA AND ANGULAR MOMENTA FOR THE C EXCHANGE INTEGRAL C 31 IT=1 LAM = 0 32 L1=ABS(LP-LAM) 33 IF(L1-LP.GT.LAM) GO TO 40 C !!! IF(L1-1.GT.LRANG1) GO TO 40 - RUB'96AUG29 WRONG SINCE '96FEB(LE22) IF(L1.GE.LRANG1) GO TO 40 IF(MAXNC(L1+1).EQ.MAXNHF(L1+1)) GO TO 39 L1P=ABS(L-LAM) 36 IF(L1P-L.GT.LAM) GO TO 39 C !!! IF(LP1-1.GT.LRANG1) GO TO 39 - SAME AS ABOVE (-1 INSTEAD OF +1) IF(L1P.GE.LRANG1) GO TO 39 C C STORE THE LOCATION OF THE EXCHANGE RK INTEGRALS IN ICTCCE C IF(MAXNC(L1P+1).EQ.MAXNHF(L1P+1)) GO TO 30 ICTCCE(L1+1,L1P+1,LAM+1)=IRK2+1+LOOP*IDMTST(2) GO TO 13 C C INCREMENT THE LAMBDA VALUE AND THE ANGULAR MOMENTA FOR THE C EXCHANGE INTEGRAL C 39 L1=L1+2 GO TO 33 40 LAM=LAM+1 IF(LAM-LRANG1.GE.L) GO TO 42 IF(LAM-LRANG1-LP) 32,42,42 C C IRK2 HAS REACHED THE END OF THE RKSTO2 ARRAY. RETURN TO C WRITE OUT THE ARRAY IF GENCC HAS BEEN LOOPED OVER LOOPCC TIMES. C 43 IRK2=1 LOOP=LOOP+1 IF(LOOP-LOOPCC) 26,22,44 44 IRK2=-IDMTST(2) 42 RETURN END C*********************************************************************** SUBROUTINE GENINT C C CALLS THE ROUTINES WHICH EVALUATE ALL THE MULTIPOLE INTEGRALS, C ONE ELECTRON AND RK INTEGRALS (and MK if IZESP.lt.0,.ne.-99). C THE INTEGRALS EVALUATED IN EARLIER RUNS ARE READ FROM ITAPE2 C AND ARE WRITTEN ONTO ITAPE3 FOLLOWED BY THE INTEGRALS EVALUATED C IN THE CURRENT RUN. C NBUG7=1 CORRESPONDS TO A DIMENSION TEST RUN ONLY. C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER TYPE*6 PARAMETER (LL53= 5* 5, LL56= 49+ 5, LL68= 8/2) PARAMETER (NXD1= 49* 5,NXD2= 5*(( 5-1)*3+1)) PARAMETER (NXT1=NXD1/NXD2,NXT2=NXD2/NXD1,NXT0=NXT1+NXT2) PARAMETER (LL54=NXD1+NXD2-NXD1*NXT1/NXT0-NXD2*NXT2/NXT0) PARAMETER (MXD1= 5*2-1, MXD2= 49+ 5+1) ! LL55=min(MXD1,MXD2): PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL55=MXD1+MXD2-MXD1*MXT1/MXT0-MXD2*MXT2/MXT0) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO3/ICTBB( 5, 5,LL53),ICTBC( 5, 5,LL54), 1 ICTCCD( 5, 5,0:LL55),ICTCCE( 5, 5,0:LL56), 2 ISTBB1( 112),ISTBB2( 112),ISTBC1( 600), 3 ISTBC2( 600),IST1( 5),IST2( 5), 4 ITAPST( 49, 49),IDPOS1,IDPOS2 COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), 1 ICCPOL( 49, 49,LL68) COMMON/INSTO6/RSPOR1( 56),RSPOR2( 600),RSPOR3(1830) COMMON/INSTO7/NBUG,INK1,INK4,LRANG3,NMIN(0: 5) COMMON/JNSTO/ SKSTO2(50000),BNORM( 49),JRK8,JBCPOL( 5, 49), * JCCPOL( 49, 49) COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) COMMON/SKIP/ L1STO,L2STO,LPOS,NBORBS COMMON/SPZETA/ZESP( 5),IZESP COMMON/YKSTOR/YK(1999),RK(1999),RK1(1999),JN2,JL2,JN4,JL4,JKM EQUIVALENCE (YK(1),TEST1) TEST1=0. 1091 FORMAT(' INTEGRAL SUM =',1P,E15.7,' FOR') C 1000 FORMAT(//52X,17HSUBROUTINE GENINT/52X,17(1H-)) 1001 FORMAT(33H GENERATE THE MULTIPOLE INTEGRALS) 1002 FORMAT(45H GENERATE THE BOUND-BOUND MULTIPOLE INTEGRALS) 1003 FORMAT(49H GENERATE THE BOUND-CONTINUUM MULTIPOLE INTEGRALS) 1004 FORMAT(53H GENERATE THE CONTINUUM-CONTINUUM MULTIPOLE INTEGRALS) 1005 FORMAT(6H IRK8=,I7,17X,42HCURRENT ARRAY SIZE IS GIVEN BY IDMTST( 2 *)=,I7) 1006 FORMAT(48 H GENERATE THE BOUND-BOUND ONE ELECTRON INTEGRALS) 1007 FORMAT(6H IRK5=,I5,19X, 43HCURRENT ARRAY SPACE IS GIVEN BY IDMTST( *19)=,I5) 1008 FORMAT(52H GENERATE THE BOUND-CONTINUUM ONE ELECTRON INTEGRALS) 1009 FORMAT(6H IRK6=,I5,19X, 43HCURRENT ARRAY SPACE IS GIVEN BY IDMTST( *20)=,I5) 1010 FORMAT(52H GENERATE CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS) 1011 FORMAT(6H IRK7=,I5,3H L=,I5,11X,43HCURRENT ARRAY SPACE IS GIVEN BY * IDMTST(21)=,I5) 1012 FORMAT(/38H GENERATE THE BOUND-BOUND RK INTEGRALS) 1013 FORMAT(6H IRK1=,I5,19X, 43HCURRENT ARRAY SPACE IS GIVEN BY IDMTST( * 1)=,I5/6H IRK4=,I5,51X,11HIDMTST( 4)=,I5) 1014 FORMAT(/42H GENERATE THE BOUND-CONTINUUM RK INTEGRALS) 1015 FORMAT(6H IRK2=,I7,17X,42HCURRENT ARRAY SIZE IS GIVEN BY IDMTST( 2 *)=,I7/6H IRK3=,I5,51X,11HIDMTST( 3)=,I5) 1016 FORMAT(/' GENERATE THE CONTINUUM-CONTINUUM RK INTEGRALS, initial L *IMEX(0:NRANG2) = ',I2/(T37,10I4)) 1017 FORMAT(6H IRK2=,I7,3H L=,I5,4H LP=,I5,8X,34HARRAY SIZE IS GIVEN BY * IDMTST( 2)=,I7) 1018 FORMAT(6H IRK7=,I6,4H L=,I3) 1019 FORMAT(6H IRK2=,I7,4H L=,I3,4H LP=,I3) 1020 FORMAT(14H TAPE POSITION,I4,17H HAS BEEN REACHED) 1021 FORMAT(//' WRITE TO TAPE COMPLETED, LIMEX(N) =',(T37,10I4)) 1022 FORMAT(6H IRK9=,I5,19X, 43HCURRENT ARRAY SPACE IS GIVEN BY IDMTST( *31)=,I5) 1023 FORMAT(7H IRK10=,I5,18X,43HCURRENT ARRAY SPACE IS GIVEN BY IDMTST( *32)=,I5) 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 ICOUNT IS A COUNT ON THE INTEGRAL BLOCKS ON TAPE C 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.AND.NBUG7.NE.1) RETURN IPLACE=0 WRITE(IWRITE,1000) C C INITIALIZE PARAMETERS REQUIRED IN SUBROUTINES SKIPER AND RS C L1STO = 0 L2STO = 0 LPOS = 0 JKM=999 C LPR = 0 DO 18 I=1,NRANG2 LPR=LIMEX(I)+LPR IF (LIMEX(I).EQ.0) LIMEX(I) = LIMEX(I-1) 18 EXLIM(0,I) = 0. IF(LPR.NE.0) LPR=NRANG2 C NMIN(0) = 0 IF (IZESP.LT.0 .and. IZESP.GT.-99) THEN L = 0 39 N = L 40 N = N+1 IF (((N-1)*N)/2 + L+1 .LT. -IZESP) GO TO 40 ! '05Aug10 NMIN(L) = N L=L+1 IF(L.LT.LRANG1) GO TO 39 print "(' IZESP, NMIN(L) = ',I4,':',7I5)", IZESP, * (nmin(i),i=0,LRANG1-1) ENDIF C C GENERATE THE BOUND-BOUND, BOUND-CONTINUUM AND CONTINUUM-CONTINUUM C MULTIPOLE INTEGRALS. SET NBUG7=1 IF ARRAY SIZES ARE EXCEEDED C INBUG7=NBUG7 WRITE(IWRITE,1001) NLMIN = 1-IZESP IRK8=0 JRK8=0 LAMIND=(LAMAX+1)/2 1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 2 IF(LAMAX.GT.0) WRITE(IWRITE,1002) CALL GENMBB CC IF(NBUG9.EQ.1) WRITE(IWRITE,1091) TEST1 CC TEST1=0. IF(LAMBC.GT.0) WRITE(IWRITE,1003) CALL GENMBC IF(LAMCC.GT.0) WRITE(IWRITE,1004) CALL GENMCC L2STO=0 C C WRITE ALL THE MULTIPOLE INTEGRALS ON TAPE UNLESS NBUG7=1 C IF(NBUG7.NE.1) GO TO 3 WRITE(IWRITE,1005) IRK8,IDMTST(2) IF(JRK8.GT.IDMTST(29)) WRITE(IWRITE,*)' JRK8=',JRK8, 1 ' CURRENT ARRAY SIZE IS GIVEN BY IDMTST(29)=',IDMTST(29) 2 IF(NBUG7.EQ.1) GO TO 6 READ(ITAPE2) IRK8,JRK8 IF(IRK8.EQ.0) GO TO 3 IF(IRK8.GT.IDMTST(2)) CALL RECOV1(2,IRK8) READ(ITAPE2) (((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(JRK8.EQ.0) GO TO 3 READ(ITAPE2) ((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2), + ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2), + (SKSTO2(J),J=1,JRK8),(BNORM(J),J=1,LRANG2) 3 WRITE(ITAPE3)IRK8,JRK8 WRITE(IWRITE,*)'IRK8=',IRK8 IF(IRK8.LE.0) GO TO 4 WRITE(ITAPE3)(((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) 4 WRITE(IWRITE,1020) ICOUNT C C MODIFICATION TO INCLUDE BLOCK NUMBER 1+1/2 FOR BUTTLE TYPE C POINTERS AND DIPOLE INTEGRALS C IF(JRK8.EQ.0) GO TO 5 WRITE(ITAPE3)((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2), + ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2), + (SKSTO2(J),J=1,JRK8),(BNORM(J),J=1,LRANG2) WRITE(IWRITE,*) 'TAPE POSITION 1+1/2 HAS BEEN REACHED' 5 IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 C C GENERATE THE BOUND BOUND ONE ELECTRON INTEGRALS AND STORE ON TAPE C SET NBUG7=1 AS BEFORE C 6 WRITE(IWRITE,1006) IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 7 CALL GEN1BB IF(NBUG7.NE.1) GO TO 8 WRITE(IWRITE,1007) IRK5,IDMTST(19) WRITE(IWRITE,1022) IRK9,IDMTST(31) 7 IF(NBUG7.EQ.1) GO TO 10 READ(ITAPE2) IRK5 IF(IRK5.GT.IDMTST(19)) CALL RECOV1(19,IRK5) READ(ITAPE2) (IST1(I),I=1,LRANG1),(ONEST1(I),I=1,IRK5) IF (IRELOP(1).GT.0) READ(ITAPE2) (RMASS1(I),I=1,IRK5) IF (IRELOP(3).GT.0) READ(ITAPE2) (RSPOR1(I),I=1,IRK5) IF (IRELOP(2).EQ.0) GO TO 8 READ(ITAPE2) IRK9 IF (IRK9.GT.IDMTST(31)) CALL RECOV1(31,IRK9) READ(ITAPE2) (RDAR1(I),I=1,IRK9) 8 WRITE(ITAPE3)IRK5 WRITE(ITAPE3)(IST1(I),I=1,LRANG1),(ONEST1(I),I=1,IRK5) IF (IRELOP(1).GT.0) WRITE(ITAPE3) (RMASS1(I),I=1,IRK5) IF (IRELOP(3).GT.0) WRITE(ITAPE3) (RSPOR1(I),I=1,IRK5) IF (IRELOP(2).EQ.0) GO TO 9 WRITE(ITAPE3) IRK9 WRITE(ITAPE3) (RDAR1(I),I=1,IRK9) 9 WRITE(IWRITE,1020) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 C C GENERATE THE BOUND CONTINUUM ONE ELECTRON INTEGRALS AND STORE C ON TAPE. HANDLE NBUG7=1 AS BEFORE C 10 WRITE(IWRITE,1008) IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 11 CALL GEN1BC IF(NBUG7.NE.1) GO TO 12 WRITE(IWRITE,1009) IRK6,IDMTST(20) WRITE(IWRITE,1023) IRK10,IDMTST(32) 11 IF(NBUG7.EQ.1) GO TO 14 READ(ITAPE2) IRK6 IF(IRK6.GT.IDMTST(20)) CALL RECOV1(20,IRK6) READ(ITAPE2) (IST2(I),I=1,LRANG1),(ONEST2(I),I=1,IRK6) IF (IRELOP(1).GT.0) READ(ITAPE2) (RMASS2(I),I=1,IRK6) IF(IRELOP(3).GT.0) READ(ITAPE2) (RSPOR2(I),I=1,IRK6) IF (IRELOP(2).EQ.0) GO TO 12 READ(ITAPE2) IRK10 IF (IRK10.GT.IDMTST(32)) CALL RECOV1(32,IRK10) READ(ITAPE2) (RDAR2(I),I=1,IRK10) 12 WRITE(ITAPE3)IRK6 WRITE(ITAPE3)(IST2(I),I=1,LRANG1),(ONEST2(I),I=1,IRK6) IF (IRELOP(1).GT.0) WRITE(ITAPE3) (RMASS2(I),I=1,IRK6) IF (IRELOP(3).GT.0) WRITE(ITAPE3) (RSPOR2(I),I=1,IRK6) IF (IRELOP(2).EQ.0) GO TO 13 WRITE(ITAPE3) IRK10 WRITE(ITAPE3) (RDAR2(I),I=1,IRK10) 13 WRITE(IWRITE,1020) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 C C GENERATE THE CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS AND C STORE ON TAPE. HANDLE NBUG7=1 AS BEFORE C 14 WRITE(IWRITE,1010) DO 17 L=1,LRANG2 LM=L-1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 15 CALL GEN1CC(L) IF(NBUG7.NE.1) GO TO 16 WRITE(IWRITE,1011) IRK7,LM,IDMTST(21) 15 IF(NBUG7.EQ.1) GO TO 17 READ(ITAPE2) IRK7 IF(IRK7.GT.IDMTST(21)) CALL RECOV1(21,IRK7) READ(ITAPE2) (ONEST3(I),I=1,IRK7) IF (IRELOP(1).GT.0) READ(ITAPE2) (RMASS3(I),I=1,IRK7) IF (IRELOP(3).GT.0 .AND. L.GT.1) READ(ITAPE2) (RSPOR3(I),I=1,IRK7) IF (IRELOP(2).EQ.0 .OR. L.GT.1) GO TO 16 READ(ITAPE2) (RDAR3(I),I=1,IRK7) 16 WRITE(IWRITE,1018) IRK7,LM WRITE(ITAPE3)IRK7 WRITE(ITAPE3)(ONEST3(I),I=1,IRK7) IF (IRELOP(1).GT.0) WRITE(ITAPE3) (RMASS3(I),I=1,IRK7) IF (IRELOP(3).GT.0 .AND. L.GT.1) WRITE(ITAPE3)(RSPOR3(I),I=1,IRK7) IF (IRELOP(2).EQ.0.OR.L.GT.1) GO TO 17 WRITE(ITAPE3) (RDAR3(I),I=1,IRK7) 17 CONTINUE IF(NBUG7.EQ.1) GO TO 19 WRITE(IWRITE,1020) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 C C GENERATE THE BOUND-BOUND RK AND MK INTEGRALS AND STORE ON TAPE C SET NBUG7=1 IF RK ARRAY SIZES EXCEEDED C 19 WRITE(IWRITE,1012) I1=LRANG1*LRANG1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 20 CALL GENBB IF(NBUG9.EQ.1) WRITE(IWRITE,1091) TEST1 TEST1=0. ITAPE = ITAPE3 IF(NBUG7.NE.1) GO TO 21 WRITE(IWRITE,1013) IRK1,IDMTST(1),IRK4,IDMTST(4) 20 IF(NBUG7.EQ.1) GO TO 22 READ(ITAPE2) IRK1,IRK4 READ(ITAPE2) (((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), * (ISTBB1(I),I=1,IRK4),(ISTBB2(I),I=1,IRK4) * ,(RKSTO1(I),I=1,IRK1) 21 WRITE(ITAPE) IRK1,IRK4 IF(IRK1.GT.IDMTST(1)) CALL RECOV1(1,IRK1) IF(IRK4.GT.IDMTST(4)) CALL RECOV1(4,IRK4) WRITE(ITAPE)(((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), * (ISTBB1(I),I=1,IRK4), * (ISTBB2(I),I=1,IRK4), (RKSTO1(I),I=1,IRK1) IF(ITAPE.EQ.ITAPE4) GO TO 22 WRITE(IWRITE,1020) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 IF (NMIN(0).LE.0) GO TO 22 ! magnetic 2-body case: NBUG=0 CALL GEN2BB C IF(NBUG.NE.0) print warning! IRK1=INK1 IRK4=INK4 ITAPE = ITAPE4 OPEN(UNIT=ITAPE,FILE='MK_seq',STATUS='UNKNOWN',FORM='UNFORMATTED' * ,ACCESS='SEQUENTIAL') PRINT "(I9,' BB INTEGRALS MK WRITTEN ON UNIT',I5)", IRK1,ITAPE WRITE(ITAPE) -IZESP,NELC,NZ,LRANG3,(NMIN(I),I=0,LRANG1-1) GO TO 21 C C GENERATE THE BOUND-CONTINUUM MK INTEGRALS AND STORE ON TAPE C HANDLE NBUG7=1 AS IN BB CASE C 22 IF(LRANG2.EQ.0) GO TO 38 WRITE(IWRITE,1014) IREC2=1 IRECB=0 I1=MIN(LRANG2,(LRANG1-1)*3+1)*LRANG1 TYPE = 'RK' ITAPE = ITAPE3 IDIAC = JDISC1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 23 CALL GENBC IF(NBUG9.EQ.1) WRITE(IWRITE,1091) TEST1 TEST1=0. IF(NBUG7.NE.1) GO TO 24 WRITE(IWRITE,1015) IRK2,IDMTST(2),IRK3,IDMTST(3) 23 IF(NBUG7.EQ.1) GO TO 25 READ(ITAPE2) IRK2,IRK3 IF(IRK2.GT.IDMTST(2)) CALL RECOV1(2,IRK2) IF(IRK3.GT.IDMTST(3)) CALL RECOV1(3,IRK3) READ(ITAPE2) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), * (ISTBC1(I),I=1,IRK3),(ISTBC2(I),I=1,IRK3) CALL DA2('RK',1,IREC2,JDISC2,IRK2,RKSTO2) 24 WRITE(ITAPE) IRK2,IRK3 WRITE(ITAPE) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), * (ISTBC1(I),I=1,IRK3),(ISTBC2(I),I=1,IRK3) CALL DA2(TYPE,2,IRECB,IDIAC,IRK2,RKSTO2) WRITE(IWRITE,1020) ICOUNT IF(ITAPE.EQ.ITAPE4) GO TO 25 IRECM=IRECB IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 IF(NMIN(0).LE.0) GO TO 25 NBUG = NBUG7 CALL GEN2BC IRK2=INK1 IRK3=INK4 TYPE = 'MK_dir' IDIAC = IDISC3 ITAPE = ITAPE4 IRECB = 0 I1 = ABS(LRANG3)*LRANG1 ! not MIN(LRANG3,(LRANG1-1)*3+1)*LRANG1 print "(I8,' BC INTEGRALS MK STORED ON UNIT',I5)", INK1,IDIAC GO TO 24 C C ENTER LOOP TO GENERATE ALL THE NON-ZERO CONTINUUM-CONTINUUM C INTEGRALS FOR EACH CONTINUUM ANGULAR MOMENTUM L AND LP C AND STORE ON TAPE C C IF THE NUMBER IRK2 OF INTEGRALS RK TO BE STORED IN ARRAY RKSTO2 C FOR A GIVEN L AND LP COMBINATION EXCEEDS THE LENGTH IDMTST(2) C OF RKSTO2, THEN IRK2 IS SET EQUAL TO -IDMTST(2) AND WRITTEN OUT C WITH THE FIRST IDMTST(2) INTEGRALS; THE RKSTO2 ARRAY IS THEN C OVERWRITTEN WITH FURTHER INTEGRALS FOR THE L AND LP COMBINATION: C LOOPCC IS THE NUMBER OF TIMES THE RKSTO2 ARRAY IS OVERWRITTEN. C 25 WRITE(IWRITE,1016) (LIMEX(I),I=0,LPR) L=0 26 LP=L 27 LOOPCC=0 ITAPE = ITAPE3 IDIAC = JDISC1 IRECL = IRECM TYPE = 'RK' I0 = 1 28 IF(NBUG7.EQ.1) GO TO 30 I1=MIN(2*LRANG1-1,L+LP+1) I2=MIN(L,LP)+LRANG1 IF(ICOUNT.GE.ICOPY1.AND.ICOUNT.LE.ICOPY2) GO TO 31 29 CALL SKIPER(L+1,LP+1) 30 CALL GENCC(L,LP) IF(NBUG9.EQ.1) WRITE(IWRITE,1091) TEST1 TEST1=0. JRK2=IRK2 IRK2=ABS(JRK2) IF(NBUG7.NE.1) GO TO 33 WRITE(IWRITE,1017) IRK2,L,LP,IDMTST(2) 31 IF(NBUG7.EQ.1) GO TO 36 IF(L.GE.LINPUT.OR.LP.GE.LINPUT) GO TO 29 32 READ(ITAPE2) JRK2,L,LP IRK2=ABS(JRK2) IF(IRK2.GT.IDMTST(2)) CALL RECOV1(2,IRK2) IF(IRK2.EQ.0) GO TO 33 IF(JRK2.GT.0) * READ(ITAPE2) (((ICTCCD(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), * (((ICTCCE(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I2) CALL DA2('RK',1,IREC2,JDISC2,IRK2,RKSTO2) 33 WRITE(IWRITE,1019)JRK2,L,LP 34 WRITE(ITAPE) JRK2,L,LP, IRECL,I1,I2 !, (irecl,i1,i2,I=I0,0) IF(IRK2.EQ.0) GO TO 35 IF(JRK2.GT.0) * WRITE(ITAPE) (((ICTCCD(I,J,K),I=1,LRANG1),J=1,LRANG1),K=I0,I1), * (((ICTCCE(I,J,K),I=1,LRANG1),J=1,LRANG1),K=I0,I2) CALL DA2(TYPE,2,IRECL,IDIAC,IRK2,RKSTO2) 35 IF(I0.EQ.0) GO TO 36 IRECM = IRECL WRITE(IWRITE,1020) ICOUNT IF(ICOUNT.GE.ITOTAL) GO TO 38 ICOUNT=ICOUNT+1 LOOPCC=LOOPCC+1 IF(JRK2.LT.0) GO TO 28 36 IF(NMIN(0).GT.0 .AND. MAX(L,LP).LT.ABS(LRANG3)) THEN IF(I0.NE.0) THEN NBUG = NBUG7 CALL GEN2CC(L,LP) JRK2 = IRK2 TYPE = 'MK_dir' ITAPE = ITAPE4 IDIAC = IDISC3 IRECL = IRECB C I2 = I1 ! WHEN EXCHANGE-LAMBDA REDUCED BY MIN(L,LP) IN ADDRESS I0 = 0 GO TO 34 ENDIF print "(I9,' CC INTEGRALS MK STORED ON UNIT',I5)", IRK2,IDIAC IF(NBUG.NE.0) print "(11X,'NBUG =',I3)",NBUG IRECB = IRECL ELSE IF(JRK2.EQ.0.AND.ICHECK.EQ.0) GO TO 37 ENDIF LP=LP+1 IF(LP.LT.LRANG2) GO TO 27 37 L=L+1 IF(L.LT.LRANG2) GO TO 26 C C INTEGRAL EVALUATION IS COMPLETE C 38 IF(NBUG7.NE.INBUG7) IPLACE=1 IF(NBUG7.EQ.1) RETURN IF(ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE(IWRITE,1021) (LIMEX(I),I=1,NRANG2) RETURN END C*********************************************************************** SUBROUTINE GENMBB C C GENERATES ALL THE BOUND-BOUND MULTIPOLE INTEGRALS INCLUDING C BUTTLE CORRECTION TYPE DIPOLE INTEGRALS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL68= 8/2) COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), 1 ICCPOL( 49, 49,LL68) COMMON/JNSTO/ SKSTO2(50000),BNORM( 49),JRK8,JBCPOL( 5, 49), * JCCPOL( 49, 49) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LM0 COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE ARRAYS C DO 1 K=1,LAMIND DO 1 J=1,LRANG1 DO 1 I=1,LRANG1 1 IBBPOL(I,J,K)=0 IF(LAMAX.EQ.0) RETURN C C LOOP OVER ANGULAR MOMENTA L1, L2; AND FOR EACH POSSIBLE C LAM, LOOP OVER PRINCIPLE QUANTUM NUMBERS N1, N2. C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C DO 10 L1=1,LRANG1 IF(MAXNC(L1).EQ.MAXNHF(L1)) GO TO 10 DO 9 L2=L1,LRANG1 NST=MAXNHF(L2) IF(MAXNC(L2).EQ.NST) GO TO 9 LAMST=0 LAM1=L2-L1 IF(LAM1.GT.MIN(LAMAX,L1+L2-2)) GO TO 9 C DO 8 LAM=LAM1,MIN(LAMAX,L1+L2-2),2 IF(LAM.EQ.0) GO TO 8 LAMST=LAMST+1 IBBPOL(L1,L2,LAMST)=IRK8+1 C DO 4 N1=MAXNC(L1)+1,MAXNHF(L1) IF(L1.EQ.L2) NST=N1 C DO 5 N2=MAXNC(L2)+1,NST IRK8=IRK8+1 IF(IRK8.GE.IDMTST(2)) NBUG7=1 IF(NBUG7.NE.1) THEN CALL RADINT(N1,L1,N2,L2,LAM,X1) RKSTO2(IRK8)=X1 IF(LAM.EQ.1) THEN IRK8=IRK8+1 CALL DERINT(N1,L1,N2,L2,X1) RKSTO2(IRK8)=X1 ENDIF ELSE IF(LAM.EQ.1) THEN IRK8=IRK8+1 ENDIF 5 CONTINUE 4 CONTINUE C 8 CONTINUE 9 CONTINUE 10 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE GENMBC C C EVALUATES ALL THE BOUND-CONTINUUM MULTIPOLE INTEGRALS C INCLUDING BUTTLE CORRECTION TYPE DIPOLE INTEGRALS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL68= 8/2) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), 1 ICCPOL( 49, 49,LL68) COMMON/JNSTO/ SKSTO2(50000),BNORM( 49),JRK8,JBCPOL( 5, 49), * JCCPOL( 49, 49) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LM0 COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE ARRAYS C DO 1 K=1,LAMIND DO 1 J=1,LRANG2 DO 1 I=1,LRANG1 1 IBCPOL(I,J,K)=0 IF(LAMBC.EQ.0) GO TO 7 C DO 2 J=1,LRANG2 DO 2 I=1,LRANG1 2 JBCPOL(I,J)=0 C C LOOP OVER ANGULAR MOMENTA L1, L2; AND FOR EACH POSSIBLE LAM, C LOOP OVER PRINCIPLE QUANTUM NUMBERS N1, N2. C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C DO 10 L2=1,LRANG2 IF(NBUG7.NE.1) CALL SKIPER(L2,0) DO 9 L1=1,LRANG1 IF(MAXNC(L1).EQ.MAXNHF(L1)) GO TO 9 LAMST=0 LAM1=ABS(L1-L2) IF(LAM1.EQ.1) JBCPOL(L1,L2)=JRK8+1 IF(LAM1.GT.MIN(LAMBC,L1+L2-1)) GO TO 9 C DO 4 LAM=LAM1,MIN(LAMBC,L1+L2-1),2 IF(LAM.EQ.0) GO TO 4 LAMST=LAMST+1 IBCPOL(L1,L2,LAMST)=IRK8+1 C DO 5 N1=MAXNC(L1)+1,MAXNHF(L1) DO 6 N2=1,NRANG2 N3=MAXNHF(L2)+N2 IRK8=IRK8+1 IF(IRK8.GE.IDMTST(2)) NBUG7=1 IF(NBUG7.NE.1) THEN CALL RADINT(N1,L1,N3,L2,LAM,X1) RKSTO2(IRK8)=X1 IF(LAM.EQ.1) THEN IRK8=IRK8+1 CALL DERINT(N1,L1,N3,L2,X1) RKSTO2(IRK8)=X1 ENDIF ELSE IF(LAM.EQ.1) THEN IRK8=IRK8+1 ENDIF 6 CONTINUE C IF(LAM.NE.1) GO TO 5 C C CALCULATE DIPOLE INTEGRAL BETWEEN A BOUND TYPE ORBITAL AND A C BUTTLE CORRECTION TYPE FUNCTION AND STORE IN ARRAY SKSTO2. C JRK8=JRK8+2 IF(JRK8.GT.IDMTST(29)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 5 N3=N3+1 CALL RADINT(N1,L1,N3,L2,LAM,X1) SKSTO2(JRK8-1)=X1 CALL DERINT(N1,L1,N3,L2,X1) SKSTO2(JRK8)=X1 5 CONTINUE 4 CONTINUE C 9 CONTINUE 10 CONTINUE C 7 RETURN END C*********************************************************************** SUBROUTINE GENMCC C C GENERATES ALL THE CONTINUUM-CONTINUUM MULTIPOLE INTEGRALS C INCLUDING BUTTLE CORRECTION TYPE DIPOLE INTEGRALS C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MWK= 60*2) PARAMETER (LL68= 8/2) DIMENSION WKSP(MWK) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON/INSTO2/RKSTO1(4000),RKSTO2(1180800), 1 ONEST1( 56),ONEST2( 600),ONEST3(1830), 2 RMASS1( 56),RMASS2( 600),RMASS3(1830), 3 RDAR1( 25),RDAR2(210),RDAR3(1830) COMMON/INSTO4/IBBPOL( 5, 5,LL68),IBCPOL( 5, 49,LL68), 1 ICCPOL( 49, 49,LL68) COMMON/JNSTO/ SKSTO2(50000),BNORM( 49),JRK8,JBCPOL( 5, 49), * JCCPOL( 49, 49) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LM0 COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C C ZEROIZE ARRAYS C DO 1 K=1,LAMIND DO 1 J=1,LRANG2 DO 1 I=1,LRANG2 1 ICCPOL(I,J,K)= 0 IF(LAMCC.EQ.0) RETURN C DO 2 J=1,LRANG2 DO 2 I=1,LRANG2 2 JCCPOL(I,J)=0 C C LOOP OVER ANGULAR MOMENTA L1 AND L2, AND FOR EACH POSSIBLE LAM C LOOP OVER PRINCIPLE QUANTUM NUMBERS N1 AND N2. C DO 10 L1=1,LRANG2 JWK=0 DO 9 L2=L1,LRANG2 IF(NBUG7.NE.1) CALL SKIPER(L1,L2) LAMST=0 LAM1=L2-L1 IF(LAM1.EQ.1) JCCPOL(L1,L2)=JRK8+1 IF(LAM1.GT.MIN(LAMCC,L1+L2-2)) GO TO 9 NST=NRANG2 C DO 4 LAM=LAM1,MIN(LAMCC,L1+L2-2),2 IF(LAM.EQ.0) GO TO 4 LAMST=LAMST+1 ICCPOL(L1,L2,LAMST)=IRK8+1 C DO 6 N1=1,NRANG2 N1P=MAXNHF(L1)+N1 IF(L1.EQ.L2) NST=N1 C DO 5 N2=1,NST N2P=MAXNHF(L2)+N2 IRK8=IRK8+1 IF(IRK8.GE.IDMTST(2)) NBUG7=1 IF(NBUG7.NE.1) THEN CALL RADINT(N1P,L1,N2P,L2,LAM,X1) RKSTO2(IRK8)=X1 IF(LAM.EQ.1) THEN IRK8=IRK8+1 CALL DERINT(N1P,L1,N2P,L2,X1) RKSTO2(IRK8)=X1 ENDIF ELSE IF(LAM.EQ.1) THEN IRK8=IRK8+1 ENDIF 5 CONTINUE C IF(LAM.NE.1) GO TO 6 C C CALCULATE DIPOLE INTEGRAL BETWEEN A CONTINUUM TYPE ORBITAL AND A C BUTTLE CORRECTION TYPE FUNCTION AND STORE IN ARRAY SKSTO2. C JRK8=JRK8+2 IF(JRK8.GT.IDMTST(29)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 6 N2P=N2P+1 CALL RADINT(N1P,L1,N2P,L2,LAM,X1) SKSTO2(JRK8-1)=X1 CALL DERINT(N1P,L1,N2P,L2,X1) SKSTO2(JRK8)=X1 C C ALSO EVALUATE THE CORRESPONDING LOWER TRIANGLE C N1P=MAXNHF(L2)+N1 N2P=MAXNHF(L1)+NRANG2+1 JWK=JWK+1 CALL RADINT(N1P,L2,N2P,L1,LAM,X1) WKSP(JWK)=X1 CALL DERINT(N1P,L2,N2P,L1,X1) JWK=JWK+1 WKSP(JWK)=X1 6 CONTINUE 4 CONTINUE 9 CONTINUE IF(L1.EQ.LRANG2) GO TO 16 C C EVALUATE DIPOLE INTEGRAL BETWEEN TWO BUTTLE TYPE FUNCTIONS C JRK8=JRK8+2 IF(JRK8+JWK.GT.IDMTST(29)) NBUG7=1 IF(NBUG7.EQ.1) GO TO 15 L2=L1+1 CALL SKIPER(L1,L2) N1=MAXNHF(L1)+NRANG2+1 N2=MAXNHF(L2)+NRANG2+1 CALL RADINT(N1,L1,N2,L2,1,X1) SKSTO2(JRK8-1)=X1 CALL DERINT(N1,L1,N2,L2,X1) SKSTO2(JRK8)=X1 C C FILL UP THE LOWER TRIANGLE AND UPDATE POINTER C JCCPOL(L2,L1)=JRK8+1 DO 14 J=1,JWK 14 SKSTO2(JRK8+J)=WKSP(J) 15 JRK8=JRK8+JWK C C FINALLY CALCULATE THE NORMALIZATION FOR BUTTLE FUNCTION L1-1. C 16 CALL ABNORM(MAXNHF(L1)+NRANG2+1,L1,MAXNHF(L1)+NRANG2+1,L1,OVRLP) 10 BNORM(L1)=OVRLP C RETURN END C*********************************************************************** SUBROUTINE LSQ(P,Q,C,N) C C LEAST SQUARE FITS N POINTS: C C IMPLICIT REAL*8(A-H,O-Z) DIMENSION P(N),Q(N),X(3,3),C(3) CC601 FORMAT('0X(I,J) =',3F14.7,' C(J) =',F14.7/) C C ROUTINE REPLACED WITH OP VERSION WE'90MAY15 X(1,1)=N DO 100 I=1,3 C(I)=0.0 L=I-1 IF(L.NE.0) GO TO 106 DO 107 K=1,N 107 C(I)=C(I)+Q(K) GO TO 103 106 DO 104 K=1,N 104 C(I)=C(I)+(P(K)**L)*Q(K) 103 DO 101 J=1,3 L=I+J-2 IF(L.EQ.0) GO TO 101 X(I,J)=0.0 DO 102 K=1,N 102 X(I,J)=X(I,J)+P(K)**L 101 CONTINUE CC WRITE(6,601)(X(I,J),J=1,3), C(I) 100 CONTINUE C CALL MA01A(X,C,3,1,0,3,1) C C RETURN END C********************************************************************* C SUBROUTINE MA01A(A,B,M,N,M1,IA,IB) C C SOLVES SIMULTANEOUS EQUATIONS OR INVERTS A MATRIX C C C A THE M*M MATRIX OF LEFT HAND SIDES OR THE MATRIX BEING C INVERTED. OVERWRITTEN ON EXIT BY THE INVERSE MATRIX C C B THE M*N MATRIX OF THE RIGHT HAND SIDES. OVERWRITTEN C ON EXIT BY SOLUTIONS C C M THE ORDER OF THE A-MATRIX. THIS MUST NOT BE GREATER C THAN THE DIMENSION OF THE C AND IND ARRAYS. THE UPPER C LIMIT CAN BE EXTENDED BY RECOMPILING WITH LARGER C DIMENSIONS FOR THE PRIVATE ARRAYS C AND IND C C N THE NUMBER OF THE RIGHT HAND SIDES IN THE C SIMULTANEOUS EQUATIONS C C M1 =0 ONLY SIMULTANEOUS EQUATIONS ARE SOLVED IF N.GT.0 C IF N=0 A FURTHER ENTRY TO MA01A WITH M1.LT.0 C REQUIRED TO OBTAIN THE INVERSE OF A C .GT.0 MATRIX INVERSION. IN ADDITION SIMULTANEOUS C EQUATIONS ARE SOLVED IF N.GT.0 C .LT.0 ONLY USED IF PREVIOUS ENTRY TO MA01A C WITH M1=0. IN THIS CASE THE MATRIX INVERSION IS C COMPLETED C C IA DEFINES THE DIMENSIONS OF THE ARRAY WHERE C THE A-MATRIX IS STORED C C IB DEFINES THE SECOND DIMENSION OF THE ARRAY WHERE C B-MATRIX IS STORED C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL92= 7+3, ONE=1.) DIMENSION A(IA,IA),B(IA,IB),C(LL92),IND(LL92) C MM=M-1 IF(M1.LT.0) GO TO 32 C C CHECK FOR ZERO DIAGONAL ELEMENTS C IF(MM.LT.0) GO TO 55 DO 3 I=1,M IF(A(I,I).EQ.0.0) A(I,I)=1.0E-37 3 CONTINUE C C DO THE TRIVIAL CASE OF A 1*1 MATRIX C IF(MM) 55,4,7 4 IF(N-1) 5,6,7 5 A(1,1)=ONE/A(1,1) GO TO 55 6 B(1,1)=B(1,1)/A(1,1) GO TO 5 C C THIS IS NOT A TRIVIAL CASE C C FIND THE FIRST PIVOTAL ELEMENT AND STORE THE CORRESPONDING ROW C NUMBER IN I4. IND DEFINES THE ORDER OF THE ROWS OF THE ORIGINAL C A-MATRIX BEFORE ROW INTERCHANGE C 7 AMAX=0.0 DO 9 I=1,M IND(I)=I IF(ABS(A(I,1)).LE.AMAX) GO TO 9 AMAX=ABS(A(I,1)) I4=I 9 CONTINUE C C EACH TIME THROUGH THE FOLLOWING LOOP THE A-MATRIX IS C REDUCED BY ONE C IF(MM.LE.0) GO TO 24 DO 23 J=1,MM C C INTERCHANGE THE I4TH AND THE JTH ROWS OF THE A-MATRIX AND STORE C ORDER IN IND IF I4 .NE.J C IF(I4.LE.J) GO TO 15 ISTO=IND(J) IND(J)=IND(I4) IND(I4)=ISTO DO 12 K=1,M STO=A(I4,K) A(I4,K)=A(J,K) 12 A(J,K)=STO C C INTERCHANGE THE I4TH AND THE JTH ROWS OF THE B-MATRIX IF N.GT. 0 C IF(N.LE.0) GO TO 15 DO 14 K=1,N STO=B(I4,K) B(I4,K)=B(J,K) 14 B(J,K)=STO C C THE JTH ROW NOW CONTAINS THE PIVOTAL ELEMENT IN THE JTH POSITION C ELIMINATE THE JTH ELEMENT FROM EACH OF THE REMAINING ROWS OF THE C A-MATRIX AND THE B-MATRIX AND STORE THE MULTIPLIERS IN THE LOWER C TRIANGLE C 15 AMAX=0.0 J1=J+1 DO 22 I=J1,M A(I,J)=A(I,J)/A(J,J) DO 18 K=J1,M A(I,K)=A(I,K)-A(I,J)*A(J,K) IF(K.GT.J1) GO TO 18 C FIND THE NEXT PIVOTAL ELEMENT AND STORE THE CORRESPONDING ROW C NUMBER IN I4 IF(ABS(A(I,K)).LE.AMAX) GO TO 18 AMAX=ABS(A(I,K)) I4=I 18 CONTINUE 19 IF(N.LE.0) GO TO 22 DO 21 K=1,N 21 B(I,K)=B(I,K)-A(I,J)*B(J,K) 22 CONTINUE 23 CONTINUE C C THE ELIMINATION IS NOW COMPLETE AND THE A-MATRIX HAS BEEN C REDUCED TO THE PRODUCT OF AN UPPER AND LOWER TRIANGLE MATRIX C 24 IF(N.LE.0) GO TO 31 C C NOW CARRY OUT THE BACK SUBSTITUTION AND STORE RESULT IN THE C B-MATRIX IF THERE IS AT LEAST ONE RIGHT HAND SIDE C DO 30 I1=1,M I=M+1-I1 if(A(i,i).eq.0.) STOP " stop: MA01A dividing by A(i,i)=0." DO 28 J=1,N IF(M.LE.I) GO TO 28 I2=I+1 DO 27 K=I2,M 27 B(I,J)=B(I,J)-A(I,K)*B(K,J) 28 B(I,J)=B(I,J)/A(I,I) 30 CONTINUE 31 IF(M1.LE.0) GO TO 55 C C REPLACE THE A-MATRIX BY ITS INVERSE WHEN M1.NE.0 C C FIRST INVERT THE LOWER TRIANGLE MATRIX AND STORE ON ITSELF C 32 IF(MM.LE.0) GO TO 40 DO 39 I1=1,MM I=M+1-I1 I2=I-1 DO 36 J1=1,I2 J=I2+1-J1 J2=J+1 W1=-A(I,J) IF(I2.LT.J2) GO TO 36 DO 35 K=J2,I2 35 W1=W1-A(K,J)*C(K) 36 C(J)=W1 DO 38 K=1,I2 38 A(I,K)=C(K) 39 CONTINUE C C NOW INVERT THE UPPER TRIANGLE MATRIX AND FORM THE ORIGINAL C A-MATRIX APART FROM COLUMN INTERCHANGE. THIS OVERWRITES THE C ORIGINAL A-MATRIX C 40 DO 50 I1=1,M I=M+1-I1 I2=I+1 W=ONE/A(I,I) DO 47 J=1,M IF(I-J) 41,42,43 41 W1=0.0 GO TO 44 42 W1=ONE GO TO 44 43 W1=A(I,J) 44 IF(I1.EQ.1) GO TO 47 DO 46 K=I2,M 46 W1=W1-A(I,K)*A(K,J) 47 C(J)=W1 DO 49 J=1,M 49 A(I,J)=C(J)*W 50 CONTINUE C C RE-ORDER THE COLUMNS OF THE INVERSE A-MATRIX TO COINCIDE WITH C THE ORDER OF THE ROWS OF THE A-MATRIX ON INPUT C DO 54 I=1,M 51 IF(IND(I).EQ.I) GO TO 54 J=IND(I) DO 53 K=1,M STO=A(K,I) A(K,I)=A(K,J) 53 A(K,J)=STO ISTO=IND(J) IND(J)=J IND(I)=ISTO GO TO 51 54 CONTINUE C 55 RETURN END C C******************************************************************** C SUBROUTINE MESH C C AUTOMATICALLY GENERATES THE INTEGRATION MESH, C ON THE BASIS OF THE NUCLEAR BEHAVIOUR OF BOUND ORBITALS, C THE NUMBER OF CONTINUUM ORBITAL LOOPS AND THE CURRENT ARRAY SIZES C C IMPLICIT REAL*8(A-H,O-Z) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) C DATA MINFAC,MAXFAC/1,2/, MSHDIM/16/ 1001 FORMAT(/ '0TO SATISFY INTEGRATION MESH CONDITIONS NRANG2 SHOULD BE * REDUCED BELOW',I3/' RECOMPILE IF THIS IS UNDESIRABLE:') C C NCORSE=NRANG2*MSHDIM -- '96QUB HIGH L FIX - NOT HELPING SS INPUT! NCORSE=(LRANG2/2-1+NRANG2)*MSHDIM IF (NCORSE .LT. 96) NCORSE=96 C C CALCULATE THE COARSEST MESH, HMAX, AND THE MESH REQUIRED C NEAR THE ORIGIN. CALCULATE HMIN = HMAX/2**M WHERE M+1 IS C THE NUMBER OF STEP SIZES C HMAX=RA/NCORSE HINNER=.025/NZ DELTA=HINNER/5. M=0 HMIN=HMAX 1 IF (HMIN .GT. HINNER+DELTA) THEN M=M+1 HMIN=HMIN/2 GO TO 1 END IF C HINT=HMIN NIX=M+1 IF (NIX .GT. 9) CALL RECOV1(17,NIX) C C SET UP THE IHX ARRAY C IH=1 DO 2 I=1,NIX IHX(I)=IH 2 IH=IH+IH C C CONSIDER SEPARATELY M .LT. 4 AND M .GE. 4 C NA IS THE NUMBER OF STEPS AT EACH STEP SIZE C IT IS A MULTIPLE OF 16 AND CAN TAKE VALUES C FROM 16*MAXFAC DOWN TO 16*MINFAC C MPOW2=2**M NAFAC=MAXFAC C '91JUL19 - L.9 FOR ALL FOLLOWING L27: IF (M .GE. 4) THEN 3 NA=16*NAFAC NTOT=NCORSE+(M-1)*NA+NA/8 IF (NTOT .GE. 1999) THEN NAFAC=NAFAC-1 IF (NAFAC .GE. MINFAC) GO TO 3 END IF C C SET UP IRX ARRAY C IRX(2)=NA+NA IRX(3)=NA+IRX(2) IRX(4)=NA+NA/8+IRX(3) IA=5 C ELSE C 4 NA=16*NAFAC NTOT=NCORSE+M*NA-NA*(MPOW2-1)/MPOW2 IF (NTOT .GE. 1999) THEN NAFAC=NAFAC-1 IF (NAFAC .GE. MINFAC) GO TO 4 END IF IA=2 C END IF C C FILL IRX ARRAY C IRX(1)=NA DO 5 I=IA,NIX-1 5 IRX(I)=NA+IRX(I-1) C IF (NAFAC .GE. MINFAC) GO TO 6 NA=(((1-M)*MINFAC*16 +IDMTST(9))*MPOW2 -MINFAC*16)*NRANG2 *HMIN/RA WRITE(IWRITE,1001) NA CALL RECOV1( 9,NTOT) NTOT=NTOT-2 C C NUMBER OF STEPS AT EACH STEP SIZE MUST BE EVEN C 6 IF (MOD(NTOT,2) .NE. 0) THEN NTOT=NTOT+1 IRX(NIX-1)=IRX(NIX-1)+2 END IF C IRX(NIX)=NTOT C C PERFORM CHECK C IF(NBUG5.NE.1) GO TO 9 RVAL=0.0 IR=0 DO 7 I=1,NIX RVAL=RVAL+HINT*(IRX(I)-IR)*IHX(I) 7 IR=IRX(I) WRITE(IWRITE,'(/'' RVAL ='',E14.7)')RVAL C 9 RETURN END C*********************************************************************** SUBROUTINE NAME(CODE,JBC,MXXE,MCB) C C NEW VERSION OF STG1RD TO READ DATA FROM NAMELIST, C ALSO NEW FACILITIES TO READ ORBITALS DIRECT FROM STRUCTURE CODES. C C IF CODE CONTAINS THE CHARACTERS CIV3 OR S.S., THEN THE BOUND C ORBITALS ARE SUPPLIED BY A CIV3 OR SUPERSTRUCTURE FILE. C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 CODE,COD(3) PARAMETER(LL71= 60+1, THIRD=1./3., PI=3.1415926) DIMENSION ISMIT( 25) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/INSTO7/NNNBUG,INK1,INK4,LRANG3,NMIN(0: 5) COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM C COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/NBUG/ NBUG(9) COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) COMMON/SPZETA/ZESP( 5),IZESP NAMELIST/STG1/MAXLS,MAXPW,MAXE,IOUT,IOUTDA,INDATA,IPSEUD,ICOPY, * IPRINT,IZESP,LRANG3,KRELOP,LAM,LAMAX,MAXC,IBC,LCB,ISMIT,LIMEX C DATA COD/'CIV3','S.S.','STO-'/ 1100 FORMAT(/' STG1 PARAMETERS (THE FIRST 3 ARE MANDATORY)'// 1' MAXLS = MAXIMUM ANGULAR MOMENTUM OF N-ELECTRON TARGET STATES'/ C NO 2' MAXPW = MAXIMUM ANGULAR MOMENTUM OF PARTIAL WAVES'/ *' MAXPW = MAXIMUM ANGULAR MOMENTUM OF (N+1) ELECTRON SYMMETRIES'/ 3' MAXE = MAXIMUM ENERGY IN RYD OF SCATTERED ELECTRON' //' THE FO 4LLOWING PARAMETERS ARE OPTIONAL (DEFAULT VALUES IN PARENTHESIS)'// 5' IOUT = OUTPUT CHANNEL NUMBER FOR STG1 INTEGRALS (',I3,')'/ 5' IOUTDA= DA OUTPUT CHANNEL NUMBER FOR STG1 INTEGRALS (',I3,')'/ 6' INDATA= INPUT CHANNEL NUMBER FROM ',A4,16X, '(',I3,')'/ 7' IPSEUD= 1 INDICATES USE OF CORE POTENTIAL POTHAM (',I3,')'/ 9' ICOPY = TAPE POSITION REACHED BY PREVIOUS RUN OF STG1 (',I3,')'/ *' IPRINT= 0-777 FOR DEBUG LEVEL: = 4 FOR DIMENSION TEST (',I3,')'/ C *' IZESP < 0: STOP BLUME WATSON SCREENING BEFORE |IZESP| (',I3,')'/ *' IZESP < 0: |"| = INDEX OF FIRST VALENCE ORBITAL (BW!) (',I3,')'/ *' KRELOP= ...7 FOR INCLUSION OF 1-BODY BP TERMS M,D,S-O (',I3,')'/ 3' LAM = 1 FOR E-COLLISIONS, =3 FOR DIPOLE MATRIX ALSO (',I3,')'/ *' LRANG3-1 = L RANGE FOR MAGNETIG INTEGRALS, .LE.LRANG2 (',I3,')'/ 4' MAXC - INCREASING NRANG2 CONSISTENT WITH MAXE AND RA (',I3,')'/ 5' IBC = NONZERO FOR RA,BSTO, NIX, NPOT EXPLICITLY READ(',I3,')'/ *' LCB = MAX L+1 FOR TREATING CONTINUUM ORBS AS BOUND (',I3,')'/ 6' ISMIT = ARRAY CONTAINING 10*N+L OF CORRELATION ORBTLS (NIL)') 1101 FORMAT(/' DEFINITION OF STG1 PARAMETERS FOR THIS RUN ...'/ 1/20X,'MAXLS =',I3/20X,'MAXPW =',I3/20X,'MAXE =',I4/ 2/20X,'IOUT =',I3/20X,'IOUTDA=',I3/20X,'INDATA=',I3 3/20X,'IPSEUD=',I3/20X,'ICOPY =',I3/20X,'IPRINT=',I3 */20X,'IZESP =',I3/20X,'KRELOP=',I3/20X,'LAM =',I3 4/20X,'LAMAX =',I3/20X,'LRANG3=',I3/20X,'MAXC =',I3/20X,'IBC =', * I3/20X,'LCB =',I3/20X,'LIMEX =',I3/20X,'ISMIT =',(T28,I3)) 1102 FORMAT(/' ORBITALS ARE DEFINED AS IN ',A4) C C2000 FORMAT(12I5) C2001 FORMAT(5F14.7) C C INITIALIZE THE PARAMETERS IN NAMELIST/STG1/ C WRITE(IWRITE,1102) CODE MAXLS =0 MAXPW =999 MAXE =9999 IOUT =2 IOUTDA=12 INDATA=5 IPSEUD=0 ICOPY =0 IPRINT=0 IZESP =0 KRELOP=0 LAMAX =0 MAXC =0 LAM =3 IBC =0 LCB=0 DO 1 I=1, 25 1 ISMIT(I)=0 WRITE(IWRITE,1100) IOUT,IOUTDA,CODE,INDATA,IPSEUD,ICOPY,IPRINT, * IZESP,KRELOP,LAM,LRANG3, MAXC,IBC,LCB C C READ NAMELIST PARAMETERS FROM DATA, AFTER READING ANY CIV3 DATA C IF(CODE.EQ.'CIV3') CALL CIV3 READ(IREAD,STG1) ILIM=0 DO 9 I=1, 25 IF(ISMIT(I).GT.0) ILIM=I 9 CONTINUE C IF(LAMAX.LT.0)LAMAX=3 BECAUSE OF RECUP'90MAY15, '91AUG13 RESTORED: C COR IF(LAMAX.LT.0) LAMAX=2*MAXLS -- SEE PAST LABEL 50 NOW, RUB'94JUN17 WRITE(IWRITE,1101)MAXLS,MAXPW,MAXE,IOUT,IOUTDA,INDATA,IPSEUD,ICOPY * ,IPRINT,IZESP,KRELOP,LAM,LAMAX,LRANG3,MAXC,IBC,LCB,LIMEX(0), * (ISMIT(I),I=1,ILIM) JBC=IBC MCB=LCB MXXE=MAXE C C INITIALIZE SOME STG1 PARAMETERS C C IDISC1 AND IDISC2 ARE SCRATCH FILES C C ITAPE2 AND JDISC2 ARE ONLY USED FOR INPUT IF RESTARTING (ICOPY.GT.0 C ICOPY2=ICOPY ITOTAL=999 IDISC1=8 IDISC2=9 IDISC3= 18 C OUT ITAPE1=IPSEUD ITAPE2=0 ITAPE3=IOUT ITAPE4= 17 IPUNCH=0 JDISC1=IOUTDA JDISC2=0 IF(ICOPY.EQ.0) GO TO 10 ITAPE2=1 JDISC2=11 C CONVERT OCTAL IPRINT TO DECIMAL BEFORE MAPPING AS BINARY ONTO NBUG 10 L=0 M=IPRINT DO 11 I=1,3 K=MIN(MOD(M,10),7) M=M/10 11 L=K*8**(I-1)+L K=512 DO 12 I=1,9 K=K/2 NBUG(I)=L/K 12 L=L-NBUG(I)*K IF(IPRINT.EQ.0) GO TO 13 IF(NBUG(6).NE.0) NBUG(5)=2 IF(NBUG(8).NE.0) NBUG(7)=2 C NBUG(6)=NBUG(8) NOT USED IN CODE: NBUG(6)=0 NBUG(8)=0 WRITE(IWRITE,'(/13X,14HNBUG(IPRINT) =,3(I6,2I4)/)') NBUG 13 L=MIN(KRELOP,7) IF(L.LT.0) L=7 IRELOP(1)=L/4 IRELOP(2)=(L-IRELOP(1)*4)/2 IRELOP(3)=MOD(L,2) IF(CODE.EQ.COD(3)) GO TO 90 C C READ IN ANY EXTRA DATA, AS DETERMINED BY THE PARAMETER IBC. C IBC = 0 FOR AUTOMATIC GENERATION OF RA, MESH AND POTENTIAL, C IBC = 1 FOR READING IN RA,BSTO ONLY C IBC = -1 FOR READING IN RA,BSTO AND POTENTIAL C IBC = 2 FOR READING IN RA,BSTO, DELTA,ETA AND (IF NIX>0) MESH C IBC = -2 FOR READING IN RA,BSTO, POTENTIAL AND TABULATION MESH C RA=-ONE -- PUTS CONFUSING RESTRICTION ON SUBROUTINE SS; '90MAY15: RA=.0 NPOT=0 IF(IBC.EQ.0) GO TO 30 READ(IREAD,*) RA,BSTO IF(ABS(IBC).EQ.1) GO TO 20 READ(IREAD,*) L IF(L.LE.0) GO TO 18 IF(L.GT.IDMTST(17)) CALL RECOV1(17,L) READ(IREAD,*) (IHX(I),I=1,L) READ(IREAD,*) (IRX(I),I=1,L) NIX=L 18 READ(IREAD,*) TMP,DELTA,ETA IF(L.GT.0) HINT=TMP 20 IF(IBC.GE.0) GO TO 30 READ(IREAD,*) NPOT IF(NPOT.LE.0) GO TO 30 IF(NPOT.GT.IDMTST(10)) CALL RECOV1(10,NPOT) READ(IREAD,*) (IPOT(I),I=1,NPOT) READ(IREAD,*) (CPOT(I),I=1,NPOT) READ(IREAD,*) (XPOT(I),I=1,NPOT) C C READ IN ORBITAL DATA IN SUPERSTRUCTURE FORMAT C 30 IF(CODE.EQ.COD(1)) GO TO 50 31 IF(CODE.EQ.COD(2)) CALL SS(INDATA,MAXE) C C DEFINE POTENTIAL FUNCTION V(R) = 2N*EXP(-Z**(1/3)*R)/R + 2(Z-N)/R C IF(IBC.LT.0.AND.NZ.NE.NELC) GO TO 40 NPOT=1 CPOT(1)=2*NELC XPOT(1)= NZ**THIRD IPOT(1)=-1 IF(NZ.EQ.NELC) GO TO 40 NPOT=2 CPOT(2)=(NZ-NELC)*2 XPOT(2)=0.0 IPOT(2)=-1 C 40 IF(MAXE.EQ.9999) GO TO 50 MAXC=MAX(INT(SQRT(ABS(MAXE)*2.)*RA/PI+0.5),MAXC) 50 NRANG2=MIN(IDMTST(7),MAXC) C LRANG2=MIN(MAXPW+MAXLS+1,IDMTST(15)) TUE'96NOV7: LRANG2=MAXPW+MAXLS+1 IF(LRANG2.GT.IDMTST(15)) CALL RECOV1(15,LRANG2) IF(LAMAX.LE.0) LAMAX=(LRANG1-1)*2 DO 60 L=1,LRANG1 MAXNLG(L)=MAXNHF(L) IF(ILIM.EQ.0) GO TO 60 DO 59 I=1,ILIM IF(MOD(ISMIT(I),10).NE.L-1) GO TO 59 MAXNLG(L)=MIN(ISMIT(I)/10-1,MAXNLG(L)) 59 CONTINUE 60 CONTINUE 90 RETURN END C*********************************************************************** SUBROUTINE NEWBUT(L) C C DETERMINES THE COEFFICIENTS OF A LEAST SQUARES FIT TO THE BUTTLE C CORRECTION FOR L-1; AND THE ENERGY INDEPENDENT BUTTLE C CORRECTION TO THE RADIAL FUNCTION FOR L-1, PASSED BACK IN ORB() C TO THE CALLING SUBROUTINE BASORB. C C...........MODIFICATIONS MADE BY MJS, 1986 AUGUST 27 C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL71= 60+1, LL90= 7+1, X=0.2, IMAX=6, TINY=1.E-6) COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBOUT/ORB(1999),DORB(1999),EIGEN,ALAMDA(LL90),BVALUE COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ C DIMENSION EL(IMAX),RT(IMAX),RCN(IMAX),A(3) C 6003 FORMAT(6X, * 'CORRECTIONS CALCULATED IN ENERGY RANGE',E12.4,' TO',E12.4) 6004 FORMAT(5X, ' SUBROUTINE NEWBUT - CANNOT EVALUATE BUTTLE CORRECTION * FOR L =',I3,' AND ENERGY',F15.7,' RYD.') 6005 FORMAT(/' BUTTLE CORRECTION COEFFICIENTS FOR L=',I3/) 6006 FORMAT(6X,'BSTO.NE.0., QUADRATIC FIT USED, COEFFICIENTS ARE'/ + 11X,3E13.4) 6007 FORMAT(//5X,'*** WARNING *** RANGE EK2MIN TO EK2MAX IS TOO SMALL' + /17X,'CANNOT CALCULATE BUTTLE CORRECTION'//) 6008 FORMAT(//6X,'*** WARNING *** EK2MIN =',E16.6,' IS .GT. EK2MAX =', * E16.6/ 17X,'CANNOT CALCULATE BUTTLE CORRECTION'//) 6009 FORMAT(6X,'BSTO.EQ.0., MJS FIT USED, ALPHA =',F9.5,' BETA =', * E12.4/32X,'NBUT =',I4,' - CONVERGED IF NBUT POSITIVE') 6010 FORMAT(6X,'LARGEST ERROR IN FIT =',1P,E13.5,' (INT',2E12.5,')') C C L1=L-1 WRITE(IWRITE,6005) L1 NBT=0 IF(L.LE.LRANG1) NBT=MAXNLG(L)-L1 C C BUTTLE CORRECTION TO R-MATRIX C ***************************** C C CHECK THAT EK2MAX NOT TOO LARGE D=.5*EIGENS(NRANG2,L) IF(EK2MAX.GT.D) EK2MAX=D C C+++ MODIFICATION BY MJS, 19.12.86 - RUB'96FEB24: =D -> =MIN(D,0.) C CHECK THAT EK2MIN NOT TOO SMALL D=.5*(3.*EIGENS(1,L)-EIGENS(2,L)) IF(EK2MIN.LT.D) EK2MIN=MIN(D,0.) C+++ END MODIFICATION C C CHECK THAT EK2MIN.LT.EK2MAX IF(EK2MIN.GT.EK2MAX)THEN CW IFLAG=1 WRITE(IWRITE,6008)EK2MIN,EK2MAX ENDIF C C BUTTLE CORRECTION CALCULATED AT ENERGIES EL(I), I=1,IMAX C INITIALISE EL(I) WITH EQUALLY SPACED POINTS D=(EK2MAX-EK2MIN)/(IMAX-1) E=EK2MIN-D DO 10 I=1,IMAX E=E+D 10 EL(I)=E C C ENSURE THAT EL(I) NOT TOO CLOSE TO POLES. EXCLUDE RANGE C ((1-X)*E(J)+X*E(J-1)) TO ((1-X)*E(J)+X*E(J+1)) C WHERE E(J) = EIGENS(J,L) AND X=.2 C NA=1 DO 35 I=1,IMAX C FIND FIRST POLE ABOVE EL(I) DO 20 N=NA,NRANG2 IF(EIGENS(N,L).LE.EL(I)) GO TO 20 NN=N GO TO 30 20 CONTINUE 30 NA=NN EA=EIGENS(NA,L) C CASE OF ALL POLES ABOVE IF(NA.EQ.1)THEN EP=EIGENS(2,L) D=X*(EP-EA) IF((EA-EL(I)).LT.D)EL(I)=EA-D C SOME POLES BELOW ELSE C NEAREST POLE BELOW EB=EIGENS(NA-1,L) D=X*(EA-EB) IF(EL(I)-EB.LT.D) EL(I)=EB+D IF(EA-EL(I).LT.D) EL(I)=EA-D ENDIF 35 CONTINUE WRITE(IWRITE,6003)EL(1),EL(IMAX) C C CHECK NUMBER OF INDEPENDENT VALUES INDEP=1 DO 60 N=2,IMAX IF(EL(N-1).NE.EL(N))INDEP=INDEP+1 60 CONTINUE IF(INDEP.LT.3) THEN WRITE(IWRITE,6007) CW IFLAG=1 C RETURN ENDIF C C CALCULATE BUTTLE CORRECTIONS AT ENERGIES EL(I) AND STORE IN RCN(I) C DO 68 II=1,IMAX IF(ABS(EL(II)).LT.TINY)EL(II)=EL(II) + TINY+TINY EH=0.0 CALL BASFUN(NBT,L1,NODE,RA,BSTO,EL(II),DELTA,EH) RT(II)=BVALUE-BSTO IF(ABS(RT(II)).GT.TINY) GO TO 692 WRITE(IWRITE,6004) L1,EL(II) CW IFLAG=1 RETURN 692 SUM=0.0 DO 69 N=1,NRANG2 IF(ENDS(N,L).EQ.0.0) GO TO 69 SUM=SUM+ENDS(N,L)*ENDS(N,L)/(EIGENS(N,L)-EL(II)) 69 CONTINUE 68 RCN(II)=1.0/RT(II)-SUM/RA C C FIT BUTTLE CORRECTION AND STORE FIT PARAMETERS IN COEFF(I,L),I=1,3 C IF(BSTO.NE.0.) GO TO 61 C C FOR BSTO.EQ.0. USE IMPROVED FITTING PROCEDURE CALL BUTFIT(IMAX,EL,RCN,RA,EIGENS(NRANG2,L),ALPHA,BETA, + NBUT,DELTB) WRITE(IWRITE,6009)ALPHA,BETA,NBUT C IF BUTFIT DIVERGING TRY QUADRATIC FIT (BSTO MAY NEED CHANGING): C IF(NBUT.LE.0) GO TO 61 -- CONSISTENT EXTENSION RUB'96JAN17: IF(NBUT.LE.0) THEN BSTO=1.E-10 PRINT *,' NEWBUT HAS FAILED, NOW SETTING BSTO=1.E-10' IF(L1.EQ.0) GO TO 61 PRINT *,' RERUN SPECIFYING SUCH BSTO!' STOP ENDIF COEFF(1,L)=ALPHA COEFF(2,L)=BETA COEFF(3,L)=-10000*NBUT GO TO 62 C C USE QUADRATIC FIT FOR BSTO.NE.0. 61 CALL LSQ(EL,RCN,A,IMAX) DO 691 I=1,3 691 COEFF(I,L)=A(I) WRITE(IWRITE,6006) A DELTB=0. DO 693 I=1,IMAX D=ABS((A(3)*EL(I)+A(2))*EL(I)+A(1)-RCN(I)) IF(DELTB.LT.D) DELTB=D 693 CONTINUE C C ACCURACY OF FIT 62 WRITE(6,6010) DELTB, RCN(1),RCN(IMAX) C C C BUTTLE CORRECTION TO FUNCTIONS C ****************************** C C DETERMINE ENERGY EBUT AT WHICH THE BUTTLE CORRECTION TO C THE RADIAL FUNCTION IS TO BE APPLIED C EBUT SHOULD BE CLOSE TO E=0 AND AWAY FROM POLES EIGENS() C ELO=EIGENS(1,L) IF (ELO.LT.0.0.AND.NRANG2.GT.1) THEN C C TAKE ENERGY HALF WAY BETWEEN TWO POLES NEXT TO ZERO ENERGY C I=2 40 EHI=EIGENS(I,L) IF(I.GE.NRANG2) GO TO 41 ELO=EHI I=I+1 GO TO 40 41 EBUT=(ELO+EHI)*0.5 C ELSE C C GO BACK FROM FIRST POLE HALF THE DISTANCE BETWEEN THE FIRST C AND THE SECOND POLES C EHALF=0.1 IF(NRANG2.GE.2) EHALF=(EIGENS(2,L)-ELO)*0.5 EBUT=ELO-EHALF ENDIF C EH=0.0 CALL BASFUN (NBT,L1,NODE,RA,BSTO,EBUT,DELTA,EH) I9=IRX(NIX)+1 D=RA/((BVALUE-BSTO)*ORB(I9)) DO 42 I=1,I9 42 ORB(I)=ORB(I)*D C C NOW HAVE THE CORRECTLY NORMALIZED EXACT FUNCTION IN ORB(). C CONTRIBUTIONS FROM THE FIRST NRANG2 CONTINUUM ORBITALS WILL C BE SUBTRACTED ONE AT A TIME FROM ORB() AT WHOLE MESH POINTS C N1=MAXNHF(L) DO 44 J=1,NRANG2 D=ENDS(J,L)/(EBUT-EIGENS(J,L)) NQ=IPOS(N1+J,L) DO 44 I=1,I9 44 ORB(I)=UJ(I,NQ)*D+ORB(I) C C NOW HAVE THE NRANG2+1 TO INFINITY SUM IN ORB(). C RETURN END C********************************************************************** SUBROUTINE ONEELE(N11,L1,N12,L2,ALBVAL) C C CALCULATES THE ONE-ELECTRON MATRIX ELEMENT BETWEEN ORBITALS C DEFINED BY THE QUANTUM NUMBERS (N1,L1-1) AND (N2,L2-1), C AND STORES THE RESULT IN ALBVAL. C WHEN BOTH ORBITALS ARE CONTINUUM ORBITALS THE SCHMIDT C COEFFICIENTS ARE USED TO EXPRESS ONE CONTINUUM ORBITAL IN TERMS C OF ORBITALS SATISFYING A DIFFERENTIAL EQUATION AND BOUND ORBITALS C SEE COMMENTS IN EVALUE FOR DETAILS ON UJ AND DUJ. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL71= 60+1, LL57= 60+ 4, LL59=2*1999) PARAMETER (LL74= 60+ 4+ 7) DIMENSION ADD(1999) COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SCOEFF/B(LL57,LL57),OVRLAP( 60, 4),TEMP(LL74) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS C C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE C ALBVAL = 0.0 IF(L1.NE.L2) GO TO 99 SUM = 0.0 C C DEFINE THE POSITION OF THE MODEL POTENTIAL IN THE POTHAM ARRAY. C LX = LPOSX(L1) ZN = NZ C C FIND IF ONE ORBITAL IS BOUND. IF SO PUT IT INTO THE SECOND C POSITION SO THAT THE ORBITAL DEFINED BY (N2,L2) IS BOUND. C MAXHF = L1-1 IF(L1.LE.LRANG1) MAXHF = MAXNHF(L1) N1=N11 N2=N12 IF(N2.LE.MAXHF) GO TO 2 IF(N1.GT.MAXHF) GO TO 11 N1=N12 N2=N11 2 I1=IPOS(N1,L1) I2=IPOS(N2,L2) C C CARRY OUT THE INTEGRATION USING SIMPSONS RULE C DO 3 I=2,NPTS 3 SUM = UJ(I,I1)*DUJ(I,I2)*WT(I) + SUM IF(IPSEUD.EQ.0) GO TO 9 DO 8 I=2,NPTS 8 SUM = (ZN-POTHAM(I,LX)) *UJ(I,I1)*UJ(I,I2)*WT(I) *2./XR(I) + SUM C 9 ALBVAL = SUM GO TO 33 C C BOTH ORBITALS ARE CONTINUUM ORBITALS. THE SCHMIDT COEFFICIENTS C ARE USED TO EXPRESS ONE CONTINUUM ORBITAL IN TERMS OF ORBITALS C SATISFYING A DIFFERENTIAL EQUATION AND BOUND ORBITALS. THE C SECOND DIFFERENTIATION CAN THEN BE CARRIED OUT ANALYTICALLY. C 11 I1=IPOS(N1,L1) I2=IPOS(N2,L2) C C ITEST DETERMINES WHETHER SCHMIDT ORTHOGONALIZATION IS USED C MAXLG = MAXHF IF(L1.LE.LRANG1) MAXLG = MAXNLG(L1)+MAXNCB(L1) ITEST = MAXHF-MAXLG C C FIRST EVALUATE CONTRIBUTION FROM THE CONTINUUM ORBITALS USING C SIMPSONS RULE, USING THE PX ARRAY SET UP IN SUBROUTINE POTF. C *** NEW VECTORIZED CODE FOR CRAY 12 IF(IPSEUD.EQ.0) THEN DO 16 J=2,NPTS 16 ADD(J)= UJ(J,I1)*UJ(J,I2)*PX(J) ELSE DO 161 J=2,NPTS 161 ADD(J)=(2*POTHAM(J,LX)/XR(J)-POVALU(2*J-2))* * WT(J)*UJ(J,I1)*UJ(J,I2) ENDIF DO 17 J=2,NPTS 17 SUM=SUM+ADD(J) ALBVAL = -SUM C2002 FORMAT(' ONEELE',30X,F15.6) *** END OF CRAY CODING. C C NOW ADD IN ENERGY TERM C N1P=N1-MAXHF+ITEST IF(ITEST.GT.0) GO TO 21 IF(N1.EQ.N2) ALBVAL = ALBVAL+EIGENS(N1P,L1) GO TO 33 21 N2P=N2-MAXHF+ITEST C N3P=N1-MAXHF N4P=N2-MAXHF DO 18 I=1,N4P 18 ALBVAL=ALBVAL+B(N1P,I+ITEST)*B(N2P,I+ITEST)*EIGENS(I,L1) DO 31 I=1,ITEST DO 19 J=1,N4P 19 ALBVAL=B(N1P,I)*B(N2P,J+ITEST)*OVRLAP(J,I)*EIGENS(J,L1)+ALBVAL C AND ADD IN CONTRIBUTION FROM THE BOUND ORBITALS USING C SIMPSONS RULE I2=IPOS(I+MAXLG,L2) SUM=0.0 DO 29 J=2,NPTS 29 SUM = (DUJ(J,I2)*WT(J)+PX(J)*UJ(J,I2))*UJ(J,I1) + SUM 31 ALBVAL=ALBVAL+SUM*B(N2P,I) C 33 ALBVAL=ALBVAL*0.5 99 RETURN END C*********************************************************************** REAL FUNCTION ORINT(K1,K2,L1,L2,NN) C C INTEGRATES P(R)*P'(R)*R**N MINUS SIMPSON INTEGRAND OVER 0-XR(3): C CAN BE USED TO INITIALIZE THE INTEGRAND OVER THE FIRST SIMPSON C INTERVAL (RADIAL POINTS 1-3) WHERE IT BEHAVES LIKE R**(L1+L2+NN) C (L1+L2+NN.GT.0), THUS IMPROVING OVER SIMPSON'S RULE. C C IMPLICIT REAL*8(A-H,O-Z) COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS DIMENSION F(3) C N = L1+L2+NN DO 1 I=1,3 1 F(I) = UJ(I,K1)*UJ(I,K2) RN=XR(3)**N ORINT = XR(3)*RN*F(1)/(N+1) DO 3 I=2,3 R2=XR(2)**(N+4-I) R3=XR(3)**(N+4-I) 3 ORINT=((RN*R2-XR(2)**N*R3)*F(1)+F(2)*R3-F(3)*R2)*XR(3)**(N+I)/ * ((N+I)*(XR(2)**(I+N-1)*R3-XR(3)**(I+N-1)*R2)) * -XR(I)**NN*F(I)*WT(I)/(I-1) + ORINT RETURN END C*********************************************************************** REAL FUNCTION ORNO(J,K,N,L) C C EVALUATES ANALYTICALLY THE OVERLAP INTEGRAL BETWEEN THE C SLATER ORBITAL SPECIFIED BY THE QUANTUM NUMBERS (K,L-1) AND THE C J-TH TERM OF THE SLATER ORBITAL SPECIFIED BY (N,L-1). C C IMPLICIT REAL*8(A-H,O-Z) COMMON/FACT/GAMMA( 57) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ C C X=0.0 M1=NLIMIT*(L-1)+K M2=NCOEFF*(M1+N-K-1)+J M=NCO(M1) ZECOMM=ZE(M2) IRCOMM=IRAD(M2) DO 1 II=1,M M3=NCOEFF*(M1-1)+II IJ=IRCOMM+IRAD(M3)+1 X=X+C(M3)*GAMMA(IJ)/(ZECOMM+ZE(M3))**IJ 1 CONTINUE C ORNO=X RETURN END C*********************************************************************** REAL FUNCTION PHASE(LP,W) C C EVALUATES THE ZERO-ORDER EIGENPHASE AT A CONTINUUM EIGENENERGY W. C ONLY FOR ANGULAR MOMENTUM (LP-1) = 0, 1 OR 2. C C IMPLICIT REAL*8(A-H,O-Z) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 C C PHASE = 0.0 IF(LP.GT.3.OR.W.LE.0.0) GO TO 5 WR=SQRT(W)*RA V1=COS(WR) V2=SIN(WR) IF(LP-2) 1,2,3 C C S-WAVE EIGENPHASE C 1 X1=V1 X2=V2 X3=-V1 X4=V2 GO TO 4 C C P-WAVE EIGENPHASE C 2 W2=WR*WR X1=V1/WR+(1.0-1.0/W2)*V2 X2=V2/WR-V1 X3=-V1/WR-V2 X4=V2/WR+(1.0/W2-1.0)*V1 GO TO 4 C C D-WAVE EIGENPHASE C 3 W2=WR*WR W3=W2*WR X1=(6.0/W2-1.0)*V1-(6.0/W3-3.0/WR)*V2 X2=(3.0/W2-1.0)*V2-3.0*V1/WR X3=-(3.0/W2-1.0)*V1-3.0*V2/WR X4=(6.0/W3-3.0/WR)*V1+(6.0/W2-1.0)*V2 C 4 RATIO=(WR*X1-BSTO*X2)/(WR*X4-BSTO*X3) PHASE=ATAN(RATIO) 5 RETURN END C*********************************************************************** SUBROUTINE POTF C C AUTOMATICALLY CALCULATES THE STATIC POTENTIAL OF THE C LOWEST POSSIBLE TARGET CONFIGURATION WITH THE GIVEN RADIAL C ORBITALS IF NPOT=0; AND A PARAMETRIC POTENTIAL IF NPOT.GT.0; C WITH SS-TYPE INPUT OPTIONALLY NPOT=-1: POTENTIAL FROM SAME INPUT. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999) DIMENSION NSHELL(13),LSHELL(13) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/FACT/GAMMA( 57) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS DATA NSHELL/1,2,2,3,3,4,3,4,5,4,5,6,4/, * LSHELL/0,0,1,0,1,0,2,1,0,2,1,0,3/, MAXELC/70/ C 1000 FORMAT(//53X,'SUBROUTINE POTF: NPOT =',I3/53X,15(1H-)) 1001 FORMAT(5E16.8) 1021 FORMAT(6H IPOT=,9I12) 1022 FORMAT(6H CPOT=,9F12.7) 1023 FORMAT(6H XPOT=,9F12.7) C C INITIALIZATION C WRITE(IWRITE,1000) NPOT I9=(NPTS-1)*2 ZN=NZ IF(ICOPY2.GT.0) GO TO 9 IF(NPOT) 33,12,32 12 IFLG=0 NSOFAR=0 DO 11 I=1,I9 11 POVALU(I)=0.0 C C LOOP OVER EACH SHELL IN THE GIVEN N,L ORDER (STOP - RUB'96FEB22) C IF(NELCOR.LE.MAXELC) GO TO 1 PRINT *, ' POTF: TOO MANY ELECTRONS: RECODE SHELL RANGE!' STOP 1 IF(NBUG4.NE.0) READ(IREAD,*) (NSHELL(I),LSHELL(I),I=1,13) DO 8 ISHELL=1,13 NS=NSHELL(ISHELL) LS=LSHELL(ISHELL)+1 NR=NS LR=LS LSH=LS+LS-1 AM=(2*LSH) NSOFAR=NSOFAR+LSH+LSH IF(NSOFAR.LT.NELCOR) GO TO 2 IFLG=1 NMO=NSOFAR-NELCOR AM=AM-NMO 2 LDA=0 M1R=NLIMIT*(LR-1)+NR NCR=NCO(M1R) M1S=NLIMIT*(LS-1)+NS NCS=NCO(M1S) C C EVALUATE THE POTENTIAL AT EACH MESH POINT C DO 7 I=1,I9 J=(I+2)/2 R=XR(J) IF(MOD(I,2).NE.0) R=(XR(J+1)+R)*0.5 COOL=0.0 IF(IFLG.NE.0) COOL=ZN/R T1=0.0 T2=0.0 C DO 6 J1=1,NCR JK=J1+NCOEFF*(M1R-1) C1=C(JK) I1=IRAD(JK) Z1=ZE(JK) DO 5 J2=1,NCS MK=J2+NCOEFF*(M1S-1) C2=C(MK) I2=IRAD(MK) Z2=Z1+ZE(MK) N=I1+I2-LDA L=LDA+I1+I2+1 C12=C1*C2*GAMMA(L) T1=C12/Z2**L+T1 IF(R*Z2.GT.150.) GO TO 5 SUM=0.0 DO 3 K=1,L 3 SUM=R**(K-1)/(GAMMA(K)*Z2**(L-K+1))+SUM T1=T1-C12*EXP(-R*Z2)*SUM SUM=0.0 DO 4 K=1,N 4 SUM=R**(K-1)/(GAMMA(K)*Z2**(N-K+1))+SUM T2=T2+GAMMA(N)*EXP(-R*Z2)*SUM*C1*C2 5 CONTINUE 6 CONTINUE C ARE=R**LDA V=T1/(ARE*R)+T2*ARE 7 POVALU(I)=POVALU(I)-(V*AM-COOL)*2.0 C IF(IFLG.NE.0) GO TO 9 8 CONTINUE C C DEFINE THE PX ARRAY FOR USE IN THE ONE-ELECTRON INTEGRAL C 9 IF(NBUG5.GT.1) WRITE(IWRITE,1001)(POVALU(I),I=1,I9,4) ZN=(NZ+NZ) DO 10 J=2,NPTS 10 PX(J)=(ZN/XR(J)-POVALU(2*J-2))*WT(J) RETURN C C PARAMETRIC POTENTIAL, ALSO IF TARGET ORBITALS USER-SUPPLIED: C 32 WRITE(IWRITE,1021)(IPOT(I),I=1,NPOT) WRITE(IWRITE,1022)(CPOT(I),I=1,NPOT) WRITE(IWRITE,1023)(XPOT(I),I=1,NPOT) 33 DO 36 I=1,I9 J=(I+2)/2 X=XR(J) IF(MOD(I,2).NE.0) X=(XR(J+1)+X)*0.5 Y=0.0 IF(NPOT.LT.0) GO TO 35 DO 34 K=1,NPOT 34 Y = CPOT(K)*X**IPOT(K)*EXP(-XPOT(K)*X) + Y GO TO 36 35 Y = (((PX(J)-ZN)*NELC)/(NELC-1)+ZN)*2./X 36 POVALU(I)=Y GO TO 9 END C*********************************************************************** SUBROUTINE RADINT(N1,L1,N2,L2,K,X) C C EVALUATES X, THE RADIAL MULTIPOLE INTEGRAL OF ORDER K BETWEEN TWO C ORBITALS SPECIFIED BY THE QUANTUM NUMBERS (N1,L1-1) AND (N2,L2-1) C C IMPLICIT REAL*8(A-H,O-Z) COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS C X=0. J1=IPOS(N1,L1) J2=IPOS(N2,L2) DO 3 I=2,NPTS 3 X = WT(I)*UJ(I,J1)*UJ(I,J2)*XR(I)**K + X RETURN END C*********************************************************************** SUBROUTINE RDAR(N1,L1,N2,L2,RLBVAL) C C EVALUATES THE RELATIVISTIC ONE-BODY DARWIN TERM; C THIS ONLY AFFECTS S-WAVE ORBITALS AT THE ORIGIN. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (FSC=7.29732E-3) COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE. C RLBVAL=0.0 IF(L1.NE.L2.OR.L1.NE.1) GO TO 5 C K1=IPOS(N1,L1) K2=IPOS(N2,L2) RLBVAL = NZ*FSC*FSC*UJ(1,K1)*UJ(1,K2)/8.0 5 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 */38H MUST INCREASE LENGTH GIVEN BY I *DMTST(,I2,2H)=,I6,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 RMASS(N11,L1,N22,L2,RLBVAL) C C EVALUATES THE RELATIVISTIC MASS-CORRECTION TERM C C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999, LL71= 60+1, LL90= 7+1) COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/ORBTLS/UJ(1999, 128),UDP(1999, 25),NBOUND,IPOS( 108, 49) COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/REL1/ RLAMDA( 49, 60,LL90) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS C DIMENSION X(2),IX(2) C PARAMETER (FSC=7.29732E-3) C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE. C RLBVAL=0.0 IF(L1.NE.L2) GO TO 99 SUM = 0.0 *=*=*= * THE FOLLOWING STATEMENT HAS BEEN INCLUDED LLL=LPOSX(L1) *=*=*= MAXLG=MAXNLG(L1)+MAXNCB(L1) MAXHF=L1-1 ALSQ=MAXHF*L1 NBT=MAXLG-MAXHF TWOZ=2*NZ C C DETERMINE WHETHER THE ORBITALS ARE BOUND-BOUND, BOUND-CONTINUUM C OR CONTINUUM-CONTINUUM C N1=N11 N2=N22 IF(L1.LE.LRANG1) MAXHF=MAXNHF(L1) ITEST=1 IF(N1.GT.MAXHF) ITEST=ITEST+1 IF(N2.GT.MAXHF) ITEST=ITEST+1 C C IF ITEST=1 BOUND-BOUND C =2 BOUND-CONTINUUM OR CONTINUUM-BOUND C =3 CONTINUUM-CONTINUUM C IF(ITEST.GT.2) GO TO 27 C C PREPARE DATA INVOLVING ONE OR TWO BOUND STATE ORBITALS C IF(N2.LE.MAXHF) GO TO 1 C C PLACE THE BOUND ORBITAL IN C THE SECOND POSITION DEFINED BY (N2,L2): N1=N22 N2=N11 C 1 IX(1)=IPOS(N1,L1) IX(2)=IPOS(N2,L2) IF (NCOEFF.NE.0) THEN C C ANALYTIC BOUND ORBITALS ARE BEING USED C DO 3 I=2,ITEST,-1 X(I) = 0. IF(L1.NE.1) GO TO 3 CX PV=ZERO -- CORRECTED FOR ORBITALS BEYOND N,L=1S WE'90MAY10TH: X(I) = UDP(1,IX(I)) C TST PRINT *, 'RMASS: L1,N1,N2,X=',L1,N1,N2,X(I) 3 CONTINUE IF(ITEST.EQ.2) GO TO 14 ELSE C C NUMERIC BOUND ORBITALS ARE BEING USED (CORRECTED WE'90MAY12) C X(2) = -TWOZ*UJ(1,IX(2)) IF(ITEST.EQ.2) GO TO 14 IF(L1.NE.1) GO TO 4 X(1) = -TWOZ*UJ(1,IX(1)) END IF C C THIS IS A BOUND-BOUND CASE. C C DETERMINE THE CONTRIBUTION,IF ANY,AT THE ORIGIN. C IF(L1.GT.1) (OR X=.0) THERE IS NO CONTRIBUTION; WE'90MAY10-11. C SUM = X(1)*X(2)*WT(1) C C CARRY OUT INTEGRATION USING SIMPSONS RULE C *=*=*= * THE FOLLOWING STATEMENT WHICH WAS X(J) = PV... * HAS BEEN REPLACED BY * X(J) = -POTHAM... * IN ORDER TO BE CONSISTENT WITH THE CIV3 STRUCTURE CODE *=*=*= '91JUL18/28 CHANGED TO 4 IF(IPSEUD.EQ.0) THEN DO 6 I=2,NPTS 6 SUM= (TWOZ*UJ(I,IX(1))/XR(I)+UDP(I,IX(1)))* * (TWOZ*UJ(I,IX(2))/XR(I)+UDP(I,IX(2)))*WT(I)+SUM ELSE DO 11 I=2,NPTS 11 SUM=POTHAM(I,LLL)*POTHAM(I,LLL)*4./(XR(I)*XR(I))* * UJ(I,IX(1))*UJ(I,IX(2))*WT(I) + SUM ENDIF GO TO 44 C C C IN THIS CASE ONE OF THE ORBITALS IS BOUND AND THE OTHER IS C CONTINUUM C 14 NN=N1-MAXHF I1=IX(1) IF(L1.NE.1) GO TO 17 C C DETERMINE THE CONTRIBUTION ,IF ANY , AT THE ORIGIN C THIS ONLY AFFECTS S-WAVE ORBITALS I.E.IF(L1.EQ.1) C C RLBVAL=-(PV*TWO*REAL(NZ)*RNORM(NN))*(H/THREE) -- PV CORRECTED: SUM = -TWOZ*UJ(1,I1)*X(2)*WT(1) C TST PRINT *, 'RMASS: L1,N1,N2,P,C,B=',L1,N1,N2,RLBVAL,RNORM(NN),X(2) C C CARRY OUT THE INTEGRATION USING SIMPSONS RULE. C 17 I2=IX(2) C DO 24 I=2,NPTS C C EVALUATE THE SECOND DERIVATIVE OF THE BOUND ORBITAL C IF(IPSEUD.EQ.0) THEN X1 = -TWOZ*UJ(I,I2)/XR(I) - UDP(I,I2) ELSE X1=-POTHAM(I,LLL)*UJ(I,I2)*2./XR(I) ENDIF C C EVALUATE THE CONTRIBUTION FROM THE CONTINUUM ORBITAL C X2=-UJ(I,I1)*(POVALU(2*I-2)+EIGENS(NN,L1)) IF(NBT.EQ.0) GO TO 24 DO 19 J=L1,MAXLG J2=IPOS(J,L1) 19 X2=X2+UJ(I,J2)*RLAMDA(L1,NN,J-L1+1) C C ADD IN THE CONTRIBUTIONS. C 24 SUM=SUM+X1*X2*WT(I) GO TO 44 C C C BOTH ORBITALS ARE CONTINUUM ORBITALS C 27 M1=N1-MAXHF M2=N2-MAXHF I1=IPOS(N1,L1) I2=IPOS(N2,L2) IF(L1.NE.1) GO TO 31 C C DETERMINE THE CONTRIBUTION ,IF ANY , AT THE ORIGIN C THIS ONLY AFFECTS S-WAVE ORBITALS I.E.IF(L1.EQ.1) C SUM = TWOZ*TWOZ*UJ(1,I1)*UJ(1,I2)*WT(1) C C CARRY OUT THE INTEGRATION USING SIMPSONS RULE C 31 EIG=EIGENS(M1,L1)+EIGENS(M2,L2) DO 35 I=2,NPTS C C EVALUATE THE SUMMATIONS INVOLVING THE LAGRANGE MULTIPLIERS C X1=0. X2=0. IF(NBT.EQ.0) GO TO 33 DO 32 J=L1,MAXLG NN=IPOS(J,L1) X1=X1+UJ(I,NN)*RLAMDA(L1,M1,J-L1+1) 32 X2=X2+UJ(I,NN)*RLAMDA(L2,M2,J-L1+1) 33 PO=POVALU(2*(I-1)) U1=UJ(I,I1) U2=UJ(I,I2) 35 SUM=((PO+EIG)*U1*U2-X1*U2-X2*U1)*PO*WT(I)+SUM C IF(N1.EQ.N2) SUM=EIG+SUM IF(NBT.EQ.0) GO TO 44 DO 37 J=L1,MAXLG 37 SUM=RLAMDA(L1,M1,J-L1+1)*RLAMDA(L2,M2,J-L1+1)+SUM 44 RLBVAL=-SUM*FSC*FSC/8. 99 RETURN END C*********************************************************************** SUBROUTINE ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG) C C THIS SUBROUTINE IS TAKEN FROM THE BOOK OF SHAMPINE AND GORDON, C 'COMPUTATIONAL SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS' C C ROOT COMPUTES A ROOT OF THE NONLINEAR EQUATION F(X)=0, WHERE F(X) C IS A CONTINUOUS REAL FUNCTION OF A SINGLE REAL VARIABLE X. THE C METHOD OF SOLUTION IS A COMBINATION OF BISECTION AND THE SECANT RULE. C C NORMAL INPUT CONSISTS OF A CONTINUOUS FUNCTION F AND AN INTERVAL C (B,C) SUCH THAT F(B)*F(C).LE.0.0. EACH ITERATION FINDS NEW VALUES OF C B AND C SUCH THAT THE INTERVALL (B,C) IS SHRUNK AND F(B)*F(C).LE.0.0. C C THE STOPPING CRITERION IS C C ABS(B-C).LE.2.0*(RELERR*ABS(B)+ABSERR) C C WHERE RELERR= RELATIVE ERROR AND ABSERR= ABSOLUTE ERROR ARE INPUT C QUANTITIES. SET THE FLAG IFLAG POSITIVE TO INITIALISE THE C COMPUTATION. AS B,C AND IFLAG ARE USED FOR BOTH INPUT AND OUTPUT, C THEY MUST BE VARIABLES IN THE CALLING PROGRAM. C IF 0.0 IS A POSSIBLE ROOT, ONE SHOULD NOT CHOOSE ABSERR=0.0. C C C THE OUTPUT VALUE OF B IS THE BETTER APPROXIMATION TO A ROOT AS C B AND C ARE ALWAYS REDEFINED SO THAT ABS(F(B)).LE.ABS(F(C)). C C TO SOLVE THE EQUATION, ROOT MUST EVALUATE F(X) REPEATEDLY. THIS IS C DONE IN THE CALLING PROGRAM. WHEN AN EVALUATION OF F IS NEEDED AT T, C ROOT RETURNS WITH IFLAG NEGATIVE. EVALUATE FT=F(T) AND CALL ROOT C AGAIN. DO NOT ALTER IFLAG. C C WHEN THE COMPUTATION IS COMPLETE, ROOT RETURNS TO THE CALLING C PROGRAM WITH IFLAG POSITIVE: C C IFLAG=1 IF F(B)*F(C).LT.0 AND THE STOPPING CRITERION IS MET. C C =2 IF A VALUE B IS FOUND SUCH THAT THE COMPUTED VALUE F(B) C IS EXACTLY ZERO. THE INTERVAL (B,C) MAY NOT SATISFY C THE STOPPING CRITERION. C C =3 IF ABS(F(B)) EXCEEDS THE INPUT VALUES ABS(F(B)), C ABS(F(C)). IN THIS CASE IT IS LIKELY THAT B IS CLOSE C TO A POLE OF F. C C =4 IF NO ODD ORDER ROOT WAS FOUND IN THE INTERVALL. C A LOCAL MININMUM MAY HAVE BEEN OBTAINED. C C =5 IF TOO MANY FUNCTION EVALUATIONS WERE MADE. C (AS PROGRAMMED, 500 ARE ALLOWED.) C C THIS CODE IS A MODIFICATION OF THE CODE Z E R O I N WHICH IS C COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, NUMERICAL C COMPUTING: AN INTRODUCTION BY L.F. SHAMPINE AND R.C. ALLEN C ************************************************************************ * THE ONLY MACHINE DEPENDENT CONSTANT IS BASED ON THE MACHINE UNIT * * ROUNDOFF ERROR U. IT IS CALCULATED IN THE SUBROUTINE M A C H I N * * WHICH MUST HAVE BEEN CALLED BEFORE THE FIRST CALL OF R O O T. * * NOTE....IN THIS CODE MACHIN IS NOT CALLED BUT U IS SET TO 1.0E-12 * * IN THE PARAMETER STATEMENT BELOW. * ************************************************************************ C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (U=1.0E-12) SAVE RE,AE,IC,ACBS,A,FA,FC,FX,KOUNT C IF (IFLAG.GE.0) GOTO 100 IFLAG=ABS(IFLAG) IF(IFLAG-2) 200,300,400 100 RE=MAX(RELERR,U) AE=MAX(ABSERR,0.0) IC=0 ACBS=ABS(B-C) A=C T=A IFLAG=-1 GO TO 13 200 FA=FT T=B IFLAG=-2 GO TO 13 300 FB=FT FC=FA KOUNT=2 FX=MAX(ABS(FB),ABS(FC)) 1 IF(ABS(FC).GE.ABS(FB)) GOTO 2 C C INTERCHANGE B AND C SO THAT ABS(F(B)).LE.ABS(F(C)) C A=B FA=FB B=C FB=FC C=A FC=FA 2 CMB=(C-B)*0.5 ACMB=ABS(CMB) TOL=RE*ABS(B)+AE C C TEST STOPPING CRITERION AND FUNCTION COUNT C IF(ACMB.LE.TOL) GOTO 8 IF(KOUNT.GE.500) GOTO 12 C C CALCULATE NEW ITERATE IMPLICITLY AS B+P/Q WHERE WE ARRANGE P.GE.0. C THE IMPLICIT FORM IS USED TO PREVENT OVERFLOW. C P=(B-A)*FB Q=FA-FB IF(P.GE.0.0) GOTO 3 P=-P Q=-Q C C UPDATE A, CHECK REDUCTION OF THE SIZE OF BRACKETING INTERVAL IS C SATISFACTORY. IF NOT, BISECT UNTIL IT IS. C 3 A=B FA=FB IC=IC+1 IF(IC.LT.4) GOTO 4 IF (8.0*ACMB.GE.ACBS) GO TO 6 IC=0 ACBS=ACMB C C TEST FOR TOO SMALL A CHANGE C 4 IF(P.GT.ABS(Q)*TOL) GOTO 5 C C INCREMENT BY TOLERANCE C B=B+SIGN(TOL,CMB) GOTO 7 C C ROOT OUGHT TO BE BETWEEN B AND (C+B)/2 C 5 IF(P.GE.CMB*Q) GOTO 6 C C USE SECANT RULE C B=B+P/Q GOTO 7 C C USE BISECTION C 6 B=(C+B)*0.5 C C HAVE COMPLETED COMPUTATION OF NEW ITERATE B C 7 T=B IFLAG=-3 GO TO 13 400 FB=FT IF(FB.EQ.0.0) GO TO 9 KOUNT=KOUNT+1 IF(SIGN(1.0,FB).NE.SIGN(1.0,FC)) GOTO 1 C=A FC=FA GOTO 1 C C FINISHED. SET IFLAG C 8 IF(SIGN(1.0,FB).EQ.SIGN(1.0,FC)) GOTO 11 IF(ABS(FB).GT.FX) GOTO 10 IFLAG=1 GO TO 13 9 IFLAG=2 GO TO 13 10 IFLAG=3 GO TO 13 11 IFLAG=4 GO TO 13 12 IFLAG=5 13 RETURN END C*********************************************************************** SUBROUTINE RS(N2,L2,N1,L1,N4,L4,N3,L3,K,MODE,RKVAL) C C IF MODE=0 THIS SUBROUTINE EVALUATES THE FUNCTION Y(P2,P4,K/R) C AND THE SLATER INTEGRAL R(P1,P2,P3,P4,K), WHERE P1,P2,P3,P4 C ARE NUMERICAL ORBITAL FUNCTIONS DEFINED OVER A GRID XR(I); C AND MAGNETIC N-INTERALS IF MODE=+1, V-INTEGRALS IF MODE=-1. C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (THIRD=1./3.,TWELTH=1./12.) DIMENSION SUM1(1999),SUM2(1999),RT(1999),AR(1999), Y(1999) COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS COMMON/YKSTOR/YK(1999),RK(1999),RK1(1999),JN2,JL2,JN4,JL4,JKM EQUIVALENCE (YK(1),TEST1,Y(1)) C C ******** NOTES FOR THE USER ******** C C THE FUNCTIONS P1,P2,P3,P4 ARE TO BE STORED IN THE ARRAY UJ(I,J) C WITH J=J1,...J4 RESPECTIVELY; DERINT PROVIDES THE DERIVATIVE Y. C I IS THE INTEGRATION POINT NUMBER WITH I=1 CORRESPONDING TO R=0.0 C C ******** ******** C C LOCATE THE POSITIONS OF THE P1,P2,P3,P4 FUNCTIONS IN THE UJ ARRAY C FROM THEIR N,L VALUES SPECIFIED IN THE ARGUMENT LIST C C C DO NOT RECALCULATE THE YK INTEGRAL IF IT ALREADY EXISTS C IF(MODE.NE.0) GO TO 1 IF(K.NE.JKM) GO TO 2 IF(N2.NE.JN2.OR.L2.NE.JL2) GO TO 2 IF(N4.NE.JN4.OR.L4.NE.JL4) GO TO 2 GO TO 7 C 1 IF(-K-3.EQ.JKM) GO TO 22 GO TO 19 2 IF(K.EQ.JKM) GO TO 22 19 DO 20 J=2,NPTS 20 RK(J)=XR(J)**K IF(MODE.NE.0) GO TO 23 IF(RK(2)*XR(2)*1.E-7.GT.0.) THEN DO 21 J=2,NPTS 21 RK1(J)=1.0/(RK(J)*XR(J)) ELSE C RUB'96AUG30 INFTY FIX FOR -R4: DO 33 J=NPTS,2,-1 ARA=RK(J)*XR(J) IF(ARA*1.E-7.GT.0.) RIN=ARA 33 RK1(J)=1./RIN C PRINT *,' RS-TEST: LAM, RIN,ARA,RK1(2) = ', K,RIN,ARA,RK1(2) ENDIF JKM=K GO TO 22 23 DO 24 J=2,NPTS 24 RK1(J)=XR(J)**(-K-3) JKM=-K-3 C C INITIALIZATION C 22 ARA=0.0 J2=IPOS(N2,L2) J4=IPOS(N4,L4) IF(MODE.LT.0) GO TO 25 DO 3 J=2,NPTS 3 SUM1(J)=UJ(J,J2)*UJ(J,J4) GO TO 27 C COMPUTE MAGNETIC V-INTEGRALS FOR BLUME-WATSON SCREENING 25 CALL DERINT(0,L2,N4,L4,RIN) DO 26 J=2,NPTS 26 SUM1(J)=(Y(J)-UJ(J,J4)/XR(J))*UJ(J,J2) 27 DO 4 J=2,NPTS RT(J)=SUM1(J)*RK(J) 4 AR(J)=SUM1(J)*RK1(J) C C SIMPSONS RULE INTEGRATION FROM 0 TO RA=XR(NPTS) C DO 5 J=2,NPTS 5 SUM2(J)=WT(J)*AR(J) DO 6 J=2,NPTS 6 ARA=ARA+SUM2(J) C C SIMPSONS RULE INTEGRATIONS FROM 0 TO R C RT(1)=0. AR(1)=0. RIN=0.0 DO 8 J=3,NPTS,2 SUM1(J) =STEP(J) *THIRD *(RT(J-2)+4.0*RT(J-1)+RT(J)) 8 SUM2(J) =STEP(J) *THIRD *(AR(J-2)+4.0*AR(J-1)+AR(J)) DO 11 J=3,NPTS,2 SUM1(J-1)=STEP(J-1)*TWELTH*(5.0*RT(J-2)+8.0*RT(J-1)-RT(J)) 11 SUM2(J-1)=STEP(J-1)*TWELTH*(5.0*AR(J-2)+8.0*AR(J-1)-AR(J)) DO 9 J=3,NPTS,2 RT(J-1)=RIN+SUM1(J-1) RIN=RIN+SUM1(J) RT(J)=RIN AR(J-1)=ARA-SUM2(J-1) ARA=ARA-SUM2(J) 9 AR(J)=ARA IF(MODE) 28,32,30 28 DO 29 J=2,NPTS 29 YK(J)=(RT(J)*RK1(J)+AR(J)*RK(J))*XR(J)*WT(J) GO TO 7 C COMPUTE MAGNETIC N-INTEGRALS FOR BLUME-WATSON SCREENING 30 DO 31 J=2,NPTS 31 YK(J)=AR(J)*RK(J)*WT(J) GO TO 7 32 DO 10 J=2,NPTS 10 YK(J)=(RT(J)*RK1(J)+AR(J)*RK(J))*WT(J) JN2=N2 JL2=L2 JN4=N4 JL4=L4 C C EVALUATE THE SLATER INTEGRAL C 7 RKVAL=0.0 J1=IPOS(N1,L1) J3=IPOS(N3,L3) DO 101 J=2,NPTS 101 SUM1(J)=UJ(J,J1)*UJ(J,J3)*YK(J) DO 103 J=2,NPTS 103 RKVAL=RKVAL+SUM1(J) TEST1=TEST1+RKVAL RETURN END C*********************************************************************** SUBROUTINE SCHMDT(LP) C C ORTHOGONALIZES THE CONTINUUM ORBITALS TO THE BOUND ORBITALS C THAT ARE NOT INCLUDED IN THE LAGRANGE ORTHOGONALIZATION C IN BASFUN FOR ANGULAR MOMENTUM LP-1. C THE SCHMIDT COEFFICIENTS ARE STORED IN THE B-ARRAY C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL57= 60+ 4, LL74= 60+ 4+ 7) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SCOEFF/B(LL57,LL57),OVRLAP( 60, 4),TEMP(LL74) C C N1 IS THE NUMBER OF SCHMIDT ORTHOGONALIZED BOUND ORBITALS AND C NPTS IS THE NUMBER OF INTEGRATION POINTS C MAXHF=MAXNHF(LP) MAXLG=MAXNLG(LP) N1=MAXHF-MAXLG NPTS=IRX(NIX)+1 C C ZEROIZE THE B-ARRAY AND SET THE REQUIRED DIAGONAL ELEMENTS TO C UNITY C N=NRANG2+N1 DO 2 I=1,N DO 1 J=1,N 1 B(J,I)=0.0 2 B(I,I)=1.0 C C CALCULATE THE SCHMIDT COEFFICIENTS C DO 8 I=1,NRANG2 N2=N1+I-1 ANORM=1.0 DO 5 J=1,N2 TEMP(J)=0.0 DO 4 K=1,N1 4 TEMP(J)=TEMP(J)-B(J,K)*OVRLAP(I,K) 5 ANORM=ANORM-TEMP(J)*TEMP(J) IF(ANORM.GT.1.E-2) GO TO 3 LP=-I GO TO 12 C AS SCHMDT FAILS BECAUSE NRANG2 IS TOO BIG. WE'89MAY/JUNE. 3 ANORM=1.0/SQRT(ANORM) DO 7 J=1,N2 B(N2+1,J)=0.0 DO 6 K=1,N2 6 B(N2+1,J)=B(N2+1,J)+TEMP(K)*B(K,J) 7 B(N2+1,J)=B(N2+1,J)*ANORM 8 B(N2+1,N2+1)=ANORM C C SCHMIDT ORTHOGONALIZE THE CONTINUUM ORBITALS C I1=IPOS(MAXHF+1,LP)-1 DO 14 I=1,NPTS DO 9 J=1,NRANG2 9 TEMP(J)=UJ(I,J+I1) DO 13 J=1,NRANG2 SUM=0.0 N2=N1+J DO 11 K=1,N2 IF(K.LE.N1)GO TO 10 X1=TEMP(K-N1) GO TO 11 10 I3=IPOS(K+MAXLG,LP) X1=UJ(I,I3) 11 SUM=X1*B(N2,K)+SUM 13 UJ(I,J+I1)=SUM 14 CONTINUE C 12 RETURN END C*********************************************************************** SUBROUTINE SKIPER(L1,L2) C IMPLICIT REAL*8(A-H,O-Z) C C ROUTINE FOR READING THE CONTINUUM ORBITALS AND THE SCHMIDT C COEFFICIENTS CORRESPONDING TO THE ANGULAR MOMENTA (L1-1) AND C (L2-1) FROM THE SCRATCH DISC IDISC1 INTO THE UJ ARRAY. IF ONLY C ONE ANGULAR MOMENTUM IS REQUIRED THEN L2 MUST BE EQUAL TO ZERO C PARAMETER (LL57= 60+ 4, LL74= 60+ 4+ 7) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SCOEFF/B(LL57,LL57),OVRLAP( 60, 4),TEMP(LL74) COMMON/SKIP/ L1STO,L2STO,LPOS,NBORBS C C CALCULATE ICT, THE NUMBER OF CONTINUUM ORBITALS TO BE READ FROM C DISC, AND SET L1P AND L2P EQUAL TO THE ANGULAR MOMENTUM +1 C OF THE ORBITALS TO BE READ INTO THE FIRST AND SECOND LOCATIONS C IN CORE. L1P AND / OR L2P SET 999 WHEN CORRESPONDING LOCATIONS C ALREADY CONTAIN REQUIRED ORBITALS C ICT = 0 L1P = 0 L2P = 0 I9 = IRX(NIX)+1 NRANGB=NRANG2+1 C C L1STO AND L2STO DEFINE THE CONTENTS OF THE FIRST AND SECOND C LOCATION IN CORE. C INITIALISED TO ZERO IN GENINT. C C FIND IF ORBITALS CORRESPONDING TO L1 ARE IN CORE C IF(L1-L1STO) 2,1,2 1 L1P = 999 GO TO 5 2 IF(L1-L2STO) 4,3,4 3 L2P = 999 GO TO 5 4 ICT = ICT+1 5 IF(L2.EQ.0) GO TO 16 IF(L2.EQ.L1) GO TO 16 C C FIND IF ORBITALS CORRESPONDING TO L2 ARE IN CORE C IF(L2-L1STO) 7,6,7 6 L1P = 999 GO TO 16 7 IF(L2-L2STO) 9,8,9 8 L2P=999 GO TO 16 9 ICT = ICT+1 C C SET L1P AND L2P C IF(ICT-1) 10,10,13 10 IF(L1P-999) 11,12,11 11 L1P=L2 L1STO=L2 GO TO 21 12 L2P = L2 L2STO = L2 GO TO 21 13 IF(L1-L2) 14,15,15 14 L1P = L1 L1STO = L1 L2P = L2 L2STO = L2 GO TO 21 15 L1P = L2 L1STO = L2 L2P = L1 L2STO = L1 GO TO 21 16 IF(ICT) 17,17,18 18 IF(L1P-999) 19,20,19 19 L1P = L1 L1STO = L1 GO TO 21 20 L2P = L1 L2STO = L1 C C NOW FIND AND READ IN THE CONTINUUM ORBITALS CORRESPONDING TO THE C ANGULAR MOMENTA (L1P-1) AND (L2P-1) C LPOS CONTAINS THE LAST ANGULAR MOMENTUM PLUS ONE READ FROM DISC, C INITIALISED TO ZERO IN GENINT. C 21 IF(L1P-999) 22,23,22 22 LPLACE = 1 LSKIP = L1P GO TO 24 23 LPLACE = 2 LSKIP = L2P 24 NUMB = NBORBS + (LPLACE-1) *NRANGB N1 = NUMB+1 N2 = NUMB+NRANGB C C BACKSPACE DISC IF NECESSARY C ICOUNT = LPOS-LSKIP+1 LTEST=LPOS IF(ICOUNT) 27,27,25 25 DO 26 I=1,ICOUNT ITEST=0 IF(LTEST.LE.LRANG1)ITEST=MAXNHF(LTEST)-MAXNLG(LTEST)-MAXNCB(LTEST) IF(ITEST.GT.0) BACKSPACE IDISC1 LTEST=LTEST-1 26 BACKSPACE IDISC1 LPOS = LSKIP-1 C C READ ORBITALS FROM DISC TO LOCATION DEFINED BY LSKIP C 27 LPOS = LPOS+1 ITEST=0 IF(LPOS.LE.LRANG1) ITEST=MAXNHF(LPOS)-MAXNLG(LPOS)-MAXNCB(LPOS) IF(ITEST.EQ.0) GO TO 28 N3=ITEST+NRANG2 READ(IDISC1) ((B(I,J),I=1,N3),J=1,N3), 1 ((OVRLAP(I,J),I=1,NRANG2),J=1,ITEST) 28 READ(IDISC1) ((UJ(I,J),I=1,I9),J=N1,N2) IF(LPOS.NE.LSKIP) GO TO 27 MAXHF=LSKIP-1 IF(LSKIP.LE.LRANG1) MAXHF=MAXNHF(LSKIP) DO 29 N=1,NRANGB 29 IPOS(N+MAXHF,LSKIP) = N+NUMB C C RETURN TO READ IN NEXT SET OF CONTINUUM ORBITALS IF NECESSARY C ICT = ICT-1 IF(ICT.EQ.1) GO TO 23 17 RETURN END C*********************************************************************** SUBROUTINE SPNORB(N1,LP,N2,LX,RLBVAL) C C EVALUATES EFFECTIVE SPIN-ORBIT PARAMETERS BETWEEN C ORBITALS DEFINED BY THE QUANTUM NUMBERS (N1,LP-1) AND C (N2,LX-1) AND STORES THE RESULT IN RLBVAL. CLOSED SHELL C SCREENING IS CALCULATED ACCORDING TO BLUME AND WATSON. C C IMPLICIT REAL*8(A-H,O-Z) DIMENSION NFULL(6) LOGICAL PRNT COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/FACT/GAMMA( 57) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS COMMON/SPZETA/ZESP( 5),IZESP DATA FSC/7.29732E-3/, NFULL/2,10,18,36,54,86/, LPMAX/6/ 20 FORMAT(13H ZETA(L,N,N'=,3I3,')/(RY*AL**2) =',F11.5,' - ',2F11.5, *', NL=',I2) ! WITH NMAX =',I2) C CG2(L1,L2,L3)=(GAMMA((L1+L2+L3)/2)/(GAMMA((L2+L3-L1)/2+1) * *GAMMA((L3+L1-L2)/2)*GAMMA((L1+L2-L3)/2+1)))**2 * *GAMMA(L1+L2-L3+1)*GAMMA(L2+L3-L1+1)*GAMMA(L3+L1-L2-1) * *(2*L3-1)/GAMMA(L1+L2+L3) C N.B. WHERE L1 AND L3 INCREMENTED BY +1, L1+L2+L3 MUST BE EVEN. C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE C RLBVAL=.0 IF(LX.NE.LP) GO TO 99 IF(LP.EQ.1) GO TO 99 C C DEFINE THE ORBITALS, COMPUTE SPIN-ORBIT PARAMETER C PRNT = MAX(N1,N2).LE.MAXNHF(LP).OR.NBUG9.NE.0 I1=IPOS(N1,LP) I2=IPOS(N2,LP) SUM=.0 IF(IPSEUD.GE.0) GO TO 12 C POTENTIAL DERIVATIVE APPROXIMATION (IGNORES EXCHANGE!): L=LPOSX(LP) DO 11 J=1,NPTS IF(J.LT.NPTS) S2=(POTHAM(J+1,L)-POTHAM(J,L))/(XR(J)-XR(J+1)) IF(J.EQ.1) GO TO 11 D=1./XR(J) C SUM = ((S1+S2)*HALF+D) --- CORR'93FEB2-3 (KLAUS'92NOV13): SUM = ((S1+S2)*0.5+POTHAM(J,L)*D) * * UJ(J,I1)*UJ(J,I2)*WT(J)*D*D + SUM 11 S1=S2 GO TO 10 C 12 NMX = NMAX IF (IZESP.LT.0) GO TO 2 DO 1 N=1,NMAX NMX=N-1 IF(N.GE.N1) GO TO 2 IF(N.GE.N2) GO TO 2 CORcor IF(NELC.LE.NFULL(N+1)) GO TO 2 at'03Mar17-21, restored Nov24&Dec8 IF(NELC.LE.NFULL(N)) GO TO 2 1 CONTINUE C C NEW SUM=ORINT(I1,I2,LP,LP,-3) C TST PRINT *, ' ORINT FROM SPNORB K1,K2,LP,SUM = ',I1,I2,LP, SUM 2 DO 3 J=2,NPTS 3 SUM = UJ(J,I1)*UJ(J,I2)*WT(J)/(XR(J)*XR(J)*XR(J)) + SUM SUM=NZ*SUM C C MULTIPLY BY EFFECTIVE SCREENING FACTOR IF SUPPLIED C IF(IPSEUD.LT.0) GO TO 10 C EVENTUALLY USE THIS OPTION FOR 1/R*(DV/DR) APPROXIMATION! IF(IZESP.LE.0) GO TO 5 4 IF(IZESP.LT.LP) GO TO 10 SUM=SUM*ZESP(LP) IF(ZESP(LP).LT.0.) SUM=-ZESP(LP) GO TO 10 C C BLUME-WATSON SCREENING, CODED ALONG P.211 IN MICHAEL JONES' THESIS C 5 IF(NMX.EQ.0) GO TO 10 IF(LP.GT.LPMAX) GO TO 10 S0=.0 S1=.0 S2=.0 S3=.0 NL = 0 NLX = 0 DO 9 N=1,NMX DO 8 L=1,N NL = NL+1 IF(IZESP.LT.0 .AND. NL.GE.-IZESP) GO TO 8 IF(L.GT.LRANG1) GO TO 8 IF(IPOS(N,L).EQ.0) GO TO 8 CALL RS(N1,LP,N,L,N2,LP,N,L,0,1,D) S0 = (2*L-1)*2*D + S0 AB3=0. BA3=0. M=ABS(L-LP) M1=M IF(M1.GT.0) M1=M1-2 M2=L+LP-1 DO 7 J=M1,M2 AB1=AB2 AB2=AB3 BA1=BA2 BA2=BA3 IF(J.EQ.M2) GO TO 6 NLX=NL CALL RS(N,L,N1,LP,N2,LP,N,L,J,1,BA3) CALL RS(N1,LP,N,L,N,L,N2,LP,J,1,AB3) IF(MOD(LP+L+J,2).NE.0) GO TO 6 IF(J.EQ.0) GO TO 7 IF(J.LT.M) GO TO 7 D = ((LP-1)*LP+(J+1)*J-(L-1)*L)*3 * CG2(LP,J,L)/((LP-1)*LP*4) S3 = ( ((LP-1)*LP-(L-1)*L-(J+1)*J) * (J*AB3-(J+1)*BA1) * -((L-1)*L-(LP-1)*LP-(J+1)*J) * (J*BA3-(J+1)*AB1) ) * *D/((J+1)*J) + S3 CALL RS(N1,LP,N,L,N,L,N2,LP,J-1,-1,V1) CALL RS(N,L,N1,LP,N2,LP,N,L,J-1,-1,V2) S1 = (V1-V2)*2.*D + S1 GO TO 7 6 IF(J-1.LT.M) GO TO 7 NLX=NL S2= (J+LP+L-1)*(J-L+LP )*(J-LP+L )*(LP+L-J-1)*3*CG2(LP,J-1,L) * /((LP-1)*(J+1)*J*LP*4)*(AB2+BA2) + S2 CORR : HES+PJS SUGGESTED FROM *8 - SEE MJ'90 (13)VS(16) -- WE'93FEB2ND 7 CONTINUE IF(NBUG9.EQ.0) GO TO 8 PRINT *,' B.-W.: N,L, SUM,S0,-S1,-S2,-S3 = ',N,L,SUM,S0,S1,S2,S3 8 CONTINUE 9 CONTINUE D=S1+S2+S3 IF(PRNT) WRITE(IWRITE,20) LP-1,N1,N2, SUM,S0,D, NLX ! NMX '03Mar15 SUM = SUM-S0+D C 10 RLBVAL= FSC*FSC*SUM*0.5 IF(IPSEUD.LT.0.AND.PRNT) WRITE(IWRITE,'(44H ZETA/RY FROM DERIVATIV *E OF V FOR (N1,N2,L)=,3I3,4H IS,1P,E12.4)') N1,N2,LP-1, RLBVAL*2. C 99 RETURN END C*********************************************************************** SUBROUTINE SS(INDATA,MAXE) C C READS ORBITAL DATA FROM CHANNEL INDATA IN SUPERSTRUCTURE FORMAT C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER DLB(6)*4 DIMENSION LSTR(3), A(30),B( 108), ITO(1999),IFR(1999) EQUIVALENCE (A(1),B(1)), (ITO(1),WT(1)),(IFR(1),STEP(1)) PARAMETER (PT01=1.E-2,PT001=1.E-3,PT0001=1.E-4,TINY=1.E-6, * PI=3.1415926) PARAMETER (LL59=2*1999) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/SIMP/ R(1999),STEP(1999),WT(1999),NC C " TO END (& DIM+EQU) REPLACED BY STG1S VERSION -- WE'90MAR15: C C TINORB WILL BE USED TO SET THE BOUNDARY RADIUS RA. DATA TINORB/.001/, ALL/0.0/ 800 FORMAT(I5,2(I4,2E14.7),A3,2A4) 1400 FORMAT(2I5,2X,2I3,F4.0,I3,F12.6,I6,F12.6,1X,6A4) C1700 FORMAT(2I5,1X,3A4,2X,I3,I4,F4.0,16X,6A4) 1700 FORMAT(2I5,1X,3A4,2X,I3, 2A4, 16X,6A4) 1033 FORMAT(25X,37HHAMILTONIAN MODEL POTENTIAL FOR L+1 =,I2) 1085 FORMAT(9X,'WARNING: EARLY TRUNCATION, RB VS MACHINE WORD LENGTH MA *Y BE VERY TIGHT') 1086 FORMAT(6X,'ATTENTION: MORE POINTS SUPPLIED THAN COULD BE STORED.') 1087 FORMAT(6X,'SS SETS MAXE=',I4,' AS IT PREFERS NOT TO HALVE H NEAR 0 *.0;'/29X,'DECREMENT INTRAN IN ZUERMODS RUN!') 1088 FORMAT(6X,'MAXE =',I4,': H HALVED TO',F6.3,' BEYOND R(',I4,') =', * F7.2,';',I5,' MORE STEPS') 1089 FORMAT(' ** ATTENTION: MAXE REDUCED TO',I3,', FOR LACK OF SPACE TO * TABULATE DENSER MESH;'/15X,'RECOMPILE WITH BIGGER L.9 UNLESS IBC *=1 FACILITY IS APPROPRIATE!') 1090 FORMAT(15X,'N.B.: INDATA MUST BE NORMALIZED BUT N O T ORTHOGONAL *IZED!') 1091 FORMAT(3X,'OVERLAP INTEGRALS(N) TO L+1=',I2,':',(T35,6F8.4)) 1092 FORMAT(6X,'** INPUT TAIL TOO POOR FOR EXTRAPOLATING - DOES IT MATT *ER?') 1093 FORMAT(' INPUT RB=',F7.3,' REDUCED TO',F7.3,' FOR LACK OF SPACE: R *ECOMPILE WITH BIGGER L.9') 1084 FORMAT(9X,'EXTRAPOLATION RANGE:',' R(',I3,')=',F7.3, * 2(' (',I4,')=',F7.3) /10X,'& VALUES OF PNL(R) ',3E15.5 * /12X,'P,KK,IC,E,D;A(K) ',E15.5,2I6,F11.5,F7.2/(T15,5F12.5)) 1094 FORMAT(9X,'EXTRAPOLATION RANGE:',3(' R(',I3,')=',F7.3)/10X,'& VALU *ES OF PNL(R) ',3E15.5/12X,'P,KK,IC,E,D;A(K) ',E15.5,2I6,F11.5, * F7.2/(T15,5F12.5)) 1095 FORMAT(6X,'** WARNING: 29 WHITTAKER TERMS MAY BE NOT ENOUGH.') 1096 FORMAT(' TOO MANY ORBITALS, 25=L72.LT.',I3) 1097 FORMAT(/6X,'READING SSTRUCT INDATA (WHILE RA =',F9.4,'):') 1098 FORMAT(/' ERROR IN S.S. DATA, INTEGRATION MESH NO GOOD'/' HINT =', * F12.9,' NIX =',I3,' X =',F12.6,' J =',I3,' R(J) =',F12.6/) 1099 FORMAT(/' ERROR IN S.S. DATA, LAST CARD READ WAS AS ABOVE'/) C C READ AND PRINT HEADER FOR S.S. DATA. C NUMBER MO OF ORBITALS, MESH POINTS(NP), ELECTRONS(NELC), CHARGE(Z) C IPLACE=0 WRITE(IWRITE,1097) RA READ(INDATA,1700) KEY,MO,LSTR, IZ,NELC,Z,DLB WRITE(IWRITE,1700) KEY,MO,LSTR, IZ,NELC,Z,DLB IF(KEY.NE.-9) GO TO 99 C C READ MESH POINTS. STORE IN ARRAY R. DEFINE RC= BOUNDARY RADIUS. C 81 NP=IZ IP=IDMTST(9) NN=IP DO 19 I=1,IP ITO(I)=I 19 IFR(I)=I NC=0 RB=ABS(RA) IF(RA.EQ.ALL) RB=1.E37 DO 3 I=1,NP,2 READ(INDATA,800) KEY,MA1,EPR1,EQR1,MA2,EPR2,EQR2,LSTR IF(KEY.NE.-8) GO TO 97 IF(MA1-IP) 1,2,3 1 IF(MA2.LE.MA1) GO TO 2 H=(EPR2-EPR1)*2 IF(EPR2.GT.RB+H) GO TO 2 NC=MA2 R(MA2)=EPR2 PX(MA2)=EQR2 2 IF(EPR1.GT.RB+H) GO TO 3 NC=MAX(MA1,NC) R(MA1)=EPR1 PX(MA1)=EQR1 3 CONTINUE IF(MA1.GT.IP) WRITE(IWRITE,1086) Z=PX(1) NZ=Z+TINY NELC=NZ-(EQR1-TINY)+1 C NP=NC G=MAXE G=PI/(SQRT(G)*23) 31 H=R(NC)-R(NC-1) IF(H.LE.G) GO TO 36 F=PI/(H*23) M=F*F DO 32 I=NC,2,-1 T=R(I)-R(I-1) K=I IF(ABS(T-H).GT.PT01*H) GO TO 33 32 CONTINUE WRITE(IWRITE,1087) M MAXE=M GO TO 36 33 KK=NC-K C EVT CHECK THAT STEP LENGTH T.EQ.H/2 J=KK+NC IF(J.GT.IP) GO TO 35 NN=K N=K+1 DO 34 I=NC,N,-1 L=IFR(I) IF(L.NE.0) ITO(L)=J R(J)=R(I) PX(J)=PX(I) IFR(J)=L IFR(J-1)=0 R(J-1)=R(I)-T C INTERPOLATE EFFECTIVE CHARGE QUADRATICALLY AT NEW MIDPOINTS: P=PX(I-2)-PX(I-1) D=R(I-2)-R(I-1) Q=PX(I)-PX(I-1) E=R(I)-R(I-1) PX(J-1)=((P*E -Q*D )*T * -P*E*E+Q*D*D )*T/(D*D*E-E*E*D) + PX(I-1) 34 J=J-2 NC=KK+NC WRITE(IWRITE,1088) MAXE, T, K,R(K), KK GO TO 31 35 WRITE(IWRITE,1089) M MAXE=M C 36 IF(RA.EQ.ALL) GO TO 39 C (RA=) 0.0; OTHERWISE EXTEND MESH TO ABS(RA): M=NC DO 37 I=1,M NC=I IF(R(I).GE.RB) GO TO 39 37 CONTINUE H=R(M)-R(M-1) DO 38 I=M,IP R(I)=R(I-1)+H PX(I)=PX(I-1) NC=I IF(R(I).GE.RB) GO TO 39 38 CONTINUE WRITE(IWRITE,1093) RB,R(NC) 39 RC=R(NC) LRANG1=0 C C PROCESS POTHAM INPUT (ASSUMING NO GAPS IN ANGULAR MOMENTA SUPPLY) C IF(IPSEUD.EQ.0) GO TO 80 NELC=NZ-(PX(NC)-.001)+1 LPOT=LPOT+1 IF(LPOT.GT.IDMTST(16)) CALL RECOV1(16,LPOT) DO 82 I=1,NC 82 POTHAM(I,LPOT)=PX(I) DO 83 K=LPOT,IDMTST(15) 83 LPOSX(K)=LPOT WRITE(IWRITE,1033) LPOT C C READ AND PRINT HEADER FOR EACH ORBITAL. C N QUANTUM NUMBER, L QUANTUM NUMBER, NUMBER OF CARDS (NO) C 80 JFLG=0 IFLG=0 IPJS=0 DO 10 K=1,MO READ(INDATA,1400,ERR=84) KEY,I,N,L,X,J,EPS,NO,H, DLB 84 WRITE(IWRITE,1400) KEY,I,N,L,X,J,EPS,NO,H, DLB IF(KEY.LE.-9) GO TO 81 IF(KEY.GT.-6) GO TO 21 IF(KEY.NE.-7) GO TO 99 NBOUND=K IF( 25.LT.K) GO TO 96 IF(K.GT.IDMTST(22)) CALL RECOV1(22,K) IF(L.GE.IDMTST(15)) CALL RECOV1(15,L+1) IF(N.GT.IDMTST(23)) CALL RECOV1(23,N) IPOS(N,L+1)=K MAXNHF(L+1)=MAX(MAXNHF(L+1),N) LRANG1=MAX(LRANG1,L+1) C C READ AND STORE ORBITAL FUNCTIONS P AND Q, C DETERMINE IPJS SUCH THAT AT R(IPJS) ALL RADIAL FUNCTIONS C ARE LESS THAN TINORB IN RELATIVE VALUE C AMPL=0. DO 4 I=1,NO READ(INDATA,800) KEY,MA1,EPR1,EQR1,MA2,EPR2,EQR2,LSTR IF(KEY.NE.-6) GO TO 97 IF(MA1.GT.NP) GO TO 4 M=ITO(MA1) UJ (M,K)=EPR1 DUJ(M,K)=EQR1 IF(MA2.GT.NP) GO TO 4 IF(MA2.LT.2) GO TO 4 M=ITO(MA2) DUJ(M,K)=EQR2 UJ (M,K)=EPR2 H=ABS(EPR2) IF(H.GT.AMPL) AMPL=H IF(H.GE.TINORB*AMPL) IPJS=MAX(M,IPJS) 4 CONTINUE C C INTERPOLATE AT POINTS INSERTED BECAUSE OF HIGH ENERGY PARTIAL WVS IF(NN.GE.M) GO TO 49 A(2)=0. A(3)=0. A(4)=0. KK=MAX(NN-1,1) DO 48 I=NN,M IF(IFR(I).NE.0) GO TO 48 42 IF(A(3).GT.R(I)) GO TO 45 IF(KK.GT.M) GO TO 45 DO 44 JJ=KK,M IF(IFR(JJ).EQ.0) GO TO 44 DO 43 J=1,3 A(J)=A(J+1) A(J+4)=A(J+5) 43 A(J+8)=A(J+9) A(4)=R(JJ) A(8)=UJ(JJ,K) A(12)=DUJ(JJ,K) KK=JJ+1 IF(A(1).GT.0.) GO TO 42 44 CONTINUE C STOP 45 F=0. G=0. C LAGRANGE INTERPOLATION OF P=UJ AND Q=DUJ AT R(I): DO 47 JJ=1,4 H=1. T=1. DO 46 J=1,4 IF (JJ.EQ.J) GO TO 46 H=(R(I)-A(J))*H T=(A(JJ)-A(J))*T 46 CONTINUE F=A(JJ+4)*H/T+F 47 G=A(JJ+8)*H/T+G UJ(I,K)=F DUJ(I,K)=G CC IF(A(2).GT.R(I).OR.A(3).LT.R(I))PRINT300,NN,(J,A(J),J=1,12),I,R(I) 48 CONTINUE 49 MA2=M C C EXTEND ORBITAL ARRAY IF NOT GIVEN COMPLETELY UP TO RA. C USE FORMULA P(R)=P(RB)*(R-RA)/(RB-RA) - OR BETTER EXPLOIT C ANALYTIC BEHAVIOUR (IF EPS.LT.0 SPECIFIED) - WE'88DEC/89FEB-AVR IF(EPS.LT.0.) IFLG=IFLG+1 IF(M.GE.NC) GO TO 10 JFLG=JFLG+1 MA1=MA2 I=IFR(M) JJ=ITO(I-1) KK=ITO(I-2) IZ=-1 P=0. J=0 5 J=-J RB=R(JJ) UB=UJ(JJ,K) IF(J.LT.0) GO TO 6 E=(RB*DUJ(JJ,K)/UB-R(KK)*DUJ(KK,K)/UJ(KK,K))/(RB-R(KK)) D=(DUJ(KK,K)/UJ(KK,K)-DUJ(JJ,K)/UB)*R(KK)*RB/(RB-R(KK)) IF(EPS.GE.0.) GO TO 6 X=SQRT(-E) DO 52 I=2,M IF(I.GE.KK-1) GO TO 51 IF(ABS(UJ(I,K)).LE.1.E-10) GO TO 52 51 IZ=I IF(ABS(DUJ(I,K)/UJ(I,K)-D/R(I)-E).LT.PT001) GO TO 53 52 CONTINUE WRITE(IWRITE,1092) C AS E TOO INACCURATE AT TABULATION POINTS M-2,M-1 OR P TOO SMALL. C 53 Z=ANINT((1.-UJ(2,K)/(UJ(1,K)*R(2)**(L+1)))*(L+1)/R(2)) C -- BUT THIS IS FOUND TO BE TOO INACCURATE IF L LARGE. 53 Q=(D*0.5+Z)/X C GET A SEMI-CONVERGENT ASYMPTOTIC WHITTAKER SERIES TO Q,L AT RB: A(1)=1. F=1. H=1. T=1. J=1 DO 56 I=1,29 A(I+1)=((L+1)*L-(I-Q)*(I-1-Q))*A(I)/(2*I*X) H=RB*H IF(ABS(A(I+1)).LT.T*H) T=ABS(A(I+1))/H IF(Q+TINY.GT.I) GO TO 55 IF(I.LT.5) GO TO 54 IF(ABS(A(I+1)).LE.RB*ABS(A(I))) GO TO 54 C OUT " RESTORED AND MODIFIED WE'91MAR06 -- PERHAPS PRINT MSG: WRITE(IWRITE,1085) GO TO 58 54 IF(ABS(F*H+A(I+1)).GT.H*T*1.E+6) GO TO 58 C WHEN SMALLEST TERM IN SUM DEGRADES BY 6 DECIMAL PLACES... IF(ABS(A(I+1)).LT.ABS(F)*H*1.E-9) GO TO 58 55 F=A(I+1)/H+F 56 J=I+1 WRITE(IWRITE,1095) 58 G=Q*LOG(RB)-X*RB P=UJ(M,K) 6 DO 9 I=M,NC H=(R(I)-RC)*UB/(RB-RC) IF(J.LE.0) GO TO 8 H=1./R(I) T=A(J) DO 61 JJ=J,2,-1 61 T=T*H+A(JJ-1) H=Q*LOG(R(I))-X*R(I)-G IF(I.EQ.NC) GO TO 7 JJ=M IF(H.LT.LOG(ABS(F/(T*UB)))-69.08) GO TO 5 7 H=EXP(H)*UB*T/F T=ABS(H) IF(T.GT.AMPL) AMPL=T IF(T.GE.TINORB*AMPL) IPJS=MAX(I,IPJS) MA2=I 8 UJ(I,K)=H DUJ(I,K)=(D/R(I)+E)*H 9 M=I A(1)=-D*0.5 JJ=MIN(ABS(J),11) IF (MA2.LE.999) THEN WRITE(IWRITE,1094) MA1,R(MA1),MA2,R(MA2),NC,RC, * UJ(MA1,K),UJ(MA2,K),UJ(NC,K), P,J,IZ,E,(A(I),I=1,JJ) ELSE WRITE(IWRITE,1084) MA1,R(MA1),MA2,R(MA2),NC,RC, * UJ(MA1,K),UJ(MA2,K),UJ(NC,K), P,J,IZ,E,(A(I),I=1,JJ) ENDIF 10 CONTINUE C C RESET NC TO VALUE OF IPJS DEFINED BY TINORB UNLESS RA SPECIFIED C 21 IF(RA.LE.0.) NC=IPJS C C C CHECK INTEGRATION MESH - MUST BE AT LEAST 7 POINTS IN FIRST RANGE. C J=2 NIX=0 11 HINT=R(J) X=HINT*5. DO 12 I=J,NC IF(ABS(R(I)-X).LT.TINY) GO TO 13 12 CONTINUE J=J+1 IF(J.GT.4) GO TO 98 GO TO 11 C C REMOVE UNWANTED POINTS IN FIRST INTERVAL C 13 IF(J.EQ.1) GO TO 18 DO 17 I=2,7 14 IF(ABS(R(I)-(I-1)*HINT).LT.TINY) GO TO 17 NC=NC-1 DO 16 IP=I,NC DO 15 K=1,NBOUND UJ(IP,K)=UJ(IP+1,K) 15 DUJ(IP,K)=DUJ(IP+1,K) 16 R(IP)=R(IP+1) GO TO 14 17 CONTINUE C C DEFINE THE IHX AND IRX ARRAYS, NIX= NUMBER OF INTERVALS. C CHECK THAT MESH DOUBLES STEP-LENGTH ONLY AFTER AN ODD POINT. C 18 H=HINT J=1 NIX=1 IHX(1)=1 AMPL=PT0001 DO 20 I=1,NC X=(I-J)*H+R(J) IF(I.GT.ITO(NP)) AMPL=X*PT0001 IF(ABS(R(I)-X).LT.AMPL) GO TO 20 IF(MOD(I,2).NE.0) GO TO 98 X=X+H IF(ABS(R(I)-X).GE.PT0001) GO TO 98 NIX=NIX+1 IF(NIX.GT.IDMTST(17)) CALL RECOV1(17,NIX) IHX(NIX)=2*IHX(NIX-1) IRX(NIX-1)=I-2 H=IHX(NIX)*HINT J=I 20 STEP(I)=H C C CHECK THAT MESH HAS ODD NUMBER OF POINTS, REDEFINE RA. C NPTS=MOD(NC,2)+NC-1 IRX(NIX)=NPTS-1 RA=R(NPTS) C ORTHOGONALIZE SUBSEQUENT ORBITALS TO THOSE WITH SAME VALUE L: IF(IFLG.EQ.0) GO TO 79 DO 78 L=1,LRANG1 M=MAXNHF(L) IF(M.LE.0) GO TO 78 DO 77 N=1,M J=0 NN=IPOS(N,L) IF(NN.LE.0) GO TO 77 DO 76 K=1,N KK=IPOS(K,L) IF(KK.LE.0) GO TO 76 J=J+1 CALL ABNORM(N,L,K,L,T) C NXT EVENTUALLY ADD TAIL CONTRIBUTION TO T FROM RA TO INFINITY(Q) IF(N.EQ.K) GO TO 75 C I.E. ASSUMING INPUT IS NORMALIZED; OTHERWISE ..NE.K)GOTO72 AND C G=1.0/SQRT(T) C H=0.0 C GO TO 73 72 G=1.0/SQRT(1.0-T*T) H=T 73 DO 74 I=1,NPTS UJ(I,NN)=(UJ(I,NN)-UJ(I,KK)*H)*G 74 DUJ(I,NN)=(DUJ(I,NN)-DUJ(I,KK)*H)*G 75 B(J)=T 76 CONTINUE WRITE(IWRITE,1091) L, (B(I),I=1,J) 77 CONTINUE 78 CONTINUE IF(JFLG.NE.0) WRITE(IWRITE,1090) 79 NCOEFF=0 IF(NBUG7.NE.2) GO TO 210 WRITE(IWRITE,300) NCOEFF,(I,R(I),I=1,NC) DO 220 K=1,NBOUND 220 WRITE(IWRITE,300) K, (I,UJ(I,K),I=1,NC) 300 FORMAT(/' ORBITAL',I5/(6(I7,1P,E15.6))) C WRITE(IWRITE,'(/5H IPOS,42I3)') ((IPOS(I,K),K=1,3),I=1,LRANG1) 210 RETURN C C ERROR MESSAGES C 96 WRITE(IWRITE,1096) NBOUND GO TO 100 98 WRITE(IWRITE,1098) HINT,NIX,X,J,R(J) GO TO 100 97 WRITE(IWRITE,800)KEY,MA1,EPR1,EQR1,MA2,EPR2,EQR2,LSTR 99 WRITE(IWRITE,1099) 100 STOP END C*********************************************************************** SUBROUTINE STG1RD C C READS IN AND WRITES OUT THE INPUT DATA C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL71= 60+1, PI=3.1415926, ONE3=1./3.,TWO3=ONE3+ONE3, * FOUR3=TWO3+TWO3, PT01=1.E-2,PT0001=1.E-4,TINY=1.E-6) CHARACTER LVALUE(6)*1,TITLE(18)*4 DIMENSION NTAPE(4) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/FACT/GAMMA( 57) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/INSTO7/NBUG,INK1,INK4,LRANG3,NMIN(0: 5) COMMON/LSTORE/EXLIM(0:3, 60),LINPUT,LOOPCC,LIMEX(0: 60) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/REL/ IRELOP(3) COMMON/SIMP/ XR(1999),STEP(1999),WT(1999),NPTS COMMON/SPZETA/ZESP( 5),IZESP DATA NTAPE(1),NTAPE(2),NTAPE(3),NTAPE(4)/1,2,3,4/, * LVALUE/'S','P','D','F','G','H'/, AMP/0.004/ C 1000 FORMAT(///52X,17HSUBROUTINE STG1RD/52X,17(1H-)) 1002 FORMAT(///5X,72(1H-)//5X,18A4//5X,72(1H-)//// 1 23X,51H SSSSSSSS TTTTTTTTTT GGGGGGGG 111 2/23X,51HSSSSSSSSSS TTTTTTTTTT GGGGGGGGGG 1111 3/23X,51HSS TT GG GG 11111 4/23X,51HSS TT GG 11 5/23X,51HSS TT GG 11 6/23X,51HSSSSSSSSS TT GG 11 7/23X,51H SSSSSSSSS TT GG GGGG 11 8/23X,51H SS TT GG GGGG 11 9/23X,51H SS TT GG GG 11 1/23X,51H SS TT GG GG 11 2/23X,51HSSSSSSSSSS TT GGGGGGGGGG 11 3/23X,51H SSSSSSSS TT GGGGGGGG 11) 1004 FORMAT(/29H INPUT-OUTPUT CHANNEL NUMBERS/11I5 * /16H NBUG PARAMETERS/9I5/ * 8H ICOPY =,I3,10H ITOTAL =,I3,10H IPSEUD =,I3/ * 17H MASS-CORRECTION(,I1,2H),,13H DARWIN-TERM(,I1,2H),, * 12H SPIN-ORBIT(,I1,1H)) 1005 FORMAT(/' POSITION THE INPUT TAPE FOR COPYING SINCE ICOPY.GT.0') 1006 FORMAT(/11H BASIC DATA/) 1007 FORMAT(7H NELC =,I3,6H NZ =,I3,' LRANG1 =',I3,' LRANG2 =',I3, * ' NRANG2 =',I3/8H LAMAX =,I2,7H LAM =,I2,7H IBC =,I2, * 8H NPOT =,I2,7H LCB =,I2,' (LRANG3 =',I3,')') 1008 FORMAT(8H MAXNHF=,24I3) 1009 FORMAT(8H MAXNLG=,24I3) 1010 FORMAT(/36H R-MATRIX BOUNDARY CONDITIONS RA =,F10.5,9H BSTO =, * 1P,E12.4//' AMPLITUDE OF THE FUNCTIONS AT RA, ',9X,'RINFL'/) 1011 FORMAT(//21H THE RADIAL FUNCTIONS/37X,11HSLATER-TYPE/ * 37X,11HCOEFFICIENT,6X,10HPOWER OF R,6X,8HEXPONENT) 1012 FORMAT(/12X,I2,A1,9H ORBITAL) 1013 FORMAT(36X,F12.5,9X,I3,9X,F9.5) 1014 FORMAT(1X,I2,A1,' ORBITAL',I3,':',1P,E10.2, E19.6E1,E8.1E1) 1015 FORMAT(56H WARNING - THE NORMALIZATION INTEGRAL OF THE FUNCTION IS *, F15.7/) 1016 FORMAT(//17H INTEGRATION MESH/5H NIX=,I3/5H IHX=,20I5) 1018 FORMAT(5H IRX=,20I5//) 1019 FORMAT(7H HINT =,F12.9,9H DELTA =,F10.7,7H ETA =,F10.7/) 1020 FORMAT(/' PARAMETRIC POTENTIAL SPECIFIED: NPOT =',I3/) 1026 FORMAT(/43H NBUG7=1, THIS IS A DIMENSION TEST RUN ONLY) 1028 FORMAT(T54,20H INPUT CHANNEL ITAPE,I1,2H =,I3) 1029 FORMAT(T54,20HOUTPUT CHANNEL ITAPE,I1,2H =,I3) 1032 FORMAT(8H LPOT =,I3,' LRANG1,LRANG2 =',2I3/' MAXNC =',20I5) 1037 FORMAT(' IZESP =',I3,(T15,5F12.6)) 1038 FORMAT(8H MAXNCB=,35I3/) 6002 FORMAT(//10X,'COMPILED FOR DIMENSIONS'/ +/15X,'LENGTH OF RKST01 IN /INSTO2/ (AMP)L.1 = 4000' +/15X,'LENGTH OF RKSTO2 IN /INSTO2/ (AMP)L.2 =1180800' +/15X,'ISTBC1 + ISTBC2 IN /INSTO3/ (AMP)L.3 = 600' +/15X,'ISTBB1 + ISTBB2 IN /INSTO3/ (AMP)L.4 = 112' +/15X,'NUMBER NRANG2 OF CONTINUUM ORBS (AMP)L.7 = 60' +/15X,'FACTORIAL VALUES IN /FACT/ (AMP)L.8 = 57' +/15X,'SIZE OF RADIAL TABULATION GRID (AMP)L.9 = 1999' +/15X,'IPOT,CPOT,XPOT IN /POTEN/ (AMP)L10 = 6' +/15X,'NO. OF CONTINUUM ANGULAR MOM. (AMP)L15 = 49' +/15X,'NO. OF BOUND ANGULAR MOMENTA (AMP)L16 = 5' +/15X,'IHX AND IRX IN /INIT/ (AMP)L17 = 9' +/15X,'ORDER OF MULTIPOLES IN POTENTIAL (AMP)L18 = 8' +/15X,'SIZE OF ONEST1 IN /INSTO2/ (AMP)L19 = 56') 6003 FORMAT( + 15X,'SIZE OF ONEST2 IN /INSTO2/ (AMP)L20 = 600' +/15X,'SIZE OF ONEST3 IN /INSTO2/ (AMP)L21 = 1830' +/15X,'FUNCTIONS UJ IN /ORBTLS/ (AMP)L22 = 128' +/15X,'VALUES N IN IPOS IN /ORBTLS/ (AMP)L23 = 108' +/15X,'SECOND DIM OF OVRLAP IN /SCOEFF/ (AMP)L24 = 4' +/15X,'LENGTH OF NCO IN /RADIAL/ (AMP)L26 = 40' +/15X,'C, ZE AND IRAD IN /RADIAL/ (AMP)L27 = 300' +/15X,'FOR DIMEN. IN /BNDORB/ ETC. (AMP)L28 = 7' +/15X,'LENGTH OF SKSTO2 IN /JNSTO/ (AMP)L29 = 5000',2H'0 +/15X,'MAX. NO OF S.S. TARGET ORBITALS (AMP)L72 = 25'//) C C THE FOLLOWING FORMAT STATEMENTS ARE TO READ THE CARD INPUT DATA C C2000 FORMAT(12I5) C2001 FORMAT(5F14.7) 2002 FORMAT(18A4) C READ(IREAD,2002) TITLE NEW=0 IF(TITLE(1).EQ.'CIV3'.OR.TITLE(1).EQ.'S.S.') NEW=1 IF(TITLE(1).EQ.'STO-') NEW=-1 IF(NEW.EQ.0) READ(IREAD,*) IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3, 1 ITAPE1,ITAPE2,ITAPE3,ITAPE4,JDISC1,JDISC2 WRITE(IWRITE,1002) TITLE C C WRITE OUT DIMENSIONS COMPILED FOR C WRITE(IWRITE,6002) WRITE(IWRITE,6003) C C INITIALISE C DO 6 L=1, 49 DO 5 J=1, 108 5 IPOS(J,L)=0 LPOSX(L)=1 MAXNCB(L)=0 MAXNC(L)=L-1 MAXNHF(L)=L-1 6 MAXNLG(L)=L-1 LPOT = 0 NELCOR=0 BSTO=0.0 MAXE=9999 C ETA=0.2*PT0001 DELTA=ETA c '00 Jul 17: ' setting LIMEX = 12 *****************************' c '01 Apr 1/4 ' setting LIMEX back to initial 99[99] <<<<<<<<<<<' C Apr 11: back to 12; Apr12ff: N-individual coding in GENCC print *, " >>> stgt'01Apr13-6: individual LIMEX(1:NRANG2) <<<" LIMEX(0) = 99 DO 888 I=1, 60 888 LIMEX(I) = 0 LRANG3 = 0 C IF(NEW.NE.0) CALL NAME(TITLE(1),IBC,MAXE,LCB) WRITE(IWRITE,1000) LINPUT=0 ICOPY1=1 IF(NEW.NE.0) GO TO 8 READ(IREAD,*) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6, * NBUG7,NBUG8,NBUG9 C C POSITION THE INPUT TAPE FOR COPYING, IF NECESSARY. C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF GENINT. C C LINPUT IS THE MAXIMUM CONTINUUM ANGULAR MOMENTUM +1 OF A PREVIOUS C RUN OF STG1, INITIALLY SET ZERO. C C IPSEUD.NE.0 FOR MODEL POTENTIAL (READ BY SS AS EFFECTIVE CHARGES) C C READ IN WHICH RELATIVISTIC OPERATORS ARE TO BE INCLUDED: C IRELOP(1) = 1 FOR MASS CORRECTION; C IRELOP(2) = 1 FOR DARWIN TERM; C IRELOP(3) = 1 FOR SPIN-ORBIT. C READ(IREAD,*) ICOPY,ITOTAL,IPSEUD, IRELOP, IZESP ICOPY2=ICOPY 8 WRITE(IWRITE,1004)IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2 * ,ITAPE3,ITAPE4,JDISC1,JDISC2, * NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 * ,ICOPY2,ITOTAL,IPSEUD, IRELOP C OUT IF(IPSEUD.GT.0) WRITE(IWRITE,1028) NTAPE(1),ITAPE1 IF(IZESP.GT.0) READ(IREAD,*) (ZESP(I),I=1,IZESP) IF(IZESP.NE.0) WRITE(IWRITE,1037)IZESP,(ZESP(I),I=1,IZESP) IF(NBUG7.EQ.1) ICOPY2=0 IF(ICOPY2) 2,1,3 1 WRITE(IWRITE,1029)NTAPE(3),ITAPE3 GO TO 4 2 ICOPY1=7 ICOPY2=999 3 WRITE(IWRITE,1028)NTAPE(2),ITAPE2 WRITE(IWRITE,1029)NTAPE(3),ITAPE3 WRITE(IWRITE,1005) CALL CHEKTP(ITAPE2) WRITE(IWRITE,1000) LINPUT=LRANG2 ! is it defined?? '04Jul9 C C READ AND WRITE CASE IDENTIFIERS C CHECK INPUT DATA AGAINST POSSIBLE ARRAY OVERFLOW C SET BSTO, THE LOGARITHMIC DERIVATIVE ON THE BOUNDARY C C MAXNCB(L+1) IS THE NUMBER OF CONTINUUM ORBITALS TO BE TREATED C AS BOUND: LCB IS THEN THE HIGHEST L+1 FOR SUCH TREATMENT C (NELCOR IS THE NUMBER OF ELECTRONS TO BE USED FOR THE POTENTIAL) C 4 WRITE(IWRITE,1006) IF(NEW.EQ.0) THEN L=0 IF(IZESP.LT.0) L=1 READ(IREAD,*) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM,IBC,NPOT,LCB *,(LRANG3,I=1,L) !or IF(IZESP.LT.0) READ(IREAD,*)LRANG3 ENDIF WRITE(IWRITE,1007)NELC,NZ,LRANG1,LRANG2, * NRANG2,LAMAX,LAM,IBC,NPOT,LCB,LRANG3 IPLACE=-1 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) IF(NEW.EQ.0) READ(IREAD,*) (MAXNHF(I),I=1,LRANG1) WRITE(IWRITE,1008)(MAXNHF(I),I=1,LRANG1) IF(NEW.EQ.0) READ(IREAD,*) (MAXNLG(I),I=1,LRANG1) WRITE(IWRITE,1009)(MAXNLG(I),I=1,LRANG1) IF(LCB.GT.0) READ(IREAD,*) (MAXNCB(I),I=1,LCB),NELCOR IF(LCB.GT.0) WRITE(IWRITE,1038) (MAXNCB(I),I=1,LCB) IF(NELCOR.GT.0) WRITE(IWRITE,*) 'NELCOR',NELCOR IF(NELCOR.EQ.0) NELCOR=NELC LAMBC=0 LAMCC=0 IF(LAM.GE.2) LAMBC=LAMAX IF(LAM.GE.3) LAMCC=LAMAX C C CHECK SIZE OF ARRAYS ASSOCIATED WITH THE BOUND ORBITALS C SET NLIMIT = THE LARGEST N-VALUE FOR THE BOUND ORBITALS C NCOEFF = THE MAXIMUM NUMBER OF TERMS ALLOWED IN ANY ORBITAL C NLIMIT=0 NBOUND=0 DO 7 L=1,LRANG1 IF(MAXNHF(L).GT.NLIMIT) NLIMIT=MAXNHF(L) MS=MAXNLG(L)-L+1 IF(MS.GT.IDMTST(28)) CALL RECOV1(28,MS) MS=MAXNHF(L)-MAXNLG(L) IF(MS.GT.IDMTST(24)) CALL RECOV1(24,MS) 7 NBOUND=NBOUND+MAXNHF(L)-L+1 IF(NBOUND.GT.IDMTST(30)) CALL RECOV1(30,NBOUND) MS=NBOUND+NRANG2 IF(MS.GT.IDMTST(22)) CALL RECOV1(22,MS) MS=LRANG2-1+NRANG2 IF(MS.GT.IDMTST(23)) CALL RECOV1(23,MS) MS=NLIMIT+NRANG2 IF(MS.GT.IDMTST(23)) CALL RECOV1(23,MS) MAXNCO=NLIMIT*(LRANG1-1)+MAXNHF(LRANG1) IF(MAXNCO.GT.IDMTST(26)) CALL RECOV1(26,MAXNCO) IF(IPLACE.EQ.26) GO TO 31 NTERMS=IDMTST(27) IF(NEW.EQ.0) NCOEFF=NTERMS/MAXNCO C C SET UP THE FACTORIAL ARRAY GAMMA(I+1) = FACTORIAL I C NFACT=(MAX(MIN(LRANG2,6),LRANG1)+LRANG1-1)*2 C SEE SPNORB: LPMAX=6 BLUME-WATSON LIMIT IF(IRELOP(3).NE.0 .AND. NFACT.GT.IDMTST(8)) CALL RECOV1(8,NFACT) NFACT=IDMTST(8) * CALL SHRIEK(NFACT) -- '01Apr14: GAMMA(1)=1 DO 777 I=2,NFACT 777 GAMMA(I)=(I-1)*GAMMA(I-1) CCC IF(NCOEFF.EQ.0) GO TO 19 IF(NEW.NE.0) GO TO 19 ! '05Feb05 C C INITIALIZE VARIABLES AND ARRAYS ASSOCIATED WITH STORING THE C RADIAL FUNCTIONS C IF(NEW.NE.0) GO TO 91 DO 9 J=1,NTERMS C (J)=0.0 ZE (J)=0.0 IF(J.LE.MAXNCO) NCO(J)=0 9 IRAD(J)=0 91 ZMIN =1.0/TINY JZMIN=1 IMAX =0 TEST =PT01 WRITE(IWRITE,1011) C C READ IN THE RADIAL FUNCTIONS AND STORE THEM IN ARRAYS IN /RADIAL/ C DO 18 L=1,LRANG1 MAXHF=MAXNHF(L) DO 17 N=L,MAXHF WRITE(IWRITE,1012) N,LVALUE(L) M1=NLIMIT*(L-1)+N M=NCO(M1) C IF(NEW.EQ.0) READ(IREAD,2000) M IF(NEW.EQ.0) READ(IREAD,*) M MS=M*MAXNCO IF(M.GT.NCOEFF) CALL RECOV1(27,MS) IF(IPLACE.EQ.27) GO TO 31 NCO(M1)=M JLAST=NCOEFF*(M1-1) JSTART=JLAST+1 JEND =JLAST+M IF(NEW.NE.0) GO TO 92 READ(IREAD,*) (IRAD(J),J=JSTART,JEND) READ(IREAD,*) (ZE (J),J=JSTART,JEND) READ(IREAD,*) (C (J),J=JSTART,JEND) C C SET IMAX = THE LARGEST POWER OF R, TO BE USED IN A DIMENSION C TEST ON THE FACTORIAL ARRAY. C JZMIN = THE TERM WITH THE SMALLEST EXPONENT, ZMIN, TO BE USED C TO FIND AN INITIAL ESTIMATE OF THE BOUNDARY RADIUS. C ALSO CHECK THE NORMALIZATION OF THE ORBITALS. C 92 X=0.0 DO 11 J=1,M J1=JLAST+J IF(IRAD(J1).LE.IMAX) GO TO 10 IMAX=IRAD(J1) NFACT=IMAX+IMAX+1 IF(NFACT.GT.IDMTST(8)) CALL RECOV1(8,NFACT) IF(IPLACE.EQ.8) GO TO 31 10 IF(ZE(J1).GE.ZMIN) GO TO 11 ZMIN =ZE(J1) JZMIN=J1 11 X=X+C(J1)*ORNO(J,N,N,L) IF(ABS(X-1.0).LE.TEST) GO TO 15 C C CONVERT CLEMENTI-TYPE COEFFICIENTS TO SLATER-TYPE C DO 13 J=1,M IR=IRAD(J+JLAST) Y=2.0*ZE(J+JLAST) 13 C(J+JLAST)=C(J+JLAST)*SQRT(Y/GAMMA(IR+IR+1))*Y**IR X=0.0 DO 14 J=1,M 14 X=C(J+JLAST)*ORNO(J,N,N,L)+X IF(ABS(X-1.0).LE.TEST) GO TO 15 WRITE(IWRITE,1015) X C C RENORMALIZE AND WRITE OUT THE ORBITAL C 15 Y=SQRT(X) DO 16 J=1,M J1=JLAST+J C(J1)=C(J1)/Y 16 WRITE(IWRITE,1013) C(J1),IRAD(J1),ZE(J1) 17 CONTINUE 18 CONTINUE C C IBC = 0 IF RA AND BSTO ARE TO BE GENERATED AUTOMATICALLY, C = 1 IF THE VALUES OF RA AND BSTO ARE TO BE READ IN. C SET MODE = 0 FOR A PRINT-OUT OF THE BOUND ORBITALS AT RA. C IF(IBC.EQ.0) GO TO 20 IF(NEW.EQ.0) READ(IREAD,*) RA,BSTO 19 WRITE(IWRITE,1010)RA,BSTO MODE=0 GO TO 22 C C DETERMINE THE LOWEST VALUE FOR THE BOUNDARY RADIUS, RA, SUCH THAT C NO BOUND ORBITAL EXCEEDS THE VALUE OF TINORB ON THE BOUNDARY. C IRA = AN INITIAL WHOLE NUMBER ESTIMATE FOR RA, DETERMINED FROM C THE FUNCTION WITH THE SMALLEST EXPONENT. C 20 TINORB=AMP IF(ICOPY2.GT.0) GO TO 19 RA=-LOG(TINORB)/ZMIN RA=RA+IRAD(JZMIN)*LOG(RA)/ZMIN IRA = NINT(RA) SMALL=0.2 C 21 RA=IRA IF(RA.LT.SMALL) RA=SMALL MODE=-1 C C EVALUATE THE AMPLITUDE PA OF THE BOUND ORBITALS ON THE BOUNDARY C 22 I1=0 DO 27 L=1,LRANG1 DO 26 N=L,MAXNHF(L) PB = 0. H = 0. IF(NCOEFF.LE.0) GO TO 75 I1=I1+1 M1=NLIMIT*(L-1)+N J1=(M1-1)*NCOEFF M=NCO(M1) 23 PA = 0. DO 24 J=1,M IF(MODE.GT.0) GO TO 24 DO 74 I=1,M X = 1./(ZE(I+J1)+ZE(J+J1)) Y = X DO 73 K=1,IRAD(I+J1)+IRAD(J+J1)+1 73 Y = K*X*Y 74 PB = C(I+J1)*C(J+J1)*Y + PB 24 PA=PA+C(J+J1)*RA**IRAD(J+J1)*EXP(-ZE(J+J1)*RA) IF(MODE.EQ.0) GO TO 25 IF(ABS(PA).LE.TINORB) GO TO 26 C ABS( ) VKL+WE 30AVRIL1989 RA=RA+SMALL MODE=1 GO TO 23 75 I1=IPOS(N,L) C COR J1=IRX(NIX) -- ADD 1 -- KAB&WE'89FEB9TH: J1=IRX(NIX)+1 PA=UJ(J1,I1) Y = 0. DO 71 I=2,J1-1,2 X = Y Y = UJ(I+1,I1)*UJ(I+1,I1)*XR(I+1) 71 PB = (UJ(I,I1)*UJ(I,I1)*XR(I)*4. + Y + X)*STEP(I) + PB PB = PB/3. X = 0. DO 72 I=J1-1,1,-1 IF(ABS(UJ(I,I1)).LT.0.02) GO TO 72 H = XR(I+1) Y = X X = ABS((UJ(I+1,I1)-UJ(I,I1)))/(H-XR(I)) IF(X.LE.Y) GO TO 25 72 CONTINUE 25 WRITE(IWRITE,1014) N,LVALUE(L),I1,PA, PB,H 26 CONTINUE 27 CONTINUE C C MODE = -1 IF RA CAN BE DECREASED, C = +1 IF RA HAS BEEN INCREASED TO ITS FINAL VALUE. C IF(NCOEFF.EQ.0) GO TO 30 IF(MODE) 28,29,19 28 IRA=IRA-1 IF(IRA) 19,21,21 C C DETERMINE THE INTEGRATION MESH, CHECK DIMENSIONS C 29 IF(IPSEUD.GT.0) GO TO 30 IF(ICOPY2.GT.0) GO TO 30 IF(NRANG2.EQ.IDMTST(7).AND.MAXE.LT.9999) * NRANG2 = MIN(IDMTST(7),NINT(RA*SQRT(2.0*MAXE)/PI)+1) IF(ABS(IBC).EQ.2) GO TO 291 294 CALL MESH GO TO 30 291 READ(IREAD,*) J IF(J.LE.0) GO TO 293 IF(J.GT.IDMTST(17)) CALL RECOV1(17,J) READ(IREAD,*) (IHX(I),I=1,J) READ(IREAD,*) (IRX(I),I=1,J) NIX=J 293 READ(IREAD,*) X,DELTA,ETA IF(J.LE.0) GO TO 294 HINT=X GO TO 30 C C READ IN CORE DATA FROM ITAPE1 IF REQUIRED C 30 WRITE(IWRITE,1016) NIX, (IHX(I),I=1,NIX) WRITE(IWRITE,1018) (IRX(I),I=1,NIX) WRITE(IWRITE,1019) HINT,DELTA,ETA C C DEFINE THE NPTS MESH POINTS (XR), STEP-LENGTHS (STEP) AND C SIMPSONS RULE WEIGHTS (WT). C IFI=1 IFX=0 XR(1)=0.0 STEP(1)=0.0 DO 33 I=1,NIX H=IHX(I)*HINT WT(IFI)=(H+STEP(IFI))*ONE3 X=XR(IFI) IST=IFI+2 IFI=IRX(I)+1 DO 32 J=IST,IFI,2 XR(J-1)=X+(J-2-IFX)*H XR(J) =X+(J-1-IFX)*H STEP(J-1)=H STEP(J) =H WT(J-1)=FOUR3*H 32 WT(J) =TWO3*H 33 IFX=IRX(I) WT(IFI)=ONE3*H NPTS=IFI C C NPOT = 0 IF THE POTENTIAL IS TO BE GENERATED AUTOMATICALLY, C GT.0 IF THE POTENTIAL FUNCTION IS TO BE READ IN. C C C READ POTENTIAL PARAMETERS, CHECK DIMENSIONS C IF(NPOT.EQ.0) GO TO 31 WRITE(IWRITE,1020)NPOT IF(NEW.NE.0) GO TO 31 NPOT=MAX(0,NPOT) IF(NPOT.GT.IDMTST(10)) CALL RECOV1(10,NPOT) IF(IPLACE.EQ.10) GO TO 31 READ(IREAD,*) (IPOT(I),I=1,NPOT) READ(IREAD,*) (CPOT(I),I=1,NPOT) READ(IREAD,*) (XPOT(I),I=1,NPOT) C C IF IPLACE HAS BEEN SET GREATER THAN ZERO BY A CALL TO RECOV1, C THEN CONTINUE WITH A FULL DIMENSION TEST BY SETTING NBUG7=1 C 31 IF(IPLACE.GT.0) NBUG7=1 IF(NBUG7.EQ.1) WRITE(IWRITE,1026) IF(ITAPE4.GT.0) CALL TABORB(ITAPE4,NBOUND) IF(NBUG5.GT.0) CALL TABORB(IWRITE,NBOUND) IF(LCB.GT.0.AND.NCOEFF.GT.0) THEN CALL TABORB(0,NBOUND) NCOEFF=0 ENDIF C C DEFINE THE MAXPN ARRAY TO FOOL STG2R AND CHECK THAT THERE IS C A VALENCE ORBITAL FOR EACH ANGULAR SYMMETRY. THIS PARAMETER C ICHECK IS USED IN SUBROUTINE GENINT. C IF(IPSEUD.EQ.0) GO TO 34 READ(IREAD,*) L,(MAXNC(I),I=1,L) WRITE(IWRITE,1032) LPOT, LRANG1,LRANG2, (MAXNC(I),I=1,L) 34 ICHECK=0 NMAX = 0 DO 39 I=1,LRANG1 NMAX = MAX(MAXNHF(I),NMAX) !'03Mar17 IF(MAXNC(I).EQ.MAXNHF(I)) ICHECK=1 39 MAXPN(I)=MAXNHF(I)-MAXNC(I)+I-1 RETURN END C*********************************************************************** SUBROUTINE TABORB(IOUT,MO) C C WRITES OUT ORBITAL DATA TO CHANNEL IOUT IN SUPERSTRUCTURE FORMAT C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/ORBTLS/UJ(1999, 128),DUJ(1999, 25),NBOUND,IPOS( 108, 49) COMMON/POTEN/ CPOT( 6),XPOT( 6),IPOT( 6),NPOT COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/SIMP/ R(1999),STEP(1999),WT(1999),NC C DATA NULL/0/, IHEAD/4HSTG1/ 800 FORMAT(I5,2(I4,1P,2E14.7),3X,A4,I2,I1,A1) 1400 FORMAT(' -7',I5,2X,2I3,F4.0,I3,F12.6,I6,F12.6,17X,A4,2X,I1,A1) 1700 FORMAT(' -9',I5,1X,F5.4,F7.2,I5,I4,I4, 36X,A4) C C " TO END COPIED FROM STG1S -- WE'90MAR15 C WRITE HEADER FOR S.S. DATA, C NUMBER OF ORBITALS(MO), MESH POINTS(NO), ELECTRONS NELC, CHARGE DZ C DZ=NZ ZN=(NZ+NZ) IF(IOUT.LE.0) GO TO 4 ZZZ=DZ**(1.0/3) WRITE(IOUT,1700) MO,R(2),R(NC),NC,NELC,NZ,IHEAD C C WRITE MESH POINTS FROM ARRAY R C KEY=-8 DO 3 I=1,NC,2 J=I+1 IF(J.GT.NC) J=1 IF(NPOT.LT.0) GO TO 3 PX(I)=(EXP(-ZZZ*R(I))-1.0)*(NELC-1)+DZ PX(J)=(EXP(-ZZZ*R(J))-1.0)*(NELC-1)+DZ 3 WRITE(IOUT,800) KEY, I,R(I),PX(I), J,R(J),PX(J), IHEAD C C LOOP OVER ANGULAR MOMENTUM AND N VALUES OF ORBITALS C 4 IF(NCOEFF.GT.0) NBOUND=0 DO 18 LP=1,LRANG1 MAXHF=MAXNHF(LP) IF(MAXHF.LT.LP) GO TO 18 IF(NCOEFF.GT.0) CALL EVALUE(LP,NBOUND) IF(IOUT.LE.0) GO TO 18 C OUT R2=R(2)**(-LP); R3=R(3)**(-LP) L=LP-1 DO 17 N=LP,MAXHF K=IPOS(N,LP) C C WRITE HEADER FOR EACH ORBITAL; C N QUANTUM NUMBER, L QUANTUM NUMBER, NUMBER OF CARDS(NO). C EPS=0.0 IF(N*N*ABS(DUJ(NC-1,K)).GE.DZ*DZ*ABS(UJ(NC-1,K))) GO TO 15 EPS=(R(NC-1)*DUJ(NC-1,K)/UJ(NC-1,K) * -R(NC-2)*DUJ(NC-2,K)/UJ(NC-2,K))/(R(NC-1)-R(NC-2)) 15 NO=(NC+1)/2 WRITE(IOUT,1400) K,N,L,DZ,NELC,0.0,NO,EPS,IHEAD C EPS MOVED! C WRITE ORBITALS: C FUNCTION P IN ARRAY UJ, ONE-ELECTRON FUNCTION Q IN ARRAY DUJ C KEY=-6 C OUT DUJ(1,K)=(DUJ(2,K)*R2*R(3)-DUJ(3,K)*R3*R(2))/(R(3)-R(2)) DO 16 I=1,NC,2 J=I+1 IF(J.GT.NC) J=1 16 WRITE(IOUT,800) KEY,I,UJ(I,K),DUJ(I,K), * J,UJ(J,K),DUJ(J,K),IHEAD,K 17 CONTINUE 18 CONTINUE IF(IOUT.GT.0) WRITE(IOUT,800) NULL RETURN END C*********************************************************************** SUBROUTINE WRITAP C C WRITES THE BASIC INFORMATION ONTO THE STG1 PERMANENT OUTPUT FILEs C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999, LL71= 60+1) COMMON/BASIC/ BSTO,RA,NELC,NRANG2 COMMON/BASIN/ EIGENS( 60, 49),ENDS(LL71, 49),DELTA,ETA COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/BUTT/COEFF(3, 49),EK2MAX,EK2MIN,MAXNCB( 49),NELCOR COMMON/COPY/ ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON/CORE/ POTHAM(1999, 5),LPOT,LPOSX( 49), * MAXNC( 49),MAXPN( 49),ICHECK,IPSEUD,NMAX COMMON/DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, * ITAPE4,JDISC1,JDISC2 COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/POTVAL/POVALU(LL59),PX(1999) COMMON/RADIAL/C( 300),ZE( 300),IRAD( 300),NCO( 40),LRANG1,LRANG2, * MAXNHF( 49),MAXNLG( 49),NCOEFF,NLIMIT,NZ COMMON/REL/ IRELOP(3) COMMON/SPZETA/ZESP( 5),IZESP C IF(ITOTAL.LE.0) GO TO 9 ITAPE=ITAPE3 REWIND ITAPE ICODE=13 WRITE(ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,IZESP *,(IRELOP(I),I=1,3) WRITE(ITAPE) (MAXPN(L),L=1,LRANG1),(MAXNLG(L),L=1,LRANG1) *,(MAXNC(L),L=1,LRANG1) DO 1 L=1,LRANG2 WRITE(ITAPE) (EIGENS(N,L),N=1,NRANG2) 1 WRITE(ITAPE) (ENDS(N,L),N=1,NRANG2+1) WRITE(ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX WRITE(ITAPE) (IHX(I),I=1,NIX),(IRX(I),I=1,NIX) IPTS=2*IRX(NIX) WRITE(ITAPE) (POVALU(I),I=1,IPTS) REWIND IDISC2 DO 4 LP=1,LRANG1 NBT=MAXNLG(LP)-LP+1 IF(NBT) 4,4,2 2 READ(IDISC2)((P(K,I),K=1,NBT),I=1,IPTS) DO 3 K=1,NBT 3 WRITE(ITAPE) (P(K,I),I=1,IPTS) 4 CONTINUE IF(LRANG2.LE.0) GO TO 9 WRITE(ITAPE)((COEFF(I,L),I=1,3),L=1,LRANG2) C 9 RETURN END C C*********************************************************************** C C C INSERT A NEW VERSION OF BASFUN, THE PROGRAM TO GENERATE NUMERICAL C ORBITAL FUNCTIONS TO BE PUBLISHED WITH THE R-MATRIX PROGRAMS C C C*********************************************************************** C SUBROUTINE BASFUN(NBT,LC,NODES,RA,BSTO,WINIT,DELTA,ETA) C IMPLICIT REAL*8(A-H,O-Z) C C NEW NUMERICAL R-MATRIX ORBITAL ROUTINE C*********************************************************************** C C OPERATING INSTRUCTIONS C C*********************************************************************** C C 1. THE USER MUST PROVIDE THE FOLLOWING INPUT DATA... C C NBT....... THE NUMBER OF FUNCTIONS TO WHICH THE SOLUTION IS TO BE C ORTHOGONALIZED...... IF NBT.GT.5 IS REQUIRED THE FIRST C INDEX IN THE ARRAYS US,P,U,DU,FR,FRH,FRM,ALAMDA,DELT, C SDELT,UNAME,ADEL,ADL,BDL SHOULD BE INCREASED. C C LC........ THE ANGULAR MOMENTUM VALUE C C RA........ THE BOUNDARY RADIUS C C BSTO...... THE VALUE OF THE LOGARITHMIC DERIVATIVE AT X=RA C C WINIT..... THE INITIAL ENERGY OR POTENTIAL MULTIPLE VALUE C .... IF ETA=0.0 OR IS LESS THAN 1.0E-8 THE WAVE C FUNCTION WILL BE EVALUATED AT THIS VALUE. IF ETA C IS GREATER THAN 1.0E-8 (TYPICALLY ETA=0.00001) THEN THE C PROGRAM WILL ITERATE FROM WR OR PR=WINIT TO THE VALUE C OF WR OR PR WHICH GIVES A SOLUTION SATISFYING THE C LOGARITHMIC BOUNDARY CONDITION AT X=RA C C DELTA..... THE INCREMENT IN THE ENERGY OR POTENTIAL MULTIPLE USED C FOR OBTAINING THE DERIVATIVE IN NEWTONS METHOD....THIS C SHOULD BE OF THE SAME ORDER AS ETA C C ETA....... THE PROGRAM WILL STOP ITERATING TO FIND THE EIGENVALUE C WHEN THE CORRECTION TO THE ENERGY OR POTENTIAL MULTIPLE C BECOMES LESS THAN ETA. C C IREAD..... THE INPUT PERIPHERAL NUMBER C C IWRITE.... THE OUTPUT PERIPHERAL NUMBER C C HINT...... THE BASIC INTEGRATION STEP LENGTH C C NIX....... THE NUMBER OF CHANGES OF INTEGRATION STEP OR THE NUMBER C OF INTERVALS INTO WHICH THE RANGE X=0 TO RA IS DIVIDED C C IHX(I),I=1,NIX.... THE MULTIPLE OF THE BASIC INTEGRATION STEP IN C EACH INTERVAL C C IRX(I),I=1,NIX.... THE TOTAL NUMBER OF INTEGRATION STEPS TO THE C END OF THE I'TH INTERVAL C C C 2. THE USER MUST PROVIDE THE POTENTIAL FUNCTION AND ORTHOGONALISATION C FUNCTIONS AND STORE THEM IN THE ARRAYS POVALU(1600) AND P(1600) C C ** THESE MUST BE EVALUATED AS FOLLOWS --- MUST BEING EMPHASISED ** C C THE ODD ELEMENTS POVALU(2N-1) AND P(I,2N-1),N=1,IRX(NIX), SHOULD C CONTAIN THE FUNCTION VALUES AT THE HALF-MESH POINTS. C C THE EVEN ELEMENTS POVALU(2N) AND P(I,2N),N=1,IRX(NIX), SHOULD C CONTAIN THE VALUES AT THE MESH POINTS. C C*********************************************************************** C C DEBUGGING PARAMETERS C C*********************************************************************** C C IF THESE ARE SET EQUAL TO ZERO THERE IS NO INTERMEDIATE PRINT-OUT C C NBUG1.....IF THIS IS NON-ZERO THE INTERMEDIATE INTEGRATIONS AND C ENERGIES ARE OUTPUT C C NBUG3.....IF THIS IS NON-ZERO THE ARRAYS FOR THE DETERMINATION C OF THE MISMATCH ARE OUTPUT C C*********************************************************************** C C OUTPUT RESULTS C C*********************************************************************** C C ORB(K) , K=1,IRX(NIX)+1 CONTAINS THE FINAL SOLUTION C C NODES.... IS THE NUMBER OF NODES IN THE FUNCTION C C EIGEN IS THE EIGENVALUE C C ALAMDA(I),I=1,NBTP1 CONTAINS THE NORMALISED LAGRANGE MULTIPLIERS C C ?? ANORMI IS THE STURMIAN NORMALISATION COEFFICIENT FOR R.GT.RA C C BVALUE IS THE LOGARITHMIC DERIVATIVE VALUE AT R=RA C C*********************************************************************** C C OTHER VARIABLE AND ARRAY DEFINITIONS C C*********************************************************************** C C SEE THE LONG WRITE-UP C PARAMETER (HALF=0.5,TWO=2.0,THREE=3.0,FOUR=4.0,TWELVE=12.0, * ONEPT5=1.0+HALF, THIRD=1./3.0,TINY=1.E-6) PARAMETER (LL59=2*1999, LL90= 7+1, LL91= 7+2, LL92= 7+3) DIMENSION AVAL(2),ADL(LL91),ORTH(LL90),BNDRY(2),DBNDRY(2) DIMENSION YIN(LL90),YOUT(LL90),DYIN(LL90),DYOUT(LL90) DIMENSION US(LL90,1999 ),DUS(LL90,1999 ) DIMENSION DU(LL90),FR(LL90),FRM(LL90),DELT(LL90,LL90) DIMENSION ADEL(LL92,LL92),BDL(LL92), SDELT(LL91,LL91) COMMON/BASDER/FM,TLC,WR,ITST,JR,KM,MMM,NBTP1,NG COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/FUNVAL/FRH(LL90),U(LL90),X COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/ORBOUT/ORB(1999),DORB(1999),EIGEN,ALAMDA(LL90),BVALUE COMMON/POTVAL/POVALU(LL59),PX(1999) C 1001 FORMAT(8F15.8) 1002 FORMAT(/54H **** DEBUGGING PRINT-OUT IN BASFUN FOR NBUG1=0 ****/ * /5H IEN=,I2,6X,4HJEN=,I2,6X,10HENERGY WR=,F14.7,5H RYDS * //20H OUTWARD INTEGRATION) 1004 FORMAT(/13H ERROR - IRX(,I1,27H)IS AN ODD NUMBER IN BASFUN/) 1005 FORMAT(/9X,1HR,(T13,7(11X,A2,I1,1H)))) 1008 FORMAT(/19H INWARD INTEGRATION,I3) 1011 FORMAT(/53H ERROR - NO CONVERGENCE IN BASFUN AFTER 99 ITERATIONS/) 1012 FORMAT(/' ERROR - HINT,IHX,IRX AND RA ARE INCOMPATIBLE IN BASFUN') 1013 FORMAT(20X,7F15.7) 1014 FORMAT(/20H SOLUTION FROM MA01A//(8F15.8)) 1015 FORMAT(/17H ARRAYS FOR MA01A/) 1016 FORMAT(/4H X1=,F15.8) C C CHECK COMPATIBILITY OF HINT,IHX,IRX AND RA C S=0.0 J=0 DO 1 I=1,NIX S = ((IRX(I)-J)*IHX(I))*HINT+S 1 J=IRX(I) IF(ABS(S-RA).LE.HALF*HINT) GO TO 3 WRITE(IWRITE,1012) GO TO 127 C C CHECK THAT IRX(I) ARE EVEN INTEGERS C 3 RA=S DO 5 I=1,NIX IF(MOD(IRX(I),2).EQ.0) GO TO 5 WRITE(IWRITE,1004)I GO TO 127 5 CONTINUE C C EVALUATE AND INITIALIZE SOME COMMONLY USED PARAMETERS C IMATCH=IRX(NIX)-20 IF(ETA.GT.0.0) IMATCH=IRX(NIX)-10 IF(MOD(IMATCH,2).EQ.1) IMATCH=IMATCH+1 FM=0.0 ITST=0 NBTP1=NBT+1 NG=NBT I9=IRX(NIX)+1 DO 6 I=1,I9 ORB(I)=0.0 6 DORB(I)=0.0 LANG=LC LCM=LC+1 TLC=LCM*LC HIMT=IHX(1)*HINT YD=HIMT**LCM DYD=LCM*YD/HIMT IEN=1 JEN=1 WR=WINIT EIGEN=WR C C BEGINNING OF LOOP TO FIND THE ENERGY WR, OR POTENTIAL MULTIPLE C PR, WHICH GIVES A FUNCTION SATISFYING THE LOGARITHMIC BOUNDARY C CONDITION. THIS IS DONE BY USING NEWTONS METHOD TO FIND THE ZERO C OF THE FUNCTION BVAL-BSTO. THIS LOOP IS LEFT ONLY WHEN THE C ENERGY, OR POTENTIAL MULTIPLE, INCREMENT DVAL IS LESS THAN ETA. C C NOTE.... THIS LOOP IS ENTERED ONCE ONLY IF ETA=0.0 C H = IHX(NIX)*HINT DO 99 IEN=1,99 WR1=WR DO 97 JEN=1,2 IF(NBUG1.EQ.0) GO TO 9 WRITE(IWRITE,1002)IEN,JEN,WR WRITE(IWRITE,1005) ('U(',I,I=1,NBTP1) C C INITIALIZATION OF FUNCTION AT X=0.0 WHICH IS USED AS THE FIRST C POINT IN THE SIMPSONS RULE NORMALIZATION AND ORTHOGONALIZATION C INTEGRATIONS. C 9 DO 10 II=1,NBTP1 U(II) = 0.0 10 DU(II) = 0.0 IF(JEN.EQ.2) GO TO 12 DO 11 I=1,NBTP1 US(I,1) = U(I) 11 DUS(I,1)=DU(I)*TWO/H 12 IF(NBUG1.NE.0) WRITE(IWRITE,1001) 0.0,(U(NV),NV=1,NBTP1) C C EVALUATE THE FUNCTION AND DERIVATIVE AT HINT AND STORE THE C FUNCTION C LP1=LCM LP2 = LC+2 X=HIMT H=HIMT DO 19 K=1,NBTP1 IF(K.EQ.NBTP1) GO TO 14 U(K) = P(K,2)*H*H/(4*LC+6) DU(K)=(LC+3)*U(K)*HALF GO TO 18 14 TWOZ = 0.0 IF(POVALU(2).LT.TINY) GO TO 17 IF(INT(POVALU(1)/POVALU(2)-HALF).GT.0) TWOZ=POVALU(1)*H*HALF 17 U(K)=X**LP1*(1.0-TWOZ*X/(2*LP1)) DU(K)=X**LC*(LP1-LP2*TWOZ*X/(LP1*2)) DU(K)=DU(K)*X*HALF 18 IF(JEN.NE.1) GO TO 19 US(K,2) = U(K) DUS(K,2)=DU(K)*TWO/H 19 CONTINUE IF(NBUG1.NE.0) WRITE(IWRITE,1001)X,(U(NV),NV=1,NBTP1) C C EVALUATE FR AT HINT C KM = 1 MMM = 1 CALL DERFUN DO 20 K=1,NBTP1 20 FR(K)=FRH(K)*H*H/TWELVE C C SET UP FRM AT HINT/2 C X=HALF*X KM = 0 IF(NBT.EQ.0) GO TO 22 DO 21 K=1,NBT FRM(K)=U(K) 21 U(K)=U(K)-DU(K)+ONEPT5*FR(K) 22 FRM(NBTP1)=U(NBTP1) U(NBTP1)=X**LP1*(1.0-TWOZ*X/(2*LP1)) CALL DERFUN KM = 2 X = X+X DO 23 K=1,NBTP1 U(K)=FRM(K) 23 FRM(K) = FRH(K)*X*X*THIRD C C STORE THE CONTRIBUTION TO THE INTEGRAL FROM THE FIRST POINT C IF(NBT.EQ.0) GO TO 26 DO 25 I=1,NBTP1 DO 24 J=1,NBT 24 DELT(I,J)=U(I)*P(J,KM)*H*FOUR 25 CONTINUE C C INTEGRATE OUT TO THE MATCHING POINT C 26 LSWT=1 I2=1 DO 41 ING=1,NIX H1=H H = IHX(ING)*HINT HS = H*H I1=I2+1 I2=IRX(ING) IF(IMATCH.LT.I2) I2=IMATCH C C INTEGRATE OVER A RANGE OF EQUAL INTERVALS C 27 DO 40 IR=I1,I2 JR = IR+1 CALL DEVGL(NBTP1,DU,FR,FRM,H,HS,H1,LSWT) IF(NBUG1.EQ.1) WRITE(IWRITE,1001)X,(U(I),I=1,NBTP1) IF(NBT.EQ.0) GO TO 37 C C COMPUTE THE SIMPSON WEIGHT C AM = 1.0 IF(IR.EQ.IMATCH) GO TO 34 IF(IR.EQ.I2) GO TO 31 AM=TWO IF(MOD(IR,2).NE.0) AM=FOUR GO TO 34 31 AM = REAL(IHX(ING)+IHX(ING+1))/IHX(ING) C C ADD IN THE CONTRIBUTATION TO THE INTEGRAL FROM THE CURRENT POINT C 34 DO 36 I=1,NBTP1 DO 35 J=1,NBT 35 DELT(I,J)=DELT(I,J)+U(I)*P(J,KM)*H*AM 36 CONTINUE C C STORE THE FUNCTIONS AT EACH INTEGRATION C 37 IF(JEN.NE.1) GO TO 39 DO 38 I=1,NBTP1 US(I,JR)=U(I) 38 DUS(I,JR)=DU(I)*TWO/H C 39 IF(IR.EQ.IMATCH) GO TO 42 40 CONTINUE 41 LSWT = 2 C C STORE THE FUNCTIONS AND DERIVATIVES AT THE MATCHING POINT FOR THE C OUTWARD INTEGRATION C 42 DO 43 I=1,NBTP1 YOUT(I) = U(I) 43 DYOUT(I)=DU(I)*TWO/H C C INITIALIZE ARRAYS FOR DEVOGELAERE INTEGRATION INWARDS C MMM = -1 NBTM=NBT ITST=1 NITS=1 BNDRY(1)=1.0 DBNDRY(1)=BSTO/RA IF(ABS(ETA).GT.TINY) GO TO 44 BNDRY(1)=1.0 DBNDRY(1)=0.0 BNDRY(2)=0.0 DBNDRY(2)=1.0 NITS=2 C C LOOP OVER NUTTY .... NITS=1 FOR ITERATION ON THE MISMATCH TO FIND C AN EIGENVALUE C NITS=2 FOR THE SOLUTION AT A GIVEN ENERGY C FOR WHICH TWO INDEPENDENT INWARD SOLUTIONS C ARE NECESSARY TO OBTAIN CONTINUITY. C 44 DO 83 NUTTY=1,NITS C C EVALUATE THE FUNCTION AND DERIVATIVES AT RA C IF(NBUG1.EQ.0) GO TO 45 IF(NITS.EQ.1) WRITE(IWRITE,1008) IF(NITS.EQ.2) WRITE(IWRITE,1008)NUTTY WRITE(IWRITE,1005) ('U(',I,I=1,NBTP1) 45 KM = 2*IRX(NIX)+1 H = IHX(NIX)*HINT HS = H*H X=RA IF(NUTTY.EQ.2) NBT=0 NG=NBT NBTP1=NBT+1 DO 47 I=1,NBTP1 IF(I.EQ.NBTP1) GO TO 46 U(I) = 0.0 DU(I)=0.0 GO TO 47 46 U(I)=BNDRY(NUTTY) DU(I)=-DBNDRY(NUTTY)*H*HALF 47 CONTINUE IF(NBUG1.NE.0) WRITE(IWRITE,1001)X,(U(NV),NV=1,NBTP1) C C EVALUATE FR AT RA C CALL DERFUN KM=KM+1 DO 48 K=1,NBTP1 48 FR(K)=FRH(K)*HS/TWELVE C C EVALUATE FRM AT RA+H/2 C X = RA+H*HALF DO 49 K=1,NBTP1 49 FRH(K)=U(K)-DU(K)+ONEPT5*FR(K) FRHVAL=TLC/X/X-WR-ONEPT5*POVALU(KM-1)+HALF*POVALU(KM-2) DO 50 K=1,NBTP1 FRM(K)=FRH(K)*FRHVAL IF(K.EQ.NBTP1) GO TO 50 FRM(K)=FRM(K)+ONEPT5*P(K,KM-1)-HALF*P(K,KM-2) 50 FRM(K)=FRM(K)*H*H*THIRD JR=I9 X=RA KM = KM-1 C C ADD CONTRIBUTION TO ORTHOGONALITY INTEGRALS FROM FIRST POINT C IF(NUTTY.EQ.1.OR.NBTM.EQ.0) GO TO 53 DO 52 JL=1,NBTM 52 ORTH(JL)=P(JL,KM)*U(1)*H 53 IF(NBT.EQ.0) GO TO 56 DO 55 I=1,NBTP1 DO 54 J=1,NBT 54 SDELT(I,J)=U(I)*P(J,KM)*H 55 CONTINUE C C STORE THE FUNCTION AT RA C 56 IF(JEN.NE.1) GO TO 59 IF(NUTTY.EQ.2) GO TO 58 DO 57 I=1,NBTP1 US(I,JR) = U(I) 57 DUS(I,JR)=DU(I)*TWO/H GO TO 59 58 ORB(JR)=U(1) DORB(JR)=DU(1)*TWO/H C C INTEGRATE IN TO THE MATCHING POINT C 59 LSWT = 1 DO 80 IMT=NIX,1,-1 H1=H H = -IHX(IMT)*HINT HS = H*H I2=IRX(IMT) I1=0 IF(IMT.GT.1) I1=IRX(IMT-1) IF(IMATCH.GT.I1) I1=IMATCH I3=I1+1 C C INTEGRATE OVER A RANGE OF EQUAL INTEGRALS C DO 79 IR=I3,I2 JR = JR-1 CALL DEVGL(NBTP1,DU,FR,FRM,H,HS,H1,LSWT) IF(NBUG1.EQ.1) WRITE(IWRITE,1001)X,(U(I),I=1,NBTP1) C C CALCULATE THE INTEGRATION FACTOR C 64 IF(IR.EQ.I2) GO TO 67 AM=TWO IF(MOD(IR,2).NE.0) AM=FOUR GO TO 71 67 IF(I1.EQ.IMATCH) GO TO 69 AM = REAL(IHX(IMT)+IHX(IMT-1))/IHX(IMT) GO TO 71 69 AM = 1.0 C C ADD IN THE CONTRIBUTION TO THE INTEGRAL FROM THE CURRENT POINT C 71 IF(NBT.EQ.0) GO TO 74 DO 73 I=1,NBTP1 DO 72 J=1,NBT 72 SDELT(I,J)=SDELT(I,J)-U(I)*P(J,KM)*H*AM 73 CONTINUE C C STORE THE FUNCTIONS AT EACH INTERATION C 74 IF(JEN.NE.1) GO TO 78 IF(NUTTY.EQ.2) GO TO 76 DO 75 I=1,NBTP1 US(I,JR)=U(I) 75 DUS(I,JR)=DU(I)*TWO/H GO TO 78 76 ORB(JR)=U(1) DORB(JR)=DU(1)*TWO/H IF(NBTM.EQ.0) GO TO 78 DO 77 JL=1,NBTM 77 ORTH(JL)=ORTH(JL)-U(1)*P(JL,KM)*H*AM C 78 IF(JR.EQ.IMATCH+1) GO TO 81 79 CONTINUE 80 LSWT = 2 C C STORE THE FUNCTIONS AND DERIVATIVES AT THE MATCHING POINT FOR C THE INWARD INTEGRATION C 81 IF(NUTTY.EQ.2) GO TO 83 DO 82 I=1,NBTP1 YIN (I) = U(I) 82 DYIN(I)=DU(I)*TWO/H 83 CONTINUE C NBT=NBTM NG=NBT NBTP1=NBT+1 NBTP2=NBT+2 C C SET UP THE MATCHING EQUATIONS FOR THE ITERATION CASE C DO 84 I=1,NBTP2 84 BDL(I)=0.0 BDL(NBTP1) = 1.0 IF(NBT.EQ.0) GO TO 87 DO 86 I=1,NBT DO 85 J=1,NBT 85 ADEL(I,J)=DELT(J,I)+SDELT(J,I) ADEL(I,NBTP1) = DELT(NBTP1,I) 86 ADEL(I,NBTP2) = SDELT(NBTP1,I) 87 IF(ABS(ETA).LT.TINY) GO TO 100 DO 88 I=1,NBTP1 88 ADEL(NBTP1,I) = YOUT(I) ADEL(NBTP1,NBTP2) = 0.0 IF(NBT.EQ.0) GO TO 90 DO 89 I=1,NBT 89 ADEL(NBTP2,I)=DYOUT(I)-DYIN(I) 90 ADEL(NBTP2,NBTP1)=DYOUT(NBTP1) ADEL(NBTP2,NBTP2)=-DYIN(NBTP1) IF(NBUG3.EQ.0) GO TO 92 WRITE(IWRITE,1015) DO 91 M=1,NBTP2 91 WRITE(IWRITE,1013) (ADEL(M,N),N=1,NBTP2), BDL(M) C C SOLVE THE MATCHING EQUATIONS C 92 CALL MA01A(ADEL,BDL,NBTP2,1,0,LL92,1) IF(NBUG1.NE.0) WRITE(IWRITE,1014)(BDL(J),J=1,NBTP2) C C CALCULATE THE MISMATCH C IF(JEN.NE.1) GO TO 94 DO 93 NN=1,NBTP2 93 ADL(NN)=BDL(NN) 94 AJEN=1.0-BDL(NBTP2)*YIN(NBTP1) IF(NBT.EQ.0) GO TO 96 DO 95 I=1,NBT 95 AJEN = AJEN-BDL(I)*YIN(I) C C STORE THE MISMATCH,INCREMENT THE ENERGY AND RETURN C 96 AVAL(JEN)=AJEN WR = WR+DELTA 97 CONTINUE C C CARRY OUT ONE ITERATION USING NEWTONS METHOD AND RETURN C FDASH = (AVAL(2)-AVAL(1))/DELTA IF(FDASH.EQ.0.0) GO TO 106 DVAL = -AVAL(1)/FDASH IF(ABS(DVAL).LE.ETA) GO TO 106 WR = WR1+DVAL 99 CONTINUE C WRITE(IWRITE,1011) GO TO 127 C C SET UP THE MATCHING EQUATIONS FOR THE ARBITRARY ENERGY CASE C 100 NBTP3=NBTP2+1 BDL(NBTP3)=0.0 IF(NBT.EQ.0) GO TO 102 DO 101 I=1,NBT ADEL(I,NBTP3)=ORTH(I) ADEL(NBTP2,I)=YOUT(I)-YIN(I) 101 ADEL(NBTP3,I)=DYOUT(I)-DYIN(I) 102 DO 103 N=1,NBTP3 103 ADEL(NBTP1,N)=0.0 ADEL(NBTP1,NBTP1)=1.0 ADEL(NBTP2,NBTP1)=YOUT(NBTP1) ADEL(NBTP3,NBTP1)=DYOUT(NBTP1) ADEL(NBTP2,NBTP2)=-YIN(NBTP1) ADEL(NBTP2,NBTP3)=-U(1) ADEL(NBTP3,NBTP3)=-DU(1)*TWO/H ADEL(NBTP3,NBTP2)=-DYIN(NBTP1) IF(NBUG3.EQ.0) GO TO 105 WRITE(IWRITE,1015) DO 104 M=1,NBTP3 104 WRITE(IWRITE,1013) (ADEL(M,N),N=1,NBTP3), BDL(M) 105 CALL MA01A(ADEL,BDL,NBTP3,1,0,LL92,1) NBTP2=NBTP3 GO TO 108 C C STORE THE ENERGY EIGENVALUE AND FORM THE CONTINUOUS SOLUTION C IN ORB C 106 EIGEN=WR1 DO 107 NN=1,NBTP2 107 BDL(NN)=ADL(NN) 108 IF(NBUG3.NE.0) WRITE(IWRITE,1014)(BDL(J),J=1,NBTP2) C C EVALUATE THE FINAL UNNORMALIZED FUNCTION AT THE MESH POINTS C NBTN6=NBT+2 DO 111 I=1,IMATCH ORB(I)=0.0 DORB(I)=0.0 DO 110 J=1,NBTP1 ORB(I)=ORB(I)+US(J,I)*BDL(J) 110 DORB(I)=DORB(I)+DUS(J,I)*BDL(J) 111 CONTINUE I1=IMATCH+1 DO 113 I=I1,I9 ORB(I)=ORB(I)*BDL(NBTP2)+US(NBTP1,I)*BDL(NBTN6) DORB(I)=DORB(I)*BDL(NBTP2)+DUS(NBTP1,I)*BDL(NBTN6) IF(NBT.EQ.0) GO TO 113 DO 112 J=1,NBT ORB(I)=ORB(I)+US(J,I)*BDL(J) 112 DORB(I)=DORB(I)+DUS(J,I)*BDL(J) 113 CONTINUE BVALUE=BDL(NBTP2)*RA/ORB(I9) C C NORMALIZE THE SOLUTION AND THE LAGRANGE MULTIPLIERS C X1= 0.0 I1=1 DO 120 I=1,NIX H = IHX(I)*HINT I2=IRX(I)+1 IF(I.GT.1) I1=IRX(I-1)+1 DO 118 J=I1,I2 AM = 1.0 IF(J.EQ.I1.OR.J.EQ.I2) GO TO 118 AM = TWO IF(MOD(J,2).EQ.0) AM=FOUR 118 X1 = ORB(J)*ORB(J)*H*AM + X1 120 CONTINUE C IF(NBUG3.NE.0) WRITE(IWRITE,1016) X1 X2=SQRT(THREE/X1) NODES = 0 X3 = X2 IF(ORB(2).LT.0.0) X3=-X2 C C EVALUATE NODES, THE NUMBER OF NODES IN THE FINAL FUNCTION C ORB1=ORB(1) DO 124 I=2,I9 ORB2=ORB(I)*X3 ORB(I)=ORB2 DORB(I)=DORB(I)*X3 IF(ORB1) 121,124,122 121 IF(ORB2) 124,123,123 122 IF(ORB2) 123,123,124 123 NODES=NODES+1 124 ORB1=ORB2 C OUT ALAMDA(NBT+1) = X3 -- INCLUDED '90MAY9TH PJS+KAB; INSTEAD C '91JUL24/25: FOR RMASS AND RDAR TO ENSURE RENORMALIZED FBAR0'S: ORB(1) = X3 IF(NBT.EQ.0) GO TO 127 DO 126 I=1,NBT 126 ALAMDA(I)=BDL(I)*X2 C 127 RETURN END C*********************************************************************** SUBROUTINE DERFUN C C EVALUATES THE SECOND DERIVATIVE FUNCTION FOR THE DE VOGELAERE C ROUTINE DEVGL ASSOCIATED WITH THE NEW BASFUN C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL59=2*1999, LL90= 7+1) COMMON/BASDER/FM,TLC,WR,ITST,JR,KM,MMM,NBTP1,NG COMMON/BNDORB/P( 7,LL59),RACOR( 128) COMMON/FUNVAL/FRH(LL90),U(LL90),X COMMON/INIT/ HINT,IHX( 9),IRX( 9),NIX,IMATCH COMMON/POTVAL/POVALU(LL59),PX(1999) C KM=KM+MMM FRHVAL=TLC/(X*X)-WR-POVALU(KM) IF(FRHVAL.LT.0.0 .AND. FM.GT.0.0) GO TO 1 IF(FRHVAL.GT.0.0 .AND. FM.LT.0.0) GO TO 1 FM=FRHVAL GO TO 2 1 IF(ITST.EQ.1) GO TO 2 IMATCH=JR IF(MOD(IMATCH,2).NE.0) IMATCH=IMATCH-1 ITST=1 2 FRH(NBTP1)=FRHVAL*U(NBTP1) IF(NG.EQ.0) GO TO 4 DO 3 I=1,NG 3 FRH(I)=FRHVAL*U(I)+P(I,KM) C 4 RETURN END C*********************************************************************** SUBROUTINE DEVGL(M,DY,FR,FRM,H,HS,H1,LSWT) C C DE VOGELAERE INTEGRATION ROUTINE C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER (LL90= 7+1) DIMENSION DY(LL90),FR(LL90),FRM(LL90),YR(LL90) PARAMETER(HALF=1./2.,THIRD=1./3., * FOURTH=1./4.,EIGHTH=1./8.,TWELVE=12.) COMMON/FUNVAL/FRH(LL90),Y(LL90),X C HH=HALF*H X=X+HH IF(LSWT.GT.1) GO TO 3 DO 2 I=1,M DY(I)=DY(I)+FR(I) YR(I)=Y(I)+DY(I) 2 Y(I)=YR(I)+FR(I)-EIGHTH*FRM(I) GO TO 5 3 H12=H/H1 H12S=H12*H12 LSWT=1 DO 4 I=1,M DY(I)=H12*DY(I)+H12S*FR(I) YR(I)=Y(I)+DY(I) 4 Y(I) = ((H12+1.0)*FR(I) - H12*FRM(I)*FOURTH) * H12S*HALF + YR(I) 5 CALL DERFUN DO 6 I=1,M FRM(I)=HS*FRH(I)*THIRD DY(I)=DY(I)+FRM(I) 6 Y(I)=YR(I)+DY(I) X=X+HH CALL DERFUN DO 7 I=1,M FR(I)=HS*FRH(I)/TWELVE 7 DY(I)=DY(I)+FR(I) C RETURN END