c PSTG1R :: Parallel Version 1.5 of stg1r. 30/06/21 c c D.M. Mitnik c Version 1.0/1.1: c Parallelization on Bound-Continuum integral Index c Parallelization on Continuum-Continuum integral Index c c N. R. Badnell c Version 1.2: Use single UNIT number for RKXXX.DAT c Version 1.3: Sync. with serial updates c Version 1.4: Sync. with serial updates c Version 1.5: Sync. with serial updates c C*********************************************************************** C C N. R. BADNELL UoS v2.39 - QUB v1.4 13/12/18 C C C*********************************************************************** C C Developed From Belfast Atomic R-matrix Codes C C*********************************************************************** 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 S T G 1 C C DISTRIBUTED BY C C QUEEN'S UNIVERSITY BELFAST 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 INCORPORATES RMATRX STG1 (CPC 14(1978)367-412) WITH THE C BREIT-PAULI CODE RMATRX STG1R (CPC 25(1982)347-387). C C*********************************************************************** C C ROUTINES USED IN STG1 C C*********************************************************************** C C MNSTG1 C STG1 DRIVER C ABNORM C BASFUN C BASORB C BLOCK DATA C BUTFIT C CALEXO C CALORB C CIV3 C COEFF C CORECT C DA2 C DERINT C DERFUN C DEVGL C EVAL C EVALUE C FINDER C GEN1BB C GEN1BC C GEN1CC C GENBB C GENBC C GENCC C GENINT C GENMBB C GENMBC C GENMCC C ISTG1 C LSQ C MA01A C MESH C NAME C NEWBUT C ONEELE C FUNCTION ORNO C FUNCTION PHASE C POTF C RADINT C RDAR C RECOV2 C RMASS C ROOT C RS C SCHMDT C SHRIEK C SPNORB C SS C STG1RD C STO C TABORB C WRINX1 C WRITAP C C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN STG1 C C*********************************************************************** C C IREAD USER INPUT FILE C IWRITE OUTPUT TO LINE PRINTER C IPUNCH NOT USED C C IDISC1 NOT USED C IDISC2 NOT USED C IDISC3 NOT USED C IDISC4 NOT USED C C ITAPE1 OPTIONAL INPUT MODEL POTENTIALS C ITAPE2 NOT USED C ITAPE3 OUTPUT STORE OF STG1 INTEGRALS C ITAPE4 NOT USED C C JDISC1 OUTPUT DA-FILE OF RK INTEGRALS C JDISC2 NOT USED C C C IREAD (5) .. input data .. dstg1 C IWRITE (6) .. printed output .. rout1r C C IPUNCH .. NOT USED C C IDISC1 .. NOT USED C IDISC2 .. NOT USED C IDISC3 .. NOT USED C IDISC4 .. NOT USED C C ITAPE1 (1) .. model potential .. STG1.POT .. if ITAPE1>0 C ITAPE2 .. NOT USED C ITAPE3 (3) .. STG1 dump .. STG1.DAT .. always used C ITAPE4 .. NOT USED C C JDISC1 (21) .. RK.DAT C JDISC2 .. NOT USED C C*********************************************************************** C C DIMENSIONING PARAMETERS USED IN STG1 C C*********************************************************************** C C INCLUDE PARAMETERS: C C FAC (32) LARGEST FACTORIAL AVAILABLE ON MACHINE C KIL (1) KILO-WORDS OF MEMORY FOR INTEGRAL STORAGE C LMX (8) MULTIPOLES IN POTENTIAL (LAMAX) C LR1 (5) HIGHEST L+1 FOR BOUND ORBITALS (LRANG1) C LR2 (20) HIGHEST L+1 FOR CONTINUUM ORBITALS (LRANG2) C MEG (1) MEGA-WORDS OF MEMORY FOR INTEGRAL STORAGE C NPT (800) RADIAL TABULAR POINTS (IRX(NIX)) ! DO NOT INFLATE - NRB C NR1 (5) HIGHEST N FOR BOUND ORBITALS (MAXNHF) C NR2 (40) NUMBER OF CONTINUUM ORBITALS FOR GIVEN L (NRANG2) C C*********************************************************************** C PROGRAM MNSTG1 IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXICT=4*MZLR1*MZLR1*MZLR1*MZLR2*MZLR2) PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXN11=MZNR1+1) PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXPOL= (MZLMX+1)/2) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C C MXORB = NUMBER OF BOUND ORBITALS: C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) PARAMETER (MXBBI=MXORB*MXORB/2*MZLMX+MXORB*MZLMX) C C FOR /INSTO2/ AND /INSTO3/ AND /INSTO6/: C PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ, A MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2, B MXCTCC=MZLR2+MZLR1-1) C C*********************************************************************** C C COMMON BLOCKS USED IN STG1 C C*********************************************************************** C COMMON /BASDER/FM,TLC,WR,ITST,JR,KM,MMM,NBTP1,NG COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BNDORB/P(MZNR1,MXPT2),RACOR(MXORB) COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /COPY/ITOTAL,ICOUNT COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /FACT/GAMMA(MZFAC) COMMON /FUNVAL/FRH(MXN11),U(MXN11),X COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /INSTO5/BBINT(MXBBI),IBBI COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /LSTORE/LOOPCC COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBOUT/ORB(MZNPT),DORB(MZNPT),EIGEN,ALAMDA(MXN11),BVALUE COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTEN/CPOT(6),XPOT(6),IPOT(6),NPOT COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /REL1/RLAMDA(MZLR2,MZNR2,MXN11) COMMON /RKSAVE/IRKBC,IRKCC(MZLR2,MZLR2,2),ICHUNK,ICT(MXICT),ITAPBC COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /YKSTOR/YK(MZNPT),TEST1 C C SUN REAL*4 TARRY(2),TIME c **** parallel **** common /parablock/iam,nproc include 'mpif.h' call mpi_init(ierr) call mpi_comm_rank(mpi_comm_world,iam,ierr) call mpi_comm_size(mpi_comm_world,nproc,ierr) c **** parallel **** C C C*********************************************************************** C C STG1 MAIN PROGRAM C C*********************************************************************** C C MEM1 AND MREC1 ARE THE MEMORY AND DA FILE POINTERS C call cpu_time(timei) c write(0,*) ' begin proc=:',iam MEM1 = 0 MREC1 = -1 CALL STG1 C C SUN c DUM=DTIME(TARRY) c TIME=TARRY(1) C CRAY CRAY CALL SECOND(TIME) c **** parallel **** if (iam.eq.0) then call cpu_time(timef) time=timef-timei time = time/60.0 WRITE(IWRITE,999) TIME,nproc 999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN -- processors=:',i4) endif 1000 call mpi_finalize(ierr) c **** parallel **** C STOP END C C C SUBROUTINE ABNORM(N1,L1,N2,L2,BRAKET) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) C----------------------------------------------------------------------- K1 = IPOS(N1,L1) K2 = IPOS(N2,L2) BRAKET = 0.0D0 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 30 I = 1,NIX B = 0.0D0 IFI = IRX(I) + 1 DO 20 J = IST,IFI IF (J.EQ.IFI) MI = 1 B = MI*UJ(J,K1)*UJ(J,K2) + B IF (MI.EQ.4) GOTO 10 MI = 4 GOTO 20 C 10 CONTINUE MI = 2 20 CONTINUE BRAKET = (IHX(I)*HINT)*B/3 + BRAKET MI = 1 IST = IFI 30 CONTINUE C END C C C SUBROUTINE BASFUN(NBT,LC,NODES,RA,BSTO,WINIT,DELTA,ETA) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C NEW NUMERICAL R-MATRIX ORBITAL ROUTINE C 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 C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN11=MZNR1+1,MXN12=MZNR1+2,MXN13=MZNR1+3) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXPT2=2*MZNPT) C CHARACTER*2 LEFT(MXN11) C DIMENSION AVAL(2),ADL(MXN12),ORTH(MXN11),BNDRY(2),DBNDRY(2) DIMENSION YIN(MXN11),YOUT(MXN11),DYIN(MXN11),DYOUT(MXN11) DIMENSION US(MXN11,MZNPT),DUS(MXN11,MZNPT) DIMENSION DU(MXN11),FR(MXN11),FRM(MXN11),DELT(MXN11,MXN11) DIMENSION ADEL(MXN13,MXN13),BDL(MXN13),SDELT(MXN12,MXN12) C COMMON /BASDER/FM,TLC,WR,ITST,JR,KM,MMM,NBTP1,NG COMMON /BNDORB/P(MZNR1,MXPT2),RACOR(MXORB) COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /FUNVAL/FRH(MXN11),U(MXN11),X COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBOUT/ORB(MZNPT),DORB(MZNPT),EIGEN,ALAMDA(MXN11),BVALUE COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) C DATA LEFT/MXN11*'U('/ C----------------------------------------------------------------------- C C CHECK COMPATIBILITY OF HINT,IHX,IRX AND RA C S = ZERO J = 0 DO 10 I = 1,NIX H = IHX(I)*HINT S = (IRX(I)-J)*H + S J = IRX(I) 10 CONTINUE IF (ABS(S-RA).LE.HALF*HINT) GOTO 20 WRITE (IWRITE,3060) S RA = S GOTO 1050 C C CHECK THAT IRX(I) ARE EVEN INTEGERS C 20 CONTINUE RA = S DO 30 I = 1,NIX J = IRX(I) M = MOD(J,2) IF (M.EQ.0) GOTO 30 WRITE (IWRITE,3020) I GOTO 1050 C 30 CONTINUE C C EVALUATE AND INITIALIZE SOME COMMONLY USED PARAMETERS C ONEPT5 = ONE + HALF IMATCH = IRX(NIX) - 20 IF (ETA.GT.ZERO) IMATCH = IRX(NIX) - 10 IF (MOD(IMATCH,2).EQ.1) IMATCH = IMATCH + 1 FM = ZERO ITST = 0 NBTP1 = NBT + 1 NG = NBT I9 = IRX(NIX) + 1 DO 40 I = 1,I9 ORB(I) = ZERO DORB(I) = ZERO 40 CONTINUE LCM = LC + 1 TLC = LCM*LC HIMT = IHX(1)*HINT 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 DO 860 IEN = 1,99 IF (IEN.LT.99) GOTO 50 WRITE (IWRITE,3050) GOTO 1050 C 50 CONTINUE WR1 = WR DO 840 JEN = 1,2 IF (NBUG1.EQ.0) GOTO 70 WRITE (IWRITE,3010) IEN,JEN,WR WRITE (IWRITE,3030) (LEFT(I),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 70 CONTINUE DO 80 II = 1,NBTP1 U(II) = ZERO DU(II) = ZERO 80 CONTINUE IF (JEN.EQ.2) GOTO 100 DO 90 I = 1,NBTP1 US(I,1) = U(I) DUS(I,1) = DU(I)*TWO/H 90 CONTINUE 100 CONTINUE IF (NBUG1.NE.0) WRITE (IWRITE,3000) ZERO, (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 150 K = 1,NBTP1 IF (K.EQ.NBTP1) GOTO 110 U(K) = P(K,2)*H*H/DBLE(4*LC+6) DU(K) = DBLE(LC+3)*U(K)*HALF GOTO 140 C 110 CONTINUE IF (POVALU(2).LT.TINY) GOTO 120 NIZ = INT(POVALU(1)/POVALU(2) - HALF) IF (NIZ.GE.1) GOTO 130 120 CONTINUE TWOZ = ZERO 130 CONTINUE TWOZ = POVALU(1)*H*HALF XL1 = X**LP1 U(K) = XL1* (ONE-TWOZ*X/ (TWO*DBLE(LP1))) DU(K) = (XL1/X)* (DBLE(LP1)- A TWOZ*DBLE(LP2)*X/ B (TWO*DBLE(LP1))) DU(K) = DU(K)*X*HALF 140 CONTINUE IF (JEN.NE.1) GOTO 150 US(K,2) = U(K) DUS(K,2) = DU(K)*TWO/H 150 CONTINUE IF (NBUG1.NE.0) WRITE (IWRITE,3000) X, (U(NV),NV=1,NBTP1) C C EVALUATE FR AT HINT C KM = 1 MMM = 1 CALL DERFUN DO 160 K = 1,NBTP1 FR(K) = FRH(K)*H*H/TWELVE 160 CONTINUE C C SET UP FRM AT HINT/2 C X = HALF*X KM = 0 IF (NBT.EQ.0) GOTO 180 DO 170 K = 1,NBT FRM(K) = U(K) U(K) = U(K) - DU(K) + ONEPT5*FR(K) 170 CONTINUE 180 CONTINUE FRM(NBTP1) = U(NBTP1) U(NBTP1) = X**LP1* (ONE-TWOZ*X/ (TWO*DBLE(LP1))) CALL DERFUN KM = 2 X = TWO*X DO 190 K = 1,NBTP1 U(K) = FRM(K) FRM(K) = FRH(K)*X*X*THIRD 190 CONTINUE C C STORE THE CONTRIBUTION TO THE INTEGRAL FROM THE FIRST POINT C IF (NBT.EQ.0) GOTO 220 DO 210 I = 1,NBTP1 DO 200 J = 1,NBT DELT(I,J) = U(I)*P(J,KM)*H*FOUR 200 CONTINUE 210 CONTINUE C C INTEGRATE OUT TO THE MATCHING POINT C 220 CONTINUE LSWT = 1 I1 = 2 DO 350 INTT = 1,NIX H1 = H H = HINT*DBLE(IHX(INTT)) HS = H*H I2 = IRX(INTT) IF (IMATCH.LT.I2) I2 = IMATCH IF (INTT.EQ.1) GOTO 230 LSWT = 2 I1 = IRX(INTT-1) + 1 C C INTEGRATE OVER A RANGE OF EQUAL INTERVALS C 230 CONTINUE DO 340 IR = I1,I2 JR = IR + 1 CALL DEVGL(NBTP1,DU,FR,FRM,H,HS,H1,LSWT) IF (NBUG1.EQ.1) WRITE (IWRITE,3000) X, (U(I),I=1,NBTP1) IF (NBT.EQ.0) GOTO 310 C C CALCULATE THE INTEGRATION FACTOR C IF (IR.EQ.IMATCH) GOTO 270 IF (IR.EQ.I2) GOTO 250 C IF (MOD(IR,2).NE.0) THEN AM = FOUR ELSE AM = TWO ENDIF C GOTO 280 C 250 CONTINUE IF (IR.EQ.IMATCH) GOTO 270 AM = DBLE(IHX(INTT)+IHX(INTT+1))/ A DBLE(IHX(INTT)) GOTO 280 C 270 CONTINUE AM = ONE C C ADD IN THE CONTRIBUTATION TO THE INTEGRAL FROM THE CURRENT POINT C 280 CONTINUE DO 300 I = 1,NBTP1 DO 290 J = 1,NBT DELT(I,J) = DELT(I,J) + U(I)*P(J,KM)*H*AM 290 CONTINUE 300 CONTINUE C C STORE THE FUNCTIONS AT EACH INTEGRATION C 310 CONTINUE IF (JEN.NE.1) GOTO 330 DO 320 I = 1,NBTP1 US(I,JR) = U(I) DUS(I,JR) = DU(I)*TWO/H 320 CONTINUE C 330 CONTINUE IF (IR.EQ.IMATCH) GOTO 360 340 CONTINUE 350 CONTINUE C C STORE THE FUNCTIONS AND DERIVATIVES AT THE MATCHING POINT FOR THE C OUTWARD INTEGRATION C 360 CONTINUE DO 370 I = 1,NBTP1 YOUT(I) = U(I) DYOUT(I) = DU(I)*TWO/H 370 CONTINUE C C INITIALIZE ARRAYS FOR DEVOGELAERE INTEGRATION INWARDS C MMM = -1 NBTM = NBT ITST = 1 NITS = 1 BNDRY(1) = ONE DBNDRY(1) = BSTO/RA IF (ABS(ETA).GT.TINY) GOTO 380 BNDRY(1) = ONE DBNDRY(1) = ZERO BNDRY(2) = ZERO DBNDRY(2) = ONE 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 380 CONTINUE DO 700 NUTTY = 1,NITS C C EVALUATE THE FUNCTION AND DERIVATIVES AT RA C IF (NBUG1.EQ.0) GOTO 390 IF (NITS.EQ.1) WRITE (IWRITE,3040) IF (NITS.EQ.2) WRITE (IWRITE,3040) NUTTY WRITE (IWRITE,3030) (LEFT(I),I,I=1,NBTP1) 390 CONTINUE KM = 2*IRX(NIX) + 1 H = HINT*DBLE(IHX(NIX)) HS = H*H X = RA IF (NUTTY.EQ.2) NBT = 0 NG = NBT NBTP1 = NBT + 1 DO 410 I = 1,NBTP1 IF (I.EQ.NBTP1) GOTO 400 U(I) = ZERO DU(I) = ZERO GOTO 410 C 400 CONTINUE U(I) = BNDRY(NUTTY) DU(I) = -DBNDRY(NUTTY)*H*HALF 410 CONTINUE IF (NBUG1.NE.0) WRITE (IWRITE,3000) X, (U(NV),NV=1,NBTP1) C C EVALUATE FR AT RA C CALL DERFUN KM = KM + 1 DO 420 K = 1,NBTP1 FR(K) = FRH(K)*HS/TWELVE 420 CONTINUE C C EVALUATE FRM AT RA+H/2 C X = RA + H*HALF DO 430 K = 1,NBTP1 FRH(K) = U(K) - DU(K) + ONEPT5*FR(K) 430 CONTINUE FRHVAL = TLC/X/X - WR - ONEPT5*POVALU(KM-1) + A HALF*POVALU(KM-2) DO 450 K = 1,NBTP1 FRM(K) = FRH(K)*FRHVAL IF (K.EQ.NBTP1) GOTO 440 FRM(K) = FRM(K) + ONEPT5*P(K,KM-1) - HALF*P(K,KM-2) 440 FRM(K) = FRM(K)*H*H*THIRD 450 CONTINUE 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) GOTO 470 DO 460 JL = 1,NBTM ORTH(JL) = P(JL,KM)*U(1)*H 460 CONTINUE 470 CONTINUE IF (NBT.EQ.0) GOTO 500 DO 490 I = 1,NBTP1 DO 480 J = 1,NBT SDELT(I,J) = U(I)*P(J,KM)*H 480 CONTINUE 490 CONTINUE C C STORE THE FUNCTION AT RA C 500 CONTINUE IF (JEN.NE.1) GOTO 530 IF (NUTTY.EQ.2) GOTO 520 DO 510 I = 1,NBTP1 US(I,JR) = U(I) DUS(I,JR) = DU(I)*TWO/H 510 CONTINUE GOTO 530 C 520 CONTINUE ORB(JR) = U(1) DORB(JR) = DU(1)*TWO/H C C INTEGRATE IN TO THE MATCHING POINT C 530 CONTINUE LSWT = 1 DO 670 INTT = 1,NIX H1 = H IMT = NIX - INTT + 1 H = -HINT*DBLE(IHX(IMT)) HS = H*H IF (IMT.NE.1) THEN I1 = IRX(IMT-1) C ELSE I1 = 0 ENDIF C I2 = IRX(IMT) IF (IMATCH.GT.I1) I1 = IMATCH I3 = I1 + 1 IF (INTT.EQ.1) GOTO 540 LSWT = 2 C C INTEGRATE OVER A RANGE OF EQUAL INTEGRALS C 540 CONTINUE DO 660 IR = I3,I2 JR = JR - 1 CALL DEVGL(NBTP1,DU,FR,FRM,H,HS,H1,LSWT) IF (NBUG1.EQ.1) WRITE (IWRITE,3000) X, (U(I),I=1,NBTP1) C C CALCULATE THE INTEGRATION FACTOR C IF (IR.EQ.I2) GOTO 550 IF (MOD(IR,2).NE.0) THEN AM = FOUR C ELSE AM = TWO ENDIF C GOTO 580 C 550 CONTINUE IF (I1.EQ.IMATCH) GOTO 570 AM = DBLE(IHX(IMT)+IHX(IMT-1))/ A DBLE(IHX(IMT)) GOTO 580 C 570 CONTINUE AM = ONE C C ADD IN THE CONTRIBUTION TO THE INTEGRAL FROM THE CURRENT POINT C 580 CONTINUE IF (NBT.EQ.0) GOTO 610 DO 600 I = 1,NBTP1 DO 590 J = 1,NBT SDELT(I,J) = SDELT(I,J) - U(I)*P(J,KM)*H*AM 590 CONTINUE 600 CONTINUE C C STORE THE FUNCTIONS AT EACH INTERATION C 610 CONTINUE IF (JEN.NE.1) GOTO 650 IF (NUTTY.EQ.2) GOTO 630 DO 620 I = 1,NBTP1 US(I,JR) = U(I) DUS(I,JR) = DU(I)*TWO/H 620 CONTINUE GOTO 650 C 630 CONTINUE ORB(JR) = U(1) DORB(JR) = DU(1)*TWO/H IF (NBTM.EQ.0) GOTO 650 DO 640 JL = 1,NBTM ORTH(JL) = ORTH(JL) - U(1)*P(JL,KM)*H*AM 640 CONTINUE C 650 CONTINUE IF (JR.EQ.IMATCH+1) GOTO 680 660 CONTINUE 670 CONTINUE C C STORE THE FUNCTIONS AND DERIVATIVES AT THE MATCHING POINT FOR C THE INWARD INTEGRATION C 680 CONTINUE IF (NUTTY.EQ.2) GOTO 700 DO 690 I = 1,NBTP1 YIN(I) = U(I) DYIN(I) = DU(I)*TWO/H 690 CONTINUE 700 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 710 I = 1,NBTP2 BDL(I) = ZERO 710 CONTINUE BDL(NBTP1) = ONE IF (NBT.EQ.0) GOTO 740 DO 730 I = 1,NBT DO 720 J = 1,NBT ADEL(I,J) = DELT(J,I) + SDELT(J,I) 720 CONTINUE ADEL(I,NBTP1) = DELT(NBTP1,I) ADEL(I,NBTP2) = SDELT(NBTP1,I) 730 CONTINUE 740 CONTINUE IF (ABS(ETA).LT.TINY) GOTO 870 DO 750 I = 1,NBTP1 ADEL(NBTP1,I) = YOUT(I) 750 CONTINUE ADEL(NBTP1,NBTP2) = ZERO IF (NBT.EQ.0) GOTO 770 DO 760 I = 1,NBT ADEL(NBTP2,I) = DYOUT(I) - DYIN(I) 760 CONTINUE 770 CONTINUE ADEL(NBTP2,NBTP1) = DYOUT(NBTP1) ADEL(NBTP2,NBTP2) = -DYIN(NBTP1) IF (NBUG3.EQ.0) GOTO 790 WRITE (IWRITE,3090) DO 780 M = 1,NBTP2 WRITE (IWRITE,3070) (ADEL(M,N),N=1,NBTP2),BDL(M) 780 CONTINUE C C SOLVE THE MATCHING EQUATIONS C 790 CONTINUE CALL MA01A(ADEL,BDL,NBTP2,1,0,MXN13,1) IF (NBUG1.NE.0) WRITE (IWRITE,3080) (BDL(J),J=1,NBTP2) C C CALCULATE THE MISMATCH C IF (JEN.NE.1) GOTO 810 DO 800 NN = 1,NBTP2 ADL(NN) = BDL(NN) 800 CONTINUE 810 CONTINUE AJEN = ONE - BDL(NBTP2)*YIN(NBTP1) IF (NBT.EQ.0) GOTO 830 DO 820 I = 1,NBT AJEN = AJEN - BDL(I)*YIN(I) 820 CONTINUE C C STORE THE MISMATCH,INCREMENT THE ENERGY AND RETURN C 830 CONTINUE AVAL(JEN) = AJEN WR = WR + DELTA 840 CONTINUE C C CARRY OUT ONE ITERATION USING NEWTONS METHOD AND RETURN C FDASH = (AVAL(2)-AVAL(1))/DELTA IF (FDASH.EQ.ZERO) GOTO 930 DVAL = -AVAL(1)/FDASH IF (ABS(DVAL).LE.ETA) GOTO 930 WR = WR1 + DVAL 860 CONTINUE C GOTO 930 C C SET UP THE MATCHING EQUATIONS FOR THE ARBITRARY ENERGY CASE C 870 CONTINUE NBTP3 = NBTP2 + 1 BDL(NBTP3) = ZERO IF (NBT.EQ.0) GOTO 890 DO 880 I = 1,NBT ADEL(I,NBTP3) = ORTH(I) ADEL(NBTP2,I) = YOUT(I) - YIN(I) ADEL(NBTP3,I) = DYOUT(I) - DYIN(I) 880 CONTINUE 890 CONTINUE DO 900 N = 1,NBTP3 ADEL(NBTP1,N) = ZERO 900 CONTINUE ADEL(NBTP1,NBTP1) = ONE 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) GOTO 920 WRITE (IWRITE,3090) DO 910 M = 1,NBTP3 WRITE (IWRITE,3070) (ADEL(M,N),N=1,NBTP3),BDL(M) 910 CONTINUE 920 CONTINUE CALL MA01A(ADEL,BDL,NBTP3,1,0,MXN13,1) NBTP2 = NBTP3 GOTO 950 C C STORE THE ENERGY EIGENVALUE AND FORM THE CONTINUOUS SOLUTION C IN ORB C 930 CONTINUE EIGEN = WR1 DO 940 NN = 1,NBTP2 BDL(NN) = ADL(NN) 940 CONTINUE 950 CONTINUE IF (NBUG3.NE.0) WRITE (IWRITE,3080) (BDL(J),J=1,NBTP2) C C EVALUATE THE FINAL UNNORMALIZED FUNCTION AT THE MESH POINTS C NBTN6 = NBT + 2 DO 970 I = 1,IMATCH ORB(I) = ZERO DORB(I) = ZERO DO 960 J = 1,NBTP1 ORB(I) = ORB(I) + US(J,I)*BDL(J) DORB(I) = DORB(I) + DUS(J,I)*BDL(J) 960 CONTINUE 970 CONTINUE I1 = IMATCH + 1 DO 990 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) GOTO 990 DO 980 J = 1,NBT ORB(I) = ORB(I) + US(J,I)*BDL(J) DORB(I) = DORB(I) + DUS(J,I)*BDL(J) 980 CONTINUE 990 CONTINUE BVALUE = BDL(NBTP2)*RA/ORB(I9) C C NORMALIZE THE SOLUTION AND THE LAGRANGE MULTIPLIERS C X1 = ZERO I1 = 1 DO 1010 I = 1,NIX H = HINT*DBLE(IHX(I)) I2 = IRX(I) + 1 IF (I.NE.1) I1 = IRX(I-1) + 1 DO 1000 J = I1,I2 IF (MOD(J,2).EQ.0) THEN AM = FOUR C ELSE AM = TWO IF (J.EQ.I1 .OR. J.EQ.I2) AM = ONE ENDIF C X1 = X1 + ORB(J)*ORB(J)*H*AM 1000 CONTINUE 1010 CONTINUE C IF (NBUG3.NE.0) WRITE (IWRITE,3100) X1 X2 = SQRT(THREE/X1) NODES = 0 X3 = X2 IF (ORB(2).LT.ZERO) X3 = -X2 C C EVALUATE NODES, THE NUMBER OF NODES IN THE FINAL FUNCTION C ORB1 = ORB(1) DO 1030 I = 2,I9 ORB2 = ORB(I)*X3 ORB(I) = ORB2 DORB(I) = DORB(I)*X3 IF (ORB1.EQ.0.0D0) GOTO 1020 IF ((ORB1.LT.0.0D0.AND.ORB2.GE.0.0D0) .OR. A (ORB1.GT.0.0D0.AND.ORB2.LE.0.0D0)) B NODES = NODES + 1 1020 ORB1 = ORB2 1030 CONTINUE 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) GOTO 1050 DO 1040 I = 1,NBT ALAMDA(I) = BDL(I)*X2 1040 CONTINUE C 1050 CONTINUE C 3000 FORMAT (8F15.8) 3010 FORMAT (' **** DEBUGGING PRINT-OUT IN BASFUN FOR NBUG1=0 ****'/ A '+',45X,'/'/' IEN=',I2,5X,' JEN=',I2,5X,' ENERGY WR=', B F15.7,' RYDS'/' OUTWARD INTEGRATION') 3020 FORMAT (' ERROR - IRX(',I1,')IS AN ODD NUMBER IN BASFUN'/) 3030 FORMAT (/9X,'R', (T13,7 (11X,A2,I1,')'))) 3040 FORMAT (/' INWARD INTEGRATION',I2) 3050 FORMAT (/' ERROR - NO CONVERGENCE IN BASFUN AFTER 99 ITERATIONS'/) 3060 FORMAT (' ERROR - HINT,IHX,IRX AND RA ARE INCOMPATIBLE IN BASFUN'/ A ' RA RESET TO',F14.7) 3070 FORMAT (20X,7F15.7) 3080 FORMAT (/' SOLUTION FROM MA01A'// (8F15.8)) 3090 FORMAT (/' ARRAYS FOR MA01A'/) 3100 FORMAT (/' X1=',F15.8) END SUBROUTINE BASORB IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES BOTH THE BOUND AND THE CONTINUUM ORBITALS 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXN11=MZNR1+1) PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BNDORB/P(MZNR1,MXPT2),RACOR(MXORB) COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBOUT/ORB(MZNPT),DORB(MZNPT),EIGEN,ALAMDA(MXN11),BVALUE COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /RECOV/IPLACE COMMON /REL1/RLAMDA(MZLR2,MZNR2,MXN11) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /NRBBUT/BUTORB(MZNPT,MZNR1),BUTEND(MZNR1),BUTEIG(MZNR1), X EMIN,EMAX,TOLE,ITEST0,IMAX,JPOS(MXN3),MJS,NBOX(0:MZLR1) C----------------------------------------------------------------------- C C NPTS =IRX(NIX)+1 IS THE NUMBER OF TABULATION POINTS C NBOUND= NUMBER OF BOUND ORBITALS C NFIRST= POSITION IN UJ ARRAY FOR NEXT SET OF CONTINUUM ORBITALS C NBORBS IS INCREMENTED IF ANY CONTINUUM ORBITALS ARE MADE BOUND. C 10 CONTINUE NBORBS = NBOUND NFIRST = NBOUND DO 20 LP = 1,LRANG2 NFIRST = NFIRST + MAXNCB(LP) 20 CONTINUE WRITE (IWRITE,3000) C C LOOP OVER THE CONTINUUM ANGULAR MOMENTA C DO 200 LP = 1,LRANG2 L1 = LP - 1 WRITE (IWRITE,3010) L1 NBT = 0 MAXHF = L1 MAXLG = L1 ITEST = 0 IBOX0 = 0 IF (LP.LE.LRANG1) THEN C C STORE THE FIRST NBT=MAXNLG(L)-L+1 BOUND ORBITALS AT THE HALF C INTERVALS IN THE P-ARRAY. MAXLG = MAXNLG(LP) NBT = MAXLG - L1 CALL EVAL(LP) MAXHF = MAXNHF(LP) ITEST = MAXHF - MAXLG IBOX0 = NBOX(L1) NBT = NBT - IBOX0 ENDIF C IF (L1.GT.2 .OR. NELC.NE.NZ) WRITE (IWRITE,3015) IF (L1.LE.2 .AND. NELC.EQ.NZ) WRITE (IWRITE,3020) NRANG2 = NRANG2 + MAXNCB(LP) NRANGB = NRANG2 + 1 C C NEW ALGORITHM FOR FINDING STARTING VALUES FOR FINDER C IF (LP.EQ.1) THEN IF (NELC.EQ.NZ) THEN ETRIAL = PI*PI/ (FOUR*RA*RA) ELSE TTT = NELC-NZ ETRIAL = TTT*PI/ (TWO*RA) ENDIF ELSE ETRIAL = EIGENS(1,L1) IF(ISMITN.GT.0)THEN T1=NZ-NELC-1 T2=MAXLG+1 ETRIAL=MIN(ETRIAL,-(T1/T2)**2) ENDIF ENDIF C C LOOP TO GENERATE THE CONTINUUM ORBITALS C ITEST0=0 IF(ISMITN.LT.0.AND.ITEST.GT.0)THEN ITEST0=ITEST IF(-ISMITN.GT.MAXLG.AND.-ISMITN.LE.MAXHF)ITEST0=-ISMITN-MAXLG-1 ENDIF ITEST0=ITEST0+IBOX0 C ELAST = ETRIAL !KAB KEYFIN= 0 !KAB 22 CONTINUE !KAB C DO 80 N0 = 1,NRANG2+ITEST0 N=N0-ITEST0 IF(N0.GT.ITEST0)THEN NQ = NFIRST + N IF (N.LE.MAXNCB(LP)) NQ = NBORBS + N IPOS(N+MAXHF,LP) = NQ ENDIF NODES = MAXHF - LP + N0 - ITEST - IBOX0 C C MODS DUE TO KAB, REPLACING SINGLE LINE CALL TO FINDER WITH: C IF( KEYFIN.EQ.0 )THEN CALL FINDER(NBT,L1,NODES,ETRIAL) IF( NODES.EQ.-9 )THEN WRITE(IWRITE,3023) KEYFIN= 1 GOTO 22 ENDIF ELSE IF( N0.EQ.1 ) THEN ETRIAL = ELAST ELAST = ELAST - HALF ELSE ELAST = EIGENS(N0-1,LP) ENDIF NODE=NODES !NRB CALL FINDEE(NBT,L1,ELAST,ETRIAL,RA,BSTO,NODE) IF(NODE.NE.NODES)THEN !NRB IF(MAXLG.EQ.MAXHF)THEN !NRB WRITE(IWRITE,3026)MAXLG+1,L1 !NRB ELSE !NRB WRITE(IWRITE,3027)MAXLG+1,L1 !NRB ENDIF !NRB STOP 'BASORB/FINDEE FAILURE...' !NRB ENDIF !NRB ENDIF C C END KAB MODS C IF(N0.LE.IBOX0)NBT=NBT+1 C C CALCULATION OF A NEW ENERGY ESTIMATE FOR THE NEXT ORBITAL C IF (ETRIAL.LE.ZERO) THEN ETRIAL = ETRIAL + (PI/RA)**2 C ELSE ETRIAL = (SQRT(ETRIAL)+PI/RA)**2 ENDIF C C STORE INFO FOR BUTTLE CORRECTION, CASE ISMITN=-1. NRB C IF(N0.GT.ITEST0)GO TO 26 BUTEND(N0)=ORB(NPTS) BUTEIG(N0)=EIGEN DO 25 I=1,NPTS BUTORB(I,N0)=ORB(I) 25 CONTINUE GO TO 80 C C RELATIVISTIC CASE: C ALAMDA CONTAINS THE NORMALISED LAGRANGE MULTIPLIERS. C 26 IF (N.GT.MAXNCB(LP) .AND. NBT.GT.0) THEN DO 30 I = 1,NBT RLAMDA(LP,N-MAXNCB(LP),I) = ALAMDA(I) 30 CONTINUE ENDIF 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 EIGENS(N,LP) = EIGEN ENDS(N,LP) = ORB(NPTS) IF (L1.LE.2 .AND. NELC.EQ.NZ) THEN EPHASE = PHASE(LP,EIGEN) WRITE (IWRITE,3030) ORB(NPTS),EIGEN,NODES,EPHASE C ELSE WRITE (IWRITE,3030) ORB(NPTS),EIGEN,NODES ENDIF C IF (NQ.GT.MXORBS) GOTO 180 DO 40 I = 1,NPTS UJ(I,NQ) = ORB(I) 40 CONTINUE C C TREAT THE FIRST MAXNCB CONTINUUM ORBITALS AS BOUND C AND STORE THE ONE-ELECTRON FUNCTIONS Q IN DUJ C ALSO STORE THEM IF NEEDED FOR NUMERICAL SCHMIDT. C IF (N.GT.MAXNCB(LP).AND.ISMITN.EQ.0) GOTO 80 IF(ISMITN.NE.0.AND.ITEST.EQ.0)GO TO 80 IF(NQ.GT.MXORBQ)THEN !THIS SHOULD NOT HAPPEN IF NQ.LE.MZNR2 WRITE(IWRITE,3040)MXORBQ GO TO 180 ENDIF DUJ(1,NQ) = -2*NZ*UJ(1,NQ) DO 50 I = 2,NPTS DUJ(I,NQ) = (EIGEN-PX(I)/WT(I))*UJ(I,NQ) 50 CONTINUE IF (NBT.EQ.0) GOTO 80 DO 70 K = 1,NBT J = IPOS(K+L1,LP) DO 60 I = 2,NPTS DUJ(I,NQ) = DUJ(I,NQ) - UJ(I,J)*ALAMDA(K) 60 CONTINUE 70 CONTINUE 80 CONTINUE C C C EVALUATE BUTTLE CORRECTIONS FOR L=LP-1 AND APPEND TO C END OF CONTINUUM ORBITAL LOCATION C BUTTLE CORRECTIONS ARE FITTED IN THE FOLLOWING ENERGY RANGE: C IF (LP.EQ.1) EK2MAX = 0.5D0*EIGENS(NRANG2,LP) Z = NZ - NELC IF(NZ.EQ.NELC)Z=ONE ! NRB 24/10/94 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 = -1.2D0*(Z/N)**2 ! NRB 24/10/94 INSERT 1.2 IF(EIGENS(1,LP).LT.EK2MIN)EK2MIN=1.2D0*EIGENS(1,LP) ! NRB 24/10/94 IF(ISMITN.GT.0)THEN EMIN=MAX(EMIN,EK2MIN) EMAX=MIN(EMAX,EIGENS(NRANG2,LP)) ELSE EMIN=EK2MIN EMAX=EIGENS(NRANG2,LP) ENDIF C NQ = NQ + 1 IPOS(NRANGB+MAXHF,LP) = NQ C IF(ISMITN.LE.0.OR.ITEST.EQ.0)CALL NEWBUT(LP) C C FOR ISMITN.EQ.0 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 THIS IS THE ORIGINAL CODING USING THE RECURRENCE RELATION C FOR THE B COEFFICIENTS. C C FOR ISMITN.NE.0 C C SCHMIDT ORTHOGONALISE THE CONTINUUM TO ALL BOUND ORBITALS. C NO NEED TO EVALUATE OVERLAP HERE (UNLESS NBUG5 REQUESTS C PRINTOUT) SINCE EVALUATED IN NEW SHMITN SUBROUTINE AS C NEEDED AND AT EACH STEP OF THE ORTHOGONALIZATION PROCEDURE. C CAN SET ISMITN=-N TO START CONTINUUM BASIS AT N. C C FOR ISMITN.GT.0 C C DIAGONALIZE 1-MMT WHERE M IS THE MATRIX OF OVERLAPS. USE C THE RESULTING O-MATRIX (OT(1-MMT)O=DIAGONAL) TO TRANSFORM C THE CONTINUUM BASIS TO FORM A LINEARLY INDEPENDENT SET C ORTHOGONAL TO THE PSEUDO ORBITALS. C C IF (ITEST.GT.0) THEN IF(ISMITN.LT.0.AND.NBUG5.GE.0)GO TO 112 N30=0 C C CHANGE BELOW .LT. TO .NE. TO APPLY ISMITN.GT.0 METHOD TO C LAGRANGE AS WELL. NEED TO ADJUST N1 IN SHMITT AS WELL. IF(ISMITN.LT.0)N30=MAXLG-L1 C DO 110 N1 = 1,ITEST+N30 N3 = MAXLG + N1 - N30 IF(NBUG5.LT.0)WRITE (IWRITE,3050) N3 DO 100 N = 1,NRANG2 N4 = MAXHF + N CALL ABNORM(N3,LP,N4,LP,RESULT) OVRLAP(N,N1,LP) = RESULT 100 CONTINUE IF(NBUG5.LT.0) X WRITE (IWRITE,3060) (OVRLAP(N,N1,LP),N=1,NRANG2) 110 CONTINUE C C SCHMIDT ORTHOGONALISE THE ORBITALS AND STORE THE SCHMIDT C COEFFICIENTS AND OVERLAPS IN /SCOEFF/ CASE ISMITN.EQ.0 C ISMITN.NE.0 SHMIT WILL STORE THE NEW Q-FUNCTIONS INSTEAD. C C N.B. SCHMIDT PROCESSING BUTTLE-ORB NOT MEANINGFUL. C 112 N2 = LP NRANG2O=NRANG2 C IF(ISMITN.EQ.0)CALL SCHMDT(N2) C IF(ISMITN.LT.0)CALL SHMITN(N2) C IF(ISMITN.GT.0)CALL SHMITT(N2) C IF (N2.LE.0) THEN C AS A STOP-GAP -- WE'90MAR16 NRANG2 = -N2 - 1 WRITE (IWRITE,3130) NRANG2 IF(ISMITN.EQ.0)WRITE(IWRITE,3131) IF(ISMITN.LT.0)WRITE(IWRITE,3132) GOTO 10 C ENDIF C IF(ISMITN.GT.0)CALL NEWBUT(LP) C NRANG2=NRANG2O C ENDIF C DO 90 I = 1,NPTS UJ(I,NQ) = ORB(I) 90 CONTINUE C DO 120 N = 1,NRANGB NQ = IPOS(N+MAXHF,LP) ENDS(N,LP) = UJ(NPTS,NQ) 120 CONTINUE C C IF NBUG5.NE.0, CALCULATE AND WRITE OUT THE OVERLAP INTEGRALS C BETWEEN THE BOUND AND CONTINUUM ORBITALS AFTER ORTHOGONALIZATION. C IF(ISMITN.NE.0.AND.NBUG5.GE.0)GO TO 141 IF (ITEST.GT.0) WRITE (IWRITE,3070) IF (NBUG5.LT.-1) WRITE (IWRITE,3080) L1 Y = ZERO DO 140 N1 = LP,MAXHF + NRANG2 DO 130 N = LP,N1 CALL ABNORM(N1,LP,N,LP,RESULT) X = ABS(RESULT) IF (N.EQ.N1.AND.X.NE.ZERO) X = ABS(X-ONE) IF (X.GT.Y) THEN Y = X BIG = RESULT J1 = N1 - L1 J = N - L1 ENDIF C TEMP(N-L1) = RESULT 130 CONTINUE IF(NBUG5.LT.-1) WRITE(IWRITE,3090)N1-L1,(TEMP(I),I=1,N1-L1) 140 CONTINUE WRITE (6,*) ' WORST CASE OVERLAP INTEGRAL =',BIG,', ORBITALS', A J1,J C C IF NBUG5.GT.0, WRITE OUT ALL THE ORBITALS AT NBUG5 POINTS IN C THE INTEGRATION MESH. C ALSO WRITE OUT ANY SCHMIDT COEFFICIENTS. C 141 IF (NBUG5.GT.2) THEN M = (NPTS-1)/NBUG5 IF(M.EQ.0)M=1 N = LP NTOT = MAXHF + NRANG2 150 CONTINUE IF (N.LE.MAXHF+MAXNCB(LP)) THEN WRITE (IWRITE,3100) L1,N,N+10 C ELSE WRITE (IWRITE,3110) L1,N,N+10 ENDIF C N3 = N N = N + 10 N4 = MIN(N-1,NTOT) !V1.4 DO 160 J = 1,NPTS,M WRITE (IWRITE,3060) XR(J), (UJ(J,IPOS(N1,LP)),N1=N3,N4) 160 CONTINUE IF (N4.LT.NTOT) GOTO 150 IF (ITEST.GT.0.AND.ISMITN.EQ.0) THEN WRITE (IWRITE,3120) L1,N3,N4 N5 = NRANG2 + ITEST DO 170 I = 1,N5 WRITE (IWRITE,3060) (B(I,J,LP),J=1,N5) 170 CONTINUE ENDIF C ENDIF C C TREAT THE FIRST MAXNCB CONTINUUM ORBITALS AS BOUND, C INCREMENT NBORBS, ADJUST MAXNHF AND LRANG1. C 180 CONTINUE NFIRST = NFIRST + NRANG2 + 1 N1 = MAXNCB(LP) IF (N1.EQ.0) GOTO 200 WRITE (IWRITE,3140) N1 NBORBS = NBORBS + N1 IF (LP.LE.LRANG1) THEN MAXNHF(LP) = MAXNHF(LP) + N1 MAXPN(LP) = MAXPN(LP) + N1 C ELSE MAXNHF(LP) = LP - 1 + N1 MAXPN(LP) = LP - 1 + N1 LRANG1 = LP ENDIF C DO 190 N = N1 + 1,NRANG2 EIGENS(N-N1,LP) = EIGENS(N,LP) ENDS(N-N1,LP) = ENDS(N,LP) 190 CONTINUE ENDS(NRANG2-N1+1,LP) = ENDS(NRANG2+1,LP) NRANG2 = NRANG2 - N1 C C END L LOOP C 200 CONTINUE C IF(NBUG5.GT.2.OR.NBUG5.LT.-10)STOP 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 IF (NBORBS.LT.NBOUND) NCOEFF = 0 M = 0 !for box orbitals RESULT = ZERO DO 220 N = 1,NBOUND TWOZ = ZERO DO 210 I = 2,NPTS IF (ABS(UJ(I,N)).GT.TWOZ) TWOZ = ABS(UJ(I,N)) 210 CONTINUE ETRIAL = RACOR(N) IF (NCOEFF.EQ.0) ETRIAL = UJ(NPTS,N) IF (ABS(ETRIAL/TWOZ).LE.RESULT) GOTO 220 RESULT = ABS(ETRIAL/TWOZ) M = N 220 CONTINUE WRITE (IWRITE,3150) M,RESULT IF (NFIRST.GT.MXORBS) CALL RECOV2('BASORB','MXORBS',MXORBS,NFIRST) IF (IPLACE.GT.0) NBUG7 = 1 C 3000 FORMAT (//30X,'SUBROUTINE BASORB'/30X,17 ('-')) 3010 FORMAT (//' ORBITALS FOR L =',I2) 3015 FORMAT (/' AMPLITUDE AT RA',5X,'EIGENVALUE (RYD)',5X,'NODES'/) 3020 FORMAT (/' AMPLITUDE AT RA',5X,'EIGENVALUE (RYD)',5X,'NODES',7X, A 'PHASE'/) 3023 FORMAT(/'WARNING...REPEATING WITH KEYFIN=1: FINDER->FINDEE'/) 3026 FORMAT('FINDEE CANNOT FIND CORRECT NODAL SOLUTION'/'TRY ADDING AN' X,' N=',I2,' L=',I2,' BOUND ORBITAL TO THE TARGET REPRESENTATION') 3027 FORMAT('FINDEE CANNOT FIND CORRECT NODAL SOLUTION'/'TRY ADDING ' X,'THE N=',I2,' L=',I2,' BOUND ORBITAL TO THE LAGRANGE ' X,'ORTHOGONALIZATION') 3030 FORMAT (F13.5,F21.4,I11,F19.4) 3040 FORMAT(//' BASORB: MXORBQ TOO SMALL!') 3050 FORMAT (//' OVERLAP INTEGRALS BETWEEN THE N =',I3, A ' BOUND ORBITAL', B ' AND EACH CONTINUUM ORBITAL BEFORE SCHMIDT ORTHOGONALIZING' C /) 3060 FORMAT (1X,11F8.4) 3070 FORMAT (//' AFTER THE SCHMIDT ORTHOGONALISATION:') 3080 FORMAT (//' OVERLAP INTEGRALS BETWEEN THE ORBITALS FOR L =',I2/) 3090 FORMAT (I4,1P,6E11.2/(4X,6E11.2)) 3100 FORMAT (/7X,'L =',I2,2X,'N=',I3,' -',I3, A' BOUND AND CONTINUUM ORBITALS AS A FUNCTION OF RADIUS IN UNITS OF B A0') 3110 FORMAT (/7X,'L =',I2,2X,'N=',I3,' -',I3, A ' CONTINUUM ORBITALS AS A FUNCTION OF RADIUS IN UNITS OF A0' B ) 3120 FORMAT (//' SCHMIDT COEFFICIENTS FOR L =',I2,2X,'N=',I3,' -',I3/) 3130 FORMAT (/1X,9 ('*'),' SCHMDT FAILS; NRANG2 REDUCED TO',I4,1X, A 9 ('*')) 3131 FORMAT(' TRY RE-RUNNING WITH ISMITN=1 TO OBTAIN LARGER NRANG2') 3132 FORMAT(' TRY VARYING ISMITN TO CHANGE "OVERLAP"' X ,' OF BOUND AND CONTINUUM BASES') 3140 FORMAT (' THE FIRST',I3,' CONTINUUM TERMS ARE TREATED AS BOUND') 3150 FORMAT (/' ORBITAL',I3, A ' IS MOST DIFFUSE, AT RA IT HAS DECAYED TO RELATIVE MAGNITUDE' B ,1P,E9.2/' TARGET ORBITALS O.K. IF .LT. 0.002') END C C C BLOCK DATA IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C SET UP THE MOST COMMONLY USED REAL CONSTANTS IN /CONST1/ C THIS MAKES IT EASIER TO CHANGE THE PRECISION OF THE PROGRAM C C----------------------------------------------------------------------- COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH C DATA ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE,FOUR,FIVE, A SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD,FOURTH,FIFTH, B SIXTH,EIGHTH,TENTH B /0.0D0,1.0D0,1.0D-2,1.0D-3, B 1.0D-4,1.0D-6, C 3.141592654D0,7.29732D-3,2.0D0, C 3.0D0,4.0D0,5.0D0,6.0D0, C 7.0D0, D 8.0D0,10.0D0,11.0D0,12.0D0, D 0.5D0,0.333333333333333D0,0.25D0, E 0.2D0,0.166666666666667D0,0.125D0, E 0.1D0/ C END C C C SUBROUTINE BUTFIT(IMAX,E,F,RA,EMAX,ALPHA,BETA,NBUT,DELTA) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- LOGICAL POLE C DIMENSION E(IMAX),F(IMAX) C----------------------------------------------------------------------- C C INITIALISATIONS C D = RA*RA DO 10 I = 1,IMAX E(I) = E(I)*D 10 CONTINUE T = 0.5D0 IF(EMAX.GT.0.0D0)T=T + RA*SQRT(EMAX)/3.141592654D0 NBUT = INT(T) DELTA = 1.0D30 ALPHA = 1.0D0 BETA = 0.0D0 C C START ITERATIONS FOR FIT C DO 50 KK = 1,15 C X11 = 0.0D0 X12 = 0.0D0 X22 = 0.0D0 Y1 = 0.0D0 Y2 = 0.0D0 DELTA0 = DELTA DELTA = 0.0D0 C C START SUM OVER POINTS I C DO 40 I = 1,IMAX U = BETA + E(I) C C CALCULATE FUNCTIONS B(U) AND C(U) C B = 0.0D0 C = 0.0D0 C CASE OF U.GT.0.04 IF (U.GT.0.04D0) THEN FK = SQRT(U) POLE = .FALSE. G = -1.5707963D0 DO 20 N = 0,NBUT G = G + 3.141592654D0 IF (ABS(FK-G).GT.0.3D0) THEN A = 1.0D0/ (U-G*G) B = B + A C = C - A*A C ELSE POLE = .TRUE. D1 = FK - G ENDIF C 20 CONTINUE IF (POLE) THEN D2 = D1*D1 D = 0.33333333D0* A D1* (1.0D0+0.066666667D0* B D2* (1.0D0+0.0952381D0*D2)) A = 1.0D0/ (2.0D0*FK-D1) BB = (D+A)/FK D = 0.33333333D0* (1.0D0+ A D2* (0.2D0+0.031746032D0*D2)) C = 2.0D0*C + 0.5D0* (D-A*A-BB)/U B = 2.0D0*B + BB C ELSE T = TAN(FK) TK = T/FK B = 2.0D0*B + TK C = 2.0D0*C + 0.5D0* A (1.0D0+T*T-TK)/U ENDIF C C SUM FOR U.LE..04 ELSE G = -1.5707963D0 DO 30 N = 0,NBUT G = G + 3.141592654D0 A = 1.0D0/ (U-G*G) B = B + A C = C - A*A 30 CONTINUE C C CASE OF U.LT..04 AND U.GT.-.04 IF (U.GT.-0.04D0) THEN B = (0.4D0*U+1.0D0) A *U*0.33333333D0 A + B*2.0D0 + 1.0D0 C = ((0.48571429D0*U+0.8D0)*U A +1.0D0)*0.33333333D0 B + C*2.0D0 C C CASE OF U.LT.-.04 ELSE FK = SQRT(-U) T = TANH(FK) TK = T/FK B = 2.0D0*B + TK C = 2.0D0*C + 0.5D0 A * (1.0D0-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 40 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.0D0/ (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.0D-4) GOTO 60 C C END ITERATIONS C 50 CONTINUE NBUT = -NBUT IF (DELTA.GT.DELTA0) NBUT = 0 C AS PROCEDURE NOT CONVERGED OR DISTINCTLY DIVERGING - WE'88NOV17. C 60 CONTINUE C END C C C SUBROUTINE CALEXO(N,L,NONCON,ISTAND) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C GENERATES A NORMALIZED ORBITAL WHICH IS ORTHOGONAL TO ORBITALS C WITH THE SAME L-VALUE BUT SMALLER N-VALUE C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C COMMON /FACT/GAMMA(MZFAC) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C PARAMETER (ONE=1.0D0) 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) GOTO 10 C ICLEM=1 IMPLIES CLEMENTI COEFFICIENTS READ (IREAD,3010) M,ICLEM GOTO 20 C 10 CONTINUE M = M4 + 1 20 CONTINUE NCO(M1) = M M21 = M2 + 1 M2M = M2 + M IF (M.LE.NCOEFF) GOTO 30 C WRITE(IWRITE,13) STOP C 30 CONTINUE IF (ISTAND.EQ.0) GOTO 40 READ (IREAD,3010) (IRAD(J),J=M21,M2M) READ (IREAD,3020) (ZE(J),J=M21,M2M) GOTO 50 C 40 CONTINUE READ (IREAD,3000) (IRAD(J),ZE(J),J=M21,M2M) 50 CONTINUE 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) GOTO 70 M2P = M2 + MP IF (ISTAND.EQ.0) GOTO 60 READ (IREAD,3020) (C(J),J=M21,M2P) GOTO 80 C 60 CONTINUE READ (IREAD,3030) (C(J),J=M21,M2P) GOTO 80 C 70 CONTINUE C(M2+1) = ONE 80 CONTINUE IF (ICLEM.EQ.0) GOTO 100 C TRANSFORM CLEMENTI COEFFICIENTS TO SLATER COEFFICIENTS DO 90 J = M21,M2P IR = IRAD(J) ZR = ZE(J) Z1 = ZR + ZR C(J) = C(J)*SQRT(Z1/GAMMA(IR+IR+1))*Z1**IR 90 CONTINUE 100 CONTINUE CALL COEFF(N,L,M,M1,M2,M4,MP) C 3000 FORMAT (5 (I5,F9.5)) 3010 FORMAT (12I5) 3020 FORMAT (5F14.7) 3030 FORMAT (8F9.5) END C C C SUBROUTINE CALORB(ISTAND) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- PARAMETER (ZERO=0.0D0,ONE=1.0D0) C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXST10=MXSLT/MXNL1) C DIMENSION ISTO(MXST10),ZESTO(MXST10),CSTO(MXST10) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /FACT/GAMMA(MZFAC) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C----------------------------------------------------------------------- C 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,3000) 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 90 L = 1,LRANG1 JI = MAXNLG(L) IF (L.GT.JI) GOTO 90 READ (IREAD,3000) M IF (M.LE.NCOEFF) GOTO 10 WRITE (IWRITE,3040) STOP C 10 CONTINUE IF (ISTAND.EQ.0) GOTO 20 READ (IREAD,3000) (ISTO(J),J=1,M) READ (IREAD,3030) (ZESTO(J),J=1,M) GOTO 30 C 20 CONTINUE READ (IREAD,3010) (ISTO(J),ZESTO(J),J=1,M) 30 CONTINUE DO 80 N = L,JI IF (ISTAND.EQ.0) GOTO 40 READ (IREAD,3030) (CSTO(J),J=1,M) GOTO 50 C 40 CONTINUE READ (IREAD,3020) (CSTO(J),J=1,M) C C --- RENORMALIZATION BEGINS C - THIS WAS SCREWED-UP, SORTED 28/5/96 - NRB C 50 CONTINUE M1 = (L-1)*NLIMIT + N J1 = (M1-1)*NCOEFF NCO(M1) = M X = ZERO DO 60 J = 1,M IR = ISTO(J) IRAD(J+J1) = IR ZE(J+J1) = ZESTO(J) Y = ZESTO(J) + ZESTO(J) C(J+J1) = CSTO(J)*SQRT(Y/GAMMA(IR+IR+1))*Y**IR 60 CONTINUE DO 65 J=1,M X = C(J+J1)*ORNO(J,N,N,L) + X 65 CONTINUE Y = ONE/SQRT(X) DO 70 J = 1,M C(J+J1) = C(J+J1)*Y 70 CONTINUE 80 CONTINUE 90 CONTINUE C C --- INPUT ADDITIONAL ORBITALS C DO 110 L = 1,LRANG2 NLOWER = MAX(MAXNLG(L)+1,L) NUPPER = MAXNHF(L) IF (NLOWER.GT.NUPPER) GOTO 110 DO 100 N = NLOWER,NUPPER CALL CALEXO(N,L,NONCON,ISTAND) 100 CONTINUE 110 CONTINUE C 3000 FORMAT (12I5) 3010 FORMAT (5 (I5,F9.5)) 3020 FORMAT (8F9.5) 3030 FORMAT (5F14.7) 3040 FORMAT (///' THE VARIABLE NCOEFF IS TOO SMALL - FAIL IN CALORB'/) END C C C SUBROUTINE CIV3 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C READS ORBITAL DATA FROM CHANNEL IREAD IN CIV3 FORMAT C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C CHARACTER*4 MINUS C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C DIMENSION ZETA(MZLR2),NOCCSH(200),NOCORB(MXORB),NELCSH(MXORB) C----------------------------------------------------------------------- C C READ IN BASIC PARAMETERS DEFINING USE OF PROGRAM C READ (IREAD,3000) IVYEXP,IHYPF,IOSCI,IXTEND,IPARTN,ISUBD,ISO, A IFNCTN,NPUNCH,ISTAND,KPUNCH,IDTAIL,NREAD,ICSTAS,ITENPR,JPUNCH C WRITE(IWRITE,11) IVYEXP,IHYPF,IOSCI,IXTEND,IPARTN,ISUBD,ISO, C 1 IFNCTN,NPUNCH,ISTAND,KPUNCH,IDTAIL,NREAD,ICSTAS,ITENPR,JPUNCH IF (ISO.EQ.0) GOTO 10 READ (IREAD,3000) NOZS C WRITE(IWRITE,62) NOZS 10 CONTINUE IF (IDTAIL.EQ.0) GOTO 20 READ (IREAD,3000) NFNGO,NFNEND C WRITE(IWRITE,12) NFNGO,NFNEND GOTO 30 C 20 CONTINUE NFNGO = -1 NFNEND = -1 IF (ITENPR.EQ.0) GOTO 30 READ (IREAD,3000) ISPORB,ISCORB,ISPSPN,IMASS,IDAR,ICM1 C WRITE(IWRITE,1013) ISPORB,ISCORB,ISPSPN,IMASS,IDAR,ICM1 C C READ IN DEBUG PARAMETERS C 30 CONTINUE READ (IREAD,3000) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A 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) GOTO 40 READ (IREAD,3000) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, A NBUG9,IWFN C WRITE(IWRITE,78) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, C 1 NBUG9,IWFN C 40 CONTINUE READ (IREAD,3000) LRANG1,LRANG2,NCOEFF,NZ C WRITE(IWRITE,13) LRANG1,LRANG2,NCOEFF,NZ C READ (IREAD,3000) (MAXNLG(I),I=1,LRANG1) C WRITE(IWRITE,28) (MAXNLG(I),I=1,LRANG1) C C (MAXNLG(L)=L-1),L=LRANG1+1,LRANG2 -- IN STG1RD C READ (IREAD,3000) (MAXNHF(I),I=1,LRANG2) C WRITE(IWRITE,14) (MAXNHF(I),I=1,LRANG2) NLIMIT = 0 DO 50 L = 1,LRANG2 MAXN = MAXNHF(L) IF (NLIMIT.GE.MAXN) GOTO 50 NLIMIT = MAXN 50 CONTINUE C C --- READ IN RADIAL FUNCTIONS C C WRITE(IWRITE,9) CALL CALORB(ISTAND) C IF (ISPORB.NE.2) GOTO 60 READ (IREAD,3010) (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 60 CONTINUE IF (ISTAND.EQ.0) GOTO 70 READ (IREAD,3030) NCFG READ (IREAD,3030) (NOCCSH(I),I=1,NCFG) N = NOCCSH(1) READ (IREAD,3030) (NOCORB(J),J=1,N) READ (IREAD,3030) (NELCSH(J),J=1,N) GOTO 80 C 70 CONTINUE READ (IREAD,3040) NCFG READ (IREAD,3040) (NOCCSH(I),I=1,NCFG) N = NOCCSH(1) READ (IREAD,3040) (NOCORB(J),J=1,N) READ (IREAD,3040) (NELCSH(J),J=1,N) 80 CONTINUE NELC = 0 DO 90 J = 1,N NELC = NELC + NELCSH(J) 90 CONTINUE C DO 100 I = 1,999 READ (IREAD,3050,END=110) MINUS IF (MINUS.EQ.'----') GO TO 110 100 CONTINUE 110 CONTINUE C C---- SURELY LRANG1 MUST BE REDEFINED, VIZ. - NRB 28/5/96 C LRANG1=LRANG2 C 3000 FORMAT (14I5) 3010 FORMAT (5F14.7) 3030 FORMAT (12I5) 3040 FORMAT (24I3) 3050 FORMAT (A4) END SUBROUTINE CODE3(MAXORB) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C A NEW IMPLEMENTATION OF COD(3)='STO-' TO READ JUST THE RADIAL C ORBITAL INFO AS PER RECORD 9 OF THE 1995 CPC WRITE-UP - NRB C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C DIMENSION NJCOMP(MXORB),LJCOMP(MXORB) C C IF(NZ*NELC*MAXORB.EQ.0)THEN WRITE(6,1000)NZ,NELC,MAXORB STOP 'NZ, NELC AND MAXORB MUST BE SPECIFIED FOR STO-' ENDIF C IF(ABS(MAXORB).GT.MXORB) X CALL RECOV2('CODE3 ','MXORB ',MXORB,MAXORB) C C IF MAXORB.LT.0 THE N,L VALUES FOR THE (-MAXORB) SHELLS ARE C AUTOMATICALLY ORDERED AS 1S,2S,2P,3S,...... C IF MAXORB.GT.0 THE N,L VALUES FOR THE (MAXORB) SHELLS ARE READ IN C C NJCOMP(I),LJCOMP(I) ..... THE N,L VALUES FOR THE I-TH SHELL. C IF (MAXORB.LE.0) THEN MAXORB = -MAXORB N = 1 L = 0 DO I = 1,MAXORB NJCOMP(I) = N LJCOMP(I) = L L = L + 1 IF (L.GE.N) THEN N = N + 1 L = 0 ENDIF ENDDO C ELSE READ (IREAD,*) (NJCOMP(I),LJCOMP(I),I=1,MAXORB) ENDIF C C SET-UP MAXNHF C LRANG1=0 DO I=1,MAXORB MAXNHF(LJCOMP(I)+1)=MAX(MAXNHF(LJCOMP(I)+1),NJCOMP(I)) LRANG1=MAX(LRANG1,LJCOMP(I)+1) ENDDO C NLIMIT=0 DO I=1,LRANG1 NLIMIT=MAX(NLIMIT,MAXNHF(I)) ENDDO MAXNCO = NLIMIT* (LRANG1-1) + MAXNHF(LRANG1) NTERMS = MXSLT NCOEFF = NTERMS/MAXNCO C DO J = 1,NTERMS C(J) = ZERO ZE(J) = ZERO IF (J.LE.MAXNCO) NCO(J) = 0 IRAD(J) = 0 ENDDO C C READ IN THE RADIAL FUNCTIONS AND STORE THEM IN ARRAYS IN /RADIAL/ C DO L = 1,LRANG1 MAXHF = MAXNHF(L) DO N = L,MAXHF M1 = NLIMIT* (L-1) + N READ (IREAD,*) M MS = M*MAXNCO IF (M.GT.NCOEFF) CALL RECOV2('CODE3 ','MXSLT ',MXSLT,MS) IF (M.GT.NCOEFF) GOTO 90 NCO(M1) = M JLAST = NCOEFF* (M1-1) JSTART = JLAST + 1 JEND = JLAST + M READ (IREAD,*) (IRAD(J),J=JSTART,JEND) READ (IREAD,*) (ZE(J),J=JSTART,JEND) READ (IREAD,*) (C(J),J=JSTART,JEND) ENDDO ENDDO C 90 RETURN C 1000 FORMAT(/'***ERROR*** NZ, NELC, MAXORB MUST BE SPECIFIED FOR', X' STO- THE CURRENT VALUES ARE:',3I5) C END C C C SUBROUTINE COEFF(N,L,M,M1,M2,M4,MP) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- PARAMETER (ZERO=0.0D0,ONE=1.0D0, A NSIMEQ=8,NQSQ=NSIMEQ*NSIMEQ) C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C DIMENSION A(NQSQ),B(NSIMEQ) C COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C----------------------------------------------------------------------- IF (M4.GT.NSIMEQ) GOTO 100 IF (M4.EQ.1) GOTO 50 IF (M4.LT.1) GOTO 70 C C --- MORE THAN ONE ORTHOGONALITY CONDITIONS RESULTS IN SOLUTION OF C SIMULTANEOUS EQUATIONS USING MA01A -- NO CHECK FOR L92 YET! C DO 30 K = 1,M4 KL1 = K + L - 1 DO 10 J = 1,M4 KK = NSIMEQ* (J-1) + K A(KK) = ORNO(J+MP,KL1,N,L) 10 CONTINUE X = ZERO DO 20 J = 1,MP X = X + ORNO(J,KL1,N,L)*C(M2+J) 20 CONTINUE B(K) = -X 30 CONTINUE CALL MA01A(A,B,M4,1,0,NSIMEQ,1) M3 = M2 + MP DO 40 J = 1,M4 C(J+M3) = B(J) 40 CONTINUE GOTO 70 C C --- ONLY ONE ORTHOGONALITY CONDITION, THEREFORE ONLY ONE EQUATION C TO BE SOLVED C 50 CONTINUE X = ZERO DO 60 J = 1,MP X = X + C(M2+J)*ORNO(J,L,N,L) 60 CONTINUE C(M2+M) = -X/ORNO(M,L,N,L) C C --- DETERMINATION OF OVER-ALL NORMALIZATION FACTOR C 70 CONTINUE X = ZERO DO 80 J = 1,M X = X + C(M2+J)*ORNO(J,N,N,L) 80 CONTINUE Y = ONE/SQRT(X) DO 90 J = 1,M C(J+M2) = Y*C(J+M2) 90 CONTINUE RETURN C 100 CONTINUE WRITE (IWRITE,3000) STOP C 3000 FORMAT (/ A' PROGRAM HALTED IN COEFF BECAUSE NUMBER OF SIMULTANEOUS EQUATIO BNS IS TOO LARGE'/' INCREASE VALUE OF PARAMETER NSIMEQ') END C C C SUBROUTINE CORECT(N,LP,R0,SIGMA,C1) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C PARAMETER (ZERO=0.0D0) PARAMETER (ONE=1.0D0) PARAMETER (S=2.0D0) PARAMETER (FIFTH=0.2D0) PARAMETER (TENTH=0.1D0) C----------------------------------------------------------------------- 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 = ZERO DP = ZERO DO 10 J = J1,M TERM = C(J)*RA**IRAD(J)*EXP(-ZE(J)*RA) PA = TERM + PA DP = (IRAD(J)/RA-ZE(J))*TERM + DP 10 CONTINUE C C FIND PARAMETERS SIGMA, R0, C1 FROM THE LOGARITHMIC DERIVATIVE B C B = RA*DP/PA SIGMA = RA* (S-SQRT(S*S-FIFTH*B))/B R0 = S*SIGMA + (ONE-TENTH)*RA C1 = PA*EXP(((RA-R0)/SIGMA)**2) C END C C C SUBROUTINE DA2(KEY,IREC,JDISC,LENGTH,ARRAY) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO STORE A LARGE ARRAY IN A DA FILE OF RECORD LENGTH 8*LREC BYTES. C C KEY = 1 FOR READ, C = 2 FOR WRITE, C = 0 FOR FINDING NUMBER OF DA RECORDS A GIVEN ARRAY TAKES. C C IREC= (ON CALL) POINTER TO FIRST DA RECORD FOR ARRAY, C = 0 FOR OPENING DA FILE (BY NAME), C =-1 FOR OPENING DA FILE (SCRATCH), C = (ON RETURN) POINTER TO NEXT AVAILABLE DA RECORD. C C JDISC = DA FILE UNIT NUMBER. C C ARRAY(LENGTH) = ARRAY TO READ OR WRITE. C C----------------------------------------------------------------------- PARAMETER (LREC=512) !MUST SYC WITH STG2! C DIMENSION ARRAY(LENGTH) C----------------------------------------------------------------------- C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc character*1 filec,filed,fileu c **** parallel **** C IF (IREC.GT.0) GOTO 20 C IRECL = 8*LREC C IF (IREC.LT.0) THEN OPEN (JDISC,STATUS='SCRATCH',ACCESS='DIRECT', X FORM='UNFORMATTED',RECL=IRECL) GOTO 10 ENDIF C IF (KEY.EQ.2) THEN c **** parallel **** c....... open RKxx.dat file (XX is the processor) if (nproc.gt.1) then ich0 = ichar('0') ic = iam/100 id = (iam - 100*ic)/10 iu = (iam - 100*ic - 10*id) ic = ic + ich0 id = id + ich0 iu = iu + ich0 filec = char(ic) filed = char(id) fileu = char(iu) OPEN (JDISC,STATUS='UNKNOWN', + FILE='RK'//filec//filed//fileu//'.DAT',ACCESS='DIRECT', + FORM='UNFORMATTED',RECL=irecl) else c **** parallel **** OPEN (JDISC,STATUS='UNKNOWN', + FILE='RK.DAT',ACCESS='DIRECT', A FORM='UNFORMATTED',RECL=IRECL) endif ELSE OPEN (JDISC,STATUS='OLD', + FILE='RK.DAT',ACCESS='DIRECT', A FORM='UNFORMATTED',RECL=IRECL) ENDIF C 10 CONTINUE IREC = 1 C 20 CONTINUE IF (LENGTH.EQ.0) RETURN I2 = 0 30 CONTINUE I1 = I2 + 1 I2 = MIN(I2+LREC,LENGTH) IF (KEY.EQ.0) GOTO 40 C IF (KEY.EQ.2) THEN WRITE (JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ELSE READ (JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ENDIF C 40 CONTINUE IREC = IREC + 1 IF (I2.LT.LENGTH) GOTO 30 C END C C C SUBROUTINE DERFUN IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES THE SECOND DERIVATIVE FUNCTION FOR THE DE VOGELAERE C ROUTINE DEVGL ASSOCIATED WITH THE NEW BASFUN C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN11=MZNR1+1) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXPT2=2*MZNPT) C COMMON /BASDER/FM,TLC,WR,ITST,JR,KM,MMM,NBTP1,NG COMMON /BNDORB/P(MZNR1,MXPT2),RACOR(MXORB) COMMON /FUNVAL/FRH(MXN11),U(MXN11),X COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) C PARAMETER (ZERO=0.0D0) C----------------------------------------------------------------------- KM = KM + MMM FRHVAL = TLC/ (X*X) - WR - POVALU(KM) IF (FRHVAL.LT.ZERO .AND. FM.GT.ZERO) GOTO 10 IF (FRHVAL.GT.ZERO .AND. FM.LT.ZERO) GOTO 10 FM = FRHVAL GOTO 20 C 10 CONTINUE IF (ITST.EQ.1) GOTO 20 IMATCH = JR IF (MOD(IMATCH,2).NE.0) IMATCH = IMATCH - 1 ITST = 1 20 CONTINUE FRH(NBTP1) = FRHVAL*U(NBTP1) IF (NG.EQ.0) GOTO 40 DO 30 I = 1,NG FRH(I) = FRHVAL*U(I) + P(I,KM) 30 CONTINUE C 40 CONTINUE C END C C C SUBROUTINE DERINT(N11,L11,N12,L12,RESULT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /YKSTOR/YK(MZNPT),TEST1 C PARAMETER (ZERO=0.0D0) PARAMETER (HALF=0.5D0) PARAMETER (ONE=1.0D0) PARAMETER (TWO=2.0D0) PARAMETER (SIX=6.0D0) PARAMETER (GSMAX=12.0D0) C----------------------------------------------------------------------- N2 = N12 L2 = L12 MAXHF2 = L2 - 1 IF (L2.LE.LRANG1) MAXHF2 = MAXNHF(L2) N1 = N11 IF (N1.LE.0) GOTO 20 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 = ZERO SUM = ZERO SIGN = ONE IF (N2.LE.MAXHF2) GOTO 10 IF (N1.GT.MAXHF1) GOTO 80 N2 = N11 L2 = L11 N1 = N12 L1 = L12 SIGN = -ONE 10 CONTINUE K1 = IPOS(N1,L1) 20 CONTINUE K2 = IPOS(N2,L2) IF (N2.GT.MAXHF2) GOTO 80 IF (NCOEFF.EQ.0) GOTO 50 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 40 I = 2,NPTS R = XR(I) C C DETERMINE THE CONTRIBUTION FROM THE ALPHA/R C PV = ZERO ALPHA = (R-R0)/SIGMA IF (-ALPHA.LT.GSMAX) PV = (TWO*ALPHA/SIGMA)*C1*EXP(-ALPHA*ALPHA) C C DETERMINE THE CONTIBUTION INVOLVING THE FIRST DERIVATIVE C ACTING ON THE BOUND ORBITAL C DO 30 J = M1,M2 PV = (IRAD(J)/R-ZE(J))*EXP(-ZE(J)*R)*R**IRAD(J)*C(J) + PV 30 CONTINUE YK(I) = PV 40 CONTINUE GOTO 150 C C OTHERWISE CALCULATE FIRST DERIVATIVE FROM FUNCTION AND C SECOND DERIVATIVE AT TWO ADJACENT POINTS C 50 CONTINUE ALL2 = ((L2-1)*L2) ANZ = 2*NZ HP = XR(2) H = HP 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) YK(2) = (UJ(3,K2)-UJ(2,K2))/HP - (DR2+DR2+DR3)*H/SIX DO 70 I = 3,NPTS H = HP DR1 = DR2 DR2 = DR3 IF (I.EQ.NPTS) GOTO 60 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.01D0) GOTO 60 YK(I) = ((UJ(I+1,K2)-UJ(I-1,K2))/H+ (DR1-DR3)*H/SIX)*HALF GOTO 70 C 60 CONTINUE YK(I) = (UJ(I,K2)-UJ(I-1,K2))/H + (DR2+DR2+DR1)*H/SIX 70 CONTINUE C NXT YK(2)= (L2-(L2+1)*NZ*XR(2)/L2)*UJ(1,K2)*XR(2)**(L2-1) GOTO 150 C C BOTH ORBITALS ARE CONTINUUM ORBITALS: LAGRANGE DIFFERENTIATION C 80 CONTINUE CNRB K1 = IPOS(N1,L1) ! NOT USED & N1 CANBE LT 0 K2 = IPOS(N2,L2) DO 140 M = 2,NPTS - 1 M1 = MAX(M-3,1) M2 = MIN(M+3,NPTS) C NOT M1=M2-6 PV = ZERO HP = ZERO DO 130 I = M1,M2 IF (I.NE.1) HP = UJ(I,K2) IF (I.NE.M) GOTO 100 H = ZERO DO 90 J = M1,M2 IF (J.EQ.M) GOTO 90 H = ONE/ (XR(M)-XR(J)) + H 90 CONTINUE GOTO 120 C 100 CONTINUE H = ONE/ (XR(I)-XR(M)) DO 110 J = M1,M2 IF (J.EQ.I) GOTO 110 IF (J.EQ.M) GOTO 110 H = (XR(M)-XR(J))*H/ (XR(I)-XR(J)) 110 CONTINUE 120 PV = HP*H + PV 130 CONTINUE YK(M) = PV 140 CONTINUE YK(NPTS) = UJ(NPTS,K2)*BSTO C C COMPUTE DIPOLE VELOCITY INTEGRAL USING SIMPSONS RULE C 150 CONTINUE C IF (N1.GT.0) THEN K1 = IPOS(N1,L1) DO 160 I = 2,NPTS SUM = (UJ(I,K2)*ALF/XR(I)+SIGN*YK(I))*UJ(I,K1)*WT(I) + SUM 160 CONTINUE RESULT = SUM TEST1 = TEST1 + RESULT ELSE YK(1) = ZERO IF (L2.EQ.1) YK(1) = UJ(1,K2) ENDIF C END C C C SUBROUTINE DEVGL(M,DY,FR,FRM,H,HS,H1,LSWT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C DE VOGELAERE INTEGRATION ROUTINE C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN11=MZNR1+1) C DIMENSION DY(MXN11),FR(MXN11),FRM(MXN11),YR(MXN11) C COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /FUNVAL/FRH(MXN11),U(MXN11),X C----------------------------------------------------------------------- HH = HALF*H X = X + HH IF (LSWT.GT.1) GOTO 20 DO 10 I = 1,M DY(I) = DY(I) + FR(I) YR(I) = U(I) + DY(I) U(I) = YR(I) + FR(I) - EIGHTH*FRM(I) 10 CONTINUE GOTO 40 C 20 CONTINUE H12 = H/H1 H12S = H12*H12 LSWT = 1 DO 30 I = 1,M DY(I) = H12*DY(I) + H12S*FR(I) YR(I) = U(I) + DY(I) U(I) = YR(I) + HALF*H12S* (FR(I)* (H12+ONE)-FOURTH*H12*FRM(I)) 30 CONTINUE 40 CONTINUE CALL DERFUN DO 50 I = 1,M FRM(I) = HS*FRH(I)*THIRD DY(I) = DY(I) + FRM(I) U(I) = YR(I) + DY(I) 50 CONTINUE X = X + HH CALL DERFUN DO 60 I = 1,M FR(I) = HS*FRH(I)/TWELVE DY(I) = DY(I) + FR(I) 60 CONTINUE C END SUBROUTINE DIAG(N,Z,D,E,MXMAT) C IMPLICIT REAL*8 (A-H,O-Z) C C BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE C C DIAGONALIZATION OF REAL SYMMETRIC N-BY-N MATRIX Z. C C METHOD: HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM AND SHIFTED C QL ALGORITHM TO DETERMINE THE E-VALUES AND E-VECTORS. C C BASED ON MARTIN, REINSCH & WILKINSON: NUM. MATH. 11, 181-95 (1968). C C INPUT REQUIRED. N AND Z. ONLY LOWER TRIANGLE OF Z NEED BE SUPPLIED. C MATRIX Z OVERWRITTEN BY EIGENVECTORS OF Z. C MXMAT, IS THE ROW DIMENSION OF Z IN THE CALLING ROUTINE. C C OUTPUT. Z AND D, WHERE Z CONSISTS OF COLUMN EIGENVECTORS C AND D CONSISTS OF CORRESPONDING EIGENVALUES. C C NOTE: E IS A WORKING ARRAY. C PARAMETER (TOL = 1.0D-75) PARAMETER (EPS = 1.0D-15) PARAMETER (ZERO = 0.0D0) PARAMETER (ONE = 1.0D0) PARAMETER (JMAX = 30) C LOGICAL BNOGT C DIMENSION D(N),E(N),Z(MXMAT,N) C C BNOGT=N.LT.0 IF(BNOGT)N=-N C DO 1 I = 1,N D(I) = Z(N,I) 1 CONTINUE IF (N.LE.1) GO TO 20 C C HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM C DO 19 I = N,2,-1 L = I - 1 F = D(I-1) G = ZERO DO 5 K = 1,I-2 G = G + D(K)*D(K) 5 CONTINUE H = G + F*F IF (G.GT.TOL) GO TO 8 E(I) = F H = ZERO DO 7 J = 1,L D(J) = Z(L,J) Z(I,J) = ZERO Z(J,I) = ZERO 7 CONTINUE GO TO 18 8 G = SQRT(H) IF (F.GE.ZERO) G = -G E(I) = G H = H - F*G D(L) = F - G DO 14 J = 1,L E(J) = ZERO 14 CONTINUE DO 15 J = 1,L Z(J,I) = D(J) G = E(J) + Z(J,J)*D(J) DO 13 K = J+1,L G = G + Z(K,J)*D(K) E(K) = E(K) + Z(K,J)*D(J) 13 CONTINUE E(J) = G 15 CONTINUE F = ZERO DO 12 J = 1,L E(J) = E(J)/H F = F + E(J)*D(J) 12 CONTINUE HH = F/(H+H) DO 11 J = 1,L E(J) = E(J) - HH*D(J) 11 CONTINUE DO 17 J = 1,L F = D(J) G = E(J) DO 16 K = J,L Z(K,J) = Z(K,J) - F*E(K) - G*D(K) 16 CONTINUE D(J) = Z(L,J) Z(I,J) = ZERO 17 CONTINUE 18 D(I) = H 19 CONTINUE C C C ACCUMULATE TRANSFORMATION MATRICES C DO 28 I = 2,N L = I - 1 Z(N,L) = Z(L,L) Z(L,L) = ONE H = D(I) IF (H.EQ.ZERO) GO TO 25 DO 21 K = 1,L D(K) = Z(K,I)/H 21 CONTINUE DO 24 J = 1,L G = ZERO DO 22 K = 1,L G = G + Z(K,I)*Z(K,J) 22 CONTINUE DO 23 K = 1,L Z(K,J) = Z(K,J) - G*D(K) 23 CONTINUE 24 CONTINUE 25 DO 27 J = 1,L Z(J,I) = ZERO 27 CONTINUE 28 CONTINUE DO 29 I = 1,N D(I) = Z(N,I) Z(N,I) = ZERO 29 CONTINUE 20 E(1) = ZERO Z(N,N) = ONE C C C SHIFTED QL ALGORITHM TO DETERMINE E-VALUES & E-VECTORS C DO 32 I = 2,N E(I-1) = E(I) 32 CONTINUE E(N) = ZERO B = ZERO F = ZERO DO 54 L = 1,N J = 0 H = EPS*(ABS(D(L))+ABS(E(L))) IF (B.LT.H) B = H DO 36 M = L,N IF (ABS(E(M)).LE.B) GO TO 37 36 CONTINUE 37 IF (M.EQ.L) GO TO 53 38 IF (J.EQ.JMAX) GO TO 62 J = J+ 1 P = E(L) + E(L) G = D(L) H = D(L+1) - G IF (ABS(H).GE.ABS(E(L))) GO TO 43 P = H/P R = SQRT(P*P+ONE) H = P + R IF (P.LT.ZERO) H = P - R D(L) = E(L)/H GO TO 44 43 P = P/H R = SQRT(P*P+ONE) D(L) = E(L)*P/(R+ONE) 44 H = G - D(L) DO 46 I = L+1,N D(I) = D(I) - H 46 CONTINUE F = F + H P = D(M) C = ONE S = ZERO DO 52 I = M-1,L,-1 G = C*E(I) H = C*P IF (ABS(P).LT.ABS(E(I))) GO TO 49 C = E(I)/P R = SQRT(C*C+ONE) E(I+1) = S*P*R S = C/R C = ONE/R GO TO 50 49 C = P/E(I) R = SQRT(C*C+ONE) E(I+1) = S*E(I)*R S = ONE/R C = C/R 50 P = C*D(I) - S*G D(I+1) = H + S*(C*G+S*D(I)) DO 51 K = 1,N H = Z(K,I+1) Z(K,I+1) = S*Z(K,I) + C*H Z(K,I) = C*Z(K,I) - S*H 51 CONTINUE 52 CONTINUE E(L) = S*P D(L) = C*P IF (ABS(E(L)).GT.B) GO TO 38 53 D(L) = D(L) + F 54 CONTINUE C IF(BNOGT)RETURN C C BEGIN SORTING INTO ASCENDING E-VALUES C DO 61 I = 1,N K = I P = D(I) DO 57 J = I+1,N IF (D(J).GE.P) GO TO 57 K = J P = D(J) 57 CONTINUE IF (K.EQ.I) GO TO 61 D(K) = D(I) D(I) = P DO 60 J = 1,N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 60 CONTINUE 61 CONTINUE C RETURN C C 62 WRITE(6,100) 100 FORMAT(' FAILED IN DIAG, TOO MANY ITERATIONS') RETURN C END C C C SUBROUTINE EVAL(LP) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C 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 (NCOEFF=0), C OR THE ANALYTIC FORM OF THE SLATER-TYPE ORBITALS. C C----------------------------------------------------------------------- PARAMETER (ZERO=0.0D0) PARAMETER (HALF=0.5D0) PARAMETER (FOURTH=0.25D0) PARAMETER (GSMAX=12.0D0) C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BNDORB/P(MZNR1,MXPT2),RACOR(MXORB) COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS C----------------------------------------------------------------------- MAXLG = MAXNLG(LP) IF (MAXLG.LT.LP) RETURN 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 40 N = LP,MAXLG N1 = IPOS(N,LP) KT = KT + 1 IF (NCOEFF.EQ.0) THEN C C INTERPOLATE THE NUMERICAL BOUND ORBITAL AT THE HALF-MESH POINTS C Y = ZERO DR1 = ZERO DO 10 K = 2,NPTS R = XR(K) DR2 = ((ALL2/R-ANZ)/R)*UJ(K,N1) - DUJ(K,N1) H = (R-XR(K-1))*FOURTH P(KT,2*K-3) = (UJ(K,N1)+Y)*HALF - (DR2+DR1)*H*H Y = UJ(K,N1) P(KT,2*K-2) = Y DR1 = DR2 10 CONTINUE C ELSE C C EVALUATE THE ANALYTIC BOUND ORBITAL AT THE HALF-MESH POINTS C CALL CORECT(N,LP,R0,SIGMA,C1) M1 = (LP-1)*NLIMIT + N J1 = (M1-1)*NCOEFF + 1 M = NCO(M1) + J1 - 1 DO 30 I = 2,NPTS R = (XR(I-1)+XR(I))*HALF PV = ZERO H = (R-R0)/SIGMA IF (-H.LT.GSMAX) PV = -C1*EXP(-H*H) DO 20 K = J1,M PV = C(K)*R**IRAD(K)*EXP(-ZE(K)*R) + PV 20 CONTINUE P(KT,2*I-3) = PV P(KT,2*I-2) = UJ(I,N1) 30 CONTINUE ENDIF C 40 CONTINUE C END C C C SUBROUTINE EVALUE IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C ONLY CALLED FOR THE CASE OF ANALYTIC SLATER-TYPE ORBITALS. C EVALUATES AND STORES ALL THE BOUND-ORBITAL FUNCTIONS P AND Q C IN THE ARRAYS UJ AND DUJ. C RACOR IS USED IN BASORB FOR MAGNITUDE PRINTOUT. C NQ IS A COUNT ON THE ORBITALS STORED, RETURNED AS NBOUND. 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----------------------------------------------------------------------- PARAMETER (ZERO=0.0D0) PARAMETER (ONE=1.0D0) PARAMETER (TWO=2.0D0) PARAMETER (GSMAX=12.0D0) C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BNDORB/P(MZNR1,MXPT2),RACOR(MXORB) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /NRBOCC/TOCC(MXORB),IMAXN,IBANDW C----------------------------------------------------------------------- NQ = 0 DO 70 LP = 1,LRANG1 MAXHF = MAXNHF(LP) IF (MAXHF.LT.LP) GOTO 70 IF (NBUG5.EQ.1) WRITE (IWRITE,3000) LP - 1 ALSQ = (LP-1)*LP ZN = (NZ+NZ) KT = 0 C C LOOP OVER ALL THE BOUND ORBITALS FOR THE GIVEN ANGULAR MOMENTUM C DO 60 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 30 I = 2,NPTS R = XR(I) C C DETERMINE THE CONTRIBUTION INVOLVING THE SECOND DERIVATIVE C ACTING ON THE BOUND-ORBITAL C PW = ZERO H = (R0-R)/SIGMA IF (H.LT.GSMAX) PW = (ONE-TWO*H*H)* (TWO/ (SIGMA*SIGMA))*C1* A EXP(-H*H) DO 10 K = J1,M IR = IRAD(K) ZEX = -ZE(K)*R PW = ((IR-1)*IR+ (IR*2+ZEX)*ZEX)*EXP(ZEX)*R** (IR-2)* A C(K) + PW 10 CONTINUE PV = ZERO H = (R-R0)/SIGMA IF (-H.LT.GSMAX) PV = -C1*EXP(-H*H) OLDEND = PV DO 20 K = J1,M PV = C(K)*R**IRAD(K)*EXP(-ZE(K)*R) + PV 20 CONTINUE UJ(I,NQ) = PV C C ADD THE ANGULAR MOMENTUM AND NUCLEAR CHARGE TERMS TO SECOND C DERIVATIVE, STORE Q FUNCTION IN DUJ ARRAY C H = ONE/R DUJ(I,NQ) = (ALSQ*H-ZN)*H*PV - PW 30 CONTINUE C C RENORMALIZE THE ORBITAL C CALL ABNORM(N,LP,N,LP,H) AN = ONE/SQRT(H) PV = ZERO PW = ZERO H = ZERO DO 40 J = J1,M C(J) = C(J)*AN IF (IRAD(J).EQ.LP) PV = C(J) + PV IF (LP.NE.1) GOTO 40 IF (IRAD(J).EQ.1) PW = C(J)*ZE(J) + PW IF (IRAD(J).EQ.2) H = C(J) + H 40 CONTINUE UJ(1,NQ) = PV DUJ(1,NQ) = (H-PW)*TWO C C HOLDING SLOPE OF 2ND DERIVATIVE, AS QBAR IS INFINITE FOR STO'S. C IF (NBUG5.EQ.1) WRITE (IWRITE,3010) N,R0,SIGMA,C1,AN DO 50 I = 2,NPTS DUJ(I,NQ) = DUJ(I,NQ)*AN UJ(I,NQ) = UJ(I,NQ)*AN 50 CONTINUE RACOR(NQ) = OLDEND*AN IF(IBANDW.EQ.0)TOCC(NQ)=4*(LP-1)+2 60 CONTINUE C 70 CONTINUE NBOUND = NQ C 3000 FORMAT (/' BOUND ORBITALS CORRECTED, L =',I2) 3010 FORMAT (' N =',I2,' R0 =',F9.5,' SIGMA =',E12.5,' C1 =',E12.5, A ' AN =',F9.5) END SUBROUTINE FINDEE(NBT,L,ELAST,ENEXT,RA,BSTO,NODES) C C KAB: C FIND THE NEXT ENERGY SOLUTION SATISFYING THE BSTO BOUNDARY CONDITION. C INPUT: NBT,N,L,ELAST(=PREVIOUS EIGENVALUE),ENEXT(=TRIAL ENERGY),RA,BSTO; C OUTPUT: NODES, AND /ORBOUT/ STUFF FROM BASFUN. C IMPLICIT REAL*8(A-H,O-Z) INCLUDE 'PARAM' C PARAMETER (MXN11=MZNR1+1) PARAMETER (FIFTY=50.0) PARAMETER (D1M12=1.D-12) PARAMETER (D1M14=1.D-14) C COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /ORBOUT/ORB(MZNPT),DORB(MZNPT),EIGEN,ALAMDA(MXN11),BVALUE C ESTEP = (ENEXT - ELAST)/FIFTY BB1 = 0. LOWER = 0 C C LOOP OVER ENERGIES TO LOCATE NEXT CHANGE OF SIGN OF LOG DERIV BVALUE DO 241 K = 1, 10000 ENEXT = ELAST + K*ESTEP C CALL BASFUN(NBT,L,NODES,RA,BSTO,ENEXT,ZERO,ZERO) C BV = BVALUE - BSTO IF( LOWER.EQ.1 .AND. BV*BB1.LT.ZERO)THEN EE2 = ENEXT BB2 = BV BBV = BV C C BISECT ENERGY 40 TIMES SHOULD GIVE 2**40 OR 12 DECIMAL PLACE ACCURACY DO KK = 1, 40 ENEXT = (EE1 + EE2)*HALF C CALL BASFUN(NBT,L,NODES,RA,BSTO,ENEXT,ZERO,ZERO) C BV = BVALUE - BSTO IF(ABS(BV).LT.D1M12.OR.ABS(EE1-EE2).LT.ENEXT*D1M14)RETURN C IF( BV.LT.MIN(BB1,BB2) .OR. BV.GT.MAX(BB1,BB2) )THEN BB1 = BBV EE1 = ELAST + K*ESTEP LOWER = 0 GOTO 241 ENDIF IF( BV*BB1.LT.ZERO )THEN EE2 = ENEXT BB2 = BV ELSE EE1 = ENEXT BB1 = BV ENDIF ENDDO RETURN ENDIF LOWER = 0 IF( ABS(BV).LT.ABS(BB1) ) LOWER = 1 BB1 = BV EE1 = ENEXT 241 CONTINUE C WRITE(IWRITE,*) X 'PROBLEMS IN FINDEE: ADJUST TRIAL ENERGY ENEXT OR ESTEP' STOP 'PROBLEMS IN FINDEE: ADJUST TRIAL ENERGY ENEXT OR ESTEP' C END C C C SUBROUTINE FINDER(NBT,LC,NODES,ETRIAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C ADAPTATION TO WORK WITH OP VERSION OF RMATRX CODE - WE'88NOV25. C C SUBROUTINE FINDER(NBT,LC,NODES,ETRIAL) C C A NEW FINDER ROUTINE WRITTEN AT MUENSTER...AUGUST 1983 C C NBT..... THE NUMBER OF BOUND ORBITALS TO ORTHOGONALISE TO. C LC ..... THE L VALUE. C NODES... THE REQUIRED NUMBER OF NODES IN THE EIGENFUNCTION. C ETRIAL.. INITIAL ESTIMATE OF THE EIGENENERGY. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN11=MZNR1+1) C PARAMETER (ZERO=0.0D0) PARAMETER (TENTH=0.1D0) PARAMETER (HALF=0.5D0) PARAMETER (THREE=3.0D0) PARAMETER (PI=3.14159D0) PARAMETER (ERROR=1.0D-6) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBOUT/ORB(MZNPT),DORB(MZNPT),EIGEN,ALAMDA(MXN11),BVALUE C----------------------------------------------------------------------- C C INITIALISE VARIABLES. C IF (NBUG4.GT.0) WRITE (IWRITE,3000) DEL = PI/RA DEL2 = DEL*DEL DELL = DEL ISUM = 0 10 CONTINUE C CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,ZERO,ZERO) C IF (NBUG4.GT.0) WRITE (IWRITE,3010) NODE,NODES,BVALUE,EIGEN,ETRIAL C C CHECK THAT THE FUNCTION HAS THE CORRECT NUMBER OF NODES. C IF (NODE.NE.NODES) THEN C C FUNCTION HAS NOT THE CORRECT NUMBER OF NODES, MODIFY ENERGY C ACCORDINGLY. C IF (ISUM.GT.0) THEN IF (NODE-NODES.EQ.NHOLD) THEN DELL = DELL*HALF DEL2 = DEL2*HALF ETRIAL = EHOLD ELSE NHOLD = NODES - NODE ENDIF ELSE NHOLD = NODES - NODE ENDIF C EHOLD = ETRIAL ISUM = ISUM + 1 REALNN = NODES - NODE IF (ETRIAL.LT.ZERO .OR. SQRT(ABS(ETRIAL))+REALNN*DELL.LT. A ZERO) THEN ETRIAL = ETRIAL + ABS(REALNN)*REALNN*DEL2 ELSE ETRIAL = (REALNN*DELL+SQRT(ABS(ETRIAL)))**2 ENDIF C IF (ISUM.EQ.100) THEN WRITE (IWRITE,3020) GOTO 60 ELSE GOTO 10 ENDIF C ELSE C C FUNCTION HAS THE CORRECT NUMBER OF NODES. C IF (BVALUE.LT.BSTO) THEN C C WE HAVE AN UPPER BOUND TO THE ENERGY,NOW FIND LOWER BOUND. C EHIGH = ETRIAL BLOW = BVALUE DEL1 = DEL/THREE DEL2 = DEL2/THREE EHOLD = ETRIAL C 20 CONTINUE C IF (ETRIAL.LT.ZERO .OR. SQRT(ABS(ETRIAL))-DEL1.LT.ZERO) THEN ETRIAL = ETRIAL - DEL2 ELSE ETRIAL = (SQRT(ABS(ETRIAL))-DEL1)**2 ENDIF C CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,ZERO,ZERO) C IF(NBUG4.GT.0)WRITE(IWRITE,3010)NODE,NODES,BVALUE,EIGEN,ETRIAL C IF (NODE.NE.NODES) THEN C C ENERGY DECREASED TOO FAR, DECREASE INCREMENT C DEL1 = DEL1/THREE DEL2 = DEL2/THREE ETRIAL = EHOLD IF(DEL1.LT.ERROR**2.OR.DEL2.LT.ERROR**2)THEN WRITE(IWRITE,3025) GO TO 60 ENDIF GOTO 20 C ELSE C IF (BVALUE.LT.BSTO) THEN C C BETTER UPPER BOUND TO THE ENERGY FOUND, TRY AGAIN C FOR A LOWER BOUND. C EHIGH = ETRIAL BLOW = BVALUE EHOLD = ETRIAL GOTO 20 C ELSE C C LOWER BOUND TO THE ENERGY NOW FOUND. C ELOW = ETRIAL BHIGH = BVALUE ENDIF C ENDIF C ELSE C C LOWER BOUND TO THE ENERGY FOUND,NOW TRY FOR AN UPPER BOUND. C ELOW = ETRIAL BHIGH = BVALUE DEL1 = DEL/THREE DEL2 = DEL2/THREE EHOLD = ETRIAL C 30 CONTINUE C IF (ETRIAL.LT.ZERO) THEN ETRIAL = ETRIAL + DEL2 ELSE ETRIAL = (SQRT(ABS(ETRIAL))+DEL1)**2 ENDIF C CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,ZERO,ZERO) C IF(NBUG4.GT.0)WRITE(IWRITE,3010)NODE,NODES,BVALUE,EIGEN,ETRIAL C IF (NODE.NE.NODES) THEN C C ENERGY INCREASED TOO FAR, DECREASE INCREMENT. C DEL1 = DEL1/THREE DEL2 = DEL2/THREE ETRIAL = EHOLD IF(DEL1.LT.ERROR**2.OR.DEL2.LT.ERROR**2)THEN WRITE(IWRITE,3025) GO TO 60 ENDIF GOTO 30 C ELSE IF (BVALUE.GE.BSTO) THEN C C BETTER LOWER BOUND TO THE ENERGY FOUND, TRY AGAIN C FOR THE UPPER BOUND. C ELOW = ETRIAL BHIGH = BVALUE EHOLD = ETRIAL GOTO 30 C ELSE C C UPPER BOUND TO THE ENERGY FOUND. C EHIGH = ETRIAL BLOW = BVALUE ENDIF C ENDIF C ENDIF C ENDIF C C WE NOW HAVE UPPER AND LOWER BOUNDS TO THE EIGENENERGY, C NOW USE ROOT FINDING ROUTINE TO GET A BETTER ESTIMATE. C IFLAG = 1 ABSERR = ZERO RELERR = ERROR*TENTH B = ELOW C = EHIGH IF (ETRIAL.EQ.ELOW) THEN FT = BHIGH - BSTO ELSE FT = BLOW - BSTO ENDIF C 40 CONTINUE C CALL ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG) C IF(IFLAG.GT.1)THEN IF(ABS(ELOW-EHIGH).LT.ERROR/TENTH)THEN IFLAG=1 B=HALF*(ELOW+EHIGH) ENDIF ENDIF C IF (IFLAG.LT.0) THEN C C STILL NOT CLOSE ENOUGH TO THE ROOT C IF (T.EQ.ELOW) THEN FT = BHIGH - BSTO GOTO 40 ELSE IF (T.EQ.EHIGH) THEN FT = BLOW - BSTO GOTO 40 ELSE ETRIAL = T C CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,ZERO,ZERO) C IF(NBUG4.GT.0)WRITE(IWRITE,3010)NODE,NODES,BVALUE,EIGEN,ETRIAL C FT = BVALUE - BSTO C C IF ABS(FT) IS LESS THAN ERROR..SOLUTION FOUND C IF (ABS(FT).LT.ERROR) GOTO 50 GOTO 40 C ENDIF C ELSE IF (IFLAG.GT.1) THEN C C ERROR IN ROOT C WRITE (IWRITE,3030) IFLAG GOTO 60 C ELSE C C IFLAG=1...ROOT SUCESSFULLY LOCATED TO REQUIRED ACCURACY C ETRIAL = B C CALL BASFUN(NBT,LC,NODE,RA,BSTO,ETRIAL,ZERO,ZERO) C IF(NBUG4.GT.0)WRITE(IWRITE,3010)NODE,NODES,BVALUE,EIGEN,ETRIAL GOTO 50 C ENDIF C 50 CONTINUE IF (NODE.EQ.NODES) GOTO 70 C C ALL IS WELL...EIGENVALUE FOUND WITH CORRECT NUMBER C OF NODES. C C INCORRECT NUMBER OF NODES.....GIVE UP C WRITE (IWRITE,3040) STOP 'INCORRECT NUMBER OF NODES' C 60 CONTINUE C C KAB FLAG FOR NEW SR.FINDEE C NODES = -9 C 70 RETURN C 3000 FORMAT ( A/' DEBUG FROM FINDER' A/' =================') 3010 FORMAT (' NODE=',I2,' NODES=',I3,' BVALUE=',1P,E11.4,' EIGEN=', A E13.6,' ETRIAL=',E13.6) 3020 FORMAT ( A/' STOP IN FINDER' B/' CANNOT FIND THE CORRECT NUMBER OF NODES') 3025 FORMAT (/' ERROR IN FINDER, DEL TOO SMALL') 3030 FORMAT (' ERROR IN ROOT...IFLAG =',I6) 3040 FORMAT ( A/' ERROR IN FINDER' B/' BASFUN ITERATION ENTERED BUT INCORRECT NUMBER OF NODES FOUND') END C C C SUBROUTINE GEN1BB IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C GENERATES AND STORES ALL THE BOUND-BOUND ONE ELECTRON INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /REL/IRELOP(3) C----------------------------------------------------------------------- IRK5 = 0 IRK9 = 0 DO 50 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) GOTO 50 IST1(L1) = IRK5 + 1 C C SET THE PRINCIPAL QUANTUM NUMBERS. C DO 40 N1 = MAXNC(L1) + 1,MAXHF DO 30 N2 = MAXNC(L1) + 1,N1 IRK5 = IRK5 + 1 IF (IRELOP(2).NE.0 .AND. L1.EQ.1) IRK9 = IRK9 + 1 IF (IRK9.GT.MX1BB .OR. IRK5.GT.MX1BB) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 30 CALL ONEELE(N1,L1,N2,L1,ALBVAL) ONEST1(IRK5) = ALBVAL C C EVALUATE THE MASS-CORRECTION TERM C IF (IRELOP(1).EQ.0) GOTO 10 CALL RMASS(N1,L1,N2,L1,RLBVAL) C IF(N2.EQ.N1) RLBVAL = ZERO !NRB RMASS1(IRK5) = RLBVAL C C EVALUATE THE ONE-BODY DARWIN TERM C 10 CONTINUE IF (IRELOP(2).EQ.0) GOTO 20 IF (L1.GT.1) GOTO 20 CALL RDAR(N1,L1,N2,L1,RLBVAL) C IF(N2.EQ.N1) RLBVAL = ZERO !NRB RDAR1(IRK9) = RLBVAL C C EVALUATE THE SPIN-ORBIT INTERACTION C 20 CONTINUE IF (IRELOP(3).EQ.0) GOTO 30 CALL SPNORB(N1,L1,N2,L1,RLBVAL) C IF(N2.EQ.N1) RLBVAL = ZERO !NRB RSPOR1(IRK5) = RLBVAL 30 CONTINUE 40 CONTINUE 50 CONTINUE C END C C C SUBROUTINE GEN1BC IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C GENERATES AND STORES ALL THE BOUND-CONTINUUM ONE ELECTRON C INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /REL/IRELOP(3) C----------------------------------------------------------------------- IRK6 = 0 IRK10 = 0 L = MIN(LRANG1,LRANG2) DO 50 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) GOTO 50 IST2(L1) = IRK6 + 1 C C SET THE PRINCIPAL QUANTUM NUMBER OF THE BOUND ORBITAL. C N1 = MAXNC(L1) + 1 DO 40 N1 = MAXNC(L1) + 1,MAXHF DO 30 N2 = 1,NRANG2 IRK6 = IRK6 + 1 IF (IRELOP(2).NE.0 .AND. L1.EQ.1) IRK10 = IRK10 + 1 IF (IRK10.GT.MX1BC) NBUG7 = 1 N3 = MAXHF + N2 IF (IRK6.GT.MX1BC) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 30 CALL ONEELE(N1,L1,N3,L1,ALBVAL) ONEST2(IRK6) = ALBVAL C C EVALUATE THE MASS-CORRECTION TERM. C IF (IRELOP(1).EQ.0) GOTO 10 CALL RMASS(N1,L1,N3,L1,RLBVAL) C IF(N3.EQ.N1) RLBVAL = ZERO !NRB RMASS2(IRK6) = RLBVAL C C EVALUATE THE ONE-BODY DARWIN TERM C 10 CONTINUE IF (IRELOP(2).EQ.0 .OR. L1.GT.1) GOTO 20 CALL RDAR(N1,L1,N3,L1,RLBVAL) C IF(N3.EQ.N1) RLBVAL = ZERO !NRB RDAR2(IRK10) = RLBVAL C C EVALUATE THE SPIN-ORBIT INTERACTION C 20 CONTINUE IF (IRELOP(3).EQ.0) GOTO 30 CALL SPNORB(N1,L1,N3,L1,RLBVAL) C IF(N3.EQ.N1) RLBVAL = ZERO !NRB RSPOR2(IRK6) = RLBVAL 30 CONTINUE 40 CONTINUE 50 CONTINUE C END C C C SUBROUTINE GEN1CC(L) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C GENERATES AND STORES ALL CONTINUUM-CONTINUUM ONE ELECTRON C INTEGRALS FOR THE ANGULAR MOMENTUM (L-1) C DIAGONAL RELATIVISTIC CORRECTIONS HAVE AN UNPHYSICALLY LARGE C EFFECT ON ELASTIC SCATTERING AND SOME WEAK INELASTIC TRANSITIONS C (PROBABLY DUE TO THE USE OF A NON-RELATIVISTIC BUTTLE CORRECTION) C SO SET TO ZERO FOR NOW, EXCEPT ISMITN.NE.0 - NRB. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) C PARAMETER (ZERO=0.0D0) C LOGICAL BZERO C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /REL/IRELOP(3) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN C----------------------------------------------------------------------- BZERO=ISMITN.EQ.0.OR.L.GT.LRANG1 IRK7 = 0 MAXHF = MAXNHF(L) DO 40 N1 = 1,NRANG2 N3 = MAXHF + N1 DO 30 N2 = 1,N1 IRK7 = IRK7 + 1 N4 = MAXHF + N2 IF (IRK7.GT.MX1CC) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 30 CALL ONEELE(N3,L,N4,L,ALBVAL) ONEST3(IRK7,L) = ALBVAL C C EVALUATE THE MASS-CORRECTION TERM C IF (IRELOP(1).EQ.0) GOTO 10 CALL RMASS(N3,L,N4,L,RLBVAL) IF(N3.EQ.N4.AND.BZERO) RLBVAL = ZERO !NRB RMASS3(IRK7,L) = RLBVAL C C EVALUATE THE ONE-BODY DARWIN TERM C 10 CONTINUE IF (IRELOP(2).EQ.0 .OR. L.GT.1) GOTO 20 CALL RDAR(N3,L,N4,L,RLBVAL) IF(N3.EQ.N4.AND.BZERO) RLBVAL = ZERO !NRB RDAR3(IRK7) = RLBVAL C C EVALUATE THE SPIN-ORBIT INTERACTION C 20 CONTINUE IF (IRELOP(3).EQ.0 .OR. L.EQ.1) GOTO 30 CALL SPNORB(N3,L,N4,L,RLBVAL) IF(N3.EQ.N4.AND.BZERO) RLBVAL = ZERO !NRB RSPOR3(IRK7,L) = RLBVAL 30 CONTINUE 40 CONTINUE C END C C C SUBROUTINE GENBB IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C GENERATES AND STORES ALL THE BOUND-BOUND RK INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc integer istat(MPI_STATUS_SIZE) c **** parallel **** C----------------------------------------------------------------------- C C ZEROIZE VARIABLES AND ARRAYS C IRK1 = 0 IRK4 = 0 I1 = LRANG1*LRANG1 DO 30 K = 1,I1 DO 20 J = 1,LRANG1 DO 10 I = 1,LRANG1 ICTBB(I,J,K) = 0 10 CONTINUE 20 CONTINUE 30 CONTINUE 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 40 CONTINUE IF (MAXNC(L1+1).EQ.MAXNHF(L1+1)) GOTO 180 L2 = L1 50 CONTINUE IF (MAXNC(L2+1).EQ.MAXNHF(L2+1)) GOTO 170 L3 = L1 60 CONTINUE IF (MAXNC(L3+1).EQ.MAXNHF(L3+1)) GOTO 160 L4 = MOD(L1+L2+L3,2) C C CHECK TRIANGULAR RELATIONS C 70 CONTINUE IF (MAXNC(L4+1).EQ.MAXNHF(L4+1)) GOTO 150 IF (L4.GE.L2) GOTO 80 L4 = L4 + 2 GOTO 70 C 80 CONTINUE IF (L4.GT.LRANG1-1) GOTO 160 C C SET THE VALUE OF LAMBDA C LAM = MAX(ABS(L1-L3),ABS(L2-L4)) IF (LAM.GT.L1+L3 .OR. LAM.GT.L2+L4) GOTO 150 IRK4 = IRK4 + 1 IF (IRK4.GT.MXIRK4) NBUG7 = 1 C C STORE LOCATION OF RK INTEGRALS IN ISTBB1 AND ISTBB2 C LP = L3*LRANG1 + L4 + 1 ICTBB(L1+1,L2+1,LP) = IRK4 90 CONTINUE IF (NBUG7.EQ.1) GOTO 100 ISTBB1(IRK4) = LAM ISTBB2(IRK4) = IRK1 + 1 C C SET AND INCREMENT THE INITIAL PRINCIPAL QUANTUM NUMBERS C 100 CONTINUE N3M = MAXNHF(L3+1) N4M = MAXNHF(L4+1) NST = MAXNHF(L2+1) DO 140 N1 = MAXNC(L1+1) + 1,MAXNHF(L1+1) IF (L2.EQ.L1) NST = N1 DO 130 N2 = MAXNC(L2+1) + 1,NST IF (L3.EQ.L1) N3M = N1 DO 120 N3 = MAXNC(L3+1) + 1,N3M IF (L4.EQ.L2) N4M = N2 DO 110 N4 = MAXNC(L4+1) + 1,N4M C C EVALUATE AND STORE AN RK INTEGRAL IN RKSTO1 C IRK1 = IRK1 + 1 IF (IRK1.GT.MXRKBB) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 110 CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,N4,L4+1,LAM,0,RKVAL) RKSTO1(IRK1) = RKVAL 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE C C INCREMENT THE VALUE OF LAMBDA C LAM = LAM + 2 IF (LAM.GT.L1+L3 .OR. LAM.GT.L2+L4) GOTO 150 IRK4 = IRK4 + 1 IF (IRK4.GT.MXIRK4) NBUG7 = 1 GOTO 90 C C INCREMENT THE ANGULAR MOMENTA C 150 CONTINUE L4 = L4 + 2 IF (L4.LE.LRANG1-1) GOTO 70 160 CONTINUE L3 = L3 + 1 IF (L3.LE.LRANG1-1) GOTO 60 170 CONTINUE L2 = L2 + 1 IF (L2.LE.LRANG1-1) GOTO 50 180 CONTINUE L1 = L1 + 1 IF (L1.LE.LRANG1-1) GOTO 40 C END SUBROUTINE GENBC IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C GENERATES AND STORES ALL THE BOUND CONTINUUM RK INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 c **** parallel **** include 'mpif.h' common /parablock/iam,nproc common/sizebcblock/irk2p common/totblock/testbc,testcc irk2p = irk2 c **** parallel **** C----------------------------------------------------------------------- C C ZEROIZE VARIABLES AND ARRAYS C IRK3 = 0 I1 = MIN(LRANG1*LRANG2,LRANG1* ((LRANG1-1)*3+1)) DO 30 K = 1,I1 DO 20 J = 1,LRANG1 DO 10 I = 1,LRANG1 ICTBC(I,J,K) = 0 10 CONTINUE 20 CONTINUE 30 CONTINUE 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 40 CONTINUE L1 = 0 50 CONTINUE IF (MAXNC(L1+1).EQ.MAXNHF(L1+1)) GOTO 170 L2 = 0 60 CONTINUE IF (MAXNC(L2+1).EQ.MAXNHF(L2+1)) GOTO 160 L3 = MOD(L+L1+L2,2) IF (L3.LT.L1) GOTO 150 C C SET THE INITIAL VALUE OF LAMBDA C 70 CONTINUE IF (MAXNC(L3+1).EQ.MAXNHF(L3+1)) GOTO 150 LAM = MAX(ABS(L-L2),ABS(L1-L3)) IF (LAM.GT.L+L2 .OR. LAM.GT.L1+L3) GOTO 150 IRK3 = IRK3 + 1 IF (IRK3.GT.MXIRK3) NBUG7 = 1 C C STORE THE LOCATION OF THE RK INTEGRALS IN ISTBC1 AND ISTBC2 C LP = LRANG1*L + L3 + 1 ICTBC(L1+1,L2+1,LP) = IRK3 80 CONTINUE IF (NBUG7.EQ.1) GOTO 90 ISTBC1(IRK3) = LAM ISTBC2(IRK3) = IRK2 + 1 C C SET AND INCREMENT THE INITIAL PRINCIPAL QUANTUM NUMBERS C 90 CONTINUE N3M = MAXNHF(L3+1) DO 130 N1 = MAXNC(L1+1) + 1,MAXNHF(L1+1) DO 120 N2 = MAXNC(L2+1) + 1,MAXNHF(L2+1) IF (L3.EQ.L1) N3M = N1 DO 110 N3 = MAXNC(L3+1) + 1,N3M DO 100 N = 1,NRANG2 C C CALCULATE AND STORE AN RK INTEGRAL IN RKSTO2 C IRK2 = IRK2 + 1 c **** parallel **** c....... calculation only for particular points iproc = mod(irk2-1,nproc) if (iproc.eq.iam) then irk2p = irk2p + 1 if (irk2p.gt.mxmem) nbug7 = 1 if (nbug7.eq.1) go to 100 CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,MAXNHF(L+1)+N,L+1, + LAM,0,RKVAL) RKSTO2(IRK2p) = RKVAL c................ test: bc contribution testbc = testbc + RKVAL endif c **** parallel **** 100 CONTINUE 110 CONTINUE 120 CONTINUE 130 CONTINUE C C INCREMENT THE VALUE OF LAMBDA C LAM = LAM + 2 IF (LAM.GT.L+L2 .OR. LAM.GT.L1+L3) GOTO 150 IRK3 = IRK3 + 1 IF (IRK3.GT.MXIRK3) NBUG7 = 1 GOTO 80 C 150 CONTINUE L3 = L3 + 2 C C INCREMENT THE ANGULAR MOMENTA C IF (L3.LE.LRANG1-1) GOTO 70 160 CONTINUE L2 = L2 + 1 IF (L2.LE.LRANG1-1) GOTO 60 170 CONTINUE L1 = L1 + 1 IF (L1.LE.LRANG1-1) GOTO 50 L = L + 1 IF (L.LE.3*LRANG1-3 .AND. L.LE.LRANG2-1) GOTO 40 C END SUBROUTINE GENCC(L,LP) IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C GENERATES AND STORES ALL THE CONTINUUM-CONTINUUM RK INTEGRALS C WITH CONTINUUM ANGULAR MOMENTA L AND LP C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /LSTORE/LOOPCC COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /DW/IDWOUT,LNOEX C SAVE KMAXEX, TEST DATA KMAXEX/MXCTCC/, TEST/1.0D+30/ c **** parallel **** include 'mpif.h' common /parablock/iam,nproc common/sizebcblock/irk2p common/totblock/testbc,testcc irk2p = irk2 c **** parallel **** C----------------------------------------------------------------------- C KMAXEX=MIN(KMAXEX,LNOEX) C C CHECK FOR INACCURATE AND MEANINGLESS EXCHANGE RK INTEGRALS AT HIGH L. C COLD (NO LONGER THE CASE/NEEDED) C DETERMINE KMAXEX = HIGHEST LAM (POWER OF R IN RK INTEGRAL) C FOR WHICH EXCHANGE INTEGRAL IS ACCURATE. C A PROBLEM ONLY ARISES FOR HIGH K, WHERE THE INTEGRAL MAY C INCREASE UNEXPECTEDLY WITH K. THIS IS DUE TO INHERENT C INSTABILITY IN THE ALGORITHM IN SUBROUTINE RS C (IE. IS NOT AFFECTED BY MESH). IN PRACTICE, THIS ONLY AFFECTS C THE EXCHANGE INTEGRALS AT HIGH L, WHICH SHOULD VANISH ANYWAY. C NRB: HAVE SEEN CASES WHERE NEED TO TEST EARLIER THAN 20, SO ->14 C IF (L.EQ.LP.AND.L+LRANG1.GE.14.AND.L-LRANG1.LE.LNOEX) THEN L1=LRANG1-1 LAM=L+L1 CALL RS(MAXNHF(L+1)+NRANG2,L+1,MAXNHF(L1+1),L1+1, A MAXNHF(L1+1),L1+1,MAXNHF(LP+1)+NRANG2,LP+1,LAM,0,RKVAL) WRITE(IWRITE,*)' TEST: L,LP=',L,LP,' K=',LAM,' RKVAL=',RKVAL ckab delete the following c IF (KMAXEX.EQ.MXCTCC.AND.ABS(RKVAL).GT.2*TEST) THEN c KMAXEX=LAM-1 c WRITE(IWRITE,*)'WARNING *** EXCHANGE OFF FOR K>',KMAXEX c ENDIF ckab TEST=ABS(RKVAL) ENDIF C C C ZEROIZE VARIABLES AND ARRAYS C LOOP = 0 I1 = MIN(2*LRANG1-1,L+LP+1) I2 = MIN(LRANG1+L,LRANG1+LP) DO 40 I = 1,LRANG1 DO 30 J = 1,LRANG1 DO 10 K = 1,I1 ICTCCD(I,J,K) = 0 10 CONTINUE DO 20 K = 1,I2 ICTCCE(I,J,K) = 0 20 CONTINUE 30 CONTINUE 40 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) 50 CONTINUE L1 = 0 60 CONTINUE IF (MAXNC(L1+1).EQ.MAXNHF(L1+1)) GOTO 80 L1P = ABS(L1-LAM) 70 CONTINUE IF (L1P.LT.L1) GOTO 160 IF (L1P.LE.L1+LAM .AND. L1P.LE.LRANG1-1) GOTO 100 C C INCREMENT THE LAMBDA VALUE AND THE ANGULAR MOMENTA FOR THE C DIRECT INTEGRAL C 80 CONTINUE L1 = L1 + 1 IF (L1.LE.LRANG1-1) GOTO 60 LAM = LAM + 2 IF (LAM.LE.L+LP .AND. LAM.LE.2*LRANG1-2) GOTO 50 GOTO 170 C C STORE THE LOCATION OF THE DIRECT R-K INTEGRALS IN ICTCCD C 100 CONTINUE IF (MAXNC(L1P+1).EQ.MAXNHF(L1P+1)) GOTO 160 ICTCCD(L1+1,L1P+1,LAM+1) = IRK2 + 1 + LOOP*MXMEM C C SET AND INCREMENT THE INITIAL PRINCIPAL QUANTUM NUMBERS FOR C BOTH THE DIRECT AND THE EXCHANGE INTEGRALS C 110 CONTINUE N1PM = MAXNHF(L1P+1) NST = NRANG2 DO 150 N1 = MAXNC(L1+1) + 1,MAXNHF(L1+1) IF (IT.EQ.0 .AND. L1P.EQ.L1) N1PM = N1 DO 140 N1P = MAXNC(L1P+1) + 1,N1PM DO 130 N = 1,NRANG2 IF (L.EQ.LP) NST = N DO 120 NP = 1,NST C C CALCULATES AND STORES EITHER A DIRECT OR AN EXCHANGE RK C INTEGRAL C IRK2 = IRK2 + 1 c **** parallel **** iproc = mod(irk2-1,nproc) c...............calculation only for particular points if (iproc.ne.iam) go to 120 irk2p = irk2p + 1 IF (NBUG7.EQ.1) GOTO 120 IF (IRK2p.GT.MXMEM) THEN c............... for safety nbug7=1 nbug7 = 1 IRK2 = 1 irk2p = 1 c **** parallel **** LOOP = LOOP + 1 IF (LOOP.LT.LOOPCC) GOTO 120 IF (LOOP.GT.LOOPCC) GOTO 230 ENDIF C IF (IT.EQ.0) THEN CALL RS(N1,L1+1,MAXNHF(L+1)+N,L+1,N1P,L1P+1, A MAXNHF(LP+1)+NP,LP+1,LAM,0,RKVAL) c **** parallel **** RKSTO2(IRK2p) = RKVAL c............... test: cc contribution testcc = testcc + RKVAL c **** parallel **** ELSE C C SWITCH OFF EXCHANGE INTEGRALS FOR HIGH LAM, either because c inaccurate (much less likely now with kab's mod) or because user c has requested it (via LNOEX) since they are small. c And, ONLY if LNOEX is used, do not increment storage. C c **** parallel **** c RKSTO2(IRK2) = 0.0D0 RKSTO2(IRK2p) = 0.0D0 c **** parallel **** IF(LAM.GT.KMAXEX) GO TO 120 CALL RS(MAXNHF(L+1)+N,L+1,N1,L1+1,N1P,L1P+1, A MAXNHF(LP+1)+NP,LP+1,LAM,0,RKVAL) c **** parallel **** RKSTO2(IRK2p) = RKVAL c............... test: cc contribution testcc = testcc + RKVAL c **** parallel **** ENDIF C 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE L1P = L1P + 2 IF (IT.EQ.0) GOTO 70 GOTO 200 C C SET THE INITIAL VALUE OF LAMBDA AND ANGULAR MOMENTA FOR THE C EXCHANGE INTEGRAL C 170 CONTINUE IT = 1 LAM = 0 180 CONTINUE L1 = ABS(LP-LAM) 190 CONTINUE IF (L1.GT.LP+LAM .OR. L1.GT.LRANG1-1) GOTO 220 IF (MAXNC(L1+1).EQ.MAXNHF(L1+1)) GOTO 210 L1P = ABS(L-LAM) 200 CONTINUE IF (L1P.GT.L+LAM .OR. L1P.GT.LRANG1-1) GOTO 210 C C STORE THE LOCATION OF THE EXCHANGE RK INTEGRALS IN ICTCCE C IF (MAXNC(L1P+1).EQ.MAXNHF(L1P+1)) GOTO 160 if(lam.gt.kmaxex.and.kmaxex.eq.lnoex)go to 160 ICTCCE(L1+1,L1P+1,LAM+1) = IRK2 + 1 + LOOP*MXMEM GOTO 110 C C INCREMENT THE LAMBDA VALUE AND THE ANGULAR MOMENTA FOR THE C EXCHANGE INTEGRAL C 210 CONTINUE L1 = L1 + 2 GOTO 190 C 220 CONTINUE LAM = LAM + 1 IF (LAM.LE.LRANG1-1+MIN(L,LP)) GOTO 180 GOTO 240 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 230 CONTINUE IRK2 = -irk2 IRK2p = -MXMEM 240 CONTINUE C END SUBROUTINE GENINT IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALLS THE ROUTINES WHICH EVALUATE ALL THE MULTIPOLE INTEGRALS, C ONE ELECTRON AND R-K INTEGRALS. C THE INTEGRALS ARE WRITTEN ONTO ITAPE3. C C NBUG7=1 CORRESPONDS TO A DIMENSION TEST RUN ONLY. C C NBUG8=1 FOR PRINTOUT OF BOUND-BOUND INTEGRALS; C =2 AS FOR 1, TOGETHER WITH BOUND-CONTINUUM INTEGRALS; C =3 AS FOR 2, TOGETHER WITH CONTINUUM-CONTINUUM INTEGRALS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXICT=4*MZLR1*MZLR1*MZLR1*MZLR2*MZLR2) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) PARAMETER (MXBBI=MXORB*MXORB/2*MZLMX+MXORB*MZLMX) PARAMETER (MXPOL= (MZLMX+1)/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /COPY/ITOTAL,ICOUNT COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /INSTO5/BBINT(MXBBI),IBBI COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /LSTORE/LOOPCC COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /RKSAVE/IRKBC,IRKCC(MZLR2,MZLR2,2),ICHUNK,ICT(MXICT),ITAPBC COMMON /YKSTOR/YK(MZNPT),TEST1 C PARAMETER (ZERO=0.0D0) c **** parallel **** include 'mpif.h' common/parablock/iam,nproc common/sizebcblock/irk2p common/totblock/testbc,testcc c **** parallel **** C----------------------------------------------------------------------- C C ITOTAL = TOTAL NUMBER OF DATA BLOCKS REQUIRED ON ITAPE3. C C ICOUNT IS A COUNT ON THE INTEGRAL BLOCKS ON FILE C C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM FILE, CALL RECOV2 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C C----------------------------------------------------------------------- IF (ITOTAL.LE.0 .AND. NBUG7.NE.1) RETURN C ICOUNT = 1 IPLACE = 0 WRITE (IWRITE,3000) C C INITIALIZE DA FILE FOR INTEGRAL STORAGE C IREC1 = 0 C IREC2 = 1 TEST1 = ZERO c **** parallel **** testbc = zero testcc = zero c **** parallel **** C C ---- GENERATE THE BOUND-BOUND, BOUND-CONTINUUM AND CONTINUUM-CONTINUUM C MULTIPOLE INTEGRALS. SET NBUG7=1 IF ARRAY DIMENSIONS ARE EXCEEDED C INBUG7 = NBUG7 WRITE (IWRITE,3010) JRK8 = 0 LAMIND = (LAMAX+1)/2 IF (LAMAX.GT.0) WRITE (IWRITE,3020) IRK8 = 0 CALL GENMBB IBBI = IRK8 IF (LAMBC.GT.0) WRITE (IWRITE,3030) CALL GENMBC IBCI = IRK8 JBCI = JRK8 IF (LAMCC.GT.0) WRITE (IWRITE,3040) CALL GENMCC IF (NBUG7.NE.1) WRITE (IWRITE,3260) TEST1 TEST1 = ZERO c **** parallel **** testbc = zero testcc = zero c **** parallel **** COUNT = IRK8 MAXRK = IRK8 C C WRITE OUT ALL THE MULTIPOLE INTEGRALS ON TAPE UNLESS NBUG7=1 C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3050) IRK8,MXMEM WRITE (IWRITE,3240) JRK8,MXSK2 GOTO 70 ENDIF C WRITE (ITAPE3) IRK8,JRK8,IBBI WRITE (IWRITE,*) 'IRK8=',IRK8 IF (IRK8.LE.0) GOTO 50 WRITE (ITAPE3) (((IBBPOL(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1, A LAMIND), (((IBCPOL(I,J,K),I=1,LRANG1),J=1,LRANG2),K=1,LAMIND), B (((ICCPOL(I,J,K),I=1,LRANG2),J=1,LRANG2),K=1,LAMIND), C (RKSTO2(I),I=1,IRK8) C C COPY BOUND-BOUND MULTIPOLE INTEGRALS TO BBINT C IF (IBBI.GT.MXBBI) CALL RECOV2('GENINT','MXBBI ',MXBBI,IBBI) DO 40 I = 1,IBBI BBINT(I) = RKSTO2(I) 40 CONTINUE C IF (NBUG8.GE.1) THEN WRITE (IWRITE,3270) (((IBBPOL(I,J,K),I=1,LRANG1),J=1,LRANG1), A K=1,LAMIND) WRITE (IWRITE,3250) (RKSTO2(I),I=1,IBBI) ENDIF C IF (NBUG8.GE.2) THEN WRITE (IWRITE,3290) (((IBCPOL(I,J,K),I=1,LRANG1),J=1,LRANG2), A K=1,LAMIND) WRITE (IWRITE,3250) (RKSTO2(I),I=IBBI+1,IBCI) ENDIF C IF (NBUG8.GE.3) THEN WRITE (IWRITE,3300) (((ICCPOL(I,J,K),I=1,LRANG2),J=1,LRANG2), A K=1,LAMIND) WRITE (IWRITE,3250) (RKSTO2(I),I=IBCI+1,IRK8) ENDIF C 50 CONTINUE WRITE (IWRITE,3200) ICOUNT C C MODIFICATION TO INCLUDE BLOCK NUMBER 1+1/2 FOR BUTTLE TYPE C POINTERS AND DIPOLE INTEGRALS C IF (JRK8.EQ.0) GOTO 60 WRITE (ITAPE3) ((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2), A ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2), (SKSTO2(J),J=1,JRK8), B (BNORM(J),J=1,LRANG2) WRITE (IWRITE,*) ' TAPE POSITION 1+1/2 HAS BEEN REACHED' C IF (NBUG8.GE.2) THEN WRITE (IWRITE,3320) ((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2) WRITE (IWRITE,3250) (SKSTO2(I),I=1,JBCI) ENDIF C IF (NBUG8.GE.3) THEN WRITE (IWRITE,3330) ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2) WRITE (IWRITE,3250) (SKSTO2(I),I=JBCI+1,JRK8) WRITE (IWRITE,3250) (BNORM(I),I=1,LRANG2) ENDIF C 60 CONTINUE IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 C C ---- GENERATE THE BOUND BOUND ONE ELECTRON INTEGRALS AND STORE ON TAPE C SET NBUG7=1 IF ARRAY DIMENSIONS ARE EXCEEDED C 70 CONTINUE WRITE (IWRITE,3060) CALL GEN1BB C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3070) IRK5,MX1BB WRITE (IWRITE,3220) IRK9,MX1BB GOTO 110 ENDIF C WRITE(IWRITE,3065)IRK5,IRK9 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).GT.0) THEN WRITE (ITAPE3) IRK9 WRITE (ITAPE3) (RDAR1(I),I=1,IRK9) ENDIF C IF (NBUG8.GE.1) THEN WRITE (IWRITE,3280) IRK5 WRITE (IWRITE,3280) (IST1(I),I=1,LRANG1) WRITE (IWRITE,3310) (ONEST1(I),I=1,IRK5) IF (IRELOP(1).GT.0) WRITE (IWRITE,3310) (RMASS1(I),I=1,IRK5) IF (IRELOP(3).GT.0) WRITE (IWRITE,3310) (RSPOR1(I),I=1,IRK5) IF (IRELOP(2).GT.0) WRITE (IWRITE,3350) IRK9 IF (IRELOP(2).GT.0) WRITE (IWRITE,3310) (RDAR1(I),I=1,IRK9) ENDIF C WRITE (IWRITE,3200) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 C C ---- GENERATE THE BOUND CONTINUUM ONE ELECTRON INTEGRALS AND STORE C ON TAPE. SET NBUG7=1 IF ARRAY DIMENSIONS ARE EXCEEDED C 110 CONTINUE WRITE (IWRITE,3080) CALL GEN1BC C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3090) IRK6,MX1BC WRITE (IWRITE,3230) IRK10,MX1BC GOTO 150 ENDIF C WRITE(IWRITE,3085)IRK6,IRK10 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).GT.0) THEN WRITE (ITAPE3) IRK10 WRITE (ITAPE3) (RDAR2(I),I=1,IRK10) ENDIF C IF (NBUG8.GE.2) THEN WRITE (IWRITE,3280) IRK6 WRITE (IWRITE,3280) (IST2(I),I=1,LRANG1) WRITE (IWRITE,3310) (ONEST2(I),I=1,IRK6) IF (IRELOP(1).GT.0) WRITE (IWRITE,3310) (RMASS2(I),I=1,IRK6) IF (IRELOP(3).GT.0) WRITE (IWRITE,3310) (RSPOR2(I),I=1,IRK6) IF (IRELOP(2).GT.0) WRITE (IWRITE,3350) IRK10 IF (IRELOP(2).GT.0) WRITE (IWRITE,3310) (RDAR2(I),I=1,IRK10) ENDIF C WRITE (IWRITE,3200) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 C C ---- GENERATE THE CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS AND C STORE ON TAPE. SET NBUG7=1 IF ARRAY DIMENSIONS ARE EXCEEDED C 150 CONTINUE C WRITE (IWRITE,3100) C DO 180 L = 1,LRANG2 L1 = L - 1 CALL GEN1CC(L) C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3110) IRK7,L1,MX1CC GOTO 180 ENDIF C WRITE (IWRITE,3180) IRK7,L1 WRITE (ITAPE3) IRK7 WRITE (ITAPE3) (ONEST3(I,L),I=1,IRK7) IF (IRELOP(1).GT.0) WRITE (ITAPE3) (RMASS3(I,L),I=1,IRK7) IF (IRELOP(3).GT.0 .AND. L.GT.1) WRITE (ITAPE3) (RSPOR3(I,L), A I=1,IRK7) IF (IRELOP(2).GT.0 .AND. L.EQ.1) WRITE (ITAPE3) (RDAR3(I),I=1, A IRK7) C IF (NBUG8.GE.3) THEN WRITE (IWRITE,3360) L1,IRK7 WRITE (IWRITE,3310) (ONEST3(I,L),I=1,IRK7) IF (IRELOP(1).GT.0) WRITE (IWRITE,3310) (RMASS3(I,L),I=1,IRK7) IF (IRELOP(3).GT.0 .AND. L1.NE.0) WRITE (IWRITE, A 3310) (RSPOR3(I,L),I=1,IRK7) IF (IRELOP(2).GT.0 .AND. L1.EQ.0) WRITE (IWRITE, A 3310) (RDAR3(I),I=1,IRK7) ENDIF C 180 CONTINUE C IF (NBUG7.EQ.1) GOTO 190 C WRITE (IWRITE,3260) TEST1 TEST1 = ZERO c **** parallel **** testbc = zero testcc = zero c **** parallel **** WRITE (IWRITE,3200) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 C C ---- GENERATE THE BOUND-BOUND RK INTEGRALS AND STORE ON TAPE C SET NBUG7=1 IF ARRAY DIMENSIONS ARE EXCEEDED C 190 CONTINUE WRITE (IWRITE,3120) I1 = LRANG1*LRANG1 CALL GENBB C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3130) IRK1,MXRKBB,IRK4,MXIRK4 GOTO 240 ENDIF C WRITE(IWRITE,3135)IRK1,IRK4 C WRITE (ITAPE3) IRK1,IRK4 WRITE (ITAPE3) (((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), A (ISTBB1(I),I=1,IRK4), (ISTBB2(I),I=1,IRK4), (RKSTO1(I),I=1,IRK1) C IF (NBUG8.GE.1) THEN WRITE (IWRITE,3280) IRK1,IRK4 WRITE (IWRITE,3280) (((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1, A I1), (ISTBB1(I),I=1,IRK4), (ISTBB2(I),I=1,IRK4) WRITE (IWRITE,3310) (RKSTO1(I),I=1,IRK1) ENDIF C WRITE (IWRITE,3200) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 C C ---- GENERATE THE BOUND-CONTINUUM RK INTEGRALS AND STORE ON TAPE C SET NBUG7=1 IF ARRAY DIMENSIONS ARE EXCEEDED C 240 CONTINUE IF (LRANG2.EQ.0) GOTO 440 WRITE (IWRITE,3140) I1 = MIN(LRANG1*LRANG2,LRANG1* ((LRANG1-1)*3+1)) IRK2 = MEM1 CALL GENBC IRK2 = IRK2 - MEM1 COUNT = COUNT + IRK2p - MEM1 MAXRK = MAX(MAXRK,IRK2p) C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3150) IRK2p,MXMEM,IRK3,MXIRK3 GOTO 280 ENDIF C WRITE(IWRITE,3155)IRK2p,IRK3 C if (iam.eq.0) then WRITE (ITAPE3) IRK2,IRK3 WRITE (ITAPE3) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), A (ISTBC1(I),I=1,IRK3), (ISTBC2(I),I=1,IRK3) endif c **** parallel **** CALL DA2(2,IREC1,JDISC1,irk2p,RKSTO2) c **** parallel **** C IF (NBUG8.GE.2) THEN WRITE (IWRITE,3280) IRK2p,IRK3 WRITE (IWRITE,3280) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1, A I1), (ISTBC1(I),I=1,IRK3), (ISTBC2(I),I=1,IRK3) WRITE (IWRITE,3310) (RKSTO2(I),I=1,IRK2) ENDIF C WRITE (IWRITE,3200) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 C C ---- ENTER LOOP TO GENERATE ALL THE NON-ZERO CONTINUUM-CONTINUUM C RK INTEGRALS FOR EACH CONTINUUM ANGULAR MOMENTUM L AND LP AND C STORE ON TAPE. C C IF THE NUMBER OF INTEGRALS IRK2 TO BE STORED IN THE RKSTO2 ARRAY C FOR A GIVEN L AND LP COMBINATION EXCEEDS MXMEM, THE SIZE C OF RKSTO2, THEN IRK2 IS SET EQUAL TO -MXMEM AND WRITTEN OUT C WITH THE FIRST MXMEM INTEGRALS. THE RKSTO2 ARRAY IS THEN C OVERWRITTEN WITH FURTHER INTEGRALS FOR THE L AND LP COMBINATION. C C LOOPCC IS THE NUMBER OF TIMES THE RKSTO2 ARRAY IS OVERWRITTEN. C 280 CONTINUE L = 0 LP = 0 LOOPCC = 0 WRITE (IWRITE,3160) I22 = 0 I3 = 0 C 290 CONTINUE C C IF (NBUG7.EQ.1) GOTO 310 C I1 = MIN(2*LRANG1-1,L+LP+1) I2 = MIN(LRANG1+L,LRANG1+LP) I12 = (I1+I2)*LRANG1*LRANG1 IF (I3+I12.GT.MXICT) NBUG7 = 1 C 300 CONTINUE TEST1 = ZERO c **** parallel **** testbc = zero testcc = zero c **** parallel **** IRK2 = MEM1 C C 310 CONTINUE C CALL GENCC(L,LP) JRK2 = IRK2 IRK2 = ABS(JRK2) - MEM1 COUNT = COUNT + abs(IRK2p) I22 = I22 + abs(IRK2p) MAXRK = MAX(MAXRK,I22) C IF (JRK2.GT.0) THEN C I3 = 0 C DO 340 K = 1,I1 DO 330 J = 1,LRANG1 DO 320 I = 1,LRANG1 ICT(I3+I) = ICTCCD(I,J,K) 320 CONTINUE I3 = I3 + LRANG1 330 CONTINUE 340 CONTINUE C ID=I3 IF (NBUG8.GE.3) WRITE (IWRITE,3340) L,LP, (ICT(K),K=1,ID) C DO 370 K = 1,I2 DO 360 J = 1,LRANG1 DO 350 I = 1,LRANG1 ICT(I3+I) = ICTCCE(I,J,K) 350 CONTINUE I3 = I3 + LRANG1 360 CONTINUE 370 CONTINUE C IF (NBUG8.GE.3) WRITE (IWRITE,3340) L,LP, (ICT(K),K=ID+1,I12) C ENDIF C IF (NBUG7.EQ.1) THEN WRITE (IWRITE,3170) IRK2p,L,LP,MXMEM GOTO 420 ENDIF C WRITE (IWRITE,3190) IRK2p,L,LP if (iam.eq.0) WRITE (ITAPE3) JRK2,L,LP IF (JRK2.EQ.0) GOTO 400 IF (JRK2.GT.0.and.iam.eq.0) WRITE (ITAPE3) (ICT(K),K=1,I12) c **** parallel **** CALL DA2(2,IREC1,JDISC1,irk2p,RKSTO2) c **** parallel **** C IF (NBUG8.GE.3) WRITE (IWRITE,3310) (RKSTO2(I),I=1,IRK2) 400 CONTINUE WRITE (IWRITE,3200) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 440 ICOUNT = ICOUNT + 1 LOOPCC = LOOPCC + 1 IF (JRK2.LT.0) GOTO 290 LOOPCC = 0 420 CONTINUE I22 = 0 IF (JRK2.EQ.0 .AND. ICHECK.EQ.0) GOTO 430 LP = LP + 1 IF (LP.LT.LRANG2) GOTO 290 430 CONTINUE L = L + 1 LP = L IF (L.LT.LRANG2) GOTO 290 c **** parallel **** c IF (NBUG7.NE.1) WRITE (IWRITE,3260) TEST1 call mpi_allreduce(testbc,testbct,1,mpi_real8,mpi_sum, 1 mpi_comm_world,ierr) call mpi_allreduce(testcc,testcct,1,mpi_real8,mpi_sum, 1 mpi_comm_world,ierr) IF (NBUG7.NE.1) WRITE (IWRITE,3260) testbct+testcct c **** parallel **** NEED = 1 + (MAXRK-1)/1000 WRITE (IWRITE,*) ' MINIMUM SPACE FOR ONE BLOCK OF INTEGRALS =', A NEED, ' KWORDS' NEED = 1 + (NINT(COUNT)-1)/1000 WRITE (IWRITE,*) ' MAXIMUM SPACE FOR RK FILE =',NEED,' KWORDS' IF (I3.GT.MXICT) CALL RECOV2('GENINT','MXICT ',MXICT,I3) C C INTEGRAL EVALUATION IS COMPLETE C 440 CONTINUE IF (NBUG7.NE.INBUG7) IPLACE = 1 IF (NBUG7.EQ.1) RETURN REWIND ITAPE3 WRITE (IWRITE,3210) C 3000 FORMAT (//30X,'SUBROUTINE GENINT'/30X,17 ('-')) 3010 FORMAT (' GENERATE THE MULTIPOLE INTEGRALS') 3020 FORMAT (' GENERATE THE BOUND-BOUND MULTIPOLE INTEGRALS') 3030 FORMAT (' GENERATE THE BOUND-CONTINUUM MULTIPOLE INTEGRALS') 3040 FORMAT (' GENERATE THE CONTINUUM-CONTINUUM MULTIPOLE INTEGRALS') 3050 FORMAT (' IRK8=',I9,17X,'CURRENT ARRAY SIZE IS GIVEN BY MXMEM=', A I9) 3060 FORMAT (' GENERATE THE BOUND-BOUND ONE ELECTRON INTEGRALS') 3065 FORMAT(' IRK5=',I5,3X,'IRK9=',I5) 3070 FORMAT (' IRK5=',I5,19X,'CURRENT ARRAY SIZE IS GIVEN BY MX1BB=', A I5) 3080 FORMAT (' GENERATE THE BOUND-CONTINUUM ONE ELECTRON INTEGRALS') 3085 FORMAT(' IRK6=',I5,3X,'IRK10=',I5) 3090 FORMAT (' IRK6=',I5,19X,'CURRENT ARRAY SIZE IS GIVEN BY MX1BC=', A I5) 3100 FORMAT (' GENERATE CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS') 3110 FORMAT (' IRK7=',I5,' L=',I5,11X, A 'CURRENT ARRAY SIZE IS GIVEN BY MX1CC=',I5) 3120 FORMAT (' GENERATE THE BOUND-BOUND RK INTEGRALS') 3130 FORMAT (' IRK1=',I9,19X,'CURRENT ARRAY SIZE IS GIVEN BY MXRKBB=', A I9/' IRK4=',I5,51X,'MXIRK4=',I5) 3135 FORMAT(' IRK1=',I9,3X,'IRK4=',I5) 3140 FORMAT (' GENERATE THE BOUND-CONTINUUM RK INTEGRALS') 3150 FORMAT (' IRK2=',I9,17X,'CURRENT ARRAY SIZE IS GIVEN BY MXMEM=', A I9/' IRK3=',I5,51X,'MXIRK3=',I5) 3155 FORMAT(' IRK2=',I9,3X,'IRK3=',I5) 3160 FORMAT (' GENERATE THE CONTINUUM-CONTINUUM RK INTEGRALS') 3170 FORMAT (' IRK2=',I9,' L=',I5,' LP=',I5,8X, A 'ARRAY SIZE IS GIVEN BY MXMEM=',I9) 3180 FORMAT (' IRK7=',I6,' L=',I3) 3190 FORMAT (' IRK2=',I9,' L=',I3,' LP=',I3) 3200 FORMAT (' FILE POSITION',I3,' HAS BEEN REACHED') 3210 FORMAT (//' WRITE TO FILE COMPLETED') 3220 FORMAT (' IRK9=',I5,19X,'CURRENT ARRAY SIZE IS GIVEN BY MX1BB=', A I5) 3230 FORMAT (' IRK10=',I5,18X,'CURRENT ARRAY SIZE IS GIVEN BY MX1BC=', A I5) 3240 FORMAT (' JRK8=',I5,18X,'CURRENT ARRAY SIZE IS GIVEN BY MXSK2=', A I5) 3250 FORMAT (1P,8E15.7) 3260 FORMAT (' INTEGRAL SUM =',E20.8) 3270 FORMAT (/' IBBPOL'/ (16I5)) 3280 FORMAT (10I5) 3290 FORMAT (/' IBCPOL'/ (16I5)) 3300 FORMAT (/' ICCPOL'/ (16I5)) 3310 FORMAT (/ (5F14.7)) 3320 FORMAT (/' JBCPOL'/ (16I5)) 3330 FORMAT (/' JCCPOL'/ (16I5)) 3340 FORMAT (/' L=',I3,' LP=',I3/ (10I5)) 3350 FORMAT (/I5,' DARWIN TERMS:') 3360 FORMAT (//' L=',I3,' IRK7=',I5) END SUBROUTINE GENMBB IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C GENERATES ALL THE BOUND-BOUND MULTIPOLE INTEGRALS INCLUDING C BUTTLE CORRECTION TYPE DIPOLE INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXPOL= (MZLMX+1)/2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C----------------------------------------------------------------------- C C ZEROIZE ARRAYS C DO 30 K = 1,LAMIND DO 20 J = 1,LRANG1 DO 10 I = 1,LRANG1 IBBPOL(I,J,K) = 0 10 CONTINUE 20 CONTINUE 30 CONTINUE IF (LAMAX.EQ.0) RETURN C C LOOP OVER ANGULAR MOMENTA L1, L2; AND FOR EACH POSSIBLE C LM0, LOOP OVER PRINCIPLE QUANTUM NUMBERS N1, N2. C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C DO 80 L1 = 1,LRANG1 IF (MAXNC(L1).EQ.MAXNHF(L1)) GOTO 80 DO 70 L2 = L1,LRANG1 NST = MAXNHF(L2) IF (MAXNC(L2).EQ.NST) GOTO 70 LAMST = 0 LAM1 = L2 - L1 IF (LAM1.GT.MIN(LAMAX,L1+L2-2)) GOTO 70 C DO 60 LM0 = LAM1,MIN(LAMAX,L1+L2-2),2 IF (LM0.EQ.0) GOTO 60 LAMST = LAMST + 1 IBBPOL(L1,L2,LAMST) = IRK8 + 1 C DO 50 N1 = MAXNC(L1) + 1,MAXNHF(L1) IF (L1.EQ.L2) NST = N1 C DO 40 N2 = MAXNC(L2) + 1,NST IRK8 = IRK8 + 1 IF (IRK8.GE.MXMEM) NBUG7 = 1 IF (NBUG7.NE.1) THEN CALL RADINT(N1,L1,N2,L2,LM0,X1) RKSTO2(IRK8) = X1 IF (LM0.EQ.1) THEN IRK8 = IRK8 + 1 CALL DERINT(N1,L1,N2,L2,X1) RKSTO2(IRK8) = X1 ENDIF C ELSE IF (LM0.EQ.1) THEN IRK8 = IRK8 + 1 ENDIF C 40 CONTINUE 50 CONTINUE C 60 CONTINUE 70 CONTINUE 80 CONTINUE C END SUBROUTINE GENMBC IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C EVALUATES ALL THE BOUND-CONTINUUM MULTIPOLE INTEGRALS C INCLUDING BUTTLE CORRECTION TYPE DIPOLE INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXPOL= (MZLMX+1)/2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /NRBDIP/LRANGD C----------------------------------------------------------------------- C C ZEROIZE ARRAYS C DO 30 K = 1,LAMIND DO 20 J = 1,LRANG2 DO 10 I = 1,LRANG1 IBCPOL(I,J,K) = 0 10 CONTINUE 20 CONTINUE 30 CONTINUE IF (LAMBC.EQ.0) GOTO 110 C DO 50 J = 1,LRANG2 DO 40 I = 1,LRANG1 JBCPOL(I,J) = 0 40 CONTINUE 50 CONTINUE C C LOOP OVER ANGULAR MOMENTA L1, L2; AND FOR EACH POSSIBLE LM0, C LOOP OVER PRINCIPLE QUANTUM NUMBERS N1, N2. C C CHECK THERE IS A VALENCE ORBITAL FOR THESE ANGULAR MOMENTA C DO 100 L2 = 1,LRANGD DO 90 L1 = 1,LRANG1 IF (MAXNC(L1).EQ.MAXNHF(L1)) GOTO 90 LAMST = 0 LAM1 = ABS(L1-L2) IF (LAM1.EQ.1) JBCPOL(L1,L2) = JRK8 + 1 IF (LAM1.GT.MIN(LAMBC,L1+L2-1)) GOTO 90 C DO 80 LM0 = LAM1,MIN(LAMBC,L1+L2-1),2 IF (LM0.EQ.0) GOTO 80 LAMST = LAMST + 1 IBCPOL(L1,L2,LAMST) = IRK8 + 1 C DO 70 N1 = MAXNC(L1) + 1,MAXNHF(L1) DO 60 N2 = 1,NRANG2 N3 = MAXNHF(L2) + N2 IRK8 = IRK8 + 1 IF (IRK8.GE.MXMEM) NBUG7 = 1 IF (NBUG7.NE.1) THEN CALL RADINT(N1,L1,N3,L2,LM0,X1) RKSTO2(IRK8) = X1 IF (LM0.EQ.1) THEN IRK8 = IRK8 + 1 CALL DERINT(N1,L1,N3,L2,X1) RKSTO2(IRK8) = X1 ENDIF C ELSE IF (LM0.EQ.1) THEN IRK8 = IRK8 + 1 ENDIF C 60 CONTINUE C IF (LM0.NE.1) GOTO 70 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.MXSK2) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 70 N3 = N3 + 1 CALL RADINT(N1,L1,N3,L2,LM0,X1) SKSTO2(JRK8-1) = X1 CALL DERINT(N1,L1,N3,L2,X1) SKSTO2(JRK8) = X1 70 CONTINUE 80 CONTINUE C 90 CONTINUE 100 CONTINUE C 110 CONTINUE C END SUBROUTINE GENMCC IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C GENERATES ALL THE CONTINUUM-CONTINUUM MULTIPOLE INTEGRALS C INCLUDING BUTTLE CORRECTION TYPE DIPOLE INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXPOL= (MZLMX+1)/2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) PARAMETER (MWK=MZNR2*2) C DIMENSION WKSP(MWK) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /NRBDIP/LRANGD C----------------------------------------------------------------------- C C ZEROIZE ARRAYS C DO 30 K = 1,LAMIND DO 20 J = 1,LRANG2 DO 10 I = 1,LRANG2 ICCPOL(I,J,K) = 0 10 CONTINUE 20 CONTINUE 30 CONTINUE IF (LAMCC.EQ.0) RETURN C DO 50 J = 1,LRANG2 DO 40 I = 1,LRANG2 JCCPOL(I,J) = 0 40 CONTINUE 50 CONTINUE C C LOOP OVER ANGULAR MOMENTA L1 AND L2, AND FOR EACH POSSIBLE LM0 C LOOP OVER PRINCIPLE QUANTUM NUMBERS N1 AND N2. C DO 130 L1 = 1,LRANGD JWK = 0 DO 90 L2 = L1,LRANGD LAMST = 0 LAM1 = L2 - L1 IF (LAM1.EQ.1) JCCPOL(L1,L2) = JRK8 + 1 IF (LAM1.GT.MIN(LAMCC,L1+L2-2)) GOTO 90 NST = NRANG2 C DO 80 LM0 = LAM1,MIN(LAMCC,L1+L2-2),2 IF (LM0.EQ.0) GOTO 80 LAMST = LAMST + 1 ICCPOL(L1,L2,LAMST) = IRK8 + 1 C DO 70 N1 = 1,NRANG2 N1P = MAXNHF(L1) + N1 IF (L1.EQ.L2) NST = N1 C DO 60 N2 = 1,NST N2P = MAXNHF(L2) + N2 IRK8 = IRK8 + 1 IF (IRK8.GE.MXMEM) NBUG7 = 1 IF (NBUG7.NE.1) THEN CALL RADINT(N1P,L1,N2P,L2,LM0,X1) RKSTO2(IRK8) = X1 IF (LM0.EQ.1) THEN IRK8 = IRK8 + 1 CALL DERINT(N1P,L1,N2P,L2,X1) RKSTO2(IRK8) = X1 ENDIF C ELSE IF (LM0.EQ.1) THEN IRK8 = IRK8 + 1 ENDIF C 60 CONTINUE C IF (LM0.NE.1) GOTO 70 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.MXSK2) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 70 N2P = N2P + 1 CALL RADINT(N1P,L1,N2P,L2,LM0,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,LM0,X1) WKSP(JWK) = X1 CALL DERINT(N1P,L2,N2P,L1,X1) JWK = JWK + 1 WKSP(JWK) = X1 70 CONTINUE 80 CONTINUE 90 CONTINUE IF (L1.EQ.LRANGD) GOTO 120 C C EVALUATE DIPOLE INTEGRAL BETWEEN TWO BUTTLE TYPE FUNCTIONS C JRK8 = JRK8 + 2 IF (JRK8+JWK.GT.MXSK2) NBUG7 = 1 IF (NBUG7.EQ.1) GOTO 110 L2 = L1 + 1 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 100 J = 1,JWK SKSTO2(JRK8+J) = WKSP(J) 100 CONTINUE 110 CONTINUE JRK8 = JRK8 + JWK C C FINALLY CALCULATE THE NORMALIZATION FOR BUTTLE FUNCTION L1-1. C 120 CONTINUE CALL ABNORM(MAXNHF(L1)+NRANG2+1,L1,MAXNHF(L1)+NRANG2+1,L1,OVRLP) BNORM(L1) = OVRLP 130 CONTINUE C END C C C SUBROUTINE ISTG1(LRANG1,LRANG2,NCOEFF,IOUT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C DEFINE THE NPTS MESH POINTS (XR), STEP-LENGTHS (STEP), C SIMPSONS RULE WEIGHTS (WT), POWERS OF MESH POINTS C (RK(I,K)=XR(I)**K) AND NUMBER OF MESH POINTS (NPTS). C C ALSO TABULATES ANALYTIC BOUND ORBITALS AND POTENTAL ON MESH. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXNIX=MZNPT/16) C COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS C PARAMETER (ZERO=0.0D0) PARAMETER (ONE3=1.0D0/3.0D0) PARAMETER (TWO3=2.0D0*ONE3) PARAMETER (FOUR3=4.0D0*ONE3) C----------------------------------------------------------------------- IFI = 1 IFX = 0 XR(1) = ZERO STEP(1) = ZERO DO 20 I = 1,NIX H = IHX(I)*HINT WT(IFI) = (H+STEP(IFI))*ONE3 RSTART = XR(IFI) IST = IFI + 2 IFI = IRX(I) + 1 DO 10 J = IST,IFI,2 XR(J-1) = RSTART + (J-2-IFX)*H XR(J) = RSTART + (J-1-IFX)*H STEP(J-1) = H STEP(J) = H WT(J-1) = FOUR3*H WT(J) = TWO3*H 10 CONTINUE IFX = IRX(I) 20 CONTINUE WT(IFI) = ONE3*H NPTS = IFI C L12 = LRANG1 + MAX(LRANG1,LRANG2) - 2 DO 40 K = -L12 - 2,L12 DO 30 I = 2,NPTS RK(I,K) = XR(I)**K 30 CONTINUE RK(1,K) = ZERO 40 CONTINUE C C TABULATE ANALYTIC BOUND ORBITALS IN /ORBTLS/ C IF (NCOEFF.GT.0) CALL EVALUE C C DEBUG PRINT OUT OF BOUND ORBITALS C IF (IOUT.GT.0) CALL TABORB(IOUT,0) C C TABULATE THE POTENTIAL FUNCTION IN /POTVAL/ C CALL POTF C END C C C SUBROUTINE LSQ(P,Q,C,N) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C LEAST SQUARE FITS N POINTS: C C----------------------------------------------------------------------- DIMENSION P(N),Q(N),X(3,3),C(3) C PARAMETER (ZERO=0.0D0) C----------------------------------------------------------------------- C C ROUTINE REPLACED WITH OP VERSION WE'90MAY15 X(1,1) = N DO 70 I = 1,3 C(I) = ZERO L = I - 1 IF (L.NE.0) GOTO 20 DO 10 K = 1,N C(I) = C(I) + Q(K) 10 CONTINUE GOTO 40 C 20 CONTINUE DO 30 K = 1,N C(I) = C(I) + (P(K)**L)*Q(K) 30 CONTINUE 40 CONTINUE DO 60 J = 1,3 L = I + J - 2 IF (L.EQ.0) GOTO 60 X(I,J) = ZERO DO 50 K = 1,N X(I,J) = X(I,J) + P(K)**L 50 CONTINUE 60 CONTINUE CC WRITE(6,601)(X(I,J),J=1,3), C(I) CC601 FORMAT('0X(I,J) =',3F14.7,' C(J) =',F14.7/) 70 CONTINUE C CALL MA01A(X,C,3,1,0,3,1) C END C C C SUBROUTINE MA01A(A,B,M,N,M1,IA,IB) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN13=MZNR1+3) C DIMENSION A(IA,IA),B(IA,IB),C(MXN13),IND(MXN13) C----------------------------------------------------------------------- ZERO = DBLE(0) ONE = DBLE(1) MM = M - 1 IF (M1.LT.0) GOTO 180 C C CHECK FOR ZERO DIAGONAL ELEMENTS C IF (MM.LT.0) GOTO 370 DO 10 I = 1,M IF (A(I,I).EQ.ZERO) A(I,I) = 1.0D-37 10 CONTINUE C C DO THE TRIVIAL CASE OF A 1*1 MATRIX C IF (M.GT.1 .OR. N.GT.1) GOTO 20 IF (N.EQ.1) B(1,1) = B(1,1)/A(1,1) A(1,1) = ONE/A(1,1) GOTO 370 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 20 CONTINUE AMAX = ZERO DO 30 I = 1,M IND(I) = I IF (ABS(A(I,1)).LE.AMAX) GOTO 30 AMAX = ABS(A(I,1)) I4 = I 30 CONTINUE C C EACH TIME THROUGH THE FOLLOWING LOOP THE A-MATRIX IS C REDUCED BY ONE C IF (MM.LE.0) GOTO 120 DO 110 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) GOTO 60 ISTO = IND(J) IND(J) = IND(I4) IND(I4) = ISTO DO 40 K = 1,M STO = A(I4,K) A(I4,K) = A(J,K) A(J,K) = STO 40 CONTINUE C C INTERCHANGE THE I4TH AND THE JTH ROWS OF THE B-MATRIX IF N.GT. 0 C IF (N.LE.0) GOTO 60 DO 50 K = 1,N STO = B(I4,K) B(I4,K) = B(J,K) B(J,K) = STO 50 CONTINUE 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 60 CONTINUE AMAX = ZERO J1 = J + 1 DO 100 I = J1,M A(I,J) = A(I,J)/A(J,J) DO 70 K = J1,M A(I,K) = A(I,K) - A(I,J)*A(J,K) IF (K.GT.J1) GOTO 70 C FIND THE NEXT PIVOTAL ELEMENT AND STORE THE CORRESPONDING ROW C NUMBER IN I4 IF (ABS(A(I,K)).LE.AMAX) GOTO 70 AMAX = ABS(A(I,K)) I4 = I 70 CONTINUE IF (N.LE.0) GOTO 100 DO 90 K = 1,N B(I,K) = B(I,K) - A(I,J)*B(J,K) 90 CONTINUE 100 CONTINUE 110 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 120 CONTINUE IF (N.LE.0) GOTO 170 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 160 I1 = 1,M I = M + 1 - I1 DO 150 J = 1,N IF (M.LE.I) GOTO 140 I2 = I + 1 DO 130 K = I2,M B(I,J) = B(I,J) - A(I,K)*B(K,J) 130 CONTINUE 140 B(I,J) = B(I,J)/A(I,I) 150 CONTINUE 160 CONTINUE 170 CONTINUE IF (M1.LE.0) GOTO 370 C C REPLACE THE A-MATRIX BY ITS INVERSE WHEN M1.NE. ZERO C C FIRST INVERT THE LOWER TRIANGLE MATRIX AND STORE ON ITSELF C 180 CONTINUE IF (MM.LE.0) GOTO 240 DO 230 I1 = 1,MM I = M + 1 - I1 I2 = I - 1 DO 210 J1 = 1,I2 J = I2 + 1 - J1 J2 = J + 1 W1 = -A(I,J) IF (I2.LT.J2) GOTO 200 DO 190 K = J2,I2 W1 = W1 - A(K,J)*C(K) 190 CONTINUE 200 C(J) = W1 210 CONTINUE DO 220 K = 1,I2 A(I,K) = C(K) 220 CONTINUE 230 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 240 CONTINUE DO 330 I1 = 1,M I = M + 1 - I1 I2 = I + 1 W = ONE/A(I,I) DO 310 J = 1,M IF (I-J) 250,260,270 250 CONTINUE W1 = ZERO GOTO 280 C 260 CONTINUE W1 = ONE GOTO 280 C 270 CONTINUE W1 = A(I,J) 280 CONTINUE IF (I1.EQ.1) GOTO 300 DO 290 K = I2,M W1 = W1 - A(I,K)*A(K,J) 290 CONTINUE 300 C(J) = W1 310 CONTINUE DO 320 J = 1,M A(I,J) = C(J)*W 320 CONTINUE 330 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 360 I = 1,M 340 CONTINUE IF (IND(I).EQ.I) GOTO 360 J = IND(I) DO 350 K = 1,M STO = A(K,I) A(K,I) = A(K,J) A(K,J) = STO 350 CONTINUE ISTO = IND(J) IND(J) = J IND(I) = ISTO GOTO 340 C 360 CONTINUE C 370 CONTINUE C END C C C SUBROUTINE MESH IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNIX=MZNPT/16) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C PARAMETER (ZERO=0.0D0) C DATA MINFAC,MAXFAC/1,2/,MSHDIM/16/ C----------------------------------------------------------------------- C NRNG2=MAX(20,NRANG2) !ALLOW FOR FAST NX1.DAT RUN LRNG2=MAX(12,LRANG2) C NCORSE = NRNG2*MSHDIM NCORSE = NCORSE + ((LRNG2-2)/2)*MSHDIM !MOD FOR HIGH-L V1.4 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 = 0.025D0/NZ DELTA = HINNER/5.0D0 M = 0 HMIN = HMAX 10 CONTINUE IF (HMIN.GT.HINNER+DELTA) THEN M = M + 1 HMIN = HMIN/2 GOTO 10 C ENDIF C HINT = HMIN NIX = M + 1 IF (NIX.GT.MXNIX) CALL RECOV2('STG1RD','MXNIX ',MXNIX,NIX) C C SET UP THE IHX ARRAY C IH = 1 DO 20 I = 1,NIX IHX(I) = IH IH = IH + IH 20 CONTINUE 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 30 CONTINUE NA = 16*NAFAC NTOT = NCORSE + (M-1)*NA + NA/8 IF (NTOT.GE.MZNPT) THEN NAFAC = NAFAC - 1 IF (NAFAC.GE.MINFAC) GOTO 30 ENDIF 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 40 CONTINUE NA = 16*NAFAC NTOT = NCORSE + M*NA - NA* (MPOW2-1)/MPOW2 IF (NTOT.GE.MZNPT) THEN NAFAC = NAFAC - 1 IF (NAFAC.GE.MINFAC) GOTO 40 ENDIF C IA = 2 C ENDIF C C FILL IRX ARRAY C IRX(1) = NA DO 50 I = IA,NIX - 1 IRX(I) = NA + IRX(I-1) 50 CONTINUE C IF (NAFAC.GE.MINFAC) GOTO 60 NA = INT((((1-M)*MINFAC*16+MZNPT)*MPOW2-MINFAC*16)*NRNG2*HMIN/RA) WRITE (IWRITE,3000) NA CALL RECOV2('MESH ',' MZNPT',MZNPT,NTOT) NTOT = NTOT - 2 C C NUMBER OF STEPS AT EACH STEP SIZE MUST BE EVEN C 60 CONTINUE IF (MOD(NTOT,2).NE.0) THEN NTOT = NTOT + 1 IRX(NIX-1) = IRX(NIX-1) + 2 ENDIF C IRX(NIX) = NTOT C C PERFORM CHECK C IF (NBUG5.NE.1) GOTO 80 RVAL = ZERO IR = 0 DO 70 I = 1,NIX RVAL = RVAL + HINT* (IRX(I)-IR)*IHX(I) IR = IRX(I) 70 CONTINUE WRITE (IWRITE,'(/'' RVAL ='',E14.7)') RVAL C 80 CONTINUE C 3000 FORMAT (/ A' TO SATISFY INTEGRATION MESH CONDITIONS NRANG2 SHOULD BE REDUCED BBELOW',I3/' RECOMPILE IF THIS IS UNDESIRABLE:') END C C C SUBROUTINE NAME(CODE,JBC,MXXE,MCB) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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 IF CODE IS STO-, NOW READ RADIAL ORBITAL DATA (AS PER RECORD 9 C OF 1995 CPC WRITE-UP) AFTER NAMELIST DATA. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C CHARACTER*4 CODE,COD(3),RELOP,RAD,RADOUT C DIMENSION ISMIT(MXORB),NPS(0:MZLR1),NPSMN(0:MZLR1),NPSMX(0:MZLR1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /COPY/ITOTAL,ICOUNT COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DPOLE/ALFD,RCUT,IPLCR,IPLFN,IKMX,IORB(MXORB) COMMON /DW/IDWOUT,LNOEX COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG(9) COMMON /POTEN/CPOT(6),XPOT(6),IPOT(6),NPOT COMMON /REL/IRELOP(3) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /NRBBUT/BUTORB(MZNPT,MZNR1),BUTEND(MZNR1),BUTEIG(MZNR1), X EMIN,EMAX,TOLE,ITEST0,IMAX,JPOS(MXN3),MJS,NBOX(0:MZLR1) COMMON /NRBDIP/LRANGD COMMON /NRBOCC/TOCC(MXORB),IMAXN,IBANDW C NAMELIST /STG1A/IOUT,IOUTDA,INDATA,IPSEUD,IDWOUT, A NBUG1,NBUG3,NBUG5,NBUG7,NBUG8,NBUG9,KRELOP,LAM, B RELOP,RAD,IRELOP,ISMITN,IZESP,IBANDW,IMAXN,RADOUT,IBOX C NAMELIST /STG1B/MAXLS,MAXPW,MAXE,LAMAX,MAXC,IBC,LCB,ISMIT,NPOT, B MAXLA,MAXLT,NPS,NPSMN,NPSMX,NMIN,NMAX,LMIN,LMAX,IMAX,TOLE,EMIN, C NELCOR,IPTS,NZ,NZED,NELC,MAXORB,EMAX,MJS,MAXLD,NBOX,MAXNCB D,ALFD,RCUT,IPLFN,IPLCR,LNOEX C EQUIVALENCE(MAXPW,MAXLT),(MAXLS,MAXLA),(NZED,NZ),(NPS(0),NPSMX(0)) C DATA COD/'CIV3','S.S.','STO-'/ C----------------------------------------------------------------------- C C INITIALIZE THE PARAMETERS IN NAMELIST /STG1A/ AND /STG1B/ C C----------------------------------------------------------------------- WRITE (IWRITE,3020) CODE C MAXLA = 0 MAXLT = 999 LNOEX = 999 !MAX EXCHANGE MULTIPOLE - SYNC. WITH STG2 MAXE = 9999 LRANGD = 999 MAXLD = -1 C IOUT = 2 IOUTDA = 12 INDATA=5 IF(CODE.EQ.COD(2))INDATA=4 C IPSEUD = 0 C NBUG1 = 0 NBUG3 = 0 NBUG5 = 0 NBUG7 = 0 NBUG8 = 0 NBUG9 =0 KRELOP = 0 RELOP='NO' ! NRB RAD='NO' RADOUT='NO' IRELOP(1)=0 IRELOP(2)=0 IRELOP(3)=0 ! NRB IZESP=0 ! NRB IBANDW=0 ! SCREENING FACTORS FROM RADIAL - NRB IF(CODE.NE.COD(2))IBANDW=1 ! ORIGINAL B&W - NRB IMAXN=0 ! INITIALIZE - NRB C IDWOUT=0 ! NRB C MAXC = MZNR2+1 LAM = 1 LAMAX = 2 IBC = 0 LCB = 0 C C TO SPECIFY A RANGE OF BOX/LAGUERRE PSEUDO STATES FOR ALL L VALUES C FROM LMIN TO LMAX, JUST SPECIFY THE RANGE OF n VALUES USING C NMIN AND NMAX. HOWEVER, IF THE PSEUDOS HAVE DIFFERENT VALUES OF C NMIN FOR DIFFERENT VALUES OF L, SET NMIN LESS THAN ZERO AND USE C NPSMN(L) TO SPECIFY THE MINIMUM n VALUE FOR EACH VALUE OF L FROM C LMIN TO LMAX. IF THE PSEUDOS HAVE DIFFERENT VALUES OF NMAX FOR C DIFFERENT VALUES OF L, THEN SET NMAX LESS THAN ZERO AND USE C NPSMX(L) TO SPECIFY THE MAXIMUM n VALUE FOR EACH L VALUE FROM C LMIN TO LMAX. C C *TEST* BOX TARGET STATES: SET IBOX.NE.0. C IF IBOX.GT.0 THEN THERE ARE IBOX STATES PER L FOR ALL TARGET L C IF IBOX.LT.0 THEN SET THE NUMBER OF BOX STATES PER L VIA NBOX(L). C IBOX=0 ISMITN = 0 NMIN=-1 NMAX=-1 LMIN=-1 LMAX=-1 DO 10 I = 1,MXORB ISMIT(I) = 0 10 CONTINUE DO 11 I=0,MZLR1 NPSMN(I)=0 NPSMX(I)=0 NBOX(I)=0 11 CONTINUE C C NUMBER OF ENERGIES USED FOR BUTTLE FIT IMAX=-1 EMIN=-9999.0D0 EMAX=9999.0D0 MJS=1 !NEWBUT C C E-VALUE TOLERANCE FOR DISCARDING LINEAR DEPENDENT VECTORS (SHMITT) TOLE=-1.0D-4 C C NO. OF POINTS PER HALF CYCLE * SQRT(2). IPTS=23 C NPOT = 0 C C FOR NEW STO-, NZ, NELC, MAXORB ***MUST*** BE SPECIFIED NZ=0 NELC=0 !AS PER NAMELIST STG2B MAXORB=0 !AS PER NAMELIST STG2B C C FOR POLARIZABILITY ALFD=0.0 RCUT=0.0 IPLFN=1 IPLCR=0 C C WRITE (IWRITE,3000) IOUT,IOUTDA,CODE,INDATA,IPSEUD,NBUG1,NBUG3, A NBUG5,NBUG7,NBUG8,KRELOP,IBANDW,LAM,MAXC,IBC,LCB,IDWOUT,LNOEX, B ALFD,RCUT,IPLFN,IPLCR,ISMITN C C READ NAMELIST PARAMETERS FROM DATA, AFTER READING ANY CIV3 DATA C IF (CODE.EQ.COD(1)) CALL CIV3 C READ (IREAD,STG1A) READ (IREAD,STG1B) C IF(LNOEX.LT.0)LNOEX=-1 IF(LNOEX.GT.999)LNOEX=999 C IF(MAXLD.GE.0)LRANGD=MAXLA+MAXLD+1 C IF(LAM.LT.1)LAM=1 IF(LAM.GT.3)LAM=3 C IF(TOLE.LT.ZERO)TOLE=1.0D-4 C IF(IMAX.LT.0)IMAX=6 C NRB 24/10/94, OR USE IRELOP EXPLICITLY! IF(KRELOP.EQ.0)THEN IF(RELOP.EQ.'YES'.OR.RELOP.EQ.'TCC')KRELOP=7 IF(RELOP.EQ.'MVD')KRELOP=6 ENDIF IF(RAD.EQ.'YES')LAM=3 IF(RADOUT.EQ.'YES')NBUG5=2 IF(IDWOUT.EQ.2)THEN IF(MAXC.GE.0)THEN MAXC=1 ELSE MAXC=-MAXC ENDIF MAXLT=0 IF(MAXE.EQ.9999)MAXE=1 IF(LNOEX.EQ.999)LNOEX=10 ENDIF C NRB IF(IBOX.GT.0)THEN !BOX TEST DO L=0,MZLR1 NBOX(L)=IBOX ENDDO ENDIF IF(IBOX.NE.0)STOP ' ***THIS IS FOR BOX TEST ONLY!!' IF(ISMITN.LT.0)STOP ' ***THIS IS FOR LAGUERRE TEST ONLY!!' C IF(LMIN.GT.-1)THEN !LAGUERRE IF(LMAX.GE.MZLR1)THEN WRITE(6,*)'***INCREASE MZLR1 TO',LMAX+1,' OR REDUCE LMAX' STOP 'TOO MANY PSEUDO ORBITALS SPECIFIED?' ENDIF K=0 IF(NMAX.GT.0)THEN IF(NMIN.GT.0) THEN DO N=NMIN,NMAX DO 13 L=LMIN,LMAX IF(L.EQ.N)GO TO 13 K=K+1 ISMIT(K)=10*N+L 13 CONTINUE END DO ELSE DO L=LMIN,LMAX NNN=MAX(NPSMN(L),L+1) DO N=NNN,NMAX K=K+1 ISMIT(K)=10*N+L END DO END DO END IF ELSE IF(NMIN.GT.0) THEN DO L=LMIN,LMAX NNN=MAX(NMIN,L+1) DO N=NNN,NPSMX(L) K=K+1 ISMIT(K)=10*N+L END DO END DO ELSE DO L=LMIN,LMAX NNN=MAX(NPSMN(L),L+1) DO N=NNN,NPSMX(L) K=K+1 ISMIT(K)=10*N+L END DO END DO END IF ENDIF ENDIF C ILIM = 0 DO 20 I = 1,MXORB IF (ISMIT(I).GT.0) ILIM = I 20 CONTINUE C IF (LAMAX.LT.0) LAMAX = 2*MAXLA IF(LAMAX.GT.MZLMX)WRITE(6,3030)MZLMX C WRITE (IWRITE,3010) MAXLA,MAXLT,MAXE,IOUT,IOUTDA,INDATA, A IPSEUD,NBUG1,NBUG3,NBUG5,NBUG7,NBUG8,NBUG9,KRELOP,IBANDW,LAM, B LAMAX,MAXC,IBC,LCB,MAXLD,IDWOUT,LNOEX,ALFD,RCUT,IPLFN,IPLCR, C ISMITN,(ISMIT(I),I=1,ILIM) C JBC = IBC MCB = LCB MXXE = MAXE C C INITIALIZE SOME STG1 PARAMETERS C ITOTAL = 999 C ITAPE1 = 0 C INDATA = 5 C DO 50 I = 1,9 NBUG(I) = 0 50 CONTINUE C NBUG(1) = NBUG1 NBUG(3) = NBUG3 NBUG(5) = NBUG5 NBUG(7) = NBUG7 NBUG(8) = NBUG8 NBUG(9) = NBUG9 C IF(IRELOP(1)+IRELOP(2)+IRELOP(3).EQ.0)THEN L = MIN(KRELOP,7) IZESP = MAX(-L,0) IF (KRELOP.GT.7) IZESP = -KRELOP + 8 IF (L.LT.0) L = 7 IRELOP(1) = L/4 IRELOP(2) = (L-IRELOP(1)*4)/2 IRELOP(3) = MOD(L,2) ENDIF ! NRB C IF (CODE.EQ.COD(3)) CALL CODE3(MAXORB) C C READ IN ANY EXTRA DATA, AS DETERMINED BY THE PARAMETER IBC. C 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 = ZERO C IF (IBC.EQ.0) GOTO 80 C READ (IREAD,*) RA,BSTO C IF (ABS(IBC).EQ.1) GOTO 70 C READ (IREAD,*) L C IF (L.LE.0) GOTO 60 C IF (L.GT.MXNIX) CALL RECOV2('NAME ','MXNIX ',MXNIX,L) READ (IREAD,*) (IHX(I),I=1,L) READ (IREAD,*) (IRX(I),I=1,L) NIX = L C 60 CONTINUE C READ (IREAD,*) TMP,DELTA,ETA IF (L.GT.0) HINT = TMP C 70 CONTINUE C IF (IBC.GE.0) GOTO 80 READ (IREAD,*) NPOT C IF (NPOT.LE.0) GOTO 80 C IF (NPOT.GT.6) CALL RECOV2('NAME ','6 ',6,NPOT) READ (IREAD,*) (IPOT(I),I=1,NPOT) READ (IREAD,*) (CPOT(I),I=1,NPOT) READ (IREAD,*) (XPOT(I),I=1,NPOT) C 80 CONTINUE C IF (CODE.EQ.COD(3)) GOTO 100 IF (CODE.EQ.COD(1)) GOTO 110 C C READ IN ORBITAL DATA IN SUPERSTRUCTURE FORMAT C IF (CODE.EQ.COD(2)) CALL SS(INDATA,MAXE,IPTS) C IF(NELCOR.LT.0)NELCOR=NELC 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.NELCOR) GOTO 100 NPOT = 1 CPOT(1) = 2*NELCOR XPOT(1) = NZ XPOT(1) = XPOT(1)**THIRD IPOT(1) = -1 IF (NZ.EQ.NELCOR) GOTO 100 NPOT = 2 CPOT(2) = (NZ-NELCOR)*2 XPOT(2) = ZERO IPOT(2) = -1 C 100 CONTINUE IF (MXXE.EQ.9999) GOTO 110 IF (MAXC.GT.MZNR2) A MAXC = INT(SQRT(ABS(MAXE)*TWO)*RA/PI + HALF) C C 110 CONTINUE C C RECODED NSTO IN STG2 SO NOW WORKS WITH MAXC.LT.MAXNHF - NRB 19/12/96 C DO 130 L = 1,LRANG1 MAXNLG(L) = MAXNHF(L) COLD MAXC = MAX(MAXC,MAXNHF(L)) IF (ILIM.EQ.0) GOTO 130 DO 120 I = 1,ILIM IF (MOD(ISMIT(I),10).NE.L-1) GOTO 120 MAXNLG(L) = MIN(ISMIT(I)/10-1,MAXNLG(L)) 120 CONTINUE 130 CONTINUE C COLD NRANG2 = MIN(MZNR2,MAXC) IFLAG=0 NRANG2=MAXC IF(NRANG2.GT.MZNR2)THEN WRITE(6,3040)NRANG2 IFLAG=1 ENDIF COLD LRANG2 = MIN(MAXLT+MAXLA+1,MZLR2) LRANG2=MAXLT+MAXLA+1 IF(LRANG2.GT.MZLR2)THEN WRITE(6,3050)LRANG2 IFLAG=2 ENDIF IF(IFLAG.EQ.1)STOP '***SR.NAME: INCREASE MZNR2' IF(IFLAG.EQ.2)STOP '***SR.NAME: INCREASE MZLR2' C C 3000 FORMAT (/' STG1 PARAMETERS (THE FIRST 3 ARE COMPULSARY)'// A ' MAXLA = MAXIMUM ANGULAR MOMENTUM OF N-ELECTRON TARGET STATES' B / C ' MAXLT = MAXIMUM ANGULAR MOMENTUM OF (N+1) ELECTRON SYMMETRIES' D /' MAXE = MAXIMUM ENERGY IN RYD OF SCATTERED ELECTRON'// E' THE FOLLOWING PARAMETERS ARE OPTIONAL (DEFAULT VALUES IN PARENTH FESIS)'//' IOUT = OUTPUT CHANNEL NUMBER FOR STG1 INTEGRALS (' G ,I3,')'/ H ' IOUTDA= DA OUTPUT CHANNEL NUMBER FOR STG1 INTEGRALS (', I I3,')'/' INDATA= INPUT CHANNEL NUMBER FROM ',A4,16X,'(',I3, J ')'/ K ' IPSEUD= 1 INDICATES USE OF CORE POTENTIAL POTHAM (', L I3,')'/ O ' NBUG1,NBUG3,NBUG5,NBUG7,NBUG8 = DEBUG LEVELS (', P I1,',',I1,',',I1,',',I1,',',I1,')'/ Q ' KRELOP= ...7 FOR RELATIVISTIC OPERATORS; IZESP=-KRELOP(', R I3,')'/ * ' IBANDW= 1 FOR ORIGINAL B&W, AND =0 READ FROM RADIAL SS(', * I3,')'/ S ' LAM = 1 FOR E-COLLISIONS, =3 FOR DIPOLE MATRIX ALSO (', A I3,')'/ B ' MAXC = MAXIMUM NUMBER OF CONTINUUM ORBITALS (', C I3,')'/ D ' IBC = NONZERO FOR RA,BSTO, NIX, NPOT EXPLICITLY READ(', E I3,')'/ F ' LCB = MAX L+1 FOR TREATING CONTINUUM ORBS AS BOUND (', G I3,')'/ H ' IDWOUT= 0 FOR CC OPERATION, 1 FOR CC+DW, 2 FOR DW ONLY(', I I3,')'/ H ' LNOEX= MAX EXCHANGE MULTIPOLE (', I I3,')'/ J ' ALFD = DIPOLE POLARIZABILITY (', K F3.1,')'/ L ' RCUT = CUT-OFF FOR POLARIZATION POTENTIAL (', M F3.1,')'/ N ' IPLFN = POLARIZATION POTENTIAL =1 NORCROSS; =2 BAYLIS (', O I3,')'/ P ' IPLCR = MAX ORBITAL NUMBER NO OF POLARIZED CORE (', Q I3,')'/ R ' ISMITN= 0 FOR RECURSIVE, AND 1 FOR NUMERICAL, ORTHOG. (', S I3,')'/ T ' ISMIT = ARRAY CONTAINING 10*N+L OF CORRELATION ORBTLS (', U 'NIL)'/) 3010 FORMAT (/' DEFINITION OF STG1 PARAMETERS FOR THIS RUN ...'//20X, A 'MAXLA =',I3/20X,'MAXLT =',I3/20X,'MAXE =',I4//20X, B 'IOUT =',I3/20X,'IOUTDA=',I3/20X,'INDATA=',I3/20X, C 'IPSEUD=',I3/20X,'NBUG1, NBUG3, NBUG5, NBUG7, NBUG8, NBUG9=', D 6I3/20X,'KRELOP=',I3/20X, E 'IBANDW=',I3/20X,'LAM =',I3/20X,'LAMAX =',I3/20X, F 'MAXC =',I3/20X,'IBC =',I3/20X,'LCB =',I3 G /20X,'MAXLD =',I3/20X,'IDWOUT=',I3/20X,'LNOEX =',I3 H /20X,'ALFD =',F4.1/20X,'RCUT =',F4.1/20X, I 'IPLFN =',I3/20X,'IPLCR =',I3/20X, J 'ISMITN=',I3/20X,'ISMIT =',(T28,I3)) 3020 FORMAT (/' ORBITALS ARE DEFINED AS IN ',A4) 3030 FORMAT (/' TOO MANY RADIAL MULTIPOLES, EITHER RESET LAMAX TO' X ,I3,' IN THE NAMELIST OR INCREASE DIMENSION AS.....') 3040 FORMAT (/' TOO MANY CONTINUUM BASIS ORBITALS REQUIRED. EITHER', X 'REDUCE MAXC/MAXE OR INCREASE MZNR2 TO:',I3) 3050 FORMAT (/'TOO MANY CONTINUUM BASIS ANGULAR MOMENTUM STATES NEEDED' X ,'. EITHER REDUCE MAXLT OR INCREASE MZLR2 TO:',I3) END SUBROUTINE NEWBUT(L) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- PARAMETER (X=0.2D0) C INCLUDE 'PARAM' C PARAMETER (MZIMX=50) PARAMETER (MXN11=MZNR1+1) PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /DW/IDWOUT,LNOEX COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /ORBOUT/ORB(MZNPT),DORB(MZNPT),EIGEN,ALAMDA(MXN11),BVALUE COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /NRBBUT/BUTORB(MZNPT,MZNR1),BUTEND(MZNR1),BUTEIG(MZNR1), X EMIN,EMAX,TOLE,ITEST0,IMAX,JPOS(MXN3),MJS,NBOX(0:MZLR1) C DIMENSION EL(MZIMX),RT(MZIMX),RCN(MZIMX),A(3) C----------------------------------------------------------------------- C IF(IMAX.GT.MZIMX)THEN WRITE(6,*)'INCREASE MZIMX TO AT LEAST',IMAX STOP ENDIF C IF(IDWOUT.EQ.2)RETURN C L1 = L - 1 WRITE (IWRITE,3020) L1 NBT = 0 ITEST=0 IF (L.LE.LRANG1) THEN NBT = MAXNLG(L) - L1 - ITEST0 ITEST=MAXNHF(L)-MAXNLG(L) ENDIF C C BUTTLE CORRECTION TO R-MATRIX C ***************************** C CHECK THAT EK2MAX NOT TOO LARGE C D = HALF*EMAX IF (EK2MAX.GT.D) EK2MAX = D C C CHECK THAT EK2MIN NOT TOO SMALL C D = HALF* (THREE*EIGENS(1,L)-EIGENS(2,L)) IF (EK2MIN.LT.D) EK2MIN = MIN(D,ZERO) !V1.4 IF(EK2MIN.LT.EMIN)EK2MIN=EMIN C C CHECK THAT EK2MIN.LT.EK2MAX C IF (EK2MIN+PT0001.GT.EK2MAX) THEN ! NRB 24/10/94 +PT0001 WRITE (IWRITE,3050) EK2MIN,EK2MAX ENDIF C C BUTTLE CORRECTION CALCULATED AT ENERGIES EL(I), I=1,IMAX C INITIALISE EL(I) WITH EQUALLY SPACED POINTS C D = (EK2MAX-EK2MIN)/ (IMAX-1) E = EK2MIN - D DO 10 I = 1,IMAX E = E + D EL(I) = E 10 CONTINUE 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 40 I = 1,IMAX C C FIND FIRST POLE ABOVE EL(I) C DO 20 N = NA,NRANG2 IF (EIGENS(N,L).LE.EL(I)) GOTO 20 NN = N GOTO 30 C 20 CONTINUE 30 CONTINUE NA = NN EA = EIGENS(NA,L) C C CASE OF ALL POLES ABOVE C IF (NA.EQ.1) THEN EP = EIGENS(2,L) D = X* (EP-EA) IF ((EA-EL(I)).LT.D) EL(I) = EA - D C C SOME POLES BELOW C ELSE C C NEAREST POLE BELOW C 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 C 40 CONTINUE WRITE (IWRITE,3000) EL(1),EL(IMAX) C C CHECK NUMBER OF INDEPENDENT VALUES C INDEP = 1 DO 50 N = 2,IMAX IF (EL(N-1).NE.EL(N)) INDEP = INDEP + 1 50 CONTINUE IF (INDEP.LT.3) THEN WRITE (IWRITE,3040) ENDIF C C CALCULATE BUTTLE CORRECTIONS AT ENERGIES EL(I) AND STORE IN RCN(I) C DO 80 II = 1,IMAX IF (ABS(EL(II)).LT.TINY) EL(II) = EL(II) + TWO*TINY EH = ZERO C CALL BASFUN(NBT,L1,NODE,RA,BSTO,EL(II),DELTA,EH) C RT(II) = BVALUE - BSTO IF (ABS(RT(II)).GT.TINY) GOTO 60 WRITE (IWRITE,3010) L1,EL(II) RETURN 60 CONTINUE SUM = ZERO C FIRST REMOVE POLES ASSOCIATED WITH SCHMIDT ORBITALS (ISMITN=-1) - NRB IF(ITEST0.GT.0)THEN DO 65 N=1,ITEST0 SUM=SUM+BUTEND(N)*BUTEND(N)/(BUTEIG(N)-EL(II)) 65 CONTINUE ENDIF C THEN POLES OF CONTINUUM BASIS DO 70 N = 1,NRANG2 IF (ENDS(N,L).EQ.0.0D0) GOTO 70 SUM=SUM+ENDS(N,L)*ENDS(N,L)/(EIGENS(N,L)-EL(II)) 70 CONTINUE RCN(II) = ONE/RT(II) - SUM/RA 80 CONTINUE C C FIT BUTTLE CORRECTION AND STORE FIT PARAMETERS IN COEFF(I,L),I=1,3 C IF (BSTO.NE.ZERO.OR.MJS.EQ.0) GOTO 90 C C FOR BSTO.EQ.0. USE IMPROVED FITTING PROCEDURE C CALL BUTFIT(IMAX,EL,RCN,RA,EMAX,ALPHA,BETA,NBUT,DELTB) WRITE (IWRITE,3060) ALPHA,BETA,NBUT C C IF BUTFIT DIVERGING TELL USER TO TRY QUADRATIC FIT (STGF CANNOT HANDLE A C MIXTURE OF OLD AND NEW BUTTLE FITS): C IF (NBUT.GT.0) THEN COEFF(1,L) = ALPHA COEFF(2,L) = BETA COEFF(3,L) = -10000*NBUT GOTO 120 ELSE WRITE(IWRITE,*)'NEW BUTFIT DIVERGING, USE QUADRATIC: SET MJS=0' STOP 'NEW BUTFIT DIVERGING, USE QUADRATIC: SET MJS=0' ENDIF C C USE QUADRATIC FIT FOR BSTO.NE.0 .OR. MJS.EQ.0. C 90 CONTINUE CALL LSQ(EL,RCN,A,IMAX) DO 100 I = 1,3 COEFF(I,L) = A(I) 100 CONTINUE WRITE (IWRITE,3030) A DELTB = ZERO DO 110 I = 1,IMAX D = ABS((A(3)*EL(I)+A(2))*EL(I)+A(1)-RCN(I)) IF (DELTB.LT.D) DELTB = D 110 CONTINUE C C ACCURACY OF FIT C 120 CONTINUE WRITE (6,3070) DELTB,RCN(1),RCN(IMAX) 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.ZERO .AND. NRANG2.GT.1) THEN C C TAKE ENERGY HALF WAY BETWEEN TWO POLES NEXT TO ZERO ENERGY C I = 2 130 CONTINUE EHI = EIGENS(I,L) IF (I.GE.NRANG2) GOTO 140 ELO = EHI I = I + 1 GOTO 130 C 140 CONTINUE EBUT = HALF* (ELO+EHI) C ELSE C C GO BACK FROM FIRST POLE HALF THE DISTANCE BETWEEN THE FIRST C AND THE SECOND POLES C EHALF = TENTH IF (NRANG2.GE.2) EHALF = (EIGENS(2,L)-ELO)*HALF EBUT = ELO - EHALF ENDIF C EH = ZERO CALL BASFUN(NBT,L1,NODE,RA,BSTO,EBUT,DELTA,EH) C NPTS = IRX(NIX) + 1 D = RA/ ((BVALUE-BSTO)*ORB(NPTS)) DO 150 I = 1,NPTS ORB(I) = ORB(I)*D 150 CONTINUE 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 170 J = 1,NRANG2 D = ENDS(J,L)/ (EBUT-EIGENS(J,L)) IF(ISMITN.LE.0.OR.ITEST.EQ.0)NQ = IPOS(N1+J,L) DO 160 I = 1,NPTS IF(ISMITN.GT.0.AND.ITEST.GT.0)THEN SUM=ZERO DO 165 K=1,NRANG2 K1=JPOS(K) SUM=SUM+B(K,J,L)*UJ(I,K1) 165 CONTINUE ELSE SUM=UJ(I,NQ) ENDIF ORB(I) = SUM*D + ORB(I) 160 CONTINUE 170 CONTINUE C C PLUS ......(ISMITN=-1) NRB C IF(ITEST0.GT.0)THEN DO 180 J=1,ITEST0 D=BUTEND(J)/(EBUT-BUTEIG(J)) DO 190 I=1,NPTS ORB(I)=BUTORB(I,J)*D+ORB(I) 190 CONTINUE 180 CONTINUE ENDIF C C NOW HAVE THE NRANG2+1+ITEST0 TO INFINITY SUM IN ORB(). C C 3000 FORMAT (6X,'CORRECTIONS CALCULATED IN ENERGY RANGE',E12.4,' TO', A E12.4) 3010 FORMAT (5X, A ' SUBROUTINE NEWBUT - CANNOT EVALUATE BUTTLE CORRECTION FOR L =' B ,I3,' AND ENERGY',F15.7,' RYD.') 3020 FORMAT (/' BUTTLE CORRECTION COEFFICIENTS FOR L=',I3/) 3030 FORMAT (6X,'BSTO.NE.0. .OR. MJS=0, QUADRATIC FIT USED,', A' COEFFICIENTS ARE'/11X,3E13.4) 3040 FORMAT (//5X, A '*** WARNING *** RANGE EK2MIN TO EK2MAX IS TOO SMALL'/17X, B 'CANNOT CALCULATE BUTTLE CORRECTION'//) 3050 FORMAT (//6X,'*** WARNING *** EK2MIN =',E16.6, A ' IS .GT. EK2MAX =',E16.6/17X, B 'CANNOT CALCULATE BUTTLE CORRECTION'//) 3060 FORMAT (6X,'BSTO.EQ.0., MJS FIT USED, ALPHA =',F9.5,' BETA =', A E12.4/32X,'NBUT =',I4,' - CONVERGED IF NBUT POSITIVE') 3070 FORMAT (6X,'LARGEST ERROR IN FIT =',1P,E13.5,' (INT',2E12.5,')') END C C C SUBROUTINE ONEELE(N11,L1,N12,L2,ALBVAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) C DIMENSION ADD(MZNPT) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /DPOLE/ALFD,RCUT,IPLCR,IPLFN,IKMX,IORB(MXORB) COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /YKSTOR/YK(MZNPT),TEST1 COMMON /NRBOCC/TOCC(MXORB),IMAXN,IBANDW C C----------------------------------------------------------------------- DPOL1(X)=ALFD*(ONE-EXP(-(X/RCUT)**6))/X**4 DPOL2(X)=ALFD*X*X/(X*X+RCUT*RCUT)**3 C----------------------------------------------------------------------- C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE C ALBVAL = ZERO IF (L1.NE.L2) GOTO 160 SUM = ZERO C C DEFINE THE POSITION OF THE MODEL POTENTIAL IN THE POTHAM ARRAY. C LX = LPOSX(L1) ZN = NZ C C ITEST DETERMINES WHETHER SCHMIDT ORTHOGONALIZATION IS USED C MAXHF = L1 - 1 IF (L1.LE.LRANG1) MAXHF = MAXNHF(L1) MAXLG = MAXHF IF (L1.LE.LRANG1) MAXLG = MAXNLG(L1) + MAXNCB(L1) ITEST = MAXHF - MAXLG ISMIT0=ISMITN IF(ITEST.EQ.0)ISMIT0=0 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 N1 = N11 N2 = N12 IF (N2.LE.MAXHF) GOTO 10 IF (N1.GT.MAXHF.AND.ISMIT0.EQ.0) GOTO 50 N1 = N12 N2 = N11 10 CONTINUE I1 = IPOS(N1,L1) I2 = IPOS(N2,L2) C C CARRY OUT THE INTEGRATION USING SIMPSONS RULE C DO 20 I = 2,NPTS SUM = UJ(I,I1)*DUJ(I,I2)*WT(I) + SUM 20 CONTINUE C C ADD-IN MODEL POTENTIAL CONTRIB C IF (IPSEUD.NE.0) THEN DO 30 I = 2,NPTS SUM = (ZN-POTHAM(I,LX))*UJ(I,I1)*UJ(I,I2)*WT(I)*TWO/XR(I)+ SUM 30 CONTINUE ENDIF C ALBVAL = SUM C C ADD-IN DPOL~ALPHAD/R**4 FOR NON-CORE (B&W) ORBS C IF(ALFD*RCUT.GT.ZERO.AND.TOCC(I2).LE.PT0001)THEN IF(N1.LE.MAXHF)THEN IF(TOCC(I1).GT.PT0001)GO TO 40 ENDIF IF(IPLFN.EQ.1) THEN DO J=2,NPTS ADD(J)=UJ(J,I1)*UJ(J,I2)*WT(J)*DPOL1(XR(J)) ENDDO ELSE DO J=2,NPTS ADD(J)=UJ(J,I1)*UJ(J,I2)*WT(J)*DPOL2(XR(J)) ENDDO ENDIF SUM = ZERO DO J = 2,NPTS SUM = SUM + ADD(J) ENDDO ALBVAL = ALBVAL - SUM ENDIF C 40 CONTINUE GOTO 150 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 50 CONTINUE I1 = IPOS(N1,L1) I2 = IPOS(N2,L2) C C FIRST EVALUATE CONTRIBUTION FROM THE CONTINUUM ORBITALS USING C SIMPSONS RULE, USING THE PX ARRAY SET UP IN SUBROUTINE POTF. C IF (IPSEUD.EQ.0) THEN DO 70 J = 2,NPTS ADD(J) = UJ(J,I1)*UJ(J,I2)*PX(J) 70 CONTINUE C ELSE DO 80 J = 2,NPTS ADD(J) = (2*POTHAM(J,LX)/XR(J)-POVALU(2*J-2))*WT(J)*UJ(J,I1)* A UJ(J,I2) 80 CONTINUE ENDIF C C DPOL~ALPHAD/R**4 C IF(ALFD*RCUT.GT.ZERO)THEN IF(IPLFN.EQ.1) THEN DO J=2,NPTS ADD(J)=ADD(J)+UJ(J,I1)*UJ(J,I2)*WT(J)*DPOL1(XR(J)) ENDDO ELSE DO J=2,NPTS ADD(J)=ADD(J)+UJ(J,I1)*UJ(J,I2)*WT(J)*DPOL2(XR(J)) ENDDO ENDIF ENDIF C DO 90 J = 2,NPTS SUM = SUM + ADD(J) 90 CONTINUE ALBVAL = -SUM C C *** END OF CRAY CODING. C C NOW ADD IN ENERGY TERM C N1P = N1 - MAXHF + ITEST IF (ITEST.GT.0) GOTO 100 IF (N1.EQ.N2) ALBVAL = ALBVAL + EIGENS(N1P,L1) GOTO 150 C 100 CONTINUE N2P = N2 - MAXHF + ITEST N4P = N2 - MAXHF DO 110 I = 1,N4P ALBVAL = ALBVAL + B(N1P,I+ITEST,L1)*B(N2P,I+ITEST,L1)* A EIGENS(I,L1) 110 CONTINUE DO 140 I = 1,ITEST DO 120 J = 1,N4P ALBVAL = ALBVAL + B(N1P,I,L1)*B(N2P,J+ITEST,L1)* A OVRLAP(J,I,L1)*EIGENS(J,L1) 120 CONTINUE C C AND ADD IN CONTRIBUTION FROM THE BOUND ORBITALS USING C SIMPSONS RULE C I2 = IPOS(I+MAXLG,L2) SUM = ZERO DO 130 J = 2,NPTS SUM = (DUJ(J,I2)*WT(J)+PX(J)*UJ(J,I2))*UJ(J,I1) + SUM 130 CONTINUE ALBVAL = ALBVAL + SUM*B(N2P,I,L1) 140 CONTINUE C 150 CONTINUE ALBVAL = ALBVAL/TWO TEST1 = TEST1 + ALBVAL 160 CONTINUE C END C C C FUNCTION ORNO(J,K,N,L) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C COMMON /FACT/GAMMA(MZFAC) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C PARAMETER (ZERO=0.0D0) C----------------------------------------------------------------------- X = ZERO M1 = NLIMIT* (L-1) + K M2 = NCOEFF* (M1+N-K-1) + J M = NCO(M1) ZECOMM = ZE(M2) IRCOMM = IRAD(M2) DO 10 II = 1,M M3 = NCOEFF* (M1-1) + II IJ = IRCOMM + IRAD(M3) + 1 X = X + C(M3)*GAMMA(IJ)/ (ZECOMM+ZE(M3))**IJ 10 CONTINUE C ORNO = X C END C C C FUNCTION PHASE(LP,W) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C PARAMETER (ZERO=0.0D0) PARAMETER (ONE=1.0D0) PARAMETER (THREE=3.0D0) PARAMETER (SIX=6.0D0) C----------------------------------------------------------------------- PHASE = ZERO IF (LP.GT.3 .OR. W.LE.ZERO) GOTO 10 WR = SQRT(W)*RA V1 = COS(WR) V2 = SIN(WR) IF (LP.EQ.1) THEN C C S-WAVE EIGENPHASE C X1 = V1 X2 = V2 X3 = -V1 X4 = V2 C ELSE IF (LP.EQ.2) THEN C C P-WAVE EIGENPHASE C W2 = WR*WR X1 = V1/WR + (ONE-ONE/W2)*V2 X2 = V2/WR - V1 X3 = -V1/WR - V2 X4 = V2/WR + (ONE/W2-ONE)*V1 C ELSE IF (LP.EQ.3) THEN C C D-WAVE EIGENPHASE C W2 = WR*WR W3 = W2*WR X1 = (SIX/W2-ONE)*V1 - (SIX/W3-THREE/WR)*V2 X2 = (THREE/W2-ONE)*V2 - THREE*V1/WR X3 = - (THREE/W2-ONE)*V1 - THREE*V2/WR X4 = (SIX/W3-THREE/WR)*V1 + (SIX/W2-ONE)*V2 ENDIF C RATIO = (WR*X1-BSTO*X2)/ (WR*X4-BSTO*X3) PHASE = ATAN(RATIO) 10 CONTINUE C END SUBROUTINE POTF IMPLICIT REAL*8 (A-H,O-Z) C C C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXPT2=2*MZNPT) C DIMENSION NSHELL(13),LSHELL(13) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /FACT/GAMMA(MZFAC) 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(MXPT2),PX(MZNPT) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS C PARAMETER (ZERO=0.0D0) PARAMETER (HALF=0.5D0) PARAMETER (TWO=2.0D0) C 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, A 1,0,3/,MAXELC/26/ C----------------------------------------------------------------------- C C INITIALIZATION C WRITE (IWRITE,3000) NPOT I9 = (NPTS-1)*2 ZN = NZ IF (NPOT.GT.0) GOTO 110 IF (NPOT.LT.0) GOTO 120 IFLG = 0 NSOFAR = 0 DO 10 I = 1,I9 POVALU(I) = ZERO 10 CONTINUE C C LOOP OVER EACH SHELL IN THE GIVEN N,L ORDER C IF (NELCOR.GT.MAXELC .OR. NBUG4.GT.0) READ (IREAD,*) (NSHELL(I), A LSHELL(I),I=1,13) DO 80 ISHELL = 1,12 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) GOTO 20 IFLG = 1 NMO = NSOFAR - NELCOR AM = AM - NMO 20 CONTINUE 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 70 I = 1,I9 J = (I+2)/2 R = XR(J) IF (MOD(I,2).NE.0) R = (XR(J+1)+R)*HALF COOL = ZERO IF (IFLG.EQ.1) COOL = ZN/R T1 = ZERO T2 = ZERO C DO 60 J1 = 1,NCR JK = J1 + NCOEFF* (M1R-1) C1 = C(JK) I1 = IRAD(JK) Z1 = ZE(JK) DO 50 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 RZ = R*Z2 IF (RZ.GT.150.0D0) GOTO 50 SUM = ZERO DO 30 K = 1,L SUM = RZ** (K-1)/GAMMA(K) + SUM 30 CONTINUE T1 = T1 - C12*EXP(-RZ)*SUM/Z2**L SUM = ZERO DO 40 K = 1,N SUM = RZ** (K-1)/GAMMA(K) + SUM 40 CONTINUE T2 = T2 + GAMMA(N)*EXP(-RZ)*SUM*C1*C2/Z2**N 50 CONTINUE 60 CONTINUE C ARE = R**LDA V = T1/ (ARE*R) + T2*ARE POVALU(I) = POVALU(I) - TWO* (V*AM-COOL) 70 CONTINUE C IF (IFLG.EQ.1) GOTO 90 80 CONTINUE C C DEFINE THE PX ARRAY FOR USE IN THE ONE-ELECTRON INTEGRAL C 90 CONTINUE IF (NBUG5.GT.1) WRITE (IWRITE,3010) (POVALU(I),I=1,I9,4) ZN = (NZ+NZ) DO 100 J = 2,NPTS PX(J) = (ZN/XR(J)-POVALU(2*J-2))*WT(J) 100 CONTINUE RETURN C C PARAMETRIC POTENTIAL, ALSO IF TARGET ORBITALS USER-SUPPLIED: C 110 CONTINUE WRITE (IWRITE,3020) (IPOT(I),I=1,NPOT) WRITE (IWRITE,3030) (CPOT(I),I=1,NPOT) WRITE (IWRITE,3040) (XPOT(I),I=1,NPOT) 120 CONTINUE DO 160 I = 1,I9 J = (I+2)/2 X = XR(J) IF (MOD(I,2).NE.0) X = (XR(J+1)+X)*HALF Y = ZERO IF (NPOT.LT.0) GOTO 140 DO 130 K = 1,NPOT Y = CPOT(K)*X**IPOT(K)*EXP(-XPOT(K)*X) + Y 130 CONTINUE GOTO 150 C 140 CONTINUE Y = (((PX(J)-ZN)*NELC)/ (NELC-1)+ZN)*2.D0/X 150 POVALU(I) = Y 160 CONTINUE GOTO 90 C 3000 FORMAT (/30X,'SUBROUTINE POTF: NPOT =',I3/30X,15 ('-')) 3010 FORMAT (5E16.8) 3020 FORMAT (' IPOT=',9I12) 3030 FORMAT (' CPOT=',9F12.7) 3040 FORMAT (' XPOT=',9F12.7) END C C C SUBROUTINE RADINT(N1,L1,N2,L2,K,X) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /YKSTOR/YK(MZNPT),TEST1 C----------------------------------------------------------------------- X = 0.0D0 C J1 = IPOS(N1,L1) J2 = IPOS(N2,L2) C DO 10 I = 2,NPTS X = WT(I)*UJ(I,J1)*UJ(I,J2)*RK(I,K) + X 10 CONTINUE C TEST1 = TEST1 + X C END C C C SUBROUTINE RDAR(N1,L1,N2,L2,RLBVAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES THE RELATIVISTIC ONE-BODY DARWIN TERM; C THIS ONLY AFFECTS S-WAVE ORBITALS AT THE ORIGIN. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /NRBREL/NREL C PARAMETER (ZERO=0.0D0) PARAMETER (EIGHT=8.0D0) PARAMETER (FSC=7.2973525D-3) C----------------------------------------------------------------------- C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE. C RLBVAL = ZERO IF (L1.NE.L2 .OR. L1.NE.1) GOTO 10 C IF(NREL.GT.0)THEN MAXHF = L1 - 1 IF (L1.LE.LRANG1) MAXHF = MAXNHF(L1) ITEST = 1 IF (N1.GT.MAXHF) ITEST = ITEST + 1 IF (N2.GT.MAXHF) ITEST = ITEST + 1 IF (ITEST.LE.2) GO TO 10 ENDIF C K1 = IPOS(N1,L1) K2 = IPOS(N2,L2) RLBVAL = NZ*FSC*FSC*UJ(1,K1)*UJ(1,K2)/EIGHT C 10 CONTINUE C END C C C SUBROUTINE RECOV2(SUBNAM,PARNAM,IDIM,NEED) C----------------------------------------------------------------------- C C THIS ROUTINE IS CALLED ONLY FOR ARRAY OVERFLOW C C SUBNAM = SUBROUTINE NAME C PARNAM = PARAMETER NAME C IDIM = CURRENT DIMENSION C NEED = REQUIRED DIMENSION, RETURN NEED=IDIM C IPLACE = 0 TO STOP PROGRAM, C OTHERWISE RETURN IPLACE=NEED TO THE CALLING ROUTINE. C C----------------------------------------------------------------------- CHARACTER*6 SUBNAM,PARNAM,PREPRO C COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RECOV/IPLACE C----------------------------------------------------------------------- PREPRO = PARNAM C IF (PREPRO(1:3).EQ.'AMP') PREPRO(1:3) = ' MZ' WRITE (IWRITE,3000) SUBNAM,PREPRO,IDIM,PREPRO,NEED C IF (IPLACE.EQ.0) THEN WRITE (IWRITE,3010) STOP ENDIF C IF (IPLACE.LT.0) WRITE (IWRITE,3020) IPLACE = NEED NEED = IDIM C 3000 FORMAT (/' * ARRAY OVERFLOW IN ', A A6/' MUST INCREASE DIMENSION GIVEN BY ',A6,' =',I7, B ' TO AT LEAST ',A6,' =',I9) 3010 FORMAT (/' PROGRAM TERMINATES IN RECOV2'/) 3020 FORMAT (/' CHECK TO SEE IF OTHER ARRAYS ARE GOING TO BE EXCEEDED') END C C C SUBROUTINE RMASS(N11,L1,N22,L2,RLBVAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES THE RELATIVISTIC MASS-CORRECTION TERM C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXN11=MZNR1+1) PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /REL1/RLAMDA(MZLR2,MZNR2,MXN11) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /NRBREL/NREL C DIMENSION X(2),IX(2) C PARAMETER (ZERO=0.0D0) PARAMETER (FSC=7.2973525D-3) C DATA IWARN/0/ C C----------------------------------------------------------------------- C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE. C RLBVAL = ZERO IF (L1.NE.L2) GOTO 180 SUM = ZERO C TWOZ = 2*NZ LLL = LPOSX(L1) MAXLG = MAXNLG(L1) + MAXNCB(L1) MAXHF = L1 - 1 NBT = MAXLG - MAXHF ITEST=0 IF (L1.LE.LRANG1) THEN MAXHF = MAXNHF(L1) ITEST=MAXHF-MAXLG ENDIF ISMIT0=ISMITN IF(ITEST.EQ.0)ISMIT0=0 IF(ITEST.NE.0.AND.ISMITN.EQ.0.AND.IWARN.EQ.0)THEN IWARN=1 WRITE(6,1000) 1000 FORMAT(///' *******WARNING*********'//' CONTINUUM' X,' ORBITALS HAVE BEEN SCHMIDT ORTHOGONALIZED BUT' X,' MASS-VELOCITY CONTRIBUTION NOT CODED FOR THE'/ X,' RECURSION OPTION:*** SET ISMITN=1 INSTEAD ***' X,' NO MORE WARNINGS GIVEN.') ENDIF C C DETERMINE WHETHER THE ORBITALS ARE BOUND-BOUND, BOUND-CONTINUUM C OR CONTINUUM-CONTINUUM C N1 = N11 N2 = N22 ISWTCH = 1 IF(ISMIT0.NE.0)GO TO 10 IF (N1.GT.MAXHF) ISWTCH = ISWTCH + 1 IF (N2.GT.MAXHF) ISWTCH = ISWTCH + 1 C C IF ISWTCH=1 BOUND-BOUND C =2 BOUND-CONTINUUM OR CONTINUUM-BOUND C =3 CONTINUUM-CONTINUUM C IF (ISWTCH.GT.2) GOTO 110 IF (NREL.GT.0.AND.ISWTCH.LE.2) GO TO 180 C C PREPARE DATA INVOLVING ONE OR TWO BOUND STATE ORBITALS C IF (N2.LE.MAXHF) GOTO 10 C C PLACE THE BOUND ORBITAL IN C THE SECOND POSITION DEFINED BY (N2,L2): C N1 = N22 N2 = N11 C 10 CONTINUE 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 20 I = 2,ISWTCH,-1 X(I) = 0.0D0 IF (L1.NE.1) GOTO 20 X(I) = DUJ(1,IX(I)) CX PV=ZERO -- CORRECTED FOR ORBITALS BEYOND N,L=1S WE'90MAY10TH: 20 CONTINUE IF (ISWTCH.EQ.2) GOTO 60 C ELSE C C NUMERIC BOUND ORBITALS ARE BEING USED (CORRECTED WE'90MAY12) C X(2) = -TWOZ*UJ(1,IX(2)) IF (ISWTCH.EQ.2) GOTO 60 IF (L1.NE.1) GOTO 30 X(1) = -TWOZ*UJ(1,IX(1)) ENDIF 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 30 CONTINUE IF (IPSEUD.EQ.0.OR.NCOEFF.EQ.0) THEN ! NRB 24/10/94 FOR SS M.P. DO 40 I = 2,NPTS SUM = (TWOZ*UJ(I,IX(1))/XR(I)+DUJ(I,IX(1)))* A (TWOZ*UJ(I,IX(2))/XR(I)+DUJ(I,IX(2)))*WT(I) + SUM 40 CONTINUE C ELSE DO 50 I = 2,NPTS SUM = POTHAM(I,LLL)*POTHAM(I,LLL)*4.D0/ (XR(I)*XR(I))* A UJ(I,IX(1))*UJ(I,IX(2))*WT(I) + SUM 50 CONTINUE ENDIF C GOTO 170 C C IN THIS CASE ONE OF THE ORBITALS IS BOUND AND THE OTHER IS C CONTINUUM C 60 CONTINUE NN = N1 - MAXHF I1 = IX(1) IF (L1.NE.1) GOTO 70 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*UJ(1,I1)*X(2)*WT(1) C C CARRY OUT THE INTEGRATION USING SIMPSONS RULE. C 70 CONTINUE I2 = IX(2) C DO 100 I = 2,NPTS C C EVALUATE THE SECOND DERIVATIVE OF THE BOUND ORBITAL C IF (IPSEUD.EQ.0.OR.NCOEFF.EQ.0) THEN X1 = -TWOZ*UJ(I,I2)/XR(I) - DUJ(I,I2) C ELSE X1 = -POTHAM(I,LLL)*UJ(I,I2)*2.D0/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) GOTO 90 DO 80 J = L1,MAXLG J2 = IPOS(J,L1) X2 = X2 + UJ(I,J2)*RLAMDA(L1,NN,J-L1+1) 80 CONTINUE C C ADD IN THE CONTRIBUTIONS. C 90 SUM = SUM + X1*X2*WT(I) 100 CONTINUE GOTO 170 C C BOTH ORBITALS ARE CONTINUUM ORBITALS C 110 CONTINUE M1 = N1 - MAXHF M2 = N2 - MAXHF I1 = IPOS(N1,L1) I2 = IPOS(N2,L2) IF (L1.NE.1) GOTO 120 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 120 CONTINUE EIG = EIGENS(M1,L1) + EIGENS(M2,L2) DO 150 I = 2,NPTS C C EVALUATE THE SUMMATIONS INVOLVING THE LAGRANGE MULTIPLIERS C X1 = 0.0D0 X2 = 0.0D0 IF (NBT.EQ.0) GOTO 140 DO 130 J = L1,MAXLG NN = IPOS(J,L1) X1 = X1 + UJ(I,NN)*RLAMDA(L1,M1,J-L1+1) X2 = X2 + UJ(I,NN)*RLAMDA(L2,M2,J-L1+1) 130 CONTINUE 140 CONTINUE PO = POVALU(2* (I-1)) U1 = UJ(I,I1) U2 = UJ(I,I2) SUM = ((PO+EIG)*U1*U2-X1*U2-X2*U1)*PO*WT(I) + SUM 150 CONTINUE C C THIS IS INCORRECT - NRB C IF (N1.EQ.N2) SUM = EIG + SUM C THIS IS CORRECT - NRB IF (N1.EQ.N2) SUM = EIGENS(M1,L1) * EIGENS(M2,L2) + SUM C IF (NBT.EQ.0) GOTO 170 DO 160 J = L1,MAXLG SUM = RLAMDA(L1,M1,J-L1+1)*RLAMDA(L2,M2,J-L1+1) + SUM 160 CONTINUE 170 CONTINUE RLBVAL = -SUM*FSC*FSC/8.D0 180 CONTINUE C END C C C SUBROUTINE ROOT(T,FT,B,C,RELERR,ABSERR,IFLAG) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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 METHOF OF SOLUTION IS A COMBINATION OF BISECTION AND THE SECANT RULE. C C NORMAL INPUT CONSISTS OF A CONTINUOUS FUNCTION F AND IN 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 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 C*********************************************************************** C THE ONLY MACHINE DEPENDENT CONSTANT IS BASED ON THE MACHINE UNIT * C ROUNDOFF ERROR U. IT IS CALCULATED IN THE SUBROUTINE M A C H I N * C WHICH MUST HAVE BEEN CALLED BEFORE THE FIRST CALL OF R O O T. * C NOTE....IN THIS CODE MACHIN IS NOT CALLED BUT U IS SET TO 1.0E-12 * C IN THE PARAMETER STATEMENT BELOW. * C*********************************************************************** C C----------------------------------------------------------------------- PARAMETER (ZERO=0.0D0,ONE=1.0D0, A EIGHT=8.0D0,HALF=0.5D0, B U=1.0D-12) C SAVE RE,AE,IC,ACBS,A,FA,FC,FX,KOUNT C----------------------------------------------------------------------- IF (IFLAG.GE.0) GOTO 10 IFLAG = ABS(IFLAG) IF (IFLAG-2) 20,30,110 10 CONTINUE RE = MAX(RELERR,U) AE = MAX(ABSERR,ZERO) IC = 0 ACBS = ABS(B-C) A = C T = A IFLAG = -1 GOTO 170 C 20 CONTINUE FA = FT T = B IFLAG = -2 GOTO 170 C 30 CONTINUE FB = FT FC = FA KOUNT = 2 FX = MAX(ABS(FB),ABS(FC)) 40 CONTINUE IF (ABS(FC).GE.ABS(FB)) GOTO 50 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 50 CONTINUE CMB = HALF* (C-B) ACMB = ABS(CMB) TOL = RE*ABS(B) + AE C C TEST STOPPING CRITERION AND FUNCTION COUNT C IF (ACMB.LE.TOL) GOTO 120 IF (KOUNT.GE.500) GOTO 160 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.ZERO) GOTO 60 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 60 CONTINUE A = B FA = FB IC = IC + 1 IF (IC.LT.4) GOTO 70 IF (EIGHT*ACMB.GE.ACBS) GOTO 90 IC = 0 ACBS = ACMB C C TEST FOR TOO SMALL A CHANGE C 70 CONTINUE IF (P.GT.ABS(Q)*TOL) GOTO 80 C C INCREMENT BY TOLERANCE C B = B + SIGN(TOL,CMB) GOTO 100 C C ROOT OUGHT TO BE BETWEEN B AND (C+B)/2 C 80 CONTINUE IF (P.GE.CMB*Q) GOTO 90 C C USE SECANT RULE C B = B + P/Q GOTO 100 C C USE BISECTION C 90 CONTINUE B = HALF* (C+B) C C HAVE COMPLETED COMPUTATION OF NEW ITERATE B C 100 CONTINUE T = B IFLAG = -3 GOTO 170 C 110 CONTINUE FB = FT IF (FB.EQ.ZERO) GOTO 130 KOUNT = KOUNT + 1 IF (SIGN(ONE,FB).NE.SIGN(ONE,FC)) GOTO 40 C = A FC = FA GOTO 40 C C FINISHED. SET IFLAG C 120 CONTINUE IF (SIGN(ONE,FB).EQ.SIGN(ONE,FC)) GOTO 150 IF (ABS(FB).GT.FX) GOTO 140 IFLAG = 1 GOTO 170 C 130 CONTINUE IFLAG = 2 GOTO 170 C 140 CONTINUE IFLAG = 3 GOTO 170 C 150 CONTINUE IFLAG = 4 GOTO 170 C 160 CONTINUE IFLAG = 5 170 CONTINUE C END C C C SUBROUTINE RS(N2,L2,N1,L1,N4,L4,N3,L3,K,MODE,RKVAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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 OR MAGNETIC N-INTEGRALS IF MODE=+1, V-INTEGRALS IF MODE=-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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) C DIMENSION SUM1(MZNPT),SUM2(MZNPT),RT(MZNPT),AR(MZNPT) C COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /DPOLE/ALFD,RCUT,IPLCR,IPLFN,IKMX,IORB(MXORB) COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /YKSTOR/YK(MZNPT),TEST1 C SAVE JN2,JL2,JN4,JL4,JKM,MODE1 C PARAMETER (TWELTH=0.08333333333333D0) C DATA MODE1/999/ C----------------------------------------------------------------------- DPOL1(X)=SQRT(ONE-EXP(-(X/RCUT)**6))/X**2 DPOL2(X)=X/(X*X+RCUT*RCUT)**1.5 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 DO NOT RECALCULATE THE YK INTEGRAL IF IT ALREADY EXISTS C IF (MODE.EQ.MODE1) THEN IF (N2.EQ.JN2 .AND. L2.EQ.JL2 .AND. K.EQ.JKM .AND. A N4.EQ.JN4 .AND. L4.EQ.JL4) GOTO 120 ENDIF C MODE1 = MODE JN2 = N2 JL2 = L2 JN4 = N4 JL4 = L4 JKM = K K1 = K + 1 IF (MODE.NE.0) K1 = K + 3 C C INITIALIZATION C ARA = ZERO J2 = IPOS(N2,L2) J4 = IPOS(N4,L4) IF (MODE.GE.0) THEN DO 10 J = 2,NPTS SUM1(J) = UJ(J,J2)*UJ(J,J4) 10 CONTINUE C ELSE C C COMPUTE MAGNETIC V-INTEGRALS FOR BLUME-WATSON SCREENING (MODE=-1) C CALL DERINT(0,0,N4,L4,DUM) DO 20 J = 2,NPTS SUM1(J) = (YK(J)-UJ(J,J4)/XR(J))*UJ(J,J2) 20 CONTINUE ENDIF C DO 30 J = 2,NPTS RT(J) = SUM1(J)*RK(J,K) AR(J) = SUM1(J)*RK(J,-K1) 30 CONTINUE C C SIMPSONS RULE INTEGRATION FROM 0 TO RA=XR(NPTS) C DO 40 J = 2,NPTS SUM2(J) = WT(J)*AR(J) 40 CONTINUE ckab delete the following c DO 50 J = 2,NPTS c ARA = ARA + SUM2(J) c 50 CONTINUE ckab C C SIMPSONS RULE INTEGRATIONS FROM 0 TO R C RT(1) = ZERO AR(1) = ZERO RIN = ZERO DO 60 J = 3,NPTS,2 SUM1(J) = STEP(J)*THIRD* (RT(J-2)+FOUR*RT(J-1)+RT(J)) SUM2(J) = STEP(J)*THIRD* (AR(J-2)+FOUR*AR(J-1)+AR(J)) 60 CONTINUE DO 70 J = 3,NPTS,2 SUM1(J-1) = STEP(J-1)*TWELTH* (FIVE*RT(J-2)+EIGHT*RT(J-1)-RT(J)) SUM2(J-1) = STEP(J-1)*TWELTH* (FIVE*AR(J-2)+EIGHT*AR(J-1)-AR(J)) 70 CONTINUE ckab delete the following c DO 80 J = 3,NPTS,2 c RT(J-1) = RIN + SUM1(J-1) c RIN = RIN + SUM1(J) c RT(J) = RIN c AR(J-1) = ARA - SUM2(J-1) c ARA = ARA - SUM2(J) c AR(J) = ARA c 80 CONTINUE c IF (MODE.EQ.0) THEN c DO 90 J = 2,NPTS c YK(J) = (RT(J)*RK(J,-K1)+AR(J)*RK(J,K))*WT(J) c 90 CONTINUE ckab insert the following, modified by nrb 25/06/08 ar(NPTS) = 0 do j = NPTS, 3, -2 ar(j-2) = ar(j) + SUM2(j) AR(J-1) = ar(J-2) - SUM2(J-1) enddo c nmax=0 if(mode.eq.0)then !only use for Slater in production code lp=l2+l4 !nrb if(mode.lt.0)lp=lp-1 m11 = k + lp + 1 nmax = max( int(ONE/(THREE**(ONE/float(m11)) - ONE)), 0) !m->m11 if( mod(nmax,2).eq.1 ) nmax = nmax - 1 do j = 1, nmax !NPTS SUM2(J) = UJ(J,J2)*UJ(J,J4) enddo call ynear0(k,lp,npts-1,XR(2),SUM2(2),RT(2),AR(2),nmax,mode) endif c nmax = nmax + 1 do j = nmax, NPTS AR(j) = AR(j)*RK(j,K) enddo RIN = 0 if( nmax.gt.1 ) RIN = RT(nmax)/RK(nmax,-K1) do j = nmax + 2, NPTS, 2 RT(j-1) = (RIN + SUM1(j-1))*RK(j-1,-K1) RIN = RIN + SUM1(j) RT(j) = RIN*RK(j,-K1) enddo IF (MODE.EQ.0) THEN do j = 2, NPTS YK(j)= (RT(j) + AR(j))*WT(j) c write(31,9)XR(j),RT(j)+AR(j),RT(j),AR(j) enddo ckab GOTO 120 ENDIF C C COMPUTE MAGNETIC INTEGRALS FOR BLUME-WATSON SCREENING C IF (MODE.LT.0) THEN DO 100 J = 2,NPTS ckab replace the following c YK(J) = (RT(J)*RK(J,-K1)+AR(J)*RK(J,K))*XR(J)*WT(J) YK(J) = (RT(J) + AR(J))*XR(J)*WT(J) ckab 100 CONTINUE C ELSE DO 110 J = 2,NPTS ckab replace the following c YK(J) = AR(J)*RK(J,K)*WT(J) YK(J) = AR(J)*WT(J) ckab 110 CONTINUE ENDIF C C EVALUATE THE SLATER INTEGRAL C 120 CONTINUE RKVAL = ZERO J1 = IPOS(N1,L1) J3 = IPOS(N3,L3) DO 130 J = 2,NPTS RKVAL = RKVAL + UJ(J,J1)*UJ(J,J3)*YK(J) 130 CONTINUE C TEST1 = TEST1 + RKVAL !Was commented-out in parallel... C C DIELECTRIC POLARIZATION POTENTIAL C IF(MODE.EQ.0.AND.ALFD*RCUT.GT.ZERO.AND.K.EQ.1)THEN IF(J1.LE.IKMX.AND.IORB(J1).LE.IPLCR)RETURN IF(J2.LE.IKMX.AND.IORB(J2).LE.IPLCR)RETURN IF(J3.LE.IKMX.AND.IORB(J3).LE.IPLCR)RETURN IF(J4.LE.IKMX.AND.IORB(J4).LE.IPLCR)RETURN B1=ZERO B2=ZERO IF(IPLFN.EQ.1) THEN DO J=2,NPTS T=DPOL1(XR(J))*WT(J) B1=B1+UJ(J,J1)*UJ(J,J3)*T B2=B2+UJ(J,J2)*UJ(J,J4)*T ENDDO ELSE DO J=2,NPTS T=DPOL2(XR(J))*WT(J) B1=B1+UJ(J,J1)*UJ(J,J3)*T B2=B2+UJ(J,J2)*UJ(J,J4)*T ENDDO ENDIF RKVAL=RKVAL-ALFD*B1*B2 ENDIF C RETURN C END C C C SUBROUTINE SCHMDT(LP) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN C----------------------------------------------------------------------- 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 20 I = 1,N DO 10 J = 1,N B(J,I,LP) = ZERO 10 CONTINUE B(I,I,LP) = ONE 20 CONTINUE C C CALCULATE THE SCHMIDT COEFFICIENTS C DO 80 I = 1,NRANG2 N2 = N1 + I - 1 ANORM = ONE DO 40 J = 1,N2 TEMP(J) = ZERO DO 30 K = 1,N1 TEMP(J) = TEMP(J) - B(J,K,LP)*OVRLAP(I,K,LP) 30 CONTINUE ANORM = ANORM - TEMP(J)*TEMP(J) 40 CONTINUE IF (ANORM.GT.PT01) GOTO 50 C C WRITE WARNING C WRITE(IWRITE,1000)LP-1,I,ANORM C IF(ANORM.LT.TINY)THEN C C AS SCHMDT FAILS BECAUSE NRANG2 IS TOO BIG. WE'89MAY/JUNE. C LP = -I GOTO 150 ENDIF 50 CONTINUE ANORM = ONE/SQRT(ANORM) DO 70 J = 1,N2 B(N2+1,J,LP) = ZERO DO 60 K = 1,N2 B(N2+1,J,LP) = B(N2+1,J,LP) + TEMP(K)*B(K,J,LP) 60 CONTINUE B(N2+1,J,LP) = B(N2+1,J,LP)*ANORM 70 CONTINUE B(N2+1,N2+1,LP) = ANORM 80 CONTINUE C C SCHMIDT ORTHOGONALIZE THE CONTINUUM ORBITALS C I1 = IPOS(MAXHF+1,LP) - 1 DO 140 I = 1,NPTS DO 90 J = 1,NRANG2 TEMP(J) = UJ(I,J+I1) 90 CONTINUE DO 130 J = 1,NRANG2 SUM = ZERO N2 = N1 + J DO 120 K = 1,N2 IF (K.LE.N1) GOTO 100 X1 = TEMP(K-N1) GOTO 110 C 100 CONTINUE I3 = IPOS(K+MAXLG,LP) X1 = UJ(I,I3) 110 SUM = X1*B(N2,K,LP) + SUM 120 CONTINUE UJ(I,J+I1) = SUM 130 CONTINUE 140 CONTINUE 150 CONTINUE C 1000 FORMAT(' ******* SCHMDT WARNING: L=',I2,3X,'N=',I2,3X X,'ANORM=',1PD10.2) C END SUBROUTINE SHMITN(LP) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C ORTHOGONALIZES THE CONTINUUM ORBITALS TO ALL OF THE BOUND C ORBITALS AS WELL AS CONTINUUM ORBITALS FOR ANGULAR MOMENTUM LP-1. C SECOND DERIVATIVE TREATED BY STORING (ORTHOGONALIZED) Q-FUNCTION. C NOTE THAT THE OVERLAPS ARE CALCULATED AT EACH STEP FOR STABILITY. C NRB 10/09/96 C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) CD PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH CD COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS C C----------------------------------------------------------------------- C L=LP-1 CD TNZ=NZ+NZ C C N1 IS THE NUMBER OF BOUND ORBITALS TO BE ORTHOGED TO: c ALL=MAXHF, WHILE SCHMIDT ONLY=MAXHF-MAXLG. C IN PRINCIPLE SHOULD ALREADY BE ORTHOGONAL TO LAGRANGED ORBITALS. C NPTS IS THE NUMBER OF INTEGRATION POINTS. C MAXHF = MAXNHF(LP) C TEST MAXLG=MAXNLG(LP) C C THIS STATEMENT ORTHOGONALZES TO ALL BOUND C N1=MAXHF-L C C THIS STATEMENT ORTHOGONALIZES TO THE ISMIT ORBITALS ONLY C C TEST N1=MAXHF-MAXLG C NL=MAXHF-N1 CD NPTS=IRX(NIX)+1 C C SCHMIDT ORTHOGONALIZE THE CONTINUUM ORBITALS C I1=IPOS(MAXHF+1,LP)-1 C DO 100 J=1,NRANG2 JI1=J+I1 N3=MAXHF+J C C ORTHOG P-FUNCTION (UJ) AND Q-FUNCTION (DUJ) C C FIRST TO THE BOUND ORBITALS C DO 120 K=1,N1 N4=K+NL I4=IPOS(N4,LP) CALL ABNORM(N3,LP,N4,LP,OVER) ANORM=ONE/SQRT(ONE-OVER*OVER) IF(UJ(2,JI1)-OVER*UJ(2,I4).LT.ZERO)ANORM=-ANORM DO 150 I=1,NPTS UJ(I,JI1)=(UJ(I,JI1)-OVER*UJ(I,I4))*ANORM DUJ(I,JI1)=(DUJ(I,JI1)-OVER*DUJ(I,I4))*ANORM 150 CONTINUE 120 CONTINUE C C THEN TO THE CONTINUUM ORBITALS C DO 140 K=1,J-1 N4=MAXHF+K I4=I1+K CALL ABNORM(N3,LP,N4,LP,OVER) ANORM=ONE/SQRT(ONE-OVER*OVER) IF(UJ(2,JI1)-OVER*UJ(2,I4).LT.ZERO)ANORM=-ANORM DO 160 I=1,NPTS UJ(I,JI1)=(UJ(I,JI1)-OVER*UJ(I,I4))*ANORM DUJ(I,JI1)=(DUJ(I,JI1)-OVER*DUJ(I,I4))*ANORM 160 CONTINUE 140 CONTINUE C C CHECK NORMALIZATION C CALL ABNORM(N3,LP,N3,LP,ANORM) C IF(NBUG5.LT.0)WRITE(6,*)J+N1,ANORM-ONE C IF(ABS(ANORM-ONE).GT.PT0001)THEN LP=-J RETURN ENDIF C ANORM=ONE/SQRT(ANORM) DO 170 I=1,NPTS UJ(I,JI1)=UJ(I,JI1)*ANORM DUJ(I,JI1)=DUJ(I,JI1)*ANORM 170 CONTINUE C CD P0=UJ(1,JI1) CD UJ(1,JI1)=ZERO C CD CALL DIFF2(UJ(1,JI1),DUJ(1,JI1)) C CD UJ(1,JI1)=P0 CD DUJ(1,JI1)=-TWO*NZ*UJ(1,JI1) C CD DO 180 I=2,NPTS CD DUJ(I,JI1)=-DUJ(I,JI1)+(L*LP/XR(I)-TNZ)*UJ(I,JI1)/XR(I) CD180 CONTINUE C 100 CONTINUE C RETURN END SUBROUTINE SHMITT(LP) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- 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 METHOD: DIAGONALIZES 1-MTM WHERE M IS THE MATRIX OF OVERLAPS. C CURRENTLY, THE OVERALL SIGN OF THE NEW ORBITALS IS NOT DETERMINED. C C TWG & NRB OCT-96 C C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /NRBBUT/BUTORB(MZNPT,MZNR1),BUTEND(MZNR1),BUTEIG(MZNR1), X EMIN,EMAX,TOLE,ITEST0,IMAX,JPOS(MXN3),MJS,NBOX(0:MZLR1) C DIMENSION XO(MXN3,MXN3),XL(MXN3),TUJ(MXN3),TDUJ(MXN3),NTEMP(MXN3) C C----------------------------------------------------------------------- C C TOLE=1.D-4 !DEFAULT C C NPTS IS THE NUMBER OF INTEGRATION POINTS C NPTS = IRX(NIX) + 1 C C N1 IS THE NUMBER OF (SCHMIDT) ORTHOGONALIZED BOUND ORBITALS AND C MAXHF = MAXNHF(LP) MAXLG = MAXNLG(LP) C C THIS IS TO SCHMIDT BOUND ORBITALS N1 = MAXHF - MAXLG C C THIS IS TO ALL BOUND ORBITALS (CHANGE BASORB AS WELL!!) C N1 = MAXHF -LP+1 C C SET-UP JPOS INDEX TO RUN OVER NEW BOUND-CONTINUUM BASIS C NL=MAXHF-N1 I1=IPOS(MAXHF+1,LP)-1 C DO 5 I=1,N1 JPOS(I)=IPOS(I+NL,LP) NTEMP(I)=I+NL ENDS(I+NRANG2,LP)=ZERO EIGENS(I+NRANG2,LP)=ZERO 5 CONTINUE DO 6 J=1,NRANG2 JPOS(J+N1)=I1+J NTEMP(J+N1)=MAXHF+J 6 CONTINUE C C C ZEROIZE THE B-ARRAY AND SET THE REQUIRED DIAGONAL ELEMENTS TO C UNITY C NN=NRANG2+N1 DO 20 I = 1,NN DO 10 J = 1,NN B(J,I,LP) = ZERO 10 CONTINUE IF(I.LE.N1)B(I,I,LP) = ONE 20 CONTINUE C C FORM MT*M C DO 30 I=1,NRANG2 DO 31 J=1,NRANG2 SUM=ZERO DO 32 K=1,N1 SUM=SUM+OVRLAP(I,K,LP)*OVRLAP(J,K,LP) 32 CONTINUE XO(I,J)=-SUM 31 CONTINUE XO(I,I)=XO(I,I)+ONE 30 CONTINUE C C FIND EIGENVALUES XL AND EIGENVECTOR MATRIX XO OF MT*M C CALL DIAG(NRANG2,XO,XL,TEMP,MXN3) C C MAKE THE B MATRIX C IX=0 DO 50 I=1,NRANG2 IF(NBUG5.EQ.-4)THEN WRITE(IWRITE,1004)I,XL(I) 1004 FORMAT(/'N=',I3,3X,'E-VALUE=',1PD15.8) WRITE(IWRITE,1005)(XO(J,I),J=1,NRANG2) 1005 FORMAT(10(1PD13.5)) ENDIF IF(XL(I).GT.TOLE)THEN FACT=ONE/SQRT(XL(I)) DO 51 J=1,NRANG2 B(I+N1,J+N1,LP)=XO(J,I)*FACT 51 CONTINUE DO 52 J=1,N1 SUM=ZERO DO 53 K=1,NRANG2 SUM=SUM+B(I+N1,K+N1,LP)*OVRLAP(K,J,LP) 53 CONTINUE B(I+N1,J,LP)=-SUM 52 CONTINUE ELSE IX=I ENDIF 50 CONTINUE C IF(IX.GT.0)THEN WRITE(IWRITE,1002)NRANG2,NRANG2-IX WRITE(IWRITE,1000)XL(IX) WRITE(IWRITE,1001)XL(IX+1) ENDIF C C TRANSFORM UJ AND DUJ. C THIS ALSO ZEROIZES THE LINEAR DEPENDENT ORBITALS. C DO 60 I=1,NPTS DO 61 J=1,NN J1=JPOS(J) TDUJ(J)=DUJ(I,J1) TUJ(J)=UJ(I,J1) 61 CONTINUE DO 62 J=1,NRANG2 J1=JPOS(J+N1) SUM=ZERO SUMD=ZERO DO 63 K=1,NN SUMD=SUMD+B(J+N1,K,LP)*TDUJ(K) SUM=SUM+B(J+N1,K,LP)*TUJ(K) 63 CONTINUE DUJ(I,J1)=SUMD UJ(I,J1)=SUM 62 CONTINUE 60 CONTINUE C C RE-INDEX TO KEEP ONLY LINEARLY IND E-VECTORS. C NOTE: THE TRANSFORMATION CAN INTRODUCE FALSE SHALLOW NODES C NEAR THE ORIGIN. THE TEST FOR A POSITIVE FUNCTION AT C THE ORIGIN SHOULD BE CARRIED OUT AT THE FIRST TURNING C POINT, WHICH DEPENDS ON THE ORBITAL I.E. I0=I0(I) C CSIGN I0=2 !SUITABLE FOR S- AND P-ORBITALS ONLY. NRANG2=0 DO 65 J=1,NN JI1=JPOS(J) IF(UJ(1,JI1).NE.ZERO)THEN NRANG2=NRANG2+1 JPOS(NRANG2)=JPOS(J) NTEMP(NRANG2)=NTEMP(J) CSIGN IF(UJ(I0,JI1).LT.ZERO)THEN CSIGN DO 67 I=1,NPTS CSIGN UJ(I,JI1)=-UJ(I,JI1) CSIGN DUJ(I,JI1)=-DUJ(I,JI1) CSIGN 67 CONTINUE CSIGN ENDIF ENDIF 65 CONTINUE C C NOW SET-UP AND DIAGONALIZE ONE-BODY ENERGY MATRIX C DO 190 I=1,NRANG2 I1=JPOS(I) DO 200 J=1,I J1=JPOS(J) SUM=ZERO DO 210 K=2,NPTS SUM=SUM+(DUJ(K,J1)*WT(K)+PX(K)*UJ(K,J1))*UJ(K,I1) 210 CONTINUE XO(I,J)=SUM XO(J,I)=SUM 200 CONTINUE 190 CONTINUE C CALL DIAG(NRANG2,XO,XL,TEMP,MXN3) C C CHECK WE HAVE RECOVERED ORIGINAL E-ENERGIES, BUT DO NOT OVERWRITE. C DO 195 I=1,NRANG2 TEMP(I)=ONE c write(iwrite,*)'***sr.shmitt: e-energy info for' c x ,i,EIGENS(I,LP),xl(i) IF(EIGENS(I,LP).EQ.ZERO)THEN EIGENS(I,LP)=XL(I) !XTRA, NOT IN ORIGINAL BASIS ELSE IF(ABS(XL(I)-EIGENS(I,LP)).LT.PT001)GO TO 195 WRITE(IWRITE,*)' SR.SHMITT: E-ENERGIES NOT RECOVERED FOR' X ,I,EIGENS(I,LP),XL(I) C STOP ENDIF 195 CONTINUE C C CHECK WE HAVE RECOVERED ORIGINAL ENDS(I,LP), BUT DO NOT OVERWRITE. C STORE TRANSFORMATION MATRIX FOR USE BY BUTTLE CORRECTION TO ORBITAL C M0=2 CSIGN N=I0 !SHOULD BE ORBITAL DEPENDENT CSIGN M0=1 C DO 212 M=M0,2 IF(M.EQ.2)N=NPTS DO 220 I=1,NRANG2 SUM=ZERO DO 230 J=1,NRANG2 J1=JPOS(J) SUM=SUM+XO(J,I)*UJ(N,J1) B(J,I,LP)=XO(J,I) 230 CONTINUE IF(M.EQ.1)THEN IF(SUM.LT.ZERO)THEN TEMP(I)=-ONE DO 232 J=1,NRANG2 B(J,I,LP)=-B(J,I,LP) 232 CONTINUE ELSE TEMP(I)=ONE ENDIF ELSE TEMP(I)=SUM*TEMP(I) c write(iwrite,*)'***sr.shmitt: ends info for',i,ENDS(I,LP),sum IF(ENDS(I,LP).EQ.ZERO)THEN ENDS(I,LP)=TEMP(I) !XTRA, NOT IN ORIGINAL BASIS ELSE CSIGN IF(ABS(TEMP(I)-ENDS(I,LP)).LT.PT01)GO TO 219 !AND REMOVE NEXT LINE IF(abs(ABS(TEMP(I))-ABS(ENDS(I,LP))).LT.PT01)GO TO 219 WRITE(IWRITE,*)' SR.SHMITT: ENDS NOT RECOVERED FOR' X ,I,ENDS(I,LP),TEMP(I) C STOP ENDIF 219 IF(ENDS(I,LP)*TEMP(I).LT.ZERO)ENDS(I,LP)=-ENDS(I,LP) ENDIF 220 CONTINUE 212 CONTINUE C C RENORMALIZE TO TAKE ACCOUNT OF NEGLECT OF E-VECTORS WITH SMALL C BUT NON-ZERO E-VALUES. C BIG=ZERO DO 240 J=N1+1,NRANG2 N3=NTEMP(J) JI1=JPOS(J) C CALL ABNORM(N3,LP,N3,LP,ANORM) C IF(ABS(ANORM-ONE).GT.PT01.AND.NBUG5.GE.0)NBUG5=-1 IF(ABS(ANORM-ONE).GT.BIG)THEN J0=JI1 K0=JI1 BIG=ABS(ANORM-ONE) ENDIF C ANORM=ONE/SQRT(ANORM) CSIGN IF(UJ(I0,JI1).LT.ZERO)ANORM=-ANORM DO 270 I=1,NPTS UJ(I,JI1)=UJ(I,JI1)*ANORM DUJ(I,JI1)=DUJ(I,JI1)*ANORM 270 CONTINUE C C DITTO, ORTHOGONALIZE. NOTE: THESE OVERLAPS SHOULD BE SMALL. C DO 140 K=N1+1,J-1 N4=NTEMP(K) KI1=JPOS(K) C CALL ABNORM(N3,LP,N4,LP,OVER) C IF(ABS(OVER).GT.PT01.AND.NBUG5.GE.0)NBUG5=-1 IF(ABS(OVER).GT.BIG)THEN J0=JI1 K0=KI1 BIG=ABS(OVER) ENDIF C ANORM=ONE/SQRT(ONE-OVER*OVER) CSIGN IF(UJ(I0,JI1)-OVER*UJ(I0,KI1).LT.ZERO)ANORM=-ANORM DO 160 I=1,NPTS UJ(I,JI1)=(UJ(I,JI1)-OVER*UJ(I,KI1))*ANORM DUJ(I,JI1)=(DUJ(I,JI1)-OVER*DUJ(I,KI1))*ANORM 160 CONTINUE 140 CONTINUE C 240 CONTINUE C WRITE(IWRITE,*) WRITE(IWRITE,*)' ISMITN=',ISMITN,' : WORST CASE OVERLAP BEFORE' X,' REORTHOGONALIZATION =',BIG,', ORBITALS',K0,J0 C RETURN C 1000 FORMAT(' LARGEST E-VALUE OF OVERLAP MATRIX' X ,' NEGLECTED= ',1PD10.3) 1001 FORMAT(' SMALLEST E-VALUE OF OVERLAP MATRIX' X ,' RETAINED= ',1PD10.3/) 1002 FORMAT(/' SR.SHMITT: NUMBER OF CONTINUUM BASIS ORBITALS' X ,' HAS BEEN REDUCED FROM',I4,' TO',I4) END C C C SUBROUTINE SHRIEK(NFACT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES FACTORIALS FROM 1 TO NFACT-1 C C GAMMA(I+1) = FACTORIAL I C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C COMMON /FACT/GAMMA(MZFAC) C----------------------------------------------------------------------- GAMMA(1) = DBLE(1) IF (NFACT.LT.2) GOTO 20 C DO 10 I = 2,NFACT GAMMA(I) = DBLE(I-1)*GAMMA(I-1) 10 CONTINUE C 20 CONTINUE END C C C SUBROUTINE SPNORB(N1,LP,N2,LX,RLBVAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES THE SPIN-ORBIT INTERACTION 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----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C DIMENSION NFULL(6) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /FACT/GAMMA(MZFAC) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /SIMP/XR(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NPTS COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /NRBOCC/TOCC(MXORB),IMAXN,IBANDW C PARAMETER (ZERO=0.0D0) PARAMETER (HALF=0.5D0) PARAMETER (ONE=1.0D0) PARAMETER (TWO=2.0D0) PARAMETER (PT0001=1.0D-4) PARAMETER (FSC=7.2973525D-3) C DATA NFULL/2,10,18,36,54,86/,LPMAX/6/ C----------------------------------------------------------------------- CG2(L1,L2,L3) = (GAMMA((L1+L2+L3)/2)/ A (GAMMA((L2+L3-L1)/2+1)*GAMMA((L3+L1- B L2)/2)*GAMMA((L1+L2-L3)/2+1)))**2* C GAMMA(L1+L2-L3+1)*GAMMA(L2+L3-L1+1)* D GAMMA(L3+L1-L2-1)* (2*L3-1)/GAMMA(L1+L2+L3) C C N.B. WHERE L1 AND L3 INCREMENTED BY +1, L1+L2+L2 ASSUMED EVEN. C C----------------------------------------------------------------------- C C RETURN IF THE ANGULAR MOMENTA ARE NOT COMPATIBLE C RLBVAL = ZERO IF (LX.NE.LP) GOTO 130 IF (LP.EQ.1) GOTO 130 C C DEFINE THE ORBITALS, COMPUTE SPIN-ORBIT PARAMETER C I1 = IPOS(N1,LP) I2 = IPOS(N2,LP) SUM = ZERO IF (IPSEUD.GE.0) GOTO 20 C C POTENTIAL DERIVATIVE APPROXIMATION (IGNORES EXCHANGE!): C L = LPOSX(LP) S2 = ZERO DO 10 J = 1,NPTS S1 = S2 IF (J.LT.NPTS) S2 = (POTHAM(J+1,L)-POTHAM(J,L))/ (XR(J)-XR(J+1)) IF (J.EQ.1) GOTO 10 D = ONE/XR(J) SUM = ((S1+S2)*HALF+POTHAM(J,L)*D)*UJ(J,I1)*UJ(J,I2)*WT(J)*D*D + A SUM 10 CONTINUE GOTO 120 C 20 CONTINUE DO 30 N = 1,6 NMAX = N - 1 IF (N.GE.N1) GOTO 40 IF (N.GE.N2) GOTO 40 IF (NELC.LE.NFULL(N)) GOTO 40 30 CONTINUE C C NEW SUM=ORINT(I1,I2,LP,LP,-3) 40 CONTINUE DO 50 J = 2,NPTS SUM = UJ(J,I1)*UJ(J,I2)*WT(J)/ (XR(J)*XR(J)*XR(J)) + SUM 50 CONTINUE SUM = NZ*SUM C C MULTIPLY BY EFFECTIVE SCREENING FACTOR IF SUPPLIED C IF (IPSEUD.LT.0) GOTO 120 C C EVENTUALLY USE THIS OPTION FOR 1/R*(DV/DR) APPROXIMATION! C IF (IZESP.EQ.0) GOTO 70 IF (IZESP.LT.0 .OR. IZESP.LT.LP) GOTO 120 SUM = SUM*ZESP(LP) IF (ZESP(LP).LT.ZERO) SUM = -ZESP(LP) GOTO 120 C C BLUME-WATSON SCREENING, CODED ALONG P.211 IN MICHAEL JONES' THESIS C 70 CONTINUE C C USE OCCUPATION NUMBERS FROM RADIAL FILE - NRB 23/9/95 C IF(IMAXN.GT.0)NMAX=MIN(N1,N2,IMAXN) C IF (NMAX.EQ.0) GOTO 120 IF (LP.GT.LPMAX) GOTO 120 S0 = ZERO S1 = ZERO S2 = ZERO S3 = ZERO T=FSC*FSC*HALF C C SUPRESS COMPILER WARNINGS. PRESUMABLY THESE VALUES ARE CYCLED OUT -NRB. AB2=ZERO BA2=ZERO C DO 110 N = 1,NMAX DO 100 L = 1,N IF (L.GT.LRANG1) GOTO 100 IF (IPOS(N,L).EQ.0) GOTO 100 IF(IBANDW.EQ.0) THEN ! USE SCREENING FACTORS FROM RADIAL - NRB IF(TOCC(IPOS(N,L)).LT.PT0001)GO TO 100 T1=ONE IF(N.EQ.N1.AND.N.EQ.N2.AND.L.EQ.LX.AND.L.EQ.LP)GO TO 105 T1=ZERO IF(N.EQ.N1.AND.L.GE.LP)GO TO 100 IF(N.EQ.N2.AND.L.GE.LX)GO TO 100 105 CALL RS(N1,LP,N,L,N2,LP,N,L,0,1,D) S0 = (TOCC(IPOS(N,L))-T1)*D + S0 TT = (TOCC(IPOS(N,L))-T1)/(4*L-2) ELSE ! USE ORIGINAL ... - NRB CALL RS(N1,LP,N,L,N2,LP,N,L,0,1,D) S0 = (2*L-1)*2*D + S0 TT = ONE ENDIF AB3 = ZERO BA3 = ZERO M = ABS(L-LP) M1 = M IF (M1.GT.0) M1 = M1 - 2 M2 = L + LP - 1 DO 90 J = M1,M2 AB1 = AB2 AB2 = AB3 BA1 = BA2 BA2 = BA3 IF (J.EQ.M2) GOTO 80 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) GOTO 80 IF (J.EQ.0) GOTO 90 IF (J.LT.M) GOTO 90 D = ((LP-1)*LP+ (J+1)*J- (L-1)*L)*3*CG2(LP,J,L)/ A ((LP-1)*LP*4) S3 = (((LP-1)*LP- (L-1)*L- (J+1)*J)* (J*AB3- (J+1)*BA1)- A ((L-1)*L- (LP-1)*LP- (J+1)*J)* (J*BA3- (J+1)*AB1))*D*TT B / ((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)*TWO*D*TT + S1 GOTO 90 C 80 CONTINUE IF (J-1.LT.M) GOTO 90 S2 = (J+LP+L-1)* (J-L+LP)* (J-LP+L)* (LP+L-J-1)*3* A TT*CG2(LP,J-1,L)/((LP-1)* (J+1)*J*LP*4)* (AB2+BA2) + S2 90 CONTINUE IF (NBUG9.LT.2) GOTO 100 PRINT *,' B.-W.: N,L, SUM,S0,-S1,-S2,-S3 = ',N,L, A T*SUM,T*S0,T*S1,T*S2,T*S3 100 CONTINUE 110 CONTINUE D = S1 + S2 + S3 IF (MAX(N1,N2).LE.MAXNHF(LP) .AND. NBUG9.GT.0) WRITE (IWRITE, A 3000) LP,N1,N2,T*SUM,T*S0,T*D,T*(SUM-S0+D),NMAX SUM = SUM - S0 + D C 120 CONTINUE RLBVAL = FSC*FSC*SUM*HALF C 130 CONTINUE C 3000 FORMAT (' ZETA(LP,N1,N2=',3I3,')/(RY*AL**2) =',1P,E14.4,' - ', A 2E14.4,' = ',E14.4,', WITH NMAX =',I2) END C C C SUBROUTINE SS(INDATA,MAXE,IPTS) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C READS ORBITAL DATA FROM CHANNEL INDATA IN SUPERSTRUCTURE FORMAT C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) C CHARACTER LSTR(3)*4,DLB(10)*4 C DIMENSION A(30),B(MXPOS),ITO(MZNPT),IFR(MZNPT) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /DPOLE/ALFD,RCUT,IPLCR,IPLFN,IKMX,IORB(MXORB) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /SIMP/R(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NC COMMON /NRBOCC/TOCC(MXORB),IMAXN,IBANDW COMMON /NRBREL/NREL c **** parallel **** common /parablock/iam,nproc include 'mpif.h' c **** parallel **** C C TINORB WILL BE USED TO SET THE BOUNDARY RADIUS RA. C C PARAMETER (TINORB=0.001D0) !NOW SET BELOW, INP. DEP. PARAMETER (ALL=0.0D0) C----------------------------------------------------------------------- C OPEN (INDATA,FILE='radial',STATUS='UNKNOWN') ! NRB 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,3160) RA C C NRB 18/01/94 ORIGINAL READ OF NELC & Z RESTORED READ (INDATA,3020) KEY,MO,KCOR,LSTR(1),LSTR(2),IZ,NELC,Z,DLB WRITE (IWRITE,3020) KEY,MO,KCOR,LSTR(1),LSTR(2),IZ,NELC,Z,DLB C IF (KEY.NE.-9) GOTO 660 C IF(MO.GT.MXPOS) CALL RECOV2('SS ','MXORB ',MXORB,MO) NREL=0 IF(DLB(10).EQ.'REL ')NREL=1 TINORB=0.001D0 !DETERMINE BOX SIZE IF(DLB(10).EQ.'BOX ')TINORB=-TINORB !USE INPUT BOX SIZE C IF(ALFD*RCUT.NE.ZERO.AND.IPLCR.EQ.0)THEN IPLCR=KCOR WRITE(IWRITE,3091) IPLCR ENDIF C MCOR=KCOR ! RETAIN ORIG KCOR FOR STGDW IF(IPSEUD.EQ.0)MCOR=0 IF(MCOR.EQ.0)IPSEUD=0 IF(IPSEUD.NE.0)KCOR=0 ! ONLY VALENCE NOW IN STG2 C C READ MESH POINTS. STORE IN ARRAY R. DEFINE RC= BOUNDARY RADIUS. C 10 CONTINUE NP = IZ IP = MZNPT NN = IP DO 20 I = 1,IP ITO(I) = I IFR(I) = I 20 CONTINUE NC = 0 RB = ABS(RA) IF (RA.EQ.ALL) RB = 1.0D37 DO 50 I = 1,NP,2 READ (INDATA,3000) KEY,MA1,EPR1,EQR1,MA2,EPR2,EQR2,LSTR IF (KEY.NE.-8) GOTO 650 IF (MA1.GT.IP) GOTO 50 IF (MA1.EQ.IP .OR. MA2.LE.MA1) GOTO 40 H = (EPR2-EPR1)*2 IF (EPR2.GT.RB+H) GOTO 40 NC = MA2 R(MA2) = EPR2 PX(MA2) = EQR2 40 CONTINUE IF (EPR1.GT.RB+H) GOTO 50 NC = MAX(MA1,NC) R(MA1) = EPR1 PX(MA1) = EQR1 50 CONTINUE IF (MA1.GT.IP)THEN WRITE (IWRITE,3050) c **** parallel **** CALL mpi_barrier(mpi_comm_world,ierr) CALL mpi_finalize(ierr) c **** parallel **** STOP ENDIF C NRB 24/10/94 C GO BACK TO READING FROM HEADER SO AS TO ALLOW EFFECTIVE CHARGE TO C REPRESENT N-ELECTRON CORE OF (N+M)-ELECTRON ATOM FOR USE IN POTHAM. C OTHERWISE NELC WRONG (DISASTER) OR POTHAM INACCURATE (AFFECTS ONLY C POTENTIAL DERIVATIVE EVALUATION OF SPIN-ORBIT?), DEPENDING ON CHOICE C OF EFFECTIVE CHARGE FOR M > 1. C*** MORE IMPORTANTLY, ALLOWS USE OF OLD RADIAL FILES THAT DID NOT C*** SPECIFY THE EFFECTIVE CHARGE, BUT JUST REPEATED RADIAL MESH. CNRB Z = PX(1) NZ = INT(Z + TINY) CNRB NELC = NZ - (EQR1-TINY) + 1 C NP = NC G = PI / ( SQRT (DBLE(MAXE)) * IPTS ) 60 CONTINUE H = R(NC) - R(NC-1) IF (H.LE.G) GOTO 110 F = PI/ (H*IPTS) M = INT(F*F) DO 70 I = NC,2,-1 T = R(I) - R(I-1) K = I IF (ABS(T-H).GT.PT01*H) GOTO 80 70 CONTINUE WRITE (IWRITE,3060) M MAXE = M GOTO 110 80 CONTINUE KK = NC - K C C EVT CHECK THAT STEP LENGTH T.EQ.H/2 C J = KK + NC IF (J.GT.IP) GOTO 100 NN = K N = K + 1 DO 90 I = NC,N,-1 L = IFR(I) IF (L.NE.0) ITO(L) = J R(J) = R(I) IFR(J) = L IFR(J-1) = 0 R(J-1) = R(I) - T C C INTERPOLATE EFFECTIVE CHARGE QUADRATICALLY AT NEW MIDPOINTS: C IF(IPSEUD.EQ.0)GO TO 89 ! NRB 24/10/94 PX(J) = PX(I) ! NRB 24/10/94 NOTE MOVE 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) 89 J = J - 2 90 CONTINUE NC = KK + NC WRITE (IWRITE,3070) MAXE,T,K,R(K),KK GOTO 60 C 100 CONTINUE WRITE (IWRITE,3080) M MAXE = M STOP 'INCREASE MZNPT - NOT ENOUGH MESH POINTS FOR THIS MAXE' C 110 CONTINUE IF (RA.EQ.ALL) GOTO 140 C C (RA=) 0.0; OTHERWISE EXTEND MESH TO ABS(RA): C M = NC DO 120 I = 1,M NC = I IF (R(I).GE.RB) GOTO 140 120 CONTINUE H = R(M) - R(M-1) DO 130 I = M,IP R(I) = R(I-1) + H PX(I) = PX(I-1) NC = I IF (R(I).GE.RB) GOTO 140 130 CONTINUE WRITE (IWRITE,3120) RB,R(NC) 140 CONTINUE RC = R(NC) LRANG1 = 0 C C PROCESS POTHAM INPUT (ASSUMING NO GAPS IN ANGULAR MOMENTA SUPPLY) C IF (IPSEUD.EQ.0) GOTO 170 C NRB 24/10/94 IBID. CNRB NELC = NZ - (PX(NC)-0.001D0) + 1 LPOT = LPOT + 1 IF (LPOT.GT.MZLR1) CALL RECOV2('SS ',' MZLR1',MZLR1,LPOT) DO 150 I = 1,NC POTHAM(I,LPOT) = PX(I) 150 CONTINUE DO 160 K = LPOT,MZLR2 LPOSX(K) = LPOT 160 CONTINUE WRITE (IWRITE,3030) LPOT C C READ AND PRINT HEADER FOR EACH ORBITAL. C N QUANTUM NUMBER, L QUANTUM NUMBER, NUMBER OF CARDS (NO) C 170 CONTINUE JFLG = 0 IFLG = 0 IPJS = 0 XSUM = 0.0D0 IKMX=MO DO 410 K = 1,MO READ (INDATA,3010,ERR=180) KEY,I,N,L,X,J,EPS,NO,H,(DLB(M),M=1,6) 180 CONTINUE WRITE (IWRITE,3010) KEY,I,N,L,X,J,EPS,NO,H,(DLB(M),M=1,6) IF (KEY.LE.-9) GOTO 10 IF (KEY.GT.-6) GOTO 420 IF (KEY.NE.-7) GOTO 660 NBOUND = K IF (MXORB.LT.K) GOTO 630 IF (NBOUND.GT.MXORBS) * CALL RECOV2('SS ','MXORBS',MXORB,NBOUND) IF (L.GE.MZLR2) CALL RECOV2('SS ',' MZLR2',MZLR2,L+1) IF (N.GT.MXPOS) CALL RECOV2('SS ','MXPOS ',MXPOS,N) IPOS(N,L+1) = K IORB(K)=I MAXNHF(L+1) = MAX(MAXNHF(L+1),N) LRANG1 = MAX(LRANG1,L+1) C NRB 19/01/94 MODEL POTENTIAL OPERATION IF(I.LE.MCOR.AND.L.LT.MZLR2)MAXNC(L+1)=MAX(MAXNC(L+1),N) C C NRB 23/09/95 OCCUPATION NUMBERS FOR IMPROVED BLUME&WATSON C XSUM=XSUM+X TOCC(K)=X IF(X.GT.PT0001)IMAXN=MAX(IMAXN,N) IF(IMAXN.EQ.0)TOCC(K)=4*L+2 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.0D0 DO 190 I = 1,NO READ (INDATA,3000) KEY,MA1,EPR1,EQR1,MA2,EPR2,EQR2,LSTR IF (KEY.NE.-6) GOTO 650 IF (MA1.GT.NP) GOTO 190 M = ITO(MA1) UJ(M,K) = EPR1 DUJ(M,K) = EQR1 IF (MA2.GT.NP) GOTO 190 IF (MA2.LT.2) GOTO 190 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) 190 CONTINUE C C INTERPOLATE AT POINTS INSERTED BECAUSE OF HIGH ENERGY PARTIAL WVS C IF (NN.GE.M) GOTO 270 A(2) = 0.0D0 A(3) = 0.0D0 A(4) = 0.0D0 KK = MAX(NN-1,1) DO 260 I = NN,M IF (IFR(I).NE.0) GOTO 260 200 CONTINUE IF (A(3).GT.R(I)) GOTO 230 IF (KK.GT.M) GOTO 230 DO 220 JJ = KK,M IF (IFR(JJ).EQ.0) GOTO 220 DO 210 J = 1,3 A(J) = A(J+1) A(J+4) = A(J+5) A(J+8) = A(J+9) 210 CONTINUE A(4) = R(JJ) A(8) = UJ(JJ,K) A(12) = DUJ(JJ,K) IF (A(1).GT.0.0D0) THEN !ONLY REDEFINE KK = JJ + 1 !KK WHEN WE GOTO 200 !WANT TO EXIT ENDIF !THE LOOP 220 220 CONTINUE C 230 CONTINUE F = 0.0D0 G = 0.0D0 C C LAGRANGE INTERPOLATION OF P=UJ AND Q=DUJ AT R(I): C DO 250 JJ = 1,4 H = 1.0D0 T = 1.0D0 DO 240 J = 1,4 IF (JJ.EQ.J) GOTO 240 H = (R(I)-A(J))*H T = (A(JJ)-A(J))*T 240 CONTINUE F = A(JJ+4)*H/T + F G = A(JJ+8)*H/T + G 250 CONTINUE UJ(I,K) = F DUJ(I,K) = G 260 CONTINUE 270 CONTINUE 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 C IF (EPS.LT.0.0D0) IFLG = IFLG + 1 IF (M.GE.NC) GOTO 410 JFLG = JFLG + 1 MA1 = MA2 I = IFR(M) JJ = ITO(I-1) KK = ITO(I-2) IZ = -1 P = 0.0D0 J = 0 280 CONTINUE J = -J RB = R(JJ) UB = UJ(JJ,K) IF (J.LT.0) GOTO 360 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.0D0) GOTO 360 X = SQRT(-E) DO 300 I = 2,M IF (I.GE.KK-1) GOTO 290 IF (ABS(UJ(I,K)).LE.1.0D-10) GOTO 300 290 CONTINUE IZ = I IF (ABS(DUJ(I,K)/UJ(I,K)-D/R(I)-E).LT.PT001) GOTO 310 300 CONTINUE WRITE (IWRITE,3110) C 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. C 310 CONTINUE Q = (D*HALF+Z)/X C C GET A SEMI-CONVERGENT ASYMPTOTIC WHITTAKER SERIES TO Q,L AT RB: C A(1) = 1.0D0 F = 1.0D0 H = 1.0D0 T = 1.0D0 J = 1 DO 340 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) GOTO 330 IF (I.LT.5) GOTO 320 IF (ABS(A(I+1)).LE.RB*ABS(A(I))) GOTO 320 WRITE (IWRITE,3040) GOTO 350 C 320 CONTINUE IF (ABS(F*H+A(I+1)).GT.H*T*1.D+6) GOTO 350 C C WHEN SMALLEST TERM IN SUM DEGRADES BY 6 DECIMAL PLACES... C IF (ABS(A(I+1)).LT.ABS(F)*H*1.D-9) GOTO 350 330 CONTINUE F = A(I+1)/H + F J = I + 1 340 CONTINUE WRITE (IWRITE,3140) 350 CONTINUE G = Q*LOG(RB) - X*RB P = UJ(M,K) 360 CONTINUE DO 400 I = M,NC H = (R(I)-RC)*UB/ (RB-RC) IF (J.LE.0) GOTO 390 H = 1.0D0/R(I) T = A(J) DO 370 JJ = J,2,-1 T = T*H + A(JJ-1) 370 CONTINUE H = Q*LOG(R(I)) - X*R(I) - G IF (I.EQ.NC) GOTO 380 JJ = M IF (H.LT.LOG(ABS(F/ (T*UB)))-69.08D0) GOTO 280 380 CONTINUE 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 390 CONTINUE UJ(I,K) = H DUJ(I,K) = (D/R(I)+E)*H M = I 400 CONTINUE A(1) = -D*HALF JJ = MIN(ABS(J),11) WRITE (IWRITE,3130) MA1,R(MA1),MA2,R(MA2),NC,RC,UJ(MA1,K), A UJ(MA2,K),UJ(NC,K),P,J,IZ,E, (A(I),I=1,JJ) 410 CONTINUE 420 CONTINUE C C C IF(XSUM.LT.PT0001.AND.IBANDW.EQ.0.AND.IMAXN.EQ.0.AND. XIRELOP(3).NE.0)WRITE(6,3135) C C RESET NC TO VALUE OF IPJS DEFINED BY TINORB UNLESS RA SPECIFIED C IF (RA.LE.0.0D0) NC = IPJS C C CHECK INTEGRATION MESH - MUST BE AT LEAST 7 POINTS IN FIRST RANGE. C J = 2 NIX = 0 430 CONTINUE HINT = R(J) X = HINT*FIVE DO 440 I = J,NC IF (ABS(R(I)-X).LT.TINY) GOTO 450 440 CONTINUE J = J + 1 IF (J.GT.4) GOTO 640 GOTO 430 C C REMOVE UNWANTED POINTS IN FIRST INTERVAL C 450 CONTINUE IF (J.EQ.2) GOTO 500 ! NRB DO 490 I = 2,7 460 CONTINUE IF (ABS(R(I)- (I-1)*HINT).LT.TINY) GOTO 490 NC = NC - 1 DO 480 IP = I,NC DO 470 K = 1,NBOUND UJ(IP,K) = UJ(IP+1,K) DUJ(IP,K) = DUJ(IP+1,K) 470 CONTINUE R(IP) = R(IP+1) 480 CONTINUE GOTO 460 C 490 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 500 CONTINUE H = HINT J = 1 NIX = 1 IHX(1) = 1 AMPL = H*PT01 ! NRB PT0001 -> H*PT01 DO 520 I = 1,NC X = (I-J)*H + R(J) CNRB IF (I.GT.ITO(NP)) AMPL = X*PT0001 IF (ABS(R(I)-X).LT.AMPL) GOTO 510 IF (MOD(I,2).NE.0) GOTO 640 X = X + H IF (ABS(R(I)-X).GE.AMPL) GOTO 635 ! NRB PT0001 -> AMPL NIX = NIX + 1 IF (NIX.GT.MXNIX) CALL RECOV2('SS ','MXNIX ',MXNIX,NIX) IHX(NIX) = 2*IHX(NIX-1) IRX(NIX-1) = I - 2 H = IHX(NIX)*HINT AMPL = H*PT01 J = I 510 STEP(I) = H 520 CONTINUE 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 C ORTHOGONALIZE SUBSEQUENT ORBITALS TO THOSE WITH SAME VALUE L: C IF (IFLG.EQ.0) GOTO 600 DO 590 L = 1,LRANG1 M = MAXNHF(L) IF (M.LE.0) GOTO 590 DO 580 N = 1,M J = 0 NN = IPOS(N,L) IF (NN.LE.0) GOTO 580 DO 570 K = 1,N KK = IPOS(K,L) IF (KK.LE.0) GOTO 570 J = J + 1 CALL ABNORM(N,L,K,L,T) C C NXT EVENTUALLY ADD TAIL CONTRIBUTION TO T FROM RA TO INFINITY(Q) C IF (N.EQ.K) THEN C C I.E. ASSUMING INPUT IS NORMALIZED; OTHERWISE UNCOMMENT CNORM C C THIS IS CRUCIAL FOR NEW SHMITN ROUTINE, 1E-6 ERROR IN NORMALIZATION C PROPAGATES THROUGH LARGE SCALE SCHMIDT ORTHOGONALIZATION C CATASTROPHICALLY. NRB 11/9/96 C G=ONE/SQRT(T) H=ZERO C C AND COMMENT OUT NEXT TWO LINES CUNNORM T=T-ONE CUNNORM GOTO 560 C ELSE C G = ONE/SQRT(ONE-T*T) H = T C ENDIF C DO 550 I = 1,NPTS UJ(I,NN) = (UJ(I,NN)-UJ(I,KK)*H)*G DUJ(I,NN) = (DUJ(I,NN)-DUJ(I,KK)*H)*G 550 CONTINUE CUNNORM 560 CONTINUE C IF(TINORB.LT.ZERO)THEN !BOX STATES UJ(NPTS,NN)=ZERO DUJ(NPTS,NN)=ZERO ENDIF C B(J) = T 570 CONTINUE WRITE (IWRITE,3100) L, (B(I),I=1,J) 580 CONTINUE 590 CONTINUE IF (JFLG.NE.0) WRITE (IWRITE,3090) 600 CONTINUE IF (NBUG7.NE.2) GOTO 620 WRITE (IWRITE,3190) 0, (I,R(I),I=1,NC) DO 610 K = 1,NBOUND WRITE (IWRITE,3190) K, (I,UJ(I,K),I=1,NC) 610 CONTINUE 620 CONTINUE RETURN C C ERROR MESSAGES C 630 CONTINUE WRITE (IWRITE,3150) NBOUND GOTO 670 C 635 CONTINUE WRITE (IWRITE,3165)H,NIX,X,I,R(I) 640 CONTINUE WRITE (IWRITE,3170) HINT,NIX,X,J,R(J) GOTO 670 C 650 CONTINUE WRITE (IWRITE,3000) KEY,MA1,EPR1,EQR1,MA2,EPR2,EQR2,LSTR 660 CONTINUE WRITE (IWRITE,3180) 670 CONTINUE STOP C 3000 FORMAT (I5,2 (I4,2E14.7),A3,2A4) 3010 FORMAT (2I5,2X,2I3,F5.1,I2,F12.6,I6,F12.6,1X,6A4) C3020 FORMAT (2I5,1X,3A4,2X,I3,2A4,16X,6A4) 3020 FORMAT (3I5,1X,2A4,I4,I4,F4.0,10A4) ! NRB 24/10/94 3030 FORMAT (25X,'HAMILTONIAN MODEL POTENTIAL FOR L+1 =',I2) 3040 FORMAT (9X, A'WARNING: EARLY TRUNCATION, RB VS MACHINE WORD LENGTH MAY BE VERY BTIGHT') 3050 FORMAT (6X,'WARNING: MORE POINTS SUPPLIED THAN COULD BE STORED.' A ) 3060 FORMAT (6X,'SS SETS MAXE=',I4, A' AS IT PREFERS NOT TO HALVE H NEAR 0.0; DECREMENT INTRAN IN ZUERM BODS RUN.') 3070 FORMAT (6X,'MAXE =',I4,': H HALVED TO',F6.3,' BEYOND R(',I4,') =', A F7.2,';',I5,' MORE STEPS') 3080 FORMAT (' ** WARNING: MAXE REDUCED TO',I5, A ', FOR LACK OF SPACE TO TABULATE DENSER MESH;'/15X,'POSSIBLE ' B,'NUMERICAL INACCURACY, RECOMPILE WITH BIGGER MZNPT?') 3090 FORMAT (15X, A 'N.B.: INDATA MUST BE NORMALIZED BUT N O T ORTHOGONALIZED!' B ) 3091 FORMAT(/'*** THE VALUE OF IPLCR RESET TO ',I3/) 3100 FORMAT (3X,'OVERLAP INTEGRALS(N) TO L+1=',I2,':',(T35,6(1PD10.2))) 3110 FORMAT (6X, A '** INPUT TAIL TOO POOR FOR EXTRAPOLATING - DOES IT MATTER?' B ) 3120 FORMAT (' INPUT RB=',F7.3,' REDUCED TO',F7.3, A ' FOR LACK OF SPACE: RECOMPILE WITH BIGGER MZNPT') 3130 FORMAT (9X,'EXTRAPOLATION RANGE:',3 (' R(',I3,')=',F7.3)/10X, A '& VALUES OF PNL(R) ',3E15.5/12X,'P,KK,IC,E,D;A(K) ',E15.5, B 2I6,F11.5,F7.2/ (T15,5F12.5)) 3135 FORMAT (//'*** ATTENTION: ALL B&W OCCUPATION NUMBERS ARE ZERO', X ' IN THE RADIAL FILE, DEFAULTS WILL BE ASSUMED'/ X ' SET IMAXN=-1 IN NAMELIST STG1A IF YOU REALLY WANT', X ' THEM TO BE ZERO ***'//) 3140 FORMAT (6X,'** WARNING: 29 WHITTAKER TERMS MAY BE NOT ENOUGH.') 3150 FORMAT (' TOO MANY ORBITALS,MXORB=L72.LT.',I3) 3160 FORMAT (/6X,'READING SSTRUCT INDATA (WHILE RA =',F9.4,'):') 3165 FORMAT (' ERROR IN S.S. DATA, INTEGRATION MESH NO GOOD'/' H =', A F12.9,' NIX =',I3,' X =',F12.6,' I =',I3,' R(I) =', B F12.6/) 3170 FORMAT (' ERROR IN S.S. DATA, INTEGRATION MESH NO GOOD'/' HINT =', A F12.9,' NIX =',I3,' X =',F12.6,' J =',I3,' R(J) =', B F12.6/) 3180 FORMAT (' ERROR IN S.S. DATA, LAST CARD READ WAS AS ABOVE'/) 3190 FORMAT (' ORBITAL',I5/ (1X,6 (I7,1P,E15.6))) END C C C SUBROUTINE STG1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /COPY/ITOTAL,ICOUNT COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /RECOV/IPLACE COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON/REL/IRELOP(3) C LOGICAL EX C c **** parallel **** common /parablock/iam,nproc c **** parallel **** C C----------------------------------------------------------------------- C C SET IREAD AND IWRITE C C----------------------------------------------------------------------- IREAD = 5 IWRITE = 6 IPUNCH = 7 C c **** parallel **** if (iam.eq.0) then OPEN (UNIT=IWRITE,FILE='rout1r',STATUS='UNKNOWN', A FORM='FORMATTED') else OPEN (UNIT=IWRITE,FILE='rout1rg',STATUS='UNKNOWN', A FORM='FORMATTED') endif c **** parallel **** C EX=.TRUE. INQUIRE (FILE='dstg1',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7777) STOP ' dstg1 does not exist....stopping.' ENDIF 7777 FORMAT (/' dstg1 does not exist....stopping.') C OPEN (UNIT=IREAD,FILE='dstg1',STATUS='OLD',FORM='FORMATTED') C----------------------------------------------------------------------- C C DEFINE FACTORIAL ARRAY IN /FACT/ C C----------------------------------------------------------------------- CALL SHRIEK(MZFAC) C----------------------------------------------------------------------- C C READ ANY INPUT FILES (IREAD, ITAPE1) ... C READ IN AND WRITE OUT THE BASIC DATA C NBUG7=1 CORRESPONDS TO A DIMENSION TEST RUN ONLY C C----------------------------------------------------------------------- CALL STG1RD WRITE (IWRITE,3000) IF (NBUG7.EQ.1) GOTO 10 C C INITIALIZE RADIAL MESH ... C TABULATE RADIAL MESH POINTS IN /SIMP/ C TABULATE ANALYTIC BOUND ORBITALS IN /ORBTLS/ C TABULATE THE POTENTIAL FUNCTION IN /POTVAL/ C DEBUG PRINTOUT OF ORBITALS IF NBUG5=2 C IOUT = 0 IF (NBUG5.EQ.2) THEN IOUT = IPUNCH OPEN(IPUNCH,FILE='radout',STATUS='UNKNOWN') ENDIF C CALL ISTG1(LRANG1,LRANG2,NCOEFF,IOUT) C C EVALUATE THE CONTINUUM ORBITALS IN /BASIN/ AND /ORBTLS/, C STORE ORTHOGONALIZATION INFORMATION IN /REL1/ AND /SCOEFF/, C EVALUATE THE BUTTLE CORRECION FIT IN /BUTT/. C CALL BASORB C C WRITE DATA FILE FOR NX CODE ! NRB 25/10/94 C IF(IRELOP(3).EQ.0)CALL WRINX1 C WRITE (IWRITE,3000) IF (NBUG7.EQ.1 .OR. ITOTAL.LE.0) GOTO 10 C C WRITE BASIC QUANTITIES AS A HEADER ON OUTPUT FILE ITAPE3 C CALL WRITAP(13) C C EVALUATE THE MULTIPOLE INTEGRALS THE ONE ELECTRON INTEGRALS AND C THE RK INTEGRALS, AND STORE ON OUTPUT FILES ITAPE3 AND RK C 10 CONTINUE CALL GENINT WRITE (IWRITE,3000) C C WRITE OUT ERROR MESSAGE IF A DIMENSION HAS BEEN EXCEEDED C IF (IPLACE.GT.0) WRITE (IWRITE,3010) IF (IPLACE.LE.0) WRITE (IWRITE,3020) C 3000 FORMAT (/10X,62 ('*')/) 3010 FORMAT (/' DIMENSIONS EXCEEDED IN STG1'/) 3020 FORMAT (35X,'END OF STG1'/35X,11 ('-')) END SUBROUTINE STG1RD IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C READS IN AND PRINTS OUT THE INPUT DATA C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) C CHARACTER LVALUE(10)*1,TITLE(18)*4 LOGICAL EX C DIMENSION NTAPE(4) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CONST1/ZERO,ONE,PT01,PT001,PT0001,TINY,PI,FSC,TWO,THREE, A FOUR,FIVE,SIX,SEVEN,EIGHT,TEN,ELEVEN,TWELVE,HALF,THIRD, B FOURTH,FIFTH,SIXTH,EIGHTH,TENTH COMMON /COPY/ITOTAL,ICOUNT COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /NBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTEN/CPOT(6),XPOT(6),IPOT(6),NPOT COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /SCOEFF/B(MXN3,MXN3,MZLR1),OVRLAP(MZNR2,MZNR1,MZLR1), 1 TEMP(MXN3),ISMITN COMMON /DW/IDWOUT,LNOEX COMMON /NRBBUT/BUTORB(MZNPT,MZNR1),BUTEND(MZNR1),BUTEIG(MZNR1), X EMIN,EMAX,TOLE,ITEST0,IMAX,JPOS(MXN3),MJS,NBOX(0:MZLR1) COMMON /NRBDIP/LRANGD COMMON /NRBOCC/TOCC(MXORB),IMAXN,IBANDW C PARAMETER (TINORB=0.004D0) C DATA NTAPE(1),NTAPE(2),NTAPE(3),NTAPE(4)/1,2,3,4/ DATA LVALUE/'s','p','d','f','g','h','i','j','k','l'/ C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc c **** parallel **** C C----------------------------------------------------------------------- READ (IREAD,3290) TITLE C----------------------------------------------------------------------- NEW = 0 IF (TITLE(1).EQ.'CIV3' .OR. TITLE(1).EQ.'S.S.') NEW = 1 IF (TITLE(1).EQ.'STO-') NEW = -1 C----------------------------------------------------------------------- IF (NEW.EQ.0) READ (IREAD,*) IPUNCH,IDISC1,IDISC2,IDISC3,IDISC4, A ITAPE1,ITAPE2,ITAPE3,ITAPE4,JDISC1 C----------------------------------------------------------------------- WRITE (IWRITE,3010) TITLE WRITE (IWRITE,3280) * MZFAC,MZLMX,MZLR1,MZLR2,MZMEG,MZKIL,MZNPT,MZNR1,MZNR2,MXORB C----------------------------------------------------------------------- C C INITIALIZE INPUT VARIABLES C C----------------------------------------------------------------------- DO 20 L = 1,MZLR2 DO 10 J = 1,MXPOS IPOS(J,L) = 0 10 CONTINUE LPOSX(L) = 1 MAXNCB(L) = 0 MAXNC(L) = L - 1 MAXNHF(L) = L - 1 MAXNLG(L) = L - 1 20 CONTINUE C LPOT = 0 NELCOR = -1 BSTO = ZERO MAXE = 9999 ETA = FIFTH*PT0001 DELTA = ETA C C INITIALIZE NON-NAME DATA IDWOUT=0 EMIN=-9999.0D0 EMAX=9999.0D0 IMAX=6 MJS=1 DO L=0,MZLR1 NBOX(L)=0 ENDDO C----------------------------------------------------------------------- IF (NEW.NE.0) CALL NAME(TITLE(1),IBC,MAXE,LCB) C----------------------------------------------------------------------- IF (NEW.EQ.0) READ (IREAD,*) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6, A NBUG7,NBUG8,NBUG9 C----------------------------------------------------------------------- C C IPSEUD.NE.0 FOR MODEL POTENTIAL ON ITAPE1 OR READ BY SS AS C EFFECTIVE CHARGES C C READ IN WHICH RELATIVISTIC OPERATORS ARE TO BE INCLUDED: C C IRELOP(1) = 1 FOR MASS CORRECTION; C IRELOP(2) = 1 FOR DARWIN TERM; C IRELOP(3) = 1 FOR SPIN-ORBIT. C IBANDW = 1 USE ORIGINAL STG1 BLUME & WATSON. SEE SR.NAME FOR C ALTERNATIVES - NRB. C IMAXN = 0 FOR IBANDW=1, SEE SS FOR USE THERE - NRB. C C----------------------------------------------------------------------- IF (NEW.EQ.0) THEN IMAXN=0 ! COULD ADD TO READ...BUT NON-STANDARD THEN - NRB IBANDW=1 ! DITTO READ (IREAD,*) ICOPY,ITOTAL,IPSEUD,IRELOP,IZESP IF (IPSEUD.GT.1 .OR. IZESP.GT.MZLR1 .OR. IRELOP(1).GT.1 .OR. A IRELOP(2).GT.1 .OR. IRELOP(3).GT.1) WRITE (IWRITE, B *) ' WARNING - FREE FORMATTED DATA LINES', C ' MAY NEED PADDING WITH EXTRA ZEROS' ENDIF C ICOPY = 0 C----------------------------------------------------------------------- C C Set the I/O numbers and open files. C C IREAD (5) .. input data .. dstg1 C IWRITE (6) .. printed output .. rout1r C C IPUNCH .. punched output .. radout C C IDISC1 .. NOT USED C IDISC2 .. NOT USED C IDISC3 .. NOT USED C IDISC4 .. NOT USED C C ITAPE1 (1) .. model potential .. STG1.POT .. if ITAPE1>0 C ITAPE2 .. NOT USED C ITAPE3 (3) .. STG1 dump .. STG1.DAT .. always used C ITAPE4 .. NOT USED C C JDISC1 (21) .. RK.DAT C JDISC2 .. NOT USED C C----------------------------------------------------------------------- C IDISC1 = 0 IDISC2 = 0 IDISC3 = 0 IDISC4 = 0 C IF (ITAPE1.GT.0) THEN ITAPE1 = 1 ELSE ITAPE1 = 0 ENDIF C ITAPE2 = 0 ITAPE3 = 3 ITAPE4 = 0 C IF(NEW*JDISC1.EQ.0)JDISC1 = 21 JDISC2 = 0 C IF (ITAPE1.GT.0) THEN INQUIRE (FILE='STG1.POT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7771) STOP ENDIF OPEN (UNIT=ITAPE1,FILE='STG1.POT',STATUS='OLD', A FORM='UNFORMATTED') ENDIF 7771 FORMAT ( A /' You have set ITAPE1>0 in the input data.' B /' The code expects a file containing a model potential etc.' C /' However file STG1.POT does not exist....stopping.') C c **** parallel **** if (iam.eq.0) then OPEN (UNIT=ITAPE3,FILE='STG1.DAT',STATUS='UNKNOWN', A FORM='UNFORMATTED') else OPEN (UNIT=ITAPE3,FILE='STG1g.DAT',STATUS='UNKNOWN', A FORM='UNFORMATTED') endif c **** parallel **** C----------------------------------------------------------------------- WRITE (IWRITE,3000) WRITE (IWRITE,3210) A IREAD,IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1, A ITAPE2,ITAPE3,ITAPE4,JDISC1,JDISC2 WRITE (IWRITE,3020) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7, A NBUG8,NBUG9 WRITE (IWRITE,3030) ICOPY,ITOTAL,IPSEUD,IRELOP,IZESP,IBANDW C----------------------------------------------------------------------- IF (IZESP.GT.0) READ (IREAD,*) (ZESP(I),I=1,IZESP) IF (IZESP.NE.0) WRITE (IWRITE,3260) (ZESP(I),I=1,IZESP) C----------------------------------------------------------------------- IF (IPSEUD.GT.0 .AND. ITAPE1.GT.0) WRITE (IWRITE,3220) NTAPE(1), A ITAPE1 C----------------------------------------------------------------------- WRITE (IWRITE,3230) NTAPE(3),ITAPE3 C----------------------------------------------------------------------- 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 C ISMITN=0 USE ORIGINAL SCHMIDT ORTHOGONALIZATION C =1 USE USE TRANSFORMATION REDUCTION OF GORCZYCA & BADNELL C C LRANGD IS MAX CONTINUUM SMALL L+1 FOR WHICH MULTIPOLE INTEGRALS C ARE COMPUTED. DEFAULT = 999, ALL. C C----------------------------------------------------------------------- WRITE (IWRITE,3050) C IF (NEW.EQ.0) THEN ISMITN=0 !COULD ADD TO READ...BUT NON-STANDARD THEN - NRB LRANGD=999 LNOEX=999 READ (IREAD,*) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX, A LAM,IBC,NPOT,LCB ENDIF C LRANGD=MIN(LRANGD,LRANG2) C WRITE (IWRITE,3060) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM,IBC, A NPOT,LCB,ISMITN,LRANGD,LNOEX C IPLACE = 0 IF (LRANG1.GT.MZLR2) CALL RECOV2('STG1RD',' MZLR2',MZLR2,LRANG1) CNRB IPLACE = -1 IF (LRANG1.GT.MZLR1) CALL RECOV2('STG1RD',' MZLR1',MZLR1,LRANG1) IF (LRANG2.GT.MZLR2) CALL RECOV2('STG1RD',' MZLR2',MZLR2,LRANG2) IF (NRANG2.GT.MZNR2) CALL RECOV2('STG1RD',' MZNR2',MZNR2,NRANG2) IF (LAMAX.GT.MZLMX) CALL RECOV2('STG1RD',' MZLMX',MZLMX,LAMAX) C IF (NEW.EQ.0) READ (IREAD,*) (MAXNHF(I),I=1,LRANG1) WRITE (IWRITE,3070) (MAXNHF(I),I=1,LRANG1) C IF (NEW.EQ.0) READ (IREAD,*) (MAXNLG(I),I=1,LRANG1) WRITE (IWRITE,3080) (MAXNLG(I),I=1,LRANG1) C IF (NEW.EQ.0.AND.LCB.GT.0) X READ (IREAD,*) (MAXNCB(I),I=1,LCB),NELCOR IF (LCB.GT.0) WRITE (IWRITE,3270) (MAXNCB(I),I=1,LCB) C IF (NELCOR.GE.0) WRITE (IWRITE,*) ' NELCOR',NELCOR IF (NELCOR.LE.0) NELCOR = NELC LAMBC = 0 LAMCC = 0 IF (LAM.GE.2) LAMBC = LAMAX IF (LAM.GE.3) LAMCC = LAMAX C----------------------------------------------------------------------- C C CHECK SIZE OF ARRAYS ASSOCIATED WITH THE BOUND ORBITALS C C SET NLIMIT = THE LARGEST N-VALUE FOR THE BOUND ORBITALS C NCOEFF = THE MAXIMUM NUMBER OF TERMS ALLOWED IN ANY ORBITAL C C----------------------------------------------------------------------- NLIMIT = 0 NBOUND = 0 IPLACE=-1 ! NRB DO 30 L = 1,LRANG1 IF (MAXNHF(L).GT.NLIMIT) NLIMIT = MAXNHF(L) MS = MAXNLG(L) - L + 1 IF (MS.GT.MZNR1) CALL RECOV2('STG1RD',' MZNR1',MZNR1,MS) MS = MAXNHF(L) - MAXNLG(L) IF (MS.GT.MZNR1) CALL RECOV2('STG1RD',' MZNR1',MZNR1,MS) NBOUND = NBOUND + MAXNHF(L) - L + 1 30 CONTINUE IF (NBOUND.GT.MXORB) CALL RECOV2('STG1RD','MXORB ',MXORB,NBOUND) MS = LRANG2 - 1 + NRANG2 IF (MS.GT.MXPOS) CALL RECOV2('STG1RD','MXPOS ',MXPOS,MS) MS = NLIMIT + NRANG2 IF (MS.GT.MXPOS) CALL RECOV2('STG1RD','MXPOS ',MXPOS,MS) MAXNCO = NLIMIT* (LRANG1-1) + MAXNHF(LRANG1) IF (MAXNCO.GT.MXNL1) CALL RECOV2('STG1RD','MXNL1 ',MXNL1,MAXNCO) IF (MAXNCO.GT.MXNL1) GOTO 190 NTERMS = MXSLT IF (NEW.EQ.0) NCOEFF = NTERMS/MAXNCO NFACT = (MAX(MIN(LRANG2,6),LRANG1)+LRANG1-1)*2 C C INITIALIZE VARIABLES AND ARRAYS ASSOCIATED WITH STORING THE C RADIAL FUNCTIONS C IF (IRELOP(3).NE.0 .AND. NFACT.GT.MZFAC) CALL RECOV2('STG1RD', A ' MZFAC',MZFAC,NFACT) IF (NCOEFF.EQ.0) GOTO 100 C C SEE SPNORB: LPMAX=6 BLUME-WATSON LIMIT C IF (NEW.EQ.0) THEN DO 40 J = 1,NTERMS C(J) = ZERO ZE(J) = ZERO IF (J.LE.MAXNCO) NCO(J) = 0 IRAD(J) = 0 40 CONTINUE ENDIF C ZMIN = ONE/TINY JZMIN = 1 WRITE (IWRITE,3100) C C READ IN THE RADIAL FUNCTIONS AND STORE THEM IN ARRAYS IN /RADIAL/ C DO 80 L = 1,LRANG1 MAXHF = MAXNHF(L) DO 70 N = L,MAXHF WRITE (IWRITE,3110) N,LVALUE(L) M1 = NLIMIT* (L-1) + N M = NCO(M1) IF (NEW.EQ.0) READ (IREAD,*) M MS = M*MAXNCO IF (M.GT.NCOEFF) CALL RECOV2('STG1RD','MXSLT ',MXSLT,MS) IF (M.GT.NCOEFF) GOTO 190 NCO(M1) = M JLAST = NCOEFF* (M1-1) JSTART = JLAST + 1 JEND = JLAST + M IF (NEW.EQ.0) THEN READ (IREAD,*) (IRAD(J),J=JSTART,JEND) READ (IREAD,*) (ZE(J),J=JSTART,JEND) READ (IREAD,*) (C(J),J=JSTART,JEND) ENDIF C C CHECK NORMALIZATION AND ORTHOGONALITY OF SLATER-TYPE ORBITALS. C JZMIN = THE TERM WITH THE SMALLEST EXPONENT, ZMIN, TO BE USED C TO FIND AN INITIAL ESTIMATE OF THE BOUNDARY RADIUS. C C WRITE OUT THE ORBITALS. C CALL STO(N,L) IF (IPLACE.GT.0) GOTO 190 DO 60 J = 1,M J1 = JLAST + J IF (ZE(J1).GE.ZMIN) GOTO 50 ZMIN = ZE(J1) JZMIN = J1 50 WRITE (IWRITE,3120) C(J1),IRAD(J1),ZE(J1) 60 CONTINUE 70 CONTINUE 80 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 C SET MODE = 0 FOR A PRINT-OUT OF THE BOUND ORBITALS AT RA. C IF (IBC.NE.0) THEN IF (NEW.EQ.0) READ (IREAD,*) RA,BSTO GOTO 100 ENDIF C RA = -LOG(TINORB)/ZMIN RA = RA + IRAD(JZMIN)*LOG(RA)/ZMIN IRA = INT(RA+HALF) 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 90 CONTINUE RA = IRA IF (RA.LT.FIFTH) RA = FIFTH MODE = -1 GOTO 110 C 100 CONTINUE WRITE (IWRITE,3090) RA,BSTO MODE = 0 C C EVALUATE THE AMPLITUDE OF THE BOUND ORBITALS ON THE BOUNDARY. C 110 CONTINUE DO 160 L = 1,LRANG1 MAXHF = MAXNHF(L) DO 150 N = L,MAXHF IF (NCOEFF.GT.0) THEN M1 = NLIMIT* (L-1) + N J1 = (M1-1)*NCOEFF M = NCO(M1) 120 CONTINUE PA = ZERO DO 130 J = 1,M PA = PA + C(J+J1)*RA**IRAD(J+J1)*EXP(-ZE(J+J1)*RA) 130 CONTINUE IF (MODE.EQ.0) GOTO 140 IF (ABS(PA).LE.TINORB) GOTO 150 RA = RA + FIFTH MODE = 1 GOTO 120 C ENDIF C I1 = IPOS(N,L) J1 = IRX(NIX) + 1 PA = UJ(J1,I1) 140 CONTINUE WRITE (IWRITE,3130) N,LVALUE(L),PA 150 CONTINUE 160 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) GOTO 180 IF (MODE.NE.0) THEN IF (MODE.GT.0) GOTO 100 IRA = IRA - 1 IF (IRA.LT.0) GOTO 100 GOTO 90 C ENDIF C C READ IN CORE DATA FROM FILE ITAPE1 IF REQUIRED C IF (IPSEUD.GT.0 .AND. ITAPE1.GT.0) THEN REWIND ITAPE1 READ (ITAPE1) LRANG1,LRANG2, (MAXNC(I),I=1,LRANG1) READ (ITAPE1) HINT,NIX, (IHX(I),I=1,NIX), (IRX(I),I=1,NIX) READ (ITAPE1) LPOT, (LPOSX(I),I=1,LRANG2) IF (LPOT.GT.MZLR1) CALL RECOV2('STG1RD',' MZLR1',MZLR1,LPOT) NPTS = IRX(NIX) IF (NPTS.GT.MZNPT) CALL RECOV2('STG1RD',' MZNPT',MZNPT,NPTS) DO 170 I = 1,LPOT READ (ITAPE1) (POTHAM(I,J),J=1,NPTS) 170 CONTINUE GOTO 180 C ENDIF C C DETERMINE THE INTEGRATION MESH, CHECK DIMENSIONS C IF (NRANG2.EQ.MZNR2 .AND. MAXE.LT.9999) NRANG2 = MIN(MZNR2, A INT(RA*SQRT(TWO*MAXE)/PI+HALF)+1) C IF (ABS(IBC).EQ.2) THEN READ (IREAD,*) J IF (J.GT.0) THEN IF (J.GT.MXNIX) CALL RECOV2('STG1RD','MXNIX ',MXNIX,J) READ (IREAD,*) (IHX(I),I=1,J) READ (IREAD,*) (IRX(I),I=1,J) NIX = J READ (IREAD,*) HINT,DELTA,ETA GOTO 180 ELSE READ (IREAD,*) X,DELTA,ETA ENDIF C ENDIF C CALL MESH C 180 CONTINUE WRITE (IWRITE,3140) NIX, (IHX(I),I=1,NIX) WRITE (IWRITE,3150) (IRX(I),I=1,NIX) WRITE (IWRITE,3160) HINT,DELTA,ETA 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 IF (NPOT.EQ.0) GOTO 190 WRITE (IWRITE,3170) NPOT IF (NEW.NE.0) GOTO 190 NPOT = MAX(0,NPOT) IF (NPOT.GT.6) CALL RECOV2('STG1RD','NPOT ',6,NPOT) IF (NPOT.GT.6) GOTO 190 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 RECOV2, C THEN CONTINUE WITH A FULL DIMENSION TEST BY SETTING NBUG7=1 C 190 CONTINUE IF (IPLACE.GT.0) NBUG7 = 1 IF (NBUG7.EQ.1) WRITE (IWRITE,3200) IF (IPSEUD.NE.0) THEN L=10 ! NRB 24/10/94 & NEW BELOW IF(NEW.EQ.0.AND.ITAPE1.EQ.0) READ (IREAD,*) L, (MAXNC(I),I=1,L) WRITE (IWRITE,3240) LPOT,LRANG1,LRANG2, (MAXNC(I),I=1,L) 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 ICHECK = 0 DO 200 I = 1,LRANG1 IF (MAXNC(I).EQ.MAXNHF(I)) ICHECK = 1 MAXPN(I) = MAXNHF(I) - MAXNC(I) + I - 1 200 CONTINUE C 3000 FORMAT (///30X,'SUBROUTINE STG1RD'/30X,17 ('-')) 3010 FORMAT (///1X,72 ('-')//1X,18A4//1X,72 ('-')////10X, A ' SSSSSSSS TTTTTTTTTT GGGGGGGG 111'/10X, B 'SSSSSSSSSS TTTTTTTTTT GGGGGGGGGG 1111'/10X, C 'SS TT GG GG 11111'/10X, D 'SS TT GG 11'/10X, E 'SS TT GG 11'/10X, F 'SSSSSSSSS TT GG 11'/10X, G ' SSSSSSSSS TT GG GGGG 11'/10X, H ' SS TT GG GGGG 11'/10X, I ' SS TT GG GG 11'/10X, J ' SS TT GG GG 11'/10X, K 'SSSSSSSSSS TT GGGGGGGGGG 11'/10X, L ' SSSSSSSS TT GGGGGGGG 11') 3020 FORMAT ( A /' NBUG PARAMETERS' B /' ---------------' C //' NBUG1 = ',I3 C /' NBUG2 = ',I3 C /' NBUG3 = ',I3 C /' NBUG4 = ',I3 C /' NBUG5 = ',I3 C /' NBUG6 = ',I3 C /' NBUG7 = ',I3 C /' NBUG8 = ',I3 C /' NBUG9 = ',I3) 3030 FORMAT ( A /' ICOPY = ',I3,' ... NOT USED' B /' ITOTAL = ',I3 C /' IPSEUD = ',I3 D //' MASS-CORRECTION (',I1,')' E /' DARWIN-TERM (',I1,')' F /' SPIN-ORBIT (',I1,')' G //' IZESP = ',I3 H /' IBANDW = ',I3) 3050 FORMAT ( A /' BASIC DATA' B /' ----------') 3060 FORMAT ( A /' NELC = ',I3 B /' NZ = ',I3 C /' LRANG1 = ',I3 D /' LRANG2 = ',I3 E /' NRANG2 = ',I3 F /' LAMAX = ',I3 G /' LAM = ',I3 H /' IBC = ',I3 I /' NPOT = ',I3 J /' LCB = ',I3 K /' ISMITN = ',I3 L /' LRANGD = ',I3 M /' LNOEX = ',I3) 3070 FORMAT (/(' MAXNHF = ',10I3)) 3080 FORMAT (/(' MAXNLG = ',10I3)) 3090 FORMAT ( A /' R-MATRIX BOUNDARY CONDITIONS' B /' ----------------------------' C //' RA = ',F10.5 D /' BSTO = ',F10.5 E //' AMPLITUDE OF THE FUNCTIONS AT RA' F /' --------------------------------') 3100 FORMAT (//' THE RADIAL FUNCTIONS'/24X,' SLATER-TYPE'/24X, A ' COEFFICIENT',6X,'POWER OF R',6X,'EXPONENT') 3110 FORMAT (/12X,I2,A1,' ORBITAL') 3120 FORMAT (24X,F12.5,9X,I3,9X,F9.5) 3130 FORMAT (1X,I2,A1,' ORBITAL',1P,E9.1) 3140 FORMAT ( A //' INTEGRATION MESH' B /' ----------------' C // ' NIX = ',I3 D //(' IHX = ',8I5)) 3150 FORMAT (/(' IRX = ',8I5)) 3160 FORMAT (1P, A /' HINT = ',E14.7, B //' DELTA = ',E14.7, C /' ETA = ',E14.7) 3170 FORMAT (/' PARAMETRIC POTENTIAL SPECIFIED: NPOT =',I3/) 3200 FORMAT (/' NBUG7=1, THIS IS A DIMENSION TEST RUN ONLY') 3210 FORMAT ( A/' INPUT-OUTPUT CHANNEL NUMBERS' B/' ----------------------------' C//' IREAD (',I2,') .. input data .. dstg1' C /' IWRITE (',I2,') .. printed output .. rout1r' C /' IPUNCH (',I2,') .. punched output .. radout' C /' IDISC1 (',I2,') .. NOT USED' C /' IDISC2 (',I2,') .. NOT USED' C /' IDISC3 (',I2,') .. NOT USED' C /' IDISC4 (',I2,') .. NOT USED' C /' ITAPE1 (',I2,') .. model potential', C ' .. STG1.POT .. if ITAPE1>0' C /' ITAPE2 (',I2,') .. NOT USED' C /' ITAPE3 (',I2,') .. STG1 dump ', C ' .. STG1.DAT .. always used' C /' ITAPE4 (',I2,') .. NOT USED' C /' JDISC1 (',I2,') .. RK.DAT' C /' JDISC2 (',I2,') .. NOT USED') 3220 FORMAT (30X,' INPUT CHANNEL ITAPE',I1,' =',I5) 3230 FORMAT (30X,' OUTPUT CHANNEL ITAPE',I1,' =',I5) 3240 FORMAT ( A /' LPOT = ',I3 B /' LRANG1 = ',I3 C /' LRANG2 = ',I3 D //(' MAXNC = ',10I3)) 3260 FORMAT (/(' ZESP = ',3F14.7)) 3270 FORMAT (/(' MAXNCB = ',10I3)) 3280 FORMAT ( A //5X,'COMPILED FOR DIMENSIONS' A /5X,'-----------------------'//5X, A 'FACTORIAL VALUES IN /FACT/ MZFAC = ',I4/5X, B 'ORDER OF MULTIPOLES IN POTENTIAL MZLMX = ',I4/5X, C 'NO. OF BOUND ANGULAR MOMENTA MZLR1 = ',I4/5X, D 'NO. OF CONTINUUM ANGULAR MOM. MZLR2 = ',I4/5X, E 'MWORDS OF RK INTEGRALS IN /MEMORY/ MZMEG = ',I4/5X, E 'KWORDS OF RK INTEGRALS IN /MEMORY/ MZKIL = ',I4/5X, F 'MAXIMUM NO. OF INTEG. POINTS MZNPT = ',I4/5X, G 'MAXIMUM N FOR BOUND ORBITALS MZNR1 = ',I4/5X, H 'MAXIMUM VALUE OF NRANG2 MZNR2 = ',I4/5X, I 'MAXIMUM NO. OF BOUND ORBITALS MXORB = ',I4//) 3290 FORMAT (18A4) END C C C SUBROUTINE STO(N,L) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CHECK NORMALIZATION OF SLATER-TYPE ORBITAL LABELLED (N,L-1), C IF NECESSARY CONVERT CLEMENTI-LIKE COEFFICIENTS TO SLATER-TYPE. C ALSO CHECK ORTHOGONALITY WITH BOUND ORBITALS OF SMALLER N. C C----------------------------------------------------------------------- PARAMETER (TEST=0.01D0) C INCLUDE 'PARAM' C PARAMETER (MXNL1=MZNR1*MZLR1) PARAMETER (MXSLT=MXNL1*MZNR1+MXNL1*10) C COMMON /FACT/GAMMA(MZFAC) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RADIAL/C(MXSLT),ZE(MXSLT),IRAD(MXSLT),NCO(MXNL1),NCOEFF, A NLIMIT C----------------------------------------------------------------------- C C CHECK NORMALIZATION. ALSO CHECK DIMENSION OF FACTORIAL ARRAY. C M1 = NLIMIT* (L-1) + N JLAST = NCOEFF* (M1-1) X = 0.0D0 DO 10 J = 1,NCO(M1) J1 = JLAST + J NFACT = IRAD(J1) + IRAD(J1) + 1 IF (NFACT.GT.MZFAC) THEN CALL RECOV2('STO ',' MZFAC',MZFAC,NFACT) RETURN C ENDIF C IF (IRAD(J1).LT.L .OR. ZE(J1).LE.0.0D0) WRITE (IWRITE, A *) ' * WARNING FROM STO *',IRAD(J1),' OR',ZE(J1), B ' SEEM WRONG. PROGRAM CONTINUES.' X = X + C(J1)*ORNO(J,N,N,L) 10 CONTINUE IF (ABS(X-1.0D0).GT.TEST) THEN C C CONVERT CLEMENTI-TYPE COEFFICIENTS TO SLATER-TYPE C DO 20 J = 1,NCO(M1) J1 = J + JLAST IR = IRAD(J1) Y = 2*ZE(J1) C(J1) = C(J1)*SQRT(Y/GAMMA(IR+IR+1))*Y**IR 20 CONTINUE X = 0.0D0 DO 30 J = 1,NCO(M1) X = X + C(J+JLAST)*ORNO(J,N,N,L) 30 CONTINUE N2 = N IF (ABS(X-1.0D0).GT.TEST) GOTO 70 ENDIF C C RENORMALIZE THE ORBITAL C Y = SQRT(X) DO 40 J = 1,NCO(M1) J1 = JLAST + J C(J1) = C(J1)/Y 40 CONTINUE C C CHECK ORTHOGONALITY C IF (N.EQ.L) RETURN DO 60 N2 = L,N - 1 X = 0.0D0 DO 50 J = 1,NCO(M1) X = X + C(JLAST+J)*ORNO(J,N2,N,L) 50 CONTINUE IF (X.GT.TEST) GOTO 70 60 CONTINUE RETURN C 70 CONTINUE WRITE (IWRITE,*) ' * ORTHONORMALITY ERROR IN STO *', A ' THE OVERLAP INTEGRAL BETWEEN ORBITALS',N2,N,' IS',X STOP C END C C C SUBROUTINE TABORB(IOUT,MO) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C WRITES OUT ORBITAL DATA TO CHANNEL IOUT IN SUPERSTRUCTURE FORMAT C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL3=MZLR1+MZLR2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTEN/CPOT(6),XPOT(6),IPOT(6),NPOT COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) COMMON /SIMP/R(MZNPT),STEP(MZNPT),WT(MZNPT), 1 RK(MZNPT,-MXL3:MXL3),NC C CHARACTER*4 IHEAD C PARAMETER (ZERO=0.0D0) PARAMETER (ONE=1.0D0) C DATA NULL/0/,IHEAD/'STG1'/ C----------------------------------------------------------------------- C C WRITE HEADER FOR S.S. DATA, C NUMBER OF ORBITALS(MO), MESH POINTS(NO), ELECTRONS NELC, CHARGE DZ C DZ = NZ IF (IOUT.LE.0) GOTO 30 ZZZ = DZ** (ONE/3) C WRITE (IOUT,3020) MO,R(2),R(NC),NC,NELC,NZ,IHEAD !SS - WERNER? WRITE (IOUT,3020) MO,NULL,NC,NELC,DZ,IHEAD !AS - NRB C C WRITE MESH POINTS FROM ARRAY R. C KEY = -8 DO 20 I = 1,NC,2 J = I + 1 IF (J.GT.NC) J = 1 IF (NPOT.GT.0) GOTO 10 ! .LT. -> .GT. PX(I) = (EXP(-ZZZ*R(I))-ONE)* (NELC-1) + DZ PX(J) = (EXP(-ZZZ*R(J))-ONE)* (NELC-1) + DZ 10 WRITE (IOUT,3000) KEY,I,R(I),PX(I),J,R(J),PX(J),IHEAD 20 CONTINUE C C LOOP OVER ANGULAR MOMENTUM AND N VALUES OF ORBITALS C 30 CONTINUE DO 70 LP = 1,LRANG1 MAXHF = MAXNHF(LP) IF (MAXHF.LT.LP) GOTO 70 IF (IOUT.LE.0) GOTO 70 L = LP - 1 DO 60 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 = ZERO IF (N*N*ABS(DUJ(NC-1,K)).GE.DZ*DZ*ABS(UJ(NC-1,K))) GOTO 40 EPS = (R(NC-1)*DUJ(NC-1,K)/UJ(NC-1,K)- A R(NC-2)*DUJ(NC-2,K)/UJ(NC-2,K))/ (R(NC-1)-R(NC-2)) 40 CONTINUE NO = (NC+1)/2 C WRITE (IOUT,3010) K,N,L,DZ,NELC,ZERO,NO,EPS,IHEAD !SS - WERNER? WRITE (IOUT,3010) K,N,L,ZERO,EPS,NO,IHEAD !AS - NRB C 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 50 I = 1,NC,2 J = I + 1 IF (J.GT.NC) J = 1 WRITE (IOUT,3000) KEY,I,UJ(I,K),DUJ(I,K),J,UJ(J,K),DUJ(J,K) C A ,IHEAD,K 50 CONTINUE 60 CONTINUE 70 CONTINUE IF (IOUT.GT.0) WRITE (IOUT,3000) NULL C 3000 FORMAT (I5,2 (I4,1P,2E14.7),3X,A4,I2,I1,A1) C 3010 FORMAT (' -7',I5,2X,2I3,F4.0,I3,F12.6,I6,F12.6,17X,A4,2X,I1,A1) 3010 FORMAT (' -7',2I5,I3,F5.1,2X,F12.6,I6,29X,A4) C 3020 FORMAT (' -9',I5,1X,F5.4,F7.2,I5,I4,I4,36X,A4) 3020 FORMAT (' -9',2I5,9X,I4,I4,F5.1,35X,A4) END C-NRB NX WRITES ----------------------------------------------------------- SUBROUTINE WRINX1 IMPLICIT REAL*8 (A-H,O-Z) C C THIS SUBROUTINE TO BE INSERTED IN RMATRX STG1 . C NOTE THAT THE COMMON BLOCKS, WHICH DIFFER IN DIFFERENT C VERSIONS OF STG1, MUST BE MADE CONSISTENT. HERE THEY C THEY MATCH THE IRON PROJECT BREIT-PAULI CODES. C WRITES A FILE TO BE READ BY THE NOEXCHANGE PROGRAM C FILE NAMED tapenx1 SHOULD BE SAVED IN THE JCL IF A RUN C OF NX IS TO FOLLOW FOR HIGHER L AT SOME TIME. C C INCLUDE 'PARAM' C PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) PARAMETER (MXNIX=MZNPT/16) PARAMETER (MXPOS=MZNR1+MZNR2+MZLR2-1) PARAMETER (MXPT2=2*MZNPT) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBQ=MZNR2*MZLR1+MXORB) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /INIT/HINT,IHX(MXNIX),IRX(MXNIX),NIX,IMATCH COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /ORBTLS/UJ(MZNPT,MXORBS),DUJ(MZNPT,MXORBQ),NBOUND, A IPOS(MXPOS,MZLR2) COMMON /POTVAL/POVALU(MXPT2),PX(MZNPT) C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc c **** parallel **** C INX1=35 C c **** parallel **** if (iam.eq.0) then OPEN (INX1,FILE='NX1.DAT',STATUS='UNKNOWN',FORM='UNFORMATTED') else OPEN (INX1,FILE='NX1g.DAT',STATUS='UNKNOWN',FORM='UNFORMATTED') endif c **** parallel **** C C FIRST WRITE DIMENSIONS FOR THE NX RUN C C IN CASE A USER REQUIRES TO RUN NX AT LOW L THE C DIMENSIONS NLAG AND NSHM ARE SET. C NLAG=1 NSHM=1 DO 1 I=1,LRANG1 NHF=MAXNHF(I) NLG=MAXNLG(I) NLAG=MAX(NLAG,NLG-I+1) NSHM=MAX(NSHM,NHF-NLG) 1 CONTINUE C NPTS=IRX(NIX)+1 C NRKPTS=MXMEM/1000 +1 NRKPTS=MZMEG WRITE (INX1)LRANG1,NRANG2,LAMAX,NIX,NPTS,NRKPTS,NLAG,NSHM C WRITE (INX1) NELC,NZ,LRANG2,IPSEUD WRITE (INX1) (MAXNHF(I),I=1,LRANG1),(MAXNLG(I),I=1,LRANG1) WRITE (INX1) HINT,(IHX(I),I=1,NIX),(IRX(I),I=1,NIX) NPTS=IRX(NIX) IF(IPSEUD.GT.0)THEN WRITE(INX1)(MAXNC(I),I=1,LRANG1) WRITE(INX1)LPOT,(LPOSX(I),I=1,LPOT) DO 2 I=1,LPOT WRITE(INX1)(POTHAM(J,I),J=1,NPTS) 2 CONTINUE ENDIF C EK2MAX=0.5D0*EIGENS(NRANG2,1) WRITE (INX1) RA,BSTO,EK2MAX C DO 3 L=1,LRANG1 DO 4 N=L,MAXNHF(L) NQ=IPOS(N,L) WRITE (INX1) (UJ(I,NQ),I=1,NPTS+1) 4 CONTINUE 3 CONTINUE C WRITE (INX1) (POVALU(I),I=1,NPTS*2) C ENDFILE INX1 CLOSE (INX1) C RETURN END C C C SUBROUTINE WRITAP(ICODE) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C WRITES THE BASIC INFORMATION ONTO THE OUTPUT FILE ITAPE3 C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN3=MZNR1+MZNR2) PARAMETER (MXN31=MXN3+1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MXN3,MZLR2),ENDS(MXN31,MZLR2),DELTA,ETA COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CORE/POTHAM(MZNPT,MZLR1),LPOT,LPOSX(MZLR2),MAXPN(MZLR2), A ICHECK,IPSEUD,KCOR COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DW/IDWOUT,LNOEX COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /REL/IRELOP(3) COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /NRBDIP/LRANGD c **** parallel **** include 'mpif.h' common /parablock/iam,nproc c **** parallel **** C C----------------------------------------------------------------------- ITAPE = ITAPE3 REWIND ITAPE C IF(LNOEX.NE.999)LAM=1000*LAM+LNOEX+1 C WRITE (ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,IZESP, A (IRELOP(I),I=1,3),KCOR,LRANGD,nproc C IF (ICODE.EQ.13) THEN DO 10 L = 1,LRANG1 MAXPN(L) = MAXNHF(L) - MAXNC(L) + L - 1 10 CONTINUE ELSE DO 20 L = 1,LRANG1 MAXPN(L) = MAXNHF(L) 20 CONTINUE ENDIF C WRITE (ITAPE) (MAXPN(L),L=1,LRANG1), (MAXNLG(L),L=1,LRANG1), A (MAXNC(L),L=1,LRANG1) C DO 30 L = 1,LRANG2 WRITE (ITAPE) (EIGENS(N,L),N=1,NRANG2) WRITE (ITAPE) (ENDS(N,L),N=1,NRANG2+1) 30 CONTINUE C H = 0.0D0 WRITE (ITAPE) RA,BSTO,H,DELTA,ETA,0 C IF (LRANG2.GT.0) WRITE (ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) C END C C C subroutine ynear0(k,lp,npts,R,X,RT,AR,nmax,mode) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- c c kab: Replace the near-origin terms of AR and RT c nrb: corrections (all) and first attempt at modifying for B&W. c In practice, ynear0 has no effect on the final integrals. c C----------------------------------------------------------------------- parameter( ONE=1.0d0 ) dimension R(npts),X(npts),AR(npts),RT(npts) c m = k + 1 - lp -1 !m->m-1 nrb lp2=lp if(mode.ne.0)then !nrb m=m+2 lp2=lp+2 endif m11 = k + lp + 1 c c nrb - moved into rs for sum2 upper bound. And float(m)->float(m11) c rat = 3 c nmax = max( int(ONE/(rat**(ONE/float(m)) - ONE)), 0) c if( mod(nmax,2).eq.1 ) nmax = nmax - 1 c if( nmax.eq.0 )return c m1 = 1 - m m2 = 2 - m rlp = R(nmax)**(lp+1) orbs = X(nmax)/R(nmax)**lp do i = 1, nmax - 1 orbr = X(i)/R(i)**lp hh = R(nmax) - R(i) tmp = hh*m1*m2 tmp1 = R(i)**(lp+1) tmp2 = rlp*(R(i)/R(nmax))**k am21 = (tmp2 - tmp1*(ONE + m2*hh/R(i)))/tmp am12 = (tmp1 - tmp2*(ONE - m2*hh/R(nmax)))/tmp arrr = am21*orbr + am12*orbs ar(i) = arrr + AR(nmax)*R(i)**k !X(i)->R(i) nrb rt(i) = (orbr*R(i)**lp2)/m11 c print*,i,arr(i),arrr,arr(nmax) enddo rt(nmax) = (orbs*R(nmax)**lp2)/m11 return end