C GRASP0.f v9.9 nrb 30 Jun 2021 c c GRASP0.f v8.5 phn 30 May 2006 c c v9.9: Bug-fix COULG did not re-initialize L-spinor c flag to .false. for l>0 for any non-L-spinors - cpb c v9.8: Bug-fix OSCL/PRINTA E1 vel/len divide by zero - nrb c All level dimensions i4,and interfacing with c grasp.adf04/grasprad - cpb c v9.7: OSCL 4 gives magnetic sub-level resolution - cpb c v9.6: Pure SCF option when no MCP.DAT (& ANG 8) - nrb c v9.5: Diagonalize each H(Jp) separately - nrb c v9.4: L-spinor basis for use with DARC DRMPS - nrb c PROGRAM GRASP C ====================================================================== C C DARC, the Dirac Atomic R-matrix Codes. C homepage: http://www.am.qub.ac.uk/DARC/ C GRASP0 module C C ====================================================================== C C Any inquiries or comments on the code can be directed to Dr Patrick C Norrington at : C C Department of Applied Mathematics and Theoretical Physics C The Queen's University of Belfast C Belfast C Northern Ireland C BT7 1NN C United Kingdom C C email : p.norrington@qub.ac.uk C homepage : http://www.am.qub.ac.uk/users/p.norrington C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Local variables C CHARACTER*60 AUT,DAT,REV,SOU C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Conversion factors for units and constants C C XCON1 is the electron mass in amu C XCON2 is the Hartree energy in cm-1 C XCON3 is the Hartree energy in eV C XCON4 converts from cm-1 to Angstrom C XCL is the speed of light in a.u. or 1/fine-structure constant C XPI is pi C XTAU is the atomic unit of time in seconds C XCON1 = 9.10938188D-31/1.66053873D-27 XCON2 = 2.194746313710D5 XCON3 = 27.2113834D0 XCON4 = 1.D8 XCL = 137.03599976D0 XPI = 3.141592653589793D0 XTAU = 2.418884326500D-17 C----------------------------------------------------------------------- C C Set the stream numbers for : C C (1) reading from input data (IREAD) C (2) writing to lineprinter (IWRITE) C (3) further output stream (IPUNCH) C IREAD = 5 IWRITE = 7 IPUNCH = 8 C OPEN (UNIT=IWRITE,FILE='GRASP.OUT',STATUS='UNKNOWN') OPEN (UNIT=IPUNCH,FILE='GRASP.PUN',STATUS='UNKNOWN') C----------------------------------------------------------------------- WRITE (IWRITE,4002) 4002 FORMAT(/' NJSYM version') C----------------------------------------------------------------------- SOU = '$Source: /home/badnell/grasp0 ' AUT = '$Author: nrb' DAT = '$Date: Fri May 27 17:02:04 BST 2011 $' REV = "$Revision: 9.8, derived from phn's 8.5 $ " C PRINT 3000,SOU,AUT,DAT,REV WRITE (IWRITE,3000) SOU,AUT,DAT,REV WRITE (IPUNCH,3000) SOU,AUT,DAT,REV C----------------------------------------------------------------------- CALL AA C----------------------------------------------------------------------- 3000 FORMAT (/1X,71('*')/1X,A60/1X,A60/1X,A60/1X,A60/1X,71('*')// +' DARC, the Dirac Atomic R-matrix Codes.'/ +' homepage: http://www.am.qub.ac.uk/DARC/'/ +' GRASP0 module'/' Coded in double precision FORTRAN' +//' Any inquiries or comments on the code can be directed to'/ +' Dr Patrick Norrington at :'// +' Department of Applied Mathematics and Theoretical Physics'/ +' The Queens University of Belfast'/' Belfast'/' Northern Ireland' +/' BT7 1NN'/' United Kingdom'// +' email : p.norrington@qub.ac.uk'/ +' homepage : http://www.am.qub.ac.uk/users/p.norrington'//1X,71( +'*')) END C C ******************* C SUBROUTINE AA C C----------------------------------------------------------------------- C C This routine directs control to each section in turn. C C After processing one problem it loops back indefinitely to start a C new problem, unless label STOP has been read. C C AA C BENA C CALEN C DATAIN C DIMPRT C DIMSET C MCDF C MCP C OSCL C QUARTZ C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N10 PARAMETER (N10=MXNX*MXNC) INTEGER N11 PARAMETER (N11=MXNP+10) INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) INTEGER NPLX PARAMETER (NPLX=14) C C Local variables C CHARACTER EMPTY,INPREC(80) DOUBLE PRECISION TIM1,TIM2,TIM3,TIM4 DOUBLE PRECISION TIMT1,TIMT2,TIMT3,TIMT4 INTEGER I,INPUNI,IO1,IO2 INTEGER IO3,IO4,IO5,IO6 INTEGER IO7,IO8,IP2,IP3 INTEGER IR1,IR2,IR3,ISTOP INTEGER LENREC LOGICAL EX,TBENA,TMCDF,TMCP LOGICAL TMCT C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),MMOM,NMOM LOGICAL FREE(MANGM) COMMON / ANG00 / MMOM,NMOM,J1,J2,J3,FREE C C Common variables C INTEGER IBREIT,ICOUL,IEXCH COMMON / ANG01 / ICOUL,IBREIT,IEXCH C C Common variables C INTEGER NOUT1 COMMON / ANG02 / NOUT1 C C Common variables C INTEGER ITOT(9),JTOT(9),KTOT(9) COMMON / ANG03 / ITOT,JTOT,KTOT C C Common variables C INTEGER IME,JA,JB,NWA COMMON / ANG04 / IME,JA,JB,NWA C C Common variables C INTEGER ICORE(MXNW) COMMON / ANG05 / ICORE C C Common variables C INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW) INTEGER JTQ1(3),JTQ2(3) COMMON / ANG08 / JBQ1,JBQ2,JTQ1,JTQ2 C C Common variables C INTEGER J2S(MTRIAD,3),J3S(MTRIAD,3) COMMON / ANG09 / J2S,J3S C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C C Common variables C DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP) DOUBLE PRECISION WIJ(2) COMMON / BESS1 / WIJ,BESSJ,BESSN C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION BREVEC(MXNC,MXNC) COMMON / BRET2 / BREVEC C C Common variables C INTEGER LABEL COMMON / CARD / LABEL C C Common variables C DOUBLE PRECISION TIME1,TIME2 COMMON / CASIO / TIME1,TIME2 C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION XCAX COMMON / CONVG / XCAX C C Common variables C INTEGER IDN(5),IDNL(16,5),IDNS(16,5) INTEGER IDNV(16,5) COMMON / CSFD / IDNV,IDNS,IDNL,IDN C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION CHECK INTEGER NITIT COMMON / DEF04 / CHECK,NITIT C C Common variables C DOUBLE PRECISION WT(MXNC) INTEGER ITY COMMON / DEF05 / WT,ITY C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC) COMMON / ENRG2 / VPENG,SFENG C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP) DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP) COMMON / INT3 / XU,XV,XR,XS,XF,XG C C Common variables C INTEGER LEVELS(MXNC),NLEV COMMON / LEVL / NLEV,LEVELS C C Common variables C DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2 COMMON / LEVM / ENLEV,GAUGE1,GAUGE2 C C Common variables C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C DOUBLE PRECISION CXCF(MXNE) INTEGER JXCF(MXNE),NSCF,NSCFY COMMON / MCPC / CXCF,JXCF,NSCF,NSCFY C C Common variables C INTEGER IOPAR,KA COMMON / MCTA / KA,IOPAR C C Common variables C INTEGER NBPAR,NCPAR,NMOTYP COMMON / MPAR1 / NMOTYP,NBPAR,NCPAR C C Common variables C DOUBLE PRECISION APAR,BBPAR(4),BPAR(4) DOUBLE PRECISION CCPAR(4),CPAR(4) COMMON / MPAR2 / APAR,BPAR,BBPAR,CPAR,CCPAR C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C DOUBLE PRECISION TC(MXNC,MXNC) COMMON / NRD00 / TC C C Common variables C INTEGER JPOS(4),MLX(4),MQX(4),NOPEN COMMON / NRD01 / MLX,MQX,JPOS,NOPEN C C Common variables C INTEGER LSVT(5,16,4),NTERM(4) COMMON / NRD02 / NTERM,LSVT C C Common variables C INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC) COMMON / NRD03 / NPX,NLX,NQX C C Common variables C INTEGER IPOS(MXNW),KPOS(4,MXNC) INTEGER NPOS(MXNC) COMMON / NRD04 / IPOS,NPOS,KPOS C C Common variables C INTEGER JSCUP(8,MXNC) COMMON / NRD05 / JSCUP C C Common variables C INTEGER LSV(5,4,MXNC) COMMON / NRD06 / LSV C C Common variables C INTEGER JFX(MXNC),KOPEN(MXNC) COMMON / NRD08 / JFX,KOPEN C C Common variables C DOUBLE PRECISION ECV(MXNO) INTEGER IECC(MXNO),NEC COMMON / OFFD / ECV,IECC,NEC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C INTEGER JTC(20) COMMON / OPT02 / JTC C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C INTEGER LTC(20) COMMON / OPT04 / LTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C DOUBLE PRECISION CXP(MXNW) COMMON / ORB03 / CXP C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER IASPAR(MXNC),IATJPO(MXNC) COMMON / OSC1 / IATJPO,IASPAR C C Common variables C INTEGER KK,LK COMMON / OSC2 / LK,KK C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV C C Common variables C INTEGER LORDER(MXNC) COMMON / PAT2 / LORDER C C Common variables C CHARACTER*14 NRCSF(MXNC) COMMON / PATX / NRCSF C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C INTEGER NPOTYP COMMON / PPAR1 / NPOTYP C C Common variables C DOUBLE PRECISION POLPAR(2) COMMON / PPAR2 / POLPAR C C Common variables C INTEGER NUMC,NUMR,NUMSTO COMMON / RACAHV / NUMC,NUMR,NUMSTO C C Common variables C INTEGER JCHOP(MXNW,MXNC) COMMON / SAVE2 / JCHOP C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C INTEGER ICD2(3,3,3),ICD3(5,5,6),ICD4(8,8,7) INTEGER ICD5(10,10,7),JJDN(10,7,3) INTEGER LSDN(10,7,3),NCD2(3),NCD3(6) INTEGER NCD4(7),NCD5(7),NDN(7,3) COMMON / TCD / ICD2,NCD2,ICD3,NCD3,ICD4,NCD4,ICD5,NCD5,NDN,JJDN! + ,LSDN C C Common variables C INTEGER ICP2(2,2),ICP3(3,3) COMMON / TCP / ICP2,ICP3 C C Common variables C INTEGER ITAB(16),JTAB(16),NROWS INTEGER NTAB(255) COMMON / TERMS / NROWS,ITAB,JTAB,NTAB C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF C C Common variables C DOUBLE PRECISION WFACT COMMON / WFAC / WFACT C C Common variables C INTEGER ILO(MXNW),IWO(MXNW),NWO COMMON / WRO / NWO,IWO,ILO Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA TIMT1,TIMT2,TIMT3,TIMT4/0.D0,0.D0,0.D0,0.D0/ DATA TIM1,TIM2,TIM3,TIM4/0.D0,0.D0,0.D0,0.D0/ DATA EMPTY/' '/ C----------------------------------------------------------------------- CALL QUARTZ(-1) CALL CALEN(IWRITE,IPUNCH,RECORD) CALL DIMSET(IWRITE) CALL DIMSET(IPUNCH) C INQUIRE (FILE='GRASP.INP',EXIST=EX) IF (.NOT.EX) THEN PRINT 3170 STOP ENDIF OPEN (UNIT=IREAD,FILE='GRASP.INP',STATUS='OLD',FORM='FORMATTED') C INPUNI = 9 OPEN (UNIT=INPUNI,STATUS='SCRATCH',FORM='FORMATTED',ACCESS='SEQUEN! +TIAL') WRITE (IWRITE,3020) WRITE (IPUNCH,3020) 10 CONTINUE READ (IREAD,3000,END=30) INPREC DO I = 80,1,-1 IF (INPREC(I).NE.EMPTY) THEN LENREC = I GOTO 20 ENDIF ENDDO LENREC = 1 20 CONTINUE WRITE (INPUNI,3000) (INPREC(I),I=1,LENREC) WRITE (IWRITE,3010) (INPREC(I),I=1,LENREC) WRITE (IPUNCH,3010) (INPREC(I),I=1,LENREC) GOTO 10 30 CONTINUE REWIND INPUNI WRITE (IWRITE,3030) WRITE (IPUNCH,3030) IREAD = INPUNI C----------------------------------------------------------------------- NUMC = 0 NUMR = 0 NUMSTO = 0 C----------------------------------------------------------------------- 40 CONTINUE IO1 = -1 IO2 = -1 IO3 = -1 IR1 = -1 IR2 = -1 IP2 = -1 IR3 = -1 IP3 = -1 IO4 = -1 IO5 = -1 IO6 = -1 IO7 = -1 IO8 = -1 TMCP = .FALSE. TMCT = .FALSE. TMCDF = .FALSE. TBENA = .FALSE. C PRINT 3180 CALL DATAIN(ISTOP,IO1,IO2,IO3,IR2,IR3,IP3) C----------------------------------------------------------------------- C C JTC(J) J=10,20 control which programs are called. C C 10 - CFOUT called C 11 - switch set on ANG input record to control calls to all C angular packages C 12 - MCP called C 13 - MCDF called C 14 - MCT called C 15 - MCBP called C 16 - BENA called C 17 - OSCL called C C----------------------------------------------------------------------- C C MCP/MCT/MCBP sections C IF (JTC(12).EQ.1 .OR. JTC(15).EQ.1) THEN IF (IO1.GT.0 .OR. IO3.GT.0) THEN IF (IO1.GT.0) IO1 = 21 IF (IO3.GT.0) IO3 = 21 OPEN (UNIT=21,FILE='MCP.DAT',FORM='UNFORMATTED',STATUS='UNKNOW! +N') TMCP = .TRUE. ENDIF ENDIF C IF (JTC(14).EQ.1) THEN IF (IO2.GT.0) THEN IO2 = 22 OPEN (UNIT=IO2,FILE='MCT.DAT',FORM='UNFORMATTED',STATUS='UNKNO! +WN') TMCT = .TRUE. ENDIF ENDIF C IF (JTC(12).EQ.1 .OR. JTC(15).EQ.1 .OR. JTC(14).EQ.1) THEN PRINT 3050 CALL MCP(IO1,IO2,IO3) CALL QUARTZ(0) TIM1 = TIME2 TIMT1 = TIMT1+TIM1 ENDIF C----------------------------------------------------------------------- C C MCDF section C IF (JTC(13).EQ.1) THEN C IR1 = 21 INQUIRE (FILE='MCP.DAT',EXIST=EX) IF (.NOT.EX) THEN if(ncmin.eq.0)then !pure SCF run - nrb 25/09/09 ir1=0 jtc(13)=0 jtc(16)=0 jtc(17)=0 go to 50 else WRITE (IWRITE,3070) WRITE (IPUNCH,3070) PRINT 3070 STOP endif ENDIF IF (TMCP) THEN REWIND 21 ELSE OPEN (UNIT=21,FILE='MCP.DAT',FORM='UNFORMATTED',STATUS='UNKNOW! +N') TMCP = .TRUE. ENDIF C 50 IF (IR2.GT.0) THEN IR2 = 24 INQUIRE (FILE='MCDF.DMP',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3080) WRITE (IPUNCH,3080) PRINT 3080 STOP ENDIF OPEN (UNIT=IR2,FILE='MCDF.DMP',FORM='UNFORMATTED',STATUS='UNKN! +OWN') ENDIF C IP2 = 25 OPEN (UNIT=IP2,FILE='MCDF.DAT',FORM='UNFORMATTED',STATUS='UNKNOW! +N') TMCDF = .TRUE. C IF (IR3.GT.0) THEN IR3 = 26 INQUIRE (FILE='ORBIN.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3090) WRITE (IPUNCH,3090) PRINT 3090 STOP ENDIF OPEN (UNIT=IR3,FILE='ORBIN.DAT',FORM='UNFORMATTED',STATUS='UNK! +NOWN') ENDIF C IF (IP3.GT.0) THEN IP3 = 27 OPEN (UNIT=IP3,FILE='ORBOUT.DAT',FORM='UNFORMATTED',STATUS='UN! +KNOWN') ENDIF C PRINT 3060 CALL MCDF(IR1,IR2,IP2,IR3,IP3) CALL QUARTZ(0) TIM2 = TIME2 TIMT2 = TIMT2+TIM2 C ENDIF C----------------------------------------------------------------------- C C BENA section C IF (JTC(16).EQ.1) THEN C IO4 = 21 INQUIRE (FILE='MCP.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3110) WRITE (IPUNCH,3110) PRINT 3110 STOP ENDIF IF (TMCP) THEN REWIND 21 ELSE OPEN (UNIT=21,FILE='MCP.DAT',FORM='UNFORMATTED',STATUS='UNKNOW! +N') TMCP = .TRUE. ENDIF C IO5 = 25 INQUIRE (FILE='MCDF.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3120) WRITE (IPUNCH,3120) PRINT 3120 STOP ENDIF IF (TMCDF) THEN REWIND 25 ELSE OPEN (UNIT=25,FILE='MCDF.DAT',FORM='UNFORMATTED',STATUS='UNKNO! +WN') TMCDF = .TRUE. ENDIF C IO6 = 30 OPEN (UNIT=IO6,FILE='BENA.DAT',FORM='UNFORMATTED',STATUS='UNKNOW! +N') TBENA = .TRUE. C PRINT 3100 CALL BENA(IO4,IO5,IO6) CALL QUARTZ(0) TIM3 = TIME2 TIMT3 = TIMT3+TIM3 C ENDIF C----------------------------------------------------------------------- C C OSCL section C IF (JTC(17).EQ.1) THEN C IO7 = 22 INQUIRE (FILE='MCT.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3140) WRITE (IPUNCH,3140) PRINT 3140 STOP ENDIF IF (TMCT) THEN REWIND 22 ELSE OPEN (UNIT=22,FILE='MCT.DAT',FORM='UNFORMATTED',STATUS='UNKNOW! +N') TMCT = .TRUE. ENDIF C IO8 = 30 INQUIRE (FILE='BENA.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3150) WRITE (IPUNCH,3150) PRINT 3150 IO8 = 25 INQUIRE (FILE='MCDF.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,3160) WRITE (IPUNCH,3160) PRINT 3160 STOP ENDIF IF (TMCDF) THEN REWIND 25 ELSE OPEN (UNIT=25,FILE='MCDF.DAT',FORM='UNFORMATTED',STATUS='UNK! +NOWN') TMCDF = .TRUE. ENDIF ELSE IF (TBENA) THEN REWIND 30 ELSE OPEN (UNIT=30,FILE='BENA.DAT',FORM='UNFORMATTED',STATUS='UNK! +NOWN') TBENA = .TRUE. ENDIF ENDIF C PRINT 3130 CALL OSCL(IO7,IO8) CALL QUARTZ(0) TIM4 = TIME2 TIMT4 = TIMT4+TIM4 C ENDIF C----------------------------------------------------------------------- WRITE (IWRITE,3040) WRITE (IWRITE,3210) C IF (TIMT1.GT.EPS10) THEN WRITE (IWRITE,3220) TIM1,TIMT1 ENDIF C IF (TIMT2.GT.EPS10) THEN WRITE (IWRITE,3230) TIM2,TIMT2 ENDIF C IF (TIMT3.GT.EPS10) THEN WRITE (IWRITE,3240) TIM3,TIMT3 ENDIF C IF (TIMT4.GT.EPS10) THEN WRITE (IWRITE,3250) TIM4,TIMT4 ENDIF C IF (NUMC+NUMR.GT.0) THEN WRITE (IWRITE,3040) WRITE (IWRITE,3200) NUMC,NUMR,NUMC + NUMR,NUMSTO ENDIF C IF (IR2.GT.0) CLOSE (24) IF (IR3.GT.0) CLOSE (26) IF (IP3.GT.0) CLOSE (27) IF (TMCP) CLOSE (21) IF (TMCT) CLOSE (22) IF (TMCDF) CLOSE (25) IF (TBENA) CLOSE (30) C WRITE (IWRITE,3040) C IF (ISTOP.EQ.1) THEN CALL DIMPRT PRINT 3190 ELSE GOTO 40 ENDIF C----------------------------------------------------------------------- 3000 FORMAT (80A1) 3010 FORMAT (1X,80A1) 3020 FORMAT (/1X,71('*')/' Input data follows'/1X,71('*')) 3030 FORMAT (1X,71('*')) 3040 FORMAT (/1X,71('*')) 3050 FORMAT (/' calling routine MCP') 3060 FORMAT (/' calling routine MCDF') 3070 FORMAT (/' MCP.DAT does not exist : STOPPING (MCDF section)') 3080 FORMAT (/' MCDF.DMP does not exist : STOPPING (MCDF section)') 3090 FORMAT (/' ORBIN.DAT does not exist : STOPPING (MCDF section)') 3100 FORMAT (/' calling routine BENA') 3110 FORMAT (/' MCP.DAT does not exist : STOPPING (BENA section)') 3120 FORMAT (/' MCDF.DAT does not exist : STOPPING (BENA section)') 3130 FORMAT (/' calling routine OSCL') 3140 FORMAT (/' MCT.DAT does not exist : STOPPING (OSCL section)') 3150 FORMAT (/' BENA.DAT does not exist : try MCDF.DAT (OSCL section)') 3160 FORMAT (/' MCDF.DAT does not exist : STOPPING (OSCL section)') 3170 FORMAT (/' GRASP.INP does not exist : STOPPING') 3180 FORMAT (/' reading input in routine DATAIN') 3190 FORMAT (/' STOPPING normally') 3200 FORMAT (/' Racah coefficients calculated = ',I7/ ! +' Racah coefficients from table = ',I7/ ! +' Racah coefficients total = ',I7/ ! +' Racah coefficients stored = ',I7) 3210 FORMAT (/' calculation time for this problem and total'/) 3220 FORMAT (' angular coefficients : ',F10.2,2X,F10.2) 3230 FORMAT (' MCDF calculation : ',F10.2,2X,F10.2) 3240 FORMAT (' BENA calculation : ',F10.2,2X,F10.2) 3250 FORMAT (' OSCL calculation : ',F10.2,2X,F10.2) END C C ******************* C SUBROUTINE BENA(IO4,IO5,IO6) C C----------------------------------------------------------------------- C C This routine controls the main sequence of routine calls C for the calculation of the transverse Breit and QED C corrections to the MCDF energy levels. C C Tree of subprogram calls: C (no main program found) C BENA C BREMAT C BREMT1 C BESSEL C BRRA C BREMT2 C RS C MATOUT C COUMAT C COUMT1 C RINTI C SLATER C COUMT2 C RS C MATOUT C DUMPB C LOAD C QED C READA C SUMMRY C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) C C Argument variables C INTEGER IO4,IO5,IO6 C C Local variables C INTEGER I,IBREIT,ICOUL,J C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C C Common variables C DOUBLE PRECISION BREVEC(MXNC,MXNC) COMMON / BRET2 / BREVEC C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC) COMMON / ENRG2 / VPENG,SFENG C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C C Common variables C DOUBLE PRECISION WFACT COMMON / WFAC / WFACT Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- PRINT 3000,IHED(1:40),IHED(41:80),RECORD WRITE (IWRITE,3000) IHED(1:40),IHED(41:80),RECORD WRITE (IPUNCH,3000) IHED(1:40),IHED(41:80),RECORD C C Zeroise the energy arrays C DO I = 1,MXNC COUENG(I) = ZERO BREENG(I) = ZERO VPENG(I) = ZERO SFENG(I) = ZERO ENDDO C C Load dumped wavefunctions C CALL LOAD(IO5) REWIND IO5 C IF (ABS(ATW).LT.EPS10) THEN WRITE (IWRITE,3030) WFACT ELSE WRITE (IWRITE,3040) WFACT,ATW ENDIF C C Check the MCP/MCBP dump. C CALL READA(IO4,ICOUL,IBREIT) C C Evaluate the Coulomb matrix C CALL COUMAT(ICOUL,IO4) C C Write a BENA dump. C CALL DUMPB(IO6) C C Evaluate the Breit matrix C CALL BREMAT(IBREIT,IO4) C C Evaluate vacuum polarization and self energy contributions. C IF (KTC(9).EQ.1) WRITE (IWRITE,3020) C CALL QED C C Obtain final summary of contributions to energy levels. C IF (KTC(10).EQ.0) THEN WRITE (IWRITE,3050) CALL SUMMRY(IWRITE) CALL SUMMRY(IPUNCH) ENDIF C C Complete the BENA dump. C IF (IBREIT.EQ.1) THEN C DO I = 1,NCF BREENG(I) = COUENG(I)+BREENG(I) ENDDO C DO I = 1,NCF COUENG(I) = BREENG(I)+VPENG(I)+SFENG(I) ENDDO C WRITE (IO6) ((BREVEC(I,J),J=1,NCF),I=1,NCF) WRITE (IO6) (BREENG(I),I=1,NCF) WRITE (IO6) (COUENG(I),I=1,NCF) C ENDIF C REWIND IO6 WRITE (IWRITE,3010) WRITE (IPUNCH,3010) C----------------------------------------------------------------------- 3000 FORMAT (/1X,71('*')/ ! +' routine BENA : calculate Breit and QED corrections'/1X,71('*')/ ! +' Title : ',A40/' ',A40/' Run at : ',A20/1X,71('*')) 3010 FORMAT (/1X,71('*')) 3020 FORMAT (/20X,' *****************************************'/20X, ! +' * QED effects *'/20X, ! +' *****************************************') 3030 FORMAT (/' WFACT (factor used to multiply frequency) = ',1P,E10.3/! +' atomic weight has been set to infinity') 3040 FORMAT (/' WFACT (factor used to multiply frequency) = ',1P,E10.3/! +' ATW (atomic weight) = ',0P,F10.4) 3050 FORMAT (/ ! +' These energies are relative to the groundstate except for the ',! +'ground-'/ ! +' state which is absolute. * indicates a level which may have sw',! +'itched '/ ! +' when Breit is added. The level order is that of the Coulomb en',! +'ergies. '/ ! +' Level assignment, i.e. the J and parity and the dominant CSF a',! +'nd mixing '/' coefficient, is based on the Coulomb eigenvectors.'! +/ ! +' CSF mixing coefficients larger than .1 in magnitude are printe',! +'d.') END C C ******************* C SUBROUTINE BESSEL(NWLAB,KEEP,IA,IB,IK,IW,K) C C----------------------------------------------------------------------- C C This routine evaluates the functions related to the Bessel functions C J(K; WAB*R) and N(K; WAB*R) for R=0 to infinity where C WAB = ABS( E(IA)-E(IB) )/C and E(I) is the eigenvalue for orbital I. C The values of the function at the grid points are loaded into the C arrays BESSJ(IK,IW,L) and BESSN(IK,IW,L) L=1,N as requested in the C argument list. A note of the contents of these arrays is kept in C KEEP(IK,IW) by coding IA,IB and K to a unique integer (symmetric C in IA, IB). If a request is made for a fuction that is already C stored a simple copy is made of the relevant array. C C The routine uses the equations 10.1.2 and 10.1.3 for small W*R and C 10.1.8 and 10.1.9 for large W*R of M. Abromawitz and I.A.Stegun to C evaluate the fuctions. C C NOTE: These are not the usual Bessel functions. C ---- See the long write up for their definition. C C No subroutines called. C C Common block BESS1: C Elements set but never used: WIJ C Common block DEF01: C Elements used but never set: RNT EPH C N C Elements never used, never set: Z H ACCY NW1 NCPRIN C Common block INFORM: C Elements used but never set: IWRITE C Elements never used, never set: IREAD IPUNCH C Common block OPT03: C Elements used but never set: all C Common block ORB00: C Elements used but never set: all C Common block ORB01: C Elements used but never set: all C Common block ORB04: C Elements used but never set: NP C Elements never used, never set: NW NCF NAK IQ C Common block WFAC: C Elements used but never set: all C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS5 PARAMETER (EPS5=1.D-5) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION HALF PARAMETER (HALF=.5D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) C C Argument variables C INTEGER IA,IB,IK,IW INTEGER K,KEEP(2,2),NWLAB C C Local variables C DOUBLE PRECISION B,CN,DFN,DFNM DOUBLE PRECISION S1,S2,SCN,SKEEP DOUBLE PRECISION SN,SSN,W,WA DOUBLE PRECISION XBESS1,XBESS2 INTEGER I,ICODE,IEND,IKKP INTEGER IPROD,ISWAP,IWKP,J INTEGER JCHAN,L,NGRID,NN C C Common variables C DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP) DOUBLE PRECISION WIJ(2) COMMON / BESS1 / WIJ,BESSJ,BESSN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C DOUBLE PRECISION WFACT COMMON / WFAC / WFACT Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Form unique label symm. in IA,IB C ICODE = MAX(IA,IB)+NWLAB*(MIN(IA,IB)+NWLAB*K) C C Check if already stored to save evaluation C IF (ICODE.EQ.KEEP(IK,IW)) RETURN C NGRID = N W = WFACT*ABS(E(IA)-E(IB))/C WIJ(IW) = W C DO IWKP = 1,2 DO IKKP = 1,2 IF (KEEP(IKKP,IWKP).EQ.ICODE) THEN C C Copy function to new position C KEEP(IK,IW) = ICODE IF (KTC(11).EQ.1) WRITE (IWRITE,3010) NP(IA),NH(IA),NP(IB),N! +H(IB),K,IKKP,IWKP,IK,IW DO L = 1,NGRID BESSJ(IK,IW,L) = BESSJ(IKKP,IWKP,L) BESSN(IK,IW,L) = BESSN(IKKP,IWKP,L) ENDDO RETURN C ENDIF C ENDDO ENDDO C C New calculation C IF (KTC(11).EQ.1) WRITE (IWRITE,3000) NP(IA),NH(IA),NP(IB),NH(IB),! +K,IK,IW C KEEP(IK,IW) = ICODE NN = K C IF (NN.EQ.0) THEN DFNM = ONE DFN = ONE ELSE IEND = NN+NN-1 IPROD = 1 DO I = 1,IEND,2 IPROD = IPROD*I ENDDO DFNM = DBLE(IPROD) DFN = DBLE(IPROD*(NN+NN+1)) ENDIF C C Use power series for low W*R C WA = -(RNT*W)**2*HALF C DO J = 1,NGRID XBESS1 = ONE XBESS2 = ONE S1 = ZERO S2 = ZERO DO I = 1,4 XBESS1 = XBESS1*WA/DBLE(I*(2*(NN+I)+1)) XBESS2 = XBESS2*WA/DBLE(I*(2*(I-NN)-1)) S1 = S1+XBESS1 S2 = S2+XBESS2 IF (ABS(XBESS1).GE.ABS(S1)*EPS5) GOTO 10 IF (ABS(XBESS2).GE.ABS(S2)*EPS5) GOTO 10 GOTO 20 10 CONTINUE ENDDO JCHAN = J WA = SQRT(-TWO*WA) GOTO 30 20 CONTINUE BESSJ(IK,IW,J) = S1 BESSN(IK,IW,J) = S2 WA = WA*EPH*EPH ENDDO C C If code reaches here then it has calculated the whole C array using power series. Hence return C RETURN C C 30 CONTINUE C C.....Use SIN/COS expansion when power series takes longer C.....than 4 terms to converge C ISWAP = 0 IF (((NN-1)/4)*4- (NN-1)) 50,40,50 C C.....NN=1,5,9,... C 40 CONTINUE SSN = -ONE SCN = ONE ISWAP = 1 GOTO 100 C 50 CONTINUE IF (((NN-2)/4)*4- (NN-2)) 70,60,70 C C.....N=2,6,10,.... C 60 CONTINUE SSN = -ONE SCN = -ONE GOTO 100 C 70 CONTINUE IF (((NN-3)/4)*4- (NN-3)) 90,80,90 C C.....NN=3,7,11,... C 80 CONTINUE SSN = ONE SCN = -ONE ISWAP = 1 GOTO 100 C C.....NN=0,4,8,... C 90 CONTINUE SSN = ONE SCN = ONE C C----------------------------------------------------------------------- C 100 CONTINUE C DO J = JCHAN,NGRID C IF (ISWAP.GT.0) THEN SN = SSN*COS(WA) CN = SCN*SIN(WA) ELSE SN = SSN*SIN(WA) CN = SCN*COS(WA) ENDIF C I = -1 S1 = ZERO S2 = ZERO C 110 CONTINUE I = I+1 C IF (I.GT.NN) GOTO 150 C IF (I) 130,120,130 120 CONTINUE B = ONE/WA GOTO 140 130 CONTINUE B = B*DBLE((NN+I)*(NN-I+1))/DBLE(2*I)/WA C 140 CONTINUE S1 = S1+B*SN S2 = S2+B*CN SKEEP = SN SN = CN CN = -SKEEP GOTO 110 C 150 CONTINUE S1 = S1*DFN/(WA**NN)-ONE S2 = S2*(WA**(NN+1))/DFNM-ONE BESSJ(IK,IW,J) = S1 BESSN(IK,IW,J) = S2 WA = WA*EPH C ENDDO C 3000 FORMAT (1X,2(I2,A2,1X),10X,I4,6X,2X,'new',6X,'(',I2,',',I2,')') 3010 FORMAT (1X,2(I2,A2,1X),10X,I4,6X,2X,'(',I2,',',I2,')',2X,'(',I2, ! +',',I2,')') END C C ******************* C SUBROUTINE BESSJ(W,L) C C----------------------------------------------------------------------- C C This routine evaluates Bessel fuctions J K ( W*R/C ) at the grid C points for K=L-1.L.L+1 and stores them in the arrays BJ(1,..), C BJ(2,..),BJ(3,..) respectively. It uses a power series expansion C for small R and switches to SIN/COS expansion when more than 4 terms C in power series are required. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS5 PARAMETER (EPS5=1.D-5) DOUBLE PRECISION EPS30 PARAMETER (EPS30=1.D-30) C C Argument variables C DOUBLE PRECISION W INTEGER L C C Local variables C DOUBLE PRECISION B,CN,DFN,R DOUBLE PRECISION S1,SCN,SKEEP,SN DOUBLE PRECISION SSN,WA,XBESS1 INTEGER I,IEND,IPROD,ISWAP INTEGER IW,J,JCHAN,NN C C Common variables C DOUBLE PRECISION BJ(6,MXNP),DUM(2),TC(MXNP) DOUBLE PRECISION TD(MXNP) COMMON / BESS1 / DUM,BJ,TC,TD C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER LTC(20) COMMON / OPT04 / LTC C C Common variables C INTEGER KK,LK COMMON / OSC2 / LK,KK Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IW = 1 NN = L-1 IF (KK.EQ.0) GOTO 10 IW = 2 NN = L C 10 CONTINUE IEND = 2*NN+1 IPROD = 1 DO I = 1,IEND,2 IPROD = IPROD*I ENDDO DFN = DBLE(IPROD) C R = RNT*W JCHAN = N DO J = 1,N C S1 = ONE IF (LTC(18).EQ.1) GOTO 20 C XBESS1 = ONE WA = -R*R*HALF DO I = 1,4 XBESS1 = XBESS1*WA/(I*(2*(NN+I)+1)) S1 = S1+XBESS1 IF (ABS(XBESS1).LT.ABS(S1)*EPS5) GOTO 20 ENDDO JCHAN = J GOTO 30 C 20 CONTINUE IF (ABS(R).LT.EPS30) THEN BJ(IW,J) = ZERO ELSE BJ(IW,J) = S1*(R**NN)/DFN ENDIF C R = R*EPH C ENDDO C----------------------------------------------------------------------- C C use SIN/COS expansion when power series takes longer than 4 terms C to converge C 30 CONTINUE IF (JCHAN.GE.N) GOTO 180 ISWAP = 0 IF (((NN-1)/4)*4- (NN-1)) 50,40,50 C C NN=1,5,9,.. C 40 CONTINUE SSN = -ONE SCN = ONE ISWAP = 1 GOTO 100 C 50 CONTINUE IF (((NN-2)/4)*4- (NN-2)) 70,60,70 C C N=2,6,10,.. C 60 CONTINUE SSN = -ONE SCN = -ONE GOTO 100 C 70 CONTINUE IF (((NN-3)/4)*4- (NN-3)) 90,80,90 C C NN=3,7,11,.. C 80 CONTINUE SSN = ONE SCN = -ONE ISWAP = 1 GOTO 100 C C NN=0,4,8,.. C 90 CONTINUE SSN = ONE SCN = ONE C 100 CONTINUE DO J = JCHAN,N IF (ISWAP.GT.0) GOTO 110 SN = SSN*SIN(R) CN = SCN*COS(R) GOTO 120 C 110 CONTINUE SN = SSN*COS(R) CN = SCN*SIN(R) C 120 CONTINUE I = -1 S1 = ZERO 130 CONTINUE I = I+1 IF (I.GT.NN) GOTO 170 IF (I) 150,140,150 140 CONTINUE B = ONE/R GOTO 160 C 150 CONTINUE B = B*((NN+I)*(NN-I+1))/(2*I)/R 160 CONTINUE S1 = S1+B*SN SKEEP = SN SN = CN CN = -SKEEP GOTO 130 C 170 CONTINUE BJ(IW,J) = S1 R = R*EPH ENDDO C 180 CONTINUE IF (NN.GE.L+1 .OR. KK.EQ.1) RETURN NN = NN+1 IW = IW+1 GOTO 10 C END C C ******************* C BLOCK DATA BLGRSP C C----------------------------------------------------------------------- C C Sets up tables of quantum numbers of terms which can be C formed by configurations J**Q. Symmetry of the table for C particle/hole configurations is used to compress it. C C Sets up commonly used constants. C C Sets up arrays used in the transformation JJ to LS. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C INTEGER IDN(5),IDNL(16,5),IDNS(16,5) INTEGER IDNV(16,5) COMMON / CSFD / IDNV,IDNS,IDNL,IDN C C Common variables C INTEGER ICD2(3,3,3),ICD3(5,5,6),ICD4(8,8,7) INTEGER ICD5(10,10,7),JJDN(10,7,3) INTEGER LSDN(10,7,3),NCD2(3),NCD3(6) INTEGER NCD4(7),NCD5(7),NDN(7,3) COMMON / TCD / ICD2,NCD2,ICD3,NCD3,ICD4,NCD4,ICD5,NCD5,NDN,JJDN! + ,LSDN C C Common variables C INTEGER ICP2(2,2),ICP3(3,3) COMMON / TCP / ICP2,ICP3 C C Common variables C INTEGER ITAB(16),JTAB(16),NROWS INTEGER NTAB(255) COMMON / TERMS / NROWS,ITAB,JTAB,NTAB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA NROWS/16/ DATA ITAB/1,1,1,2,1,3,3,1,4,6,8,1,5,10,18,20/ DATA JTAB/0,3,6,9,15,18,27,36,39,51,69,93,96,111,141,195/ DATA NTAB/0,0,1,1,0,2,1,0,4,0,0,1,2,0,5,1,0,6,0,0,1,2,0,5,2,0,9,1,! +0,6,3,0,4,3,0,10,1,0,8,0,0,1,2,0,5,2,0,9,2,0,13,1,0,8,3,0,4,3,0,6,! +3,0,10,3,0,12,3,0,16,0,0,1,2,0,5,2,0,9,2,0,13,4,0,5,4,0,9,4,0,11,4! +,0,17,1,0,10,0,0,1,2,0,5,2,0,9,2,0,13,2,0,17,1,0,10,3,0,4,3,0,6,3,! +0,8,3,0,10,3,0,12,3,0,14,3,0,16,3,0,18,3,0,22,0,0,1,2,0,5,2,0,9,2,! +0,13,2,0,17,4,0,1,4,0,5,4,0,7,4,0,9,4,1,9,4,0,11,4,0,13,4,1,13,4,0! +,15,4,0,17,4,0,19,4,0,21,4,0,25,1,0,10,3,0,4,3,0,6,3,0,8,3,0,10,3,! +0,12,3,0,14,3,0,16,3,0,18,3,0,22,5,0,2,5,0,6,5,0,8,5,0,10,5,0,12,5! +,0,14,5,0,16,5,0,18,5,0,20,5,0,26/ C DATA ZERO,HALF,TENTH/0.0D0,0.5D0,0.1D0/ DATA ONE,TWO,THREE/1.0D0,2.0D0,3.0D0/ DATA TEN/10.0D0/ C DATA IDN/1,5,8,16,16/ DATA IDNL/5,15*0,7,3,9,5,1,11*0,7,3,11,9,7,5,5,3,8*0,5,11,9,7,7,5,! +3,3,13,9,9,7,5,5,1,1,1,9,7,5,3,13,11,9,9,7,7,5,5,5,3,1/ DATA IDNS/2,15*0,3,3,1,1,1,11*0,4,4,6*2,8*0,5,7*3,8*1,6,4*4,11*2/ DATA IDNV/1,15*-1,4*2,0,11*-1,5*3,1,2*3,8*-1,3*4,2,4,4,2,4,4,2,4,4! +,2,4,0,4,5,5,3,5,3,5,3,3,5,3,5,1,3,5,3,5/ C DATA ICP2/2,1,-1,2/,ICP3/-4,10,4,9,0,9,5,8,-5/ C DATA ICD2/4,1,0,-1,4,4*0,-9,32,84,56,63,-6,60,-30,35,-2,0,3,3,0,2,! +3*0/,NCD2/5,125,5/ C DATA ICD3/-7,-8,3*0,-8,7,18*0,48,-240,168,540,-504,-252,-560,32,-5! +60,-96,0,0,1125,0,375,-480,600,105,0,-315,-720,-100,-70,400,210,-3! +92,726,-240,3500,-392,-1008,-3024,-210,0,-1008,-980,540,2400,-350,! +-980,-2625,0,0,0,2625,245,-960,2400,1400,245,200,-24,56,0,0,5,-135! +,-140,0,0,75,121,-84,12*0,-60,55,10,0,0,-11,-48,66,0,0,-54,-22,-49! +,12*0,-1,24*0/ DATA NCD3/15,1500,5250,280,125,1/ C DATA ICD4/-48,-42,-420,96,-144,3*0,-400,0,0,50,300,3*0,-56,324,90,! +112,-168,3*0,225,0,0,450,75,3*0,-21,-384,240,42,-63,27*0,-36,-21,-! +21,-72,4*0,0,75,-75,5*0,-100,0,0,50,4*0,-14,54,54,-28,36*0,420,-42! +0,-105,2880,-375,0,-210,-840,-126,-896,0,0,0,3528,-252,448,-504,-2! +24,-2016,6,1800,0,252,-448,-1260,-560,315,-240,-1125,0,630,-1120,7! +84,-1764,0,0,0,-252,1568,882,-896,126,1134,1944,450,0,448,252,840,! +840,0,0,0,1470,1680,-420,-420,420,-1680,180,-1500,0,210,840,-12600! +,-1176,336,12600,-336,-2352,0,0,-15,-2835,5760,-2160,12960,-5670,0! +,0,0,-19600,3*0,9800,0,0,4725,-49,-8064,8400,8064,-98,0,0,10800,-2! +800,1800,1200,-7200,-5600,0,0,1260,2940,13440,5040,840,5880,18*0,4! +032,-9240,-504,3960,240,-2016,-1008,0,1232,3360,2464,5760,2640,-61! +6,4928,0,2688,3465,-1701,-2640,5760,-1344,-3402,0,5600,0,-2800,0,0! +,11200,1400,0,-3584,1155,-2023,7920,480,1792,-4046,0,1400,0,11200,! +0,0,2800,-5600,0,-2464,-3780,308,-720,11880,1232,616,9*0,-9,-16,6*! +0,16,-9,54*0,3,2,6*0,2,-3,54*0/ DATA NCD4/750,150,5250,29400,21000,25,5/ C DATA ICD5/3,0,-24,-3,6*0,-7,16,0,-7,6*0,-8,-14,0,-8,6*0,12,0,6,-12! +,66*0,-60,168,-270,0,24,-60,-168,3*0,300,0,0,-150,0,-300,4*0,-140,! +32,280,0,-126,-140,-32,3*0,0,375,4*0,375,3*0,150,105,0,0,-240,150,! +-105,3*0,-75,0,0,-600,0,75,4*0,-25,-70,-200,0,-360,-25,70,33*0,-70! +56,42336,2940,-70560,0,-1470,-7056,-42336,-2940,-7056,-10584,-1512! +9,-29160,-17340,0,-46080,-10584,15129,29160,-10584,13720,12705,-42! +00,0,-122500,0,0,12705,-4200,-13720,-19600,-600,30375,36000,0,-270! +00,-19600,600,-30375,-19600,35280,-52920,-3675,4*0,-52920,-3675,-3! +5280,34300,9450,42000,0,12250,0,0,9450,42000,-34300,6860,25410,-84! +00,28350,0,-67200,6860,-25410,8400,6860,30625,5*0,-122500,0,0,3062! +5,-8575,-16800,42000,0,-49000,0,0,-16800,42000,8575,17150,-8400,21! +000,-31500,0,-42000,17150,8400,-21000,17150,-10952,-5400,-21296,0,! +-4800,10952,5400,3*0,21000,-2520,0,-11760,0,21000,-2520,3*0,-12960! +,-480,31680,0,240,12960,480,3*0,525,-14175,0,29400,0,525,-14175,3*! +0,385,-10395,-280,0,36960,-385,10395,3*0,7875,12705,0,17640,0,7875! +,12705,3*0,5103,-13125,5544,0,-16800,-5103,13125,33*0,-125,-500,0,! +0,125,5*0,165,0,-60,-360,165,5*0,-144,0,-396,-66,-144,5*0,-66,0,29! +4,-324,-66,5*0,250,-250,0,0,-250,55*0,-12,-26,12,7*0,13,-24,-13,7*! +0,-25,0,-25,77*0,-1,99*0/ DATA NCD5/30,750,183750,58800,750,50,1/ C DATA NDN/2,5,5,3,3,1,0,5,4,8,6,7,2,2,4,7,10,7,5,3,1/ C DATA JJDN/1425,2516,8*0,134,1425,1421,2516,3401,5*0,136,1429,1425,! +2516,2116,5*0,1429,1425,2516,7*0,140,1429,2516,7*0,1429,19*0,141,1! +434,2525,2121,4101,5*0,1436,1434,2525,3416,6*0,145,1436,1434,2529,! +2525,2521,2125,3416,0,0,1440,1436,1434,2529,2525,3416,4*0,149,1440! +,1436,2529,2525,2129,3416,3*0,1440,2529,8*0,1440,2529,8*0,1445,253! +6,2534,3425,6*0,1445,1441,2536,2534,2134,3425,3421,3*0,156,1449,14! +45,2540,2536,2534,2136,3429,3425,4116,1449,1445,2540,2536,2534,342! +9,3425,3*0,1449,2540,2536,2140,3429,5*0,1449,2540,3429,7*0,2540,9*! +0/ C DATA LSDN/343,323,8*0,347,343,125,325,323,5*0,347,343,327,125,325,! +5*0,347,329,327,7*0,347,331,329,7*0,331,19*0,455,233,433,11,411,5*! +0,455,435,233,433,6*0,455,237,437,435,233,433,215,415,0,0,455,439,! +237,437,435,417,4*0,455,441,439,237,437,219,419,3*0,441,439,8*0,44! +1,423,8*0,545,343,323,521,6*0,347,545,343,125,325,525,323,3*0,561,! +549,347,545,343,327,527,125,325,525,549,347,545,329,529,327,527,3*! +0,549,347,331,329,529,5*0,549,533,331,7*0,533,9*0/ C END C C ******************* C SUBROUTINE BREID(JA1,IPCA,JB1) C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL CLRX,ITRIG DOUBLE PRECISION CLRX INTEGER ITRIG C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) INTEGER NPLX PARAMETER (NPLX=14) INTEGER IDIM PARAMETER (IDIM=20) C C Argument variables C INTEGER IPCA,JA1,JB1 C C Local variables C DOUBLE PRECISION COEF,CONE(7,IDIM),CONST DOUBLE PRECISION GAM,PROC,PROD,S(12) INTEGER I,IA1,IB1,IBRD INTEGER IBRE,ID1,ID2,IP INTEGER IPP,ISG,ITYPE,JS(4) INTEGER K,KAP1,KAPS(4),KK INTEGER KS(4),MU,N,NE1 INTEGER NE2,NQS1,NQS2,NU INTEGER NUP1 C C Common variables C INTEGER IME,JA,JB,NWA COMMON / ANG04 / IME,JA,JB,NWA C C Common variables C INTEGER ICORE(MXNW) COMMON / ANG05 / ICORE C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IPCA.EQ.2) THEN IA1 = KLIST(JA1) ELSE IA1 = JLIST(JA1) ENDIF IB1 = KLIST(JB1) C----------------------------------------------------------------------- ISG = 1 C----------------------------------------------------------------------- IF (JA.NE.JB) GOTO 10 IF (ICORE(IA1).EQ.0 .OR. ICORE(IB1).EQ.0) GOTO 10 C----------------------------------------------------------------------- IF (JA.GT.1) RETURN ISG = -1 C----------------------------------------------------------------------- 10 CONTINUE JS(1) = IA1 JS(2) = IB1 JS(3) = IA1 JS(4) = IB1 NQS1 = NQ1(IA1) NQS2 = NQ2(IB1) DO I = 1,4 KAPS(I) = 2*NAK(JS(I)) KS(I) = ABS(KAPS(I)) ENDDO C----------------------------------------------------------------------- CONST = NQS1*NQS2 C----------------------------------------------------------------------- IF (IBUG2.EQ.1) WRITE (IWRITE,3000) IA1,IB1 C----------------------------------------------------------------------- CALL SNRC(JS,KAPS,KS,ID1,ID2,NE1,NE2,IBRD,IBRE) C----------------------------------------------------------------------- IF (IBUG2.EQ.1) WRITE (IWRITE,3010) ID1,ID2,NE1,NE2,IBRD,IBRE C----------------------------------------------------------------------- IF (IA1.EQ.IB1) THEN DO N = 1,ID2 NU = ID1+2*(N-1) K = NU IF (MOD(K,2).NE.1) RETURN KAP1 = KAPS(1)/2 GAM = CLRX(KAP1,NU,KAP1) COEF = CONST*TWO*(KS(1)*KS(1))*GAM*GAM/(NU*(NU+1)) IF (IBUG2.GT.0) WRITE (IWRITE,3020) NU,GAM,COEF ITYPE = ISG*4 CALL SPEAKG(0,ITYPE,IA1,IA1,IA1,IA1,NU,COEF) ENDDO RETURN C ENDIF C----------------------------------------------------------------------- IF (IBRE.LT.0) RETURN C----------------------------------------------------------------------- IF (NE2.GT.IDIM) THEN WRITE (IWRITE,3030) WRITE (IPUNCH,3030) STOP C ENDIF C----------------------------------------------------------------------- DO N = 1,NE2 DO MU = 1,7 CONE(MU,N) = ZERO ENDDO ENDDO C----------------------------------------------------------------------- PROC = -CONST/(KS(1)*KS(2)) C DO N = 1,NE2 NU = NE1+2*(N-1) C K = NU IP = (KS(1)-KS(2))/2+K IPP = IP+1 IF (NU.EQ.0) GOTO 30 C KK = K+K+1 IF (ITRIG(KS(1),KS(2),KK).EQ.0) GOTO 20 C PROD = PROC IF (MOD(IP,2).NE.0) PROD = -PROD CALL CXK(S,JS,KAPS,NU,K,IBRE,2) IF (IBUG2.GT.0) WRITE (IWRITE,3040) PROD, (S(MU),MU=1,3) DO MU = 1,3 CONE(MU,N) = CONE(MU,N)+PROD*S(MU) ENDDO C 20 CONTINUE K = NU-1 KK = K+K+1 IF (ITRIG(KS(1),KS(2),KK).EQ.0) GOTO 30 C PROD = PROC IF (MOD(IPP,2).NE.0) PROD = -PROD CALL CXK(S,JS,KAPS,NU,K,IBRE,2) IF (IBUG2.GT.0) WRITE (IWRITE,3040) PROD, (S(MU),MU=1,3) DO MU = 1,3 CONE(MU,N) = CONE(MU,N)+PROD*S(MU) ENDDO C 30 CONTINUE IF (N.NE.NE2) THEN K = NU+1 KK = K+K+1 PROD = PROC IF (MOD(IPP,2).NE.0) PROD = -PROD CALL CXK(S,JS,KAPS,NU,K,IBRE,2) IF (IBUG2.GT.0) WRITE (IWRITE,3040) PROD, (S(MU),MU=1,7) DO MU = 1,7 CONE(MU,N) = CONE(MU,N)+PROD*S(MU) ENDDO ENDIF C ENDDO C----------------------------------------------------------------------- C----------------------------------------------------------------------- DO N = 1,NE2 NU = NE1+2*(N-1) ITYPE = ISG*5 CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NU,CONE(1,N)) CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NU,CONE(2,N)) CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NU,CONE(3,N)) IF (N.EQ.NE2) GOTO 40 NUP1 = NU+1 ITYPE = ISG*6 CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NUP1,CONE(4,N)) CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NUP1,CONE(5,N)) CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NUP1,CONE(6,N)) CALL SPEAKG(0,ITYPE,IB1,IA1,IA1,IB1,NUP1,CONE(7,N)) 40 CONTINUE ENDDO C----------------------------------------------------------------------- 3000 FORMAT (' BREID called : orbitals = ',2I4) 3010 FORMAT (' BREID called : ID1 ID2 NE1 NE2 IBRD IBRE = ',6I5) 3020 FORMAT (' AAAA contribution : NU,GAM,COEF = ',I5,1P,2E13.5) 3030 FORMAT (/' BREID called : dimension ERROR for IDIM') 3040 FORMAT (' BREID called : PROD = ',1P,E12.4/ ! +' BREID called : S = ',4E12.4/' BREID called : S = ',3E12.4) END C C ******************* C SUBROUTINE BREMAT(IBREIT,IO4) C C----------------------------------------------------------------------- C C This routine controls the calculation of the Breit matrix. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER IBREIT,IO4 C C Local variables C DOUBLE PRECISION AM,EAU,ERY INTEGER I,IJ,IP,J C C Common variables C DOUBLE PRECISION BREVEC(MXNC,MXNC) COMMON / BRET2 / BREVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV C C Common variables C INTEGER LORDER(MXNC) COMMON / PAT2 / LORDER Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IBREIT.EQ.0) RETURN C WRITE (IWRITE,3010) PRINT 3010 C C Evaluate the Breit matrix C CALL BREMT1(IO4) C IF ((KTC(4)+KTC(5)+KTC(6)).GT.0) WRITE (IWRITE,3000) C----------------------------------------------------------------------- C C Print Breit matrix if option 4 is set. C IF (KTC(4).EQ.1) CALL MATOUT(IWRITE,BREVEC,NCF,NCF,MXNC,MXNC,1) C----------------------------------------------------------------------- C C Diagonalise the Breit matrix C CALL BREMT2 C----------------------------------------------------------------------- C C Print Breit energies if option 5 is set. C IF (KTC(5).EQ.1) THEN WRITE (IWRITE,3020) DO J = 1,NCPRIN EAU = BREENG(J)+COUENG(J) IF (J.GT.1) EAU = EAU - (BREENG(1) + COUENG(1)) ERY = EAU+EAU I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = BREVEC(I,J) C IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3090) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3100) J,IJ,I,AM,EAU,ERY ENDIF ELSE IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3070) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3080) J,IJ,I,AM,EAU,ERY ENDIF ENDIF ELSE IF (IP.EQ.1) THEN IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3050) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3060) J,IJ,I,AM,EAU,ERY ENDIF ELSE IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3030) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3040) J,IJ,I,AM,EAU,ERY ENDIF ENDIF ENDIF C ENDDO ENDIF C----------------------------------------------------------------------- C C Print Breit vectors if option 6 is set. C IF (KTC(6).GT.0) CALL MATOUT(IWRITE,BREVEC,NCF,NCPRIN,MXNC,MXNC,3) C----------------------------------------------------------------------- 3000 FORMAT (/20X,' *****************************************'/20X, ! +' * Breit matrix *'/20X, ! +' *****************************************') 3010 FORMAT (/' >>>> routine BREMAT called') 3020 FORMAT (/' Breit dominant'/ ! +' level J parity CSF mix a.u. Ryd.'! +/) 3030 FORMAT (1X,I4,2X,I4,'/2 odd ',I4,2X,F5.3,3X,1P,2E20.8) 3040 FORMAT (1X,I4,2X,I4,'/2 odd ** ',I4,2X,F5.3,3X,1P,2E20.8) 3050 FORMAT (1X,I4,2X,I4,'/2 even ',I4,2X,F5.3,3X,1P,2E20.8) 3060 FORMAT (1X,I4,2X,I4,'/2 even ** ',I4,2X,F5.3,3X,1P,2E20.8) 3070 FORMAT (1X,I4,2X,I4,' odd ',I4,2X,F5.3,3X,1P,2E20.8) 3080 FORMAT (1X,I4,2X,I4,' odd ** ',I4,2X,F5.3,3X,1P,2E20.8) 3090 FORMAT (1X,I4,2X,I4,' even ',I4,2X,F5.3,3X,1P,2E20.8) 3100 FORMAT (1X,I4,2X,I4,' even ** ',I4,2X,F5.3,3X,1P,2E20.8) END C C ******************* C SUBROUTINE BREMT1(IO4) C C----------------------------------------------------------------------- C C Routine for evaluating the Breit matrix. C C IO4 - stream for MCBP coefficients. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL BRRA DOUBLE PRECISION BRRA C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C INTEGER IO4 C C Local variables C CHARACTER IBL,ILAB,IST DOUBLE PRECISION COEF,CONTR,ELMNT,ELSTO DOUBLE PRECISION XINT,XLAB INTEGER I,IA,IB,IC INTEGER ICOD,ICOD1,ICOD2,ICOD3 INTEGER ICOD4,ID,IPRNT,ISTOR INTEGER ISTORE,ITYP,ITYPE,J INTEGER JA,JAP,JB,JBP INTEGER K,KEEP(2,2),NCFP,NSTART INTEGER NUM,NUMEL,NUMINT,NUMSTO INTEGER NUMTOT,NUMX,NWA,NWP INTEGER NWS C C Common variables C DOUBLE PRECISION BREVEC(MXNC,MXNC) COMMON / BRET2 / BREVEC C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA IBL,IST/' ','S'/ C----------------------------------------------------------------------- C C Zeroise the KEEP array C DO I = 1,2 DO J = 1,2 KEEP(I,J) = 0 ENDDO ENDDO C NSTART = MPOIN(NW)+MPOS(NW)-1 NUMX = MXNG-NSTART C NUMINT = 0 NUMSTO = 0 NUMTOT = 0 NUMEL = 0 C ELSTO = ZERO C IPRNT = 0 IF (KTC(8).EQ.1) IPRNT = IPRNT + 1 IF (KTC(11).EQ.1) IPRNT = IPRNT + 2 C----------------------------------------------------------------------- C C Position stream IO4 which reads in MCBP coefficients. C REWIND IO4 READ (IO4) READ (IO4) NCFP,NWP NWA = NWP+1 NWS = NWA*NWA DO I = 1,7 READ (IO4) ENDDO C----------------------------------------------------------------------- DO JA = 1,NCF DO JB = JA,NCF C C Read coefficients for configuration pair JA,JB. C ELMNT = ZERO READ (IO4) JAP,JBP NUM = 0 C C Coefficients stored as : ISTORE,ITYP,COEF C Need to decode ISTORE. C 10 CONTINUE READ (IO4) ISTORE,ITYP,COEF IF (ISTORE.EQ.0) GOTO 100 ITYPE = ABS(ITYP) IF (ITYPE.GT.6) GOTO 10 C ISTOR = ISTORE ID = MOD(ISTOR,NWA) ISTOR = ISTOR/NWA IC = MOD(ISTOR,NWA) ISTOR = ISTOR/NWA IB = MOD(ISTOR,NWA) ISTOR = ISTOR/NWA IA = MOD(ISTOR,NWA) K = ISTOR/NWA C IF (NUM.GT.0 .OR. IPRNT.EQ.0) GOTO 20 IF (IPRNT.EQ.1) WRITE (IWRITE,3010) JA,JB IF (IPRNT.EQ.2) WRITE (IWRITE,3040) IF (IPRNT.EQ.3) WRITE (IWRITE,3050) JA,JB C C Check if the radial integral has been stored. C 20 CONTINUE NUM = NUM+1 C XLAB = ISTORE*10+ITYPE IF (NUMSTO.GT.0) THEN DO I = NSTART+1,NSTART+NUMSTO IF (ABS(XLAB-PF(I)).LT.EPS10) THEN XINT = QF(I) ILAB = IST GOTO 90 ENDIF ENDDO ENDIF C C Evaluate Bessel functions in this section. C ILAB = IBL GOTO (30,60,50,80,40,70),ITYPE C C Type 1 and 5 integrals require J(K),N(K) Bessel fuctions. C Type 5 integrals only require W=WAB Bessel functions. C 30 CONTINUE IF (IA.EQ.IC .AND. IB.EQ.ID) GOTO 40 IF (IA.EQ.ID .AND. IC.EQ.IB) GOTO 40 CALL BESSEL(NWA,KEEP,IC,ID,1,2,K) 40 CONTINUE CALL BESSEL(NWA,KEEP,IA,IB,1,1,K) GOTO 80 C C TYPE 3 integrals require J(K),N(K) Bessel functions for either C W=WAB or W=CD whichever is non-zero. C 50 CONTINUE IF (IA.NE.IB) CALL BESSEL(NWA,KEEP,IA,IB,1,1,K) IF (IC.NE.ID) CALL BESSEL(NWA,KEEP,IC,ID,1,2,K) GOTO 80 C C Type 2 and 6 integrals require J(K),N(K) and J(K+2),N(K+2) C Bessel fuctions C Type 6 integrals only require W=WAB Bessel functions. C 60 CONTINUE IF (IA.EQ.IC .AND. IB.EQ.ID) GOTO 70 IF (IA.EQ.ID .AND. IC.EQ.IB) GOTO 70 C ICOD = MAX(IC,ID)+NWA*MIN(IC,ID) ICOD1 = ICOD+NWS*(K-1) ICOD2 = ICOD+NWS*(K+1) ICOD = MAX(IA,IB)+NWA*MIN(IA,IB) ICOD3 = ICOD+NWS*(K-1) ICOD4 = ICOD+NWS*(K+1) IF (ICOD1.EQ.KEEP(1,2) .AND. ICOD2.EQ.KEEP(2,2) .AND.ICOD3.EQ.! +KEEP(1,1) .AND. ICOD4.EQ.KEEP(2,1)) GOTO 80 IF (ICOD1.EQ.KEEP(1,1) .AND. ICOD2.EQ.KEEP(2,1) .AND.ICOD3.EQ.! +KEEP(1,2) .AND. ICOD4.EQ.KEEP(2,2)) GOTO 80 C CALL BESSEL(NWA,KEEP,IC,ID,1,2,K-1) CALL BESSEL(NWA,KEEP,IC,ID,2,2,K+1) 70 CONTINUE CALL BESSEL(NWA,KEEP,IA,IB,1,1,K-1) CALL BESSEL(NWA,KEEP,IA,IB,2,1,K+1) C C Multiply coefficient by integral. C 80 CONTINUE XINT = BRRA(ITYPE,IA,IB,IC,ID,K) C C Store radial integral. C NUMINT = NUMINT+1 IF (NUMSTO.LT.NUMX) THEN NUMSTO = NUMSTO+1 PF(NSTART+NUMSTO) = XLAB QF(NSTART+NUMSTO) = XINT ENDIF C 90 CONTINUE CONTR = COEF*XINT ELMNT = ELMNT+CONTR C C Sum core contributions. C IF (ITYP.LT.0) THEN ELSTO = ELSTO+CONTR NUMEL = NUMEL+1 ENDIF C C Write out contributions if requested - option 8 set. C IF (KTC(8).EQ.1) WRITE (IWRITE,3020) NP(IA),NH(IA),NP(IB),NH(I! +B),NP(IC),NH(IC),NP(ID),NH(ID),K,ITYP,COEF,XINT,CONTR,ILAB GOTO 10 C C Store total in BREVEC array. C Write out total if requested - option 8 set. C 100 CONTINUE NUMTOT = NUMTOT+NUM C IF (NUM.GT.0 .AND. KTC(8).EQ.1) WRITE (IWRITE,3030) ELMNT C BREVEC(JA,JB) = ELMNT BREVEC(JB,JA) = ELMNT !for new BREMT2 - nrb C C Add in core contribution if applicable. C Write out contribution if option 8 is set. C IF (JA.EQ.JB .AND. JA.GT.1 .AND. NUMEL.GT.0) THEN BREVEC(JA,JA) = BREVEC(JA,JA)+ELSTO IF (KTC(8).EQ.1) THEN WRITE (IWRITE,3060) ELSTO WRITE (IWRITE,3030) BREVEC(JA,JA) ENDIF ENDIF C IF (JA.EQ.JB) PRINT 3000,JA,JA,ELSTO,BREVEC(JA,JA) C ENDDO ENDDO C----------------------------------------------------------------------- REWIND IO4 C----------------------------------------------------------------------- WRITE (IWRITE,3070) NUMTOT WRITE (IWRITE,3080) NUMEL WRITE (IWRITE,3090) NUMINT WRITE (IWRITE,3100) NUMSTO PRINT 3070,NUMTOT PRINT 3080,NUMEL PRINT 3090,NUMINT PRINT 3100,NUMSTO C----------------------------------------------------------------------- 3000 FORMAT (' BREMT1 : ',2I5,1P,2E12.4) 3010 FORMAT (/' contributions to matrix element (',I2,',',I2,')'// ! +' A B C D K ITYPE coeff. integral ',! +' contribution'/) 3020 FORMAT (1X,4(I2,A2,1X),I4,2X,I4,1X,1P,3E16.8,1X,A1) 3030 FORMAT (1X,62X,'---------------'/1X,62X,1P,E15.8) 3040 FORMAT (/' Bessel functions evaluated'// ! +' A B K source destination'/) 3050 FORMAT (/' contribution to matrix element (',I2,',',I2,')'/ ! +' Bessel functions evaluated'// ! +' A B C D K ITYPE coeff. integral ',! +' contribution'/ ! +' A B K source destination'/) 3060 FORMAT (1X,'core contribution = ',48X,1P,E15.8) 3070 FORMAT (/1X,I5,' MCBP (Breit) angular coefficients read') 3080 FORMAT (1X,I5,' core (Breit) angular coefficients read') 3090 FORMAT (/1X,I5,' radial integrals evaluated') 3100 FORMAT (1X,I5,' radial integrals stored') END C C ******************* C SUBROUTINE BREMT2 C C----------------------------------------------------------------------- C C This subroutine forms the first-order Coulomb + Breit Hamiltonian C matrix and diagonalises it. It then orders the eigenvalues and C eigenvectors so they are compatible with the zero-order matrix's. C C Subroutine called: DSYEV C C Diagonalisation is now by Jp - nrb 17/09/08 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER LWORK PARAMETER (LWORK=MXNC*3-1) C C Local variables C DOUBLE PRECISION A,AMAX,AOVLAP(MXNC),EAV,am,eau DOUBLE PRECISION WORK(LWORK),XXX INTEGER I,IMAX,INFO INTEGER IORDER(MXNC),J,L INTEGER MAX integer ij,ip,itr,jtr,k LOGICAL LSWAP C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION BREVEC(MXNC,MXNC) COMMON / BRET2 / BREVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC) COMMON / ENRG2 / VPENG,SFENG C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER LORDER(MXNC) COMMON / PAT2 / LORDER C C Common variables C double precision tmpvec(mxnc,mxnc) double precision tmpeng(mxnc),ee,t integer itmp(mxnc),jtmp(mxnc),ncf0,nsym common /nrbtmp/ tmpvec,tmpeng,ee,t x ,itmp,jtmp,ncf0,nsym Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- LSWAP = .FALSE. WRITE (IWRITE,3000) C C add zero-order and Breit matrix - upper triangle only C DO I = 1,NCF DO J = I,NCF XXX = ZERO DO L = 1,NCF XXX = XXX+COUVEC(I,L)*COUVEC(J,L)*COUENG(L) ENDDO IF (ABS(XXX).LT.EPS10) XXX = ZERO BREVEC(I,J) = BREVEC(I,J)+XXX ENDDO ENDDO C C ----- Hamiltonian evaluated ----- C C Print Hamiltonian matrix if option 5 is set C IF (ITC(5).EQ.1) THEN WRITE (IWRITE,3070) CALL MATOUT(IWRITE,BREVEC,NCF,NCF,MXNC,MXNC,1) ENDIF C C calculate the average energy and subtract from diagonal C EAV = ZERO DO I = 1,NCF EAV = EAV+BREVEC(I,I) ENDDO EAV = EAV/DBLE(NCF) WRITE (IWRITE,3060) EAV PRINT 3060,EAV DO I = 1,NCF BREVEC(I,I) = BREVEC(I,I)-EAV ENDDO C C----------------------------------------------------------------------- C C Diagonalise the Hamiltonian by Jp sub-block (nrb) C C----------------------------------------------------------------------- c WRITE (IWRITE,3030) c c Initialize c nsym=0 do itr=1,ncf itmp(itr)=0 enddo c c First, find a symmetry c 40 ncf0=0 do itr=1,ncf if(itmp(itr).eq.0)then !we have a new one nsym=nsym+1 do jtr=1,ncf !find all if(itjpo(itr).eq.itjpo(jtr).and. x ispar(itr).eq.ispar(jtr))then ncf0=ncf0+1 jtmp(ncf0)=jtr itmp(jtr)=nsym endif enddo go to 50 !go diagonalize endif enddo c go to 60 !we are done c 50 do j=1,ncf0 !transfer Jp block jtr=jtmp(j) do i=1,j itr=jtmp(i) tmpvec(i,j)=brevec(itr,jtr) enddo enddo C C use a LAPACK routine C ij=itjpo(jtmp(1))-1 ip=ispar(jtmp(1)) c write(iwrite,*)'Diagonalizing symmetry:',nsym,' 2J=',ij,' P=',ip c CALL DSYEV ('V','U',ncf0,tmpvec,MXNC,tmpeng,WORK,LWORK,INFO) c IF (INFO.NE.0) THEN WRITE (IWRITE,3010) STOP ENDIF c c Transfer back c do j=1,ncf0 jtr=jtmp(j) vpeng(jtr)=tmpeng(j) do i=1,ncf0 itr=jtmp(i) brevec(itr,jtr)=tmpvec(i,j) enddo enddo c c Go look for another symmetry c go to 40 C----------------------------------------------------------------------- C C Diagonalisation of the Hamiltonian complete C C----------------------------------------------------------------------- c c Sort into ascending energy order c 60 do i=1,ncf k=i ee=vpeng(k) do j=i+1,ncf if(vpeng(j).lt.ee)then k=j ee=vpeng(j) endif enddo if(k.ne.i)then vpeng(k)=vpeng(i) vpeng(i)=ee do j=1,ncf t=brevec(j,i) brevec(j,i)=brevec(j,k) brevec(j,k)=t enddo endif enddo C C Add back the average energy C DO I = 1,NCF VPENG(I) = VPENG(I)+EAV ENDDO C----------------------------------------------------------------------- C C Order new Breit eigenvectors and eigenvalues consistently C with the zero-order Coulomb ones. C DO I = 1,NCF C C Find equivalent new vector that is (approx) normal C to the I-th zero-order vector. C MAX = 0 AMAX = ZERO C C Find MAX element of vector. C DO J = 1,NCF A = ZERO DO L = 1,NCF A = A+COUVEC(L,I)*BREVEC(L,J) ENDDO A = ABS(A) AOVLAP(J) = A IF (A.GE.AMAX) THEN MAX = J AMAX = A ENDIF ENDDO C IF (AMAX.LT.0.9D0) THEN WRITE (IWRITE,3020) I,AMAX,MAX,(AOVLAP(J),J=1,NCF) ENDIF C C MAX-th vector is (approx) equivalent C BREENG(I) = VPENG(MAX)-COUENG(I) C IF (I.NE.MAX) THEN LSWAP = .TRUE. LORDER(I) = 1 WRITE (IWRITE,3040) I,MAX WRITE (IPUNCH,3050) I,MAX PRINT 3050,I,MAX ELSE LORDER(I) = 0 ENDIF C C use same phase for vector as used for coulomb vector C AMAX = ZERO IMAX = 0 C DO L = 1,NCF A = ABS(BREVEC(L,MAX)) IF (A.LT.EPS10) THEN BREVEC(L,MAX) = ZERO ELSE IF (A.GT.AMAX) THEN AMAX = A IMAX = L ENDIF ENDIF ENDDO C C make sign of largest element positive C IF (BREVEC(IMAX,MAX).LT.ZERO) THEN DO L = 1,NCF BREVEC(L,MAX) = -BREVEC(L,MAX) ENDDO ENDIF C IORDER(I) = MAX itmp(i)=imax C ENDDO C C Print eigenvalues and eigenvectors if option 6 is set C (Breit ordering here.) C IF (ITC(6).EQ.1) THEN C WRITE (IWRITE,3080) C DO J = 1,NCPRIN C EAU = vpeng(J) I = itmp(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = brevec(I,J) C IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3120) J,IJ,I,AM,EAU ELSE WRITE (IWRITE,3110) J,IJ,I,AM,EAU ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3100) J,IJ,I,AM,EAU ELSE WRITE (IWRITE,3090) J,IJ,I,AM,EAU ENDIF ENDIF C ENDDO C CALL MATOUT(IWRITE,BREVEC,NCPRIN,NCF,MXNC,MXNC,3) C ENDIF C C now rearrange the eigenvectors according to the Coulomb ordering C IF (LSWAP) THEN C DO I = 1,NCF MAX = IORDER(I) DO L = 1,NCF TMPVEC(L,I) = BREVEC(L,MAX) ENDDO ENDDO C DO I = 1,NCF DO J = 1,NCF BREVEC(I,J) = TMPVEC(I,J) ENDDO ENDDO C ENDIF C 3000 FORMAT (/ ! +' >>>> routine BREMT2 called : diagonalise the Breit matrix') 3010 FORMAT (/' ERROR using the DSYEV routine'/' STOPPING') 3020 FORMAT (/' Possible breakdown in perturbation theory for level ',I! +4/' Maximum vector normalisation is ',1P,E8.1,' with level ',I4/ ! +' The overlaps are :'/(1X,1P,8E9.1)) 3030 FORMAT (/' diagonalisation using the DSYEV routine'/) 3040 FORMAT (/' WARNING from BREMT2'/ ! +' Change in level ordering when Breit contribution is included'/ ! +' Coulomb level ',I4,' is equivalent to Breit level ',I4) 3050 FORMAT (/' Coulomb level ',I4,' is equivalent to Breit level ',I4) 3060 FORMAT (/' average energy (a.u.) ',1P,E18.10) 3070 FORMAT (/' estimated Hamiltonian matrix') 3080 FORMAT (/' eigenenergies'//' dominant'/ ! +' level J parity CSF mix a.u.'/) 3090 FORMAT (1X,I4,2X,I4,'/2 odd ',I4,2X,F5.3,3X,1P,E20.12) 3100 FORMAT (1X,I4,2X,I4,'/2 even ',I4,2X,F5.3,3X,1P,E20.12) 3110 FORMAT (1X,I4,2X,I4,' odd ',I4,2X,F5.3,3X,1P,E20.12) 3120 FORMAT (1X,I4,2X,I4,' even ',I4,2X,F5.3,3X,1P,E20.12) END C C ******************* C FUNCTION BRRA(ITYPE,IA,IC,IB,ID,K) C C----------------------------------------------------------------------- C C This routine evaluates the Breit interaction integrals C C ITYPE=1. calculates general R(K; A C / B D ) C C ITYPE=2. calculates general S(K; A C / B D ) C C ITYPE=3. calculates R(K; A , B D ) C C ITYPE=4. calculates F(K; A , B ) C C ITYPE=5. calcualtes G(K; A , B ) type integral C C ITYPE=6. calculates H(K; A , B ) type integral C C It calls the routines RKINT and SKINT to perform the particular C integrals required. C C Subroutines called: RKINT,SKINT C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION BRRA INCLUDE 'grasp0.inc' C C External functions C EXTERNAL RKINT,SKINT DOUBLE PRECISION RKINT,SKINT C C Parameter variables C DOUBLE PRECISION HALF PARAMETER (HALF=.5D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) C C Argument variables C INTEGER IA,IB,IC,ID INTEGER ITYPE,K C C Local variables C DOUBLE PRECISION RAC(MXNP),RBD(MXNP) INTEGER I,IA1,IB1,IC1 INTEGER ID1,NGRAC,NGRBD,NGRID C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Set the grid end C NGRAC = MIN(MPOIN(IA),MPOIN(IC)) NGRBD = MIN(MPOIN(IB),MPOIN(ID)) NGRID = MIN(NGRAC,NGRBD) C IA1 = MPOS(IA) IC1 = MPOS(IC) DO I = 1,NGRAC RAC(I) = PF(IA1)*QF(IC1) IA1 = IA1+1 IC1 = IC1+1 ENDDO IB1 = MPOS(IB) ID1 = MPOS(ID) DO I = 1,NGRBD RBD(I) = PF(IB1)*QF(ID1) IB1 = IB1+1 ID1 = ID1+1 ENDDO C GOTO (10,20,30,40,50,60),ITYPE C C ITYPE=1 C ------- 10 CONTINUE IF (IA.EQ.IB .AND. IC.EQ.ID) THEN BRRA = TWO*RKINT(NGRAC,NGRID,RAC,RBD,K,1) RETURN C ENDIF C IF (IA.EQ.ID .AND. IC.EQ.IB) THEN BRRA = RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RBD,RAC,! +K,1) RETURN C ENDIF C BRRA = (RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RAC,RBD,K! +,2)+RKINT(NGRAC,NGRID,RBD,RAC,K,1)+RKINT(NGRAC,NGRID,RBD,RAC,K,2))! +*HALF RETURN C C ITYPE=2 C ------- 20 CONTINUE IF ((IA.EQ.IB.AND.IC.EQ.ID) .OR. (IA.EQ.ID.AND.IC.EQ.IB)) THEN BRRA = SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,1) C ELSE BRRA = (SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,1)+SKINT(NGRAC,NGRBD,N! +GRID,RAC,RBD,K,2))*HALF ENDIF C RETURN C C ITYPE=3 C ------- 30 CONTINUE IF (IA.EQ.IC) THEN IB1 = MPOS(IB) ID1 = MPOS(ID) DO I = 1,NGRBD RBD(I) = RBD(I)+PF(ID1)*QF(IB1) IB1 = IB1+1 ID1 = ID1+1 ENDDO BRRA = (RKINT(NGRAC,NGRID,RAC,RBD,K,0)+RKINT(NGRAC,NGRID,RAC,RBD! +,K,2)+RKINT(NGRAC,NGRID,RBD,RAC,K,2))*HALF C ELSE IC1 = MPOS(IC) IA1 = MPOS(IA) DO I = 1,NGRAC RAC(I) = RAC(I)+PF(IC1)*QF(IA1) IC1 = IC1+1 IA1 = IA1+1 ENDDO BRRA = (RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RBD,RAC! +,K,1)+RKINT(NGRAC,NGRID,RAC,RBD,K,0))*HALF ENDIF C RETURN C C ITYPE=4 C ------- 40 CONTINUE BRRA = RKINT(NGRAC,NGRID,RAC,RBD,K,0) RETURN C C ITYPE=5 C ------- 50 CONTINUE IF (IA.EQ.ID .AND. IC.EQ.IB) THEN BRRA = RKINT(NGRAC,NGRID,RAC,RBD,K,1)+RKINT(NGRAC,NGRID,RBD,RAC,! +K,1) C ELSE BRRA = TWO*RKINT(NGRAC,NGRID,RAC,RBD,K,1) ENDIF C RETURN C C ITYPE=6 C ------- 60 CONTINUE BRRA = SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,1) C END C C ******************* C SUBROUTINE CALEN(IWRITE,IPUNCH,RECORD) C----------------------------------------------------------------------- C C CALEN returns in RECORD the time and date at execution of program. C C----------------------------------------------------------------------- CHARACTER RECORD*20 C----------------------------------------------------------------------- RECORD = ' not available ' C IF (IWRITE.GT.0) WRITE (IWRITE,3000) RECORD IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) RECORD C 3000 FORMAT (//' Run at : ',A20/) END C C ******************* C SUBROUTINE CARDIN(IREAD,IWRITE,IPUNCH,LABEL,JC,NH,NG,NN,RT,IT,ND) C C----------------------------------------------------------------------- C C Reads input records using free format. C C NOTE that only the first 72 characters on the input record are read. C C INPUT C C IREAD - input read from stream number IREAD C IWRITE - output written to stream number IWRITE C IPUNCH - output written to stream number IPUNCH C LABEL - number of input record being read C JC - determines the format in which the input C record is to be read C =0 read 72 characters. C =1 read integer (I2) , label (A2) , 68 characters C The label is used to assign kappa values for orbitals. C =2 read label (A4) , 68 characters C ND - maximum number of numbers which can be read C sets the dimensions of RT and IT C C OUTPUT C C NH - A2 label read if JC=1 C NG - A4 label read if JC=2 C NN - the number of numbers which have been read C RT - array containing the NN numbers as reals C IT - array containing the NN numbers as integers C C The following characters are recognised C 0 1 2 3 4 5 6 7 8 9 - . E / * C ! c e D d + : and BLANK C C BLANK is used to separate numbers. C BLANKs cannot occur within a number. C C 'C' or 'c' can be used to continue an input record - another C input record will be read by CARDIN using format JC=0 C A number cannot be split across two input records. C All characters following 'C' or 'c' are ignored. C C '/' can be used to input fractions with numerator or C denominator being real or integer C C 'E' or 'e' or 'D' or 'd' denotes exponent C the exponent must be an integer between -99 and 99 C C '*' is used to indicate a repeated value as in FORTRAN C data statements C C ':' specifies a range of numbers C C '!' marks the end of the input record, allows comments to be written C C Some checks on consistency are in the code. C An error message will be output if the routine fails. C C The following are examples of numbers which can C be read by CARDIN : C C .123 , -.123 , -3.23 , 4.5E6 , 12 , 2E-6 C 2/6 , 2.1/6 , -2./6E-2 C C Numbers are read as reals (RT) C and then the nearest integers are obtained (IT). C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION EPS6 PARAMETER (EPS6=1.D-6) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION HALF PARAMETER (HALF=.5D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TEN PARAMETER (TEN=1.D1) C C Argument variables C INTEGER JC,LABEL,ND,NN CHARACTER*4 NG CHARACTER*2 NH DOUBLE PRECISION RT(ND) INTEGER IPUNCH,IREAD,IT(ND),IWRITE C C Local variables C CHARACTER BLANK,ICH(24) CHARACTER*2 IOR(15) CHARACTER JD(73),JDJ DOUBLE PRECISION RINC,SUM,SUMA,SUME DOUBLE PRECISION SUMX,XSIGN INTEGER I,IBL,ICO,IDI INTEGER IEX,IFAIL,IPT,IRA INTEGER IRP,ISI,J,JPT INTEGER JSTART,K,LEN,N1 INTEGER NK(15),NRA,NRP Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA BLANK/' '/ DATA IOR/'S ','P-','P ','D-','D ','F-','F ','G-','G ','H-','H ','I! +-','I ','J-','J '/ DATA NK/-1,1,-2,2,-3,3,-4,4,-5,5,-6,6,-7,7,-8/ DATA ICH/'0','1','2','3','4','5','6','7','8','9','-','.','E','/','! +*',' ','C','!','c','e','D','d','+',':'/ C----------------------------------------------------------------------- IF (JC.EQ.2) THEN C C JC=2 read label (A4) , 68 characters C READ (IREAD,3200) NG, (JD(I),I=5,72) C DO I = 72,5,-1 IF (JD(I).NE.BLANK) THEN LEN = I GOTO 10 ENDIF ENDDO LEN = 5 10 CONTINUE C LABEL = LABEL+1 IF (IWRITE.GT.0) WRITE (IWRITE,3210) LABEL,NG, (JD(I),I=5,LEN) IF (IPUNCH.GT.0) WRITE (IPUNCH,3210) LABEL,NG, (JD(I),I=5,LEN) NN = 0 N1 = 1 JSTART = 4 C ELSE C IF (JC.EQ.1) THEN C C JC=1 read integer (I2) , label (A2) , 68 characters C The label is used to assign kappa values for orbitals. C READ (IREAD,3260) IT(1),NH, (JD(I),I=5,72) C DO I = 72,5,-1 IF (JD(I).NE.BLANK) THEN LEN = I GOTO 20 ENDIF ENDDO LEN = 5 20 CONTINUE C LABEL = LABEL+1 IF (IWRITE.GT.0) WRITE (IWRITE,3270) LABEL,IT(1),NH,(JD(I),I=5! +,LEN) IF (IPUNCH.GT.0) WRITE (IPUNCH,3270) LABEL,IT(1),NH,(JD(I),I=5! +,LEN) DO I = 1,15 IF (NH.EQ.IOR(I)) GOTO 30 ENDDO J = 1 JSTART = 4 IFAIL = 0 GOTO 170 C 30 CONTINUE IT(2) = NK(I) RT(1) = IT(1) RT(2) = IT(2) NN = 2 N1 = 3 JSTART = 4 C ELSE C C JC=0 read 72 characters. C READ (IREAD,3220) (JD(I),I=1,72) C DO I = 72,1,-1 IF (JD(I).NE.BLANK) THEN LEN = I GOTO 40 ENDIF ENDDO LEN = 1 40 CONTINUE C LABEL = LABEL+1 IF (IWRITE.GT.0) WRITE (IWRITE,3230) LABEL, (JD(I),I=1,LEN) IF (IPUNCH.GT.0) WRITE (IPUNCH,3230) LABEL, (JD(I),I=1,LEN) NN = 0 N1 = 1 JSTART = 0 ENDIF C ENDIF C GOTO 70 C----------------------------------------------------------------------- C C begin here if an input record is continued C C----------------------------------------------------------------------- 50 CONTINUE READ (IREAD,3220) (JD(I),I=1,72) C DO I = 72,1,-1 IF (JD(I).NE.BLANK) THEN LEN = I GOTO 60 ENDIF ENDDO LEN = 1 60 CONTINUE C LABEL = LABEL+1 IF (IWRITE.GT.0) WRITE (IWRITE,3230) LABEL, (JD(I),I=1,LEN) IF (IPUNCH.GT.0) WRITE (IPUNCH,3230) LABEL, (JD(I),I=1,LEN) JSTART = 0 C----------------------------------------------------------------------- C C begin here for each new input record C C----------------------------------------------------------------------- 70 CONTINUE ICO = 0 IRA = 0 IRP = 0 LEN = LEN+1 JD(LEN) = BLANK J = JSTART C----------------------------------------------------------------------- C C begin here when a complete number has been read C C----------------------------------------------------------------------- 80 CONTINUE IBL = 0 IDI = 0 C----------------------------------------------------------------------- C C begin here if '/' has been read - read denominator C C----------------------------------------------------------------------- 90 CONTINUE IEX = 0 C----------------------------------------------------------------------- C C begin here if 'E' or 'e' or 'D' or 'd' has been read - read exponent C C----------------------------------------------------------------------- 100 CONTINUE ISI = 0 IPT = 0 JPT = 0 SUM = ZERO XSIGN = ONE C----------------------------------------------------------------------- C C examine each character in turn C C----------------------------------------------------------------------- 110 CONTINUE J = J+1 C C ====== only the first LEN characters are examined ====== C IF (J.EQ.LEN+1) GOTO 160 C JDJ = JD(J) DO I = 1,24 IF (JDJ.EQ.ICH(I)) GOTO 120 ENDDO C----------------------------------------------------------------------- C C ERROR - character not allowed C C----------------------------------------------------------------------- IFAIL = 1 GOTO 170 C----------------------------------------------------------------------- 120 CONTINUE C----------------------------------------------------------------------- IF (I.EQ.16) GOTO 140 C----------------------------------------------------------------------- C C character is '!' for comment C this is equivalent to BLANK and end of line C C----------------------------------------------------------------------- IF (I.EQ.18) THEN I = 16 J = LEN GOTO 140 ENDIF C----------------------------------------------------------------------- C C character is 'C' or 'c' for continue C another input record will be read C this is equivalent to BLANK and end of line C with flag set for continue C C----------------------------------------------------------------------- IF (I.EQ.17 .OR. I.EQ.19) THEN I = 16 J = LEN ICO = 1 GOTO 140 ENDIF C----------------------------------------------------------------------- C C character is ':' for range C this is equivalent to BLANK C with flag set for range C C----------------------------------------------------------------------- IF (I.EQ.24) THEN C IF (IRA.GT.0) THEN IFAIL = 13 GOTO 170 ENDIF C IF (IRP.GT.0) THEN IFAIL = 14 GOTO 170 ENDIF C I = 16 IRA = 1 GOTO 140 C ENDIF C----------------------------------------------------------------------- C C character is '*' for repeat C this is equivalent to BLANK C with flag set for repeat C C----------------------------------------------------------------------- IF (I.EQ.15) THEN C IF (IRA.GT.0) THEN IFAIL = 23 GOTO 170 ENDIF C IF (IRP.GT.0) THEN IFAIL = 24 GOTO 170 ENDIF C I = 16 IRP = 1 GOTO 140 C ENDIF C----------------------------------------------------------------------- C C Character is a digit. C Construct the number. C IBL is set to 1 and ISI is set to 1 to indicate a number C is being read C C----------------------------------------------------------------------- IF (I.GE.1 .AND. I.LE.10) THEN IBL = 1 ISI = 1 JPT = JPT+1 SUM = SUM*TEN+(I-1) GOTO 110 ENDIF C----------------------------------------------------------------------- C C character is '-' C ERROR - if a sign has already been read for this number C C----------------------------------------------------------------------- IF (I.EQ.11) THEN C IF (ISI.EQ.1) THEN IFAIL = 4 GOTO 170 ENDIF C XSIGN = -ONE ISI = 1 GOTO 110 C ENDIF C----------------------------------------------------------------------- C C character is '+' C ERROR - if a sign has already been read for this number C C----------------------------------------------------------------------- IF (I.EQ.23) THEN C IF (ISI.EQ.1) THEN IFAIL = 4 GOTO 170 ENDIF C XSIGN = ONE ISI = 1 GOTO 110 C ENDIF C----------------------------------------------------------------------- C C character is '.' C ERROR - if '.' has already been read for this number C C----------------------------------------------------------------------- IF (I.EQ.12) THEN C IF (IPT.EQ.1) THEN IFAIL = 5 GOTO 170 ENDIF C ISI = 1 IPT = 1 JPT = 0 GOTO 110 C ENDIF C----------------------------------------------------------------------- C C To get here you must have read C C 'E' or 'e' or 'D' or 'd' C '/' C ' ' just after a number C C----------------------------------------------------------------------- 130 CONTINUE C----------------------------------------------------------------------- C C form current number C C ERROR - '.' in isolation C C----------------------------------------------------------------------- SUM = XSIGN*SUM C IF (IPT.GT.0) THEN IF (IBL.EQ.0) THEN IFAIL = 6 GOTO 170 ENDIF SUM = SUM*TEN**(-JPT) ENDIF C----------------------------------------------------------------------- C C character is 'E' or 'e' or 'D' or 'd' C C ERROR - if 'E' has already been read for this number C or a number is not being read C C store mantissa in SUME and look for exponent C C----------------------------------------------------------------------- IF (I.EQ.13 .OR. I.EQ.20 .OR. I.EQ.21 .OR. I.EQ.22) THEN C IF (IEX.EQ.1) THEN IFAIL = 7 GOTO 170 ENDIF C IF (IBL.EQ.0) THEN IFAIL = 8 GOTO 170 ENDIF C IEX = 1 SUME = SUM GOTO 100 C ENDIF C----------------------------------------------------------------------- C C character is '/' or ' ' C C----------------------------------------------------------------------- C C 'E' has been read for this number C the exponent has now been obtained C C ERROR - if exponent contained '.' or more than 2 digits C (exponent is an integer lying between -99 and 99) C C Form the number. C C----------------------------------------------------------------------- IF (IEX.EQ.1) THEN C IF (IPT.EQ.1) THEN IFAIL = 9 GOTO 170 ENDIF C IF (JPT.GT.2) THEN IFAIL = 10 GOTO 170 ENDIF C IF (SUM.LT.ZERO) SUM = SUM - HALF - EPS6 IF (SUM.GE.ZERO) SUM = SUM + HALF + EPS6 JPT = INT(SUM) SUM = SUME*TEN**JPT C ENDIF C----------------------------------------------------------------------- C C Character is '/' - denoting division C C ERROR - if '/' has already been read for this number C or a number is not being read C C Store the first number. C Read the denominator. C C----------------------------------------------------------------------- IF (I.EQ.14) THEN C IF (IDI.EQ.1) THEN IFAIL = 11 GOTO 170 ENDIF C IF (IBL.EQ.0) THEN IFAIL = 12 GOTO 170 ENDIF C IDI = 1 SUMA = SUM GOTO 90 C ENDIF C----------------------------------------------------------------------- GOTO 150 C----------------------------------------------------------------------- C C character is ' ' C This character is used to separate numbers. C It indicates that a number has been read. C C----------------------------------------------------------------------- 140 CONTINUE IF (IBL.EQ.1) GOTO 130 GOTO 80 C----------------------------------------------------------------------- C C '/' was read - evaluate number. C C ERROR - denominator is zero. C C----------------------------------------------------------------------- 150 CONTINUE IF (IDI.EQ.1) THEN IF (SUM.EQ.ZERO) THEN IFAIL = 15 GOTO 170 ENDIF SUM = SUMA/SUM ENDIF C----------------------------------------------------------------------- C C Range was defined. C C----------------------------------------------------------------------- IF (IRA.EQ.1) THEN SUMX = SUM IRA = 2 GOTO 80 ENDIF C IF (IRA.EQ.2) THEN C NRA = INT(SUM-SUMX) RINC = ONE C IF (NRA.LT.0) THEN RINC = -ONE NRA = -NRA ELSE RINC = ONE ENDIF C NN = NN+1 IF (NN.GT.ND) GOTO 180 RT(NN) = SUMX C IF (NRA.GT.0) THEN DO K = 1,NRA SUMX = SUMX+RINC NN = NN+1 IF (NN.GT.ND) GOTO 180 RT(NN) = SUMX ENDDO ENDIF C IRA = 0 GOTO 80 C ENDIF C----------------------------------------------------------------------- C C Repeat count given. C C ERROR - if repeat count is less then 1 C C----------------------------------------------------------------------- IF (IRP.EQ.1) THEN C NRP = INT(SUM) C IF (NRP.LE.0) THEN IFAIL = 20 GOTO 170 ENDIF C IRP = 2 GOTO 80 C ENDIF C IF (IRP.EQ.2) THEN DO K = 1,NRP NN = NN+1 IF (NN.GT.ND) GOTO 180 RT(NN) = SUM ENDDO IRP = 0 GOTO 80 ENDIF C----------------------------------------------------------------------- NN = NN+1 IF (NN.GT.ND) GOTO 180 RT(NN) = SUM GOTO 80 C----------------------------------------------------------------------- C C Input record has been read. C Read another input record if 'C' has been read. C C EROOR - You cannot continue with incomplete range or repeat. C C----------------------------------------------------------------------- 160 CONTINUE C IF (IRA.GT.1) THEN IFAIL = 33 GOTO 170 ENDIF C IF (IRP.GT.1) THEN IFAIL = 34 GOTO 170 ENDIF C IF (ICO.EQ.1) GOTO 50 C----------------------------------------------------------------------- C C The numbers are read as real. C Take the nearest integers. C C----------------------------------------------------------------------- IF (NN.GE.N1) THEN DO I = N1,NN SUM = RT(I) IF (SUM.LT.ZERO) THEN SUM = SUM-HALF-EPS6 ELSE SUM = SUM+HALF+EPS6 ENDIF IT(I) = INT(SUM) ENDDO ENDIF C----------------------------------------------------------------------- RETURN C----------------------------------------------------------------------- C C ERROR messages. C C----------------------------------------------------------------------- 170 CONTINUE DO I = JSTART+1,LEN JD(I) = ICH(16) ENDDO IF (IFAIL.GT.0) JD(J) = ICH(15) IF (IWRITE.GT.0) THEN IF (JC.EQ.2) WRITE (IWRITE,3210) LABEL,NG, (JD(I),I=5,LEN) IF (JC.EQ.1) WRITE (IWRITE,3270) LABEL,IT(1),NH,(JD(I),I=5,LEN) IF (JC.EQ.0) WRITE (IWRITE,3230) LABEL, (JD(I),I=1,LEN) WRITE (IWRITE,3240) IF (IFAIL.EQ.0) WRITE (IWRITE,3000) IF (IFAIL.EQ.1) WRITE (IWRITE,3010) IF (IFAIL.EQ.4) WRITE (IWRITE,3020) IF (IFAIL.EQ.5) WRITE (IWRITE,3030) IF (IFAIL.EQ.6) WRITE (IWRITE,3040) IF (IFAIL.EQ.7) WRITE (IWRITE,3050) IF (IFAIL.EQ.8) WRITE (IWRITE,3060) IF (IFAIL.EQ.9) WRITE (IWRITE,3070) IF (IFAIL.EQ.10) WRITE (IWRITE,3080) IF (IFAIL.EQ.11) WRITE (IWRITE,3090) IF (IFAIL.EQ.12) WRITE (IWRITE,3100) IF (IFAIL.EQ.13) WRITE (IWRITE,3110) IF (IFAIL.EQ.14) WRITE (IWRITE,3120) IF (IFAIL.EQ.15) WRITE (IWRITE,3130) IF (IFAIL.EQ.17) WRITE (IWRITE,3140) IF (IFAIL.EQ.20) WRITE (IWRITE,3150) IF (IFAIL.EQ.23) WRITE (IWRITE,3160) IF (IFAIL.EQ.24) WRITE (IWRITE,3170) IF (IFAIL.EQ.33) WRITE (IWRITE,3180) IF (IFAIL.EQ.34) WRITE (IWRITE,3190) ENDIF C IF (IPUNCH.GT.0) THEN IF (JC.EQ.2) WRITE (IPUNCH,3210) LABEL,NG, (JD(I),I=5,LEN) IF (JC.EQ.1) WRITE (IPUNCH,3270) LABEL,IT(1),NH,(JD(I),I=5,LEN) IF (JC.EQ.0) WRITE (IPUNCH,3230) LABEL, (JD(I),I=1,LEN) WRITE (IPUNCH,3240) IF (IFAIL.EQ.0) WRITE (IPUNCH,3000) IF (IFAIL.EQ.1) WRITE (IPUNCH,3010) IF (IFAIL.EQ.4) WRITE (IPUNCH,3020) IF (IFAIL.EQ.5) WRITE (IPUNCH,3030) IF (IFAIL.EQ.6) WRITE (IPUNCH,3040) IF (IFAIL.EQ.7) WRITE (IPUNCH,3050) IF (IFAIL.EQ.8) WRITE (IPUNCH,3060) IF (IFAIL.EQ.9) WRITE (IPUNCH,3070) IF (IFAIL.EQ.10) WRITE (IPUNCH,3080) IF (IFAIL.EQ.11) WRITE (IPUNCH,3090) IF (IFAIL.EQ.12) WRITE (IPUNCH,3100) IF (IFAIL.EQ.13) WRITE (IPUNCH,3110) IF (IFAIL.EQ.14) WRITE (IPUNCH,3120) IF (IFAIL.EQ.15) WRITE (IPUNCH,3130) IF (IFAIL.EQ.17) WRITE (IPUNCH,3140) IF (IFAIL.EQ.20) WRITE (IPUNCH,3150) IF (IFAIL.EQ.23) WRITE (IPUNCH,3160) IF (IFAIL.EQ.24) WRITE (IPUNCH,3170) IF (IFAIL.EQ.33) WRITE (IPUNCH,3180) IF (IFAIL.EQ.34) WRITE (IPUNCH,3190) ENDIF C STOP C----------------------------------------------------------------------- 180 CONTINUE IF (IWRITE.GT.0) WRITE (IWRITE,3250) IF (IPUNCH.GT.0) WRITE (IPUNCH,3250) STOP C----------------------------------------------------------------------- 3000 FORMAT (' orbital label not recognised') 3010 FORMAT (' character not recognised') 3020 FORMAT (' sign already read for this number') 3030 FORMAT (' . already read for this number') 3040 FORMAT (' . occurs in isolation') 3050 FORMAT (' exponent already read for this number') 3060 FORMAT (' exponent read but number is not being read') 3070 FORMAT (' exponent contains .') 3080 FORMAT (' exponent has more than 2 digits') 3090 FORMAT (' / already read for this number') 3100 FORMAT (' / read but number is not being read') 3110 FORMAT (' : read but range already specified') 3120 FORMAT (' : read but repeat count already specified') 3130 FORMAT (' denominator is zero') 3140 FORMAT (' range of numbers but repeat count already specified') 3150 FORMAT (' repeat count is less than 1') 3160 FORMAT (' * read but range already specified') 3170 FORMAT (' * read but repeat count already specified') 3180 FORMAT (' : cannot be continued to another line') 3190 FORMAT (' * cannot be continued to another line') 3200 FORMAT (A4,69A1) 3210 FORMAT (1X,I4,' = ',A4,69A1) 3220 FORMAT (73A1) 3230 FORMAT (1X,I4,' = ',73A1) 3240 FORMAT (/' ERROR on above input record read by subroutine CARDIN') 3250 FORMAT (/' Dimension ERROR in subroutine CARDIN.'/ ! +' Increase the input parameter ND.') 3260 FORMAT (I2,A2,69A1) 3270 FORMAT (1X,I4,' = ',I2,A2,69A1) END C C ******************* C SUBROUTINE CFOUT C C----------------------------------------------------------------------- C C Print configuration data in a neat format. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Local variables C CHARACTER*4 ILIT(MXNW),ITOT(MXNW),JLAB(20) CHARACTER*2 NNH(MXNW),NOCCP(MXNW),NSEN(MXNW),NUM(20) INTEGER I,IBIGJ,IFIRST INTEGER ILITJ(MXNW),ITOTJ(MXNW),J,K INTEGER K1,K2,MM,MX INTEGER NCOR,NCORE,NFULL INTEGER NN(MXNW),NOC,NOCC,NWP INTEGER NX C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA NUM/'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 ','10','1! +1','12','13','14','15','16','17','18','19'/ DATA JLAB/'0 ','1/2 ','1 ','3/2 ','2 ','5/2 ','3 ','7/2 ',! +'4 ','9/2 ','5 ','11/2','6 ','13/2','7 ','15/2','8 ','17! +/2','9 ','19/2'/ C----------------------------------------------------------------------- NCORE = 0 IF (NW.GT.0) THEN DO J = 1,NW NFULL = 2*ABS(NAK(J)) DO I = 1,NCF IF (IQ(J,I).NE.NFULL) GOTO 10 ENDDO NCORE = NCORE+1 ENDDO ENDIF C 10 CONTINUE NWP = NW-NCORE NCOR = NCORE+1 C WRITE (IWRITE,3000) C IF (NCORE.EQ.0) THEN WRITE (IWRITE,3050) ELSE C DO I = 1,NCORE NX = IQ(I,1) NOCCP(I) = NUM(NX+1) ENDDO C WRITE (IWRITE,3020) C K1 = 1 K2 = NCORE IF (K2.GT.10) K2 = 10 20 CONTINUE WRITE (IWRITE,3030) (NOCCP(I),I=K1,K2) WRITE (IWRITE,3040) (NP(I),NH(I),I=K1,K2) IF (K2.EQ.NCORE) GOTO 30 K1 = K1+10 K2 = NCORE IF (K2.GT.K1+9) K2 = K1 + 9 GOTO 20 C 30 CONTINUE ENDIF C----------------------------------------------------------------------- IF (NWP.EQ.0) THEN WRITE (IWRITE,3060) ELSE WRITE (IWRITE,3070) DO I = 1,NCF MM = 1 IBIGJ = 1 IFIRST = 0 NOC = 0 C DO J = NCOR,NW IF (IQ(J,I).GT.0) THEN NOC = NOC+1 MX = IQ(J,I) NOCCP(NOC) = NUM(MX+1) NN(NOC) = NP(J) NNH(NOC) = NH(J) MX = JQS(1,J,I) NSEN(NOC) = NUM(MX+1) ILITJ(NOC) = JQS(3,J,I) NOCC = MIN(IQ(J,I),2*ABS(NAK(J))-IQ(J,I)) IF (NOCC.GT.0) THEN IF (IFIRST.EQ.0) THEN IFIRST = 1 IBIGJ = ILITJ(NOC) ELSE IBIGJ = JCUP(MM,I) MM = MM+1 ENDIF ENDIF ITOTJ(NOC) = IBIGJ ENDIF ENDDO C DO J = 1,NOC MX = ILITJ(J) ILIT(J) = JLAB(MX) MX = ITOTJ(J) ITOT(J) = JLAB(MX) ENDDO C MX = ITJPO(I) IF (ISPAR(I).GT.0) THEN WRITE (IWRITE,3120) I,JLAB(MX) ELSE WRITE (IWRITE,3110) I,JLAB(MX) ENDIF C K1 = 1 K2 = NOC IF (K2.GT.4) K2 = 4 40 CONTINUE WRITE (IWRITE,3080) (NOCCP(K),K=K1,K2) WRITE (IWRITE,3090) (NN(K),NNH(K),K=K1,K2) WRITE (IWRITE,3100) (NSEN(K),ILIT(K),ITOT(K),K=K1,K2) IF (K2.EQ.NOC) GOTO 50 K1 = K1+4 K2 = NOC IF (K2.GT.K1+3) K2 = K1 + 3 GOTO 40 C 50 CONTINUE ENDDO C ENDIF C WRITE (IWRITE,3010) C----------------------------------------------------------------------- 3000 FORMAT (/1X,71('*')/' routine CFOUT: write out jj-coupled CSFs'/1X! +,71('*')) 3010 FORMAT (/1X,71('*')) 3020 FORMAT (/' The core common to all CSFs is : ') 3030 FORMAT (/2X,10(3X,A2,1X)) 3040 FORMAT (2X,10(I2,A2,2X)) 3050 FORMAT (/' No core has been defined') 3060 FORMAT (/' No valence orbitals have been defined') 3070 FORMAT (/' CSFs are defined using format : Q'/ ! +' NL(-)'/ ! +' V;J ) X') 3080 FORMAT (/1X,4(6X,A2,10X)) 3090 FORMAT (1X,4(2X,I2,A2,12X)) 3100 FORMAT (1X,4(6X,A2,';',A4,')',A4)) 3110 FORMAT (/' CSF ',I5,' J = ',A4,' odd') 3120 FORMAT (/' CSF ',I5,' J = ',A4,' even') END C C ******************* C SUBROUTINE CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,COEFP) C C======================================================================= C C Section 3 CFP 5 routines C C 1. CFP C 2. CFP3 C 3. CFP5 C 4. CFP7 C 5. CFPD C C======================================================================= C C CFP C | C ------------------- C | | | | C CFP3 CFP5 CFP7 CFPD C C======================================================================= C C These routines have been taken from: C CFPJJ - CPC 4(1972)377 , I.P.Grant - ACRI C C The following changes have been made : C C (1) correction deck has been incorporated C (2) double precision is used C (3) routine CFP has been modified C (4) programs now stops when an error is detected C C======================================================================= C C Selects the appropriate table of fractional parentage coefficients C in JJ-coupling. C C Input variables - C C LOCK - + OR - (2*J + 1) C NEL - number of equivalent electrons in shell. C IJD/IJP - total J of daughter/parent state. C IVD/IVP - seniority of daughter/parent state C IWD/IWP - other quantum number (if needed). C C Output variable - C C COEFP - numerical result C C This control routine does not check the input variables for C consistency, except the trivial case of J = 1/2. All other C checks are performed at a lower level. The package will return C correct results for J = 3/2, 5/2, 7/2. Higher values of J return C a value 1.0 if NEL = 1 OR 2; otherwise 0 with an error signal. C C Subroutines called: CFP3,CFP5,CFP7,CFPD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Argument variables C DOUBLE PRECISION COEFP INTEGER IJD,IJP,IVD,IVP INTEGER IWD,IWP,LOCK,NEL C C Local variables C INTEGER K C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- K = ABS(LOCK)/2 C IF (K.GE.5) GOTO 50 C GOTO (10,20,30,40),K C 10 CONTINUE WRITE (IWRITE,3000) STOP C 20 CONTINUE CALL CFP3(NEL,IJD,IJP,COEFP) RETURN C 30 CONTINUE CALL CFP5(NEL,IJD,IVD,IJP,IVP,COEFP) RETURN C 40 CONTINUE CALL CFP7(NEL,IJD,IVD,IJP,IVP,COEFP) RETURN C 50 CONTINUE CALL CFPD(LOCK,NEL,COEFP) C 3000 FORMAT ( ! +' Unnecessary attempt to form CFP for an electron with J = 1/2. ',! +'There is an ERROR!') END C C ******************* C SUBROUTINE CFP3(NEL,IJD,IJP,COEFP) C C----------------------------------------------------------------------- C C Table look-up for fractional parentage coefficients of equivalent C electrons with J = 3/2. See listing of CFP for argument list. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION SIX PARAMETER (SIX=6.D0) DOUBLE PRECISION FIVE PARAMETER (FIVE=5.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C DOUBLE PRECISION COEFP INTEGER IJD,IJP,NEL C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF ((NEL.LE.0) .OR. (NEL.GT.4)) GOTO 70 C GOTO (10,20,30,50),NEL C 10 CONTINUE IF (IJD.NE.3 .OR. IJP.NE.0) GOTO 70 GOTO 60 C 20 CONTINUE IF (IJP.NE.3) GOTO 70 IF (IJD.EQ.0 .OR. IJD.EQ.4) GOTO 60 GOTO 70 C 30 CONTINUE IF (IJD.NE.3) GOTO 70 IF (IJP.NE.0) GOTO 40 COEFP = SQRT(ONE/SIX) RETURN C 40 CONTINUE IF (IJP.NE.4) GOTO 70 COEFP = -SQRT(FIVE/SIX) RETURN C 50 CONTINUE IF (IJD.NE.0 .OR. IJP.NE.3) GOTO 70 60 CONTINUE COEFP = ONE RETURN C C Fault mode section. C 70 CONTINUE COEFP = ZERO WRITE (IWRITE,3000) NEL,IJD,IJP STOP C 3000 FORMAT (' ERROR in trying to compute CFP for a state with ',I4, ! +' electrons with J = 3/2'/' Parameters ',4I6) END C C ******************* C SUBROUTINE CFP5(NEL,IJD,IVD,IJP,IVP,COEFP) C C----------------------------------------------------------------------- C C Table look-up for fractional parentage coefficients of equivalent C electrons with J = 5/2. See listing of CFP for argument list. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION SEVEN PARAMETER (SEVEN=7.D0) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C DOUBLE PRECISION COEFP INTEGER IJD,IJP,IVD,IVP INTEGER NEL C C Local variables C DOUBLE PRECISION DENOM,DNEL,FACT INTEGER IJ(3,3),IJ1,IJ2,IS INTEGER IV(3,3),IV1,IV2,K INTEGER KD,KP,N,NORM(3) INTEGER NUM3(3,3) C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C 1.0 tables of data C DATA IJ/5,0,5,0,4,3,0,8,9/,IV/1,0,1,8,2,3,8,2,3/,NUM3/-4,0,0,5,-5,! +3,9,2,-11/,NORM/18,7,14/ C----------------------------------------------------------------------- C C 2.0 locate entry in CFP table C IF (NEL.LE.0) GOTO 120 IF (NEL.GE.4) GOTO 10 C N = NEL IJ1 = IJD IV1 = IVD IJ2 = IJP IV2 = IVP GOTO 20 C 10 CONTINUE IF (NEL.GT.6) GOTO 120 N = 7-NEL IJ1 = IJP IV1 = IVP IJ2 = IJD IV2 = IVD C C 2.1 find 'daughter' index C 20 CONTINUE K = 0 30 CONTINUE K = K+1 IF (K.GT.3) GOTO 120 IF (IJ(N,K).NE.IJ1) GOTO 30 IF (IV(N,K).NE.IV1) GOTO 30 KD = K C C 2.2 find 'parent' index C IF (N.NE.1) GOTO 40 IF (IV2.NE.0) GOTO 120 IF (IJ2.EQ.0) GOTO 60 GOTO 120 C 40 CONTINUE K = 0 50 CONTINUE K = K+1 IF (K.GT.3) GOTO 120 IF (IJ(N-1,K).NE.IJ2) GOTO 50 IF (IV(N-1,K).NE.IV2) GOTO 50 KP = K C----------------------------------------------------------------------- C C 3.0 compute coefficients C C 3.1 table look-up C GOTO (60,60,70),N C 60 CONTINUE COEFP = ONE GOTO 100 C 70 CONTINUE COEFP = DBLE(NUM3(KD,KP)) DENOM = DBLE(NORM(KD)) IF (COEFP) 90,110,80 80 CONTINUE COEFP = SQRT(COEFP/DENOM) GOTO 100 C 90 CONTINUE COEFP = -SQRT(-COEFP/DENOM) C C 3.2 insert additional factors for hole states C 100 CONTINUE IF (NEL.LE.3) GOTO 110 DNEL = DBLE(NEL) FACT = ((SEVEN-DNEL)/DNEL)*(ONE+IJP)/(ONE+IJD) COEFP = COEFP*SQRT(FACT) IS = ABS((IJD-IJP-IVD+IVP)/2) IF (MOD(IS,2).EQ.0) GOTO 110 COEFP = -COEFP 110 CONTINUE RETURN C----------------------------------------------------------------------- C C 4.0 fault mode section C 120 CONTINUE COEFP = ZERO WRITE (IWRITE,3000) NEL,IJD,IVD,IJP,IVP STOP C 3000 FORMAT (' ERROR in trying to compute CFP for a state with ',I4, ! +' electrons with J = 5/2'/' Parameters ',4I6) END C C ******************* C SUBROUTINE CFP7(NEL,IJD,IVD,IJP,IVP,COEFP) C C----------------------------------------------------------------------- C Table look-up for fractional parentage coefficients of equivalent C electrons with J = 7/2. See listing of CFP for argument list. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION NINE PARAMETER (NINE=9.D0) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C DOUBLE PRECISION COEFP INTEGER IJD,IJP,IVD,IVP INTEGER NEL C C Local variables C DOUBLE PRECISION DENOM,DNEL,FACT INTEGER IJ(4,8),IJ1,IJ2,IS INTEGER IV(4,8),IV1,IV2,K INTEGER KD,KP,N INTEGER NORM3(6),NORM4(8),NUM3(6,4) INTEGER NUM4(8,6) C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C 1.0 tables of data C DATA IJ/7,0,7,0,0,4,3,4,0,8,5,8,0,12,9,12,0,0,11,4,0,0,15,8,3*0,10! +,3*0,16/ DATA IV/1,0,1,0,10,2,3,2,10,2,3,2,10,2,3,2,10,10,3,4,10,10,3,4,3*1! +0,4,3*10,4/ DATA NUM3/9,5*0,-5,3,121,143,-55,0,-9,-11,12,-900,39,5,-13,0,-65,3! +43,104,-17/ DATA NORM3/36,14,198,1386,198,22/ DATA NUM4/1,280,308,1144,4*0,0,54,-121,0,-968,169,462,0,0,-231,-14! +,195,-77,2366,-343,0,0,-65,250,-245,-1755,90,-945,140,0,-210,91,62! +4,280,2275,650,234,0,0,140,-1224,0,-560,680,627/ DATA NORM4/1,840,924,3432,3080,5460,3080,1001/ C----------------------------------------------------------------------- C C 2.0 locate entry in CFP table C IF (NEL.LE.0) GOTO 140 IF (NEL.GE.5) GOTO 10 C N = NEL IJ1 = IJD IV1 = IVD IJ2 = IJP IV2 = IVP GOTO 20 C 10 CONTINUE IF (NEL.GT.8) GOTO 140 N = 9-NEL IJ1 = IJP IV1 = IVP IJ2 = IJD IV2 = IVD C C 2.1 find 'daughter' index C 20 CONTINUE K = 0 30 CONTINUE K = K+1 IF (K.GT.8) GOTO 140 IF (IJ(N,K).NE.IJ1) GOTO 30 IF (IV(N,K).NE.IV1) GOTO 30 KD = K C C 2.2 find 'parent' index C IF (N.NE.1) GOTO 40 IF (IV2.NE.0) GOTO 140 IF (IJ2.EQ.0) GOTO 60 GOTO 140 C 40 CONTINUE K = 0 50 CONTINUE K = K+1 IF (K.GT.8) GOTO 140 IF (IJ(N-1,K).NE.IJ2) GOTO 50 IF (IV(N-1,K).NE.IV2) GOTO 50 KP = K C----------------------------------------------------------------------- C C 3.0 compute coefficients C C 3.1 table look-up C GOTO (60,60,70,110),N C 60 CONTINUE COEFP = ONE GOTO 120 C 70 CONTINUE COEFP = NUM3(KD,KP) DENOM = NORM3(KD) 80 CONTINUE IF (COEFP) 100,130,90 90 CONTINUE COEFP = SQRT(COEFP/DENOM) GOTO 120 C 100 CONTINUE COEFP = -SQRT(-COEFP/DENOM) GOTO 120 C 110 CONTINUE COEFP = NUM4(KD,KP) DENOM = NORM4(KD) GOTO 80 C C 3.2 insert additional factors for hole states C 120 CONTINUE IF (NEL.LE.4) GOTO 130 DNEL = DBLE(NEL) FACT = ((NINE-DNEL)/DNEL)*(ONE+IJP)/(ONE+IJD) COEFP = COEFP*SQRT(FACT) IS = ABS((IJD-IJP-IVD+IVP)/2-3) IF (MOD(IS,2).EQ.0) GOTO 130 COEFP = -COEFP 130 CONTINUE RETURN C----------------------------------------------------------------------- C C 4.0 fault mode section C 140 CONTINUE COEFP = ZERO WRITE (IWRITE,3000) NEL,IJD,IVD,IJP,IVP STOP C 3000 FORMAT (' ERROR in trying to compute CFP for a state with ',I4, ! +' electrons with J = 7/2'/' Parameters ',4I6) END C C ******************* C SUBROUTINE CFPD(LOCK,NEL,COEFP) C C----------------------------------------------------------------------- C C This is a dummy subroutine. It returns correct values for 1 or 2 C particle or single hole states, and signals an error otherwise. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C DOUBLE PRECISION COEFP INTEGER LOCK,NEL C C Local variables C INTEGER LOCJ C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (NEL.EQ.1) GOTO 10 IF (NEL.EQ.2) GOTO 10 IF (NEL.EQ.ABS(LOCK)) GOTO 10 C COEFP = ZERO LOCJ = ABS(LOCK)-1 WRITE (IWRITE,3000) LOCJ STOP C 10 CONTINUE COEFP = ONE C----------------------------------------------------------------------- 3000 FORMAT ( ! +' Inadmissable attempt to obtain CFP for a state of the shell wi',! +'th J = ',I4,'/2'/' New subprogram required') END C C ******************* C SUBROUTINE CLEBGOR(XJ1,XJ2,XM1,XM2,XJ3,XM3,CG,IER) C----------------------------------------------------------------------- C C C----------------------------------------------------------------------- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IMPLICIT NONE C C PARAMETER VARIABLES C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) INTEGER IFAK PARAMETER (IFAK=500) C C ARGUMENT VARIABLES C DOUBLE PRECISION CG,XJ1,XJ2,XJ3 DOUBLE PRECISION XM1,XM2,XM3 INTEGER IER C C LOCAL VARIABLES C DOUBLE PRECISION AI,BIP1,CONST,SUM DOUBLE PRECISION FAK(IFAK) DOUBLE PRECISION X INTEGER I,IA,IB,IC INTEGER ID,IE,IG,J INTEGER J1,J2,J3,JX INTEGER JY,JZ,KMAX,KMIN INTEGER L,L1,L2,L3 INTEGER M,M1,M2,M3 INTEGER N,N1,N10,N11 INTEGER N2,N3,N4,N5 INTEGER N6,N7,N8 INTEGER K LOGICAL FIRST CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SAVE FAK SAVE FIRST DATA FIRST/.TRUE./ C----------------------------------------------------------------------- C C CALCULATE LOG OF FACTORIALS (0..........500) TO THE BASE E C C----------------------------------------------------------------------- IF (FIRST) THEN FAK(1) = ZERO FAK(2) = ZERO DO K = 3,500 N = K-1 X = N FAK(K) = FAK(N)+LOG(X) ENDDO FIRST = .FALSE. ENDIF C----------------------------------------------------------------------- CG = ZERO IER = 0 C J1 = NINT(TWO*XJ1) J2 = NINT(TWO*XJ2) J3 = NINT(TWO*XJ3) M1 = NINT(TWO*XM1) M2 = NINT(TWO*XM2) M3 = NINT(TWO*XM3) J = (J1+J2+J3)/2 M = (M1+M2-M3)/2 JX = (-J1+J2+J3)/2 JY = (J1-J2+J3)/2 JZ = (J1+J2-J3)/2 C C ********** CHECK OF THE COUPLING RULES ********** C IF ((J1.LT.0) .OR. (J2.LT.0) .OR. (J3.LT.0) .OR. (JX.LT.0) .OR.(JY! +.LT.0) .OR. (JZ.LT.0) .OR. ((J1-ABS(M1)).LT.0) .OR.((J2-ABS(M2)).L! +T.0) .OR. ((J3-ABS(M3)).LT.0) .OR.(MOD(J1,2).NE.MOD(ABS(M1),2)) .O! +R.(MOD(J2,2).NE.MOD(ABS(M2),2)) .OR.(MOD(J3,2).NE.MOD(ABS(M3),2)) ! +.OR.(MOD(J1+J2,2).NE.MOD(J3,2)) .OR. (M.NE.0)) THEN IER = 1 RETURN ENDIF C C ********** CALCULATION OF SPECIAL VALUES ********** C IF ((J1.EQ.0) .OR. (J2.EQ.0)) THEN CG = ONE RETURN ENDIF C IF (J3.EQ.0) THEN CG = ONE/SQRT(TWO*XJ1+ONE) N = (J1-M1)/2 IF (MOD(N,2).EQ.1) CG = -CG RETURN ENDIF C IF ((M1.EQ.0) .AND. (M2.EQ.0)) THEN IF (MOD(J,2).EQ.1) RETURN N10 = J/2 L1 = J1/2 L2 = J2/2 L3 = J3/2 N11 = (L1+L2-L3)/2 CG = (TWO*XJ3+ONE)*EXP(FAK(JX+1)+FAK(JY+1)+FAK(JZ+1)-FAK(J+2)+TW! +O*(FAK(N10+1)-FAK(N10-L1+1)-FAK(N10-L2+1)-FAK(N10-L3+1))) CG = SQRT(CG) IF (MOD(N11,2).EQ.1) CG = -CG RETURN ENDIF C C ********** CALCULATION OF THE GENERAL CASE ********** C N1 = (J1+M1)/2 N2 = (J1-M1)/2 N3 = (J2+M2)/2 N4 = (J2-M2)/2 N5 = (J3+M3)/2 N6 = (J3-M3)/2 N7 = (J2-J3-M1)/2 N8 = (J1-J3+M2)/2 KMIN = MAX(0,N7,N8) KMAX = MIN(JZ,N2,N3) L = KMIN CONST = FAK(N1+1)+FAK(N2+1)+FAK(N3+1)+FAK(N4+1)+FAK(N5+1)+FAK(N6+1! +)+FAK(JX+1)+FAK(JY+1)+FAK(JZ+1)-FAK(J+2)-TWO*(FAK(JZ-L+1)+FAK(N2-L! ++1)+FAK(N3-L+1)+FAK(L-N7+1)+FAK(L-N8+1)+FAK(L+1)) N = KMAX-KMIN+1 I = N-1 SUM = ONE IA = JZ-L IB = N2-L IC = N3-L ID = L+1-N7 IE = L+1-N8 IG = L+1 C 10 CONTINUE AI = (IA-I)*(IB-I)*(IC-I) BIP1 = (ID+I)*(IE+I)*(IG+I) SUM = ONE-AI*SUM/BIP1 I = I-1 IF (I.GE.0) GOTO 10 C CG = SQRT((TWO*XJ3+ONE)*EXP(CONST))*SUM IF (MOD(L,2).EQ.1) CG = -CG C END C C ******************* C FUNCTION CLRX(KAP1,K,KAP2) C C----------------------------------------------------------------------- C C The value of CLRX is the 3-J symbol C C J1 K J2 C 0.5 0 -0.5 C C KAP1 = kappa value for J1 C KAP2 = kappa value for J2 C C Triangular conditions are tested in code. C C SEE : Angular Momentum (second edition) C by Brink and Satchler C Page 138 C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION CLRX C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) C C Argument variables C INTEGER K,KAP1,KAP2 C C Local variables C DOUBLE PRECISION X,Y INTEGER I,IP,IPHASE,IX INTEGER J,JM,JP,JQ INTEGER KMA,KMB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- KMA = ABS(KAP1) KMB = ABS(KAP2) JP = KMA+KMB-1 JM = KMA-KMB X = ONE/(KMA*KMB) C IX = JP-K J = 1 GOTO 90 C 10 CONTINUE IX = JP+K+1 J = 1 GOTO 100 C 20 CONTINUE IX = JM+K J = 2 GOTO 90 C 30 CONTINUE IX = K-JM J = 3 GOTO 90 C 40 CONTINUE Y = SQRT(X) IP = K JQ = JP+K IF (MOD(JQ,2).NE.0) THEN Y = -Y IP = K+1 ENDIF C X = ONE IX = (IP+JP)/2 J = 4 GOTO 90 C 50 CONTINUE IX = (JP-IP)/2 J = 2 GOTO 100 C 60 CONTINUE IX = (JM+IP-1)/2 J = 3 GOTO 100 C 70 CONTINUE IX = (IP-1-JM)/2 J = 4 GOTO 100 C 80 CONTINUE CLRX = Y*X IPHASE = (JP+IP-2)/2 IF (MOD(IPHASE,2).EQ.1) CLRX = -CLRX RETURN C----------------------------------------------------------------------- 90 CONTINUE IF (IX.LT.0) GOTO 110 IF (IX.GT.0) THEN DO I = 1,IX X = X*DBLE(I) ENDDO ENDIF C IF (J.EQ.1) GOTO 10 IF (J.EQ.2) GOTO 30 IF (J.EQ.3) GOTO 40 GOTO 50 C----------------------------------------------------------------------- 100 CONTINUE IF (IX.LT.0) GOTO 110 IF (IX.GT.0) THEN DO I = 1,IX X = X/DBLE(I) ENDDO ENDIF C IF (J.EQ.1) GOTO 20 IF (J.EQ.2) GOTO 60 IF (J.EQ.3) GOTO 70 GOTO 80 C----------------------------------------------------------------------- 110 CONTINUE CLRX = ZERO C END C C ******************* C SUBROUTINE CORD(JA1,IPCA,JB1) C C----------------------------------------------------------------------- C C Computes the MCP coefficients for contributions C involving closed shells. The standard formulae are given in C I.P.Grant. Advances in Physics (1970), vol.19, p.747, eq.(8.33). C C JA1,JB1 point to the JLIST array, C IA1,IB1 point to the full list of orbitals. C C Subroutines called: CLRX, SPEAK, BREID C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL CLRX DOUBLE PRECISION CLRX C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IPCA,JA1,JB1 C C Local variables C DOUBLE PRECISION CONST,GAM,X INTEGER IA1,IB1,ISG,ITYPE INTEGER J1,J2,KAP1,KAP2 INTEGER NQS1,NQS2,NS,NU INTEGER NUMAX,NUMIN C C Common variables C INTEGER IBREIT,ICOUL,IEXCH COMMON / ANG01 / ICOUL,IBREIT,IEXCH C C Common variables C INTEGER IME,JA,JB,NWA COMMON / ANG04 / IME,JA,JB,NWA C C Common variables C INTEGER ICORE(MXNW) COMMON / ANG05 / ICORE C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IBREIT.EQ.1) CALL BREID(JA1,IPCA,JB1) IF (ICOUL.EQ.0) RETURN C----------------------------------------------------------------------- C C Set quantum numbers required. C C----------------------------------------------------------------------- IF (IPCA.EQ.2) THEN IA1 = KLIST(JA1) ELSE IA1 = JLIST(JA1) ENDIF IB1 = KLIST(JB1) IF (IA1.LE.IB1) GOTO 10 NS = IA1 IA1 = IB1 IB1 = NS C 10 CONTINUE ISG = 1 IF (JA.NE.JB) GOTO 20 IF (ICORE(IA1).EQ.0 .OR. ICORE(IB1).EQ.0) GOTO 20 IF (JA.GT.1) RETURN ISG = -1 C 20 CONTINUE KAP1 = NAK(IA1) J1 = ABS(KAP1) NQS1 = NQ1(IA1) C IF (IA1.EQ.IB1) THEN C----------------------------------------------------------------------- C C Case when IA1=IB1 C C----------------------------------------------------------------------- X = DBLE(NQS1*(NQS1-1)/2) ITYPE = ISG*8 CALL SPEAKG(1,ITYPE,IA1,IB1,IA1,IB1,0,X) NUMAX = J1+J1-2 IF (NUMAX.LE.0) RETURN CONST = DBLE(NQS1*NQS1/2) DO NU = 2,NUMAX,2 GAM = CLRX(KAP1,NU,KAP1) X = -CONST*GAM*GAM IF (ABS(X).LT.EPS10) GOTO 30 CALL SPEAKG(1,ITYPE,IA1,IB1,IA1,IB1,NU,X) 30 CONTINUE ENDDO C ELSE C----------------------------------------------------------------------- C C Case when IA1<>IB1 C C----------------------------------------------------------------------- KAP2 = NAK(IB1) J2 = ABS(KAP2) NQS2 = NQ1(IB1) CONST = DBLE(NQS1*NQS2) ITYPE = ISG*8 CALL SPEAKG(1,ITYPE,IA1,IB1,IA1,IB1,0,CONST) NUMIN = ABS(J1-J2) NUMAX = J1+J2-1 IF (KAP1*KAP2.LT.0) NUMIN = NUMIN + 1 ITYPE = ISG*9 DO NU = NUMIN,NUMAX,2 GAM = CLRX(KAP1,NU,KAP2) X = -CONST*GAM*GAM IF (ABS(X).LT.EPS10) GOTO 40 CALL SPEAKG(1,ITYPE,IA1,IB1,IB1,IA1,NU,X) 40 CONTINUE ENDDO ENDIF C----------------------------------------------------------------------- END C C ******************* C SUBROUTINE CORG(JA1,JB1,JA2,JB2) C C----------------------------------------------------------------------- C C Computes the MCP/MCBP coefficients. C C Subroutines called: CRE,GENSUM,ITRIG,LTAB,MODJ23, C MUMDAD,NJSYM,OCON,SETJ,SKRC,SPEAK, C CXK,SNRC C C Equations refer to CPC 5,263(1973) C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL FREE LOGICAL FAILD,FAILE C PARAMETER (MANGM = 60) PARAMETER (MTRIAD=20) PARAMETER (M3MNGM = 3*MANGM) PARAMETER (M6J = 20) COMMON / NJS00 / J6C,J7C,J8C,JWC COMMON / NJS01 / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM), +JW(6,M6J) COMMON / NJS02 / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD) DIMENSION JD6(M3MNGM),JD7(M3MNGM),JD8(M3MNGM), +JDW(6,M6J),J2TSTD(MTRIAD),J3TSTD(MTRIAD) DIMENSION JE6(M3MNGM),JE7(M3MNGM),JE8(M3MNGM), +JEW(6,M6J),J2TSTE(MTRIAD),J3TSTE(MTRIAD) C INCLUDE 'grasp0.inc' PARAMETER (NPLX=14) PARAMETER (IDIM=20) C COMMON / ANG00 / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3), ! + FREE(MANGM) COMMON / ANG01 / ICOUL,IBREIT,IEXCH COMMON / ANG08 / JBQ1(3,MXNW),JBQ2(3,MXNW),JTQ1(3),JTQ2(3) COMMON / ANG11 / NQ1(MXNW),NQ2(MXNW) COMMON / ANG12 / JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG13 / JLIST(NPLX),KLIST(MXNW),NPEEL,NCORE COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 COMMON / INFORM / IREAD,IWRITE,IPUNCH COMMON / ORB04 / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC) COMMON / TERMS / NROWS,ITAB(16),JTAB(16),NTAB(255) C DIMENSION COND(IDIM),CONE(IDIM) DIMENSION BOND(12,IDIM),BONE(12,IDIM),S(12) DIMENSION KAPS(4),KS(4),NQS(4),ILS(4),LLS(4),IROWS(4),IS(4),JS(4) C PARAMETER (EPS10=1.D-10) PARAMETER (ZERO=0.D0) PARAMETER (HALF=.5D0) C----------------------------------------------------------------------- C C Initialize pointers and flags and set any tables required. C C The array IS points to the full list of orbitals, C the array JS to the array, JLIST, of peel orbital pointers. C C Initialization. C C----------------------------------------------------------------------- JS(1) = JA1 JS(2) = JB1 JS(3) = JA2 JS(4) = JB2 C DO I = 1,4 IS(I) = JLIST(JS(I)) KAPS(I) = 2*NAK(IS(I)) KS(I) = ABS(KAPS(I)) ENDDO C IA1 = IS(1) IB1 = IS(2) IA2 = IS(3) IB2 = IS(4) C KJ23 = 0 ISNJ = 0 C FAILD = .FALSE. FAILE = .FALSE. C----------------------------------------------------------------------- C C Initialize arrays. C DO J = 1,NW DO K = 1,3 JBQ1(K,J) = 0 JBQ2(K,J) = 0 ENDDO ENDDO C NBRJ = 3*NPEEL+7 C----------------------------------------------------------------------- C C Set tables of quantum numbers of spectator shells. C DO JJ = 1,NPEEL C J = JLIST(JJ) IF ((J.EQ.IA1) .OR. (J.EQ.IB1)) GOTO 10 DO K = 1,3 JBQ1(K,J) = JJQ1(K,J) ENDDO 10 CONTINUE IF ((J.EQ.IA2) .OR. (J.EQ.IB2)) GOTO 20 DO K = 1,3 JBQ2(K,J) = JJQ2(K,J) ENDDO C C Examine quantum numbers of spectator shells for orthogonality C and exit if found. C IF (J.EQ.IA1 .OR. J.EQ.IB1 .OR. J.EQ.IA2 .OR.J.EQ.IB2) GOTO 20 C DO K = 1,3 IF (JBQ1(K,J).NE.JBQ2(K,J)) THEN IF (IBUG2.EQ.1) WRITE (IWRITE,3000) RETURN ENDIF ENDDO C 20 CONTINUE ENDDO C IF (IBUG2.EQ.1) WRITE (IWRITE,3010) IA1,IB1,IA2,IB2 C----------------------------------------------------------------------- C C Set range of the parameter K for coulomb integrals. C Terminate run if buffer store dimension IDIM is too small. C IF (ICOUL.EQ.1) THEN CALL SKRCG(IS,KAPS,KS,KCD1,KCD2,KCE1,KCE2) IF (IEXCH.EQ.-1) THEN KCD2 = 0 ELSE IF (IEXCH.EQ.1) THEN KCE2 = 0 ENDIF ENDIF ELSE KCD1 = 0 KCD2 = 0 KCE1 = 0 KCE2 = 0 ENDIF C IF (IBUG2.EQ.1) WRITE (IWRITE,3020) KCD1,KCD2,KCE1,KCE2 C IF (KCD2.GT.IDIM .OR. KCE2.GT.IDIM) THEN KK = MAX(KCD2,KCE2) WRITE (IWRITE,3030) KK WRITE (IPUNCH,3030) KK STOP ENDIF C IF (KCD2.GT.0) THEN DO K = 1,KCD2 COND(K) = ZERO ENDDO ENDIF C IF (KCE2.GT.0) THEN DO K = 1,KCE2 CONE(K) = ZERO ENDDO ENDIF C----------------------------------------------------------------------- C C Set range of the parameter K for Breit integrals. C Terminate run if buffer store dimension IDIM is too small. C IF (IBREIT.EQ.1) THEN CALL SNRC(IS,KAPS,KS,KBD1,KBD2,KBE1,KBE2,IBRD,IBRE) ELSE KBD1 = 0 KBD2 = 0 KBE1 = 0 KBE2 = 0 IBRD = -1 IBRE = -1 ENDIF C IF (IBUG2.EQ.1) WRITE (IWRITE,3040) KBD1,KBD2,KBE1,KBE2,IBRD,IBRE C IF (KCD2.EQ.0 .AND. KCE2.EQ.0 .AND. IBRD.LT.0 .AND.IBRE.LT.0) RETU! +RN C IF (KBD2.GT.IDIM .OR. KBE2.GT.IDIM) THEN KK = MAX(KBD2,KBE2) WRITE (IWRITE,3050) KK WRITE (IPUNCH,3050) KK STOP ENDIF C IF (IBRD.GE.0) THEN DO K = 1,KBD2 DO MU = 1,12 BOND(MU,K) = ZERO ENDDO ENDDO ENDIF C IF (IBRE.GE.0) THEN DO K = 1,KBE2 DO MU = 1,12 BONE(MU,K) = ZERO ENDDO ENDDO ENDIF C----------------------------------------------------------------------- NQS(1) = NQ1(IA1) NQS(2) = NQ1(IB1) NQS(3) = NQ2(IA2) NQS(4) = NQ2(IB2) C----------------------------------------------------------------------- C C Set parameters of summation over parent (barred) terms in eq.(5). C The array IROWS is formed to point at the list of allowed C parents of active shells in the array NTAB. C CALL LTAB(IS,NQS,KS,IROWS) C DO I = 1,4 II = IROWS(I) LLS(I) = ITAB(II) ILS(I) = JTAB(II) ENDDO C IF (IBUG2.EQ.1) THEN WRITE (IWRITE,3060) (NQS(I),I=1,4) WRITE (IWRITE,3070) (LLS(I),I=1,4) WRITE (IWRITE,3080) (ILS(I),I=1,4) ENDIF C----------------------------------------------------------------------- C C Sum contributions over all parent terms permitted by angular C momentum and seniority selection rules. C LLS1 = LLS(1) LLS2 = LLS(2) LLS3 = LLS(3) LLS4 = LLS(4) C LS2 = ILS(2) DO LB1 = 1,LLS2 LS2 = LS2+3 IT12 = NTAB(LS2) IT2 = KS(2) IT3 = JJQ1(3,IB1) IF (ITRIG(IT12,IT2,IT3).EQ.0) GOTO 140 IF (ABS(NTAB(LS2-2)-JJQ1(1,IB1)).NE.1) GOTO 140 C LS1 = ILS(1) DO LA1 = 1,LLS1 LS1 = LS1+3 IT11 = NTAB(LS1) IT2 = KS(1) C IF (IA1.EQ.IB1) THEN IT3 = IT12 IF (ITRIG(IT11,IT2,IT3).EQ.0) GOTO 130 IF (ABS(NTAB(LS1-2)-NTAB(LS2-2)).NE.1) GOTO 130 ELSE IT3 = JJQ1(3,IA1) IF (ITRIG(IT11,IT2,IT3).EQ.0) GOTO 130 IF (ABS(NTAB(LS1-2)-JJQ1(1,IA1)).NE.1) GOTO 130 ENDIF C LS4 = ILS(4) DO LB2 = 1,LLS4 LS4 = LS4+3 IT14 = NTAB(LS4) IT2 = KS(4) IT3 = JJQ2(3,IB2) IF (ITRIG(IT14,IT2,IT3).EQ.0) GOTO 120 IF (ABS(NTAB(LS4-2)-JJQ2(1,IB2)).NE.1) GOTO 120 C LS3 = ILS(3) DO LA2 = 1,LLS3 LS3 = LS3+3 IT13 = NTAB(LS3) IT2 = KS(3) C IF (IA2.EQ.IB2) THEN IT3 = IT14 IF (ITRIG(IT13,IT2,IT3).EQ.0) GOTO 110 IF (ABS(NTAB(LS3-2)-NTAB(LS4-2)).NE.1) GOTO 110 ELSE IT3 = JJQ2(3,IA2) IF (ITRIG(IT13,IT2,IT3).EQ.0) GOTO 110 IF (ABS(NTAB(LS3-2)-JJQ2(1,IA2)).NE.1) GOTO 110 ENDIF C IF (IBUG2.EQ.1) WRITE (IWRITE,3090) LS1,LS2,LS3,LS4 C----------------------------------------------------------------------- C C The current parent has been completely defined, and its quantum C numbers can now be set. The JTQ arrays must be set if IA1=IB1 or C IA2=IB2. The matrix element should be diagonal in barred quantum C numbers. C C----------------------------------------------------------------------- DO K = 1,3 C JBQ1(K,IA1) = NTAB(LS1+K-3) JBQ2(K,IA2) = NTAB(LS3+K-3) C JTQ1(K) = 0 C IF (IB1.EQ.IA1) THEN JTQ1(K) = NTAB(LS2+K-3) ELSE JBQ1(K,IB1) = NTAB(LS2+K-3) ENDIF C JTQ2(K) = 0 C IF (IB2.EQ.IA2) THEN JTQ2(K) = NTAB(LS4+K-3) ELSE JBQ2(K,IB2) = NTAB(LS4+K-3) ENDIF C ENDDO C IF (IBUG2.EQ.1) WRITE (IWRITE,3100) (IS(KK),(JBQ1(K,IS(KK)! +),K=1,3), (JBQ2(K,IS(KK)),K=1,3),KK=1,4) C DO K = 1,3 DO KK = 1,4 IF (JBQ1(K,IS(KK)).NE.JBQ2(K,IS(KK))) GOTO 110 ENDDO ENDDO C----------------------------------------------------------------------- C C Evaluate product of 4 CFP'S, eq.(5). C CALL MUMDAD(IS,KAPS,PROD) IF (ABS(PROD).LT.EPS10) GOTO 110 C----------------------------------------------------------------------- C C Set arrays for defining the recoupling coefficient. C CALL SETJ(IS,JS,KS,NPEEL,KJ23) C IF (ISNJ.NE.0) GOTO 40 C----------------------------------------------------------------------- C C Set up arrays and variables for direct case. C C J1(NBRJ) ( = J1(M) ) is set to (2*KCD1+1) so that NJSYM is C called correctly. C IF (KCD2.EQ.0 .AND. IBRD.LT.0) GOTO 30 C IF (KCD2.GT.0) THEN J1(NBRJ) = KCD1+KCD1+1 ELSE J1(NBRJ) = KBD1+KBD1+1 ENDIF C CALL NJSYM (RECUP,-1,FAILD) C ISNJ = 1 IF (FAILD) GOTO 30 C----------------------------------------------------------------------- C C Store data for future calls in direct case. C JD6C=J6C JD7C=J7C JD8C=J8C JDWC=JWC ICNTD=ICOUNT IF (J6C.NE.0) THEN DO I=1,J6C JD6(I)=J6(I) ENDDO ENDIF IF (J7C.NE.0) THEN DO I=1,J7C JD7(I)=J7(I) ENDDO ENDIF IF (J8C.NE.0) THEN DO I=1,J8C JD8(I)=J8(I) ENDDO ENDIF IF (JWC.NE.0) THEN DO I=1,6 DO J=1,JWC JDW(I,J)=JW(I,J) ENDDO ENDDO ENDIF IF (ICOUNT.NE.0) THEN DO I=1,ICOUNT J2TSTD(I)=J2TEST(I) J3TSTD(I)=J3TEST(I) ENDDO ENDIF C----------------------------------------------------------------------- C C Set up arrays and variables for exchange case. C C J1(NBRJ) ( = J1(M) ) is set to (2*KCE1+1) so that NJSYM is C called correctly. C 30 CONTINUE IF (KCE2.EQ.0 .AND. IBRE.LT.0) GOTO 40 C CALL MODJ23 C IF (KCE2.GT.0) THEN J1(NBRJ) = KCE1+KCE1+1 ELSE J1(NBRJ) = KBE1+KBE1+1 ENDIF C CALL NJSYM (RECUP,-1,FAILE) C ISNJ = 2 C IF (FAILE) GOTO 40 C----------------------------------------------------------------------- C C Store data for future calls in exchange case. C JE6C=J6C JE7C=J7C JE8C=J8C JEWC=JWC ICNTE=ICOUNT IF (J6C.NE.0) THEN DO I=1,J6C JE6(I)=J6(I) ENDDO ENDIF IF (J7C.NE.0) THEN DO I=1,J7C JE7(I)=J7(I) ENDDO ENDIF IF (J8C.NE.0) THEN DO I=1,J8C JE8(I)=J8(I) ENDDO ENDIF IF (JWC.NE.0) THEN DO I=1,6 DO J=1,JWC JEW(I,J)=JW(I,J) ENDDO ENDDO ENDIF IF (ICOUNT.NE.0) THEN DO I=1,ICOUNT J2TSTE(I)=J2TEST(I) J3TSTE(I)=J3TEST(I) ENDDO ENDIF C----------------------------------------------------------------------- C C COULOMB C Calculate recoupling coefficients for direct cases. C Calculate AD, eq.(6), without the phase factor C C----------------------------------------------------------------------- 40 CONTINUE IF ((KCD2.NE.0) .AND. (.NOT.FAILD)) THEN KK = KCD1-2 DO K = 1,KCD2 KK = KK+2 J1(MMOM) = KK+KK+1 CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW, + ICNTD,J2TSTD,J3TSTD,X) IF (IBUG2.EQ.1) WRITE (IWRITE,3110) KK,X COND(K) = COND(K)+X*PROD ENDDO ENDIF C----------------------------------------------------------------------- C C COULOMB C Calculate recoupling coefficients for exchange cases. C Calculate AE, eq.(6), without the phase factor C C----------------------------------------------------------------------- IF ((KCE2.NE.0) .AND. (.NOT.FAILE)) THEN KK = KCE1-2 DO K = 1,KCE2 KK = KK+2 J1(MMOM) = KK+KK+1 CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW, + ICNTE,J2TSTE,J3TSTE,X) IF (IBUG2.EQ.1) WRITE (IWRITE,3120) KK,X CONE(K) = CONE(K)+X*PROD ENDDO ENDIF C----------------------------------------------------------------------- C C BREIT C Calculate recoupling coefficients for direct cases. C C----------------------------------------------------------------------- IF ((IBRD.GE.0) .AND. (.NOT.FAILD)) THEN C IF (IBRD.GT.1) THEN IMUD = 1 ELSE IMUD = 4 ENDIF C NCODE = 0 C====================================================== DO NN = 1,KBD2 C NU = KBD1+2*(NN-1) NUD = NU+NU+1 C IF (NU.EQ.0) GOTO 60 C IF (ITRIG(KS(1),KS(3),NUD).EQ.0) GOTO 50 IF (ITRIG(KS(2),KS(4),NUD).EQ.0) GOTO 50 K = NU J1(MMOM) = NUD C CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW, + ICNTD,J2TSTD,J3TSTD,X) C IF (IBUG2.EQ.1) WRITE (IWRITE,3130) NU,K,X C IF (ABS(X).GE.EPS10) THEN X = X*PROD CALL CXK(S,IS,KAPS,NU,K,IBRD,1) IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM! +UD) DO MU = 1,IMUD BOND(MU,NN) = BOND(MU,NN)+X*S(MU) ENDDO ENDIF C++++++++++++++++++++++++++++++++++++++++++++++++++ 50 CONTINUE IF (IBRD.GT.1) GOTO 70 K = NU-1 C IF (NCODE.EQ.NN) THEN X = XCODE ELSE ITKMO = NUD-2 IF (ITRIG(KS(1),KS(3),ITKMO).EQ.0) GOTO 60 IF (ITRIG(KS(2),KS(4),ITKMO).EQ.0) GOTO 60 J1(MMOM) = ITKMO CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW, + ICNTD,J2TSTD,J3TSTD,X) ENDIF C IF (IBUG2.EQ.1) WRITE (IWRITE,3130) NU,K,X C IF (ABS(X).GE.EPS10) THEN X = X*PROD CALL CXK(S,IS,KAPS,NU,K,IBRD,1) IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,4) DO MU = 1,4 BOND(MU,NN) = BOND(MU,NN)+X*S(MU) ENDDO ENDIF C++++++++++++++++++++++++++++++++++++++++++++++++++ 60 CONTINUE IF (IBRD.GT.1 .OR. NN.EQ.KBD2) GOTO 70 NCODE = NN+1 XCODE = ZERO C ITKMO = NUD+2 IF (ITRIG(KS(1),KS(3),ITKMO).EQ.0) GOTO 70 IF (ITRIG(KS(2),KS(4),ITKMO).EQ.0) GOTO 70 K = NU+1 J1(MMOM) = ITKMO C CALL GENSUM (JD6C,JD7C,JD8C,JDWC,JD6,JD7,JD8,JDW, + ICNTD,J2TSTD,J3TSTD,X) XCODE = X C IF (IBUG2.EQ.1) WRITE (IWRITE,3130) NU,K,X C IF (ABS(X).GE.EPS10) THEN X = X*PROD CALL CXK(S,IS,KAPS,NU,K,IBRD,1) IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,12! +) DO MU = 1,12 BOND(MU,NN) = BOND(MU,NN)+X*S(MU) ENDDO ENDIF C++++++++++++++++++++++++++++++++++++++++++++++++++ 70 CONTINUE ENDDO C ENDIF C----------------------------------------------------------------------- C C BREIT C Calculate recoupling coefficients for exchange cases. C C----------------------------------------------------------------------- IF ((IBRE.GE.0) .AND. (.NOT.FAILE)) THEN NCODE = 0 C DO NN = 1,KBE2 IMUE = 4 IF (IBRE.EQ.2) IMUE = 1 IF (IBRE.EQ.4) IMUE = 3 C NU = KBE1+2*(NN-1) NUD = NU+NU+1 C IF (NU.EQ.0) GOTO 90 C IF (ITRIG(KS(1),KS(4),NUD).EQ.0) GOTO 80 IF (ITRIG(KS(2),KS(3),NUD).EQ.0) GOTO 80 K = NU J1(MMOM) = NUD C CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW, + ICNTE,J2TSTE,J3TSTE,X) C IF (IBUG2.EQ.1) WRITE (IWRITE,3150) NU,K,X C IF (ABS(X).GE.EPS10) THEN X = X*PROD CALL CXK(S,IS,KAPS,NU,K,IBRE,2) IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM! +UE) DO MU = 1,IMUE BONE(MU,NN) = BONE(MU,NN)+X*S(MU) ENDDO ENDIF C++++++++++++++++++++++++++++++++++++++++++++++++++ 80 CONTINUE IF (IBRE.EQ.2) GOTO 100 C IMUE = 4 IF (IBRE.EQ.4) IMUE = 3 K = NU-1 C IF (NCODE.EQ.NN) THEN X = XCODE ELSE ITKMO = NUD-2 IF (ITRIG(KS(1),KS(4),ITKMO).EQ.0) GOTO 90 IF (ITRIG(KS(2),KS(3),ITKMO).EQ.0) GOTO 90 J1(MMOM) = ITKMO CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW, + ICNTE,J2TSTE,J3TSTE,X) ENDIF C IF (IBUG2.EQ.1) WRITE (IWRITE,3150) NU,K,X C IF (ABS(X).GE.EPS10) THEN X = X*PROD CALL CXK(S,IS,KAPS,NU,K,IBRE,2) IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM! +UE) DO MU = 1,IMUE BONE(MU,NN) = BONE(MU,NN)+X*S(MU) ENDDO ENDIF C++++++++++++++++++++++++++++++++++++++++++++++++++ 90 CONTINUE IF (IBRE.EQ.2 .OR. NN.EQ.KBE2) GOTO 100 C NCODE = NN+1 XCODE = ZERO C IMUE = 12 IF (IBRE.EQ.4) IMUE = 7 C ITKMO = NUD+2 IF (ITRIG(KS(1),KS(4),ITKMO).EQ.0) GOTO 100 IF (ITRIG(KS(2),KS(3),ITKMO).EQ.0) GOTO 100 K = NU+1 J1(MMOM) = ITKMO C CALL GENSUM (JE6C,JE7C,JE8C,JEWC,JE6,JE7,JE8,JEW, + ICNTE,J2TSTE,J3TSTE,X) C XCODE = X C IF (IBUG2.EQ.1) WRITE (IWRITE,3150) NU,K,X C IF (ABS(X).GE.EPS10) THEN X = X*PROD CALL CXK(S,IS,KAPS,NU,K,IBRE,2) IF (IBUG2.EQ.1) WRITE (IWRITE,3140) (S(III),III=1,IM! +UE) DO MU = 1,IMUE BONE(MU,NN) = BONE(MU,NN)+X*S(MU) ENDDO ENDIF C++++++++++++++++++++++++++++++++++++++++++++++++++ 100 CONTINUE ENDDO C ENDIF C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF (FAILD .AND. FAILE) GOTO 150 C----------------------------------------------------------------------- 110 CONTINUE ENDDO 120 CONTINUE ENDDO 130 CONTINUE ENDDO 140 CONTINUE ENDDO C----------------------------------------------------------------------- C C Insert factors independent of barred quantum numbers. C Output results. C C Begin with common statistical factors, eq.(5). C C----------------------------------------------------------------------- 150 CONTINUE CONST = OCON(IA1,IB1,IA2,IB2) C IF (IBUG2.EQ.1) WRITE (IWRITE,3160) CONST C KAP1 = NAK(IA1) KAP2 = NAK(IB1) KAP3 = NAK(IA2) KAP4 = NAK(IB2) C----------------------------------------------------------------------- C C Compute products of reduced matrix elements,eq.(7). C C CRED for direct terms C CREE for exchange terms C C----------------------------------------------------------------------- IF (KCD2.GT.0) THEN PRODD = CONST/SQRT(DBLE(KS(1)*KS(4))) IF (MOD(KCD1,2).NE.0) PRODD = -PRODD IF (IA1.EQ.IB1 .AND. IA2.EQ.IB2) PRODD = PRODD*HALF KK = KCD1-2 DO K = 1,KCD2 KK = KK+2 CRED = CRE(KAP1,KK,KAP3)*CRE(KAP2,KK,KAP4) X = PRODD*COND(K)*CRED IF (ABS(X).GT.EPS10) CALL SPEAKG(0,8,IA1,IB1,IA2,IB2,KK,X) ENDDO ENDIF C IF (KCE2.GT.0) THEN PRODE = CONST/SQRT(DBLE(KS(1)*KS(3))) IF (MOD(KCE1,2).NE.0) PRODE = -PRODE PRODE = -PRODE KK = KCE1-2 DO K = 1,KCE2 KK = KK+2 CREE = CRE(KAP1,KK,KAP4)*CRE(KAP2,KK,KAP3) X = PRODE*CONE(K)*CREE IF (ABS(X).GT.EPS10) CALL SPEAKG(0,9,IA1,IB1,IB2,IA2,KK,X) ENDDO ENDIF C----------------------------------------------------------------------- IF (IBRD.GE.0) THEN C PRODD = CONST/SQRT(DBLE(KS(1)*KS(4))) IF (IA1.EQ.IB1 .AND. IA2.EQ.IB2) PRODD = PRODD*HALF DO NN = 1,KBD2 DO MU = 1,12 BOND(MU,NN) = BOND(MU,NN)*PRODD ENDDO ENDDO C====================================================== DO NN = 1,KBD2 C NU = KBD1+2*(NN-1) C IF (IBRD.EQ.2) THEN ITYPE = 3 CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NU,BOND(1,NN)) GOTO 160 ENDIF C IF (IBRD.EQ.3) THEN ITYPE = 4 CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NU,BOND(1,NN)) GOTO 160 ENDIF C ITYPE = 1 CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NU,BOND(1,NN)) CALL SPEAKG(0,ITYPE,IA2,IA1,IB2,IB1,NU,BOND(2,NN)) CALL SPEAKG(0,ITYPE,IA1,IA2,IB2,IB1,NU,BOND(3,NN)) CALL SPEAKG(0,ITYPE,IA2,IA1,IB1,IB2,NU,BOND(4,NN)) C IF (NN.NE.KBD2) THEN NUP1 = NU+1 ITYPE = 2 CALL SPEAKG(0,ITYPE,IA1,IA2,IB1,IB2,NUP1,BOND(5,NN)) CALL SPEAKG(0,ITYPE,IB1,IB2,IA1,IA2,NUP1,BOND(6,NN)) CALL SPEAKG(0,ITYPE,IA2,IA1,IB2,IB1,NUP1,BOND(7,NN)) CALL SPEAKG(0,ITYPE,IB2,IB1,IA2,IA1,NUP1,BOND(8,NN)) CALL SPEAKG(0,ITYPE,IA1,IA2,IB2,IB1,NUP1,BOND(9,NN)) CALL SPEAKG(0,ITYPE,IB2,IB1,IA1,IA2,NUP1,BOND(10,NN)) CALL SPEAKG(0,ITYPE,IA2,IA1,IB1,IB2,NUP1,BOND(11,NN)) CALL SPEAKG(0,ITYPE,IB1,IB2,IA2,IA1,NUP1,BOND(12,NN)) ENDIF C 160 CONTINUE ENDDO C ENDIF C----------------------------------------------------------------------- IF (IBRE.GE.0) THEN C PRODE = CONST/SQRT(DBLE(KS(1)*KS(3))) PRODE = -PRODE DO NN = 1,KBE2 DO MU = 1,12 BONE(MU,NN) = BONE(MU,NN)*PRODE ENDDO ENDDO C====================================================== DO NN = 1,KBE2 C NU = KBE1+2*(NN-1) C IF (IBRE.EQ.4) THEN ITYPE = 5 CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NU,BONE(1,NN)) CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NU,BONE(2,NN)) CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NU,BONE(3,NN)) IF (NN.NE.KBE2) THEN NUP1 = NU+1 ITYPE = 6 CALL SPEAKG(0,ITYPE,IA1,IB1,IA1,IB1,NUP1,BONE(4,NN)) CALL SPEAKG(0,ITYPE,IB1,IA1,IB1,IA1,NUP1,BONE(5,NN)) CALL SPEAKG(0,ITYPE,IA1,IB1,IB1,IA1,NUP1,BONE(6,NN)) CALL SPEAKG(0,ITYPE,IB1,IA1,IA1,IB1,NUP1,BONE(7,NN)) ENDIF GOTO 170 ENDIF C IF (IBRE.EQ.2) THEN ITYPE = 3 CALL SPEAKG(0,ITYPE,IA1,IB2,IB1,IA2,NU,BONE(1,NN)) GOTO 170 ENDIF C ITYPE = 1 CALL SPEAKG(0,ITYPE,IA1,IB2,IB1,IA2,NU,BONE(1,NN)) CALL SPEAKG(0,ITYPE,IB2,IA1,IA2,IB1,NU,BONE(2,NN)) CALL SPEAKG(0,ITYPE,IA1,IB2,IA2,IB1,NU,BONE(3,NN)) CALL SPEAKG(0,ITYPE,IB2,IA1,IB1,IA2,NU,BONE(4,NN)) C IF (NN.NE.KBE2) THEN NUP1 = NU+1 ITYPE = 2 CALL SPEAKG(0,ITYPE,IA1,IB2,IB1,IA2,NUP1,BONE(5,NN)) CALL SPEAKG(0,ITYPE,IB1,IA2,IA1,IB2,NUP1,BONE(6,NN)) CALL SPEAKG(0,ITYPE,IB2,IA1,IA2,IB1,NUP1,BONE(7,NN)) CALL SPEAKG(0,ITYPE,IA2,IB1,IB2,IA1,NUP1,BONE(8,NN)) CALL SPEAKG(0,ITYPE,IA1,IB2,IA2,IB1,NUP1,BONE(9,NN)) CALL SPEAKG(0,ITYPE,IA2,IB1,IA1,IB2,NUP1,BONE(10,NN)) CALL SPEAKG(0,ITYPE,IB2,IA1,IB1,IA2,NUP1,BONE(11,NN)) CALL SPEAKG(0,ITYPE,IB1,IA2,IB2,IA1,NUP1,BONE(12,NN)) ENDIF C 170 CONTINUE ENDDO C ENDIF C----------------------------------------------------------------------- 3000 FORMAT ( ! +' spectator quantum numbers not diagonal for non-interacting she',! +'lls') 3010 FORMAT (' COR called : orbitals = ',4I5) 3020 FORMAT (' COR called : KCD1,KCD2,KCE1,KCE2 = ',4I5) 3030 FORMAT (/' STOPPING in routine COR'/ ! +' recompile and increase dimension of arrays COND,CONE to at lea',! +'st ',I5/' i.e. increase parameter IDIM to this value') 3040 FORMAT (' COR called : KBD1,KBD2,KBE1,KBE2,IBRD,IBRE = ',6I5) 3050 FORMAT (/' STOPPING in routine COR'/ ! +' recompile and increase dimension of arrays BOND,BONE to at lea',! +'st ',I5/' i.e. increase parameter IDIM to this value') 3060 FORMAT (' COR called : NQS = ',4I5) 3070 FORMAT (' COR called : LLS = ',4I5) 3080 FORMAT (' COR called : ILS = ',4I5) 3090 FORMAT (' COR called : LS1,LS2,LS3,LS4 = ',4I5) 3100 FORMAT (' COR called : IS = ',I5/ ! +' COR called : JBQ1 = ',3I5/ ! +' COR called : JBQ2 = ',3I5) 3110 FORMAT (' direct K recoupling coef ',I5,2X,1P,E20.9) 3120 FORMAT (' exchange K recoupling coef ',I5,2X,1P,E20.9) 3130 FORMAT (' direct NU K recoupling coef ',2I5,2X,1P,E20.9) 3140 FORMAT (' S = ',1P,4E12.4) 3150 FORMAT (' exchange NU K recoupling coef ',2I5,2X,1P,E20.9) 3160 FORMAT (' COR called : statistical factor = ',1P,E20.9/) END C C ******************* C SUBROUTINE COULG(NLAST,J) C C----------------------------------------------------------------------- C C This subroutine tabulates relativistic wave functions for a Coulomb C potential, calculated from the analytic formula. C The expressions used are given in, for example, C Burke and Grant, Proc. Phys. Soc. (London), 90,297(1967) c c Extended to generate L-spinors - nrb 09/01/08 c Energy norm correct to all orders - nrb 30/01/08 c c lspin=.true. for L-spinors, flagged by scr.lt.-0.1 c then lambda=-scr and scr is reset to ne-1 where ne is the no. of c electrons, so that the effective charge is the asymptotic charge c seen by one of the target electrons. c lambda=1 is the normal choice for L-spinors c.f. the non-relativ. c problem. c c lspin=.false. for Coulomb, flagged by scr.ge.-0.1 c then lambda=tlam=2/cpn recovers the Coulomb case. c c Note, Grant's lambda=tlamg=tlam*zj/2, in both cases, c and so we redefine: zj=zj*cpn*tlam/two c C C DATA C ---- C NLAST index of last element used in PF and QF C J serial number of function to be computed C C RESULTS C ------- C PF,QF the wave functions are tabulated in these common arrays C C C Subroutine called: GAMF C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL GAMF,rint DOUBLE PRECISION GAMF,rint C C Parameter variables C INTEGER N11 PARAMETER (N11=MXNP+10) c double precision eps4 parameter (eps4=1.d-4) C C Argument variables C INTEGER J,NLAST C C Local variables C DOUBLE PRECISION AZ,COP,COQ,CPN DOUBLE PRECISION CRM,FK,FNJ,FNR DOUBLE PRECISION GA,GAM,SCR,WA DOUBLE PRECISION WAM,WB,WC,WD DOUBLE PRECISION WE,WP,WQ,WX DOUBLE PRECISION ZJ INTEGER I,IJ,K,NADD INTEGER NGRID,NPOINT,NR,nx c double precision tlam,tlamg,ee integer ne,ifirst C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C integer icut(mxnw) common /nrbcut/icut C C Common variables C double precision fx integer istatx,npmin0 common /nrbinf/fx,istatx,npmin0 C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION CXP(MXNW) COMMON / ORB03 / CXP C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF C C Common variables C logical lspin common /nrb000/lspin Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc data ifirst/0/ C----------------------------------------------------------------------- c SCR = CXP(J) c if(scr.lt.-tenth)then lspin=.true. if(ifirst.eq.0)write(iwrite,3010) ifirst=1 tlam=-scr ne=0 do i=1,nw ne=ne+iq(i,1) enddo scr=ne-1 else lspin=.false. !re-initialize for l>0 endif C C compute normalising factor C ZJ = Z-SCR AZ = ZJ/C COQ = AZ*AZ K = NAK(J) FK = K FNJ = NP(J) NR = NP(J)-ABS(K) FNR = DBLE(NR) GA = SQRT(FK*FK-COQ) GAM = GA+GA+ONE COP = FNR+GA CPN = SQRT(COP*COP+COQ) c c set-up for L-spinors or Coulomb c if(lspin)then zj=zj*cpn*tlam/two AZ = ZJ/C c CXP(J)=z-zj !write(*,*)'SCREEN',j,cxp(j) endif c tlamg=zj/cpn !Grant's lambda tlamg=tlamg/c !c-scaled c c slight modification to energy factor required for L-spinors c (covers Coulomb case as well, albeit slightly more lengthily) c if(lspin)then wp=one+cop/cpn !1+E(coul)/c**2 wp=wp/tlamg wp=wp*wp wq=two/(one+wp) wq=sqrt(wq) wp=one/wp wp=two/(one+wp) wp=sqrt(wp) else WP = SQRT(ONE+COP/CPN) WQ = AZ/(CPN*WP) endif c c this imposes unit norm on p and q individually (no energy factor) c c wp=sqrt(two) c wq=wp c c this imposes overall unit norm on p and q combined (no energy factor) c c wp=one c wq=wp C WA = ONE WB = ZJ*GAMF(GAM+FNR)/(TWO*(CPN-FK)) I = NR 10 CONTINUE IF (I.GT.0) THEN WB = WB/WA WA = WA+ONE I = I-1 GOTO 10 ENDIF C CRM = SIGN(SQRT(WB),-FK) CRM = CRM/(CPN*GAMF(GAM)) WP = WP*CRM WQ = -WQ*CRM C C Compute eigenvalue. This covers both cases: Coulomb and L-spinors. C Both were subject to cancellation in non-rel limit, i.e. c->c*1e6, C but this e-value was/is not used to determine H, of course. c ee=sqrt(one-tlamg*tlamg) tlamg=tlamg*c e(j)=-tlamg*tlamg/(one+ee) C C compute coefficients in hypergeometric functions in TA and TB. C TA(1) = ZERO TA(2) = ZERO TB(1) = ZERO TB(2) = ZERO C IF (NR.GT.0) THEN TA(1) = FNR WA = ONE-FNR WB = GAM WC = ONE I = 2 20 CONTINUE IF (I.LT.NR+1) THEN TA(I) = TA(I-1)*WA/(WB*WC) WA = WA+ONE WB = WB+ONE WC = WC+ONE I = I+1 GOTO 20 ENDIF ENDIF C TB(1) = CPN-FK WA = -FNR WB = GAM WC = ONE I = 2 30 CONTINUE IF (I.LT.NR+2) THEN TB(I) = TB(I-1)*WA/(WB*WC) WA = WA+ONE WB = WB+ONE WC = WC+ONE I = I+1 GOTO 30 ENDIF C C tabulate wave functions C WX = TWO*ZJ/CPN WA = RNT*WX WAM = TWO*FNJ*FNJ*WX/ZJ !Outer turning point C C evaluate hypergeometric functions and form wave functions C C================================================== DO I = 1,N C WC = ZERO IF (NR.GT.0) THEN IJ = NR 40 CONTINUE WC = WC*WA+TA(IJ) IJ = IJ-1 IF (IJ.GT.0) GOTO 40 ENDIF C WD = ZERO IJ = NR+1 50 CONTINUE WD = WD*WA+TB(IJ) IJ = IJ-1 IF (IJ.GT.0) GOTO 50 C WE = WA**GA*EXP(-WA*HALF) C Q(I) = WE*(WC+WD)*WQ P(I) = WE*(WD-WC)*WP C WA = WA*EPH C IF (WA.GT.WAM) THEN IF (ABS(P(I)).LE.CUTOFF) GOTO 60 ENDIF C ENDDO C================================================== NGRID = N if(lspin.or.np(j).ge.npmin0)icut(j)=n write(*,3001)J write(iwrite,3001)j GOTO 70 C 60 CONTINUE NPOINT = I c c add buffer space for subsequent formation of new basis in rritz; c extend it radially by a factor fx. c if(lspin.or.np(j).ge.npmin0)then icut(j)=npoint !store real end nx=log(fx)/h nx=nx+mod(nx,2) else nx=0 endif C IF (NPOINT.LT.N) THEN IF (MOD(NPOINT,2).EQ.1) THEN NADD = 8 ELSE NADD = 7 ENDIF c nadd=nadd+nx c IF (NPOINT+NADD.GT.N) NADD = N - NPOINT DO I = NPOINT+1,NPOINT+NADD P(I) = ZERO Q(I) = ZERO ENDDO NGRID = NPOINT+NADD ELSE NGRID = NPOINT ENDIF C 70 CONTINUE IF (NLAST+NGRID.GT.MXNG) THEN WRITE (IWRITE,3000) NLAST + NGRID,MXNG WRITE (IPUNCH,3000) NLAST + NGRID,MXNG STOP ENDIF cc c ij=ngrid-1 c write(72,*)j,ngrid,h,rnt*exp(h*ij),cutoff c do i=1,ngrid,10 c ij=i-1 c write(72,*)i,rnt*exp(h*ij),p(i) c enddo C IJ = NLAST+1 DO I = 1,NGRID PF(IJ) = P(I) QF(IJ) = Q(I) IJ = IJ+1 ENDDO C MPOS(J) = NLAST+1 MPOIN(J) = NGRID NLAST = NLAST+NGRID C WB = WX**GA PZ(J) = WB*WP*(TB(1)-TA(1)) QZ(J) = WB*WQ*(TA(1)+TB(1)) c c check normalizations, P**2+Q**2 and Q(0)/P(0), for L-spinors (only) c as only they should be being formed at high-n. Starts to break-down c above n=30, as can be seen by examining the norm. c if(lspin)then c write(*,*)'*** Q(0)/P(0) = ',j,qz(j)/pz(j),q(1)/p(1),az/(fk-ga) c x,(fk+ga)/az*(cpn*tlam/two)**2 wx=rint(j,j,0) if(abs(wx-one).gt.tenth)then write(iwrite,3002) write(iwrite,*)'COULG: **** NORM **** =',np(j),k,wx stop ' FAILURE in COULG...' endif if(abs(wx-one).gt.eps4) x write(*,*)'COULG: **** NORM **** =',np(j),k,wx wx=one/sqrt(wx) ij = mpos(j) do i = 1,ngrid pf(ij) = pf(ij)*wx qf(ij) = qf(ij)*wx ij = ij+1 enddo endif C 3000 FORMAT (/' ERROR in COULG: dimension ... STOPPING'/ ! +' You must increase MXNG to at least ',I9, ! +' from the present value of ',I9/) 3001 FORMAT ('***SR.COULG: WAVEFUNCTION TRUNCATED AT RMAX!!! - J=',I4) 3002 FORMAT (/' FAILURE in COULG: L-spinor normalization deviating' x,'from unity - too high in n?') 3010 FORMAT (/' >>>> routine COULG called : form initial L-spinor basis x'/) END C C ******************* C SUBROUTINE COUMAT(ICOUL,IO4) C C----------------------------------------------------------------------- C C This routine controls the calculation of the Coulomb matrix. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C INTEGER ICOUL,IO4 C C Local variables C DOUBLE PRECISION AM,AMAX,EAU,ERY DOUBLE PRECISION WA INTEGER I,IA,IJ,IP INTEGER J C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3010) PRINT 3010 C C Evaluate the Coulomb matrix C IF (ICOUL.EQ.1) CALL COUMT1(IO4) C IF ((KTC(1)+KTC(2)+KTC(3)).GT.0) WRITE (IWRITE,3000) C----------------------------------------------------------------------- C C Print Coulomb matrix if option 1 is set. C IF (ICOUL.EQ.1 .AND. KTC(1).EQ.1) CALL MATOUT(IWRITE,COUVEC,NCF,NC! +F,MXNC,MXNC,1) C----------------------------------------------------------------------- C C Diagonalise the Coulomb matrix C IF (ICOUL.EQ.1) CALL COUMT2 C----------------------------------------------------------------------- C C Eigenvector elements less than 1e-10 are set to zero. C Set up the array LEV where LEV(J) identifies the dominant CSF for C level J. C The largest mixing coefficient for each CSF is made positive C DO J = 1,NCF IA = 0 AMAX = ZERO DO I = 1,NCF WA = ABS(COUVEC(I,J)) IF (WA.LT.EPS10) COUVEC(I,J) = ZERO IF (WA.GT.AMAX) THEN AMAX = WA IA = I ENDIF ENDDO LEV(J) = IA IF (COUVEC(IA,J).LT.ZERO) THEN DO I = 1,NCF COUVEC(I,J) = -COUVEC(I,J) ENDDO ENDIF ENDDO C----------------------------------------------------------------------- C C Print Coulomb energies if option 2 is set. C IF (KTC(2).EQ.1) THEN WRITE (IWRITE,3020) DO J = 1,NCPRIN EAU = COUENG(J) IF (J.GT.1) EAU = EAU - COUENG(1) ERY = EAU+EAU I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) C IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3060) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3050) J,IJ,I,AM,EAU,ERY ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3040) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3030) J,IJ,I,AM,EAU,ERY ENDIF ENDIF C ENDDO ENDIF C----------------------------------------------------------------------- C C Print Coulomb vectors if option 3 is set. C IF (KTC(3).EQ.1) CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3) C----------------------------------------------------------------------- 3000 FORMAT (/20X,' *****************************************'/20X, ! +' * Coulomb matrix *'/20X, ! +' *****************************************') 3010 FORMAT (/' >>>> routine COUMAT called') 3020 FORMAT (/' Coulomb dominant'/ ! +' level J parity CSF mix a.u. Ryd.'! +/) 3030 FORMAT (1X,I4,2X,I4,'/2 odd ',I4,2X,F5.3,3X,1P,2E20.8) 3040 FORMAT (1X,I4,2X,I4,'/2 even ',I4,2X,F5.3,3X,1P,2E20.8) 3050 FORMAT (1X,I4,2X,I4,' odd ',I4,2X,F5.3,3X,1P,2E20.8) 3060 FORMAT (1X,I4,2X,I4,' even ',I4,2X,F5.3,3X,1P,2E20.8) END C C ******************* C SUBROUTINE COUMT1(IO4) C C----------------------------------------------------------------------- C C Routine for evaluating the Coulomb matrix. C C IO4 - stream for MCP coefficients. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL RINTI,SLATER DOUBLE PRECISION RINTI,SLATER C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C INTEGER IO4 C C Local variables C CHARACTER IBL,ILAB,IST DOUBLE PRECISION COEF,CONTR,ELMNT,ELSTO DOUBLE PRECISION XINT,XLAB INTEGER I,IA,IB,IC INTEGER ID,ISTOR,ISTORE,ITYP INTEGER ITYPE,JA,JAP,JB INTEGER JBP,K,NCFP,NSTART INTEGER NUM,NUMEL,NUMINT,NUMSTO INTEGER NUMTOT,NUMX,NWA,NWP C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA IBL,IST/' ','S'/ C----------------------------------------------------------------------- NSTART = MPOIN(NW)+MPOS(NW)-1 NUMX = MXNG-NSTART C NUMINT = 0 NUMSTO = 0 NUMTOT = 0 NUMEL = 0 C ELSTO = ZERO C----------------------------------------------------------------------- C C Position stream IO4 which reads in MCP coefficients. C REWIND IO4 READ (IO4) READ (IO4) NCFP,NWP NWA = NWP+1 DO I = 1,7 READ (IO4) ENDDO C----------------------------------------------------------------------- DO JA = 1,NCF DO JB = JA,NCF C C Read coefficients for configuration pair JA,JB. C ELMNT = ZERO READ (IO4) JAP,JBP NUM = 0 C C Coefficients stored as : ISTORE,ITYP,COEF C Need to decode ISTORE. C 10 CONTINUE READ (IO4) ISTORE,ITYP,COEF IF (ISTORE.EQ.0) GOTO 30 ISTORE = ABS(ISTORE) ITYPE = ABS(ITYP) IF (ITYPE.LT.7) GOTO 10 C IF (ITYPE.EQ.8 .OR. ITYPE.EQ.9) THEN ISTOR = ISTORE ID = MOD(ISTOR,NWA) ISTOR = ISTOR/NWA IC = MOD(ISTOR,NWA) ISTOR = ISTOR/NWA IB = MOD(ISTOR,NWA) ISTOR = ISTOR/NWA IA = MOD(ISTOR,NWA) K = ISTOR/NWA ELSE ISTOR = ISTORE ID = MOD(ISTOR,NWA) IC = ISTOR/NWA ENDIF C IF (NUM.EQ.0 .AND. KTC(8).EQ.1) WRITE (IWRITE,3010) JA,JB NUM = NUM+1 C C Check if the radial integral has been stored. C XLAB = ISTORE*10+ITYPE IF (NUMSTO.GT.0) THEN DO I = NSTART+1,NSTART+NUMSTO IF (ABS(XLAB-PF(I)).LT.EPS10) THEN XINT = QF(I) ILAB = IST GOTO 20 ENDIF ENDDO ENDIF C C Evaluate the radial integral. C ILAB = IBL IF (ITYPE.EQ.7) THEN XINT = RINTI(IC,ID) ELSE XINT = SLATER(IA,IB,IC,ID,K) ENDIF C C Store radial integral. C NUMINT = NUMINT+1 IF (NUMSTO.LT.NUMX) THEN NUMSTO = NUMSTO+1 PF(NSTART+NUMSTO) = XLAB QF(NSTART+NUMSTO) = XINT ENDIF C 20 CONTINUE CONTR = COEF*XINT ELMNT = ELMNT+CONTR C C Sum core contributions. C IF (ITYP.LT.0) THEN ELSTO = ELSTO+CONTR NUMEL = NUMEL+1 ENDIF C C Write out contributions if requested - option 8 set. C IF (KTC(8).EQ.1) THEN IF (ITYPE.EQ.8 .OR. ITYPE.EQ.9) THEN WRITE (IWRITE,3090) NP(IA),NH(IA),NP(IB),NH(IB),NP(IC),NH(! +IC),NP(ID),NH(ID),K,ITYP,COEF,XINT,CONTR,ILAB ELSE WRITE (IWRITE,3080) NP(IC),NH(IC),NP(ID),NH(ID),ITYP,COEF,! +XINT,CONTR,ILAB ENDIF ENDIF C GOTO 10 C C Store total in COUVEC array. C Write out total if requested - option 8 set. C 30 CONTINUE C NUMTOT = NUMTOT+NUM C IF (NUM.GT.0 .AND. KTC(8).EQ.1) WRITE (IWRITE,3020) ELMNT C COUVEC(JA,JB) = ELMNT C COUVEC(JB,JA) = ELMNT C C Add in core contribution if applicable. C Write out contribution if option 8 is set. C IF (JA.EQ.JB .AND. JA.GT.1 .AND. NUMEL.GT.0) THEN COUVEC(JA,JA) = COUVEC(JA,JA)+ELSTO IF (KTC(8).EQ.1) THEN WRITE (IWRITE,3030) ELSTO WRITE (IWRITE,3020) COUVEC(JA,JA) ENDIF ENDIF C IF (JA.EQ.JB) PRINT 3000,JA,JA,ELSTO,COUVEC(JA,JA) C ENDDO ENDDO C----------------------------------------------------------------------- REWIND IO4 C----------------------------------------------------------------------- WRITE (IWRITE,3040) NUMTOT WRITE (IWRITE,3050) NUMEL WRITE (IWRITE,3060) NUMINT WRITE (IWRITE,3070) NUMSTO PRINT 3040,NUMTOT PRINT 3050,NUMEL PRINT 3060,NUMINT PRINT 3070,NUMSTO C----------------------------------------------------------------------- 3000 FORMAT (' COUMAT : ',2I5,1P,2E12.4) 3010 FORMAT (/' contributions to matrix element (',I2,',',I2,')'// ! +' A B C D K ITYPE coeff. integral ',! +' contribution'/) 3020 FORMAT (1X,62X,'---------------'/1X,62X,1P,E15.8) 3030 FORMAT (1X,'core contribution = ',48X,1P,E15.8) 3040 FORMAT (/1X,I5,' MCP (Coulomb) angular coefficients read') 3050 FORMAT (1X,I5,' core (Coulomb) angular coefficients read') 3060 FORMAT (/1X,I5,' radial integrals evaluated') 3070 FORMAT (1X,I5,' radial integrals stored') 3080 FORMAT (11X,2(I2,A2,1X),5X,I4,1X,1P,3E16.8,1X,A1) 3090 FORMAT (1X,4(I2,A2,1X),I4,2X,I4,1X,1P,3E16.8,1X,A1) END C C ******************* C SUBROUTINE COUMT2 C C----------------------------------------------------------------------- C C This routine is used to determine the eigenvalues and eigenvectors C of the zero order matrix (Coulomb). C C Subroutine called: DSYEV C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER LWORK PARAMETER (LWORK=MXNC*3-1) C C Local variables C DOUBLE PRECISION EAV,WORK(LWORK) INTEGER I,INFO C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3020) C C calculate the average energy and subtract from diagonal C EAV = ZERO DO I = 1,NCF EAV = EAV+COUVEC(I,I) ENDDO EAV = EAV/DBLE(NCF) WRITE (IWRITE,3030) EAV PRINT 3030,EAV DO I = 1,NCF COUVEC(I,I) = COUVEC(I,I)-EAV ENDDO C C diagonalise the matrix C C use a LAPACK routine C WRITE (IWRITE,3000) CALL DSYEV ('V','U',NCF,COUVEC,MXNC,COUENG,WORK,LWORK,INFO) IF (INFO.NE.0) THEN WRITE (IWRITE,3010) STOP ENDIF C DO I = 1,NCF COUENG(I) = COUENG(I)+EAV ENDDO C 3000 FORMAT (/' diagonalisation using the DSYEV routine') 3010 FORMAT (/' ERROR using the DSYEV routine'/' STOPPING') 3020 FORMAT (/ ! +' >>>> routine COUMT2 called : diagonalise the Coulomb matrix') 3030 FORMAT (/' average energy (a.u.) ',1P,E18.10) END C C ******************* C SUBROUTINE COUP(IWRITE,NL,NQ,JI,JF,JQS,IQ,JCUP,ICASE,MODE,ICASEX) C C----------------------------------------------------------------------- C C IWRITE = output stream for printer C NL = L value C NQ = occupation number C JI = initial 2J C JF = final 2J C JQS,IQ,JCUP - results C ICASE = number of relativistic subshells C MODE =0 if JF is not fixed, C =1 if JF is fixed C ICASEX = dimension of arrays C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Statement functions C LOGICAL ITRG C C Argument variables C INTEGER ICASEX INTEGER ICASE,IQ(2,ICASEX) INTEGER IWRITE,JCUP(ICASEX),JF INTEGER JI,JQS(3,2,ICASEX),MODE INTEGER NL,NQ C C Local variables C INTEGER I1,I2,I3,ISA INTEGER ISB,ITA,ITB,ITBX INTEGER IXA,IXB,IXJA,IXJB INTEGER J1,J2,J3,J4 INTEGER JMAX,JMIN,K,NC INTEGER NCA,NCB,NJA,NJB INTEGER NQA,NQB,NX C C Common variables C INTEGER ITAB(16),JTAB(16),NROWS INTEGER NTAB(255) COMMON / TERMS / NROWS,ITAB,JTAB,NTAB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ITRG(J1,J2,J3) = ABS(J1-J2).LE.J3.AND.J3.LE.J1+J2.AND.MOD(J1+J2+J3! +,2).EQ.0 C----------------------------------------------------------------------- ICASE = 0 IF (NQ.EQ.0) GOTO 10 IF (NL.EQ.0) GOTO 20 C NJA = NL+NL NJB = NJA+2 IXJA = 1+(NJA*(NJA-2))/8 IXJB = 1+(NJB*(NJB-2))/8 NX = MIN(NQ,NJA)+1 C DO I1 = 1,NX NQA = NX-I1 NQB = NQ-NQA NCA = MIN(NQA,NJA-NQA) NCB = MIN(NQB,NJB-NQB) C IF (NCB.GE.0) THEN C IF (NCA.EQ.0) THEN IXA = 1 ELSE IXA = NCA+IXJA IF (IXA.GT.NROWS) GOTO 50 ENDIF C IF (NCB.EQ.0) THEN IXB = 1 ELSE IXB = NCB+IXJB IF (IXB.GT.NROWS) GOTO 50 ENDIF C ISA = ITAB(IXA) ITA = JTAB(IXA) ISB = ITAB(IXB) ITB = JTAB(IXB) C DO I2 = 1,ISA J1 = NTAB(ITA+3)-1 JMIN = ABS(J1-JI) JMAX = J1+JI DO J4 = JMIN,JMAX,2 ITBX = ITB DO I3 = 1,ISB J2 = NTAB(ITBX+3)-1 IF (MODE.EQ.0 .OR. ITRG(J4,J2,JF)) THEN ICASE = ICASE+1 IF (ICASE.GT.ICASEX) GOTO 40 DO K = 1,3 JQS(K,1,ICASE) = NTAB(ITA+K) JQS(K,2,ICASE) = NTAB(ITBX+K) ENDDO IQ(1,ICASE) = NQA IQ(2,ICASE) = NQB JCUP(ICASE) = J4+1 ENDIF ITBX = ITBX+3 ENDDO ENDDO ITA = ITA+3 ENDDO C ENDIF C ENDDO RETURN C C NQ=0 occupation number is zero C 10 CONTINUE IF (MODE.EQ.1 .AND. JI.NE.JF) RETURN ICASE = 1 DO K = 1,3 JQS(K,1,1) = NTAB(K) JQS(K,2,1) = NTAB(K) ENDDO IQ(1,1) = 0 IQ(2,1) = 0 JCUP(1) = JI+1 RETURN C C NL=0 L-value is zero C 20 CONTINUE J2 = 0 IF (NQ.EQ.1) J2 = 1 IF (MODE.EQ.0) GOTO 30 IF (ITRG(JI,J2,JF)) GOTO 30 RETURN C 30 CONTINUE NC = MIN(NQ,2-NQ)*3 ICASE = 1 DO K = 1,3 JQS(K,1,1) = NTAB(K) JQS(K,2,1) = NTAB(K+NC) ENDDO IQ(1,1) = 0 IQ(2,1) = NQ JCUP(1) = JI+1 RETURN C C Error messages C 40 CONTINUE WRITE (IWRITE,3000) STOP C 50 CONTINUE WRITE (IWRITE,3010) STOP C 3000 FORMAT (/' ERROR in COUP : dimension for ICASE ... STOPPING') 3010 FORMAT (/' ERROR in COUP : dimension for NROWS ... STOPPING') END C C ******************* C FUNCTION CRE(KAP1,K,KAP2) C C----------------------------------------------------------------------- C C Computes the relativistic reduced matrix element C (J1 // C(K) // J2) C defined by eq.(5.15), I.P.Grant, Advances in Physics (1970), C vol.19, p.762. C C KAP1,KAP2 are the kappa values corresponding to J1,J2. C C The triangle conditions are tested by the 3J-coefficient C routine, CLRX. C C Subroutine called: CLRX C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION CRE C C External functions C EXTERNAL CLRX DOUBLE PRECISION CLRX C C Argument variables C INTEGER K,KAP1,KAP2 C C Local variables C INTEGER K1,K2 Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- K1 = ABS(KAP1) K2 = ABS(KAP2) CRE = SQRT(DBLE(K1*K2))*CLRX(KAP1,K,KAP2) IF (MOD(K1,2).EQ.1) CRE = -CRE CRE = CRE+CRE END C C ******************* C SUBROUTINE CSFM(ASFA,ASFB,LEV1,LEV2) C C----------------------------------------------------------------------- C C This routine calculates the CSF Coulomb, Babuskin, and magnetic C matrix elements for a transition between levels separated by energy C OMEGA. C C Option 8 gives a debug print from this routine. C C Subroutine called: SPME C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) C C Argument variables C DOUBLE PRECISION ASFA,ASFB INTEGER LEV1,LEV2 C C Local variables C DOUBLE PRECISION COUVX,CSFA,CSFB,FACT DOUBLE PRECISION FACT1,FACT2,HBAB,HCOUL DOUBLE PRECISION HMAG,XCOEF DOUBLE PRECISION MIX(6) INTEGER I,IC,ID,IDL INTEGER IL,ILDA,ILDB,ILDN INTEGER IRS,ISTOR(MXNW,MXNW),ITEMP INTEGER ITR,IX,IXX,J INTEGER JTR,NSTART,NUMSTO,NUMX INTEGER NWA INTEGER NCOUNT,CSF(6) C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C INTEGER LTC(20) COMMON / OPT04 / LTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER KK,LK COMMON / OSC2 / LK,KK C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NWA = NW+1 NSTART = MPOIN(NW)+MPOS(NW)-1 NUMX = MXNG-NSTART NUMSTO = 0 DO I = 1,NW DO J = 1,NW ISTOR(I,J) = 0 ENDDO ENDDO C ASFA = ZERO ASFB = ZERO C IF (LTC(8).EQ.1) THEN C IF (KK.EQ.0) THEN WRITE (IWRITE,3000) WRITE (IWRITE,3010) WRITE (IWRITE,3020) LEV1,LEV2 WRITE (IPUNCH,3000) WRITE (IPUNCH,3010) WRITE (IPUNCH,3030) LEV1,LEV2 ELSE WRITE (IWRITE,3000) WRITE (IWRITE,3010) WRITE (IWRITE,3040) LEV1,LEV2 ENDIF C WRITE (IWRITE,3050) LEV1 NCOUNT = 0 DO ITR = 1,NCF IF (ABS(COUVEC(ITR,LEV1)).GT.0.01D0) THEN NCOUNT = NCOUNT+1 CSF(NCOUNT) = ITR MIX(NCOUNT) = COUVEC(ITR,LEV1) IF (NCOUNT.EQ.6) THEN WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT) NCOUNT = 0 ENDIF ENDIF ENDDO IF (NCOUNT.GT.0) THEN WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT) ENDIF C WRITE (IWRITE,3050) LEV2 NCOUNT = 0 DO ITR = 1,NCF IF (ABS(COUVEC(ITR,LEV2)).GT.0.01D0) THEN NCOUNT = NCOUNT+1 CSF(NCOUNT) = ITR MIX(NCOUNT) = COUVEC(ITR,LEV2) IF (NCOUNT.EQ.6) THEN WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT) NCOUNT = 0 ENDIF ENDIF ENDDO IF (NCOUNT.GT.0) THEN WRITE (IWRITE,3060) (CSF(I),MIX(I),I=1,NCOUNT) ENDIF C WRITE (IWRITE,3070) IF (KK.EQ.0) THEN WRITE (IPUNCH,3070) ENDIF C ENDIF C C Loop over CSF pairs C ------------------- C DO ITR = 1,NCF DO JTR = 1,NCF C COUVX = COUVEC(ITR,LEV1)*COUVEC(JTR,LEV2) IF (ABS(COUVX).LT.EPS10) GOTO 10 C C Find MCT coefficients for these configurations and accumulate C contributions. C IF (ITR.LT.JTR) THEN IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR ELSE IRS = (JTR-1)*(NCF+NCF-JTR)/2+ITR ENDIF C ILDN = NNLDR(IRS) IF (ILDN.EQ.0) GOTO 10 C ILDA = NSLDF(IRS) ILDB = ILDA+ILDN-1 C DO IL = ILDA,ILDB C IC = ISLDR(IL)/NWA ID = ISLDR(IL)-IC*NWA XCOEF = XSLDR(IL) C C The following code allows interchange of CSF labels. C IF (ITR.GT.JTR) THEN ITEMP = IC IC = ID ID = ITEMP FACT1 = DBLE(ITJPO(JTR)*(NKJ(IC)+1)) FACT2 = DBLE(ITJPO(ITR)*(NKJ(ID)+1)) FACT = SQRT(FACT1/FACT2) IDL = (ITJPO(ITR)-ITJPO(JTR)+NKJ(IC)-NKJ(ID))/2 IF (MOD(IDL,2).NE.0) FACT = -FACT XCOEF = FACT*XCOEF ENDIF C IF (KK.EQ.0) THEN C C electric case C ------------- C IXX = ISTOR(IC,ID) C C the integrals are stored when the code is positive C IF (IXX.GT.0) THEN HCOUL = PF(IXX) HBAB = QF(IXX) C ELSE C C calculate the Babushkin integral when the code is negative C IF (IXX.LT.0) THEN IXX = -IXX HCOUL = PF(IXX) CALL SPME(IC,ID,HCOUL,HBAB,HMAG,1) ISTOR(IC,ID) = IXX QF(IXX) = HBAB C ELSE C C calculate the integrals when the code is zero C HCOUL = ZERO CALL SPME(IC,ID,HCOUL,HBAB,HMAG,0) C C store the integrals if possible C IF (NUMSTO.LT.NUMX) THEN NUMSTO = NUMSTO+1 IX = NSTART+NUMSTO ISTOR(IC,ID) = IX PF(IX) = HCOUL QF(IX) = HBAB C C use the symmetry of the COULOMB integral C store it provided option 19 is NOT set C When option 19 is set the COULOMB may have a gauge contribution. C IF (NUMSTO.LT.NUMX) THEN IF (LTC(19).EQ.0) THEN FACT = SQRT(DBLE(NKJ(IC)+1)/DBLE(NKJ(ID)+1)) IDL = (NKJ(IC)-NKJ(ID))/2 IF (MOD(IDL,2).NE.0) FACT = -FACT NUMSTO = NUMSTO+1 IX = NSTART+NUMSTO ISTOR(ID,IC) = -IX PF(IX) = -HCOUL*FACT ENDIF ENDIF C ENDIF C ENDIF C ENDIF C ASFA = ASFA+COUVX*XCOEF*HCOUL ASFB = ASFB+COUVX*XCOEF*HBAB C IF (LTC(8).EQ.1) THEN CSFA = COUVX*XCOEF*HCOUL CSFB = COUVX*XCOEF*HBAB WRITE (IWRITE,3080)ITR,JTR,COUVX,NP(IC),NH(IC),NP(ID),NH! +(ID),XCOEF,HCOUL,CSFA,ASFA WRITE (IPUNCH,3080)ITR,JTR,COUVX,NP(IC),NH(IC),NP(ID),NH! +(ID),XCOEF,HBAB,CSFB,ASFB ENDIF C ELSE C C magnetic case C ------------- C IXX = ISTOR(IC,ID) C C the integral is stored when the code is positive C IF (IXX.GT.0) THEN HMAG = PF(IXX) C ELSE C C calculate the integral when the code is zero C CALL SPME(IC,ID,HCOUL,HBAB,HMAG,0) C C store the integral if possible C IF (NUMSTO.LT.NUMX) THEN NUMSTO = NUMSTO+1 IX = NSTART+NUMSTO ISTOR(IC,ID) = IX PF(IX) = HMAG C C use the symmetry of the magnetic integral C IF (NUMSTO.LT.NUMX) THEN FACT = SQRT(DBLE(NKJ(IC)+1)/DBLE(NKJ(ID)+1)) IDL = (NKJ(IC)-NKJ(ID))/2 IF (MOD(IDL,2).NE.0) FACT = -FACT NUMSTO = NUMSTO+1 IX = NSTART+NUMSTO ISTOR(ID,IC) = IX PF(IX) = HMAG*FACT ENDIF C ENDIF C ENDIF C ASFA = ASFA+COUVX*XCOEF*HMAG C IF (LTC(8).EQ.1) THEN CSFA = COUVX*XCOEF*HMAG WRITE (IWRITE,3080)ITR,JTR,COUVX,NP(IC),NH(IC),NP(ID),NH! +(ID),XCOEF,HMAG,CSFA,ASFA ENDIF C ENDIF C ENDDO C 10 CONTINUE ENDDO ENDDO IF (LTC(8).EQ.1) THEN WRITE (IWRITE,3000) ENDIF C 3000 FORMAT (1X,70('-')) 3010 FORMAT (1X,'Debug print from routine CSFM in OSCL module') 3020 FORMAT (1X,' electric case - first gauge'/1X, ! +' levels : LEV1,LEV2 : ',2I4) 3030 FORMAT (1X,' electric case - second gauge'/1X, ! +' levels : LEV1,LEV2 : ',2I4) 3040 FORMAT (1X,' magnetic case'/1X,' levels : LEV1,LEV2 : ',2I4) 3050 FORMAT (/' mixing coefficients (|c|>.01) for level ',I4) 3060 FORMAT (1X,6(I4,' : ',F5.2)) 3070 FORMAT (/' ITR,JTR ... CSF labels'/ ! +' mixing ... product of mixing coefficients ... = C(ITR,LEV1)*C',! +'(JTR,LEV2)'/ ! +' angular ... integral (MCT) ... d(ITR,JTR;ORB1,ORB2)'/ ! +' radial ... integral ... I(ORB1,ORB2)'/ ! +' product ... = mixing*angular*radial'/ ! +' total ... running total'// ! +' ITR JTR mixing ORB1 ORB2 angular radial product ',! +' total'/) 3080 FORMAT (1X,2I4,1P,E11.3,2(1X,I2,A2),4E11.3) END C C ******************* C SUBROUTINE CXK(S,IS,KAPS,NU,K,IBR,IEX) C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C External functions C EXTERNAL CRE DOUBLE PRECISION CRE C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) C C Argument variables C DOUBLE PRECISION S(12) INTEGER IBR,IEX,IS(4),K INTEGER KAPS(4),NU C C Local variables C DOUBLE PRECISION A,B,D,DK DOUBLE PRECISION DK1,DK2,F1,F2 DOUBLE PRECISION F3,F4,FK,G1 DOUBLE PRECISION G2,G3,G4,GK DOUBLE PRECISION H INTEGER IA,IB,IC,ID INTEGER IK,IP,KA,KB INTEGER KC,KD,KK,MU C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO MU = 1,12 S(MU) = ZERO ENDDO C IA = IS(1) IB = IS(2) IC = IS(3) ID = IS(4) C KA = KAPS(1)/2 KB = KAPS(2)/2 KC = KAPS(3)/2 KD = KAPS(4)/2 C IF (IEX.NE.2) GOTO 10 C KK = KD IK = ID KD = KC ID = IC KC = KK IC = IK C 10 CONTINUE IF (IBR.EQ.1) GOTO 20 IF (IBR.EQ.2) GOTO 60 IF (IBR.EQ.3) GOTO 90 IF (IBR.EQ.4) GOTO 100 GOTO 150 C----------------------------------------------------------------------- 20 CONTINUE IF (NU-K) 50,30,40 C 30 CONTINUE S(1) = -((KA+KC)*(KD+KB)) IF (K.EQ.0) GOTO 140 D = DBLE(K*(K+1)) H = CRE(KA,K,KC)*CRE(KB,K,KD) IF (MOD(K,2).NE.0) H = -H S(1) = S(1)*H/D DO MU = 2,4 S(MU) = S(1) ENDDO RETURN C 40 CONTINUE DK1 = DBLE(KC-KA) DK2 = DBLE(KD-KB) FK = DBLE(K) GK = DBLE(K+1) G1 = DK1-GK G2 = DK1+GK G3 = DK2-GK G4 = DK2+GK KK = K+K+1 H = CRE(KA,K,KC)*CRE(KB,K,KD) IF (MOD(K,2).NE.0) H = -H A = H*FK/GK/(KK*(KK+2)) S(1) = A*G1*G3 S(2) = A*G2*G4 S(3) = A*G1*G4 S(4) = A*G2*G3 RETURN C 50 CONTINUE DK1 = DBLE(KC-KA) DK2 = DBLE(KD-KB) FK = DBLE(K) GK = DBLE(K+1) F1 = DK1-FK F2 = DK1+FK F3 = DK2-FK F4 = DK2+FK G1 = DK1-GK G2 = DK1+GK G3 = DK2-GK G4 = DK2+GK KK = K+K+1 H = CRE(KA,K,KC)*CRE(KB,K,KD) IF (MOD(K,2).NE.0) H = -H A = H*GK/FK/(KK*(KK-2)) S(1) = A*F2*F4 S(2) = A*F1*F3 S(3) = A*F2*F3 S(4) = A*F1*F4 B = H/(KK*KK) S(5) = B*F2*G3 S(6) = B*F4*G1 S(7) = B*F1*G4 S(8) = B*F3*G2 S(9) = B*F2*G4 S(10) = B*F3*G1 S(11) = B*F1*G3 S(12) = B*F4*G2 RETURN C----------------------------------------------------------------------- 60 CONTINUE IF (IA.EQ.IC .AND. IB.NE.ID) GOTO 80 IF (IA.NE.IC .AND. IB.EQ.ID) GOTO 70 GOTO 150 C 70 CONTINUE IK = IB IB = IA IA = IK IK = ID ID = IC IC = IK KK = KB KB = KA KA = KK KK = KD KD = KC KC = KK C 80 CONTINUE IF (MOD(K,2).NE.1) RETURN C DK = DBLE(K*(K+1)) H = CRE(KA,K,KC)*CRE(KB,K,KD)/DK S(1) = H*(4*KA*(KB+KD)) RETURN C----------------------------------------------------------------------- 90 CONTINUE IF (IA.NE.IC .OR. IB.NE.ID) GOTO 150 IF (MOD(K,2).NE.1) RETURN DK = DBLE(K*(K+1)) H = CRE(KA,K,KA)*CRE(KB,K,KB)/DK S(1) = H*(16*KA*KB) RETURN C----------------------------------------------------------------------- 100 CONTINUE IF (IA.NE.ID .OR. IB.NE.IC) GOTO 150 C IF (NU-K) 130,110,120 C 110 CONTINUE S(1) = DBLE(KA+KB)*CRE(KA,K,KB) IP = ABS(KA)-ABS(KB)+K+1 S(1) = S(1)*S(1)/(K*(K+1)) IF (MOD(IP,2).NE.0) S(1) = -S(1) S(3) = S(1) S(2) = S(1)+S(1) RETURN C 120 CONTINUE DK = DBLE(KB-KA) GK = DBLE(K+1) FK = DBLE(K) G1 = DK+GK G2 = DK-GK KK = K+K+1 H = CRE(KA,K,KB)**2 IF (KA*KB.LT.0) H = -H A = H*FK/GK/(KK*(KK+2)) S(1) = -A*G1*G1 S(2) = -TWO*A*G1*G2 S(3) = -A*G2*G2 RETURN C 130 CONTINUE DK = DBLE(KB-KA) FK = DBLE(K) GK = DBLE(K+1) F1 = DK+FK F2 = DK-FK G1 = DK+GK G2 = DK-GK KK = K+K+1 H = CRE(KA,K,KB)**2 IF (KA*KB.LT.0) H = -H A = H*GK/FK/(KK*(KK-2)) S(1) = -A*F2*F2 S(2) = -TWO*A*F1*F2 S(3) = -A*F1*F1 B = H/(KK*KK) B = B+B S(4) = -B*F1*G2 S(5) = -B*F2*G1 S(6) = -B*F1*G1 S(7) = -B*F2*G2 RETURN C----------------------------------------------------------------------- 140 CONTINUE WRITE (IWRITE,3000) IS(1),IS(2),IS(3),IS(4),NU,IBR,IEX WRITE (IPUNCH,3000) IS(1),IS(2),IS(3),IS(4),NU,IBR,IEX STOP C----------------------------------------------------------------------- 150 CONTINUE WRITE (IWRITE,3010) IBR,IS(1),IS(2),IS(3),IS(4),NU,K,IEX WRITE (IPUNCH,3010) IBR,IS(1),IS(2),IS(3),IS(4),NU,K,IEX STOP C----------------------------------------------------------------------- 3000 FORMAT (/' CXK halted on illegal value K = 0'/ ! +' IS(1),IS(2),IS(3),IS(4),NU,IBR,IEX : ',4I3,2X,I3,2X,2I2) 3010 FORMAT (/' CXK halted on type ',I2/ ! +' IBR,IS(1),IS(2),IS(3),IS(4),NU,K,IEX : ',I2,3X,4I3,2X,2I3,2X,I2) END C C ******************* C SUBROUTINE DAMP(CHECK,IC) C C----------------------------------------------------------------------- C C This routine checks for convergence of the configuration mixing C coefficients, returning IC=0 at convergence and IC=1 otherwise. C This routine also damps the predicted changes to the above C coefficients if any change is large. This is done by taking a C linear combination of the old and new C.I. coefficients C in such a way that the largest change is CHECK. C The first C.I. vector is then re-normalised and the remainder C Schmidt orthogonalised in order of increasing energy and C then normalised. C The old coefficients are stored in an array CHK. C The predicted ones are stored in array CCR. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS9 PARAMETER (EPS9=1.D-9) INTEGER N10 PARAMETER (N10=MXNX*MXNC) C C Argument variables C DOUBLE PRECISION CHECK INTEGER IC C C Local variables C DOUBLE PRECISION COM,DAM,FACTOR,OVLAP DOUBLE PRECISION RNORM,TBIG,TEST INTEGER I,IA,IADD,IAS INTEGER IB,IBIG,IBIGC,IBS INTEGER IEL,IELM,II,J INTEGER JJ,NCFTT,NF,NS C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3030) WRITE (IWRITE,3020) (UCF(I),I=1,NW) WRITE (IWRITE,3040) WRITE (IWRITE,3020) (COUENG(I),I=1,NCF) NCFTT = NCF*NCMIN C C Examine each of the NCMIN (the number of levels the sum of whose C energy is to be minimised) vectors in turn and change sign of a C vector if its largest element has opposite sign to that of same C element in new vector. Then test magnitudes of predicted changes C to coefficients. C IADD = 0 IBIGC = 0 IC = 0 TBIG = ZERO DO IEL = 1,NCMIN IBIG = 1+IADD NS = 1+IBIG NF = NS+NCF-2 C C Find largest coefficient C TEST = ABS(CHK(IBIG))+EPS9 DO I = NS,NF IF (ABS(CHK(I)).LT.TEST) GOTO 10 TEST = ABS(CHK(I)) IBIG = I 10 CONTINUE ENDDO NS = NS-1 TEST = CHK(IBIG)*CCR(IBIG) IF (TEST.GT.ZERO) GOTO 20 C C Change sign of old vector if neccessary C DO I = NS,NF CHK(I) = -CHK(I) ENDDO C C Examine predicted changes in CI coefficients C 20 CONTINUE DO I = NS,NF TEST = ABS(CCR(I)-CHK(I)) IF (TEST.GT.ACCY) IC = 1 IF (TEST.LT.CHECK .OR. TEST.LT.TBIG) GOTO 30 TBIG = TEST IBIGC = 1 30 CONTINUE ENDDO IADD = IADD+NCF ENDDO IF (IBIGC.NE.0) GOTO 40 WRITE (IWRITE,3000) GOTO 70 C 40 CONTINUE IC = 1 C C Calculate damping factor C DAM = ONE-CHECK/TBIG COM = ONE-DAM WRITE (IWRITE,3010) DAM C C Calculate new CI coefficients C DO I = 1,NCFTT CCR(I) = COM*CCR(I)+DAM*CHK(I) ENDDO C C Renormalise lowest energy eigenvector C RNORM = ZERO DO I = 1,NCF RNORM = RNORM+CCR(I)*CCR(I) ENDDO RNORM = ONE/SQRT(RNORM) DO I = 1,NCF CCR(I) = CCR(I)*RNORM ENDDO IF (NCMIN.EQ.1) GOTO 50 C C Schmidt orthogonalize remaining vectors C IAS = 1+NCF DO IEL = 2,NCMIN IELM = IEL-1 IBS = 1 DO II = 1,IELM C C Calculate overlap C OVLAP = ZERO IA = IAS IB = IBS DO I = 1,NCF OVLAP = OVLAP+CCR(IA)*CCR(IB) IA = IA+1 IB = IB+1 ENDDO C C Orthogonalise pair of vectors C IA = IAS IB = IBS DO I = 1,NCF CCR(IA) = CCR(IA)-OVLAP*CCR(IB) IA = IA+1 IB = IB+1 ENDDO IBS = IBS+NCF ENDDO C C Normalise vector which is now orthogonal to those of lower energy C RNORM = ZERO NF = IAS+NCF-1 DO I = IAS,NF RNORM = RNORM+CCR(I)*CCR(I) ENDDO RNORM = ONE/SQRT(RNORM) DO I = IAS,NF CCR(I) = CCR(I)*RNORM ENDDO IAS = IAS+NCF ENDDO C C Evaluate mixing coefficients C FACTOR = ONE/DBLE(NCMIN) DO I = 1,NCF COUENG(I) = ZERO II = I DO JJ = 1,NCMIN COUENG(I) = COUENG(I)+CCR(II)*CCR(II) II = II+NCF ENDDO COUENG(I) = SQRT(FACTOR*COUENG(I)) ENDDO GOTO 60 C 50 CONTINUE DO I = 1,NCF COUENG(I) = CCR(I) ENDDO C C Evaluate generalised occupation numbers C 60 CONTINUE DO J = 1,NW UCF(J) = ZERO DO I = 1,NCF UCF(J) = UCF(J)+COUENG(I)*COUENG(I)*DBLE(IQ(J,I)) ENDDO ENDDO C C Store new CI coefficients in array of old coefficients for C next call to DAMP C 70 CONTINUE DO I = 1,NCFTT CHK(I) = CCR(I) ENDDO IF (IBIGC.EQ.0) RETURN WRITE (IWRITE,3030) WRITE (IWRITE,3020) (UCF(I),I=1,NW) WRITE (IWRITE,3040) WRITE (IWRITE,3020) (COUENG(I),I=1,NCF) C 3000 FORMAT (/' Change in CI mixing coefficients not damped') 3010 FORMAT (/' Change in CI mixing coefficients damped by',1P,E13.5) 3020 FORMAT (1X,1P,4E15.7) 3030 FORMAT (/' generalised occupation numbers'/) 3040 FORMAT (/' CI mixing coefficients'/) END C C ******************* C SUBROUTINE DATAIN(ISTOP,IO1,IO2,IO3,IR2,IR3,IP3) C C----------------------------------------------------------------------- C C This subroutine controls the reading of the input data. C The free format input record reading routine CARDIN is used. C C C DATAIN C CARDIN C CFOUT C DATNR C CARDIN C MAN4 C COUP C MANOUT C REORDR C DATR C DATSCF C CARDIN C NROUT C MATOUT C TRANS C NRCSF C JCLIST C JJLS C DRACAH C GENSUM --- C SSTC C GENSUM --- C LSTERM C NJSYM --- C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS6 PARAMETER (EPS6=1.D-6) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) C C---------- ND - max. no. of numbers read by CARDIN C INTEGER ND PARAMETER (ND=MXNC+3) C C Argument variables C INTEGER IO1,IO2,IO3,IP3 INTEGER IR2,IR3,ISTOP C C Local variables C CHARACTER*4 LAB(8) CHARACTER*2 NA CHARACTER*4 NB DOUBLE PRECISION BB,RT(ND) INTEGER I,IOP,IT(ND),J INTEGER JJ,NMAN,NN,NWM C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C INTEGER LABEL COMMON / CARD / LABEL C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C INTEGER LEVELS(MXNC),NLEV COMMON / LEVL / NLEV,LEVELS C DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2 COMMON / LEVM / ENLEV,GAUGE1,GAUGE2 C INTEGER IOPAR,KA COMMON / MCTA / KA,IOPAR C INTEGER ITC(50) COMMON / OPT01 / ITC C INTEGER JTC(20) COMMON / OPT02 / JTC C INTEGER KTC(20) COMMON / OPT03 / KTC C INTEGER LTC(20) COMMON / OPT04 / LTC C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C DOUBLE PRECISION WFACT COMMON / WFAC / WFACT C DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C INTEGER ITAB(16),JTAB(16),NROWS INTEGER NTAB(255) COMMON / TERMS / NROWS,ITAB,JTAB,NTAB C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA LAB/'MCP ','MCDF','END ','MCT ','MCBP','BENA','OSCL','STOP'/ C----------------------------------------------------------------------- C C ************************************************ C ***** Read a title and orbital data ************ C ************************************************ C C This READ statement uses an END parameter to find the end of data. C Replace if this is not available. C LABEL = 1 READ (IREAD,3000,END=120) IHED WRITE (IWRITE,3010) LABEL,IHED(1:40),IHED(41:80) C C Set the options to 0. C C If option J is to be set then at the appropriate place C input the number J. This will set JTC(J)=1 for example. C If JTC(J)=0 the option is not set . C C ITC contains options for the MCDF program. C C JTC(J) ,J=1,9 contains options for the angular programs. C C JTC(J) ,J=10,20 control which programs are called. C C 10 - CFOUT called C 11 - switch set on ANG input record to control calls to C all angular packages C 12 - MCP called C 13 - MCDF called C 14 - MCT called C 15 - MCBP called C 16 - BENA called C 17 - OSCL called C C KTC contains options for BENA program. C C LTC contains options for OSCL program. C DO I = 1,50 ITC(I) = 0 ENDDO C DO I = 1,20 JTC(I) = 0 KTC(I) = 0 LTC(I) = 0 ENDDO C----------------------------------------------------------------------- C C Input record 2 C CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.LT. 2.OR. NN.GT.6) GOTO 110 NMAN = IT(1) NWM = IT(2) C IF (NN.GE.3) THEN IOP = IT(3) IF (IOP.LT.-1 .OR. IOP.GT.3) GOTO 110 ELSE IOP = 0 ENDIF C IF (NN.GE.4) THEN ATW = RT(4) IF (ATW.GT.EPS6) THEN BB = ONE/(ONE+XCON1/ATW) ELSE BB = ONE ENDIF ELSE ATW = ZERO BB = ONE ENDIF C C Work out conversion factors taking account of atomic weight. C FACTCM = XCON2*BB FACTEV = XCON3*BB FACTAN = XCON4 FACTRY = TWO C IF (NN.GE.5) THEN NCPRIN = IT(5) ELSE NCPRIN = -999 ENDIF C IF (NN.EQ.6) THEN CUTOFF = RT(6) ELSE CUTOFF = 1.D-10 ENDIF C----------------------------------------------------------------------- C C Call routine DATR or DATNR for the orbital/CSF data. C C----------------------------------------------------------------------- IF (IOP.EQ.-1) THEN CALL DATR (NMAN, NWM, + IWRITE, IREAD, LABEL, ND, RT, IT, + ITAB, JTAB, NTAB, + NH, IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6, + ICHOP, IQ, ISPAR, ITJPO, JCUP, JQS, JTC, NAK, NCF, + NKJ, NKL, NP, NW) ELSE CALL DATNRG (RT,IT,NMAN,NWM,ND) ENDIF C IF (NW .GT.MAXDIM(1)) MAXDIM(1) = NW IF (NCF.GT.MAXDIM(2)) MAXDIM(2) = NCF C IF (IOP.GT.0) THEN ITC(30) = 1 CALL TRANS(NWM,NMAN) IF (IOP.EQ.3) ITC(31) = 1 ENDIF C IF (NCPRIN.LE.0 .OR. NCPRIN.GT.NCF) NCPRIN = NCF C----------------------------------------------------------------------- C C Process labels C C----------------------------------------------------------------------- 10 CONTINUE CALL CARDIN(IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND) IF (LAB(1).EQ.NB) GOTO 20 IF (LAB(2).EQ.NB) GOTO 50 IF (LAB(3).EQ.NB) GOTO 80 IF (LAB(4).EQ.NB) GOTO 30 IF (LAB(5).EQ.NB) GOTO 40 IF (LAB(6).EQ.NB) GOTO 60 IF (LAB(7).EQ.NB) GOTO 70 IF (LAB(8).EQ.NB) GOTO 90 GOTO 100 C C *********** C *** MCP *** C *********** C 20 CONTINUE IF (NN.GT.2) GOTO 110 JTC(12) = JTC(11) C DO I = 1,1 JTC(I) = 0 ENDDO C IF (NN.GE.1) THEN IO1 = IT(1) ELSE IO1 = 1 ENDIF C IF (NN.GT.1) THEN DO I = 2,2 JJ = IT(I) J = ABS(JJ) IF (J.LT. 1.OR. J.GT.1) GOTO 110 JTC(J) = SIGN(1,JJ) ENDDO ENDIF C IEXC = JTC(1) GOTO 10 C C *********** C *** MCT *** C *********** C 30 CONTINUE IF (NN.LT. 1.OR. NN.GT.3) GOTO 110 JTC(14) = JTC(11) KA = IT(1) IOPAR = 0 C IF (NN.GT.1) THEN IOPAR = IT(2) ENDIF C IF (NN.EQ.3) THEN IO2 = IT(3) ELSE IO2 = 1 ENDIF C GOTO 10 C C ************ C *** MCBP *** C ************ C 40 CONTINUE IF (NN.GT.1) GOTO 110 JTC(15) = JTC(11) IF (NN.EQ.1) THEN IO3 = IT(1) ELSE IO3 = 1 ENDIF GOTO 10 C C *********** C *** MCDF ** C *********** C C Input record 9 --- MCDF call and options C 50 CONTINUE IF (NN.GT.50) GOTO 110 JTC(13) = 1 IF (NN.GT.0) THEN DO I = 1,NN J = IT(I) IF (J.LT. 1.OR. J.GT.50) GOTO 110 ITC(J) = 1 ENDDO IF (ITC(20).EQ.1) JTC(13) = 0 ENDIF C CALL DATSCF(RT,IT,ND,NMAN,IR2,IR3,IP3) C GOTO 10 C C ************ C *** BENA *** C ************ C C Input record 20 --- Call BENA section of GRASP. C 60 CONTINUE IF (NN.GT.20) GOTO 110 JTC(16) = 1 IF (NN.GT.0) THEN DO I = 1,NN J = IT(I) IF (J.LT. 1.OR. J.GT.20) GOTO 110 KTC(J) = 1 ENDDO IF (KTC(20).EQ.1) JTC(16) = 0 ENDIF C C set default for printing C IF (KTC(16)+KTC(17)+KTC(18)+KTC(19).EQ.0) THEN KTC(16) = 1 KTC(17) = 1 ENDIF C C Input record 21 --- BENA data C CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.GT.1) GOTO 110 C IF (NN.GT.0) THEN WFACT = RT(1) ELSE WFACT = ONE ENDIF C GOTO 10 C C ************ C *** OSCL *** C ************ C C Input record 22 --- Call OSCL section of GRASP. C 70 CONTINUE IF (NN.GT.20) GOTO 110 JTC(17) = 1 C IF (NN.GT.0) THEN DO I = 1,NN J = IT(I) IF (J.LT. 1.OR. J.GT.20) GOTO 110 LTC(J) = 1 ENDDO IF (LTC(20).EQ.1) JTC(17) = 0 ENDIF C C Input record 23 --- OSCL data --- levels. C CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.GT.NCF) GOTO 110 C IF (NN.GT.0) THEN NLEV = NN DO I = 1,NLEV J = IT(I) IF (J.LT. 1.OR. J.GT.NCF) GOTO 110 LEVELS(I) = J ENDDO ELSE NLEV = NCF DO I = 1,NLEV LEVELS(I) = I ENDDO ENDIF C C Input record 24 --- OPTIONAL --- Level energies C C OPTIONAL if OSCL option 17 is set C IF (LTC(17).EQ.1) THEN CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.NE.NLEV) GOTO 110 DO I = 1,NLEV ENLEV(I) = RT(I) ENDDO ENDIF C C Input record 25 --- OPTIONAL --- Gauge parameters C C OPTIONAL if OSCL option 19 is set C IF (LTC(19).EQ.1) THEN CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.NE.2) GOTO 110 GAUGE1 = RT(1) GAUGE2 = RT(2) ENDIF C GOTO 10 C C ******************* C *** END or STOP *** C ******************* C C Input record 26 --- End of input data block C 80 CONTINUE ISTOP = 0 IF (JTC(10).EQ.1) CALL CFOUT CALL NROUT (NMAN,NWM,IOP,IWRITE) RETURN C 90 CONTINUE ISTOP = 1 IF (JTC(10).EQ.1) CALL CFOUT CALL NROUT (NMAN,NWM,IOP,IWRITE) RETURN C----------------------------------------------------------------------- C C error messages C 100 CONTINUE WRITE (IWRITE,3040) NB STOP C 110 CONTINUE WRITE (IWRITE,3020) STOP C C end of data encountered C 120 CONTINUE WRITE (IWRITE,3050) WRITE (IWRITE,3030) CALL DIMPRT PRINT 3030 STOP C----------------------------------------------------------------------- 3000 FORMAT (A80) 3010 FORMAT (/' Input records'//1X,I4,1X,'=',1X,A40/7X,A40) 3020 FORMAT (/' ERROR in DATAIN : on above input record ... STOPPING') 3030 FORMAT (/' **************************'/ +' *** end of input data ***'/' *** STOPPING in DATAIN ***'/ +' **************************') 3040 FORMAT (/' ERROR in DATAIN : incorrect label read - ',A4, +' ... STOPPING') 3050 FORMAT (/1X,71('*')) END C C ******************* C SUBROUTINE DATNRG(RT,IT,NMAN,NWM,ND) C C----------------------------------------------------------------------- C C This subroutine reads input record input defining non-relativistic C configurations and uses it to generate all possible relativistic C configurations which produce the required total J-value. C C RT - array of real numbers C IT - array of integer numbers C NMAN - number of NR config. to be defined C NWM - number of NR orbitals to be defined C ND - maximum number of numbers that can be read in CARDIN C i.e. the dimension of RT and IT C C----------------------------------------------------------------------- C C NOPENX - maximum number of open shells in any configuration C that can be handled by this routine. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER NOPENX PARAMETER (NOPENX=4) INTEGER JSTMAX PARAMETER (JSTMAX=40) C C Argument variables C INTEGER ND DOUBLE PRECISION RT(ND) INTEGER IT(ND),NMAN,NWM C C Local variables C CHARACTER*2 LABT,NA CHARACTER*4 NB CHARACTER*2 NG(5),NHX INTEGER I,II,IPAR,ITEST INTEGER J,JF,JMAN,JMAX INTEGER JMAXX(MXNC),JMIN,JMINX(MXNC),JST INTEGER JST1,JST2,JSTORE(0:JSTMAX) INTEGER K,KCHOP(MXNW),M,NAKX INTEGER NELEC,NELEC1,NFULL,NL INTEGER NN,NOPEN1,NPN,NQ INTEGER NST LOGICAL MFAIL C C Common variables C INTEGER LABEL COMMON / CARD / LABEL C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM C C Common variables C INTEGER JPOS(4),MLX(4),MQX(4),NOPEN COMMON / NRD01 / MLX,MQX,JPOS,NOPEN C C Common variables C INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC) COMMON / NRD03 / NPX,NLX,NQX C C Common variables C INTEGER IPOS(MXNW),KPOS(4,MXNC) INTEGER NPOS(MXNC) COMMON / NRD04 / IPOS,NPOS,KPOS C C Common variables C INTEGER JFX(MXNC),KOPEN(MXNC) COMMON / NRD08 / JFX,KOPEN C C Common variables C INTEGER JTC(20) COMMON / OPT02 / JTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER JCHOP(MXNW,MXNC) COMMON / SAVE2 / JCHOP Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA NG/'P-','D-','F-','G-','H-'/ C----------------------------------------------------------------------- IF (NWM.GT.MXNW) THEN WRITE (IWRITE,3020) STOP ENDIF IF (NMAN.GT.MXNC) THEN WRITE (IWRITE,3030) STOP ENDIF C IF (NWM.GT.MAXDIM(1)) MAXDIM(1) = NWM IF (NMAN.GT.MAXDIM(2)) MAXDIM(2) = NMAN C C Input record 3 --- ORBITAL DATA C NW = 0 DO I = 1,NWM NW = NW+2 CALL CARDIN(IREAD,IWRITE,0,LABEL,1,NHX,NB,NN,RT,IT,ND) NPN = IT(1) NAKX = IT(2) NL = -(NAKX+1) NFULL = 4*NL+2 C IF (NN.EQ.2) THEN DO K = 1,NMAN NQX(I,K) = NFULL ENDDO ELSE IF (NN.EQ.3) THEN DO K = 1,NMAN NQX(I,K) = IT(3) ENDDO ELSE IF (NN.EQ.NMAN+2) THEN DO K = 1,NMAN NQX(I,K) = IT(K+2) ENDDO ELSE GOTO 50 ENDIF ENDIF ENDIF C IF (NL.EQ.0) NW = NW - 1 IF (NW.GT.MXNW) GOTO 60 C NPX(I) = NPN NLX(I) = NL IPOS(I) = NW DO K = 1,NMAN IF (NQX(I,K).EQ.0) THEN JCHOP(NW,K) = -1 ELSE JCHOP(NW,K) = 0 ENDIF ENDDO NP(NW) = NPN NAK(NW) = NAKX NKL(NW) = NL NKJ(NW) = NL+NL+1 NH(NW) = NHX C IF (NL.GT.0) THEN DO K = 1,NMAN IF (NQX(I,K).EQ.0) THEN JCHOP(NW-1,K) = -1 ELSE JCHOP(NW-1,K) = 0 ENDIF ENDDO NP(NW-1) = NPN NAK(NW-1) = NL NKL(NW-1) = NL NKJ(NW-1) = NL+NL-1 NH(NW-1) = NG(NL) ENDIF C ENDDO C IF (NW.GT.MAXDIM(1)) MAXDIM(1) = NW C C Check number of electrons in each configuration C IF (NMAN.GT.1) THEN NELEC1 = 0 DO J = 1,NWM NELEC1 = NELEC1+NQX(J,1) ENDDO DO I = 2,NMAN NELEC = 0 DO J = 1,NWM NELEC = NELEC+NQX(J,I) ENDDO IF (NELEC.NE.NELEC1) GOTO 80 ENDDO ENDIF C C ************ C *** ANG **** C ************ C C Input record 4 C C OPTIONS FOR THE ANGULAR MOMENTUM PROGRAMS C CALL CARDIN(IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND) IF (NN.GT.10) GOTO 50 C DO I = 1,10 JTC(I) = 0 ENDDO C IF (NN.GT.0) THEN DO I = 1,NN J = IT(I) IF (J.LT.1 .OR. J.GT.10) GOTO 50 JTC(J) = 1 ENDDO ENDIF C C use option 20 rather than 10 C JTC(20) = JTC(10) C IF (JTC(7).EQ.1) THEN JTC(10) = 0 ELSE JTC(10) = 1 ENDIF C IF (JTC(8).EQ.1) THEN JTC(11) = 0 ELSE JTC(11) = 1 ENDIF C IBUG1 = JTC(1) IBUG2 = JTC(2) IBUG3 = JTC(3) IBUG4 = JTC(4) IBUG5 = JTC(5) IBUG6 = JTC(6) C C Input record 5 --- non-relativistic CSF total J values C CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) C IF (NN.EQ.1 .AND. IT(1).GE.-1) THEN JF = NINT(RT(1)+RT(1)) DO JMAN = 1,NMAN JMINX(JMAN) = JF JMAXX(JMAN) = JF JFX(JMAN) = JF ENDDO ELSE IF (NN.EQ.1) THEN DO JMAN = 1,NMAN CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.NE.2) GOTO 50 JMIN = NINT(RT(1)+RT(1)) JMAX = NINT(RT(2)+RT(2)) IF (JMIN.LT.0 .OR. JMAX.LT.0 .OR. JMAX.LT.JMIN) GOTO 50 JMINX(JMAN) = JMIN JMAXX(JMAN) = JMAX JFX(JMAN) = -2 ENDDO ELSE IF (NN.EQ.3 .AND. IT(1).LT.0) THEN JMIN = NINT(RT(2)+RT(2)) JMAX = NINT(RT(3)+RT(3)) IF (JMIN.LT.0 .OR. JMAX.LT.0 .OR. JMAX.LT.JMIN) GOTO 50 DO JMAN = 1,NMAN JMINX(JMAN) = JMIN JMAXX(JMAN) = JMAX JFX(JMAN) = -2 ENDDO ELSE IF (NN.EQ.NMAN) THEN DO JMAN = 1,NMAN JF = NINT(RT(JMAN)+RT(JMAN)) IF (JF.LT.0) GOTO 50 JMINX(JMAN) = JF JMAXX(JMAN) = JF JFX(JMAN) = JF ENDDO ELSE GOTO 50 ENDIF ENDIF ENDIF ENDIF C----------------------------------------------------------------------- C C Loop over each non-relativistic configuration in turn. C (1) determine which shells are open C (2) set up arrays KCHOP,MLX,MQX,JPOS for call to MAN4 C which generates relativistic configurations C MFAIL = .FALSE. NCF = 0 JST1 = 0 JST2 = 0 DO JMAN = 1,NMAN JMIN = JMINX(JMAN) JMAX = JMAXX(JMAN) JF = JFX(JMAN) C DO I = 1,NW KCHOP(I) = JCHOP(I,JMAN) ENDDO C C Select open shells C NOPEN = 0 DO I = 1,NWM NL = NLX(I) NQ = NQX(I,JMAN) NFULL = 4*NL+2 IF (NQ.EQ.NFULL .OR. NQ.EQ.0) GOTO 10 NOPEN = NOPEN+1 IF (NOPEN.GT.NOPENX) GOTO 70 MLX(NOPEN) = NL MQX(NOPEN) = NQ JPOS(NOPEN) = IPOS(I) KPOS(NOPEN,JMAN) = I 10 CONTINUE ENDDO C C Set the parity C IF (NOPEN.EQ.0) THEN IF (JF.GT.0) GOTO 20 IPAR = 1 ELSE ITEST = 0 DO I = 1,NOPEN ITEST = ITEST+MLX(I)*MQX(I) ENDDO IF (MOD(ITEST,2).NE.0) THEN IPAR = -1 ELSE IPAR = 1 ENDIF ENDIF C C Four open shells must always be defined in MAN4 C and the following code includes extra dummy orbitals C to ensure this. C IF (NOPEN.LT.NOPENX) THEN NOPEN1 = NOPEN+1 II = 1 DO I = NOPEN1,NOPENX MLX(I) = 0 MQX(I) = 0 JPOS(I) = NW+II II = II+1 ENDDO ENDIF C NST = NCF+1 CALL MAN4(IWRITE,KCHOP,IPAR,JMIN,JMAX,MFAIL,JSTORE) C DO JST = JSTMAX,0,-1 IF (JSTORE(JST).GT.0) THEN JST1 = JST2+1 JST2 = JST1+JSTORE(JST)-1 IF (MOD(JST,2).EQ.0) THEN IF (IPAR.EQ.1) THEN WRITE (IWRITE,3070) JMAN,JSTORE(JST),JST/2,JST1,JST2 WRITE (IPUNCH,3070) JMAN,JSTORE(JST),JST/2,JST1,JST2 ELSE WRITE (IWRITE,3080) JMAN,JSTORE(JST),JST/2,JST1,JST2 WRITE (IPUNCH,3080) JMAN,JSTORE(JST),JST/2,JST1,JST2 ENDIF ELSE IF (IPAR.EQ.1) THEN WRITE (IWRITE,3090) JMAN,JSTORE(JST),JST,JST1,JST2 WRITE (IPUNCH,3090) JMAN,JSTORE(JST),JST,JST1,JST2 ELSE WRITE (IWRITE,3100) JMAN,JSTORE(JST),JST,JST1,JST2 WRITE (IPUNCH,3100) JMAN,JSTORE(JST),JST,JST1,JST2 ENDIF ENDIF ENDIF ENDDO C NPOS(JMAN) = NCF KOPEN(JMAN) = NOPEN C IF (.NOT.MFAIL) THEN IF (NCF.GT.NST .AND. JF.LT.0) THEN CALL REORDR(NST) ENDIF ENDIF C 20 CONTINUE ENDDO C IF (MFAIL) THEN WRITE (IWRITE,3110) NCF,MXNC STOP ENDIF C C Check for orbitals with zero occupation in all CSF and eliminate C M = 0 DO J = 1,NW DO I = 1,NCF IF (IQ(J,I).NE.0) GOTO 30 ENDDO M = M+1 GOTO 40 C 30 CONTINUE IF (M.EQ.0) GOTO 40 NP(J-M) = NP(J) LABT = NH(J) NH(J-M) = LABT NAK(J-M) = NAK(J) NKJ(J-M) = NKJ(J) NKL(J-M) = NKL(J) DO I = 1,NCF DO K = 1,3 JQS(K,J-M,I) = JQS(K,J,I) ENDDO IQ(J-M,I) = IQ(J,I) ICHOP(J-M,I) = ICHOP(J,I) ENDDO 40 CONTINUE ENDDO NW = NW-M C C The equivalent input which could be read by DATR is now output C by a call to MANOUT. C IF (JTC(20).EQ.1) THEN WRITE (IWRITE,3010) CALL MANOUT(0) WRITE (IWRITE,3010) ENDIF C RETURN C C Error messages C 50 CONTINUE WRITE (IWRITE,3000) STOP C 60 CONTINUE WRITE (IWRITE,3040) STOP C 70 CONTINUE WRITE (IWRITE,3050) STOP C 80 CONTINUE WRITE (IWRITE,3060) STOP C 3000 FORMAT (/' ERROR in DATNRG : on input record ... STOPPING') 3010 FORMAT (1X) 3020 FORMAT (/' ERROR in DATNRG : dimension ERROR for NWM ... STOPPING'! +) 3030 FORMAT (/ ! +' ERROR in DATNRG : dimension ERROR for NMAN ... STOPPING') 3040 FORMAT (/' ERROR in DATNRG : dimension ERROR for NW ... STOPPING') 3050 FORMAT (/ ! +' ERROR in DATNRG : dimension ERROR for NOPEN ... STOPPING') 3060 FORMAT (/ ! +' ERROR in DATNRG : inconsistency in the number of electrons ...',! +' STOPPING'/' Check orbital data') 3070 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4, ! +' even (',I5,',',I5,')') 3080 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4, ! +' odd (',I5,',',I5,')') 3090 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4, ! +'/2 even (',I5,',',I5,')') 3100 FORMAT (' NR CSF ',I4,' ---> ',I4,' rel. CSFs with J = ',I4, ! +'/2 odd (',I5,',',I5,')') 3110 FORMAT (/ ! +' ERROR in DATNRG : the number of CSFs generated in MAN4 exceeds',! +' the dimensions ... STOPPING'/' NCF is ',I6, ! +' maximum allowed is ',I6) END C C ******************* C SUBROUTINE DATR (NMAN, NWM, + IWRITE, IREAD, LABEL, ND, RT, IT, + ITAB, JTAB, NTAB, + NH, IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6, + ICHOP, IQ, ISPAR, ITJPO, JCUP, JQS, JTC, NAK, NCF, + NKJ, NKL, NP, NW) C C $Log: DATR.f,v $ C Revision 1.2 2004/01/06 10:09:24 phn C *** empty log message *** C C Revision 1.1 2003/12/11 10:24:45 phn C Version grasp80d C C CX CX\routine{DATR}{(NMAN, NWM,\\ CX IWRITE, IREAD, LABEL, ND, RT, IT,\\ CX ITAB, JTAB, NTAB,\\ CX NH, IBUG1, IBUG2, IBUG3, IBUG4, IBUG5, IBUG6,\\ CX ICHOP, IQ, ISPAR, ITJPO, JCUP, JQS, JTC, NAK, NCF,\\ CX NKJ, NKL, NP, NW)} CX CX This routine reads the card input defining relativistic CX CSFs as described in the CPC write-up. CX CX i {\tt NMAN} --- number of relativistic CSFs to be CX defined CX CX i {\tt NWM} --- number of relativistic orbitals to be CX defined CX CX i {\tt IWRITE} --- stream number for output CX CX i {\tt IREAD} --- stream number for input CX CX {\tt LABEL} --- input record number CX CX {\tt ND} --- maximum number of numbers that can be CX read in CARDIN \ie the dimension of CX {\tt RT} and {\tt IT} CX CX {\tt RT(ND)} --- array of real numbers CX CX {\tt IT(ND)} --- array of integer numbers CX CX i {\tt ITAB(16)} --- table of shell quantum numbers CX CX i {\tt JTAB(16)} --- table of shell quantum numbers CX CX i {\tt NTAB(255)} --- table of shell quantum numbers CX CX o {\tt NH(MXNW)} --- orbital spectroscopic label CX CX o {\tt IBUG1} --- debug parameter CX CX o {\tt IBUG2} --- debug parameter CX CX o {\tt IBUG3} --- debug parameter CX CX o {\tt IBUG4} --- debug parameter CX CX o {\tt IBUG5} --- debug parameter CX CX o {\tt IBUG6} --- debug parameter CX CX o {\tt ICHOP(MXNW,MXNC)} --- open/closed flag for shells in CSFs CX CX o {\tt IQ(MXNW,MXNC)} --- shell occupation in CSFs CX CX o {\tt ISPAR(MXNC)} --- CSF parity CX CX o {\tt ITJPO(MXNC)} --- CSF $2J+1$-value CX CX o {\tt JCUP(10,MXNC)} --- shell coupling in CSFs CX CX o {\tt JQS(3,MXNW,MXNC)} --- shell quantum numbers in CSFs CX CX o {\tt JTC(20)} --- options CX CX o {\tt NAK(MXNW)} --- orbital $\kappa$-value CX CX o {\tt NCF} --- number of CSFs CX CX o {\tt NKJ(MXNW)} --- orbital $2j$-value CX CX o {\tt NKL(MXNW)} --- orbital $l$-value CX CX o {\tt NP(MXNW)} --- orbital $n$-value CX CX o {\tt NW} --- number of orbitals CX C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER NMAN INTEGER NWM C INTEGER IWRITE INTEGER IREAD INTEGER LABEL INTEGER ND DOUBLE PRECISION RT(*) INTEGER IT(*) C INTEGER ITAB(*) INTEGER JTAB(*) INTEGER NTAB(*) C CHARACTER*2 NH(*) INTEGER IBUG1 INTEGER IBUG2 INTEGER IBUG3 INTEGER IBUG4 INTEGER IBUG5 INTEGER IBUG6 INTEGER ICHOP(MXNW,*) INTEGER IQ(MXNW,*) INTEGER ISPAR(*) INTEGER ITJPO(*) INTEGER JCUP(10,*) INTEGER JQS(3,MXNW,*) INTEGER JTC(20) INTEGER NAK(*) INTEGER NCF INTEGER NKJ(*) INTEGER NKL(*) INTEGER NP(*) INTEGER NW C C Parameter variables C DOUBLE PRECISION EPS PARAMETER (EPS=1.0D-05) DOUBLE PRECISION TWO PARAMETER (TWO=2.0D0) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D0) C C Statement functions C LOGICAL ITRG C C Local variables C CHARACTER*4 LABEL4 CHARACTER*2 NA CHARACTER*4 NB INTEGER I,IQF INTEGER ITEST,J INTEGER K,MK,NELEC,NELEC1 INTEGER NN INTEGER IERR INTEGER J1,J2,J3,JBIG INTEGER JX,JXA,JXB,KTAB INTEGER MM,N1,N2,NFULL INTEGER NJ,NOCC,NOPEN INTEGER NQ,NRCUP,NRCUPX,NS LOGICAL OKAY C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C DATA LABEL4/'ANG '/ C----------------------------------------------------------------------- ITRG(J1,J2,J3) = J3.GE.ABS(J1-J2).AND. + J3.LE.J1+J2.AND. + MOD(J1+J2+J3,2).EQ.0 C----------------------------------------------------------------------- NCF = NMAN NW = NWM IF (NCF.GT.MXNC) GOTO 30 IF (NW.GT.MXNW) GOTO 40 C C Card 2a C See description in DATAIN. C DO J = 1,NW C CALL CARDIN (IREAD,IWRITE,0,LABEL,1,NH(J),NB,NN,RT,IT,ND) C NP(J) = IT(1) NAK(J) = IT(2) C K = NAK(J) MK = ABS(K) IQF = MK+MK NKJ(J) = IQF-1 NKL(J) = MK+(SIGN(1,K)-1)/2 C IF (NN.EQ.2) THEN DO I = 1,NCF IQ(J,I) = IQF ENDDO ELSEIF (NN.EQ.3) THEN DO I = 1,NCF IQ(J,I) = IT(3) ENDDO ELSEIF (NN.EQ.NCF+2) THEN DO I = 1,NCF IQ(J,I) = IT(I+2) ENDDO ELSE GOTO 20 ENDIF C ENDDO C C Check number of electrons in each CSF C IF (NCF.GT.1) THEN NELEC1 = 0 DO J = 1,NW NELEC1 = NELEC1+IQ(J,1) ENDDO DO I = 2,NCF NELEC = 0 DO J = 1,NW NELEC = NELEC+IQ(J,I) ENDDO IF (NELEC.NE.NELEC1) GOTO 50 ENDDO ENDIF C C Set up array ISPAR defining parity of the CSF C DO I = 1,NCF ISPAR(I) = 1 ITEST = 0 DO J = 1,NW ITEST = ITEST+NKL(J)*IQ(J,I) ENDDO IF (MOD(ITEST,2).NE.0) ISPAR(I)=-1 ENDDO C C ************ C *** ANG **** C ************ C C Card 2b C See description in DATAIN. C CALL CARDIN (IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND) IF (NB.NE.LABEL4) GOTO 60 IF (NN.GT.8) GOTO 20 JTC(10) = 1 JTC(11) = 1 IF (NN.GT.0) THEN DO I = 1,NN J = IT(I) IF (J.LT.1.OR.J.GT.8) GOTO 20 JTC(J) = 1 ENDDO IF (JTC(7).EQ.1) JTC(10)=0 IF (JTC(8).EQ.1) JTC(11)=0 ENDIF C C Set the debug parameters C IBUG1 = JTC(1) IBUG2 = JTC(2) IBUG3 = JTC(3) IBUG4 = JTC(4) IBUG5 = JTC(5) IBUG6 = JTC(6) C C NRCUPX+1 is the maximum number of open shells per configuration C allowed by arrays used in the angular sections of the package C NRCUPX = 8 C C Card 2c C See description in DATAIN. C IERR = 0 C DO I = 1,NCF C JBIG = 1 NOPEN = 0 NJ = 0 NS = 0 C DO J = 1,NW C NFULL = NKJ(J)+1 NQ = IQ(J,I) NOCC = MIN(NQ,NFULL-NQ) C C Set the ICHOP array C C ICHOP(J,I) = 1 ... shell J in CSF I is full C ICHOP(J,I) = -1 ... shell J in CSF I is empty C ICHOP(J,I) = 0 ... shell J in CSF I is open C IF (NOCC.GT.4) GOTO 70 IF (NOCC.GT.2.AND.NFULL.GT.8) GOTO 80 C IF (NOCC.EQ.0) THEN ICHOP(J,I) = 1 IF (NQ.EQ.0) ICHOP(J,I)=-1 ELSE NOPEN = NOPEN+1 ICHOP(J,I) = 0 IF (NOCC.GT.1) NJ = NJ+1 IF (NOCC.EQ.4) NS = NS+1 ENDIF C ENDDO C NRCUP = MAX(NOPEN-1,0) IF (NRCUP.GT.NRCUPX) GOTO 110 C N1 = NRCUP+NJ+1 N2 = N1+NS MM = 0 NN = 0 C IF (N2.GT.1) THEN CALL CARDIN (IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (I.NE.IT(1).OR.NN.LT.N1.OR.NN.GT.N2) GOTO 90 MM = 1 ENDIF C DO J = 1,NW C NFULL = NKJ(J)+1 NQ = IQ(J,I) NOCC = MIN(NQ,NFULL-NQ) JQS(2,J,I) = 0 C IF (NOCC.EQ.0) THEN JQS(1,J,I) = 0 JQS(3,J,I) = 1 ELSEIF (NOCC.EQ.1) THEN JQS(1,J,I) = 1 JQS(3,J,I) = NFULL JBIG = NFULL ELSE C MM = MM+1 JBIG = INT(TWO*RT(MM)+EPS)+1 KTAB = 1+NOCC+(NFULL*(NFULL-2))/8 JXA = ITAB(KTAB) JXB = JTAB(KTAB) OKAY = .FALSE. DO JX = 1,JXA JXB = JXB+3 IF (JBIG.EQ.NTAB(JXB)) OKAY = .TRUE. ENDDO C IF (.NOT.OKAY) THEN IERR = IERR+1 WRITE (IWRITE,3100) J GOTO 10 ENDIF C JQS(3,J,I) = JBIG C IF (NOCC.EQ.2) THEN JQS(1,J,I) = 2 IF (JBIG.EQ.1) JQS(1,J,I)=0 ELSEIF (NOCC.EQ.3) THEN JQS(1,J,I) = 3 IF (JBIG.EQ.NFULL) JQS(1,J,I)=1 ELSEIF (NOCC.EQ.4) THEN IF (JBIG.EQ.5.OR.JBIG.EQ.9) THEN MM = MM+1 JQS(1,J,I) = IT(MM) JXB = JTAB(KTAB) OKAY = .FALSE. DO JX = 1,JXA JXB = JXB+3 IF (JBIG.EQ.NTAB(JXB).AND. + IT(MM).EQ.NTAB(JXB-2)) OKAY = .TRUE. ENDDO IF (.NOT.OKAY) THEN IERR = IERR+1 WRITE (IWRITE,3110) J GOTO 10 ENDIF ELSE JQS(1,J,I) = 4 IF (JBIG.EQ.1 ) JQS(1,J,I)=0 IF (JBIG.EQ.13) JQS(1,J,I)=2 ENDIF ENDIF C ENDIF C ENDDO C IF (NRCUP.GT.0) THEN DO J = 1,NRCUP MM = MM+1 JCUP(J,I) = INT(TWO*RT(MM)+EPS)+1 ENDDO JBIG = JCUP(NRCUP,I) ENDIF C C Set the ITJPO array C ITJPO(I) = JBIG C IF (MM.NE.NN) GOTO 100 C C Check if the coupling scheme is consistent C IF (NRCUP.GT.0) THEN MM = -1 J1 = 0 J2 = 0 J3 = 0 DO J = 1,NW NFULL = NKJ(J)+1 NQ = IQ(J,I) NOCC = MIN(NQ,NFULL-NQ) IF (NOCC.GT.0) THEN J2 = JQS(3,J,I)-1 IF (MM.LT.0) THEN MM = MM+1 J1 = J2 ELSE MM = MM+1 J3 = JCUP(MM,I)-1 IF (.NOT.ITRG(J1,J2,J3)) THEN WRITE (IWRITE,3090) I IERR = IERR+1 ENDIF J1 = J3 ENDIF ENDIF ENDDO ENDIF C 10 CONTINUE C ENDDO C IF (IERR.GT.0) THEN WRITE (IWRITE,3130) STOP ENDIF C RETURN C C Error messages C 20 CONTINUE WRITE (IWRITE,3000) STOP 30 CONTINUE WRITE (IWRITE,3010) STOP 40 CONTINUE WRITE (IWRITE,3020) STOP 50 CONTINUE WRITE (IWRITE,3030) STOP 60 CONTINUE WRITE (IWRITE,3040) STOP 70 CONTINUE WRITE (IWRITE,3050) NOCC STOP 80 CONTINUE WRITE (IWRITE,3060) NKJ(J),NOCC STOP 90 CONTINUE WRITE (IWRITE,3070) I,N1,N2 STOP 100 CONTINUE WRITE (IWRITE,3080) MM STOP 110 CONTINUE WRITE (IWRITE,3120) I STOP C 3000 FORMAT ( +/' Stopping in routine DATR.' +/' Error on above data card.') 3010 FORMAT ( +/' Stopping in routine DATR.' +/' Dimension error for NCF.') 3020 FORMAT ( +/' Stopping in routine DATR.' +/' Dimension error for NW.') 3030 FORMAT ( +/' Stopping in routine DATR.'/ +/' Inconsistency in the number of electrons.' +/' Check orbital data.') 3040 FORMAT ( +/' Stopping in routine DATR.' +/' Label ANG not found.' +/' Check input data.') 3050 FORMAT ( +/' Stopping in routine DATR.' +/' Program cannot handle shells with NOCC = ',I2) 3060 FORMAT ( +/' Stopping in routine DATR.' +/' Program cannot handle shells with 2J = ',I2,' and NOCC = ',I2) 3070 FORMAT ( +/' Stopping in routine DATR.' +/' Expect card for CSF ',I2, +' with between ',I2,' and ',I2,' numbers') 3080 FORMAT ( +/' Stopping in routine DATR.' +/1X,I2,' numbers expected') 3090 FORMAT ( +/' Incorrect coupling for CSF ',I2) 3100 FORMAT ( +/' Incorrect J value for subshell ',I2) 3110 FORMAT ( +/' Incorrect seniority for subshell ',I2) 3120 FORMAT ( +/' Stopping in routine DATR.'/ +/' Too many open shells for CSF ',I2) 3130 FORMAT ( +/' Stopping in routine DATR.') END C C ******************* C SUBROUTINE DATSCF(RT,IT,ND,NCN,IR2,IR3,IP3) C C----------------------------------------------------------------------- C C Input data for the MCDF program C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS30 PARAMETER (EPS30=1.D-30) C C---------- NPARMX - max. no. of nuclear parameters C INTEGER NPARMX PARAMETER (NPARMX=4) C C Argument variables C INTEGER NCN,ND DOUBLE PRECISION RT(ND) INTEGER IP3,IR2,IR3,IT(ND) C C Local variables C CHARACTER*4 LAB(7) CHARACTER*2 NA CHARACTER*4 NB,NTY(5) DOUBLE PRECISION CON,SCR,WA INTEGER I,II,IMARK(7),J INTEGER JJ,LLR,LUP,NN C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C INTEGER LABEL COMMON / CARD / LABEL C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C DOUBLE PRECISION XCAX COMMON / CONVG / XCAX C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C DOUBLE PRECISION CHECK INTEGER NITIT COMMON / DEF04 / CHECK,NITIT C DOUBLE PRECISION WT(MXNC) INTEGER ITY COMMON / DEF05 / WT,ITY C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C INTEGER NBPAR,NCPAR,NMOTYP COMMON / MPAR1 / NMOTYP,NBPAR,NCPAR C DOUBLE PRECISION APAR,BBPAR(4),BPAR(4) DOUBLE PRECISION CCPAR(4),CPAR(4) COMMON / MPAR2 / APAR,BPAR,BBPAR,CPAR,CCPAR c double precision fx integer istatx,npmin0 common /nrbinf/fx,istatx,npmin0 C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C INTEGER IPOS(MXNW),KPOS(4,MXNC) INTEGER NPOS(MXNC) COMMON / NRD04 / IPOS,NPOS,KPOS C INTEGER ITC(50) COMMON / OPT01 / ITC C DOUBLE PRECISION CXP(MXNW) COMMON / ORB03 / CXP C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C INTEGER NPOTYP COMMON / PPAR1 / NPOTYP C DOUBLE PRECISION POLPAR(2) COMMON / PPAR2 / POLPAR C INTEGER ILO(MXNW),IWO(MXNW),NWO COMMON / WRO / NWO,IWO,ILO C DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA NTY/'AL ','EAL ','EOL ','OL ','CI '/ DATA LAB/'VNUC','FIX ','LOAD','ORB ','SCR ','VMOD','VPOL'/ C----------------------------------------------------------------------- C C Input record 10 --- Dataset I/O stream numbers. C CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.GT.3) GOTO 210 IR2 = 0 IR3 = 0 IP3 = 0 IF (NN.GT.0) IR2 = IT(1) IF (NN.GT.1) IR3 = IT(2) IF (NN.GT.2) IP3 = IT(3) C C Input record 11 --- Basic data. C CALL CARDIN(IREAD,IWRITE,0,LABEL,0,NA,NB,NN,RT,IT,ND) IF (NN.EQ.0 .OR. NN.GT.9) GOTO 210 Z = RT(1) H = 0.05D0 RNT = 1.0D-05 ACCY = 1.0D-08 CON = ONE XCAX = ONE fx=three istatx=0 npmin0=9999 C GOTO (60,50,40,30,20,10,9,8,7),NN C 7 continue if(it(9).gt.0)npmin0=it(9) 8 continue istatx=it(8) 9 continue if(rt(7).ge.one)fx=rt(7) 10 CONTINUE XCAX = RT(6) 20 CONTINUE IF (RT(5).GT.EPS30) CON = RT(5) 30 CONTINUE IF (RT(4).GT.EPS30) ACCY = RT(4) 40 CONTINUE IF (RT(3).GT.EPS30) RNT = RT(3) 50 CONTINUE IF (RT(2).GT.EPS30) H = RT(2) C 60 CONTINUE C = XCL IF (ITC(25).EQ.1) CON=1.D4 C = C*CON C EPH = EXP(H) NW1 = NW+1 C C Optional input records. C NUCTYP = 0 NPOTYP = 0 NMOTYP = 0 NPARM = 0 NWO = 0 DO J = 1,NW JFIX(J) = 0 ILO(J) = 0 IWO(J) = 0 ENDDO C IF (ITC(33).EQ.1) THEN DO J = 1,NW CXP(J) = ZERO ENDDO ELSE DO J = 1,NW SCR = ZERO DO I = 1,NW IF (NP(I)-NP(J)) 80,70,90 70 CONTINUE IF (NKL(I)-NKL(J)) 80,90,90 80 CONTINUE SCR = SCR+IQ(I,1) 90 CONTINUE ENDDO CXP(J) = SCR ENDDO ENDIF C DO I = 1,7 IMARK(I) = 0 ENDDO C 100 CONTINUE CALL CARDIN(IREAD,IWRITE,0,LABEL,2,NA,NB,NN,RT,IT,ND) IF (NB.EQ.LAB(1)) GOTO 110 IF (NB.EQ.LAB(2)) GOTO 130 IF (NB.EQ.LAB(3)) GOTO 140 IF (NB.EQ.LAB(4)) GOTO 150 IF (NB.EQ.LAB(5)) GOTO 160 IF (NB.EQ.LAB(6)) GOTO 170 IF (NB.EQ.LAB(7)) GOTO 180 IF (NB.EQ.NTY(1) .OR. NB.EQ.NTY(2) + .OR. NB.EQ.NTY(3) + .OR. NB.EQ.NTY(4) + .OR. NB.EQ.NTY(5)) GOTO 190 GOTO 210 C C Input record 12 --- OPTIONAL --- Nuclear Type C 110 CONTINUE IF (IMARK(1).EQ.1) GOTO 210 IF (NN.LT.1 .OR. NN.GT.NPARMX+1) GOTO 210 NUCTYP = IT(1) IF (NUCTYP.EQ.0) GOTO 120 NPARM = NN-1 C IF (NUCTYP.EQ.1) THEN IF (NPARM.GT.1) GOTO 210 IF (NPARM.EQ.0) THEN PARM(1) = ATW ELSE PARM(1) = RT(2) ENDIF NPARM = 1 GOTO 120 ENDIF C IF (NUCTYP.EQ.2) THEN IF (NPARM.GT.2) GOTO 210 IF (NPARM.EQ.0) THEN IF (ATW.EQ.ZERO) GOTO 210 PARM(1) = 2.2291D-05*(ATW**(ONE/THREE))-0.90676D-05 PARM(2) = 1.039D-05 ELSE IF (NPARM.EQ.1) THEN PARM(1) = RT(2) PARM(2) = 1.039D-05 ELSE PARM(1) = RT(2) PARM(2) = RT(3) ENDIF ENDIF NPARM = 2 GOTO 120 ENDIF C IF (NPARM.GT.0) THEN DO I = 1,NPARM PARM(I) = RT(I+1) ENDDO ENDIF C 120 CONTINUE IMARK(1) = 1 GOTO 100 C C Input record 13 --- OPTIONAL --- Fixed Orbitals C 130 CONTINUE IF (IMARK(2).EQ.1) GOTO 210 IF (NN.EQ.0 .OR. NN.GT.NW) GOTO 210 !Was NW-1. Allow for CI check DO J = 1,NN I = IT(J) JFIX(I) = 1 ENDDO IMARK(2) = 1 GOTO 100 C C Input record 14 --- OPTIONAL --- Source of orbitals. C 140 CONTINUE IF (IMARK(3).EQ.1) GOTO 210 IF (NN.NE.NW) GOTO 210 DO J = 1,NW ILO(J) = IT(J) ENDDO IMARK(3) = 1 GOTO 100 C C Input record 15 --- OPTIONAL --- Orbitals to be dumped C 150 CONTINUE IF (IMARK(4).EQ.1) GOTO 210 IF (NN.GT.NW) GOTO 210 IF (IP3.EQ.0) GOTO 210 C IF (NN.GT.0) THEN DO J = 1,NN I = IT(J) IF (JFIX(I).EQ.0) THEN NWO = NWO+1 IWO(NWO) = I ENDIF ENDDO ENDIF C IMARK(4) = 1 GOTO 100 C C Input record 16 --- OPTIONAL --- Orbital Screening C 160 CONTINUE IF (IMARK(5).EQ.1) GOTO 210 IF (NN.NE.NW) GOTO 210 DO J = 1,NN CXP(J) = RT(J) ENDDO IMARK(5) = 1 GOTO 100 C C Input record 17 --- OPTIONAL --- Polarisation Potential C 170 CONTINUE IF (IMARK(6).EQ.1) GOTO 210 IF (NN.LT.1) GOTO 210 NPOTYP = IT(1) IF (NPOTYP.NE.0) THEN IF (NPOTYP.NE.1) GOTO 210 IF (NN.LT.3) GOTO 210 POLPAR(1) = RT(2) POLPAR(2) = RT(3) ENDIF IMARK(6) = 1 GOTO 100 C C Input record 18 --- OPTIONAL --- Model Potential C 180 CONTINUE IF (IMARK(7).EQ.1) GOTO 210 IF (NN.LT.1) GOTO 210 NMOTYP = IT(1) C IF (NMOTYP.NE.0) THEN C IF (NMOTYP.NE.1) GOTO 210 IF (NN.LT.3) GOTO 210 NBPAR = IT(2) NCPAR = IT(3) C IF (NN.NE.4+2*NBPAR+2*NCPAR) GOTO 210 IF (NBPAR.GT.4) GOTO 210 IF (NCPAR.GT.4) GOTO 210 C APAR = RT(3) C DO I = 1,NBPAR BPAR(I) = RT(4+I) ENDDO DO I = 1,NBPAR BBPAR(I) = RT(4+NBPAR+I) ENDDO DO I = 1,NCPAR CPAR(I) = RT(4+NBPAR+NBPAR+I) ENDDO DO I = 1,NCPAR CCPAR(I) = RT(4+NBPAR+NBPAR+NCPAR+I) ENDDO C ENDIF C IMARK(7) = 1 GOTO 100 C C Input record 19 --- Calculation type C 190 CONTINUE ITY = 1 NCMIN = 0 NITIT = 3 C C CI calculation C IF (NB.EQ.NTY(5)) THEN IF (NN.GT.0) GOTO 210 NITIT = 0 GOTO 200 ENDIF C C Average level calculation C IF (NB.EQ.NTY(1)) THEN IF (NN.EQ.0) GOTO 200 IF (NN.GT.1) GOTO 210 NITIT = IT(1) GOTO 200 ENDIF C C Extended average level calculation C IF (NB.EQ.NTY(2)) THEN C ITY = 2 IF (NN.GT.NCF+1) GOTO 210 C IF (NN.EQ.0 .OR. NN.EQ.1) THEN IF (NN.EQ.1) NITIT = IT(1) DO I = 1,NCF WT(I) = DBLE(ITJPO(I)) ENDDO GOTO 200 ENDIF C IF (NN.EQ.NCF .OR. NN.EQ.NCF+1) THEN IF (NN.EQ.NCF+1) NITIT = IT(NCF+1) DO I = 1,NCF WT(I) = RT(I) ENDDO GOTO 200 ENDIF C IF (NN.EQ.NCN .OR. NN.EQ.NCN+1) THEN IF (NN.EQ.NCN+1) NITIT = IT(NCN+1) LLR = 1 DO J = 1,NCN LUP = NPOS(J) WA = RT(J) DO I = LLR,LUP WT(I) = WA ENDDO LLR = LUP+1 ENDDO GOTO 200 ELSE GOTO 210 ENDIF C ENDIF C C Extended optimal level or optimal level calculation C NITIT = 6 CHECK = 0.15D0 ITY = 3 C IF (NB.EQ.NTY(3)) THEN IF (NN.GT.NCF+3) GOTO 210 NCMIN = IT(1) II = NCMIN+1 JJ = 1 ELSE IF (NB.NE.NTY(4)) GOTO 210 IF (NN.GT.3 .OR. NN.LT.1) GOTO 210 NCMIN = 1 II = 1 JJ = 0 ENDIF C IF (NN.LT.II .OR. NN.GT.II+2) GOTO 210 DO I = 1,NCMIN ICCMIN(I) = IT(I+JJ) ENDDO C IF (NN.EQ.II) GOTO 200 NITIT = IT(II+1) IF (NN.EQ.II+1) GOTO 200 CHECK = RT(II+2) C 200 CONTINUE IF (NCF.EQ.1) NCMIN = 0 RETURN C C Error message C 210 CONTINUE WRITE (IWRITE,3000) STOP C 3000 FORMAT (/' ERROR in DATSCF : on above input record ... STOPPING') END C C ******************* C SUBROUTINE DIMPRT C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) C IF (NAXDIM(2).GT.0) THEN WRITE (IWRITE,3010) MAXDIM(2),NAXDIM(2) ENDIF C IF (NAXDIM(5).GT.0) THEN WRITE (IWRITE,3020) MAXDIM(5),NAXDIM(5) ENDIF C IF (NAXDIM(17).GT.0) THEN WRITE (IWRITE,3030) MAXDIM(17),NAXDIM(17) ENDIF C IF (NAXDIM(4).GT.0) THEN WRITE (IWRITE,3040) MAXDIM(4),NAXDIM(4) ENDIF C IF (NAXDIM(3).GT.0) THEN WRITE (IWRITE,3050) MAXDIM(3),NAXDIM(3) ENDIF C IF (NAXDIM(7).GT.0) THEN WRITE (IWRITE,3060) MAXDIM(7),NAXDIM(7) ENDIF C IF (NAXDIM(1).GT.0) THEN WRITE (IWRITE,3070) MAXDIM(1),NAXDIM(1) ENDIF C IF (NAXDIM(9).GT.0) THEN WRITE (IWRITE,3080) MAXDIM(9),NAXDIM(9) ENDIF C 3000 FORMAT (/' >>>> routine DIMPRT called'// ! +' dimension max. used max. set'! +/) 3010 FORMAT (' NC relativistic CSFs ',3X,I10,9X,I10) 3020 FORMAT (' NE exchange terms ',3X,I10,9X,I10) 3030 FORMAT (' NG radial grid points for /WAVE/ ',3X,I10,9X,I10) 3040 FORMAT (' NM angular coefficients ',3X,I10,9X,I10) 3050 FORMAT (' NO Lagrange multipliers ',3X,I10,9X,I10) 3060 FORMAT (' NP radial grid points ',3X,I10,9X,I10) 3070 FORMAT (' NW relativistic orbitals ',3X,I10,9X,I10) 3080 FORMAT (' NX dimension for EOL (=1 for AL,OL ',3X,I10,9X,I10) END C C ******************* C SUBROUTINE DIMSET(IWRITE) C C----------------------------------------------------------------------- C C This routine sets the dimensions for the code. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER IWRITE C C Local variables C INTEGER I C C Common variables C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO I = 1,20 MAXDIM(I) = 0 NAXDIM(I) = 0 ENDDO C NAXDIM(1) = MXNW NAXDIM(2) = MXNC NAXDIM(3) = MXNO NAXDIM(4) = MXNM NAXDIM(5) = MXNE NAXDIM(7) = MXNP NAXDIM(9) = MXNX NAXDIM(17) = MXNG C C The following code writes out information on the processed C version of the code. C WRITE (IWRITE,3000) WRITE (IWRITE,3020) WRITE (IWRITE,3030) MXNC WRITE (IWRITE,3040) MXNE WRITE (IWRITE,3050) MXNG WRITE (IWRITE,3060) MXNM WRITE (IWRITE,3070) MXNO WRITE (IWRITE,3080) MXNP WRITE (IWRITE,3090) MXNW WRITE (IWRITE,3100) MXNX WRITE (IWRITE,3010) C 3000 FORMAT (/1X,71('*')/ ! +' routine DIMSET : the code has been dimensioned as follows'/1X,71! +('*')) 3010 FORMAT (/1X,71('*')) 3020 FORMAT (/' The following dimensions have been set :'/) 3030 FORMAT (1X,I10,' = NC relativistic CSFs') 3040 FORMAT (1X,I10,' = NE exchange terms') 3050 FORMAT (1X,I10,' = NG radial grid points for /WAVE/') 3060 FORMAT (1X,I10,' = NM angular coefficients') 3070 FORMAT (1X,I10,' = NO Lagrange multipliers') 3080 FORMAT (1X,I10,' = NP radial grid points') 3090 FORMAT (1X,I10,' = NW relativistic orbitals') 3100 FORMAT (1X,I10,' = NX dimension for EOL (=1 for AL,EAL,OL)') END C C ******************* C SUBROUTINE DRACAH(I,J,K,L,M,N,RAC) C C----------------------------------------------------------------------- C C Evaluates Racah coefficient C C----------------------------------------------------------------------- C C This table shows results from calling DRACAH for all values of the C arguments from 0 to jmax. C numc --- number of coefficients calculated C numr --- number of coefficients read from table C numsto --- number of non-zero coefficients stored C (only non-zero coefficients are stored in aray XSTO) C If you choose MXNY to be one of these jmax values then C numsto would be the dimension required for array XSTO. C C jmax : 0 numc : 1 numr : 0 numsto : 1 C jmax : 1 numc : 19 numr : 45 numsto : 4 C jmax : 2 numc : 144 numr : 585 numsto : 17 C jmax : 3 numc : 676 numr : 3420 numsto : 48 C jmax : 4 numc : 2350 numr : 13275 numsto : 128 C jmax : 5 numc : 6651 numr : 40005 numsto : 288 C jmax : 6 numc : 16219 numr : 101430 numsto : 613 C jmax : 7 numc : 35344 numr : 226800 numsto : 1176 C jmax : 8 numc : 70551 numr : 460890 numsto : 2171 C jmax : 9 numc : 131275 numr : 868725 numsto : 3757 C jmax :10 numc : 230626 numr : 1540935 numsto : 6273 C C MXNY = NY dimension used for table in DRACAH C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE C C Parameter variables C INTEGER MXNY PARAMETER (MXNY=8) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) C C Argument variables C INTEGER I,J,K,L INTEGER M,N DOUBLE PRECISION RAC C C Local variables C DOUBLE PRECISION RAC1,RAC2 INTEGER ICODE,ICOUNT,IMARK,J1 INTEGER J2,J3,J4,J5 INTEGER J6,J7,KI,KK INTEGER NUMAX,NUMIN C C Common variables C DOUBLE PRECISION GAM(500) COMMON / RACAHG / GAM C C Common variables C DOUBLE PRECISION XSTO(2171) COMMON / RACAHS / XSTO C C Common variables C INTEGER*2 ISTO(0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY) COMMON / RACAHT / ISTO C C Common variables C INTEGER NUMC,NUMR,NUMSTO COMMON / RACAHV / NUMC,NUMR,NUMSTO C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IF (I.LE.MXNY .AND. J.LE.MXNY .AND. + K.LE.MXNY .AND. L.LE.MXNY .AND. + M.LE.MXNY .AND. N.LE.MXNY) THEN C IF (ISTO(I,J,K,L,M,N).GE.0) THEN ICODE = ISTO(I,J,K,L,M,N) IF (ICODE.EQ.0) THEN RAC = ZERO ELSE RAC = XSTO(ICODE) ENDIF NUMR = NUMR+1 GOTO 20 ENDIF C IMARK = 1 ELSE IMARK = 0 ENDIF C----------------------------------------------------------------------- C C Test the triangular conditions C C----------------------------------------------------------------------- RAC = ZERO C J1 = I+J+M IF ((2*MAX(I,J,M)-J1).GT.0 .OR. MOD(J1,2).NE.0) GOTO 10 J2 = K+L+M IF ((2*MAX(K,L,M)-J2).GT.0 .OR. MOD(J2,2).NE.0) GOTO 10 J3 = I+K+N IF ((2*MAX(I,K,N)-J3).GT.0 .OR. MOD(J3,2).NE.0) GOTO 10 J4 = J+L+N IF ((2*MAX(J,L,N)-J4).GT.0 .OR. MOD(J4,2).NE.0) GOTO 10 C J1 = J1/2 J2 = J2/2 J3 = J3/2 J4 = J4/2 J5 = (I+J+K+L)/2 J6 = (I+L+M+N)/2 J7 = (J+K+M+N)/2 C NUMIN = MAX(J1,J2,J3,J4)+1 NUMAX = MIN(J5,J6,J7)+1 RAC = ONE C IF (NUMIN.NE.NUMAX) THEN NUMIN = NUMIN+1 ICOUNT = 0 DO KK = NUMIN,NUMAX KI = NUMAX-ICOUNT RAC1 = KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2) RAC2 = (KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4) RAC = ONE-(RAC*RAC1/RAC2) ICOUNT = ICOUNT+1 ENDDO NUMIN = NUMIN-1 ENDIF C RAC = RAC*((-ONE)**(J5+NUMIN+1))*EXP((GAM(NUMIN+1)-GAM(NUMIN-J1)-G! +AM(NUMIN-J2)-GAM(NUMIN-J3)-GAM(NUMIN-J4)-GAM(J5+2-NUMIN)-GAM(J6+2-! +NUMIN)-GAM(J7+2-NUMIN))+((GAM(J1+1-I)+GAM(J1+1-J)+GAM(J1+1-M)-GAM(! +J1+2)+GAM(J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M)-GAM(J2+2)+GAM(J3+1-I)+GA! +M(J3+1-K)+GAM(J3+1-N)-GAM(J3+2)+GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N! +)-GAM(J4+2))/TWO)) C----------------------------------------------------------------------- 10 CONTINUE NUMC = NUMC+1 IF (IMARK.EQ.1) THEN C IF (ABS(RAC).GT.EPS10) THEN IF (NUMSTO.EQ.2171) GOTO 20 NUMSTO = NUMSTO+1 XSTO(NUMSTO) = RAC ICODE = NUMSTO ELSE ICODE = 0 ENDIF C ISTO(I,J,K,L,M,N) = ICODE ISTO(L,K,J,I,M,N) = ICODE ISTO(L,J,K,I,N,M) = ICODE ISTO(I,K,J,L,N,M) = ICODE ISTO(J,I,L,K,M,N) = ICODE ISTO(K,L,I,J,M,N) = ICODE ISTO(K,I,L,J,N,M) = ICODE ISTO(J,L,I,K,N,M) = ICODE C ENDIF C----------------------------------------------------------------------- 20 CONTINUE END C C ******************* C SUBROUTINE DUMP(IC,IP2) C C----------------------------------------------------------------------- C C Dump to file with DS number IP2. C C No routines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER N10 PARAMETER (N10=MXNX*MXNC) C C Argument variables C INTEGER IC,IP2 C C Local variables C DOUBLE PRECISION ZX INTEGER I,IJ,J,K INTEGER NCFTT,NGRID C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C DOUBLE PRECISION ECV(MXNO) INTEGER IECC(MXNO),NEC COMMON / OFFD / ECV,IECC,NEC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IP2.EQ.0) RETURN C REWIND IP2 C----------------------------------------------------------------------- IF (IC.EQ.0) THEN C C...marks unconverged dump C ZX = -Z C ELSE ZX = Z ENDIF C----------------------------------------------------------------------- WRITE (IP2) IHED,RECORD WRITE (IP2) NCMIN,NW,NCF,N WRITE (IP2) ZX,RNT,H,C C----------------------------------------------------------------------- DO I = 1,NW C NGRID = MPOIN(I) IJ = MPOS(I) C DO J = 1,NGRID P(J) = PF(IJ) Q(J) = QF(IJ) IJ = IJ+1 ENDDO C IF (N.GT.NGRID) THEN DO J = NGRID+1,N P(J) = ZERO Q(J) = ZERO ENDDO ENDIF C WRITE (IP2) NH(I),NP(I),NAK(I),E(I) WRITE (IP2) PZ(I),QZ(I) WRITE (IP2) (P(J),J=1,N), (Q(J),J=1,N) C ENDDO C----------------------------------------------------------------------- WRITE (IP2) (COUENG(I),I=1,NCF) WRITE (IP2) (UCF(I),I=1,NW) IF (NCMIN.GT.0) THEN NCFTT = NCF*NCMIN WRITE (IP2) (CCR(I),I=1,NCFTT) WRITE (IP2) (ICCMIN(I),I=1,NCMIN) ENDIF C----------------------------------------------------------------------- WRITE (IP2) ((IQ(I,J),J=1,NCF),I=1,NW) WRITE (IP2) EAV, ((COUVEC(I,J),J=1,NCF),I=1,NCF),(BREENG(I),I=1,NC! +F) C----------------------------------------------------------------------- WRITE (IP2) NEC IF (NEC.GT.0) WRITE (IP2) (IECC(I),I=1,NEC), (ECV(I),I=1,NEC) C----------------------------------------------------------------------- WRITE (IP2) NUCTYP WRITE (IP2) (ZZ(I),I=1,N) WRITE (IP2) Z1 WRITE (IP2) NPARM IF (NPARM.GT.0) WRITE (IP2) (PARM(I),I=1,NPARM) C----------------------------------------------------------------------- WRITE (IP2) ((ICHOP(I,J),I=1,NW),J=1,NCF) WRITE (IP2) (((JQS(K,I,J),I=1,NW),J=1,NCF),K=1,3) WRITE (IP2) ((JCUP(I,J),I=1,8),J=1,NCF) WRITE (IP2) (ITJPO(J),J=1,NCF) WRITE (IP2) (ISPAR(J),J=1,NCF) C----------------------------------------------------------------------- REWIND IP2 C----------------------------------------------------------------------- WRITE (IWRITE,3000) C----------------------------------------------------------------------- 3000 FORMAT (/' >>>> MCDF dump written') END C C ******************* C SUBROUTINE DUMPB(IO6) C C----------------------------------------------------------------------- C C This routine writes a BENA dump in a form which can be C read by the routine LOAD and used in OSCL. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER IO6 C C Local variables C INTEGER I,IJ,J,NEC INTEGER NGRID C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C write basic information C C----------------------------------------------------------------------- REWIND IO6 WRITE (IO6) IHED,RECORD WRITE (IO6) NCMIN,NW,NCF,N WRITE (IO6) Z,RNT,H,C C----------------------------------------------------------------------- C C write orbital information C C----------------------------------------------------------------------- DO I = 1,NW NGRID = MPOIN(I) IJ = MPOS(I) DO J = 1,NGRID TA(J) = PF(IJ) TB(J) = QF(IJ) IJ = IJ+1 ENDDO IF (N.GT.NGRID) THEN DO J = NGRID+1,N TA(J) = ZERO TB(J) = ZERO ENDDO ENDIF WRITE (IO6) NH(I),NP(I),NAK(I),E(I) WRITE (IO6) WRITE (IO6) (TA(J),J=1,N), (TB(J),J=1,N) ENDDO C----------------------------------------------------------------------- C C write generalised occupation and mixing numbers C C----------------------------------------------------------------------- WRITE (IO6) WRITE (IO6) (UCF(I),I=1,NW) IF (NCMIN.GT.0) THEN WRITE (IO6) WRITE (IO6) (ICCMIN(I),I=1,NCMIN) ENDIF C----------------------------------------------------------------------- C C write occupation numbers and eigenvectors C C----------------------------------------------------------------------- EAV = ZERO WRITE (IO6) ((IQ(I,J),J=1,NCF),I=1,NW) WRITE (IO6) EAV, ((COUVEC(I,J),J=1,NCF),I=1,NCF),(COUENG(I),I=1,NC! +F) C----------------------------------------------------------------------- C C skip over Lagrange multipliers C C----------------------------------------------------------------------- NEC = 0 WRITE (IO6) NEC C----------------------------------------------------------------------- C C write nuclear information C C----------------------------------------------------------------------- WRITE (IO6) NUCTYP WRITE (IO6) (ZZ(I),I=1,N) WRITE (IO6) Z1 WRITE (IO6) NPARM IF (NPARM.GT.0) THEN WRITE (IO6) (PARM(I),I=1,NPARM) ENDIF C----------------------------------------------------------------------- WRITE (IO6) WRITE (IO6) WRITE (IO6) WRITE (IO6) WRITE (IO6) C----------------------------------------------------------------------- WRITE (IWRITE,3000) C----------------------------------------------------------------------- 3000 FORMAT (/' >>>> BENA dump has been written with the current data') END C C ******************* C FUNCTION EIGENV(J) C C----------------------------------------------------------------------- C C This function computes an estimate of the eigenvalue E(J) C by use of the Rayleigh quotient. The appropriate C functions must be tabulated in the arrays YP, XTP and XTQ, C and the Rayleigh quotient is computed in terms of the C estimated wave functions stored in the arrays PF and QF. C C The derivatives of P(R) and Q(R) are approximated by a C finite difference formula involving 5 consecutive points. C The integrand is therefore taken to be zero at two points C at each end of the table. C C Subroutines called : QUAD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION EIGENV INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZA PARAMETER (ZA=12.D0) DOUBLE PRECISION ZB PARAMETER (ZB=8.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER J C C Local variables C DOUBLE PRECISION RESULT,WA,WC,WD INTEGER I,IJ,L,M INTEGER NGRID,NN C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NGRID = MPOIN(J) M = 2 DO I = 1,M TA(I) = ZERO L = NGRID+1-I TA(L) = ZERO ENDDO C NN = NGRID-M M = M+1 C WC = C+C WA = WC*C WC = WC*NAK(J) WD = C/(ZA*H) C IJ = MPOS(J)+M-1 DO I = M,NN TA(I) = WA*RGRID(I)*QF(IJ)**2+YP(I)*(PF(IJ)**2+QF(IJ)**2)-WC*PF(! +IJ)*QF(IJ)+C*(PF(IJ)*XTQ(I)-QF(IJ)*XTP(I))-WD*(QF(IJ)*(PF(IJ-2)+ZB! +*(PF(IJ+1)-PF(IJ-1))-PF(IJ+2))-PF(IJ)*(QF(IJ-2)+ZB*(QF(IJ+1)-QF(IJ! +-1))-QF(IJ+2))) IJ = IJ+1 ENDDO C CALL QUAD(NGRID,RESULT) EIGENV = RESULT C END C C ******************* C SUBROUTINE ENGOUT(E,N,IWRITE) C C----------------------------------------------------------------------- C C This routine prints energy levels in a.u., cm-1, and eV using the C correct value for the Rydberg. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C DOUBLE PRECISION E(MXNC) INTEGER IWRITE,N C C Local variables C DOUBLE PRECISION EAU,ECM,EEV INTEGER I C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) C DO I = 1,N EAU = E(I) ECM = EAU*FACTCM EEV = EAU*FACTEV WRITE (IWRITE,3010) I,EAU,ECM,EEV ENDDO C IF (N.EQ.1) RETURN WRITE (IWRITE,3020) DO I = 2,N EAU = E(I)-E(1) ECM = EAU*FACTCM EEV = EAU*FACTEV WRITE (IWRITE,3010) I,EAU,ECM,EEV ENDDO C 3000 FORMAT (//' Eigenenergies'// ! +' Level a.u. cm-1 eV'/) 3010 FORMAT (1X,I4,4X,1P,3E20.10) 3020 FORMAT (//' Eigenenergies relative to the lowest'// ! +' Level a.u. cm-1 eV'/) END C C ******************* C SUBROUTINE FACTT C C----------------------------------------------------------------------- C C Calculates the logs of factorials required by the Racah coefficient C routine DRACAH C C----------------------------------------------------------------------- C MXNY = NY dimension used for table in DRACAH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE C C Parameter variables C INTEGER MXNY PARAMETER (MXNY=8) DOUBLE PRECISION THIRTY PARAMETER (THIRTY=3.D1) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) C C Local variables C DOUBLE PRECISION X INTEGER I,J,K,L INTEGER M,N C C Common variables C DOUBLE PRECISION GAM(500) COMMON / RACAHG / GAM C C Common variables C INTEGER*2 ISTO(0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY,0:MXNY) COMMON / RACAHT / ISTO C C Common variables C INTEGER NUMC,NUMR,NUMSTO COMMON / RACAHV / NUMC,NUMR,NUMSTO C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc GAM(1) = ONE GAM(2) = ONE X = TWO DO I = 3,30 GAM(I) = GAM(I-1)*X X = X+ONE ENDDO DO I = 1,30 GAM(I) = LOG(GAM(I)) ENDDO X = THIRTY DO I = 31,500 GAM(I) = GAM(I-1)+LOG(X) X = X+ONE ENDDO C IF (NUMSTO.EQ.0) THEN DO I = 0,MXNY DO J = 0,MXNY DO K = 0,MXNY DO L = 0,MXNY DO M = 0,MXNY DO N = 0,MXNY ISTO(I,J,K,L,M,N) = -1 ENDDO ENDDO ENDDO ENDDO ENDDO ENDDO ENDIF C END C C ******************* C SUBROUTINE FIXJ(JA1,JA2,KA,IS,KS,NS,KJ23) C C----------------------------------------------------------------------- C C Sets up the arrays J1 ,J2 ,J3 required C by the recoupling package. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IS(2),JA1,JA2,KA INTEGER KJ23,KS(2),NS C C Local variables C INTEGER II,IJ,JAF1,JJ INTEGER JK,JWW,N2,N3 INTEGER NM1,NS1 C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),MMOM,NMOM LOGICAL FREE(MANGM) COMMON / ANG00 / MMOM,NMOM,J1,J2,J3,FREE C C Common variables C INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW) INTEGER JTQ1(3),JTQ2(3) COMMON / ANG08 / JBQ1,JBQ2,JTQ1,JTQ2 C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C SET UP THE J2 AND J3 ARRAYS C C----------------------------------------------------------------------- NM1 = NS-1 IF (KJ23.EQ.1) GOTO 30 NS1 = NS+1 N2 = NS+NS N3 = N2+NS C J2(1,1) = N3+2 J2(1,2) = N3+3 J2(1,3) = N3+1 J2(2,1) = JA1 J2(2,2) = N3+1 J2(2,3) = N3-1 C J3(1,1) = JA2 J3(1,2) = N3+2 J3(1,3) = N3 C IF (NS.EQ.1) GOTO 20 C DO JWW = 1,NM1 JJ = JWW+2 J2(JJ,1) = NS+JWW-1 J2(JJ,2) = JWW+1 J2(JJ,3) = NS+JWW C JK = JWW+1 J3(JK,1) = N2+JWW-2 J3(JK,2) = JWW+1 J3(JK,3) = N2+JWW-1 ENDDO C J2(3,1) = 1 IF (JA1.EQ.1) J2(3,1) = N3 - 1 C J3(2,1) = 1 IF (JA2.EQ.1) J3(2,1) = N3 C J2(NS1,3) = N2-1 C J3(NS1,1) = N3-2 J3(NS1,2) = N3+3 J3(NS1,3) = N2-1 C IF (JA1.EQ.1) GOTO 10 JAF1 = JA1+1 J2(JAF1,2) = N3-1 C 10 CONTINUE IF (JA2.EQ.1) GOTO 30 J3(JA2,2) = N3 C IF (NS.GT.1) GOTO 30 20 CONTINUE J3(2,1) = N3 J3(2,2) = N3+3 J3(2,3) = N3-1 C----------------------------------------------------------------------- C C SET THE J1 ARRAY C C----------------------------------------------------------------------- 30 CONTINUE II = 0 C DO JWW = 1,NS IJ = JLIST(JWW) II = II+1 J1(II) = JBQ2(3,IJ) ENDDO C IF (NS.EQ.1) GOTO 40 C DO JWW = 1,NM1 II = II+1 J1(II) = JJC1(JWW) ENDDO C DO JWW = 1,NM1 II = II+1 J1(II) = JJC2(JWW) ENDDO C 40 CONTINUE II = II+1 IJ = IS(1) J1(II) = JJQ1(3,IJ) J1(II+2) = KS(1) II = II+1 IJ = IS(2) J1(II) = JJQ2(3,IJ) J1(II+2) = KS(2) C II = II+3 J1(II) = KA+KA+1 MMOM = II NMOM = NS+2 C END C C ******************* C SUBROUTINE FZALF(ZEFF,I,SLFE) C C----------------------------------------------------------------------- C C This routine obtains an estimate of the self energy contribution C to the energy resulting from either 1s, 2s, 2p- or 2p orbital in C the field of a point nucleus with effective charge ZEFF. C The values are interpolated among the values supplied by P.J. Mohr C C Subroutine called: INTRPG C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C DOUBLE PRECISION SLFE,ZEFF INTEGER I C C Local variables C DOUBLE PRECISION ARG(11),VAL1S(11),VAL2P1(11) DOUBLE PRECISION VAL2P3(11),VAL2S(11) INTEGER NUMVAL C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C 1s data : C DATA VAL1S/4.654D0,3.246D0,2.5519D0,2.1351D0,1.8644D0,1.6838D0,1.5! +675D0,1.5032D0,1.4880D0,1.5317D0,1.6614D0/ C C 2s data : C DATA VAL2S/4.8930D0,3.5063D0,2.8391D0,2.4550D0,2.2244D0,2.0948D0,2! +.0435D0,2.0650D0,2.1690D0,2.3870D0,2.7980D0/ C C 2p- data : C DATA VAL2P1/-0.1145D0,-0.0922D0,-0.0641D0,-0.0308D0,0.0082D0,0.054! +9D0,0.1129D0,0.1884D0,0.2934D0,0.4530D0,0.7250D0/ C C 2p data C DATA VAL2P3/0.1303D0,0.1436D0,0.1604D0,0.1794D0,0.1999D0,0.2215D0,! +0.2440D0,0.2671D0,0.2906D0,0.3141D0,0.3367D0/ C C Z data values : C DATA ARG/10.0D0,20.0D0,30.0D0,40.0D0,50.0D0,60.0D0,70.0D0,80.0D0,9! +0.0D0,100.0D0,110.0D0/ C C Number of data points C DATA NUMVAL/11/ C----------------------------------------------------------------------- IF (NP(I).GT.1) GOTO 10 C C 1s case C CALL INTRPG(ARG,VAL1S,ZEFF,NUMVAL,SLFE) RETURN C C ns case C 10 CONTINUE IF (NAK(I).EQ.-1) CALL INTRPG(ARG,VAL2S,ZEFF,NUMVAL,SLFE) C C np- case C IF (NAK(I).EQ.1) CALL INTRPG(ARG,VAL2P1,ZEFF,NUMVAL,SLFE) C C np case C IF (NAK(I).EQ.-2) CALL INTRPG(ARG,VAL2P3,ZEFF,NUMVAL,SLFE) C END C C ******************* C FUNCTION GAMF(XA) C C----------------------------------------------------------------------- C C The value of this function is the gamma function of the C argument XA. C C The recurrence relation for the gamma function is used to C reduce the argument to a corresponding value in the range C (1,2). In this range the Chebyshev series is used, C the coefficients being taken from Chebyshev Series for C Mathematical Functions, by C.W.Clenshaw, Maths Tables Vol 5, C H.M.S.O., London, 1962. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION GAMF C C Parameter variables C DOUBLE PRECISION Z1 PARAMETER (Z1=-.3339646306868D-7) DOUBLE PRECISION Z2 PARAMETER (Z2=.2689759964406D-6) DOUBLE PRECISION Z3 PARAMETER (Z3=.29600117751880D-5) DOUBLE PRECISION Z4 PARAMETER (Z4=-.804814124978471D-4) DOUBLE PRECISION Z5 PARAMETER (Z5=.416609138709689D-3) DOUBLE PRECISION Z6 PARAMETER (Z6=.5065798640286087D-2) DOUBLE PRECISION Z7 PARAMETER (Z7=-.6419254361091582D-1) DOUBLE PRECISION Z8 PARAMETER (Z8=-.498558728684003D-2) DOUBLE PRECISION Z9 PARAMETER (Z9=2.127546015610523D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) C C Argument variables C DOUBLE PRECISION XA C C Local variables C DOUBLE PRECISION WA,WB,WC,WD DOUBLE PRECISION WE,WF INTEGER I,J Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (XA.LE.TWO) GOTO 30 C C For XA greater than 2, reduce successively by 1, accumulating C product in WB. Set link to J=1. C WB = ONE WA = XA-ONE J = INT(WA) DO I = 1,J WB = WB*WA WA = WA-ONE ENDDO J = 1 GOTO 20 C 10 CONTINUE GAMF = WB/(WE-WF) GAMF = GAMF+GAMF RETURN C C Sum Chebyshev series C 20 CONTINUE WC = WA+WA-ONE WC = WC+WC WD = Z1*WC+Z2 WE = WC*WD+Z3 WF = WC*WE-WD+Z4 WD = WC*WF-WE+Z5 WE = WC*WD-WF+Z6 WF = WC*WE-WD+Z7 WD = WC*WF-WE+Z8 WE = WC*WD-WF+Z9 IF (J) 50,50,10 C 30 CONTINUE WB = ONE WA = XA IF (XA.GE.ONE) GOTO 40 C C For arguments less than 1, increase successively by 1, accumulating C product in WB. Set link to J=-1. C J = INT(TWO-XA) DO I = 1,J WB = WB*WA WA = WA+ONE ENDDO C 40 CONTINUE J = -1 WA = WA-ONE GOTO 20 C 50 CONTINUE GAMF = TWO/(WB*(WE-WF)) C END C C ******************* C SUBROUTINE GENI9(IP) C C----------------------------------------------------------------------- C C Determines the number of recoupling necessary to bring J2(I5,I3) C and J2(I6,I4) into the same triad. This will give a triad C identical with one in J3. On exit I9 contains the number of C recouplings plus two, I7 contains the level of the I5 triad below C the common triad and I8 contains the level of the I6 triad below C the common triads C C See description of common block NJS04 for further details C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE C C Parameter variables C INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) C C Argument variables C INTEGER IP C C Local variables C INTEGER I,I1,I2,J C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),M,N LOGICAL FREE(MANGM) COMMON / ANG00 / M,N,J1,J2,J3,FREE C C Common variables C INTEGER J4(MANGM),J5(MANGM) COMMON / NJS03 / J4,J5 C C Common variables C INTEGER I17,I18,I19,I20 INTEGER I3,I4,I5,I6 INTEGER I7,I8,I9 COMMON / NJS04 / I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20 C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Common block ANG00: C Elements used but never set: J2 C Elements never used, never set: M N J1 J3 FREE C C Common block NJS03: C Elements used but never set: J4 C Elements never used, never set: J5 C C Common block NJS04: C Elements set but never used: I9 I17 I18 I19 I20 C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc I1 = J4(I7) I2 = J4(I8) C C Determines which J of J2(I5,I3) and J2(I6,I4) lies lowest, store C lowest as J2(I18,I20) and highest as J2(I17,I19) C IF (I1.LE.I2) THEN C I17 = I5 I18 = I6 I19 = I3 I20 = I4 I3 = I2-I1 I7 = 0 I8 = I3 I4 = I1 C IF (I3.GT.0) THEN C C I6 denotes the lowest triad, scan triads to find new triad I6 at C same level as I5 C DO I = 1,I3 DO J = 1,IP IF (J2(J,1).EQ.J2(I6,3)) GOTO 510 IF (J2(J,2).EQ.J2(I6,3)) GOTO 510 ENDDO J = IP 510 CONTINUE I6 = J ENDDO C ENDIF C ELSE C I17 = I6 I18 = I5 I19 = I4 I20 = I3 I3 = I1-I2 I7 = I3 I8 = 0 C C I5 denotes the lowest triads. Scan triads to find new triad I6 at C same level I5 C DO I = 1,I3 DO J = 1,IP IF (J2(J,1).EQ.J2(I5,3)) GOTO 520 IF (J2(J,2).EQ.J2(I5,3)) GOTO 520 ENDDO J = IP 520 CONTINUE I5 = J ENDDO I4 = I2 C ENDIF C C I5 and I6 now denotes triads at same level. I4 contains the C common level C DO I = 1,I4 C I1 = I IF (I5.EQ.I6) GOTO 550 C C I5 and I6 denote different triads. Scan to find triads at next C level which replace I5 and I6 C DO J = 1,IP IF (J2(J,1).EQ.J2(I5,3)) GOTO 530 IF (J2(J,2).EQ.J2(I5,3)) GOTO 530 ENDDO J = IP 530 CONTINUE I5 = J C DO J = 1,IP IF (J2(J,1).EQ.J2(I6,3)) GOTO 540 IF (J2(J,2).EQ.J2(I6,3)) GOTO 540 ENDDO J = IP 540 CONTINUE I6 = J C ENDDO C C I5 and I6 now both denote the common triad C 550 CONTINUE I9 = I3+2*I1 I8 = I8+I1 I7 = I7+I1 C END C C ******************* C SUBROUTINE GENJ45(IP) C C----------------------------------------------------------------------- C C Find the level of each J in the coupling trees of J2 and J3 and C store in the J4 and J5 arrays respectively. If an element of J1 C does not occur in J2 the J4 entry is -1 and if an element does C not occur in J3 the J5 entry is -1 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE C C Parameter variables C INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) C C Argument variables C INTEGER IP C C Local variables C INTEGER I,I2,I3,I4 C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),M,N LOGICAL FREE(MANGM) COMMON / ANG00 / M,N,J1,J2,J3,FREE C C Common variables C INTEGER J4(MANGM),J5(MANGM) COMMON / NJS03 / J4,J5 C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Common block ANG00: C Elements used but never set: M J2 J3 C Elements never used, never set: N J1 FREE C C Common block NJS03: C Elements set but never used: all C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DO I = 1,M C C Store level of each J in J2 array in J4 C DO I2 = 1,IP IF (J2(I2,1).EQ.I) GOTO 520 IF (J2(I2,2).EQ.I) GOTO 520 ENDDO DO I2 = 1,IP IF (J2(I2,3).EQ.I) GOTO 510 ENDDO J4(I) = -1 GOTO 550 C 510 CONTINUE J4(I) = 0 GOTO 550 C 520 CONTINUE I3 = 1 530 CONTINUE DO I4 = 1,IP IF (J2(I4,1).EQ.J2(I2,3)) GOTO 540 IF (J2(I4,2).EQ.J2(I2,3)) GOTO 540 ENDDO J4(I) = I3 GOTO 550 C 540 CONTINUE I3 = I3+1 I2 = I4 GOTO 530 C C Store level of each J in J3 array in J5 C 550 CONTINUE DO I2 = 1,IP IF (J3(I2,1).EQ.I) GOTO 570 IF (J3(I2,2).EQ.I) GOTO 570 ENDDO DO I2 = 1,IP IF (J3(I2,3).EQ.I) GOTO 560 ENDDO J5(I) = -1 GOTO 600 C 560 CONTINUE J5(I) = 0 GOTO 600 C 570 CONTINUE I3 = 1 580 CONTINUE DO I4 = 1,IP IF (J3(I4,1).EQ.J3(I2,3)) GOTO 590 IF (J3(I4,2).EQ.J3(I2,3)) GOTO 590 ENDDO J5(I) = I3 GOTO 600 C 590 CONTINUE I3 = I3+1 I2 = I4 GOTO 580 C 600 CONTINUE C ENDDO C END C C ******************* C SUBROUTINE GENSUM(J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,J3TEST! +,RECUP) C C----------------------------------------------------------------------- C C Carries out the summation over coefficients defined by the arrays C J6, J7, J8 and JW to give RECUP. C C The entry is either made from NJSYM or directly assuming that the C arrays J6, J7, J8 and JW have already been determined by a previous C entry to NJSYM and that the summation is required for another set C of J values defined by the array J1. C C The definition of the argument list is given at beginning of NJSYM C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE DOUBLE PRECISION DBLE C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) INTEGER M3MNGM PARAMETER (M3MNGM=3*MANGM) INTEGER M6J PARAMETER (M6J=20) C C Argument variables C INTEGER ICOUNT,J2TEST(MTRIAD) INTEGER J3TEST(MTRIAD),J6(M3MNGM),J6C INTEGER J7(M3MNGM),J7C,J8(M3MNGM),J8C INTEGER JW(6,M6J),JWC DOUBLE PRECISION RECUP C C Local variables C DOUBLE PRECISION STOR,STOR1,WSTOR(M6J),X1 INTEGER I,I1,I2,I20 INTEGER I3,I4,I5,I6 INTEGER I7,IASTOR,IORTH INTEGER IPAIR(2,2),IST(6),IX2,J INTEGER J6CP,J6P(M3MNGM),J7CP INTEGER J7P(M3MNGM),J8CP,J8P(M3MNGM),JJ2 INTEGER JJ3,JSUM(2,M6J),JSUM1(MTRIAD) INTEGER JSUM2(MTRIAD),JSUM3(MTRIAD) INTEGER JSUM5(MTRIAD,M6J),JSUM6(MTRIAD) INTEGER JSUM7(MTRIAD),JSUM8(MTRIAD) INTEGER JWORD(6,M6J),JWRD INTEGER JWTEST(M6J),MAXJWE,MAXSUM,NCT INTEGER NCT1,NSUM,NSUM1 C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),M,N LOGICAL FREE(MANGM) COMMON / ANG00 / M,N,J1,J2,J3,FREE C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Common block ANG00: C Elements used but never set: M J1 C Elements never used, never set: N J2 J3 FREE C C Common block DEBUG: C Elements used but never set: IBUG3 C Elements never used, never set: IBUG1 IBUG2 IBUG4 IBUG5 IBUG6 C C Common block INFORM: C Elements used but never set: IWRITE C Elements never used, never set: IREAD IPUNCH C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Section 1 C C Evaluates all terms in J6, J7, J8 and JW which do not involve a C summation and form modified arrays J6P, J7P, J8P and JWORD which do. C C The result of the evaluation is stored in RECUP and AISTOR. C C First check orthogonality of original coupling scheme. C C----------------------------------------------------------------------- IF (ICOUNT.GT.0) THEN RECUP = ZERO IORTH = 0 DO I = 1,ICOUNT JJ2 = J2TEST(I) JJ3 = J3TEST(I) IF (J1(JJ2).NE.J1(JJ3)) IORTH = 1 ENDDO IF (IORTH.EQ.1) RETURN ENDIF C IF (IBUG3.EQ.1) WRITE (IWRITE,3000) (J1(I),I=1,M) C RECUP = ONE C C Multiply RECUP by all Racah coefficients which do not involve a C summation C MAXJWE = M JWRD = 0 IF (JWC.GT.0) THEN DO I = 1,JWC DO J = 1,6 IF (JW(J,I).GT.M) GOTO 510 ENDDO DO J = 1,6 I1 = JW(J,I) IST(J) = J1(I1)-1 ENDDO CALL DRACAH(IST(1),IST(2),IST(3),IST(4),IST(5),IST(6),X1) RECUP = RECUP*X1 GOTO 520 C C JWRD is the number of Racah coefficients which involve a C summation C C JWORD(I,J),I=1,6,J=1,JWRD contains the number which give the C location of the J values for the Racah coefficients either in the C J1 list or in the JSUM1 list C C MAXJWE contains the maximum J in the list of variables to be C summed over C 510 CONTINUE JWRD = JWRD+1 DO J = 1,6 JWORD(J,JWRD) = JW(J,I) IF (MAXJWE.LT.JW(J,I)) THEN MAXJWE = JW(J,I) ENDIF ENDDO 520 CONTINUE ENDDO ENDIF C C J6P(I),I=1,J6CP contains all J6 which involve a summation. C Multiply RECUP by all those which do not C J6CP = 0 IF (J6C.GT.0) THEN DO I = 1,J6C IF (J6(I).LE.M) THEN I1 = J6(I) RECUP = RECUP*SQRT(DBLE(J1(I1))) ELSE J6CP = J6CP+1 J6P(J6CP) = J6(I) ENDIF ENDDO ENDIF C C J7P(I),I=1,J7CP contains all J7 which involve a summation. C Multiply RECUP by all those which do not C IASTOR = 0 J7CP = 0 IF (J7C.GT.0) THEN DO I = 1,J7C IF (J7(I).LE.M) THEN I1 = J7(I) IASTOR = IASTOR+J1(I1)-1 ELSE J7CP = J7CP+1 J7P(J7CP) = J7(I) ENDIF ENDDO ENDIF C C J8CP(I),I=1,J8CP contains all J8 which involve a summation. C Multiply RECUP by all those which do not. C J8CP = 0 IF (J8C.GT.0) THEN DO I = 1,J8C IF (J8(I).LE.M) THEN I1 = J8(I) IASTOR = IASTOR-J1(I1)+1 ELSE J8CP = J8CP+1 J8P(J8CP) = J8(I) ENDIF ENDDO ENDIF C C No Racah coefficients remaining and thus no summations to be C carried out if JWRD=0. Jump to end to include (-1) factors in C RECUP and then exit C IF (JWRD.LE.0) GOTO 710 C----------------------------------------------------------------------- C C Section 2 C C Search through the JWORD list to find all the summation variables C NSUM is the number of summation variables C JSUM1(I),I=1,NSUM contains a list of all summation variables in C the same notation as in JW list C C----------------------------------------------------------------------- NSUM = 0 MAXSUM = MAXJWE-M DO I = 1,MAXSUM JSUM6(I) = 0 JSUM7(I) = 0 ENDDO C C Find summation variables C DO I = 1,JWRD DO J = 1,6 IF (JWORD(J,I)-M.GT.0) THEN C NSUM = NSUM+1 C C Has the summation variable occurred before? C If not include in JSUM1 list C IF (NSUM-1.GT.0) THEN NSUM1 = NSUM-1 DO I1 = 1,NSUM1 IF (JWORD(J,I)-JSUM1(I1).EQ.0) GOTO 530 ENDDO ENDIF C JSUM1(NSUM) = JWORD(J,I) I1 = NSUM GOTO 540 C 530 CONTINUE NSUM = NSUM1 C C JSUM6(I),I=1,NSUM is the number of times each summation variable C occurs in JWORD C 540 CONTINUE JSUM6(I1) = JSUM6(I1)+1 I2 = JSUM6(I1) C C JSUM4(I,J),JSUM5(I,J),I=1,NSUM,J=1,JSUM6(I) C is the position in the JWORD list where the JSUM1 element occurs C CPN JSUM4(I1,I2)=J JSUM5(I1,I2) = I C C (JWORD-M) gives location in JSUM1 list if a summation variable C JWORD(J,I) = M+I1 C ENDIF ENDDO ENDDO C IF (MTRIAD.LT.NSUM) THEN WRITE (IWRITE,3080) STOP ENDIF C C Check that no extra summation variables occur in J6P. Set J6P C equal to the location in JSUM1 list of summation variable C IF (J6CP.GT.0) THEN DO I = 1,J6CP DO J = 1,NSUM IF (J6P(I).EQ.JSUM1(J)) GOTO 550 ENDDO WRITE (IWRITE,3020) STOP 550 CONTINUE J6P(I) = J ENDDO ENDIF C C Check that no extra summation variables occur in J7P, set J7P C equal to the location in JSUM1 list of summation variable C IF (J7CP.GT.0) THEN DO I = 1,J7CP DO J = 1,NSUM IF (J7P(I).EQ.JSUM1(J)) GOTO 560 ENDDO WRITE (IWRITE,3030) STOP 560 CONTINUE J7P(I) = J ENDDO ENDIF C C Check that no extra summation variables occur in J8P. Set J8P C equal to the location in JSUM1 list of summation variable C IF (J8CP.GT.0) THEN DO I = 1,J8CP DO J = 1,NSUM IF (J8P(I).EQ.JSUM1(J)) GOTO 570 ENDDO WRITE (IWRITE,3040) STOP 570 CONTINUE J8P(I) = J ENDDO ENDIF C----------------------------------------------------------------------- C C Section 3 C C Orders the summation variables so that the range of each C summation has been previously defined C C----------------------------------------------------------------------- NCT = 0 NCT1 = 0 580 CONTINUE C DO I = 1,JWRD DO J = 1,6 C I1 = JWORD(J,I)-M C IF (I1.LE.0) GOTO 620 C C JSUM7(I),I=1,NSUM is the order of the summations over the J C variables. Initially this array is zero C IF (JSUM7(I1).GT.0) GOTO 620 C C The rows of the IPAIR arrays give limits of summation imposed C by the triangular condition C IF (J.EQ.1) THEN IPAIR(1,1) = JWORD(2,I) IPAIR(1,2) = JWORD(5,I) IPAIR(2,1) = JWORD(3,I) IPAIR(2,2) = JWORD(6,I) GOTO 590 ENDIF C IF (J.EQ.2) THEN IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(5,I) IPAIR(2,1) = JWORD(4,I) IPAIR(2,2) = JWORD(6,I) GOTO 590 ENDIF C IF (J.EQ.3) THEN IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(6,I) IPAIR(2,1) = JWORD(4,I) IPAIR(2,2) = JWORD(5,I) GOTO 590 ENDIF C IF (J.EQ.4) THEN IPAIR(1,1) = JWORD(2,I) IPAIR(1,2) = JWORD(6,I) IPAIR(2,1) = JWORD(3,I) IPAIR(2,2) = JWORD(5,I) GOTO 590 ENDIF C IF (J.EQ.5) THEN IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(2,I) IPAIR(2,1) = JWORD(3,I) IPAIR(2,2) = JWORD(4,I) GOTO 590 ENDIF C IF (J.EQ.6) THEN IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(3,I) IPAIR(2,1) = JWORD(2,I) IPAIR(2,2) = JWORD(4,I) GOTO 590 ENDIF C C Test whether range of summation has been defined. We choose the C first pair of J values that define the range and store in JSUM. C C JSUM7 greater than zero means that limit is defined previously C 590 CONTINUE C DO I2 = 1,2 DO I3 = 1,2 IF (IPAIR(I2,I3)-M.GT.0) THEN I4 = IPAIR(I2,I3)-M IF (JSUM7(I4).LE.0) GOTO 600 ENDIF ENDDO GOTO 610 600 CONTINUE ENDDO C GOTO 620 C C NCT is count on order of summation C C JSUM(I,J),I=1,2,J=1,NSUM contains the position of the J values C that define the range of each variable. The first row corresponds C to the first J and the second row to the second J defining range. C If value in range 1 to M then corresponds to an element in J1. C If value greater than M then corresponds to a summation variable C in JSUM1 list. Note that JSUM does not necessarily contain the C most restrictive ranges since only one of two possible pairs from C the Racah coefficient is taken C 610 CONTINUE NCT = NCT+1 JSUM7(I1) = NCT DO I3 = 1,2 JSUM(I3,I1) = IPAIR(I2,I3) ENDDO C 620 CONTINUE C ENDDO ENDDO C C Check whether the range of all summations set. Fail if not C possible to set all ranges C IF (NCT-NSUM.GE.0) GOTO 640 IF (NCT-NCT1.GT.0) GOTO 630 WRITE (IWRITE,3050) STOP C 630 CONTINUE NCT1 = NCT GOTO 580 C C JSUM8(I),I=1,NSUM is the position in the JSUM7 list where the Ith C summation is found C 640 CONTINUE DO J = 1,NSUM DO I1 = 1,NSUM IF (JSUM7(I1).EQ.J) GOTO 650 ENDDO I1 = NSUM 650 CONTINUE JSUM8(J) = I1 ENDDO C----------------------------------------------------------------------- C C Section 4 C C Carry out the summations. C I6 denotes the first J that requires to be set to the lowest C value in the range C I7 = 0 the first time the JS are set but is set equal to 1 C on subsequent times C C----------------------------------------------------------------------- I6 = 1 I7 = 0 660 CONTINUE IF (I6-NSUM.GT.0) GOTO 670 C C JSUM2(I),I=1,NSUM contains current value of (2J+1) in the same C order as JSUM1 list. Set JSUM2 equal to lowest value in each C range C DO J = I6,NSUM I1 = JSUM8(J) C IF (JSUM(1,I1)-M.LE.0) THEN C C First J defining range fixed C I2 = JSUM(1,I1) I3 = J1(I2) C ELSE C C First J defining range variable C I2 = JSUM(1,I1)-M I3 = JSUM2(I2) C ENDIF C IF (JSUM(2,I1)-M.LE.0) THEN C C Second J defining range fixed C I2 = JSUM(2,I1) I4 = J1(I2) C ELSE C C Second J defining range variable C I2 = JSUM(2,I1)-M I4 = JSUM2(I2) C ENDIF C C Set lower limit of range in JSUM2 C JSUM2(I1) = ABS(I3-I4)+1 ENDDO C C JSUM3(I),I=1,NSUM is 1 if J has altered from its previous value C and is 0 if it is still the same C DO I = I6,NSUM JSUM3(I) = 1 ENDDO C IF (I7.GT.0) GOTO 670 I7 = 1 C C JWTEST(I),I=1,JWRD is 1 if required to evaluate Racah coefficient C and is 0 if value the same as before. JWTEST is set zero the first C time through and later set 1 if necessary C DO I = 1,JWRD JWTEST(I) = 0 ENDDO C C STOR1 will contain the product of Racah coefficients times C (2J+1) factors C STOR will contain sums of the STOR1 C STOR1 = ONE STOR = ZERO C C Check the triangular relation for all J values in JWORD list. If C a summation variable then value taken from JSUM2 list C 670 CONTINUE DO J = 1,JWRD DO I = 1,6 IF (JWORD(I,J).LE.M) THEN I1 = JWORD(I,J) IST(I) = J1(I1)-1 ELSE I1 = JWORD(I,J)-M IST(I) = JSUM2(I1)-1 ENDIF ENDDO C IF ( IST(1)+IST(2) -IST(5).LT.0) GOTO 680 IF (ABS(IST(1)-IST(2))-IST(5).GT.0) GOTO 680 IF ( IST(3)+IST(4) -IST(5).LT.0) GOTO 680 IF (ABS(IST(3)-IST(4))-IST(5).GT.0) GOTO 680 IF ( IST(1)+IST(3) -IST(6).LT.0) GOTO 680 IF (ABS(IST(1)-IST(3))-IST(6).GT.0) GOTO 680 IF ( IST(2)+IST(4) -IST(6).LT.0) GOTO 680 IF (ABS(IST(2)-IST(4))-IST(6).GT.0) GOTO 680 C ENDDO GOTO 700 C C Fail one of the triangular relations. Increase the J values C 680 CONTINUE I2 = NSUM 690 CONTINUE I1 = JSUM8(I2) C C Increase a summation J value which is in JSUM2 and set JSUM3 to C show value changed C JSUM2(I1) = JSUM2(I1)+2 JSUM3(I1) = 1 C C Now store J value defining range of this J in I3 and I4. C IF (JSUM(1,I1).LE.M) THEN I20 = JSUM(1,I1) I3 = J1(I20) ELSE I20 = JSUM(1,I1)-M I3 = JSUM2(I20) ENDIF C IF (JSUM(2,I1).LE.M) THEN I20 = JSUM(2,I1) I4 = J1(I20) ELSE I20 = JSUM(2,I1)-M I4 = JSUM2(I20) ENDIF C I5 = I3+I4-1 I6 = I2+1 C C Now test J values against maximum in range. If satisfied return C to set remaining J values which depend on this J to their C lowest values. If not return to increase preceding J value C IF (JSUM2(I1).LE.I5) GOTO 660 C I2 = I2-1 IF (I2.GT.0) GOTO 690 C C No more J values to sum over. The summation is therefore complete C Multiply by common factor and exit C RECUP = RECUP*STOR C IF (IBUG3.EQ.1) THEN WRITE (IWRITE,3060) RECUP,STOR,STOR1 ENDIF C RETURN C C See triangular relations are satisfied. Now proceed to evaluate C Racah coefficients C First determine which Racah coefficients need re-evaluating and C set JWTEST appropriately C 700 CONTINUE DO J = 1,NSUM IF (JSUM3(J).GT.0) THEN I2 = JSUM6(J) DO I1 = 1,I2 I3 = JSUM5(J,I1) JWTEST(I3) = 1 ENDDO ENDIF ENDDO C C Now evaluate all JWRD Racah coefficients which have not already C been evaluated C DO I = 1,JWRD IF (JWTEST(I).GT.0) THEN DO I1 = 1,6 IF (JWORD(I1,I).LE.M) THEN I2 = JWORD(I1,I) IST(I1) = J1(I2)-1 ELSE I2 = JWORD(I1,I)-M IST(I1) = JSUM2(I2)-1 ENDIF ENDDO CALL DRACAH(IST(1),IST(2),IST(3),IST(4),IST(5),IST(6),X1) WSTOR(I) = X1 ENDIF ENDDO C C WSTOR(I),I=1,JWRD contains the evaluated Racah coefficients C IF (IBUG3.EQ.1) THEN WRITE (IWRITE,3070) (WSTOR(J),J=1,JWRD) ENDIF C C Set JSUM3 and JWTEST to zero to indicate that Racah coefficients C need not be evaluated unless J value changes C DO J = 1,NSUM JSUM3(J) = 0 ENDDO C DO J = 1,JWRD JWTEST(J) = 0 ENDDO C C Form product of Racah coefficients, (2J+1) factors and (-1) C factors in STOR1 C DO I = 1,JWRD STOR1 = STOR1*WSTOR(I) ENDDO C C IASTOR contains the power of (-1) which is common to all terms C IX2 = IASTOR C IF (J6CP.GT.0) THEN DO I = 1,J6CP I1 = J6P(I) STOR1 = STOR1*SQRT(DBLE(JSUM2(I1))) ENDDO ENDIF C IF (J7CP.GT.0) THEN DO I = 1,J7CP I1 = J7P(I) IX2 = IX2+JSUM2(I1)-1 ENDDO ENDIF C IF (J8CP.GT.0) THEN DO I = 1,J8CP I1 = J8P(I) IX2 = IX2-JSUM2(I1)+1 ENDDO ENDIF C IX2 = IX2/2 C C Add term into STOR and reset STOR1 to 1 ready for next term C IF (MOD(IX2,2).EQ.1) STOR1 = -STOR1 STOR = STOR+STOR1 STOR1 = ONE GOTO 680 C C No summations. C Check that there are no inconsistencies. C Then multiply by (-1) factor and exit C 710 CONTINUE IF (J6CP+J7CP+J8CP.GT.0) THEN WRITE (IWRITE,3090) STOP ENDIF C IX2 = IASTOR/2 IF (MOD(IX2,2).EQ.1) RECUP = -RECUP IF (IBUG3.EQ.1) WRITE (IWRITE,3010) RECUP C----------------------------------------------------------------------- C C FORMAT statements used in GENSUM C C----------------------------------------------------------------------- 3000 FORMAT (' J1=',10I5) 3010 FORMAT (' RECUP = ',1P,E16.8,' no summation') 3020 FORMAT (' FAIL in GENSUM : with J6P array') 3030 FORMAT (' FAIL in GENSUM : with J7P array') 3040 FORMAT (' FAIL in GENSUM : with J8P array') 3050 FORMAT (' FAIL in GENSUM : setting summation ranges') 3060 FORMAT (' RECUP = ',1P,E16.8,' STOR =',E16.8,' STOR1 =',E16.8) 3070 FORMAT (' WSTOR =',5F10.6) 3080 FORMAT (' FAIL in GENSUM : MTRIAD dimension') 3090 FORMAT (' FAIL in GENSUM : inconsistency for no summation case') END C C ******************* C SUBROUTINE HPOT(J,XCF) C C----------------------------------------------------------------------- C C Modify the potentials for orbital J as described by C Cowan and Mann C C Cowan and Mann J. Comp. Phys. Vol. 16 Page 160 (1975) C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION FACTK PARAMETER (FACTK=.95D0) DOUBLE PRECISION FACTL PARAMETER (FACTL=1.D-2) DOUBLE PRECISION FACTX PARAMETER (FACTX=1.D-3) C C Argument variables C DOUBLE PRECISION XCF INTEGER J C C Local variables C DOUBLE PRECISION DLIMIT,DMX,HP,HQ DOUBLE PRECISION P,Q INTEGER I,IJ,NGRID C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (XCF.LT.EPS10) RETURN C NGRID = MPOIN(J) IJ = MPOS(J) C DMX = FACTX DLIMIT = DMX C DO I = 1,NGRID P = PF(IJ) IF (ABS(P)-DMX) 20,10,10 10 CONTINUE DMX = ABS(P) DLIMIT = SIGN(DMX*FACTL,P) GOTO 40 C 20 CONTINUE IF (ABS(P)-ABS(DLIMIT)) 30,40,40 30 CONTINUE IF (P.NE.ZERO) DLIMIT = SIGN(DLIMIT,P) P = DLIMIT 40 CONTINUE HQ = FACTK*XTQ(I)/P XTQ(I) = XTQ(I)-HQ*PF(IJ) YQ(I) = YQ(I)+C*HQ IJ = IJ+1 ENDDO C NGRID = MPOIN(J) IJ = MPOS(J) C DMX = FACTX DLIMIT = DMX IF (NAK(J).LT.0) DLIMIT = -DLIMIT C DO I = 1,NGRID Q = QF(IJ) IF (ABS(Q)-DMX) 60,50,50 50 CONTINUE DMX = ABS(Q) DLIMIT = SIGN(DMX*FACTL,Q) GOTO 80 C 60 CONTINUE IF (ABS(Q)-ABS(DLIMIT)) 70,80,80 70 CONTINUE IF (Q.NE.ZERO) DLIMIT = SIGN(DLIMIT,Q) Q = DLIMIT 80 CONTINUE HP = FACTK*XTP(I)/Q XTP(I) = XTP(I)-HP*QF(IJ) YP(I) = YP(I)-C*HP IJ = IJ+1 ENDDO C END C C ******************* C SUBROUTINE IN(JORB,JP,MF,WA,WB) C C----------------------------------------------------------------------- C C This subroutine computes the solution of the inhomogeneous C pair of Dirac equations in the exponential tail region. C The equations are treated as a boundary value problem, C with the value of P(R) given at one boundary, and P(R) C being required to vanish for large R, the position of C this second boundary being determined in the course of C the calculation. C C DATA C C JORB orbital label C JP determines the point at which the outward integration ends. C MF determines the end of the tail region. C WA the value of 1 + H*K/2 C WB the value of 1 - H*K/2 C C RESULT C C P(I) I= J+1,...,N table of P(R) C Q(I) I= J ,...,N table of Q(R) C C The same finite difference equations are used as in C the outward integration. When written in boundary-value C form the solution satisfies a system of linear equations C of the form M*W = V, where W is a vector consisting of C the elements Q(J), P(J+1), Q(J+1), ... The matrix M C is of band type, with 5 elements in each row. M is C expressed as a product of two triangular matrices L AND U, C the non-zero elements of L being stored in the arrays C TA, TB and TC, and those of U in TD, TE and TH. The C required vector W is then obtained by solving two C triangular systems, L*Z=V and U*W = Z. C C The subroutine is usually called 3 times with the same C matrix M, but different vectors V. The elements of the C triangular matrices L and U are therefore preserved C between calls. If the parameter MF is zero, the elements C of L and U are computed, and the position of the C extreme boundary is determined by the condition that the C assumption P(I+1)=Q(I+1)=0 leads to a value of P(I) C smaller in magnitude than the accuracy parameter ACCY. C the position of this boundary is then stored in MF. If C the end of the table is reached before this condition can be C satisfied, the subroutine returns with MF set to -1 as a C failure indication. C C If MF is non-zero on entry to the subroutine, the C elements of L and U are not re-computed, and the boundary C is taken to be at the point MF. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) C C Argument variables C DOUBLE PRECISION WA,WB INTEGER JORB,JP,MF C C Local variables C DOUBLE PRECISION TA(MXNP),TB(MXNP),TC(MXNP) DOUBLE PRECISION TD(MXNP),TE(MXNP),TEST1,TEST2 DOUBLE PRECISION TF(MXNP) INTEGER I,J,NGRID C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP) DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP) COMMON / INT3 / XU,XV,XR,XS,XF,XG C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C SAVE TA,TB,TC,TD,TE,TF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- I = 1 J = JP C IF (MF.EQ.0) THEN NGRID = MPOIN(JORB) TD(1) = WA TC(1) = -XF(J)/TD(1) TE(1) = -WA+TC(1)*XG(J+1) TF(1) = WB*TC(1)-XF(J+1) XR(1) = -XV(J)+XG(J)*P(J) XS(1) = -XU(J)-WB*P(J)-TC(1)*XR(1) TEST1 = ABS(XS(1)/TE(1)) C 10 CONTINUE I = I+1 J = J+1 C C compute rows of L and U matrices C TA(I) = -XG(J)/TE(I-1) TD(I) = WA-TA(I)*TF(I-1) TB(I) = WB/TE(I-1) TC(I) = (-XF(J)-TB(I)*TF(I-1))/TD(I) TE(I) = -WA+TC(I)*XG(J+1) TF(I) = -XF(J+1)+WB*TC(I) C C solution of L*Z=V C XR(I) = -XV(J)-TA(I)*XS(I-1) XS(I) = -XU(J)-TB(I)*XS(I-1)-TC(I)*XR(I) C C test for extreme boundary possible C TEST2 = ABS(XS(I)/TE(I)) IF (TEST1+TEST2.LE.CUTOFF) GOTO 30 TEST1 = TEST2 C C failure if tables not long enough C IF (J.GE.NGRID-1) THEN MF = -1 RETURN ENDIF C GOTO 10 C ELSE XR(1) = -XV(J)+XG(J)*P(J) XS(1) = -XU(J)-WB*P(J)-TC(1)*XR(1) C 20 CONTINUE I = I+1 J = J+1 C C solution of L*Z=V C XR(I) = -XV(J)-TA(I)*XS(I-1) XS(I) = -XU(J)-TB(I)*XS(I-1)-TC(I)*XR(I) IF (J.LT.MF) GOTO 20 ENDIF C C ***** INWARD SOLUTION ****** C store boundary position in MF C 30 CONTINUE MF = J C C begin solution of U*W=Z C I = I-1 Q(J) = ZERO P(J) = XS(I)/TE(I) Q(J-1) = (XR(I)+XG(J)*P(J))/TD(I) C 40 CONTINUE J = J-1 I = I-1 C C compute elements of vector W. C P(J) = (XS(I)-TF(I)*Q(J))/TE(I) Q(J-1) = (XR(I)+WB*Q(J)+XG(J)*P(J))/TD(I) IF (J.GT.JP+1) GOTO 40 C END C C ******************* C SUBROUTINE IN2CH3 (i,name,iwrite) C C----------------------------------------------------------------------- C C This routine converts an integer into a 3-charcter variable. C e.g. if i is 29 then name is 029. C i lies between 0 and 999 inclusive. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE CHARACTER CHAR INTEGER ICHAR C C Argument variables C CHARACTER*3 NAME INTEGER I,IWRITE C C Local variables C CHARACTER NAME1 CHARACTER*2 NAME2 INTEGER I1,I2,I3,IA INTEGER IB,N1,N2,N3 INTEGER NUM(0:9) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (i.lt.0 .or. i.gt.999) THEN WRITE (iwrite,3000) i stop ENDIF C num(0) = ichar('0') num(1) = ichar('1') num(2) = ichar('2') num(3) = ichar('3') num(4) = ichar('4') num(5) = ichar('5') num(6) = ichar('6') num(7) = ichar('7') num(8) = ichar('8') num(9) = ichar('9') C ia = i/10 i3 = i-ia*10 ib = ia/10 i2 = ia-ib*10 i1 = ib C n1 = num(i1) n2 = num(i2) n3 = num(i3) C name1 = char(n1) name2 = name1//char(n2) name = name2//char(n3) C 3000 FORMAT (/' STOPPING in routine IN2CH3.'/' The number ',I6, ! +' is out of range.') END C C ******************* C SUBROUTINE INIT(IR1,IR2,IR3) C C----------------------------------------------------------------------- C C This subroutine : C C (1) writes out the basic data C C (2) obtains initial estimates for the wavefunctions by C using one of the following methods C (a) reading from a dump - rescaling if Z changes C and interpolating if the grid changes (SCORB) C dump can be MCDF or ORBITALS C (b) using a Thomas-Fermi potential C (c) using analytic Coulomb wavefunctions C C (3) sets up the nuclear potential by a call to NUCPOT C C (4) calls MCPIN to read the MCP coefficients from a file C C (5) sets up mixing coefficients and generalised occupation numbers C C (6) determines if Lagrange multipliers are required C C----------------------------------------------------------------------- C C reference structure: C C INIT COULG C MCPIN C NUCPOT C PROPG C PRWF c rritz C SCORB C STWAVE PRWF C QUAD C STWOPT EIGENV C LAGR C MATRIX C PRWF C QUAD C XPOT C YPOT C TFPOT C TFWAVE C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION RMAX PARAMETER (RMAX=300.0D0) C C Argument variables C INTEGER IR1,IR2,IR3 C C Local variables C CHARACTER*80 IHEDIN CHARACTER*2 NHY CHARACTER*20 RECIN DOUBLE PRECISION CON,CY,EY,FAC1 DOUBLE PRECISION FAC2,FK,HY,PZY DOUBLE PRECISION QZY,RY,SUM,WA DOUBLE PRECISION ZY INTEGER I,J,JA,JB INTEGER JP,L,MA,MB INTEGER MF,NAKY,NBIG,NCFY INTEGER NCY,NLAST,NMAX,NPY INTEGER NWM,NWTOT,NWY,NY LOGICAL LSTWAV C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION CHECK INTEGER NITIT COMMON / DEF04 / CHECK,NITIT C C Common variables C DOUBLE PRECISION WT(MXNC) INTEGER ITY COMMON / DEF05 / WT,ITY C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION CXCF(MXNE) INTEGER JXCF(MXNE),NSCF,NSCFY COMMON / MCPC / CXCF,JXCF,NSCF,NSCFY C C Common variables C integer icut(mxnw) common /nrbcut/icut C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ECV(MXNO) INTEGER IECC(MXNO),NEC COMMON / OFFD / ECV,IECC,NEC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C C Common variables C INTEGER ILO(MXNW),IWO(MXNW),NWO COMMON / WRO / NWO,IWO,ILO C C Common variables C logical lspin common /nrb000/lspin Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- PRINT 3030,IHED(1:40),IHED(41:80),RECORD WRITE (IWRITE,3030) IHED(1:40),IHED(41:80),RECORD WRITE (IPUNCH,3030) IHED(1:40),IHED(41:80),RECORD C IF (ABS(ATW).LT.EPS10) THEN WRITE (IWRITE,3070) FACTCM,FACTEV ELSE WRITE (IWRITE,3080) ATW,FACTCM,FACTEV ENDIF WRITE (IWRITE,3150) Z,C,RNT,H,ACCY,CUTOFF C----------------------------------------------------------------------- C C Set up the array containing the radial grid C NMAX = MXNP C WA = RNT DO I = 1,NMAX RGRID(I) = WA WA = WA*EPH IF (WA.GT.RMAX) THEN NMAX = I GOTO 10 ENDIF ENDDO C C N is set to be NMAX C N is an odd number C 10 CONTINUE C IF (MOD(NMAX,2).EQ.1) THEN N = NMAX ELSE N = NMAX-1 ENDIF C WRITE (IWRITE,3160) RMAX,N C----------------------------------------------------------------------- C NLAST = 0 C NSCFY = 0 c lspin=.false. !initialize L-spinor flag C IF (NITIT.EQ.0) ITY = 0 C IF (ITY.EQ.0) WRITE (IWRITE,3140) IF (ITY.EQ.1) WRITE (IWRITE,3180) IF (ITY.EQ.2) WRITE (IWRITE,3190) IF (NCMIN.EQ.1) WRITE (IWRITE,3200) IF (NCMIN.GT.1) WRITE (IWRITE,3210) IF (ITC(4).EQ.1) WRITE (IWRITE,3240) C----------------------------------------------------------------------- WRITE (IWRITE,3220) DO J = 1,NW icut(j)=0 IF (JFIX(J).EQ.0) THEN WRITE (IWRITE,3230) J,NP(J),NH(J),NP(J),NAK(J),NKJ(J),NKL(J) ELSE WRITE (IWRITE,3170) J,NP(J),NH(J),NP(J),NAK(J),NKJ(J),NKL(J) ENDIF ENDDO WRITE (IWRITE,3250) C----------------------------------------------------------------------- C C Set up initial estimates for the wavefunctions C IF (NUCTYP.GT.0) THEN DO J = 1,NW MPOIN(J) = N XAM(J) = ZERO E(J) = -ONE FK = NAK(J) GAMA(J) = ABS(FK) ENDDO ELSE CON = Z/C CON = CON*CON DO J = 1,NW MPOIN(J) = N XAM(J) = ZERO E(J) = -ONE FK = NAK(J) GAMA(J) = SQRT(FK*FK-CON) ENDDO ENDIF C NWTOT = 0 C----------------------------------------------------------------------- C C If IR2 is positive then an MCDF dump is available C this is then read C C----------------------------------------------------------------------- IF (IR2.GT.0) THEN C REWIND IR2 C C Read the dump title C READ (IR2) IHEDIN,RECIN WRITE (IWRITE,3000) IHEDIN(1:40),IHEDIN(41:80),RECIN C READ (IR2) NCY,NWY,NCFY,NY READ (IR2) ZY,RY,HY,CY ZY = ABS(ZY) IF (NY.GT.MXNP) THEN WRITE (IWRITE,3270) NY,MXNP STOP ENDIF C C ++++ loop over orbitals on dump ++++ C DO I = 1,NWY C READ (IR2) NHY,NPY,NAKY,EY READ (IR2) PZY,QZY READ (IR2) (P(L),L=1,NY), (Q(L),L=1,NY) C C The orbital is used provided ILO has been set to 0. C DO J = 1,NW IF (ILO(J).EQ.0) THEN IF (NPY.EQ.NP(J) .AND. NAKY.EQ.NAK(J)) THEN E(J) = EY CALL SCORB(NLAST,J,ZY,RY,HY,NY,PZY,QZY) WRITE (IWRITE,3280) NP(J),NH(J),E(J),MPOIN(J) ILO(J) = -1 NWTOT = NWTOT+1 GOTO 20 ENDIF ENDIF ENDDO C 20 CONTINUE ENDDO C ENDIF C----------------------------------------------------------------------- C C If IR3 is positive then read from an orbitals dump C C----------------------------------------------------------------------- IF (IR3.GT.0) THEN C 30 CONTINUE READ (IR3,END=40) NHY,NPY,NAKY,NY,ZY,HY,RY,EY,PZY,QZY C IF (NY.GT.MXNP) THEN WRITE (IWRITE,3270) NY,MXNP STOP ENDIF C READ (IR3) (P(L),L=1,NY), (Q(L),L=1,NY) C C ++++ read the orbitals for which ILO is set to 1 ++++ C DO J = 1,NW IF (ILO(J).EQ.1 .OR. ILO(J).EQ.-2) THEN IF (NPY.EQ.NP(J) .AND. NAKY.EQ.NAK(J)) THEN E(J) = EY CALL SCORB(NLAST,J,ZY,RY,HY,NY,PZY,QZY) WRITE (IWRITE,3260) NP(J),NH(J),E(J),MPOIN(J) IF (ILO(J).NE.-2) THEN ILO(J) = -2 NWTOT = NWTOT+1 ENDIF GOTO 30 ENDIF ENDIF ENDDO C GOTO 30 C 40 CONTINUE DO J = 1,NW IF (ILO(J).EQ.-2) ILO(J) = -1 ENDDO C ENDIF C----------------------------------------------------------------------- C C Set up the nuclear potential. This is stored in array ZZ. C CALL NUCPOT C----------------------------------------------------------------------- C C The remainder of the orbitals are either Thomas-Fermi or Coulomb C When option 1 is set the estimates are Coulomb. C LSTWAV = .FALSE. C IF (NWTOT.LT.NW) THEN C IF (ITC(1).EQ.0) CALL TFPOT C DO J = 1,NW IF (ILO(J).GE.0) THEN IF (ILO(J).EQ.3 .OR. ITC(1).EQ.1) THEN CALL COULG(NLAST,J) WRITE (IWRITE,3020) NP(J),NH(J),E(J),MPOIN(J) ELSEIF (ILO(J).EQ.4 .OR. ILO(J).EQ.5) THEN IF (ILO(J).EQ.4) THEN CALL STWAVE(NLAST,J,0) WRITE (IWRITE,3050) NP(J),NH(J),E(J),MPOIN(J) ELSE CALL STWAVE(NLAST,J,1) WRITE (IWRITE,3060) NP(J),NH(J),E(J),MPOIN(J) ENDIF LSTWAV = .TRUE. ELSE CALL TFWAVE(NLAST,J,MF) IF (MF.EQ.0) THEN WRITE (IWRITE,3010) NP(J),NH(J),E(J),MPOIN(J) ELSE CALL COULG(NLAST,J) WRITE (IWRITE,3020) NP(J),NH(J),E(J),MPOIN(J) ENDIF ENDIF ENDIF ENDDO c c If L-spinors, form new basis from zero-order. c if(lspin)then c call rritz(nlast) c if(itc(22).ne.0)then write(*,3300) write(iwrite,3300) itc(22)=0 endif c endif C ENDIF C----------------------------------------------------------------------- C C Set the value of N to be the largest for the orbitals. C NBIG = 0 DO J = 1,NW IF (MPOIN(J).GT.NBIG) NBIG = MPOIN(J) ENDDO N = NBIG C NLAST = MPOS(NW)+MPOIN(NW)-1 C WRITE (IWRITE,3290) NLAST,MXNG,N,MXNP,RGRID(1),RGRID(N) C CALL PROPG(1) C----------------------------------------------------------------------- C C Read the MCP coefficients from MCP file. C CALL MCPIN(IR1) C----------------------------------------------------------------------- C C Set up the mixing coefficients and generalised occupation numbers. C if(lspin)then !L-spinors for DARC ZSTAT coueng(1)=one do j=2,ncf coueng(j)=zero enddo do i=1,nw ucf(i)=iq(i,1) enddo elseIF (ITY.EQ.2) THEN SUM = ZERO DO J = 1,NCF SUM = SUM+WT(J) ENDDO FAC1 = ONE/SUM DO J = 1,NCF COUENG(J) = SQRT(FAC1*WT(J)) ENDDO DO I = 1,NW SUM = ZERO DO J = 1,NCF SUM = SUM+WT(J)*IQ(I,J) ENDDO UCF(I) = SUM*FAC1 ENDDO ELSE FAC1 = ONE/NCF FAC2 = SQRT(FAC1) DO J = 1,NCF COUENG(J) = FAC2 ENDDO DO I = 1,NW SUM = ZERO DO J = 1,NCF SUM = SUM+IQ(I,J) ENDDO UCF(I) = FAC1*SUM ENDDO ENDIF C----------------------------------------------------------------------- C C Determine if Lagrange multipliers are required C NEC = 0 C IF (NITIT.GT.0 .OR. LSTWAV) THEN IF (ITC(2).EQ.1) THEN WRITE (IWRITE,3110) ELSE IF (NW.GT.1) THEN NWM = NW-1 DO JA = 1,NWM JP = JA+1 DO JB = JP,NW IF (NAK(JA).NE.NAK(JB)) GOTO 60 IF (NP(JA).EQ.NP(JB)) GOTO 60 IF (ABS(UCF(JA)-DBLE(NKJ(JA))-ONE).GT.EPS10) GOTO 50 IF (ABS(UCF(JB)-DBLE(NKJ(JB))-ONE).GT.EPS10) GOTO 50 GOTO 60 C 50 CONTINUE NEC = NEC+1 IF (NEC.GT.MXNO) THEN WRITE (IWRITE,3130) STOP ENDIF C IECC(NEC) = JA+NW1*JB ECV(NEC) = ZERO 60 CONTINUE ENDDO ENDDO ENDIF C ENDIF ENDIF C IF (NEC.EQ.0) THEN WRITE (IWRITE,3120) ELSE WRITE (IWRITE,3090) DO I = 1,NEC MA = IECC(I)/NW1 MB = IECC(I)-NW1*MA WRITE (IWRITE,3100) NP(MB),NH(MB),NP(MA),NH(MA) ENDDO ENDIF C----------------------------------------------------------------------- C C Improve wavefunction approximation with Slater-type orbitals input C IF (LSTWAV) CALL STWOPT C IF (ITC(9).EQ.1) CALL PRWF (0) C WRITE (IWRITE,3040) WRITE (IPUNCH,3040) C----------------------------------------------------------------------- 3000 FORMAT (/' Dump title : ',A40/' ',A40/' Run at : ',! +A20/1X,71('*')) 3010 FORMAT (' *** Thomas-Fermi estimate *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3020 FORMAT (' *** Coulomb estimate *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3030 FORMAT (/1X,71('*')/' routine INIT : start of MCDF calculation'/1X! +,71('*')/' Title : ',A40/' ',A40/' Run at : ',A20/1X,71(! +'*')) 3040 FORMAT (/1X,71('*')) 3050 FORMAT (' *** Slater-type coeffs *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3060 FORMAT (' *** Clementi-type coeffs *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3070 FORMAT (/' atomic units are used except where indicated'/ ! +' the following conversion factors are set in routine DATAIN'/ ! +' using the atomic weight set to infinity'/' 1 a.u. = ',1P,E17! +.10,' cm-1'/' 1 a.u. = ',E17.10,' eV') 3080 FORMAT (/' atomic units are used except where indicated'/ ! +' the following conversion factors are set in routine DATAIN'/ ! +' using atomic weight = ',F10.5/' 1 a.u. = ',1P,E17.10,' cm-1'! +/' 1 a.u. = ',E17.10,' eV') 3090 FORMAT (/' include Lagrange multipliers between'/) 3100 FORMAT (16X,I2,A2,2X,I2,A2) 3110 FORMAT (/' Lagrange multipliers are not to be included') 3120 FORMAT (/' Lagrange multipliers are not required') 3130 FORMAT (/' ERROR in INIT : dimension for NEC ... STOPPING') 3140 FORMAT (/' configuration interaction (CI) calculation') 3150 FORMAT (/' Z (atomic number) = ',F6.2/ ! +' C (speed of light) = ',1P,E17.10/ ! +' RNT (first grid point) = ',E10.3/ ! +' H (grid step-size) = ',E10.3/ ! +' ACCY (accuracy) = ',E10.3/ ! +' CUTOFF (wave-function cut-off parameter) = ',E10.3) 3160 FORMAT (' N (maximum grid point at ',F8.1,') =',I5) 3170 FORMAT (1X,I2,1X,I2,A2,4I4,' fixed orbital') 3180 FORMAT (/' average level (AL) calculation') 3190 FORMAT (/' extended average level (EAL) calculation') 3200 FORMAT (/' optimal level (OL) calculation') 3210 FORMAT (/' extended optimal level (EOL) calculation') 3220 FORMAT (/1X,' orbital N',3X,'K',2X,'2J',3X,'L'/) 3230 FORMAT (1X,I2,1X,I2,A2,4I4) 3240 FORMAT (/' using Mann and Cowan modification to potentials') 3250 FORMAT (1X) 3260 FORMAT (' *** read from ORBS file *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3270 FORMAT (/' ERROR in INIT : dimension ... STOPPING'/ ! +' You must increase MXNP to at least ',I6, ! +' from the present value of ',I6) 3280 FORMAT (' *** read from MCDF file *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3290 FORMAT (/' number of w.f. points = ',I7,' (max=',I7,')'/ ! +' number of grid points = ',I7,' (max=',I7,')'/ ! +' first grid point = ',1P,E12.5/' last grid point = ',E! +12.5) 3300 format(/'L-spinor setting overrides ITC(22)=1'/) END C C ******************* C SUBROUTINE INTRPG(ARG,VAL,X,N,Y) C C----------------------------------------------------------------------- C C Uses Lagrange interpolation formula to obtain value of VAL(X). C ARG(I),VAL(I) ,I=1,N contain the data values. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) C C Argument variables C INTEGER N DOUBLE PRECISION ARG(N),VAL(N),X,Y C C Local variables C DOUBLE PRECISION PL INTEGER J,L Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- Y = ZERO DO L = 1,N PL = ONE DO J = 1,N IF (L-J) 10,20,10 10 CONTINUE PL = (X-ARG(J))*PL/(ARG(L)-ARG(J)) 20 CONTINUE ENDDO Y = Y+PL*VAL(L) ENDDO C END C C ******************* C FUNCTION IROW1(NELC,KSI) C C----------------------------------------------------------------------- C C Locate the row position of configuration J(**N) in table NTAB. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INTEGER IROW1 C C Argument variables C INTEGER KSI,NELC C C Local variables C INTEGER KQ1,KQ2,KQL C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (NELC.LE.0 .OR. NELC.GT.KSI) THEN WRITE (IWRITE,3000) NELC,KSI IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) NELC,KSI STOP ENDIF C KQ1 = NELC-1 KQ2 = KSI-KQ1 KQL = MIN(KQ1,KQ2)+1 C IF (KQL.EQ.1) THEN IROW1 = 1 ELSE IROW1 = (KSI*(KSI-2))/8+KQL ENDIF C 3000 FORMAT (' STOPPING in routine IROW1'/ ! +' Termination because of data ERROR'/1X,I3, ! +' electrons in shell with 2j+1 = ',I3) END C C ******************* C FUNCTION ITRIG(I1,I2,I3) C C----------------------------------------------------------------------- C C The triangular delta. C C INPUT - values of 2*J+1; C OUTPUT - 1, if J'S form a triangle, C 0, otherwise. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INTEGER ITRIG C C Argument variables C INTEGER I1,I2,I3 Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IF (I1.GE. (ABS(I2-I3)+1) .AND. (I1.LE. (I2+I3-1))) THEN ITRIG = 1 ELSE ITRIG = 0 ENDIF C END C C ******************* C SUBROUTINE JCLIST(NST,NFI) C C----------------------------------------------------------------------- C C This subroutine sets up an array of coupled J values arising from C all relativistic subshells originating from one open nonrelativistic C subshell, whether they are open or not. The array is used in JJLS. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER NFI,NST C C Local variables C INTEGER I1,I2,ICF,ICUP INTEGER IOPEN,J,JC C C Common variables C INTEGER JPOS(4),MLX(4),MQX(4),NOPEN COMMON / NRD01 / MLX,MQX,JPOS,NOPEN C C Common variables C INTEGER JSCUP(8,MXNC) COMMON / NRD05 / JSCUP C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO ICF = NST,NFI ICUP = -1 J = 0 JC = 1 DO IOPEN = 1,NOPEN I2 = JPOS(IOPEN) IF (MLX(IOPEN).EQ.0) GOTO 20 I1 = I2-1 IF (ICHOP(I1,ICF).NE.0) GOTO 20 ICUP = ICUP+1 IF (ICUP.GT.0) GOTO 10 JC = JQS(3,I1,ICF) GOTO 20 C 10 CONTINUE JC = JCUP(ICUP,ICF) 20 CONTINUE J = J+1 JSCUP(J,ICF) = JC IF (ICHOP(I2,ICF).NE.0) GOTO 40 ICUP = ICUP+1 IF (ICUP.GT.0) GOTO 30 JC = JQS(3,I2,ICF) GOTO 40 C 30 CONTINUE JC = JCUP(ICUP,ICF) 40 CONTINUE J = J+1 JSCUP(J,ICF) = JC ENDDO ENDDO C END C C ******************* C SUBROUTINE JJLS(NST,NCFN,IFAIL,CHECK) C C----------------------------------------------------------------------- C C This subroutine calculates coefficients for transformation from C JJ to LS coupling. The coefficient divides into three parts: C (1) transformation from successive coupling of J values to C coupling of J values for subshells with the same N,L and C recoupling to give the total J value. This involves a C Racah coefficient for each subshell and a summation over C possible J values for the coupled subshells. C (2) transformation of single subshells from JJ to LS coupling C these transformation coefficients are given as BLOCK DATA C (3) transformation of coupling of subshells from JJ to LS C coupling. This involves a 3NJ symbol, where N=2*NOPEN+1 C A check is made on the orthonormality of the transformation C coefficients, flagged by IFAIL. C C Subroutines called : SSTC,DRACAH,GENSUM C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL FREE LOGICAL NTRIG C PARAMETER (MANGM = 60) PARAMETER (MTRIAD=20) PARAMETER (M3MNGM = 3*MANGM) PARAMETER (M6J = 20) COMMON / NJS00 / J6C,J7C,J8C,JWC COMMON / NJS01 / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM), +JW(6,M6J) COMMON / NJS02 / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD) C INCLUDE 'grasp0.inc' C COMMON / ANG00 / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3), ! + FREE(MANGM) COMMON / INFORM / IREAD,IWRITE,IPUNCH COMMON / NRD00 / TC(MXNC,MXNC) COMMON / NRD01 / MLX(4),MQX(4),JPOS(4),NOPEN COMMON / NRD05 / JSCUP(8,MXNC) COMMON / NRD06 / LSV(5,4,MXNC) COMMON / ORB04 / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC) COMMON / ORB06 / JQS(3,MXNW,MXNC),JCUP(10,MXNC),ICHOP(MXNW,MXNC),! + IEXC C PARAMETER (ACCY=1.D-8) PARAMETER (ZERO=0.D0) PARAMETER (ONE=1.D0) C DIMENSION NCASE(4),JCASE(4,10),WCASE(4,10) C NTRIG(I,J,K) = I.GE.J+K.OR.J.GE.K+I.OR.K.GE.I+J C----------------------------------------------------------------------- CHECK = -ONE C C Loop thru all possible relativistic CSF C DO ICF = NST,NCF C C First open subshell C IF (NTRIG(LSV(2,1,NCFN),LSV(3,1,NCFN),JSCUP(2,ICF))) GOTO 110 CALL SSTC(1,NCFN,ICF,JSCUP(2,ICF),COEFF) C C Branch here for one open subshell C IF (NOPEN.EQ.1) GOTO 100 J1(3) = JSCUP(2,ICF) C C Set up arrays with possible J values for nonrelativistic subshells C Store values of SSTC * 6-J symbol for each case C DO I = 2,NOPEN II = I+I NJ1 = JSCUP(II-2,ICF) NJP = JSCUP(II-1,ICF) NJ2 = JSCUP(II,ICF) K = 0 IF (MLX(I).NE.0) GOTO 10 LJ1 = 1 LJ2 = 2 GOTO 20 C 10 CONTINUE JP = JPOS(I) LJ1 = JQS(3,JP-1,ICF) LJ2 = JQS(3,JP,ICF) 20 CONTINUE NJMIN = ABS(LJ2-LJ1)+1 NJI = LJ2+LJ1+1 30 CONTINUE NJI = NJI-2 IF (NJI.LT.NJMIN) GOTO 40 IF (NTRIG(NJ1,NJI,NJ2)) GOTO 30 IF (NTRIG(LSV(2,I,NCFN),LSV(3,I,NCFN),NJI)) GOTO 30 K = K+1 JCASE(I,K) = NJI CALL SSTC(I,NCFN,ICF,NJI,WA) CALL DRACAH(NJ1-1,LJ1-1,NJ2-1,LJ2-1,NJP-1,NJI-1,WB) WCASE(I,K) = WA*WB*SQRT(DBLE(NJP*NJI)) GOTO 30 C 40 CONTINUE IF (K.EQ.0) GOTO 110 NCASE(I) = K ENDDO C C Sum over all possible cases to form transformation coefficient C SUM = ZERO I2 = 0 50 CONTINUE I2 = I2+1 IF (I2.GT.NCASE(2)) GOTO 90 TERM = WCASE(2,I2) J1(6) = JCASE(2,I2) J1(9) = JSCUP(4,ICF) C C Branch here for 2 open subshells C IF (NOPEN.EQ.2) GOTO 80 TERM1 = TERM I3 = 0 60 CONTINUE I3 = I3+1 IF (I3.GT.NCASE(3)) GOTO 50 TERM = TERM1*WCASE(3,I3) J1(12) = JCASE(3,I3) J1(15) = JSCUP(6,ICF) C C Branch here for 3 open shells C IF (NOPEN.EQ.3) GOTO 80 TERM2 = TERM I4 = 0 70 CONTINUE I4 = I4+1 IF (I4.GT.NCASE(4)) GOTO 60 TERM = TERM2*WCASE(4,I4) J1(18) = JCASE(4,I4) J1(21) = JSCUP(8,ICF) 80 CONTINUE CALL GENSUM (J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST, + J3TEST,WA) SUM = SUM+TERM*WA GOTO (100,50,60,70),NOPEN C 90 CONTINUE COEFF = COEFF*SUM C C Store coefficient C 100 CONTINUE IF (ABS(COEFF).LT.ACCY) GOTO 110 CHECK = CHECK+COEFF*COEFF TC(ICF,NCFN) = COEFF GOTO 120 C 110 CONTINUE TC(ICF,NCFN) = ZERO 120 CONTINUE ENDDO C C Check orthonormality of transformations C IFAIL = 0 J = NCFN 130 CONTINUE IF (ABS(CHECK).GT.ACCY) GOTO 140 J = J-1 IF (J.LT.NST) GOTO 150 CHECK = ZERO DO ICF = NST,NCF CHECK = CHECK+TC(ICF,NCFN)*TC(ICF,J) ENDDO GOTO 130 C 140 CONTINUE IFAIL = J 150 CONTINUE C C Error messages C ============== C IF (IFAIL.GT.0) THEN WRITE (IWRITE,3000) J,CHECK WRITE (IPUNCH,3000) J,CHECK DO J = NST,NCFN WRITE (IWRITE,3010) J WRITE (IWRITE,3020) (TC(ICF,J),ICF=NST,NCF) WRITE (IPUNCH,3010) J WRITE (IPUNCH,3020) (TC(ICF,J),ICF=NST,NCF) ENDDO ENDIF C 3000 FORMAT (/' *** ERROR in JJLS ***'/' J,CHECK : ',I4,1P,E12.4) 3010 FORMAT (/' J = ',I4) 3020 FORMAT (' TC : ',1P,7E10.2) END C C ******************* C SUBROUTINE LAGR(J) C C----------------------------------------------------------------------- C C Determine new estimates for the Lagrange multipliers C involving orbital J. C C Subroutines called : YPOT , XPOT , QUAD , RINTI C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL RINTI DOUBLE PRECISION RINTI C C Parameter variables C DOUBLE PRECISION EPS3 PARAMETER (EPS3=1.D-3) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER J C C Local variables C DOUBLE PRECISION RESULT,WA,WW,WWX DOUBLE PRECISION WWY INTEGER I,IJ,IJJ,JA INTEGER JB,JJ,LB,NGRID C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C DOUBLE PRECISION ECV(MXNO) INTEGER IECC(MXNO),NEC COMMON / OFFD / ECV,IECC,NEC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (NEC.EQ.0) RETURN C C Tabulate direct and exchange potentials for orbital J C CALL YPOT(J,WW,ONE) CALL XPOT(J,ONE,WWX,WWY) C NGRID = MPOIN(J) DO I = 1,NGRID Q(I) = YP(I) PC(I) = XTP(I) QC(I) = XTQ(I) ENDDO C DO LB = 1,NEC C C Search list for contributing Lagrange multiplier C JA = IECC(LB)/NW1 JB = IECC(LB)-NW1*JA C IF (J.EQ.JA) THEN JJ = JB C ELSE IF (J.EQ.JB) THEN JJ = JA C ELSE GOTO 10 C ENDIF C ENDIF C CALL YPOT(JJ,WW,ONE) CALL XPOT(JJ,ONE,WWX,WWY) C IF (ABS(UCF(J)-UCF(JJ)).LT.EPS3 .AND. JFIX(JJ).EQ.0) THEN C C Orbitals J and JJ have the same occupation numbers. C Skip if option 3 is set. C IF (ITC(3).EQ.1) THEN ECV(LB) = ZERO C ELSE C NGRID = MIN(MPOIN(J),MPOIN(JJ)) IJ = MPOS(J) IJJ = MPOS(JJ) DO I = 1,NGRID TA(I) = (PF(IJ)*PF(IJJ)+QF(IJ)*QF(IJJ))*(Q(I)+YP(I)-TWO*ZZ! +(I))+(PF(IJJ)*QC(I)-QF(IJJ)*PC(I))*C+(PF(IJ)*XTQ(I)-QF(IJ)*XTP(I))! +*C IJ = IJ+1 IJJ = IJJ+1 ENDDO C CALL QUAD(NGRID,RESULT) C WA = RINTI(J,JJ) ECV(LB) = ECV(LB)+(RESULT-WA-WA)*UCF(J)*UCF(JJ)/(UCF(JJ)+UCF! +(J)) ENDIF C ELSE C C Orbitals J and JJ have different occupation numbers. C NGRID = MIN(MPOIN(J),MPOIN(JJ)) IJ = MPOS(J) IJJ = MPOS(JJ) DO I = 1,NGRID TA(I) = (PF(IJ)*PF(IJJ)+QF(IJ)*QF(IJJ))*(Q(I)-YP(I))+(PF(IJJ! +)*QC(I)-QF(IJJ)*PC(I))*C-(PF(IJ)*XTQ(I)-QF(IJ)*XTP(I))*C IJ = IJ+1 IJJ = IJJ+1 ENDDO C CALL QUAD(NGRID,RESULT) C IF (JFIX(JJ).EQ.0) THEN ECV(LB) = ECV(LB)+RESULT*UCF(J)*UCF(JJ)/(UCF(JJ)-UCF(J)) C ELSE ECV(LB) = ECV(LB)+RESULT*UCF(J) ENDIF C ENDIF C 10 CONTINUE ENDDO C END C C ******************* C SUBROUTINE LOAD(IDT) C C----------------------------------------------------------------------- C C This routine reads the wavefunctions and other information dumped C by the MCDF program. The orbitals and their occupation numbers are C checked for consistency. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER IDT C C Local variables C CHARACTER*80 IHEDIN CHARACTER*2 NHCHK(MXNW) CHARACTER*20 RECIN INTEGER I,J,M,NAKX INTEGER NCFCHK,NEC,NPCHK(MXNW),NSTART INTEGER NSTOP,NWCHK LOGICAL OK C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3180) C C Read basic information. C REWIND IDT READ (IDT) IHEDIN,RECIN READ (IDT) NCMIN,NWCHK,NCFCHK,N READ (IDT) Z,RNT,H,C C WRITE (IWRITE,3020) IHEDIN(1:40),IHEDIN(41:80),RECIN C C Test dump for completeness (i.e. Z>0) C IF (Z.LE.ZERO) THEN WRITE (IWRITE,3010) WRITE (IPUNCH,3010) STOP ENDIF C IF (N.GT.MXNP) THEN WRITE (IWRITE,3030) N,MXNP WRITE (IPUNCH,3030) N,MXNP STOP ENDIF C IF (N.GT.MAXDIM(7)) MAXDIM(7) = N C IF (NWCHK.GT.MXNW) THEN WRITE (IWRITE,3140) NWCHK,MXNW WRITE (IPUNCH,3140) NWCHK,MXNW STOP ENDIF C IF (NWCHK.GT.MAXDIM(1)) MAXDIM(1) = NWCHK C IF (NCFCHK.GT.MXNC) THEN WRITE (IWRITE,3150) NCFCHK,MXNC WRITE (IPUNCH,3150) NCFCHK,MXNC STOP ENDIF C IF (NCFCHK.GT.MAXDIM(2)) MAXDIM(2) = NCFCHK C C set up the logarithmic grid C EPH = EXP(H) RGRID(1) = RNT DO I = 2,N RGRID(I) = RGRID(I-1)*EPH ENDDO C DO I = 1,NWCHK MPOIN(I) = N ENDDO C C read orbital information C NSTART = 1 DO I = 1,NWCHK C READ (IDT) NHCHK(I),NPCHK(I),NAKX,E(I) READ (IDT) READ (IDT) (TA(J),J=1,N), (TB(J),J=1,N) C C set the arrays MPOIN and MPOS C DO J = N,1,-1 IF (ABS(TA(J)).GT.CUTOFF) GOTO 10 ENDDO C 10 CONTINUE MPOIN(I) = J MPOS(I) = NSTART C NSTOP = MPOIN(I)+NSTART-1 IF (NSTOP.GT.MXNG) THEN WRITE (IWRITE,3040) NSTOP,MXNG WRITE (IPUNCH,3040) NSTOP,MXNG STOP ENDIF C M = 1 DO J = NSTART,NSTOP PF(J) = TA(M) QF(J) = TB(M) M = M+1 ENDDO C NSTART = NSTOP+1 ENDDO C IF (NSTOP.GT.MAXDIM(17)) MAXDIM(17) = NSTOP C C read generalised occupation and mixing numbers. C READ (IDT) READ (IDT) (UCF(I),I=1,NWCHK) IF (NCMIN.GT.0) THEN READ (IDT) READ (IDT) (ICCMIN(I),I=1,NCMIN) ENDIF C C read occupation numbers and eigenvectors C READ (IDT) READ (IDT) EAV, ((COUVEC(I,J),J=1,NCFCHK),I=1,NCFCHK),(COUENG(I),I! +=1,NCFCHK) C C skip over Lagrange multipliers C READ (IDT) NEC IF (NEC.GT.0) THEN READ (IDT) ENDIF C C read in nuclear information C READ (IDT) NUCTYP READ (IDT) (ZZ(I),I=1,N) READ (IDT) Z1 READ (IDT) NPARM IF (NPARM.GT.0) THEN READ (IDT) (PARM(I),I=1,NPARM) ENDIF C READ (IDT) READ (IDT) READ (IDT) READ (IDT) READ (IDT) C C check for consistency C IF (NW.GT.NWCHK) GOTO 20 C DO I = 1,NW IF (NPCHK(I).NE.NP(I) .OR. NHCHK(I).NE.NH(I)) GOTO 20 ENDDO C IF (NWCHK.NE.NW) GOTO 30 IF (NCFCHK.NE.NCF) GOTO 30 C OK = .TRUE. GOTO 40 C C error message C 20 CONTINUE WRITE (IWRITE,3000) OK = .FALSE. GOTO 40 C 30 CONTINUE WRITE (IWRITE,3170) OK = .TRUE. C----------------------------------------------------------------------- 40 CONTINUE WRITE (IWRITE,3050) Z,C,RNT,H,CUTOFF,NW,NCF C IF (NCMIN.EQ.0) THEN WRITE (IWRITE,3060) ELSE IF (NCMIN.GT.0) THEN WRITE (IWRITE,3070) NCMIN, (ICCMIN(I),I=1,NCMIN) ENDIF ENDIF C WRITE (IWRITE,3080) DO I = 1,NWCHK WRITE (IWRITE,3090) I,NPCHK(I),NHCHK(I),MPOIN(I) ENDDO C IF (NUCTYP.EQ.0) THEN WRITE (IWRITE,3100) ELSE IF (NUCTYP.EQ.1) THEN WRITE (IWRITE,3110) PARM(1) ELSE IF (NUCTYP.EQ.2) THEN WRITE (IWRITE,3120) PARM(1),PARM(2) ELSE IF (NUCTYP.EQ.3) THEN WRITE (IWRITE,3130) (PARM(I),I=1,4) ENDIF ENDIF ENDIF ENDIF C WRITE (IWRITE,3160) NSTOP C IF (OK) THEN WRITE (IWRITE,3190) RETURN ELSE STOP ENDIF C----------------------------------------------------------------------- 3000 FORMAT (/' ERROR in LOAD : input data is not consistent with dump'! +/' The orbitals are different ... STOPPING'/ ! +' CHECK the following information with input data') 3010 FORMAT (/' ERROR in LOAD : dump read is not complete ... STOPPING'! +) 3020 FORMAT (/' Dump title : ',A40/' ',A40/ ! +' Run at : ',A20) 3030 FORMAT (/' ERROR in LOAD : dimension for grid points ... STOPPING'! +/' N =',I4,' but dimension is ',I4) 3040 FORMAT (/ ! +' ERROR in LOAD : dimension for PF,QF arrays ... STOPPING'/ ! +' NSTOP =',I6,' but dimension is ',I6) 3050 FORMAT (/' Z (atomic number) = ',F6.2/ ! +' C (speed of light) = ',1P,E17.10/ ! +' RNT (first grid point) = ',E10.3/ ! +' H (grid step-size) = ',E10.3/ ! +' CUTOFF (wave-function cut-off parameter) = ',E10.3/ ! +' NW (number of orbitals) = ',I6/ ! +' NCF (number of CSFs) = ',I6) 3060 FORMAT (/' average level calculation') 3070 FORMAT (/' optimal level calculation on ',I4,' levels namely :'/(1! +X,10I4)) 3080 FORMAT (/' orbital NPOINT'/) 3090 FORMAT (1X,I2,1X,I2,A2,7X,I4) 3100 FORMAT (/' point nucleus calculation') 3110 FORMAT (/' uniform nuclear charge calculation with atomic weight '! +,1P,E12.5) 3120 FORMAT (/' Fermi two parameter nuclear charge distribution'/ ! +' with half radius ',1P,E12.5,' and skin thickness ',E12.5) 3130 FORMAT (/' user supplied nuclear potential via parameters '/1X,1P,! +4E14.5) 3140 FORMAT (/' ERROR in LOAD : dimension for orbitals ... STOPPING'/ ! +' NWCHK =',I4,' but dimension is ',I4) 3150 FORMAT (/' ERROR in LOAD : dimension for CSFs ... STOPPING'/ ! +' NCFCHK =',I4,' but dimension is ',I4) 3160 FORMAT (/' the size of the PF,QF arrays is ',I6) 3170 FORMAT (/ ! +' WARNING from LOAD : input data is not consistent with dump'/ ! +' The number of orbitals or CSFs differ.'/ ! +' The program will continue assuming this is a CI case.'/ ! +' CHECK the following information with input data') 3180 FORMAT (/' >>>> routine LOAD called : MCDF/BENA dump being read') 3190 FORMAT (/' >>>> returning from routine LOAD') END C C ******************* C SUBROUTINE LSTERM C C----------------------------------------------------------------------- C C This subroutine sets up LS terms for each unfilled subshell, C storing V,S and L values in the array LSVT. Limitations on C configurations are (1) Q < 3 and (2) L < 3, Q > 3, where C Q is the reduced occupation, i.e. 4L+2-Q if Q > 2L+1, and C L is the subshell orbital angular momentum C C No subroutines called C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Local variables C INTEGER I,IOPEN,L,M INTEGER NFULL,NL,NLL,NQ INTEGER NTRM C C Common variables C INTEGER IDN(5),IDNL(16,5),IDNS(16,5) INTEGER IDNV(16,5) COMMON / CSFD / IDNV,IDNS,IDNL,IDN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER JPOS(4),MLX(4),MQX(4),NOPEN COMMON / NRD01 / MLX,MQX,JPOS,NOPEN C C Common variables C INTEGER LSVT(5,16,4),NTERM(4) COMMON / NRD02 / NTERM,LSVT Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO IOPEN = 1,NOPEN NQ = MQX(IOPEN) NL = MLX(IOPEN) NLL = NL+NL+1 NFULL = NLL+NLL NQ = MIN(NQ,NFULL-NQ) IF (NQ-2) 10,20,30 C C one electron C 10 CONTINUE LSVT(1,1,IOPEN) = 1 LSVT(2,1,IOPEN) = 2 LSVT(3,1,IOPEN) = NLL NTERM(IOPEN) = 1 GOTO 60 C C two electrons C 20 CONTINUE L = NFULL+1 DO I = 1,NL L = L-4 LSVT(1,I,IOPEN) = 2 LSVT(2,I,IOPEN) = 3 LSVT(3,I,IOPEN) = L ENDDO L = NFULL+3 M = NL+1 DO I = M,NLL L = L-4 LSVT(1,I,IOPEN) = 2 LSVT(2,I,IOPEN) = 1 LSVT(3,I,IOPEN) = L ENDDO LSVT(1,NLL,IOPEN) = 0 NTERM(IOPEN) = NLL GOTO 60 C C more than two electrons C 30 CONTINUE IF (NL-2) 40,50,70 40 CONTINUE LSVT(1,1,IOPEN) = 3 LSVT(2,1,IOPEN) = 4 LSVT(3,1,IOPEN) = 1 L = 7 DO I = 2,3 L = L-2 LSVT(1,I,IOPEN) = L-2 LSVT(2,I,IOPEN) = 2 LSVT(3,I,IOPEN) = L ENDDO NTERM(IOPEN) = 3 GOTO 60 C 50 CONTINUE NTRM = IDN(NQ) DO I = 1,NTRM LSVT(1,I,IOPEN) = IDNV(I,NQ) LSVT(2,I,IOPEN) = IDNS(I,NQ) LSVT(3,I,IOPEN) = IDNL(I,NQ) ENDDO NTERM(IOPEN) = NTRM 60 CONTINUE ENDDO RETURN C C failure for more than two electrons for subshell with L > 2 C 70 CONTINUE WRITE (IWRITE,3000) WRITE (IPUNCH,3000) STOP C 3000 FORMAT (/1X, ! +'ERROR in LSTERM : more than 2 electrons for subshells with l>2 ',! +'not allowed') END C C ******************* C SUBROUTINE LTAB(IS,NQS,KS,IROWS) C C----------------------------------------------------------------------- C C Locates rows of possible parents of active shell states for C accessing NTAB. C C It is assumed that empty shells have been eliminated from C consideration by subroutine RKCO. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Argument variables C INTEGER IROWS(4),IS(4),KS(4),NQS(4) C C Local variables C INTEGER I,KQ(4),KQ1,KQ2 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IS(1).EQ.IS(2)) NQS(1) = NQS(2) - 1 IF (IS(3).EQ.IS(4)) NQS(3) = NQS(4) - 1 C DO I = 1,4 C C Fault exit - input data inconsistent C IF (NQS(I).LE.0 .OR. NQS(I).GT.KS(I)) THEN WRITE (IWRITE,3000) NQS(I),IS(I),KS(I) IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) NQS(I),IS(I),KS(I) STOP ENDIF C KQ1 = NQS(I)-1 KQ2 = KS(I)-KQ1 KQ(I) = MIN(KQ1,KQ2)+1 C C Normal status - pointer properly defined. C IF (KQ(I).NE.1) THEN IROWS(I) = (KS(I)*(KS(I)-2))/8+KQ(I) ELSE IROWS(I) = 1 ENDIF C ENDDO C 3000 FORMAT (/' Termination in LTAB because of data ERROR'/1X,I4, ! +'electrons in shell ',I3,' with 2j+1 =',I3) END C C ******************* C SUBROUTINE MAN4(IWRITE,KCHOP,IPAR,JMIN,JMAX,MFAIL,JSTORE) C C----------------------------------------------------------------------- C C IWRITE = stream for output to printer C C KCHOP C IPAR = parity C JMIN = min 2J C JMAX = max 2J C C For a particular configuration this routine evaluates C all the possible ways of coupling the open shells C defined by MLX ( L values ) and MQX ( occupation numbers ) C to give the resultant total J value JF. C IPAR is the parity of the configuration. C C The results are then used to fill the COMMON blocks C ORB06 and ORB07. C C Routines called : COUP C C Tree of subprogram calls: C C MAN4 C COUP C C Common block MAXDIM: C Elements never used, never set: NAXDIM C Common block NRD01: C Elements used but never set: JPOS C Elements never used, never set: NOPEN C Common block ORB04: C Elements used but never set: NW C Elements never used, never set: NP NAK C Common block ORB05: C Elements used but never set: NKJ C Elements never used, never set: NKL C Common block ORB06: C Elements set but never used: JQS JCUP C Elements never used, never set: IEXC C Common block ORB07: C Elements set but never used: all C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER JSTMAX PARAMETER (JSTMAX=40) INTEGER ICASEX PARAMETER (ICASEX=100) C C Argument variables C INTEGER IPAR,IWRITE,JMAX,JMIN INTEGER JSTORE(0:JSTMAX),KCHOP(MXNW) LOGICAL MFAIL C C Local variables C INTEGER ICUP,JF,JFMAX,JFMIN INTEGER JK,JL,JM,JST INTEGER K,KC,KCASE INTEGER KCUP(ICASEX),KMAX,KMIN INTEGER KQ(2,ICASEX),KQS(3,2,ICASEX) INTEGER L,LA,LC,LCASE INTEGER LCUP(ICASEX),LL,LMAX INTEGER LMIN,LP,LQ(2,ICASEX) INTEGER LQS(3,2,ICASEX),MC,MCASE INTEGER MCUP(ICASEX),MMAX,MMIN INTEGER MODE,MQ(2,ICASEX) INTEGER MQS(3,2,ICASEX),NC,NCASE INTEGER NCUP(ICASEX),NQ(2,ICASEX) INTEGER NQS(3,2,ICASEX) C C Common variables C INTEGER MAXDIM(20),NAXDIM(20) COMMON / MAXDIM / MAXDIM,NAXDIM C C Common variables C INTEGER JPOS(4),MLX(4),MQX(4),NOPEN COMMON / NRD01 / MLX,MQX,JPOS,NOPEN C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO JST = 0,JSTMAX JSTORE(JST) = 0 ENDDO C CALL COUP(IWRITE,MLX(1),MQX(1),0,0,KQS,KQ,KCUP,KCASE,0,ICASEX) C IF (KCASE.GT.0) THEN DO KC = 1,KCASE KMIN = ABS(KCUP(KC)-KQS(3,2,KC)) KMAX = KCUP(KC)+KQS(3,2,KC)-2 DO JK = KMIN,KMAX,2 CALL COUP(IWRITE,MLX(2),MQX(2),JK,0,LQS,LQ,LCUP,LCASE,0,ICAS! +EX) C IF (LCASE.GT.0) THEN DO LC = 1,LCASE LMIN = ABS(LCUP(LC)-LQS(3,2,LC)) LMAX = LCUP(LC)+LQS(3,2,LC)-2 DO JL = LMIN,LMAX,2 CALL COUP(IWRITE,MLX(3),MQX(3),JL,0,MQS,MQ,MCUP,MCASE,! +0,ICASEX) C IF (MCASE.GT.0) THEN DO MC = 1,MCASE MMIN = ABS(MCUP(MC)-MQS(3,2,MC)) MMAX = MCUP(MC)+MQS(3,2,MC)-2 DO JM = MMIN,MMAX,2 C DO JF = JMIN,JMAX,1 C IF (JF.LT.0) THEN MODE = 0 ELSE MODE = 1 ENDIF C CALL COUP(IWRITE,MLX(4),MQX(4),JM,JF,NQS,NQ,NC! +UP,NCASE,MODE,ICASEX) C IF (NCASE.GT.0) THEN DO NC = 1,NCASE C***** IF (JF.LT.0) THEN JFMIN = ABS(NCUP(NC)-NQS(3,2,NC)) JFMAX = NCUP(NC)+NQS(3,2,NC)-2 ELSE JFMIN = JF JFMAX = JF ENDIF C 10 CONTINUE NCF = NCF+1 IF (NCF.GT.MXNC) THEN MFAIL = .TRUE. GOTO 130 ENDIF C DO L = 1,NW JQS(1,L,NCF) = 0 JQS(2,L,NCF) = 0 JQS(3,L,NCF) = 1 ICHOP(L,NCF) = -1 IF (KCHOP(L).EQ.-1) THEN IQ(L,NCF) = 0 ELSE IQ(L,NCF) = NKJ(L)+1 ENDIF ENDDO C C LP = JPOS(1) IF (LP.GT.NW) GOTO 20 DO K = 1,3 JQS(K,LP,NCF) = KQS(K,2,KC) IQ(LP,NCF) = KQ(2,KC) IF (MLX(1).GT.0) THEN JQS(K,LP-1,NCF) = KQS(K,1,KC) IQ(LP-1,NCF) = KQ(1,KC) ENDIF ENDDO C LP = JPOS(2) IF (LP.GT.NW) GOTO 20 DO K = 1,3 JQS(K,LP,NCF) = LQS(K,2,LC) IQ(LP,NCF) = LQ(2,LC) IF (MLX(2).GT.0) THEN JQS(K,LP-1,NCF) = LQS(K,1,LC) IQ(LP-1,NCF) = LQ(1,LC) ENDIF ENDDO C LP = JPOS(3) IF (LP.GT.NW) GOTO 20 DO K = 1,3 JQS(K,LP,NCF) = MQS(K,2,MC) IQ(LP,NCF) = MQ(2,MC) IF (MLX(3).GT.0) THEN JQS(K,LP-1,NCF) = MQS(K,1,MC) IQ(LP-1,NCF) = MQ(1,MC) ENDIF ENDDO C LP = JPOS(4) IF (LP.GT.NW) GOTO 20 DO K = 1,3 JQS(K,LP,NCF) = NQS(K,2,NC) IQ(LP,NCF) = NQ(2,NC) IF (MLX(4).GT.0) THEN JQS(K,LP-1,NCF) = NQS(K,1,NC) IQ(LP-1,NCF) = NQ(1,NC) ENDIF ENDDO C C 20 CONTINUE LA = 0 DO L = 1,4 LP = JPOS(L) IF (LP.GT.NW) GOTO 30 LA = LA+2 IF (IQ(LP,NCF).EQ.NKJ(LP)+1) THEN ICHOP(LA,NCF) = 1 ELSEIF (IQ(LP,NCF).EQ.0) THEN ICHOP(LA,NCF) = -1 ELSE ICHOP(LA,NCF) = 0 ENDIF IF (MLX(L).GT.0) THEN IF (IQ(LP-1,NCF).EQ.NKJ(LP-1)+1) THEN ICHOP(LA-1,NCF) = 1 ELSEIF (IQ(LP-1,NCF).EQ.0) THEN ICHOP(LA-1,NCF) = -1 ELSE ICHOP(LA-1,NCF) = 0 ENDIF ELSE ICHOP(LA-1,NCF) = -1 ENDIF ENDDO C 30 CONTINUE ICUP = 1 DO L = 1,8 LL = L IF (ICHOP(L,NCF).EQ.0) GOTO 40 ENDDO GOTO 120 C 40 CONTINUE GOTO (50,60,70,80,90,100,110,120),LL C 50 CONTINUE IF (ICHOP(2,NCF).NE.0) GOTO 60 JCUP(ICUP,NCF) = JK+1 ICUP = ICUP+1 60 CONTINUE IF (ICHOP(3,NCF).NE.0) GOTO 70 JCUP(ICUP,NCF) = LCUP(LC) ICUP = ICUP+1 70 CONTINUE IF (ICHOP(4,NCF).NE.0) GOTO 80 JCUP(ICUP,NCF) = JL+1 ICUP = ICUP+1 80 CONTINUE IF (ICHOP(5,NCF).NE.0) GOTO 90 JCUP(ICUP,NCF) = MCUP(MC) ICUP = ICUP+1 90 CONTINUE IF (ICHOP(6,NCF).NE.0) GOTO 100 JCUP(ICUP,NCF) = JM+1 ICUP = ICUP+1 100 CONTINUE IF (ICHOP(7,NCF).NE.0) GOTO 110 JCUP(ICUP,NCF) = NCUP(NC) ICUP = ICUP+1 110 CONTINUE IF (ICHOP(8,NCF).NE.0) GOTO 120 JCUP(ICUP,NCF) = JFMIN+1 120 CONTINUE C DO L = 1,NW ICHOP(L,NCF) = 0 IF (IQ(L,NCF).EQ.NKJ(L)+1) ICHOP(L,NCF) ! += 1 IF (IQ(L,NCF).EQ.0) ICHOP(L,NCF) = -1 ENDDO C ITJPO(NCF) = JFMIN+1 ISPAR(NCF) = IPAR C 130 CONTINUE IF (JFMIN .LE. JSTMAX) THEN JSTORE(JFMIN) = JSTORE(JFMIN)+1 ENDIF JFMIN = JFMIN+2 IF (JFMIN.LE.JFMAX) GOTO 10 C****** ENDDO ENDIF C ENDDO ENDDO ENDDO ENDIF C ENDDO ENDDO ENDIF C ENDDO ENDDO ENDIF C IF (NCF.GT.MAXDIM(2)) MAXDIM(2) = NCF C END C C ******************* C SUBROUTINE MANOUT(NCFST) C C----------------------------------------------------------------------- C C This routine prints out CSF data in a form which C can be read by subroutine DATR i.e. relativistic C CSF format. A description of this format is given C in the CPC-80 write-up of GRASP V0 C C NCFST is the first-1 CSF in the list to be considered C thus in GRASP NCFST=O C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER NCFST C C Local variables C CHARACTER*4 IBL,IOUT(19),JLAB(20),NUM(20) INTEGER I,IERR,IQ1,IX INTEGER J,JJ,JX,K INTEGER NCF1,NCF2,NCFS,NFULL INTEGER NOCC,NOPEN,NX C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER JTC(20) COMMON / OPT02 / JTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA NUM/'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 ','! +8 ','9 ','10 ','11 ','12 ','13 ','14 ','15 ','16 ','17 ! + ','18 ','19 '/ DATA JLAB/'0 ','1/2 ','1 ','3/2 ','2 ','5/2 ','3 ','7/2 ',! +'4 ','9/2 ','5 ','11/2','6 ','13/2','7 ','15/2','8 ','17! +/2','9 ','19/2'/ DATA IBL/' '/ C----------------------------------------------------------------------- NCF1 = NCFST+1 NCF2 = NCFST+2 NCFS = NCF-NCFST C IF (NCFS.EQ.0) THEN WRITE (IWRITE,3040) RETURN ENDIF C WRITE (IWRITE,3020) WRITE (IWRITE,3050) NCFS,NW C DO I = 1,NW C IQ1 = IQ(I,NCF1) C IF (NCFS.GT.1) THEN DO J = NCF2,NCF IF (IQ(I,J).NE.IQ1) THEN WRITE (IWRITE,3030) NP(I),NH(I), (IQ(I,K),K=NCF1,NCF) GOTO 10 ENDIF ENDDO ENDIF C IF (IQ1.EQ.NKJ(I)+1) THEN WRITE (IWRITE,3030) NP(I),NH(I) ELSE WRITE (IWRITE,3030) NP(I),NH(I),IQ1 ENDIF C 10 CONTINUE ENDDO C IX = 0 C DO J = 1,9 IF (JTC(J).EQ.0) GOTO 20 IX = IX+1 IOUT(IX) = NUM(J+1) 20 CONTINUE ENDDO C IF (IX.GT.0) THEN WRITE (IWRITE,3060) (IOUT(I),I=1,IX) ELSE WRITE (IWRITE,3060) ENDIF C IERR = 0 C DO J = NCF1,NCF JJ = J-NCFST IX = 0 NOPEN = 0 C DO I = 1,NW IF (ICHOP(I,J).EQ.0) THEN NOPEN = NOPEN+1 NFULL = NKJ(I)+1 NOCC = IQ(I,J) NOCC = MIN(NOCC,NFULL-NOCC) C IF (NOCC.EQ.1) GOTO 30 C IF (NOCC.GT.2 .AND. NFULL.GT.8) THEN WRITE (IWRITE,3010) IERR = IERR+1 GOTO 40 ENDIF C JX = JQS(3,I,J) IX = IX+1 IOUT(IX) = JLAB(JX) IF (NFULL.NE.8) GOTO 30 IF (NOCC.NE.4) GOTO 30 IF (JX.NE.5 .AND. JX.NE.9) GOTO 30 JX = JQS(1,I,J) IX = IX+1 IOUT(IX) = NUM(JX+1) C ENDIF C 30 CONTINUE ENDDO C IF (NOPEN.GT.1) THEN NX = NOPEN-1 IX = IX+1 IOUT(IX) = IBL DO I = 1,NX JX = JCUP(I,J) IX = IX+1 IOUT(IX) = JLAB(JX) ENDDO ENDIF C IF (IX.GT.0) THEN WRITE (IWRITE,3000) JJ, (IOUT(I),I=1,IX) ENDIF C 40 CONTINUE ENDDO C IF (IERR.GT.0) THEN STOP ELSE RETURN ENDIF C 3000 FORMAT (1X,I4,1X,19A4) 3010 FORMAT (' MANOUT : data cannot be read by program....STOPPING') 3020 FORMAT (/' Equivalent Relativistic Input Data'/) 3030 FORMAT (1X,I2,A2,1X,24I3,2X,'C'/(6X,24I3,2X,'C')) 3040 FORMAT (/' no configurations generated'/) 3050 FORMAT (1X,2I4) 3060 FORMAT (' ANG ',19A4) END C C ******************* C SUBROUTINE MATOUT(IWRITE,HAMIL,NR,NC,NRX,NCX,MODE) C C----------------------------------------------------------------------- C C Routine for printing matrices. C C MODE=1 symmetric C MODE=2 unsymmetric C MODE=3 matrix of eigenvectors C MODE=4 unsymmetric with no heading C MODE=5 symmetric with no heading C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Argument variables C INTEGER IWRITE,MODE,NC,NCX INTEGER NR,NRX DOUBLE PRECISION HAMIL(NRX,NCX) C C Local variables C INTEGER J1,J2,J3,JM INTEGER JP,L,L1,L2 INTEGER M Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (MODE.EQ.1 .OR. MODE.EQ.5) GOTO 10 IF (MODE.GT.1 .AND. MODE.LT.5) GOTO 80 RETURN C----------------------------------------------------------------------- C C Symmetric matrix. C C----------------------------------------------------------------------- 10 CONTINUE IF (MODE.EQ.1) WRITE (IWRITE,3070) JP = 5 J1 = 1 J2 = JP C 20 CONTINUE IF (J2.GT.NR) J2 = NR DO L1 = 1,J1 WRITE (IWRITE,3010) (HAMIL(L1,L2),L2=J1,J2) ENDDO C JM = J2-J1 J3 = J1+1 C IF (JM.EQ.0) RETURN IF (JM.EQ.1) GOTO 30 IF (JM.EQ.2) GOTO 40 IF (JM.EQ.3) GOTO 50 IF (JM.EQ.4) GOTO 60 C 30 CONTINUE WRITE (IWRITE,3030) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2) GOTO 70 C 40 CONTINUE WRITE (IWRITE,3040) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2) GOTO 70 C 50 CONTINUE WRITE (IWRITE,3050) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2) GOTO 70 C 60 CONTINUE WRITE (IWRITE,3060) ((HAMIL(L1,L2),L2=L1,J2),L1=J3,J2) C 70 CONTINUE IF (J2.EQ.NR) RETURN J1 = J1+JP J2 = J2+JP GOTO 20 C----------------------------------------------------------------------- C C Unsymmetric matrix. C C----------------------------------------------------------------------- 80 CONTINUE IF (MODE.EQ.2) WRITE (IWRITE,3070) IF (MODE.EQ.3) WRITE (IWRITE,3080) JP = 5 J1 = 1 J2 = JP 90 CONTINUE IF (J2.GT.NC) J2 = NC IF (MODE.EQ.3) THEN WRITE (IWRITE,3000) (L,L=J1,J2) WRITE (IWRITE,3020) ENDIF C DO M = 1,NR WRITE (IWRITE,3010) (HAMIL(M,L),L=J1,J2) ENDDO WRITE (IWRITE,3020) IF (J2.EQ.NC) RETURN J1 = J1+JP J2 = J2+JP GOTO 90 C 3000 FORMAT (1X,5(I8,7X)) 3010 FORMAT (1X,1P,5E15.7) 3020 FORMAT (1X) 3030 FORMAT (16X,1P,E15.7/) 3040 FORMAT (16X,1P,2E15.7/31X,E15.7/) 3050 FORMAT (16X,1P,3E15.7/31X,2E15.7/46X,E15.7/) 3060 FORMAT (16X,1P,4E15.7/31X,3E15.7/46X,2E15.7/61X,E15.7/) 3070 FORMAT (/' matrix elements'/) 3080 FORMAT (/' eigenvectors'/) END C C ******************* C SUBROUTINE MATRIX C C----------------------------------------------------------------------- C C This subroutine forms the zero-order Coulomb Hamiltonian matrix and C diagonalises it. New estimates of the configuration mixing C coefficients are obtained. C C Subroutine called: DSYEV C C Diagonalisation is now by Jp - nrb 17/09/08 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL CLRX,RINTI,SLATER DOUBLE PRECISION CLRX,RINTI,SLATER C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N10 PARAMETER (N10=MXNX*MXNC) INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) INTEGER LWORK PARAMETER (LWORK=MXNC*3-1) C C Local variables C DOUBLE PRECISION AM,AMAX,COEF,EAU DOUBLE PRECISION FACTOR,WA,WB DOUBLE PRECISION WORK(LWORK) INTEGER I,IA,ICOEF,IFA INTEGER IFB,II,IJ,IL INTEGER ILCX,ILDA,ILDB,ILDN INTEGER IMARK,INFO,IP,IQA INTEGER IQB,IRS,ITR,ITRP INTEGER J,JA,JB,JJ INTEGER JM,JTR,K,KA INTEGER KB,KC,KD,KK INTEGER KMX,L,LM,LMN INTEGER LMX,NCFM,NWM C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C integer jtc(20) common / opt02 / jtc C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR C C Common variables C double precision tmpvec(mxnc,mxnc) double precision tmpeng(mxnc),ee,t integer itmp(mxnc),jtmp(mxnc),ncf0,nsym common /nrbtmp/ tmpvec,tmpeng,ee,t x ,itmp,jtmp,ncf0,nsym Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C----------------------------------------------------------------------- C C Zeroise the array containing the Hamiltonian. C C----------------------------------------------------------------------- DO ITR = 1,NCF DO JTR = 1,NCF COUVEC(ITR,JTR) = ZERO ENDDO ENDDO c if(jtc(13).eq.0)return c WRITE (IWRITE,3000) C C----------------------------------------------------------------------- C C I integrals C C----------------------------------------------------------------------- DO JA = 1,NW WA = RINTI(JA,JA) DO ITR = 1,NCF WB = IQ(JA,ITR) COUVEC(ITR,ITR) = COUVEC(ITR,ITR)+WA*WB ENDDO ENDDO C----------------------------------------------------------------------- C C F integrals C C----------------------------------------------------------------------- DO JA = 1,NW KA = NAK(JA) IFA = NKJ(JA)+1 DO JB = JA,NW IFB = NKJ(JB)+1 C C Determine bounds in sum over K C KMX = IFA IF (IFA.GT.IFB) KMX = IFB DO L = 1,KMX,2 K = L-1 C C Determine the angular coefficient. C ICOEF = 0 IMARK = 0 DO ITR = 1,NCF WB = ZERO IQA = IQ(JA,ITR) IQB = IQ(JB,ITR) IF (IQA.EQ.0 .OR. IQB.EQ.0) GOTO 10 C C If either orbital is in closed shell. C IF (IQA.EQ.IFA .OR. IQB.EQ.IFB) THEN IF (JA.EQ.JB) THEN IF (K.EQ.0) THEN WB = HALF*IQA*(IQA-1) IMARK = 1 ELSE IF (ICOEF.EQ.0) THEN COEF = CLRX(KA,K,KA)**2 ICOEF = 1 ENDIF WB = -HALF*IQA*IQA*COEF IMARK = 1 ENDIF ELSE IF (K.EQ.0) THEN WB = IQA*IQB IMARK = 1 ENDIF ENDIF C C If both are in open shells. C ELSE C IF (NMCP.GT.0) THEN IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR ILDN = NNLDR(IRS) IF (ILDN.GT.0) THEN ILDA = NSLDF(IRS) ILDB = ILDA+ILDN-1 ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JA)*NW1+JB DO IL = ILDA,ILDB IF (ILCX.EQ.ISLDR(IL)) THEN WB = XSLDR(IL) IMARK = 1 GOTO 10 ENDIF ENDDO ENDIF ENDIF C ENDIF C 10 CONTINUE BREENG(ITR) = WB ENDDO C C Add to diagonal elements. C IF (IMARK.EQ.1) THEN C C Evaluate Slater integral. C WA = SLATER(JA,JB,JA,JB,K) C DO ITR = 1,NCF COUVEC(ITR,ITR) = COUVEC(ITR,ITR)+BREENG(ITR)*WA ENDDO C ENDIF C ENDDO ENDDO ENDDO C----------------------------------------------------------------------- C C G integrals C C----------------------------------------------------------------------- IF (NW.EQ.1) GOTO 30 C NWM = NW-1 DO JA = 1,NWM JM = JA+1 KA = NAK(JA) IFA = NKJ(JA)+1 DO JB = JM,NW KB = NAK(JB) IFB = NKJ(JB)+1 C C Determine bounds in sum over K C LMN = ABS(IFA-IFB)/2+1 LMX = (IFA+IFB)/2 IF (KA*KB.LT.0) LMN = LMN + 1 DO LM = LMN,LMX,2 K = LM-1 C C Determine the angular coefficient. C ICOEF = 0 IMARK = 0 DO ITR = 1,NCF WB = ZERO IQA = IQ(JA,ITR) IQB = IQ(JB,ITR) IF (IQA.EQ.0 .OR. IQB.EQ.0) GOTO 20 C C If either orbital is in closed shell. C IF (IQA.EQ.IFA .OR. IQB.EQ.IFB) THEN C IF (ICOEF.EQ.0) THEN COEF = CLRX(KA,K,KB)**2 ICOEF = 1 ENDIF C WB = -IQA*IQB*COEF IMARK = 1 C C If both orbitals are in open shells. C ELSE C IF (NMCP.GT.0) THEN IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR ILDN = NNLDR(IRS) IF (ILDN.GT.0) THEN ILDA = NSLDF(IRS) ILDB = ILDA+ILDN-1 ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JB)*NW1+JA DO IL = ILDA,ILDB IF (ILCX.EQ.ISLDR(IL)) THEN WB = XSLDR(IL) IMARK = 1 GOTO 20 ENDIF ENDDO ENDIF ENDIF C ENDIF C 20 CONTINUE BREENG(ITR) = WB ENDDO C C Add contribution to diagonal element. C IF (IMARK.EQ.1) THEN C C Evaluate Slater integral C WA = SLATER(JA,JB,JB,JA,K) C DO ITR = 1,NCF COUVEC(ITR,ITR) = COUVEC(ITR,ITR)+BREENG(ITR)*WA ENDDO C ENDIF C ENDDO ENDDO ENDDO C----------------------------------------------------------------------- C C R integrals C C----------------------------------------------------------------------- 30 CONTINUE IF (NMCP.GT.0) THEN IF (NCF.GT.1) THEN C C Cycle over the off-diagonal elements C NCFM = NCF-1 DO ITR = 1,NCFM ITRP = ITR+1 C DO JTR = ITRP,NCF IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR ILDN = NNLDR(IRS) C IF (ILDN.GT.0) THEN JA = NSLDF(IRS) JB = JA+ILDN-1 C C Extract corresponding entries from table C DO JJ = JA,JB WB = XSLDR(JJ) C C Decode C ILCX = ISLDR(JJ) KA = MOD(ILCX,NW1) ILCX = ILCX/NW1 KB = MOD(ILCX,NW1) ILCX = ILCX/NW1 KC = MOD(ILCX,NW1) C IF (KC.LE.0) THEN WA = RINTI(KA,KB) ELSE ILCX = ILCX/NW1 KD = MOD(ILCX,NW1) KK = ILCX/NW1 WA = SLATER(KD,KC,KB,KA,KK) ENDIF C COUVEC(ITR,JTR) = COUVEC(ITR,JTR)+WA*WB C ENDDO C ENDIF C ENDDO ENDDO C ENDIF C ENDIF C----------------------------------------------------------------------- C C ----- Hamiltonian evaluated ----- C C Print Hamiltonian matrix if option 5 is set C IF (ITC(5).EQ.1) THEN WRITE (IWRITE,3020) CALL MATOUT(IWRITE,COUVEC,NCF,NCF,MXNC,MXNC,1) ENDIF C----------------------------------------------------------------------- C C Evaluate the average energy C EAV = ZERO C DO ITR = 1,NCF EAV = EAV+COUVEC(ITR,ITR) ENDDO C EAV = EAV/NCF C WRITE (IWRITE,3040) EAV C C Subtract the average energy from the diagonal C DO ITR = 1,NCF COUVEC(ITR,ITR) = COUVEC(ITR,ITR)-EAV ENDDO C C----------------------------------------------------------------------- C C Diagonalise the Hamiltonian by Jp sub-block (nrb) C C----------------------------------------------------------------------- c WRITE (IWRITE,3130) c c Initialize c nsym=0 do itr=1,ncf itmp(itr)=0 enddo c c First, find a symmetry c 40 ncf0=0 do itr=1,ncf if(itmp(itr).eq.0)then !we have a new one nsym=nsym+1 do jtr=1,ncf !find all if(itjpo(itr).eq.itjpo(jtr).and. x ispar(itr).eq.ispar(jtr))then ncf0=ncf0+1 jtmp(ncf0)=jtr itmp(jtr)=nsym endif enddo go to 50 !go diagonalize endif enddo c go to 60 !we are done c 50 do j=1,ncf0 !transfer Jp block jtr=jtmp(j) do i=1,j itr=jtmp(i) tmpvec(i,j)=couvec(itr,jtr) enddo enddo C C Use a LAPACK routine C ij=itjpo(jtmp(1))-1 ip=ispar(jtmp(1)) c write(iwrite,*)'Diagonalizing symmetry:',nsym,' 2J=',ij,' P=',ip c CALL DSYEV ('V','U',ncf0,tmpvec,MXNC,tmpeng,WORK,LWORK,INFO) c IF (INFO.NE.0) THEN WRITE (IWRITE,3010) STOP ENDIF c c Transfer back c do j=1,ncf0 jtr=jtmp(j) breeng(jtr)=tmpeng(j) do i=1,ncf0 itr=jtmp(i) couvec(itr,jtr)=tmpvec(i,j) enddo enddo c c Go look for another symmetry c go to 40 C----------------------------------------------------------------------- C C Diagonalisation of the Hamiltonian complete C C----------------------------------------------------------------------- c c Sort into ascending energy order c 60 do i=1,ncf k=i ee=breeng(k) do j=i+1,ncf if(breeng(j).lt.ee)then k=j ee=breeng(j) endif enddo if(k.ne.i)then breeng(k)=breeng(i) breeng(i)=ee do j=1,ncf t=couvec(j,i) couvec(j,i)=couvec(j,k) couvec(j,k)=t enddo endif enddo C C Add back the average energy C DO ITR = 1,NCF BREENG(ITR) = BREENG(ITR)+EAV ENDDO C----------------------------------------------------------------------- C C Eigenvector elements less than 1e-10 are set to zero. C Set up the array LEV where LEV(J) identifies the dominant CSF for C level J. C The largest mixing coefficient for each CSF is made positive C DO J = 1,NCF IA = 0 AMAX = ZERO DO I = 1,NCF WA = ABS(COUVEC(I,J)) IF (WA.LT.EPS10) COUVEC(I,J) = ZERO IF (WA.GT.AMAX) THEN AMAX = WA IA = I ENDIF ENDDO LEV(J) = IA IF (COUVEC(IA,J).LT.ZERO) THEN DO I = 1,NCF COUVEC(I,J) = -COUVEC(I,J) ENDDO ENDIF ENDDO C----------------------------------------------------------------------- C C Print eigenvalues and eigenvectors if option 6 is set C IF (ITC(6).EQ.1) THEN C WRITE (IWRITE,3080) C DO J = 1,NCPRIN C EAU = BREENG(J) I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) C IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3120) J,IJ,I,AM,EAU ELSE WRITE (IWRITE,3110) J,IJ,I,AM,EAU ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3100) J,IJ,I,AM,EAU ELSE WRITE (IWRITE,3090) J,IJ,I,AM,EAU ENDIF ENDIF C ENDDO C CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3) C ENDIF C----------------------------------------------------------------------- C C Average level C IF (NCMIN.EQ.0) RETURN C----------------------------------------------------------------------- IF (NCMIN.EQ.1) THEN C C Optimal level C II = ICCMIN(1) WRITE (IWRITE,3060) II,BREENG(II) DO I = 1,NCF COUENG(I) = COUVEC(I,II) CCR(I) = COUENG(I) ENDDO C ELSE C C Extended optimal level C JJ = 1 WRITE (IWRITE,3070) DO J = 1,NCMIN II = ICCMIN(J) WRITE (IWRITE,3050) II,BREENG(II) WRITE (IWRITE,3030) (COUVEC(I,II),I=1,NCF) DO I = 1,NCF CCR(JJ) = COUVEC(I,II) JJ = JJ+1 ENDDO ENDDO C FACTOR = ONE/NCMIN DO I = 1,NCF COUENG(I) = ZERO II = I DO JJ = 1,NCMIN COUENG(I) = COUENG(I)+CCR(II)*CCR(II) II = II+NCF ENDDO COUENG(I) = SQRT(FACTOR*COUENG(I)) ENDDO C ENDIF C----------------------------------------------------------------------- C C Evaluate generalised occupation numbers C DO J = 1,NW UCF(J) = ZERO DO I = 1,NCF UCF(J) = UCF(J)+COUENG(I)*COUENG(I)*IQ(J,I) ENDDO ENDDO C----------------------------------------------------------------------- 3000 FORMAT (/ +' >>>> routine MATRIX called: diagonalise the Coulomb matrix') 3010 FORMAT (/' ERROR using the DSYEV routine'/' STOPPING') 3020 FORMAT (/' estimated Hamiltonian matrix') 3030 FORMAT (1X,1P,4E15.7) 3040 FORMAT (/' average energy (a.u.) ',1P,E18.10/) 3050 FORMAT (/' level ',I4,' energy =',1P,E18.10/) 3060 FORMAT (/' optimise on level ',I4,' energy =',1P,E18.10) 3070 FORMAT (/' optimise on the following levels'/) 3080 FORMAT (/' eigenenergies'//' dominant'/ ! +' level J parity CSF mix a.u.'/) 3090 FORMAT (1X,I4,2X,I4,'/2 odd ',I4,2X,F5.3,3X,1P,E20.12) 3100 FORMAT (1X,I4,2X,I4,'/2 even ',I4,2X,F5.3,3X,1P,E20.12) 3110 FORMAT (1X,I4,2X,I4,' odd ',I4,2X,F5.3,3X,1P,E20.12) 3120 FORMAT (1X,I4,2X,I4,' even ',I4,2X,F5.3,3X,1P,E20.12) 3130 FORMAT (/' diagonalisation using the DSYEV routine'/) END C C ******************* C SUBROUTINE MCDF(IR1,IR2,IP2,IR3,IP3) C C----------------------------------------------------------------------- C C This subroutine begins the SCF problem with a call C to INIT and controls the MCDF iterations. C C MCDF C DAMP C DUMP C INIT C MATRIX C NEWBAS C ORBPR C PROP C PRWF C SCF C YPOTX C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N10 PARAMETER (N10=MXNX*MXNC) C C Argument variables C INTEGER IP2,IP3,IR1,IR2 INTEGER IR3 C C Local variables C DOUBLE PRECISION ACUSE INTEGER I,IC,J,M INTEGER MX,NCFTT,NIT LOGICAL HIACC C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION CHECK INTEGER NITIT COMMON / DEF04 / CHECK,NITIT C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NCFTT = NCF*NCMIN C IF (NCMIN.GT.MXNX) THEN WRITE (IWRITE,3000) NCMIN,MXNX STOP ENDIF C NIT = 1 C----------------------------------------------------------------------- C C Initialise the SCF problem C CALL INIT(IR1,IR2,IR3) C----------------------------------------------------------------------- C C Initial diagonalisation C IF (NCMIN.GT.0 .OR. NITIT.EQ.0) THEN CALL MATRIX IF (NITIT.EQ.0) GOTO 30 DO I = 1,NCFTT CHK(I) = CCR(I) ENDDO ENDIF C WRITE (IWRITE,3040) WRITE (IWRITE,3030) (UCF(I),I=1,NW) WRITE (IWRITE,3050) WRITE (IWRITE,3030) (COUENG(I),I=1,NCF) C----------------------------------------------------------------------- C C Initial low accuracy runs C HIACC = .FALSE. M = 3 C DO I = 1,M J = M+1-I ACUSE = ACCY*TEN**J IF (ACUSE.LT.1.D-6 .AND. ITC(43).EQ.0) HIACC=.TRUE. CALL DUMP(0,IP2) WRITE (IWRITE,3020) CALL SCF(ACUSE,MX,HIACC) WRITE (IWRITE,3020) IF (NCMIN.GT.0) THEN CALL MATRIX CALL DAMP(CHECK,IC) ENDIF ENDDO C----------------------------------------------------------------------- C C Iterate at final accuracy C 10 CONTINUE CALL DUMP(0,IP2) C IF (ITC(43).EQ.1) THEN HIACC = .FALSE. ELSE HIACC = .TRUE. ENDIF C----------------------------------------------------------------------- WRITE (IWRITE,3020) CALL SCF(ACCY,MX,HIACC) WRITE (IWRITE,3020) C IF (NCMIN.EQ.0 .AND. MX.EQ.1) GOTO 20 C CALL MATRIX C IF (NCMIN.EQ.0) GOTO 30 C CALL DAMP(CHECK,IC) C IF (IC.EQ.0 .AND. MX.EQ.0) GOTO 30 C----------------------------------------------------------------------- 20 CONTINUE NIT = NIT+1 IF (NIT.GT.NITIT) THEN WRITE (IWRITE,3010) CALL DUMP(0,IP2) STOP ENDIF GOTO 10 C----------------------------------------------------------------------- 30 CONTINUE CALL DUMP(1,IP2) WRITE (IWRITE,3020) CALL PROPG(0) CALL DUMP(2,IP2) CALL ORBPR(IR3,IP3) C C If option 30 is set call NEWBAS to transform from JJ to C LS coupled basis C IF (ITC(30).EQ.1) CALL NEWBAS C C Call YPOTX to calculate and print the static potential C CALL YPOTX C C If option 8 is set print out the wavefunctions C IF (ITC(8).EQ.1) THEN WRITE (IWRITE,3020) CALL PRWF(0) ENDIF C WRITE (IWRITE,3060) C----------------------------------------------------------------------- 3000 FORMAT (/' dimension ERROR in routine MCDF ... STOPPING'/ ! +' increase MXNX to at least ',I6,' from the present value of ',I6) 3010 FORMAT (/' maximum iterations in MCDF exceeded') 3020 FORMAT (/1X,71('-')) 3030 FORMAT (1X,1P,5E14.6) 3040 FORMAT (/' generalised orbital occupation numbers'/) 3050 FORMAT (/' CSF mixing coefficients'/) 3060 FORMAT (/1X,71('*')) END C C ******************* C SUBROUTINE MCP(IO1,IO2,IO3) C C----------------------------------------------------------------------- C C The main routine of the package for evaluating angular coefficients. C C MCP C MCT C RKCOG C SPEAKG C TMSOUT C TNSRJJ C C Common block ANG04: C Elements set but never used: NWA C Common block DEBUG: C Elements used but never set: IBUG1 IBUG2 IBUG3 IBUG4 IBUG6 C Common block INFORM: C Elements used but never set: IWRITE IPUNCH C Elements never used, never set: IREAD C Common block OPT02: C Elements used but never set: all C Common block ORB00: C Elements used but never set: all C Common block ORB04: C Elements used but never set: all C Common block ORB05: C Elements used but never set: all C Common block ORB06: C Elements used but never set: all C Common block ORB07: C Elements used but never set: all C Common block TITL: C Elements used but never set: all C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER IZ PARAMETER (IZ=0) C C Argument variables C INTEGER IO1,IO2,IO3 C C Local variables C DOUBLE PRECISION COEF,VSHELL(MXNW) INTEGER I,IA1,IA2,ITOT1 INTEGER ITOT2,ITOT3,ITOT4,ITOT5 INTEGER ITOT6,ITOT7,ITOT8,ITOT9 INTEGER ITOTAL,ITYPE,J,JTOTAL INTEGER K,KTOTAL,NOUT2 C C Common variables C INTEGER IBREIT,ICOUL,IEXCH COMMON / ANG01 / ICOUL,IBREIT,IEXCH C C Common variables C INTEGER NOUT1 COMMON / ANG02 / NOUT1 C C Common variables C INTEGER ITOT(9),JTOT(9),KTOT(9) COMMON / ANG03 / ITOT,JTOT,KTOT C C Common variables C INTEGER IME,JA,JB,NWA COMMON / ANG04 / IME,JA,JB,NWA C C Common variables C INTEGER ICORE(MXNW) COMMON / ANG05 / ICORE C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER IOPAR,KA COMMON / MCTA / KA,IOPAR C C Common variables C INTEGER JTC(20) COMMON / OPT02 / JTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- PRINT 3020,IHED(1:40),IHED(41:80),RECORD,NW,NCF WRITE (IWRITE,3020) IHED(1:40),IHED(41:80),RECORD,NW,NCF WRITE (IPUNCH,3020) IHED(1:40),IHED(41:80),RECORD,NW,NCF C WRITE (IWRITE,3030) WRITE (IPUNCH,3030) WRITE (IWRITE,3040) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 WRITE (IPUNCH,3040) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Prints out table of allowed levels in jj coupling. C IF (IBUG5.EQ.1) CALL TMSOUT IBUG5 = 0 C----------------------------------------------------------------------- IF (JTC(14).EQ.1) THEN C IF (IO2.GT.0) THEN NOUT2 = 22 WRITE (NOUT2) IHED,RECORD WRITE (NOUT2) NCF,NW WRITE (NOUT2) (NH(I),NP(I),NAK(I),NKL(I),NKJ(I),I=1,NW) WRITE (NOUT2) ((IQ(I,J),J=1,NCF),I=1,NW) WRITE (NOUT2) (ITJPO(J),J=1,NCF) WRITE (NOUT2) (ISPAR(J),J=1,NCF) WRITE (NOUT2) (((JQS(K,I,J),J=1,NCF),I=1,NW),K=1,3) WRITE (NOUT2) ((JCUP(I,J),J=1,NCF),I=1,8) WRITE (NOUT2) ((ICHOP(I,J),J=1,NCF),I=1,NW) WRITE (NOUT2) KA,IOPAR ELSE NOUT2 = 0 ENDIF C WRITE (IWRITE,3050) KA,IOPAR WRITE (IPUNCH,3050) KA,IOPAR C CALL MCT(KA,IOPAR,NOUT2) C ENDIF C----------------------------------------------------------------------- IF (JTC(12).EQ.0 .AND. JTC(15).EQ.0) RETURN C NWA = NW+1 C IEXCH = IEXC C IF (JTC(12).EQ.1) THEN WRITE (IWRITE,3110) WRITE (IPUNCH,3110) ICOUL = 1 ELSE ICOUL = 0 ENDIF C IF (JTC(15).EQ.1) THEN WRITE (IWRITE,3120) WRITE (IPUNCH,3120) IBREIT = 1 ELSE IBREIT = 0 ENDIF C----------------------------------------------------------------------- IF (IO1.GT.0 .OR. IO3.GT.0) THEN NOUT1 = 21 WRITE (NOUT1) IHED,RECORD WRITE (NOUT1) NCF,NW WRITE (NOUT1) (NH(I),NP(I),NAK(I),NKL(I),NKJ(I),I=1,NW) WRITE (NOUT1) ((IQ(I,J),J=1,NCF),I=1,NW) WRITE (NOUT1) (ITJPO(J),J=1,NCF) WRITE (NOUT1) (ISPAR(J),J=1,NCF) WRITE (NOUT1) (((JQS(K,I,J),J=1,NCF),I=1,NW),K=1,3) WRITE (NOUT1) ((JCUP(I,J),J=1,NCF),I=1,8) WRITE (NOUT1) ((ICHOP(I,J),J=1,NCF),I=1,NW) ELSE NOUT1 = 0 ENDIF C----------------------------------------------------------------------- IF (IEXCH.EQ.1) THEN WRITE (IWRITE,3070) WRITE (IPUNCH,3070) ELSE IF (IEXCH.EQ.-1) THEN WRITE (IWRITE,3080) WRITE (IPUNCH,3080) ENDIF ENDIF C----------------------------------------------------------------------- C C The array ICORE marks orbitals which are full in all C shells i.e. these are closed shells. C This is used to identify angular coefficients for diagonal C matrix elements involving only closed shells. C These occur for all diagonal matrix elements and are only C written once. C C ICORE(I)=1 - shell I is closed C ICORE(I)=0 - shell I is open C C----------------------------------------------------------------------- DO I = 1,NW ICORE(I) = 0 DO J = 1,NCF IF (ICHOP(I,J).EQ.0) GOTO 10 IF (ICHOP(I,J).EQ.-1) GOTO 10 ENDDO ICORE(I) = 1 10 CONTINUE ENDDO C----------------------------------------------------------------------- KA = 0 IOPAR = 1 C----------------------------------------------------------------------- C C JA and JB refer to the initial and final states in the list of C NCF configurations, respectively C C----------------------------------------------------------------------- IF (IBUG1.EQ.1) WRITE (IWRITE,3000) C----------------------------------------------------------------------- DO I = 1,9 ITOT(I) = 0 JTOT(I) = 0 KTOT(I) = 0 ENDDO C----------------------------------------------------------------------- DO JA = 1,NCF DO JB = JA,NCF C IME = 0 IF (NOUT1.GT.0) WRITE (NOUT1) JA,JB C C Call MCP package C CALL RKCOG(JA,JB) C----------------------------------------------------------------------- IF (ICOUL.EQ.1) THEN IF (JA.EQ.JB) THEN C C One-electron integrals for diagonal case C DO I = 1,NW IF (ICORE(I).EQ.1) THEN IF (JA.GT.1) GOTO 20 ITYPE = -7 ELSE ITYPE = 7 ENDIF IF (IQ(I,JA).GT.0) THEN COEF = IQ(I,JA) CALL SPEAKG(1,ITYPE,IZ,IZ,I,I,IZ,COEF) ENDIF 20 CONTINUE ENDDO C ELSE C C One-electron integrals for off-diagonal case C CALL TNSRJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL) C IF (IA1.GT.0) THEN IF (IA1.EQ.IA2) THEN DO IA1 = 1,NW COEF = VSHELL(IA1) IF (ABS(COEF).GE.EPS10) CALL SPEAKG(0,7,IZ,IZ,IA1,IA! +1,IZ,COEF) ENDDO ELSE COEF = VSHELL(1) IF (ABS(COEF).GE.EPS10) CALL SPEAKG(0,7,IZ,IZ,IA1,IA2,! +IZ,COEF) ENDIF ENDIF C ENDIF C ENDIF C IF (IME.GT.0 .AND. IBUG1.EQ.1) WRITE (IWRITE,3060) IME,JA,JB IF (NOUT1.GT.0) WRITE (NOUT1) IZ,IZ,ZERO C ENDDO ENDDO C----------------------------------------------------------------------- IF (ICOUL.EQ.1) THEN ITOT7 = ITOT(7)+JTOT(7) ITOT8 = ITOT(8)+JTOT(8) ITOT9 = ITOT(9)+JTOT(9) ITOTAL = ITOT(7)+ITOT(8)+ITOT(9) JTOTAL = JTOT(7)+JTOT(8)+JTOT(9) ITOTAL = ITOTAL+JTOTAL KTOTAL = KTOT(7)+KTOT(8)+KTOT(9) WRITE (IWRITE,3100) ITOT7,JTOT(7),KTOT(7),ITOT8,JTOT(8),KTOT(8),! +ITOT9,JTOT(9),KTOT(9),ITOTAL,JTOTAL,KTOTAL WRITE (IPUNCH,3100) ITOT7,JTOT(7),KTOT(7),ITOT8,JTOT(8),KTOT(8),! +ITOT9,JTOT(9),KTOT(9),ITOTAL,JTOTAL,KTOTAL ENDIF C----------------------------------------------------------------------- IF (IBREIT.EQ.1) THEN ITOT1 = ITOT(1)+JTOT(1) ITOT2 = ITOT(2)+JTOT(2) ITOT3 = ITOT(3)+JTOT(3) ITOT4 = ITOT(4)+JTOT(4) ITOT5 = ITOT(5)+JTOT(5) ITOT6 = ITOT(6)+JTOT(6) ITOTAL = ITOT(1)+ITOT(2)+ITOT(3)+ITOT(4)+ITOT(5)+ITOT(6) JTOTAL = JTOT(1)+JTOT(2)+JTOT(3)+JTOT(4)+JTOT(5)+JTOT(6) ITOTAL = ITOTAL+JTOTAL WRITE (IWRITE,3090) ITOT1,JTOT(1),ITOT2,JTOT(2),ITOT3,JTOT(3),IT! +OT4,JTOT(4),ITOT5,JTOT(5),ITOT6,JTOT(6),ITOTAL,JTOTAL WRITE (IPUNCH,3090) ITOT1,JTOT(1),ITOT2,JTOT(2),ITOT3,JTOT(3),IT! +OT4,JTOT(4),ITOT5,JTOT(5),ITOT6,JTOT(6),ITOTAL,JTOTAL ENDIF C WRITE (IWRITE,3010) WRITE (IPUNCH,3010) C----------------------------------------------------------------------- 3000 FORMAT (/4X,'R',3X,'S',4X,'A',4X,'B',4X,'C',4X,'D',4X,'K',4X, ! +'coefficient',8X,'ISTORE ITYPE'/) 3010 FORMAT (/1X,71('*')) 3020 FORMAT (/1X,71('*')/ ! +' routine MCP: calculate MCP/MCBP/MCT angular coefficients'/1X,71(! +'*')/' Title : ',A40/' ',A40/' Run at : ',A20/ ! +' NW (number of orbitals) = ',I6/' NCF (number of CSFs) = ',I! +6/1X,71('*')) 3030 FORMAT (/ ! +' Core coefficients are common to all diagonal matrix elements. ',! +'They are '/ ! +' only written for the first CSF. These coefficients are indicat',! +'ed by '/ ! +' having ITYPE set negative where ITYPE is 1 to 6 for the Breit '/! +' interaction and 7 to 9 for the Coulomb. For the Coulomb intera',! +'ction '/ ! +' the core/core and core/peel coefficients are indicated by sett',! +'ing '/ ! +' ISTORE negative. These coefficients can be calculated internal',! +'ly by '/ ! +' the MCDF section and they are skipped there. However in BENA t',! +'hey are '/ ! +' used. The core coefficients (above) are a subset of these core',! +'/core and '/' core/peel coefficients.') 3040 FORMAT (/' Debug options are : ',6I2) 3050 FORMAT (/' Calculate MCT (one-electron) coefficients'/ ! +' Rank of tensor is ',I2,' and parity is ',I2) 3060 FORMAT (1X,I4,' coefficients between ',I2,' and ',I2) 3070 FORMAT (' exchange Coulomb coefficients neglected') 3080 FORMAT (' direct Coulomb coefficients neglected') 3090 FORMAT (/1X,I6,' Breit type 1 coefficients (',I6,' in core)'/1X! +,I6,' Breit type 2 coefficients (',I6,' in core)'/1X,I6, ! +' Breit type 3 coefficients (',I6,' in core)'/1X,I6, ! +' Breit type 4 coefficients (',I6,' in core)'/1X,I6, ! +' Breit type 5 coefficients (',I6,' in core)'/1X,I6, ! +' Breit type 6 coefficients (',I6,' in core)'//1X,I6, ! +' total Breit coefficients (',I6,' in core)') 3100 FORMAT (/1X,I6,' one-electron coefficients (',I6,' in core)'/7X! +,' (',I6, ! +' in core/core or core/peel)'/1X,I6, ! +' direct Slater coefficients (',I6,' in core)'/7X, ! +' (',I6,' in core/core or core/peel)'! +/1X,I6,' exchange Slater coefficients (',I6,' in core)'/7X, ! +' (',I6,' in core/core or core/peel)'! +//1X,I6,' total Coulomb coefficients (',I6,' in core)'/7X, ! +' (',I6,' in core/core or core/peel)'! +) 3110 FORMAT (/' Calculate Coulomb coefficients') 3120 FORMAT (/' Calculate Breit coefficients') END C C ******************* C SUBROUTINE MCPIN(IR1) C C----------------------------------------------------------------------- C C This subroutine reads any MCP coefficients which are required C A print out is made if option 7 is set C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) C C Argument variables C INTEGER IR1 C C Local variables C DOUBLE PRECISION X INTEGER IA,IB,IC,ICX INTEGER ID,IK,IR,IRS INTEGER IRX,IS,ISTO,ISTORE INTEGER ISX,ITYPE,NCFS,NMREAD INTEGER NUMI,NUMR,NWS C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C If there is no MCP dump (IR1=0) then exit from routine C NMCP = 0 C IF (IR1.EQ.0) RETURN C WRITE (IWRITE,3010) C----------------------------------------------------------------------- C C Read the heading data which gives information on the type C of MCP calculation i.e. CSF data C ** check the number of orbitals and CSFs are the same ** C REWIND IR1 READ (IR1) READ (IR1) NCFS,NWS IF (NW.NE.NWS .OR. NCF.NE.NCFS) GOTO 40 READ (IR1) READ (IR1) READ (IR1) READ (IR1) READ (IR1) READ (IR1) READ (IR1) C IF (ITC(7).EQ.1) WRITE (IWRITE,3020) C----------------------------------------------------------------------- C C Loop over pairs of configurations C NMREAD = 0 NUMI = 0 NUMR = 0 ICX = 1 C DO IRX = 1,NCF DO ISX = IRX,NCF C READ (IR1) IR,IS IRS = (IR-1)*(NCF+NCF-IR)/2+IS NNLDR(IRS) = 0 C 10 CONTINUE READ (IR1) ISTORE,ITYPE,X IF (ISTORE.EQ.0) GOTO 20 NMREAD = NMREAD+1 IF (ISTORE.LT.0) GOTO 10 IF (ITYPE.LT.7) GOTO 10 C IF (ITYPE.EQ.7) THEN NUMI = NUMI+1 ELSE NUMR = NUMR+1 ENDIF C----------------------------------------------------------------------- C C Write out coefficients if option 7 is set. C IF (ITC(7).EQ.1) THEN IF (ITYPE.EQ.8 .OR. ITYPE.EQ.9) THEN ISTO = ISTORE ID = MOD(ISTO,NW1) ISTO = ISTO/NW1 IC = MOD(ISTO,NW1) ISTO = ISTO/NW1 IB = MOD(ISTO,NW1) ISTO = ISTO/NW1 IA = MOD(ISTO,NW1) IK = ISTO/NW1 WRITE (IWRITE,3030) IR,IS,NP(IA),NH(IA),NP(IB),NH(IB),NP(I! +C),NH(IC),NP(ID),NH(ID),IK,X ELSE ISTO = ISTORE ID = MOD(ISTO,NW1) IC = ISTO/NW1 WRITE (IWRITE,3050) IR,IS,NP(IC),NH(IC),NP(ID),NH(ID),X ENDIF ENDIF C NMCP = NMCP+1 C IF (NMCP.LE.MXNM) THEN NNLDR(IRS) = NNLDR(IRS)+1 ISLDR(NMCP) = ISTORE XSLDR(NMCP) = X GOTO 10 ELSE GOTO 30 ENDIF C----------------------------------------------------------------------- 20 CONTINUE NSLDF(IRS) = ICX ICX = ICX+NNLDR(IRS) C ENDDO ENDDO C----------------------------------------------------------------------- REWIND IR1 WRITE (IWRITE,3040) NMREAD,NMCP,NUMR,NUMI PRINT 3040,NMREAD,NMCP,NUMR,NUMI RETURN C----------------------------------------------------------------------- C C error messages C 30 CONTINUE WRITE (IWRITE,3000) WRITE (IPUNCH,3000) PRINT 3000 STOP C 40 CONTINUE WRITE (IWRITE,3060) NCFS,NWS,NCF,NW WRITE (IPUNCH,3060) NCFS,NWS,NCF,NW PRINT 3060,NCFS,NWS,NCF,NW STOP C----------------------------------------------------------------------- 3000 FORMAT (/ ! +' ERROR in MCPIN : dimension for MCP coefficients ... STOPPING') 3010 FORMAT (/' >>>> routine MCPIN called : read angular coefficients') 3020 FORMAT (/' MCP (Coulomb) angular coefficients'//4X,'R',3X,'S',31X,! +'K'/) 3030 FORMAT (1X,2I4,4(3X,I2,A2),I4,3X,1P,E14.7) 3040 FORMAT (/1X,I7,' angular coefficients read'/1X,I7, ! +' MCP (Coulomb) angular coefficients to be used in MCDF'/1X,I7, ! +' Slater coefficients'/1X,I5,' one-electron coefficients') 3050 FORMAT (1X,2I4,14X,2(3X,I2,A2),7X,1P,E14.7) 3060 FORMAT (/' ERROR in MCPIN : incorrect MCP dump ... STOPPING'/ ! +' NCF,NW on dump are : ',2I5/' NCF,NW in run are : ',2I5) END C C ******************* C SUBROUTINE MCT(KA,IOPAR,NOUT2) C C----------------------------------------------------------------------- C C Main routine for evaluating MCT coefficients C using the one-electron tensor operator routine C TNSRJJ. C C KA - order of tensor C IOPAR - parity of tensor C NOUT2 - the stream number for output to disk/tape C C Subroutines called: RAT1, TNSRJJ C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER IZ PARAMETER (IZ=0) C C Argument variables C INTEGER IOPAR,KA,NOUT2 C C Local variables C DOUBLE PRECISION COEF,VSHELL(MXNW) INTEGER IA1,IA2,IMT,IRAT(4) INTEGER JA,JB,MODE,XA INTEGER XB,XC,XD C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C JA and JB refer to the initial and final states in the list of C NCF configurations, respectively. C IF (IBUG1.EQ.1) WRITE (IWRITE,3010) C IMT = 0 C----------------------------------------------------------------------- DO JA = 1,NCF DO JB = JA,NCF C CALL TNSRJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL) C----------------------------------------------------------------------- IF (IA1.GT.0) THEN IF (IA1.EQ.IA2) THEN C DO IA1 = 1,NW C COEF = VSHELL(IA1) C IF (ABS(COEF).GE.EPS10) THEN C IF (NOUT2.GT.0) WRITE (NOUT2) JA,JB,IA1,IA1,COEF C IF (IBUG1.EQ.1) THEN C WRITE (IWRITE,3000) JA,JB,NP(IA1),NH(IA1),NP(IA1),NH! +(IA1),COEF C CALL RAT1(COEF,IRAT) C XA = IRAT(1) XB = IRAT(2) XC = IRAT(3) XD = IRAT(4) C IF (XD.EQ.1) THEN IF (XC.EQ.1) THEN IF (XB.EQ.1) THEN MODE = 1 ELSE MODE = 2 ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 7 ELSE MODE = 3 ENDIF ELSE MODE = 5 ENDIF ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 8 ELSE MODE = 6 ENDIF ELSE MODE = 4 ENDIF ENDIF C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3030) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XA ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3040) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XA,XB ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3050) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XA,XC ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3060) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XA,XB,XC,XD ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3070) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XA,XB,XC ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3080) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XA,XC,XD ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3090) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XC ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3100) KA,JA,JB,NP(IA1),NH(IA1),NP(IA! +1),NH(IA1),XC,XD ENDIF C ENDIF C IMT = IMT+1 ENDIF C ENDDO C----------------------------------------------------------------------- ELSE C----------------------------------------------------------------------- COEF = VSHELL(1) C IF (ABS(COEF).GE.EPS10) THEN C IF (NOUT2.GT.0) WRITE (NOUT2) JA,JB,IA1,IA2,COEF C IF (IBUG1.EQ.1) THEN C WRITE (IWRITE,3000) JA,JB,NP(IA1),NH(IA1),NP(IA2),NH(I! +A2),COEF C CALL RAT1(COEF,IRAT) C XA = IRAT(1) XB = IRAT(2) XC = IRAT(3) XD = IRAT(4) C IF (XD.EQ.1) THEN IF (XC.EQ.1) THEN IF (XB.EQ.1) THEN MODE = 1 ELSE MODE = 2 ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 7 ELSE MODE = 3 ENDIF ELSE MODE = 5 ENDIF ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 8 ELSE MODE = 6 ENDIF ELSE MODE = 4 ENDIF ENDIF C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3030) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XA ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3040) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XA,XB ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3050) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XA,XC ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3060) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XA,XB,XC,XD ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3070) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XA,XB,XC ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3080) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XA,XC,XD ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3090) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XC ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3100) KA,JA,JB,NP(IA1),NH(IA1),NP(IA2)! +,NH(IA2),XC,XD ENDIF C ENDIF C IMT = IMT+1 ENDIF C----------------------------------------------------------------------- ENDIF ENDIF C----------------------------------------------------------------------- ENDDO ENDDO C----------------------------------------------------------------------- WRITE (IWRITE,3020) IMT WRITE (IPUNCH,3020) IMT C IF (NOUT2.GT.0) WRITE (NOUT2) IZ,IZ,IZ,IZ,ZERO C----------------------------------------------------------------------- 3000 FORMAT (7X,2I4,2X,2(I2,A2,1X),5X,1P,E16.9) 3010 FORMAT (/10X,'R',3X,'S',4X,'A',4X,'B',9X,'coefficient'/) 3020 FORMAT (/1X,I6,' MCT (one-electron) coefficients calculated') 3030 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',I7) 3040 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',I7,'/',I7) 3050 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',I7,' ',7X,! +' * S (',I7,' ',7X,')') 3060 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',I7,'/',I7,! +' * S (',I7,'/',I7,')') 3070 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',I7,'/',I7,! +' * S (',I7,' ',7X,')') 3080 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',I7,' ',7X,! +' * S (',I7,'/',I7,')') 3090 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',7X,' ',7X,! +' S (',I7,' ',7X,')') 3100 FORMAT (1X,I2,2I4,' T( ;',I2,A2,',',I2,A2,')',10X,' ',7X,' ',7X,! +' S (',I7,'/',I7,')') END C C ******************* C SUBROUTINE MCTIN(IO7) C C----------------------------------------------------------------------- C C This routine reads the MCT coefficients from stream IO7 C and loads them into the arrays XSLDR and ISLDR. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) C C Argument variables C INTEGER IO7 C C Local variables C CHARACTER*80 IHEDIN CHARACTER*20 RECIN DOUBLE PRECISION COEFF INTEGER I,IA,IB,IC INTEGER IRS,IRSM,ITR,JTR INTEGER NCFIN,NWA,NWIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C INTEGER IOPAR,KA COMMON / MCTA / KA,IOPAR C C Common variables C INTEGER LTC(20) COMMON / OPT04 / LTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Read basic information regarding tensor operator. C C----------------------------------------------------------------------- WRITE (IWRITE,3070) REWIND IO7 C READ (IO7) IHEDIN,RECIN READ (IO7) NCFIN,NWIN IF (NW.NE.NWIN .OR. NCF.NE.NCFIN) GOTO 30 READ (IO7) READ (IO7) READ (IO7) READ (IO7) READ (IO7) READ (IO7) READ (IO7) READ (IO7) KA,IOPAR WRITE (IWRITE,3020) IHEDIN(1:40),IHEDIN(41:80),RECIN,KA,IOPAR IF (KA.EQ.0) GOTO 40 C NWA = NW+1 C IRSM = NCF*(NCF+1)/2 DO I = 1,IRSM NNLDR(I) = 0 ENDDO C C Begin reading MCT coefficients. C IF (LTC(5).EQ.1) WRITE (IWRITE,3060) NMCP = 0 10 CONTINUE READ (IO7) ITR,JTR,IA,IB,COEFF IF (ITR.EQ.0) GOTO 20 IF (LTC(5).EQ.1) WRITE (IWRITE,3040) ITR,JTR,NP(IA),NH(IA),NP(IB),! +NH(IB),COEFF NMCP = NMCP+1 IF (NMCP.GT.MXNM) GOTO 50 IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR NNLDR(IRS) = NNLDR(IRS)+1 ISLDR(NMCP) = NWA*IA+IB XSLDR(NMCP) = COEFF GOTO 10 C C Store start and number of coefficients read for each configuration. C 20 CONTINUE IC = 1 DO I = 1,IRSM NSLDF(I) = IC IC = IC+NNLDR(I) ENDDO C WRITE (IWRITE,3050) NMCP RETURN C C error messages C 30 CONTINUE WRITE (IWRITE,3000) STOP C 40 CONTINUE WRITE (IWRITE,3010) STOP C 50 CONTINUE WRITE (IWRITE,3030) STOP C 3000 FORMAT (/' ERROR in MCTIN : inconsistent MCT dump ... STOPPING') 3010 FORMAT (/' ERROR in MCTIN : tensor rank is zero ... STOPPING') 3020 FORMAT (/' MCT dump : ',A40/' ',A40/' ',A20/! +' tensor rank ',I2,'and parity ',I2/) 3030 FORMAT (/ ! +' ERROR in MCTIN : dimension for MCT coefficients ... STOPPING') 3040 FORMAT (2X,I4,2X,I4,2X,I2,A2,2X,I2,A2,2X,1P,E15.8) 3050 FORMAT (/1X,I6,' MCT (one-electron) coefficients read') 3060 FORMAT (/' I J A B coefficient'/) 3070 FORMAT (/ ! +' >>>> routine MCTIN called : read the one-electron coefficients') END C C ******************* C SUBROUTINE MODJ23 C C----------------------------------------------------------------------- C C Restores common block /ANG00/ from saved values. C For exchange case. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) C C Local variables C INTEGER I,J,NS2 C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),MMOM,NMOM LOGICAL FREE(MANGM) COMMON / ANG00 / MMOM,NMOM,J1,J2,J3,FREE C C Common variables C INTEGER J2S(MTRIAD,3),J3S(MTRIAD,3) COMMON / ANG09 / J2S,J3S Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NS2 = NMOM-1 DO J = 1,3 DO I = 1,NS2 J2(I,J) = J2S(I,J) J3(I,J) = J3S(I,J) ENDDO ENDDO C I = J3(1,3) J3(1,3) = J2(1,1) J2(1,1) = I C END C C ******************* C SUBROUTINE MUMDAD(IS,KAPS,X) C C----------------------------------------------------------------------- C C Evaluate the product of 4 CFPs. C C Subroutines called: CFP C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) C C Argument variables C DOUBLE PRECISION X INTEGER IS(2,2),KAPS(2,2) C C Local variables C DOUBLE PRECISION C INTEGER II,IJD,IJP,IVD INTEGER IVP,IWD,IWP,LOCK INTEGER NEL C C Common variables C INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW) INTEGER JTQ1(3),JTQ2(3) COMMON / ANG08 / JBQ1,JBQ2,JTQ1,JTQ2 C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- X = ONE C----------------------------------------------------------------------- C C First index C C----------------------------------------------------------------------- LOCK = KAPS(1,1) IF (ABS(LOCK).EQ.2) GOTO 10 C II = IS(1,1) NEL = NQ1(II) IVP = JBQ1(1,II) IWP = JBQ1(2,II) IJP = JBQ1(3,II)-1 C IF (IS(1,1).NE.IS(2,1)) THEN C C IA1<>IB1 and IA2<>IB2; use JJQ array. C IVD = JJQ1(1,II) IWD = JJQ1(2,II) IJD = JJQ1(3,II)-1 C ELSE C C IA1=IB1 or IA2=IB2; JTQ array needed. C NEL = NEL-1 IVD = JTQ1(1) IWD = JTQ1(2) IJD = JTQ1(3)-1 ENDIF C CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C) IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I! +WP,C IF (ABS(C).LT.EPS10) GOTO 50 X = X*C C----------------------------------------------------------------------- 10 CONTINUE LOCK = KAPS(2,1) IF (ABS(LOCK).EQ.2) GOTO 20 II = IS(2,1) NEL = NQ1(II) IVD = JJQ1(1,II) IWD = JJQ1(2,II) IJD = JJQ1(3,II)-1 C IF (IS(1,1).NE.IS(2,1)) THEN IVP = JBQ1(1,II) IWP = JBQ1(2,II) IJP = JBQ1(3,II)-1 ELSE IVP = JTQ1(1) IWP = JTQ1(2) IJP = JTQ1(3)-1 ENDIF C CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C) IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I! +WP,C IF (ABS(C).LT.EPS10) GOTO 50 X = X*C C----------------------------------------------------------------------- C C Second index C C----------------------------------------------------------------------- 20 CONTINUE LOCK = KAPS(1,2) IF (ABS(LOCK).EQ.2) GOTO 30 II = IS(1,2) NEL = NQ2(II) IVP = JBQ2(1,II) IWP = JBQ2(2,II) IJP = JBQ2(3,II)-1 C IF (IS(1,2).NE.IS(2,2)) THEN C C IA1<>IB1 and IA2<>IB2; use JJQ array. C IVD = JJQ2(1,II) IWD = JJQ2(2,II) IJD = JJQ2(3,II)-1 C ELSE C C IA1=IB1 or IA2=IB2; JTQ array needed. C NEL = NEL-1 IVD = JTQ2(1) IWD = JTQ2(2) IJD = JTQ2(3)-1 ENDIF C CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C) IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I! +WP,C IF (ABS(C).LT.EPS10) GOTO 50 X = X*C C----------------------------------------------------------------------- 30 CONTINUE LOCK = KAPS(2,2) IF (ABS(LOCK).EQ.2) GOTO 40 II = IS(2,2) NEL = NQ2(II) IVD = JJQ2(1,II) IWD = JJQ2(2,II) IJD = JJQ2(3,II)-1 C IF (IS(1,2).NE.IS(2,2)) THEN IVP = JBQ2(1,II) IWP = JBQ2(2,II) IJP = JBQ2(3,II)-1 ELSE IVP = JTQ2(1) IWP = JTQ2(2) IJP = JTQ2(3)-1 ENDIF C CALL CFP(LOCK,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C) IF (IBUG2.EQ.1) WRITE (IWRITE,3000) LOCK,NEL,IJD,IVD,IWD,IJP,IVP,I! +WP,C IF (ABS(C).LT.EPS10) GOTO 50 X = X*C 40 CONTINUE RETURN C----------------------------------------------------------------------- 50 CONTINUE X = ZERO C----------------------------------------------------------------------- 3000 FORMAT (' CFP ',I4,I4,I7,2I4,I7,2I4,1P,E20.9) END C C ******************* C SUBROUTINE NCHARG C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) WRITE (IPUNCH,3000) STOP C 3000 FORMAT (/' Routine NCHARG called'/ ! +' This is a dummy routine called for NUCTYP > 2 OR < 0'/ ! +' Code is STOPPING'/ ! +' Please rewrite this routine or change the value of NUCTYP') END C C ******************* C SUBROUTINE NEWBAS C C----------------------------------------------------------------------- C C Subroutine to transform eigenvectors from JJ to LS CSF basis. C Note : argument IW not used. C C Subroutine called : MATOUT C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N10 PARAMETER (N10=MXNX*MXNC) C C Local variables C DOUBLE PRECISION AM,EAU,SUM,WA DOUBLE PRECISION WMAX1,WMAX2,WMAX3 INTEGER I,IA,IB,IC INTEGER J,K,MEV(MXNC) INTEGER NEV(MXNC) C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION TC(MXNC,MXNC) COMMON / NRD00 / TC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV C C Common variables C CHARACTER*14 NRCSF(MXNC) COMMON / PATX / NRCSF C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO I = 1,NCF DO J = 1,NCF SUM = ZERO DO K = 1,NCF SUM = SUM+COUVEC(K,I)*TC(K,J) ENDDO IF (ABS(SUM).LT.EPS10) SUM = ZERO CHK(J) = SUM ENDDO DO J = 1,NCF COUVEC(J,I) = CHK(J) ENDDO ENDDO C C Set up the array LEV C DO J = 1,NCF IA = 0 IB = 0 IC = 0 WMAX1 = ZERO WMAX2 = ZERO WMAX3 = ZERO DO I = 1,NCF WA = ABS(COUVEC(I,J)) IF (WA.GE.WMAX1) THEN WMAX3 = WMAX2 WMAX2 = WMAX1 WMAX1 = WA IC = IB IB = IA IA = I ELSE IF (WA.GE.WMAX2) THEN WMAX3 = WMAX2 WMAX2 = WA IC = IB IB = I ELSE IF (WA.GE.WMAX3) THEN WMAX3 = WA IC = I ENDIF ENDIF ENDIF ENDDO LEV(J) = IA MEV(J) = IB NEV(J) = IC ENDDO C C Output the level energies C WRITE (IWRITE,3000) WRITE (IWRITE,3010) WRITE (IPUNCH,3000) WRITE (IPUNCH,3010) DO J = 1,NCPRIN IA = LEV(J) AM = COUVEC(IA,J) IF (J.GT.1) THEN EAU = (BREENG(J)-BREENG(1))*TWO ELSE EAU = BREENG(J)*TWO ENDIF WRITE (IWRITE,3020) J,NRCSF(IA),IA,AM,EAU WRITE (IPUNCH,3020) J,NRCSF(IA),IA,AM,EAU IB = MEV(J) IF (IB.GT.0) THEN AM = COUVEC(IB,J) IF (ABS(AM).GT..4D0) THEN WRITE (IWRITE,3030) NRCSF(IB),IB,AM WRITE (IPUNCH,3030) NRCSF(IB),IB,AM ENDIF ENDIF IC = NEV(J) IF (IC.GT.0) THEN AM = COUVEC(IC,J) IF (ABS(AM).GT..4D0) THEN WRITE (IWRITE,3030) NRCSF(IC),IC,AM WRITE (IPUNCH,3030) NRCSF(IC),IC,AM ENDIF ENDIF ENDDO C IF (ITC(31).EQ.1)CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3) C 3000 FORMAT (/' >>>> routine NEWBAS called'/ ! +' >>>> eigenvectors transformed from jj to LS CSF basis') 3010 FORMAT (/ ! +' eigenenergies (absolute for groundstate, relative for others)'/ ! +' -------------'/' dominant'/ ! +' level state CSF mix Ryd.'/) 3020 FORMAT (1X,I4,2X,A14,2X,I4,2X,F6.3,2X,1P,4E20.12) 3030 FORMAT (6X,A14,2X,I4,2X,F6.3) END C C ******************* C SUBROUTINE NJSYM(RECUP,IGEN,FAIL) C C----------------------------------------------------------------------- C C This is an adaption of the revised NJSYM program due to Scott and C Hibbert. AAON CPC 28 (1982) 189 C C A program to calculate a general recoupling coefficient. C P.G.Burke -- modified by N.S.Scott and A.Hibbert C Queens University Belfast. C C----------------------------------------------------------------------- C C RECUP the resultant recoupling coefficient C C IGEN=0 normal call to NJSYM C =1 only GENSUM is called C =-1 GENSUM is not called C C----------------------------------------------------------------------- C C Dimension parameters set in the program : C C MANGM test on dimension of J1 array (and J4, J5 arrays) C MTRIAD test on dimensions of J2 and J3 arrays C M3MNGM test on dimensions of J6 and J8 arrays C M3MNGM test on dimensions of J7 array C MTRIAD test on dimensions of JSUM1, JSUM2 etc arrays used in GENSUM C M6J test on dimension of JW array C C Renamed some common blocks : C C COUPLE ---> ANG00 C ARG0 ---> NJS00 C ARG1 ---> NJS01 C ARG2 ---> NJS02 C DEPTHS ---> NJS03 C WCOMI9 ---> NJS04 C C Description of common blocks C ============================ C C Common block ANG00 C ------------------ C C M the total number of angular momentum values in the initial and C final states C C N the number of basic angular momentum values that are coupled C C (J1(I),I=1,M) C the angular momentum values stored as 2J+1 C C ((J2(I,J),I=1,(N-1)),J=1,3) C the position in the J1 array of the initial state triads C C ((J3(I,J),I=1,(N-1)),J=1,3) C the position in the J1 array of the final state triads C C FREE not used C C Common block DEBUG C ------------------ C C IBUG1 not used C IBUG2 not used C IBUG3 debug prints in NJSYM and GENSUM if IBUG3 equals 1 C IBUG4 not used C IBUG5 not used C IBUG6 not used C C Common block INFORM C ------------------- C C IREAD input channel number C IWRITE output channel number C IPUNCH not used C C Common block NJS00 C ------------------ C C J6C the number of elements in the J6 array C C J7C the number of elements in the J7 array C C J8C the number of elements in the J8 array C C JWC the number of columns in the JW array C C Common block NJS01 C ------------------ C C (J6(I),I=1,J6C) C each entry corresponds to a factor SQRT(2J+1) in RECUP. The C value of J6 gives position in J1 array where J value is found C C (J7(I),I=1,J7C) C each entry corresponds to a factor (-1)**J in RECUP C C (J8(I),I=1,J8C) C each entry corresponds to a factor (-1)**(-J) in RECUP C C ((JW(I,J),I=1,6),J=1,JWC) C each column corresponds to a Racah coefficient in RECUP C C Common block NJS02 C ------------------ C C ICOUNT C (J2TEST(I),I=1,ICOUNT) C (J3TEST(I),I=1,ICOUNT) C C Common block NJS03 C ------------------ C C (J4(J),J=1,M) the level of J in the J2 coupling tree evaluated C by subroutine GENJ45 C C (J5(J),J=1,M) the level of J in the J3 coupling tree evaluated C by subroutine GENJ45 C C Common block NJS04 C ------------------ C C I3 contains the column of the J2 array which contains the first C element to be brought into the same triad by recoupling. Input C to subroutine GENI9 C C I4 contains the column of the J2 array which contains the second C element to be brought into the same triad by recoupling. Input C to subroutine GENI9 C C I5 contains the row of the J2 array which contains the first C element. Input to subroutine GENI9 C C I6 contains the row of the J2 array which contains the second C element. Input to subroutine GENI9 C C I7 contains the level of the I5 triad below the common triad in C coupling scheme of J2, evaluated by subroutine GENI9 C C I8 contains the level of the I6 triad below the common triad in C coupling scheme of J2, evaluated by subroutine GENI9 C C I9 contains the number of recouplings plus two, evaluated by C subroutine GENI9 C C I17 contains the row of the J2 array containing the highest C element, evaluated by subroutine GENI9 C C I18 contains the row of the J2 array containing the lowest element, C evaluated by SUBROUTINE GENI9 C C I19 contains the column of the J2 array containing the highest C element, evaluated by subroutine GENI9 C C I20 contains the column of the J2 array containing the lowest C element, evaluated by subroutine GENI9 C C----------------------------------------------------------------------- C C The arrays J6,J7,J8 and JW are evaluated by NJSYM. The entry in C each case corresponds to a position in the J1 array where the C 2J+1 value is found if less than or equal to M, or to a summation C variable if greater than M C C The summation over the variables in J6,J7,J8 and JW and the C evaluation of RECUP is carried out in GENSUM C C GENSUM can be re-entered directly to evaluate different recoupling C coefficients with the same structure by just altering the numbers in C the J1 array. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C IMPLICIT NONE C C Parameter variables C INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) INTEGER M3MNGM PARAMETER (M3MNGM=3*MANGM) INTEGER M6J PARAMETER (M6J=20) C C Argument variables C INTEGER IGEN DOUBLE PRECISION RECUP LOGICAL FAIL C C Local variables C INTEGER I,I1,I10,I11 INTEGER I12,I13,I14,I15 INTEGER I16,I2,IJKL,IP INTEGER IQ,ITEST,ITEST1,J INTEGER JJ2,JJ3,JP,MP C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),M,N LOGICAL FREE(MANGM) COMMON / ANG00 / M,N,J1,J2,J3,FREE C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER J6C,J7C,J8C,JWC COMMON / NJS00 / J6C,J7C,J8C,JWC C C Common variables C INTEGER J6(M3MNGM),J7(M3MNGM),J8(M3MNGM) INTEGER JW(6,M6J) COMMON / NJS01 / J6,J7,J8,JW C C Common variables C INTEGER ICOUNT,J2TEST(MTRIAD) INTEGER J3TEST(MTRIAD) COMMON / NJS02 / ICOUNT,J2TEST,J3TEST C C Common variables C INTEGER I17,I18,I19,I20 INTEGER I3,I4,I5,I6 INTEGER I7,I8,I9 COMMON / NJS04 / I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20 C C Common variables C INTEGER NUMC,NUMR,NUMSTO COMMON / RACAHV / NUMC,NUMR,NUMSTO C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Common block ANG00: C Elements used but never set: M N J1 C Elements never used, never set: FREE C C Common block DEBUG: C Elements used but never set: IBUG3 C Elements never used, never set: IBUG1 IBUG2 IBUG4 IBUG5 IBUG6 C C Common block INFORM: C Elements used but never set: IWRITE C Elements never used, never set: IREAD IPUNCH C C Common block NJS04: C Elements used but never set: I9 I17 I18 I19 I20 C C Common block RACAHV: C Elements set but never used: all C Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc SAVE IJKL C DATA IJKL/0/ C----------------------------------------------------------------------- C C Call the routine FACTT when NJSYM is first used C IF (IJKL.EQ.0) THEN NUMC = 0 NUMR = 0 NUMSTO = 0 CALL FACTT IJKL = 1 ENDIF C FAIL = .FALSE. C----------------------------------------------------------------------- IF (IBUG3.EQ.1) THEN IF (IGEN.EQ.0) WRITE (IWRITE,3130) IF (IGEN.EQ.1) WRITE (IWRITE,3140) IF (IGEN.EQ.-1) WRITE (IWRITE,3150) ENDIF C----------------------------------------------------------------------- IF (IGEN.EQ.1) GOTO 750 C----------------------------------------------------------------------- C C test some of the dimensions C C----------------------------------------------------------------------- IF (MTRIAD.LT.N-1) GOTO 770 IF (MANGM.LT.M) GOTO 780 C C IP is the number of inequivalent triads which have to be recoupled. C It is set initially to the total number of triads and then decreased C in section 1 below as the recoupling proceeds until eventually it C reaches zero. C IP = N-1 C C debug prints C IF (IBUG3.EQ.1) THEN WRITE (IWRITE,3020) DO I = 1,IP WRITE (IWRITE,3030) (J2(I,J),J=1,3), (J3(I,J),J=1,3) ENDDO ENDIF C C Set counts zero. MP is count on the J values which are summed over. C J6C = 0 J7C = 0 J8C = 0 JWC = 0 MP = M ICOUNT = 0 C----------------------------------------------------------------------- C C Section 1 C C The following section searches the J2 and J3 arrays to see if any C triads are equivalent. If so it puts them at end of J2 and J3 arrays C and sets IP equal to the number of inequivalent triads remaining. If C IP=0 then the recouping has been completed and exit is made to GENSUM C to carry out the summations. C C----------------------------------------------------------------------- 510 CONTINUE I1 = 1 520 CONTINUE DO I2 = 1,IP IF (J2(I2,1).EQ.J3(I1,1)) GOTO 530 IF (J2(I2,2).EQ.J3(I1,1)) GOTO 540 ENDDO C C No equivalent triads with this value of I1. Increase I1 and try again C GOTO 580 C 530 CONTINUE IF (J2(I2,2)-J3(I1,2)) 580,550,580 540 CONTINUE IF (J2(I2,1)-J3(I1,2)) 580,550,580 550 CONTINUE C C Rearrange so that equivalent triads occur at the end of J2 and C J3 arrays C IF (I2.LT.IP) THEN I3 = J2(I2,1) I4 = J2(I2,2) I5 = J2(I2,3) I6 = I2+1 DO I7 = I6,IP DO I8 = 1,3 J2(I7-1,I8) = J2(I7,I8) ENDDO ENDDO J2(IP,1) = I3 J2(IP,2) = I4 J2(IP,3) = I5 ENDIF C IF (I1.LT.IP) THEN I3 = J3(I1,1) I4 = J3(I1,2) I5 = J3(I1,3) I6 = I1+1 DO I7 = I6,IP DO I8 = 1,3 J3(I7-1,I8) = J3(I7,I8) ENDDO ENDDO J3(IP,1) = I3 J3(IP,2) = I4 J3(IP,3) = I5 ENDIF C C Is the third element in J2 summed over? If so replace by third C element in J3 array. C IF (J2(IP,3).LE.M) GOTO 570 C 560 CONTINUE J = J3(IP,3) JP = J2(IP,3) J2(IP,3) = J C C Now replace all other elements in J2,JW,J7,J8 and J6 which are C summed over at the same time by the same quantity J C IF (IP.GE.2) THEN IQ = IP-1 DO I3 = 1,IQ DO I4 = 1,3 IF (J2(I3,I4).EQ.JP) THEN J2(I3,I4) = J ENDIF ENDDO ENDDO ENDIF C IF (JWC.GT.0) THEN DO I = 1,6 DO I3 = 1,JWC IF (JW(I,I3).EQ.JP) THEN JW(I,I3) = J ENDIF ENDDO ENDDO ENDIF C IF (J7C.GT.0) THEN DO I3 = 1,J7C IF (J7(I3).EQ.JP) THEN J7(I3) = J ENDIF ENDDO ENDIF C IF (J8C.GT.0) THEN DO I3 = 1,J8C IF (J8(I3).EQ.JP) THEN J8(I3) = J ENDIF ENDDO ENDIF C IF (J6C.GT.0) THEN DO I3 = 1,J6C IF (J6(I3).EQ.JP) THEN J6(I3) = J ENDIF ENDDO ENDIF C C Set I1 back to 1 in order to start search for equivalent triads C again since some elements may have been altered C I1 = 1 C C test whether triangle matches C 570 CONTINUE JJ2 = J2(IP,3) JJ3 = J3(IP,3) C C Assume equivalent triad but store kronecker delta information C in arrays J2TEST and J3TEST. C IF (JJ2.NE.JJ3) THEN ICOUNT = ICOUNT+1 J2TEST(ICOUNT) = JJ2 J3TEST(ICOUNT) = JJ3 GOTO 560 ENDIF C C If J2 angular momenta are in opposite order to J3 angular C momenta interchange them and store sign changes in J7 and J8. C Check dimensions C IF (J2(IP,1).NE.J3(IP,1)) THEN C J = J2(IP,1) J2(IP,1) = J2(IP,2) J2(IP,2) = J J7(J7C+1) = J2(IP,1) J7(J7C+2) = J2(IP,2) J7C = J7C+2 J8(J8C+1) = J2(IP,3) J8C = J8C+1 C IF (M3MNGM.LT.J7C) GOTO 800 IF (M3MNGM.LT.J8C) GOTO 800 C ENDIF C C Decrease IP and return to look for further equivalent triads C IP = IP-1 GOTO 590 C 580 CONTINUE I1 = I1+1 C 590 CONTINUE IF (I1.LE.IP) GOTO 520 C C If IP = 0 this means that all triads have been transformed to be C equivalent. Now exit to sum over Racah coefficients C IF (IP.LE.0) GOTO 750 C----------------------------------------------------------------------- C C Section 2 C C ITEST = 0 C Determines the mimimum recoupling of J2 array to obtain an equivalent C triad to one in J3 array. Store row of J3 array in ITEST1. C C ITEST = 1 C Determine recoupling of J2 array to obtain an equivalent triad of C ITEST1 row of J3 array. C C In both cases store information on recoupling C C----------------------------------------------------------------------- I10 = 9999 ITEST = 0 I1 = 1 C C GENJ45 determines the level of each J in the coupling tree of J2 C and J3 and stores the result in the J4 and J5 arrays respectively C 600 CONTINUE CALL GENJ45(IP) C C look for J in J2 array which is same as first element in J3 array C 610 CONTINUE DO I2 = 1,IP IF (J2(I2,1).EQ.J3(I1,1)) GOTO 620 IF (J2(I2,2).EQ.J3(I1,1)) GOTO 630 ENDDO GOTO 680 C C I3 and I5 denotes position in J2 array of common J C 620 CONTINUE I3 = 1 GOTO 640 C 630 CONTINUE I3 = 2 640 CONTINUE I5 = I2 C C now look for J in J2 array which is same as other element in J3 C array C DO I2 = 1,IP IF (J2(I2,1).EQ.J3(I1,2)) GOTO 650 IF (J2(I2,2).EQ.J3(I1,2)) GOTO 660 ENDDO GOTO 680 C C I4 and I6 denotes position in J2 array of common J C 650 CONTINUE I4 = 1 GOTO 670 C 660 CONTINUE I4 = 2 670 CONTINUE I6 = I2 C C I7 and I8 denote the position in the J1 array of the two common J C values in J2 and J3 C I7 = J2(I5,I3) I8 = J2(I6,I4) C C GENI9 determines the number of recouplings of two elements of J2 C necessary to obtain identical triads in J2 and J3 arrays. This C number plus two is stored in I9 C CALL GENI9(IP) C IF (I9.GE.I10) GOTO 680 C C A smaller recoupling pair found. Store lowest as J2(I13,I14) and C highest as J2(I11,I12). I15 and I16 contain level of these below C common triads. Finally ITEST1 denotes triad in J3 for next entry C to section 2 and is required if more than one recoupling C I10 = I9 I11 = I17 I12 = I19 I13 = I18 I14 = I20 I15 = I7 I16 = I8 ITEST1 = I1 C 680 CONTINUE C C I1 is only increased if searching for smallest recoupling pair C IF (ITEST.EQ.0) THEN I1 = I1+1 IF (I1.LE.IP) GOTO 610 ENDIF C IF (I10.GE.9999) GOTO 760 C----------------------------------------------------------------------- C C Section 3 C C The pair of J values that require the smallest number of recouplings C of J2 to bring into the same order as J3 has now been found. This C section now carries out one recoupling. C C----------------------------------------------------------------------- C C I1 and I2 denotes the level above the given levels of the triad C of elements to be recoupled C IF (I15.LT.I16) THEN I1 = I15-1 I2 = I16-2 ELSE I1 = I16-1 I2 = I15-2 ENDIF C I3 = I11 I4 = I13 I5 = I12 I6 = I14 C C Find first element to be recoupled C IF (I1.GT.0) THEN C DO I = 1,I1 C DO I7 = 1,IP IF (J2(I7,1).EQ.J2(I3,3)) GOTO 690 IF (J2(I7,2).EQ.J2(I3,3)) GOTO 700 ENDDO C 690 CONTINUE I5 = 1 GOTO 710 700 CONTINUE I5 = 2 C 710 CONTINUE I3 = I7 C ENDDO C ENDIF C C First element to be recoupled is J2(I3,I5) C Now find second element to be recoupled C IF (I2.GT.0) THEN C DO I = 1,I2 C DO I7 = 1,IP IF (J2(I7,1).EQ.J2(I4,3)) GOTO 720 IF (J2(I7,2).EQ.J2(I4,3)) GOTO 730 ENDDO C 720 CONTINUE I6 = 1 GOTO 740 730 CONTINUE I6 = 2 C 740 CONTINUE I4 = I7 C ENDDO C ENDIF C C Second element to be recoupled is J2(I4,I6) C C Interchange elements of I4 row of J2 if necessary and include C signs in J7 and J8 arrays C IF (I6.LE.1) THEN J7(J7C+1) = J2(I4,1) J7(J7C+2) = J2(I4,2) J7C = J7C+2 J8(J8C+1) = J2(I4,3) J8C = J8C+1 I = J2(I4,1) J2(I4,1) = J2(I4,2) J2(I4,2) = I ENDIF C C Interchange elements of I3 row of J2 if necessary and store signs C in J7 and J8 arrays C IF (I5.LE.1) THEN J7(J7C+1) = J2(I3,1) J7(J7C+2) = J2(I3,2) J7C = J7C+2 J8(J8C+1) = J2(I3,3) J8C = J8C+1 I = J2(I3,1) J2(I3,1) = J2(I3,2) J2(I3,2) = I ENDIF C C Now recouple the two elements of J2 and store square roots in J6 C and Racah coefficient in JW arrays. MP denotes a J which will be C summed over. C J6(J6C+1) = J2(I4,3) MP = MP+1 J6(J6C+2) = MP J6C = J6C+2 JWC = JWC+1 JW(1,JWC) = J2(I4,1) JW(2,JWC) = J2(I4,2) JW(3,JWC) = J2(I3,3) JW(4,JWC) = J2(I3,2) JW(5,JWC) = J2(I3,1) JW(6,JWC) = MP J2(I3,1) = J2(I4,1) J2(I4,1) = J2(I4,2) J2(I4,2) = J2(I3,2) J2(I4,3) = MP J2(I3,2) = MP C C Test dimensions and exit if failure C IF (M3MNGM.LT.J7C) GOTO 800 IF (M3MNGM.LT.J8C) GOTO 800 IF (MANGM.LT.MP) GOTO 800 IF (M3MNGM.LT.J6C) GOTO 800 IF (M6J.LT.JWC) GOTO 790 C IF (I1+I2.LE.0) GOTO 510 C C More than one recoupling required. Return to section 2 to decide C which elements of J2 to recouple in next step. If all recouplings C of a particular pair have been carried out then identical pairs C are now present in J2 and J3 arrays. Return to section 1 to see C if any more recoupling required. C ITEST = 1 I1 = ITEST1 I10 = 9999 GOTO 600 C C debug prints C 750 CONTINUE IF (IBUG3.EQ.1) THEN C WRITE (IWRITE,3010) (J1(I),I=1,M) WRITE (IWRITE,3040) C IF (JWC.GT.0) THEN DO J = 1,JWC WRITE (IWRITE,3050) (JW(I,J),I=1,6) ENDDO ELSE WRITE (IWRITE,3090) ENDIF C IF (J6C.GT.0) THEN WRITE (IWRITE,3060) (J6(J),J=1,J6C) ELSE WRITE (IWRITE,3100) ENDIF C IF (J7C.GT.0) THEN WRITE (IWRITE,3070) (J7(J),J=1,J7C) ELSE WRITE (IWRITE,3110) ENDIF C IF (J8C.GT.0) THEN WRITE (IWRITE,3080) (J8(J),J=1,J8C) ELSE WRITE (IWRITE,3120) ENDIF C IF (ICOUNT.GT.0) THEN WRITE (IWRITE,3160) (J2TEST(J),J=1,ICOUNT) WRITE (IWRITE,3170) (J3TEST(J),J=1,ICOUNT) ELSE WRITE (IWRITE,3180) ENDIF C ENDIF C----------------------------------------------------------------------- C C carry out summations C C----------------------------------------------------------------------- IF (IGEN.EQ.-1) RETURN CALL GENSUM(J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST,J3TEST,RECUP! +) RETURN C----------------------------------------------------------------------- C C fail because no pair in J2 and J3 found which could be recoupled C 760 CONTINUE WRITE (IWRITE,3000) STOP C C fail due to dimensions C 770 CONTINUE WRITE (IWRITE,3190) STOP 780 CONTINUE WRITE (IWRITE,3200) STOP 790 CONTINUE WRITE (IWRITE,3210) STOP 800 CONTINUE WRITE (IWRITE,3220) STOP C----------------------------------------------------------------------- 3000 FORMAT (' FAIL in NJSYM recoupling program') 3010 FORMAT (/' J1=',10I5) 3020 FORMAT (/' J2 J3') 3030 FORMAT (3I5,I10,2I5) 3040 FORMAT (' JW') 3050 FORMAT (6I5) 3060 FORMAT (' J6=',15I3) 3070 FORMAT (' J7=',15I3) 3080 FORMAT (' J8=',15I3) 3090 FORMAT (' no JW arrays set') 3100 FORMAT (' no J6 arrays set') 3110 FORMAT (' no J7 arrays set') 3120 FORMAT (' no J8 arrays set') 3130 FORMAT (/' ** NJSYM called ** IGEN=0 normal') 3140 FORMAT (/' ** NJSYM called ** IGEN=1 only GENSUM called') 3150 FORMAT (/' ** NJSYM called ** IGEN=-1 GENSUM not called') 3160 FORMAT (' J2TEST : ',20I3) 3170 FORMAT (' J3TEST : ',20I3) 3180 FORMAT (' no J2TEST,J3TEST arrays set') 3190 FORMAT (' FAIL in NJSYM : MTRIAD dimension failure') 3200 FORMAT (' FAIL in NJSYM : MANGM dimension failure') 3210 FORMAT (' FAIL in NJSYM : M6J dimension failure') 3220 FORMAT (' FAIL in NJSYM : M3MNGM dimension failure') END C C ******************* C SUBROUTINE NRCSF(NST,NFI,NJ) C C----------------------------------------------------------------------- C C This subroutine sets up nonrelativistic CSF data : V,S and L values C for each subshell and coupled S and L values for the combination of C subshells that may arise, subject to the total S and L coupling to C give the appropriate J value. The coupled angular momentum values C are stored in the array LSV. Routines are called to set up the C possible V,S and L values for each subshell and to calculate the C transformation between JJ and LS coupled configurations. C C Subroutines called : LSTERM,JCLIST,NJSYM,JJLS C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*2 NH LOGICAL FREE LOGICAL FAILN C INCLUDE 'grasp0.inc' PARAMETER (MANGM=60) PARAMETER (MTRIAD=20) C COMMON / ANG00 / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3), ! + FREE(MANGM) COMMON / INFORM / IREAD,IWRITE,IPUNCH COMMON / NRD01 / MLX(4),MQX(4),JPOS(4),NOPEN COMMON / NRD02 / NTERM(4),LSVT(5,16,4) COMMON / NRD06 / LSV(5,4,MXNC) COMMON / ORB00 / NH(MXNW) COMMON / ORB04 / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC) C DIMENSION INDEX(4) C----------------------------------------------------------------------- CALL LSTERM CALL JCLIST(NST,NFI) NCFN = NST-1 I1 = 0 C C Initialise arrays for NJSYM C NPN = NOPEN IF (NPN.EQ.1) NPN = NPN + 1 MMOM = 6*(NPN-1) NMOM = 2*NPN-1 C DO K = 1,3 KK = 3*(K-1) DO L = 3,NMOM,2 LL = 3*(L-2) J2(L-1,K) = LL+K LL = LL+KK DO J = 1,2 J3(L-J,K) = LL-J ENDDO J2(L,K) = LL ENDDO J2(1,K) = K J3(NMOM,K) = MMOM+K ENDDO C MMOM = MMOM+3 NMOM = NMOM+1 DO J = 1,MMOM J1(J) = 1 FREE(J) = .TRUE. ENDDO C CALL NJSYM (RECUP,-1,FAILN) J1(MMOM) = NJ C C Loop thru terms for first unfilled subshell C 10 CONTINUE I1 = I1+1 IF (I1.GT.NTERM(1)) GOTO 130 INDEX(1) = I1 NS1 = LSVT(2,I1,1) NL1 = LSVT(3,I1,1) LSVT(4,I1,1) = NS1 LSVT(5,I1,1) = NL1 J1(1) = NL1 J1(2) = NS1 NS = NS1 NL = NL1 C C Branch here for one unfilled subshell. C IF (NOPEN.EQ.1) GOTO 110 C C Loop thru terms for second unfilled subshell. C I2 = 0 20 CONTINUE I2 = I2+1 IF (I2.GT.NTERM(2)) GOTO 10 INDEX(2) = I2 NS2 = LSVT(2,I2,2) NL2 = LSVT(3,I2,2) J1(4) = NL2 J1(5) = NS2 NSMIN1 = ABS(NS1-NS2)+1 NLMIN1 = ABS(NL1-NL2)+1 NSI = NS1+NS2+1 NLMAX1 = NL1+NL2+1 C C Loop thru coupled S values. C 30 CONTINUE NSI = NSI-2 IF (NSI.LT.NSMIN1) GOTO 20 LSVT(4,I2,2) = NSI J1(8) = NSI NS = NSI C C Loop thru coupled L values. C NLI = NLMAX1 40 CONTINUE NLI = NLI-2 IF (NLI.LT.NLMIN1) GOTO 30 LSVT(5,I2,2) = NLI J1(7) = NLI NL = NLI C C Branch here for two unfilled subshells. C IF (NOPEN.EQ.2) GOTO 110 C C Loop thru terms for third unfilled subshell. C I3 = 0 50 CONTINUE I3 = I3+1 IF (I3.GT.NTERM(3)) GOTO 40 INDEX(3) = I3 NS3 = LSVT(2,I3,3) NL3 = LSVT(3,I3,3) J1(10) = NL3 J1(11) = NS3 NSMIN2 = ABS(NSI-NS3)+1 NLMIN2 = ABS(NLI-NL3)+1 NSJ = NSI+NS3+1 NLMAX2 = NLI+NL3+1 C C Loop thru coupled S values. C 60 CONTINUE NSJ = NSJ-2 IF (NSJ.LT.NSMIN2) GOTO 50 LSVT(4,I3,3) = NSJ J1(14) = NSJ NS = NSJ C C Loop thru coupled L values. C NLJ = NLMAX2 70 CONTINUE NLJ = NLJ-2 IF (NLJ.LT.NLMIN2) GOTO 60 LSVT(5,I3,3) = NLJ J1(13) = NLJ NL = NLJ C C Branch here for three unfilled subshells. C IF (NOPEN.EQ.3) GOTO 110 C C Loop thru terms for fourth unfilled subshell. C I4 = 0 80 CONTINUE I4 = I4+1 IF (I4.GT.NTERM(4)) GOTO 70 INDEX(4) = I4 NS4 = LSVT(2,I4,4) NL4 = LSVT(3,I4,4) J1(16) = NL4 J1(17) = NS4 NSMIN3 = ABS(NSJ-NS4)+1 NLMIN3 = ABS(NLJ-NL4)+1 NS = NSJ+NS4+1 NLMAX3 = NLJ+NL4+1 C C Loop thru coupled S values. C 90 CONTINUE NS = NS-2 IF (NS.LT.NSMIN3) GOTO 80 LSVT(4,I4,4) = NS J1(20) = NS C C Loop thru coupled L values. C NL = NLMAX3 100 CONTINUE NL = NL-2 IF (NL.LT.NLMIN3) GOTO 90 LSVT(5,I4,4) = NL J1(19) = NL 110 CONTINUE IF (NJ.GE.NL+NS .OR. NJ.LE.ABS(NL-NS)) GOTO 120 NCFN = NCFN+1 DO K = 1,NOPEN L = INDEX(K) DO I = 1,5 LSV(I,K,NCFN) = LSVT(I,L,K) ENDDO ENDDO C CALL JJLS(NST,NCFN,IFAIL,CHECK) IF (IFAIL.EQ.NCFN) GOTO 140 IF (IFAIL.GT.0) GOTO 150 C 120 CONTINUE GOTO (10,40,70,100),NOPEN C 130 CONTINUE IF (NCFN.EQ.NFI) RETURN C C Error messages C ============== C WRITE (IWRITE,3030) NCFN,NST,NFI WRITE (IWRITE,3000) NOPEN WRITE (IPUNCH,3030) NCFN,NST,NFI WRITE (IPUNCH,3000) NOPEN DO IJK = 1,NW WRITE (IWRITE,3010) NP(IJK),NH(IJK) WRITE (IWRITE,3020) (IQ(IJK,IJKL),IJKL=NST,NCF) WRITE (IPUNCH,3010) NP(IJK),NH(IJK) WRITE (IPUNCH,3020) (IQ(IJK,IJKL),IJKL=NST,NCF) ENDDO STOP C 140 CONTINUE WRITE (IWRITE,3040) NCFN,CHECK WRITE (IPUNCH,3040) NCFN,CHECK STOP C 150 CONTINUE WRITE (IWRITE,3050) NCFN,IFAIL,CHECK WRITE (IPUNCH,3050) NCFN,IFAIL,CHECK STOP C 3000 FORMAT (/' NOPEN : ',I6) 3010 FORMAT (/' ORBITAL : ',I2,A2) 3020 FORMAT (' IQ : ',15I4) 3030 FORMAT (/' *** ERROR in NRCSF....STOPPING ***'/ ! +' Too many nonrelativistic configurations'/' NCFN,NST,NFI : ',3I6) 3040 FORMAT (/' *** ERROR in NRCSF....STOPPING ***'/ ! +' ERROR in normalization of transformation vector for nonrel CSF '! +,I5/' Discrepancy is ',1P,E12.5) 3050 FORMAT (/' *** ERROR in NRCSF....STOPPING ***'/ ! +' ERROR in orthogonality of transformation vectors for nonrel CS',! +'F ',I5,' and ',I5/' discrepancy is ',1P,E12.5) END C C ******************* C SUBROUTINE NROUT(NMAN,NWM,IOP,IWRITE) C C----------------------------------------------------------------------- C C Print non-relativistic configuration data in a neat format. C Print transformation coefficients. C (each column corresponds to a non-relativistic configuration) C C NMAN - number of non-relativistic CSFS C NWM - number of non-relativistic orbitals C IOP - control parameter C =0 return C =1 no printing but array NRCSF is set-up C =2,3 print non-relativistic CSFs C =3 print transformation coefficients C IWRITE - lineprinter stream C C Subroutines called : MATOUT C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER IOP,IWRITE,NMAN,NWM C C Local variables C CHARACTER IBL CHARACTER*4 IPAR(2),JLAB(20) CHARACTER*14 LABT CHARACTER LLAB(20),NL,NLCUP(MXNW) CHARACTER NLN(MXNW),NLSUB(MXNW) CHARACTER*2 NOCCP(MXNW),NUM(20) INTEGER I,J,J1,J2 INTEGER K,LLR,LUP,MX INTEGER NCF,NCOR,NCORE,NFULL INTEGER NOC,NOPEN,NPN(MXNW),NS INTEGER NSCUP(MXNW),NSSUB(MXNW),NVSUB(MXNW),NX LOGICAL IPRT C C Common variables C DOUBLE PRECISION TC(MXNC,MXNC) COMMON / NRD00 / TC C C Common variables C INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC) COMMON / NRD03 / NPX,NLX,NQX C C Common variables C INTEGER IPOS(MXNW),KPOS(4,MXNC) INTEGER NPOS(MXNC) COMMON / NRD04 / IPOS,NPOS,KPOS C C Common variables C INTEGER LSV(5,4,MXNC) COMMON / NRD06 / LSV C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C CHARACTER*14 NRCSF(MXNC) COMMON / PATX / NRCSF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA IBL/' '/ DATA IPAR/'even','odd '/ DATA NUM/'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 ','10','1! +1','12','13','14','15','16','17','18','19'/ DATA JLAB/'0 ','1/2 ','1 ','3/2 ','2 ','5/2 ','3 ','7/2 ',! +'4 ','9/2 ','5 ','11/2','6 ','13/2','7 ','15/2','8 ','17! +/2','9 ','19/2'/ DATA LLAB/'S','P','D','F','G','H','I','K','L','M','N','O','Q','R',! +'T','U','V','W','X','Y'/ C----------------------------------------------------------------------- IF (IOP.EQ.0) RETURN IPRT = (IOP.EQ.2.OR.IOP.EQ.3) C NCORE = 0 NCF = NPOS(NMAN) C LABT = NUM(2)//IBL//LLAB(1)//IBL//JLAB(1)//IBL//IPAR(1) DO I = 1,NCF NRCSF(I) = LABT ENDDO C DO J = 1,NWM NFULL = NLX(J)*4+2 DO I = 1,NMAN IF (NQX(J,I).NE.NFULL) GOTO 10 ENDDO NCORE = NCORE+1 ENDDO C 10 CONTINUE NCOR = NCORE+1 C IF (IPRT) WRITE (IWRITE,3000) C IF (NCORE.EQ.0) THEN IF (IPRT) WRITE (IWRITE,3050) ELSE DO I = 1,NCORE NX = NQX(I,1) NOCCP(I) = NUM(NX+1) NX = NLX(I)+1 NLN(I) = LLAB(NX) ENDDO IF (IPRT) THEN WRITE (IWRITE,3020) WRITE (IWRITE,3030) (NOCCP(I),I=1,NCORE) WRITE (IWRITE,3040) (NPX(I),NLN(I),I=1,NCORE) ENDIF ENDIF C IF (NCORE.GE.NWM) THEN IF (IPRT) WRITE (IWRITE,3060) ELSE IF (IPRT) WRITE (IWRITE,3070) LLR = 1 DO K = 1,NMAN NOC = 0 C LUP = NPOS(K) IF (LUP.LT.LLR) GOTO 30 C DO J = NCOR,NWM IF (NQX(J,K).GT.0) THEN NOC = NOC+1 NX = NQX(J,K) NOCCP(NOC) = NUM(NX+1) NPN(NOC) = NPX(J) NX = NLX(J)+1 NLN(NOC) = LLAB(NX) ENDIF ENDDO C LUP = NPOS(K) C DO I = LLR,LUP NL = LLAB(1) NS = 1 NOPEN = 1 NOC = 0 DO J = NCOR,NWM IF (NQX(J,K).GT.0) THEN NOC = NOC+1 IF (J.NE.KPOS(NOPEN,K)) THEN NVSUB(NOC) = 0 NSSUB(NOC) = 1 NLSUB(NOC) = LLAB(1) ELSE NVSUB(NOC) = LSV(1,NOPEN,I) NSSUB(NOC) = LSV(2,NOPEN,I) NX = (LSV(3,NOPEN,I)+1)/2 NLSUB(NOC) = LLAB(NX) NS = LSV(4,NOPEN,I) NX = (LSV(5,NOPEN,I)+1)/2 NL = LLAB(NX) NOPEN = NOPEN+1 ENDIF NSCUP(NOC) = NS NLCUP(NOC) = NL ENDIF ENDDO C MX = ITJPO(I) IF (ISPAR(I).LT.0) THEN IF (IPRT) WRITE (IWRITE,3110) I,JLAB(MX) NRCSF(I) = NUM(NS+1)//IBL//NL//IBL//JLAB(MX)//IBL//IPAR(2) ELSE IF (IPRT) WRITE (IWRITE,3120) I,JLAB(MX) NRCSF(I) = NUM(NS+1)//IBL//NL//IBL//JLAB(MX)//IBL//IPAR(1) ENDIF C J1 = 1 20 CONTINUE J2 = NOC IF (J2.GT.J1+6) J2 = J1 + 6 IF (IPRT) THEN WRITE (IWRITE,3080) (NOCCP(J),NSSUB(J),NSCUP(J),J=J1,J2) WRITE (IWRITE,3090) (NPN(J),NLN(J),NLSUB(J),NLCUP(J),J=J1,! +J2) WRITE (IWRITE,3100) (NVSUB(J),J=J1,J2) ENDIF J1 = J1+7 IF (J2.LT.NOC) GOTO 20 C ENDDO 30 CONTINUE LLR = LUP+1 ENDDO C IF (IOP.EQ.3) THEN WRITE (IWRITE,3130) CALL MATOUT(IWRITE,TC,NCF,NCF,MXNC,MXNC,4) ENDIF C ENDIF C WRITE (IWRITE,3010) C----------------------------------------------------------------------- 3000 FORMAT (/1X,71('*')/' routine NROUT: write out LS-coupled CSFs'/1X! +,71('*')) 3010 FORMAT (/1X,71('*')) 3020 FORMAT (/' The core common to all CSFs is : ') 3030 FORMAT (/2X,10(3X,A2,1X)) 3040 FORMAT (2X,10(I2,A1,3X)) 3050 FORMAT (/' No core has been defined') 3060 FORMAT (/' No valence orbitals have been defined') 3070 FORMAT (/' CSFs are defined using format : Q S S"'/ ! +' NL ( L) L"'/ ! +' V') 3080 FORMAT (/1X,7(3X,A2,2X,I1,I4,4X)) 3090 FORMAT (1X,7(I2,A1,' ( ',A1,') ',A1,3X)) 3100 FORMAT (1X,7(I8,8X)) 3110 FORMAT (/' CSF ',I4,' J = ',A4,' odd') 3120 FORMAT (/' CSF ',I4,' J = ',A4,' even') 3130 FORMAT (/' Transformation coefficients'/) END C C ******************* C SUBROUTINE NUCPOT C C----------------------------------------------------------------------- C C Evaluate the nuclear potential. C C Routines called: NCHARG,YZK,QUAD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION CONNUC PARAMETER (CONNUC=2.2677D-5) INTEGER N11 PARAMETER (N11=MXNP+10) C C Local variables C DOUBLE PRECISION ARG,ATM,DNORM,FAC DOUBLE PRECISION RAD,SKI,WA INTEGER I,NGRID,NOPTS,NOPTSP C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER NBPAR,NCPAR,NMOTYP COMMON / MPAR1 / NMOTYP,NBPAR,NCPAR C C Common variables C DOUBLE PRECISION APAR,BBPAR(4),BPAR(4) DOUBLE PRECISION CCPAR(4),CPAR(4) COMMON / MPAR2 / APAR,BPAR,BBPAR,CPAR,CCPAR C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C INTEGER NPOTYP COMMON / PPAR1 / NPOTYP C C Common variables C DOUBLE PRECISION POLPAR(2) COMMON / PPAR2 / POLPAR C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) C C Point nucleus C IF (NUCTYP.EQ.0) THEN Z1 = ZERO DO I = 1,N ZZ(I) = Z ENDDO WRITE (IWRITE,3010) GOTO 30 ENDIF C----------------------------------------------------------------------- C C Finite nucleus C uniform charge distribution C IF (NUCTYP.EQ.1) THEN ATM = PARM(1) IF (ATM.LE.ZERO) GOTO 40 C RAD = CONNUC*ATM**(ONE/THREE) WA = RNT/RAD NOPTS = INT(ONE-LOG(WA)/H) WA = RAD*RAD FAC = Z/(TWO*RAD*WA) WA = WA*THREE Z1 = THREE*Z/(TWO*RAD) DO I = 1,NOPTS ZZ(I) = FAC*RGRID(I)*(WA-RGRID(I)*RGRID(I)) ENDDO NOPTSP = NOPTS+1 DO I = NOPTSP,N ZZ(I) = Z ENDDO WRITE (IWRITE,3030) ATM,RAD,NOPTS GOTO 30 C ENDIF C----------------------------------------------------------------------- C C Finite nucleus C Fermi two-parameter charge distribution C IF (NUCTYP.EQ.2) THEN RAD = PARM(1) SKI = PARM(2) IF (RAD.LE.ZERO .OR. SKI.LE.ZERO) GOTO 40 C DO I = 1,N ARG = (RGRID(I)-RAD)/SKI IF (ARG.GT.80.D0) GOTO 10 TA(I) = (RGRID(I)*RGRID(I))/(ONE+EXP(ARG)) ENDDO NGRID = N GOTO 20 C 10 CONTINUE NGRID = I-1 IF (MOD(NGRID,2).EQ.0) THEN NGRID = NGRID+1 TA(NGRID) = ZERO ENDIF C 20 CONTINUE CALL QUAD(NGRID,Z1) C DO I = 1,NGRID TA(I) = TA(I)*RGRID(I) ENDDO CALL YZK(NGRID,0) C C normalise to Z at large R C DNORM = Z/TB(NGRID) PARM(3) = TB(NGRID) DO I = 1,NGRID ZZ(I) = TB(I)*DNORM ENDDO Z1 = Z1*DNORM NOPTS = INT(ONE-LOG(RNT/RAD)/H) IF (NGRID.LT.N) THEN DO I = NGRID+1,N ZZ(I) = Z ENDDO ENDIF C WRITE (IWRITE,3040) RAD,SKI,NOPTS GOTO 30 C ENDIF C----------------------------------------------------------------------- C C Finite nucleus C for other values of NUCTYP a call is made to NCHARG C WRITE (IWRITE,3020) CALL NCHARG C C =============== NUCLEAR POTENTIAL HAS BEEN EVALUATED C =============== NOW CONSIDER ADDING POLARISATION OR MODEL POTENTIALS C 30 CONTINUE RETURN C----------------------------------------------------------------------- C C error messages C 40 CONTINUE WRITE (IWRITE,3050) WRITE (IPUNCH,3050) STOP C----------------------------------------------------------------------- 3000 FORMAT (/ ! +' >>>> routine NUCPOT called : evaluate nuclear potential') 3010 FORMAT (/' point nucleus case') 3020 FORMAT (/' finite nucleus case - call to NCHARG') 3030 FORMAT (/' finite nucleus with uniform charge distribution'/ ! +' atomic mass = ',1P,E12.5/ ! +' nuclear radius = ',E12.5/ ! +' grid points inside nucleus = ',I4) 3040 FORMAT (/ ! +' finite nucleus with a two-parameter Fermi charge distribution'/ ! +' half radius = ',1P,E12.5/ ! +' skin depth = ',E12.5/ ! +' grid points inside nucleus = ',I4) 3050 FORMAT (/' incorrect nuclear parameters - STOPPING in NUCPOT') END C C ******************* C FUNCTION OCON(IA1,IB1,IA2,IB2) C C----------------------------------------------------------------------- C C Evaluates the multiplicative statistical factor. C It is assumed that states are ordered so that C IA1.LE.IB1 and IA2.LE.IB2. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION OCON INCLUDE 'grasp0.inc' C C Argument variables C INTEGER IA1,IA2,IB1,IB2 C C Local variables C DOUBLE PRECISION WA,WB,WC INTEGER IDL,IDR,IPHAS,K INTEGER LLD1,LLD2,LRD1,LRD2 C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WA = DBLE(NQ1(IA1)*NQ1(IB1)) IF (IA1.EQ.IB1) WA = WA - DBLE(NQ1(IA1)) WB = DBLE(NQ2(IA2)*NQ2(IB2)) IF (IA2.EQ.IB2) WB = WB - DBLE(NQ2(IB2)) C WC = WA*WB OCON = SQRT(WC) C C Set phase factor (-1)**(DELTA P) C LRD1 = MIN(IA2,IB2)+1 LRD2 = MAX(IA2,IB2) IDR = 0 IF (LRD1.LE.LRD2) THEN IDR = 1 DO K = LRD1,LRD2 IDR = IDR+NQ2(K) ENDDO ENDIF C LLD1 = MIN(IA1,IB1)+1 LLD2 = MAX(IA1,IB1) IDL = 0 IF (LLD1.LE.LLD2) THEN IDL = 1 DO K = LLD1,LLD2 IDL = IDL+NQ1(K) ENDDO ENDIF C IPHAS = IDR-IDL IF (MOD(IPHAS,2).NE.0) OCON = -OCON C END C C ******************* C SUBROUTINE ORBPR(IR3,IP3) C C----------------------------------------------------------------------- C C This routine writes orbital data to the ORBITALS file. C Two records of information are written for each orbital. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER IP3,IR3 C C Local variables C CHARACTER*2 NHX DOUBLE PRECISION EX,HX,PZX,QZX DOUBLE PRECISION RNTX,ZX INTEGER I,IJ,IJ1,IJ2 INTEGER J,L,NAKX,NGRID INTEGER NPX,NX C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF C C Common variables C INTEGER ILO(MXNW),IWO(MXNW),NWO COMMON / WRO / NWO,IWO,ILO Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IR3.GT.0) THEN IF (ITC(41).EQ.1) THEN REWIND IR3 10 CONTINUE READ (IR3,END=20) NHX,NPX,NAKX,NX,ZX,HX,RNTX,EX,PZX,QZX READ (IR3) (P(I),I=1,NX), (Q(I),I=1,NX) WRITE (IP3) NHX,NPX,NAKX,NX,ZX,HX,RNTX,EX,PZX,QZX WRITE (IP3) (P(I),I=1,NX), (Q(I),I=1,NX) WRITE (IWRITE,3000) NPX,NHX GOTO 10 ENDIF ENDIF C 20 CONTINUE IF (NWO.EQ.0) RETURN DO L = 1,NWO J = IWO(L) NGRID = MPOIN(J) IJ1 = MPOS(J) IJ2 = IJ1+NGRID-1 WRITE (IP3) NH(J),NP(J),NAK(J),NGRID,Z,H,RNT,E(J),PZ(J),QZ(J) WRITE (IP3) (PF(IJ),IJ=IJ1,IJ2), (QF(IJ),IJ=IJ1,IJ2) WRITE (IWRITE,3000) NP(J),NH(J) ENDDO REWIND IP3 C 3000 FORMAT (/1X,I2,A2,' copied to orbitals file') END C C ******************* C SUBROUTINE OSCL(IO7,IO8) C C----------------------------------------------------------------------- C C This routine controls the main sequence of routine calls for the C calculation of transition oscillator strengths between MCDF levels. C C OSCL C BESSJ C CSFM C ENGOUT C LOAD C MATOUT C MCTIN C PRINTA C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Statement functions C LOGICAL ITRG C C Parameter variables C CHARACTER*4 IAU PARAMETER (IAU = 'a.u.') CHARACTER*4 IEV PARAMETER (IEV = 'eV ') CHARACTER*4 ICM PARAMETER (ICM = 'cm-1') CHARACTER*4 IAN PARAMETER (IAN = 'Ang ') C C Argument variables C INTEGER IO7,IO8 C C Local variables C CHARACTER*47 IEN CHARACTER*4 IUNITS DOUBLE PRECISION ARGU,ASFA,ASFB,FACTOR DOUBLE PRECISION OMEGA,VALUE INTEGER I,IELEC,II,ITEST INTEGER ITKPO,ITR,J,J1 INTEGER J2,J3,JC,JCASE INTEGER JJ,JJJ,JREAD,JTMP1 INTEGER JTMP2,LEV1,LEV2,LEVEL INTEGER LEVF,LEVI,LEVX,MAXV C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C DOUBLE PRECISION BJ(6,MXNP),DUM(2),TC(MXNP) DOUBLE PRECISION TD(MXNP) COMMON / BESS1 / DUM,BJ,TC,TD C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C INTEGER LEVELS(MXNC),NLEV COMMON / LEVL / NLEV,LEVELS C DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2 COMMON / LEVM / ENLEV,GAUGE1,GAUGE2 C INTEGER IOPAR,KA COMMON / MCTA / KA,IOPAR C INTEGER LTC(20) COMMON / OPT04 / LTC C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C INTEGER IASPAR(MXNC),IATJPO(MXNC) COMMON / OSC1 / IATJPO,IASPAR C INTEGER KK,LK COMMON / OSC2 / LK,KK C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ITRG(J1,J2,J3) = ABS(J1-J2).LE.J3 .AND. + J3.LE.J1+J2 .AND. + MOD(J1+J2+J3,2).EQ.0 C----------------------------------------------------------------------- C C Set the conversion factor for the transition wavelength. C IF (LTC(14)+LTC(15)+LTC(16).EQ.0) THEN IUNITS = IAN FACTOR = FACTAN/FACTCM GOTO 10 ENDIF C IF (LTC(14)+LTC(15)+LTC(16).GT.1) THEN IUNITS = IAN FACTOR = FACTAN/FACTCM GOTO 10 ENDIF C IF (LTC(14).EQ.1) THEN IUNITS = ICM FACTOR = FACTCM GOTO 10 ENDIF C IF (LTC(15).EQ.1) THEN IUNITS = IEV FACTOR = FACTEV GOTO 10 ENDIF C IF (LTC(16).EQ.1) THEN IUNITS = IAU FACTOR = ONE GOTO 10 ENDIF C----------------------------------------------------------------------- 10 CONTINUE WRITE (IWRITE,3000) IHED(1:40),IHED(41:80),RECORD WRITE (IPUNCH,3000) IHED(1:40),IHED(41:80),RECORD PRINT 3000,IHED(1:40),IHED(41:80),RECORD IF (LTC(19).EQ.1) THEN WRITE (IWRITE,3150) GAUGE1,GAUGE2 WRITE (IPUNCH,3150) GAUGE1,GAUGE2 ENDIF C C Read and check MCT coefficient file. C CALL MCTIN(IO7) C C Read and check MCDF wavefunction file. C REWIND IO8 CALL LOAD(IO8) C C = XCL WRITE (IWRITE,3120) C C C Set parity and total J of levels C DO LEVEL = 1,NCF MAXV = 0 VALUE = ZERO DO ITR = 1,NCF IF (ABS(COUVEC(ITR,LEVEL)).GE.VALUE) THEN MAXV = ITR VALUE = ABS(COUVEC(ITR,LEVEL)) ENDIF ENDDO IASPAR(LEVEL) = ISPAR(MAXV) IATJPO(LEVEL) = ITJPO(MAXV) ENDDO C WRITE (IWRITE,3020) NLEV DO I = 1,NLEV II = LEVELS(I) jtmp1 = IATJPO(II) IF (mod(jtmp1,2).eq.1) THEN jtmp2 = (jtmp1-1)/2 IF (IASPAR(II).eq.1) THEN WRITE (IWRITE,3050) II,jtmp2 ELSE WRITE (IWRITE,3060) II,jtmp2 ENDIF ELSE jtmp2 = jtmp1-1 IF (IASPAR(II).eq.1) THEN WRITE (IWRITE,3070) II,jtmp2 ELSE WRITE (IWRITE,3080) II,jtmp2 ENDIF ENDIF ENDDO C C LK = order of multipole = KA C LK = KA C C ============================================ C = Loop over the number of cases to be done = C ============================================ C IF (LTC(9)+LTC(10)+LTC(11).EQ.0) LTC(11) = 1 JCASE = LTC(9)+LTC(10)+LTC(11) JREAD = 0 C DO JC = 1,JCASE C C use MCDF energies C IF (LTC(9).EQ.1) THEN LTC(9) = 0 IEN = 'using Coulomb eigenvectors and Coulomb energies' GOTO 30 ENDIF C C use BENA energies C IF (LTC(10).EQ.1) THEN LTC(10) = 0 IEN = 'using Breit eigenvectors and Breit energies ' READ (IO8,END=20) ((COUVEC(I,J),J=1,NCF),I=1,NCF) READ (IO8) (COUENG(I),I=1,NCF) JREAD = 1 GOTO 30 ENDIF C C use BENA+QED energies C IF (LTC(11).EQ.1) THEN LTC(11) = 0 IEN = 'using Breit eigenvectors and Breit+QED energies' IF (JREAD.EQ.0) THEN READ (IO8,END=20) ((COUVEC(I,J),J=1,NCF),I=1,NCF) READ (IO8) ENDIF READ (IO8) (COUENG(I),I=1,NCF) REWIND IO8 GOTO 30 ENDIF C GOTO 90 C C ERROR message C BENA program was not called and energies are not available C use MCDF energies if they have not already been used. C 20 CONTINUE WRITE (IWRITE,3160) LTC(10) = 0 LTC(11) = 0 IF (JC.GT.1) GOTO 90 LTC(9) = 0 IEN = 'using Coulomb eigenvectors and Coulomb energies' C C Print out level energies and eigenvectors if requested. C 30 CONTINUE IF (LTC(12).EQ.1) THEN WRITE (IWRITE,3130) IEN CALL ENGOUT(COUENG,NCPRIN,IWRITE) CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3) ENDIF C----------------------------------------------------------------------- C C KK = 0 for electric multi-pole. C = 1 for magnetic multi-pole. C C IOPAR = (-1)**N electric N-pole C = (-1)**(N+1) magnetic N-pole. C C----------------------------------------------------------------------- IELEC = (-1)**KA IF (IOPAR.EQ.0) GOTO 40 IF (IELEC.NE.IOPAR) GOTO 50 C C electric case C 40 CONTINUE KK = 0 GOTO 60 C C magnetic case C 50 CONTINUE KK = 1 IELEC = -IELEC C C Choose pairs of levels and evaluate oscillator strengths. C 60 CONTINUE IF (LTC(17).EQ.1) WRITE (IWRITE,3170) IF (KK.EQ.1) THEN WRITE (IWRITE,3040) KA WRITE (IWRITE,3140) WRITE (IWRITE,3130) IEN WRITE (IWRITE,3100) IUNITS WRITE (IPUNCH,3040) KA WRITE (IPUNCH,3140) WRITE (IPUNCH,3130) IEN WRITE (IPUNCH,3100) IUNITS ELSE WRITE (IWRITE,3030) KA WRITE (IWRITE,3140) WRITE (IWRITE,3130) IEN WRITE (IWRITE,3090) IUNITS WRITE (IPUNCH,3030) KA WRITE (IPUNCH,3140) WRITE (IPUNCH,3130) IEN WRITE (IPUNCH,3090) IUNITS ENDIF IF(LTC(4).EQ.1)THEN WRITE (IWRITE,3180) WRITE (IPUNCH,3180) ENDIF C----------------------------------------------------------------------- DO LEVF = 1,NLEV DO LEVI = LEVF,NLEV C LEV2 = LEVELS(LEVF) LEV1 = LEVELS(LEVI) IF (LEV1.EQ.LEV2) GOTO 80 C C Check for consistent parity and J C ITKPO = KA+KA IF (ITRG(IATJPO(LEV1)-1,IATJPO(LEV2)-1,ITKPO)) GOTO 70 GOTO 80 C 70 CONTINUE ITEST = IASPAR(LEV1)*IASPAR(LEV2)*IELEC IF (ITEST.LT.0) GOTO 80 C C Find OMEGA and evaluate required Bessel functions. C OMEGA = COUENG(LEV1)-COUENG(LEV2) IF (LTC(17).EQ.1) OMEGA = ENLEV(LEVI) - ENLEV(LEVF) C IF (OMEGA.LT.ZERO) THEN OMEGA = -OMEGA LEVX = LEV1 LEV1 = LEV2 LEV2 = LEVX ENDIF C ARGU = OMEGA/C CALL BESSJ(ARGU,LK) C IF (LTC(6).EQ.1) THEN DO JJ = 1,3 JJJ = LK-2+JJ WRITE (IWRITE,3110) JJJ, (BJ(JJ,II),II=1,N) ENDDO ENDIF C C Calculate oscillator strength w.r.t. ASF C CALL CSFM(ASFA,ASFB,LEV1,LEV2) CALL PRINTA(ASFA,ASFB,LEV1,LEV2,OMEGA,FACTOR) C 80 CONTINUE C ENDDO ENDDO C----------------------------------------------------------------------- IF (IOPAR.EQ.0 .AND. KK.EQ.0) GOTO 50 C 90 CONTINUE ENDDO C C End loop over cases. C WRITE (IWRITE,3010) WRITE (IPUNCH,3010) C----------------------------------------------------------------------- 3000 FORMAT (/1X,71('*')/ +' routine OSCL : calculate transition probabilities'/1X,71('*')/ +' Title : ',A40/' ',A40/' Run at : ',A20/1X,71('*')) 3010 FORMAT (/1X,71('*')) 3020 FORMAT (/' Transitions between the following ',I4,' levels'/) 3030 FORMAT (/' Electric 2**(',I2,')-pole transitions') 3040 FORMAT (/' Magnetic 2**(',I2,')-pole transitions') 3050 FORMAT (9X,I4,5X,I4,' ',3X,'even') 3060 FORMAT (9X,I4,5X,I4,' ',3X,'odd') 3070 FORMAT (9X,I4,5X,I4,'/2',3X,'even') 3080 FORMAT (9X,I4,5X,I4,'/2',3X,'odd') 3090 FORMAT (/ +' A IJ ... emission transition probability (sec-1) ... length'/ +' F JI ... absorption oscillator strength ... length'/ +' S IJ ... line-strength (a.u.) ... length'// +' J I energy A IJ F JI S IJ vel', +'/len'/' ',A4/) 3100 FORMAT (/' A IJ ... emission transition probability (sec-1)'/ +' F JI ... absorption oscillator strength'/ +' S IJ ... line-strength (a.u.)'// +' J I energy A IJ F JI S IJ'/ +' ',A4/) 3110 FORMAT (/' Bessel function of order ',I3/(1P,4E18.10)) 3120 FORMAT (/' The speed of light has been reset to ',1P,E17.10) 3130 FORMAT (/1X,A47) 3140 FORMAT (1X,33('-')) 3150 FORMAT (/' option 19 set'/' different gauge factors will be used'/ +' Babushkin is replaced by gauge factor ',1P,E12.5/ +' Coulomb is replaced by gauge factor ',E12.5) 3160 FORMAT (/ +' *** WARNING - BENA has not been called - calculation continuin', +'g ***') 3170 FORMAT (/' *** using input level energies ***') 3180 FORMAT (12X,' 2j 2i',2X,' 2mj 2mi',4X,'CG',5X,'Q',4X,'S IJ', +8X,'A IJ'/) END C C ******************* C SUBROUTINE OUT(NODES,JORB,VN,AST,QZE,ALX,ALY,ECL,JC,JP,M,MAW,MA) C C----------------------------------------------------------------------- C C This subroutine carries out the step-by-step outward C integration for the inhomogeneous pair of Dirac radial C equations C C Data C C NODES number of nodes in the large component C JORB serial number of function to be computed C VN coefficient of r in series expansion of direct potential C ALX leading coefficients in the series expansions C ALY of the two exchange terms C AST current estimate of the parameter A C ECL current estimate of the eigenvalue E C JC if this is non-zero, it indicates the point C at which the step-by-step integration is to C terminate. If JC is zero, this point is C determined in the course of the calculation. C MAW If this is non-zero, it indicates the point at C which the use of the series expansion is to stop, C and the step-by-step integration is to begin. C C Results C C M is a failure warning, and should normally be zero. C =-1 indicates that P(R) has passed through too many zeros C =+1 indicates that either the end of the table has been reached, C or that P(R) has exceeded 10**6 in magnitude, C or that P(R) did not pass through enough zeros. C JP indicates the point at which the integration terminated. C MA indicates the last point for the series expansion. C QZE leading coefficient in expansion of Q(R) C P two common arrays in which the required C Q solutions are tabulated C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION QUART PARAMETER (QUART=.25D0) DOUBLE PRECISION DELTA PARAMETER (DELTA=1.D6) C C Argument variables C DOUBLE PRECISION ALX,ALY,AST,ECL DOUBLE PRECISION QZE,VN INTEGER JC,JORB,JP,M INTEGER MA,MAW,NODES C C Local variables C DOUBLE PRECISION AE,BE,FKJ,GAJ DOUBLE PRECISION PUN,PZE,QUN,WA DOUBLE PRECISION WAB,WB,WC,WD DOUBLE PRECISION WE,WFK INTEGER I,II,JS,KJ INTEGER MB,NGRID C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP) DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP) COMMON / INT3 / XU,XV,XR,XS,XF,XG C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- JS = NODES C BE = ECL/C AE = C+C-BE GAJ = GAMA(JORB) KJ = NAK(JORB) FKJ = DBLE(KJ) WFK = (FKJ*FKJ-QUART)*H*H*QUART C C Compute coefficients in the power series expansions of P and Q C IF (NUCTYP.GT.0) THEN C C Finite nucleus case C MA = 3 C IF (KJ.LT.0) THEN PZE = AST QZE = ZERO PUN = ZERO QUN = -(ALY-PZE*(BE-VN/C))/(GAJ+GAJ+ONE) ELSE PZE = ZERO QZE = AST*(GAJ+FKJ)*C/Z PUN = -(ALX-QZE*(AE+VN/C))/(GAJ+GAJ+ONE) QUN = ZERO ENDIF C ELSE C C Point nucleus case C PZE = AST C IF (KJ.LT.0) THEN QZE = -PZE*Z/(C*(GAJ-FKJ)) ELSE QZE = PZE*(GAJ+FKJ)*C/Z ENDIF C WA = GAJ+GAJ+ONE WB = ALX-QZE*(AE+VN/C) WC = ALY-PZE*(BE-VN/C) PUN = (-(GAJ+ONE-FKJ)*WB-Z*WC/C)/WA QUN = (-(GAJ+ONE+FKJ)*WC+Z*WB/C)/WA C C If MAW is zero, estimate number of points at which series C expansions can be used. Number must be at least 3. C IF (MAW.LE.0) THEN WA = ONE/(H*(GAJ+ONE)) WB = LOG(RNT)/H MA = INT(LOG(ABS(ACCY/PUN))*WA-WB) MB = INT(LOG(ABS(ACCY/QUN))*WA-WB) IF (MA.GT.MB) MA = MB IF (MA.LT.3) MA = 3 ELSE MA = MAW ENDIF C ENDIF C C Tabulate P and Q from series expansions C --------------------------------------- C WA = RNT**GAJ WB = EPH**GAJ DO I = 1,MA P(I) = WA*(PZE+RGRID(I)*PUN) Q(I) = WA*(QZE+RGRID(I)*QUN) WA = WA*WB ENDDO C C Debug print out if option 15 is set C IF (ITC(15).EQ.1) THEN WRITE (IWRITE,3000) NP(JORB),NH(JORB),WC,VN,ALX,ALY,PZE,QZE,PUN,! +QUN DO I = 1,MA,10 WRITE (IWRITE,3000) NP(JORB),NH(JORB),P(I),Q(I) ENDDO ENDIF C C Tabulate P and Q by step-by-step integration C -------------------------------------------- C WA = H*FKJ*HALF+ONE WB = WA-TWO WAB = WA*WB C IF (JC.GT.0) THEN II = MA+1 DO I = II,JC WC = XU(I-1)-WB*P(I-1)-XF(I-1)*Q(I-1) WD = XV(I-1)+WA*Q(I-1)-XG(I-1)*P(I-1) WE = XF(I)*XG(I)+WAB P(I) = (XF(I)*WD+WB*WC)/WE Q(I) = (XG(I)*WC-WA*WD)/WE ENDDO M = 0 I = JC ELSE I = MA NGRID = MPOIN(JORB) 10 CONTINUE I = I+1 WC = XU(I-1)-WB*P(I-1)-XF(I-1)*Q(I-1) WD = XV(I-1)+WA*Q(I-1)-XG(I-1)*P(I-1) WE = XF(I)*XG(I)+WAB P(I) = (XF(I)*WD+WB*WC)/WE Q(I) = (XG(I)*WC-WA*WD)/WE C C Test for change of sign C Count zeros C Exit with M=-1 if required number is exceeded C IF (P(I)*P(I-1).LE.ZERO) THEN C JS = JS-1 IF (JS.LT.0) THEN M = -1 GOTO 50 ELSE GOTO 10 ENDIF C ELSE C C Exit with M=1 if P grows too large C IF (ABS(P(I)).GE.DELTA) THEN M = 1 GOTO 50 ENDIF C C Exit with M=2 if end of table is reached C IF (I.GE.NGRID) THEN M = 2 GOTO 50 ENDIF C C Test for change of sign of discriminant C IF (WFK+XF(I)*XG(I)) 10,20,20 20 CONTINUE IF (WFK+XF(I-2)*XG(I-2)) 40,40,30 30 CONTINUE IF (XF(I)*XG(I)-XF(I-1)*XG(I-1)) 10,40,40 C C Normal termination when discriminant changes from negative C to positive, or when it passes through a positive minimum. C Exit with M=1 if P has not passed through enough zeros. C 40 CONTINUE IF (JS.GT.0) THEN M = 1 ELSE M = 0 ENDIF C ENDIF C ENDIF C 50 CONTINUE JP = I IF (ITC(15).EQ.1) WRITE (IWRITE,3010) NP(JORB),NH(JORB),JS,M,MA,JP C C Debug print out if option 14 is set C IF (ITC(14).EQ.1) THEN II = MA+1 DO I = II,JP,10 WRITE (IWRITE,3020) NP(JORB),NH(JORB),P(I),Q(I),XF(I),XG(I),XU! +(I-1),XV(I-1) ENDDO ENDIF C 3000 FORMAT (' OUT15 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3010 FORMAT (' OUT15 ',I2,A2,2X,4I12) 3020 FORMAT (' OUT14 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) END C C ******************* C SUBROUTINE PRINTA(ASFA,ASFB,I,J,OMEGA,FACTOR) C C----------------------------------------------------------------------- C C This routine prints the basic oscillator strength information C for transitions between level I and level J. C C ASFA : C ASFB : C I : level label C J : level label C OMEGA : C FACTOR : C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10,EPS70 PARAMETER (EPS10=1.D-10) PARAMETER (EPS70=1.D-70) C C Argument variables C DOUBLE PRECISION ASFA,ASFB,FACTOR,OMEGA INTEGER I,J C C Local variables C DOUBLE PRECISION ASFA2,ASFB2,ENG,FOS DOUBLE PRECISION FSEP,SEB DOUBLE PRECISION SEC,TOB,TOC DOUBLE PRECISION FACALF,LINESTR,VELLEN C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C INTEGER LTC(20) COMMON / OPT04 / LTC C INTEGER IASPAR(MXNC),IATJPO(MXNC) COMMON / OSC1 / IATJPO,IASPAR C INTEGER KK,LK COMMON / OSC2 / LK,KK C INTEGER IQ,IER,LL,LLL DOUBLE PRECISION XJ1,XJ2,XJ3,XM1,XM2,XM3,CG DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (ABS(OMEGA).LT.EPS10) RETURN C C evaluate relevant constants C C FOS = \frac{c^2\:(2J_r+1)}{\omega\:(2L+1)\:(2J_s+1)} C FOS = C*C/(OMEGA*DBLE(LK+LK+1)) FOS = FOS*DBLE(IATJPO(I))/DBLE(IATJPO(J)) C C FSEP = \frac{2\omega}{c\:(2L+1)\:\tau_o} C where $\tau_o$ is the atomic unit of time is seconds C FSEP = (TWO*OMEGA)/(C*DBLE(LK+LK+1)) FSEP = FSEP/XTAU C C convert energy to the required units C IF (LTC(14)+LTC(15)+LTC(16).EQ.0) THEN ENG = FACTOR/OMEGA ELSE ENG = OMEGA*FACTOR ENDIF C IF (KK.EQ.0) THEN C C electric case C ASFA2 = ASFA**2 ASFB2 = ASFB**2 TOB = ASFB2*FOS SEB = ASFB2*FSEP VELLEN = ASFB2 !NRB IF(VELLEN.GT.EPS70)VELLEN = ASFA2/ASFB2 !NRB C IF (LK.EQ.1) THEN FACALF = 1.D0 ELSE IF (LK.EQ.2) THEN FACALF = 3.756D5/OMEGA**2 ELSE FACALF = 0.D0 ENDIF ENDIF C LINESTR = 1.5D0*FACALF*DBLE(IATJPO(I))*SEB/(3.213D10*OMEGA**3) C C optional magentic sub-level resolution C IF(LTC(4).EQ.1)THEN DO LL=-(IATJPO(J)-1),(IATJPO(J)-1),2 DO LLL=-(IATJPO(I)-1),(IATJPO(I)-1),2 DO IQ=-1,1,1 IER=0 XJ1=REAL(IATJPO(J)-1)*0.5d0 XJ2=1.0d0 XJ3=REAL(IATJPO(I)-1)*0.5d00 XM1=REAL(LL)*0.5d0 XM2=REAL(IQ) XM3=REAL(LLL)*0.5d0 C CALL CLEBGOR(XJ1,XJ2,-XM1,XM2,XJ3,XM3,CG,IER) C IF(IER.EQ.0)THEN CG=CG/SQRT(REAL(IATJPO(I))) CG=CG**2 C write(iwrite,999)' LEV= ',j,' LEV= ',i,' 2J_final=', C X IATJPO(J)-1,' 2J_init=',IATJPO(I)-1, C X ' 2m_i=',nint(2*XM1),' 2m_j=',nint(2*XM3),CG,IQ, C X LINESTR*CG,SEB*CG WRITE(IWRITE,3000) J,I,IATJPO(J)-1,IATJPO(I)-1, X nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEB*CG WRITE(IPUNCH,3000) J,I,IATJPO(J)-1,IATJPO(I)-1, X nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEB*CG ENDIF ENDDO ENDDO ENDDO ENDIF C WRITE (IWRITE,3010) J,I,ENG,SEB,TOB,LINESTR,VELLEN WRITE (IPUNCH,3010) J,I,ENG,SEB,TOB,LINESTR,VELLEN C ELSE C C magnetic case C ASFA2 = ASFA**2 TOC = ASFA2*FOS SEC = ASFA2*FSEP C IF (LK.EQ.1) THEN FACALF = 7.511D4 ELSE IF (LK.EQ.2) THEN FACALF = 2.821D10/OMEGA**2 ELSE FACALF = 0.D0 ENDIF ENDIF C LINESTR = 1.5D0*FACALF*DBLE(IATJPO(I))*SEC/(3.213D10*OMEGA**3) C C optional magentic sub-level resolution C IF(LTC(4).EQ.1)THEN DO LL=-(IATJPO(J)-1),(IATJPO(J)-1),2 DO LLL=-(IATJPO(I)-1),(IATJPO(I)-1),2 DO IQ=-1,1,1 IER=0 XJ1=REAL(IATJPO(J)-1)*0.5d0 XJ2=1.0d0 XJ3=REAL(IATJPO(I)-1)*0.5d00 XM1=REAL(LL)*0.5d0 XM2=REAL(IQ) XM3=REAL(LLL)*0.5d0 C CALL CLEBGOR(XJ1,XJ2,-XM1,XM2,XJ3,XM3,CG,IER) C IF(IER.eq.0)THEN CG=CG/SQRT(REAL(IATJPO(I))) CG=CG**2 C write(iwrite,999)' LEV= ',j,' LEV= ',i,' 2J_final=', C X IATJPO(J)-1,' 2J_init=',IATJPO(I)-1, C X ' 2m_i=',nint(2*XM1),' 2m_j=',nint(2*XM3),CG,IQ, C X LINESTR*CG,SEC*CG WRITE(IWRITE,3000) J,I,IATJPO(J)-1,IATJPO(I)-1, X nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEC*CG WRITE(IPUNCH,3000) J,I,IATJPO(J)-1,IATJPO(I)-1, X nint(2*XM1),nint(2*XM3),CG,IQ,LINESTR*CG,SEC*CG ENDIF ENDDO ENDDO ENDDO ENDIF C WRITE (IWRITE,3020) J,I,ENG,SEC,TOC,LINESTR WRITE (IPUNCH,3020) J,I,ENG,SEC,TOC,LINESTR C ENDIF C C 999 FORMAT(2(A6,I3),A10,I3,A9,I3,2(A6,F9.5),F9.5,I3,F15.9,1X,E12.4) 3000 FORMAT (1X,2I5,3X,2I5,2X,2I5,F9.5,I3,1P,2E12.4) 3010 FORMAT (1X,2I5,1P,4E12.4,1X,E9.1) 3020 FORMAT (1X,2I5,1P,4E12.4) END C C ******************* C SUBROUTINE PROPG(IJK) C C----------------------------------------------------------------------- C C This subroutine calculates various properties of the orbitals C and prints out information i.e. C C (1) orbital eigenvalues in a.u. , expectation values of 1/r , C r and r*r , screening numbers (SC) C C (2) Lagrange multipliers C C (3) checks orthogonality and Schmidt orthogonalises if necessary c c Re-written for L-spinors viz. single pass orthogonalization c on-the-fly, which is highly accurate - nrb 16/01/08 C C (4) ordered eigenvalues and eigenvectors of the Hamiltonian C C IJK controls the output : C C =0 final print out using (1),(2),(3),(4) C C =1 check orthogonality of initial wave functions using (3) C with no print out C C Routines called : RINT , ZEFR , MATOUT C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL RINT DOUBLE PRECISION RINT C C Parameter variables C DOUBLE PRECISION EPS6 PARAMETER (EPS6=1.D-6) DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) C C Argument variables C INTEGER IJK C C Local variables C DOUBLE PRECISION AM,EAN,EAU,ECM DOUBLE PRECISION EEV,ERY,ORTH,RN DOUBLE PRECISION WA,WB,WC,WD DOUBLE PRECISION RT(MXNW) double precision eps INTEGER I,II,IJ,IP INTEGER J,L INTEGER LI,LJ,MA,MB INTEGER NGRID integer jf2 !,nt C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C double precision pz(mxnw),qz(mxnw) common / exco / pz,qz C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION ECV(MXNO) INTEGER IECC(MXNO),NEC COMMON / OFFD / ECV,IECC,NEC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C integer jtc(20) common / opt02 / jtc C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF C C Common variables C logical lspin common /nrb000/lspin Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Section (1) C C----------------------------------------------------------------------- IF (IJK.EQ.1) GOTO 10 C----------------------------------------------------------------------- WRITE (IWRITE,3010) WRITE (IPUNCH,3010) C DO J = 1,NW IF (JFIX(J).EQ.0) THEN NGRID = MPOIN(J) WB = RINT(J,J,1) RT(J) = WB CALL ZEFR(J,WB,WD) WD = Z-WD WRITE (IWRITE,3020) J,NP(J),NH(J),E(J),WD,NGRID WRITE (IPUNCH,3020) J,NP(J),NH(J),E(J),WD,NGRID ENDIF ENDDO C----------------------------------------------------------------------- WRITE (IWRITE,3230) WRITE (IPUNCH,3230) C DO J = 1,NW IF (JFIX(J).EQ.0) THEN WA = RINT(J,J,-1) WB = RT(J) WC = RINT(J,J,2) WRITE (IWRITE,3240) J,NP(J),NH(J),WA,WB,WC WRITE (IPUNCH,3240) J,NP(J),NH(J),WA,WB,WC ENDIF ENDDO C----------------------------------------------------------------------- C C Section (2) C C----------------------------------------------------------------------- IF (NEC.GT.0) THEN WRITE (IWRITE,3040) DO I = 1,NEC MA = IECC(I)/NW1 MB = IECC(I)-NW1*MA WRITE (IWRITE,3050) NP(MB),NH(MB),NP(MA),NH(MA),ECV(I) ENDDO ENDIF C----------------------------------------------------------------------- C C Section (3) C C----------------------------------------------------------------------- 10 CONTINUE IF (NW.EQ.1) GOTO 30 C 20 CONTINUE WRITE (IWRITE,3030) C if(lspin)then jf2=-2 eps=eps10 else jf2=2 eps=eps6 endif c nt = 0 DO I = 1,nw IP = I-1 DO J = 1,IP IF (NAK(I).EQ.NAK(J)) THEN IF (JFIX(I)+JFIX(J).NE.jf2) THEN NGRID = MIN(MPOIN(I),MPOIN(J)) ORTH = RINT(I,J,0) if(itc(22).eq.0.and.(ijk.eq.1.or.abs(orth).gt.eps))then write (iwrite,3045) np(i),nh(i),np(j),nh(j),orth c nt = nt+1 li = mpos(i) lj = mpos(j) do l = 1,ngrid pf(li) = pf(li)-orth*pf(lj) qf(li) = qf(li)-orth*qf(lj) li = li+1 lj = lj+1 enddo pz(i) = pz(i)-orth*pz(j) qz(i) = qz(i)-orth*qz(j) elseif(abs(orth).gt.eps.or.itc(22).eq.1)then WRITE (IWRITE,3050) NP(I),NH(I),NP(J),NH(J),ORTH endif ENDIF ENDIF ENDDO c if(nt.gt.0)then c do when nt=0, as improves norm for subsequent L-spinor overlaps ngrid = mpoin(i) rn = rint(i,i,0) cw write (iwrite,3050) np(i),nh(i),np(i),nh(i),rn rn = one/sqrt(rn) li = mpos(i) do l = 1,ngrid pf(li) = pf(li)*rn qf(li) = qf(li)*rn li = li+1 enddo pz(i) = pz(i)*rn qz(i) = qz(i)*rn c nt=0 c endif cw li = mpos(i) cw write(*,*)i,qz(i)/pz(i),qf(li)/pf(li) ENDDO C----------------------------------------------------------------------- 30 CONTINUE IF (IJK.EQ.1.or.jtc(13).eq.0) RETURN C----------------------------------------------------------------------- C C Section (4) C C----------------------------------------------------------------------- WRITE (IPUNCH,3110) DO J = 1,NCPRIN IF (J.EQ.1) THEN EAU = BREENG(J) ELSE EAU = BREENG(J)-BREENG(1) ENDIF ERY = EAU*FACTRY I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IPUNCH,3180) J,IJ,I,AM,EAU,ERY ELSE WRITE (IPUNCH,3170) J,IJ,I,AM,EAU,ERY ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IPUNCH,3160) J,IJ,I,AM,EAU,ERY ELSE WRITE (IPUNCH,3150) J,IJ,I,AM,EAU,ERY ENDIF ENDIF ENDDO C----------------------------------------------------------------------- IF (ABS(ATW).LT.EPS10) THEN WRITE (IWRITE,3090) FACTCM,FACTEV ELSE WRITE (IWRITE,3100) ATW,FACTCM,FACTEV ENDIF C DO J = 1,NCPRIN EAU = BREENG(J) ERY = EAU*FACTRY I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3180) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3170) J,IJ,I,AM,EAU,ERY ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3160) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3150) J,IJ,I,AM,EAU,ERY ENDIF ENDIF ENDDO C WRITE (IWRITE,3130) DO J = 1,NCPRIN EAU = BREENG(J) ECM = EAU*FACTCM EEV = EAU*FACTEV I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3180) J,IJ,I,AM,ECM,EEV ELSE WRITE (IWRITE,3170) J,IJ,I,AM,ECM,EEV ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3160) J,IJ,I,AM,ECM,EEV ELSE WRITE (IWRITE,3150) J,IJ,I,AM,ECM,EEV ENDIF ENDIF ENDDO C IF (NCPRIN.GT.1) THEN C WRITE (IWRITE,3120) DO J = 1,NCPRIN EAU = BREENG(J)-BREENG(1) ERY = EAU*FACTRY I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3220) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3210) J,IJ,I,AM,EAU,ERY ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3200) J,IJ,I,AM,EAU,ERY ELSE WRITE (IWRITE,3190) J,IJ,I,AM,EAU,ERY ENDIF ENDIF ENDDO C WRITE (IWRITE,3140) DO J = 1,NCPRIN EAU = BREENG(J)-BREENG(1) ECM = EAU*FACTCM EEV = EAU*FACTEV EAN = ZERO IF (J.GT.1) EAN = FACTAN/ECM I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN WRITE (IWRITE,3220) J,IJ,I,AM,ECM,EEV,EAN ELSE WRITE (IWRITE,3210) J,IJ,I,AM,ECM,EEV,EAN ENDIF ELSE IF (IP.EQ.1) THEN WRITE (IWRITE,3200) J,IJ,I,AM,ECM,EEV,EAN ELSE WRITE (IWRITE,3190) J,IJ,I,AM,ECM,EEV,EAN ENDIF ENDIF ENDDO C ENDIF C----------------------------------------------------------------------- C C Print the eigenvectors if option 32 is set C IF (ITC(32).EQ.1)CALL MATOUT(IWRITE,COUVEC,NCF,NCPRIN,MXNC,MXNC,3) C----------------------------------------------------------------------- 3000 FORMAT (1X) 3010 FORMAT (/' orbital properties'/' ------------------'/21X, ! +'E (a.u.)',8X,'SC'/) 3020 FORMAT (1X,I2,1X,I2,A2,3X,1P,E20.12,E15.7,I6) 3030 FORMAT (/' orthogonality integrals'/) 3040 FORMAT (/' Lagrange multipliers'/) 3045 format (1x,i2,a2,2x,i2,a2,3x,1p,e15.7,' Schmidt orthogonalised') 3050 FORMAT (1X,I2,A2,2X,I2,A2,3X,1P,E15.7) 3090 FORMAT (/' atomic level properties'/' -----------------------'/ ! +' conversion of units using atomic weight set to infinity'/ ! +' 1 a.u. = ',1P,E17.10,' cm-1'/' 1 a.u. = ',E17.10,' eV'// ! +' eigenenergies'/' -------------'/' dominant'/ ! +' level J parity CSF mix a.u.',16X,'Ryd.'/) 3100 FORMAT (/' atomic level properties'/' -----------------------'/ ! +' conversion of units using atomic weight = ',F10.5/ ! +' 1 a.u. = ',1P,E17.10,' cm-1'/' 1 a.u. = ',E17.10,' eV'// ! +' eigenenergies'/' -------------'/' dominant'/ ! +' level J parity CSF mix a.u.',16X,'Ryd.'/) 3110 FORMAT (/' atomic level properties'/' -----------------------'/ ! +' eigenenergies (absolute for groundstate; relative for others)'/ ! +' -------------'/' dominant'/ ! +' level J parity CSF mix a.u.',16X,'Ryd.'/) 3120 FORMAT (/' eigenenergies relative to the lowest'/ ! +' ------------------------------------'/ ! +' dominant'/ ! +' level J parity CSF mix a.u.',12X,'Ryd.'/) 3130 FORMAT (/' dominant'/ ! +' level J parity CSF mix cm-1',16X,' eV '/) 3140 FORMAT (/' eigenenergies relative to the lowest'/ ! +' ------------------------------------'/ ! +' dominant'/ ! +' level J parity CSF mix cm-1',12X,' eV ',12X,'Ang.'/) 3150 FORMAT (1X,I4,2X,I4,'/2 odd ',I4,2X,F5.3,1X,1P,2E20.12) 3160 FORMAT (1X,I4,2X,I4,'/2 even ',I4,2X,F5.3,1X,1P,2E20.12) 3170 FORMAT (1X,I4,2X,I4,' odd ',I4,2X,F5.3,1X,1P,2E20.12) 3180 FORMAT (1X,I4,2X,I4,' even ',I4,2X,F5.3,1X,1P,2E20.12) 3190 FORMAT (1X,I4,2X,I4,'/2 odd ',I4,2X,F5.3,1X,1P,3E16.8) 3200 FORMAT (1X,I4,2X,I4,'/2 even ',I4,2X,F5.3,1X,1P,3E16.8) 3210 FORMAT (1X,I4,2X,I4,' odd ',I4,2X,F5.3,1X,1P,3E16.8) 3220 FORMAT (1X,I4,2X,I4,' even ',I4,2X,F5.3,1X,1P,3E16.8) 3230 FORMAT (/16X,'1/r',12X,' r ',12X,'r*r'/) 3240 FORMAT (1X,I2,1X,I2,A2,3X,1P,3E15.7) END C C ******************* C SUBROUTINE PRWF(J) C C----------------------------------------------------------------------- C C Print wavefunctions C The wavefunctions are written formatted to PRWF.DAT on stream 29. C This file is in the form of a SHELL program that can be run to C split up the file. This facilitates input into a graphics package. C The file ORB files details on the contents of the other files. C C There are two modes : C (1) J>0 - used as a debug option in SOLV0/1, wavefunctions for C orbital J are printed if option 16 is set. C - also called from STWAVE C (2) J=0 - a final print out of wavefunctions is made if option 8 C is set. C - an initial print out wavefunctions is made if option 9 C is set. C C Subroutine called : IN2CH3 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER J C C Local variables C CHARACTER*3 LABEL CHARACTER*6 ORBNAM INTEGER I,IK,INDORB,IPRWF INTEGER K,NGRID C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc SAVE INDORB DATA INDORB/0/ C----------------------------------------------------------------------- IPRWF = 29 IF (INDORB.EQ.0) THEN OPEN (UNIT=IPRWF,FILE='GRASP.SH',FORM='FORMATTED',STATUS='UNKNOW! +N') ENDIF C IF (J.GT.0) THEN C C Mode (1) C NGRID = MPOIN(J) DO I = 1,NGRID PC(I) = P(I)*P(I)+Q(I)*Q(I) ENDDO INDORB = INDORB+1 CALL IN2CH3 (INDORB,LABEL,IWRITE) ORBNAM = 'orb'//LABEL WRITE (IPRWF,3000) ORBNAM,NP(J),NH(J),NAK(J),NGRID,E(J) WRITE (IPRWF,3010) ORBNAM WRITE (IPRWF,3020) (RGRID(I),P(I),Q(I),PC(I),I=1,NGRID) WRITE (IPRWF,3030) C ELSE C C Mode (2) C DO K = 1,NW NGRID = MPOIN(K) IK = MPOS(K) DO I = 1,NGRID P(I) = PF(IK) Q(I) = QF(IK) IK = IK+1 ENDDO DO I = 1,NGRID PC(I) = P(I)*P(I)+Q(I)*Q(I) ENDDO INDORB = INDORB+1 CALL IN2CH3 (INDORB,LABEL,IWRITE) ORBNAM = 'orb'//LABEL WRITE (IPRWF,3000) ORBNAM,NP(K),NH(K),NAK(K),NGRID,E(K) WRITE (IPRWF,3010) ORBNAM WRITE (IPRWF,3020) (RGRID(I),P(I),Q(I),PC(I),I=1,NGRID) WRITE (IPRWF,3030) ENDDO C ENDIF C 3000 FORMAT ('cat << eof >> INDEX'/A6,' : ',I2,1X,A2,1X,I3, ! +' : r (a.u.) : ',I4,1X,1P,E12.5/'eof') 3010 FORMAT ('cat << eof >> ',A6) 3020 FORMAT (1X,1P,4E12.4) 3030 FORMAT ('eof') END C C ******************* C SUBROUTINE QED C C----------------------------------------------------------------------- C C This routine evaluates the QED corrections to the energy levels C due to vacuum polarisation (correct to first order) and a crude C approximation to the self energy. C The V.P. contribution is calculated using the results of Fullerton C and Rinker Phys. Rev. A Vol 13 P 1283 (1976) while the S.E. C contribution is estimated for S, P- and P orbitals by interpolating C among the values given by P. Mohr for Coulomb type wavefunctions C after an effective nuclear charge, ZEFF, is obtained by finding the C ZEFF required to give a Coulomb orbital with the same average R C as the MCDF orbital. C C Subroutines called : RINT,FZALF,QUAD,VACPOL,ZEFR C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL RINT DOUBLE PRECISION RINT C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Local variables C DOUBLE PRECISION ALLINT,COEF,CONT,ENG DOUBLE PRECISION RAV,SFCONT,SLFINT(MXNW) DOUBLE PRECISION VALU,VPCONT,VPINT(MXNW),ZEFF INTEGER I,I1,J,K INTEGER LEV,NGRID C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC) COMMON / ENRG2 / VPENG,SFENG C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C INTEGER KTC(20) COMMON / OPT03 / KTC C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF C DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Calculate the vacuum polarisation potential at each of the grid C points C CALL VACPOL C C Obtain contribution from each orbital C DO I = 1,NW C C Obtain v.p. contribution for orbital I C NGRID = MPOIN(I) I1 = MPOS(I) DO K = 1,NGRID TA(K) = (PF(I1)*PF(I1)+QF(I1)*QF(I1))*TB(K) I1 = I1+1 ENDDO CALL QUAD(NGRID,ALLINT) VPINT(I) = ALLINT C C Obtain s.e. contribution for orbital I C IF (NAK(I).GT.1 .OR. NAK(I).LT.-2) THEN C C No estimate for other than s, p- or p states C VALU = ZERO C ELSE C C ...find average R for MCDF orbital... C RAV = RINT(I,I,1) C C ...find effective Z of Coulomb orbital with same average R... C CALL ZEFR(I,RAV,ZEFF) C C ...interpolate among P. Mohr data... C CALL FZALF(ZEFF,I,VALU) C C ...scale as required... C VALU = (ZEFF**4/XCL**3)*VALU/(XPI*DBLE(NP(I)**3)) C if(ktc(9).eq.1) x write(iwrite,3030)np(i),nh(i),zeff,rav,allint,valu C ENDIF C SLFINT(I) = VALU C ENDDO C C DO LEV = 1,NCF IF (KTC(9).EQ.1) WRITE (IWRITE,3000) LEV VPENG(LEV) = ZERO SFENG(LEV) = ZERO ENG = ZERO DO I = 1,NW C C Calculate coefficient C COEF = ZERO DO J = 1,NCF COEF = COEF+IQ(I,J)*(COUVEC(J,LEV)**2) ENDDO VPCONT = COEF*VPINT(I) SFCONT = COEF*SLFINT(I) CONT = VPCONT+SFCONT VPENG(LEV) = VPENG(LEV)+VPCONT SFENG(LEV) = SFENG(LEV)+SFCONT ENG = ENG+CONT C C Print contributions if requested C IF (KTC(9).EQ.1) + WRITE (IWRITE,3010) NP(I),NH(I),COEF,VPINT(I), + VPCONT,SLFINT(I),SFCONT,CONT ENDDO C C Print totals if requested C IF (KTC(9).EQ.1) WRITE (IWRITE,3020) VPENG(LEV),SFENG(LEV),ENG ENDDO C 3000 FORMAT (/' Contribution of Q.E.D. to level',I4,' energy'// +' orbital coeff. v.p. integral v.p. contrib. s.', +'e. integral s.e. contrib. Q.E.D. contribution'/) 3010 FORMAT (1X,1X,I2,A2,4X,E15.8,5(2X,E15.8)) 3020 FORMAT (44X,15('-'),19X,15('-'),2X,15('-')/44X,E15.8,19X,E15.8,2X, +E15.8) 3030 format('Orbital',2x,i2,a2,3x,'zeff=',f8.4,3x,'rav=',f8.4,3x, x'v.p. int.=',e15.8,3x,'s.e. int.=',e15.8) END C C ******************* C SUBROUTINE QUAD(NGRID,RESULT) C C----------------------------------------------------------------------- C C The value of RESULT is the integral of F(R) from C zero to infinity, where the values of R*F(R) are C tabulated in the array TA. The integral is computed by C use of Simpson's rule. The contribution of the interval C from 0 to the start of the Simpson's rule quadrature is C included by assuming that for small values of R the function C R*F(R) behaves like W*R**PX, where W is a constant which need C not be specified. The value of PX is obtained by comparing the C first two significant terms in TA. C The contribution of the tail of the function beyond the C last tabular point is assumed to be negligible. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS35 PARAMETER (EPS35=1.D-35) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) DOUBLE PRECISION THREE PARAMETER (THREE=3.D0) DOUBLE PRECISION FOUR PARAMETER (FOUR=4.D0) DOUBLE PRECISION THIRD PARAMETER (THIRD=ONE/THREE) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C DOUBLE PRECISION RESULT INTEGER NGRID C C Local variables C DOUBLE PRECISION COP,RPX,S1,S2 DOUBLE PRECISION SUM1,SUM2 INTEGER I,J,NP C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Find the starting point for the integration. this is the point C where the integrand ta first becomes significant, and is chosen C to prevent dividing by zero. C DO J = 1,NGRID IF (ABS(TA(J)).GT.EPS35) GOTO 10 ENDDO RESULT = ZERO RETURN C C Simpson's rule C 10 CONTINUE C NP = NGRID-J+1 IF (MOD(NP,2).EQ.0) THEN NP = NP+1 TA(NGRID+1) = ZERO ENDIF C S1 = ZERO DO I = 1,NP,2 S1 = S1+TA(J+I-1) ENDDO S1 = S1*TWO C S2 = ZERO DO I = 2,NP,2 S2 = S2+TA(J+I-1) ENDDO S2 = S2*FOUR C SUM2 = S1+S2 SUM2 = SUM2-(TA(J)+TA(J+NP-1)) SUM2 = SUM2*H*THIRD C C Add the contribution from 0 to R(J), plus the contribution C to Simpson's rule from TA(J). C COP = TA(J+1)/TA(J) IF (COP.LE.ONE) THEN RPX = ZERO ELSE RPX = H/LOG(COP) ENDIF C SUM1 = TA(J)*RPX C RESULT = SUM1+SUM2 C END C C ******************* C SUBROUTINE QUARTZ(I) C----------------------------------------------------------------------- C C This subroutine calculates the CPU time which has been used. C C I=-1 used to initialise the time stored in TIME1 C I= 0 writes out time used in seconds since last call C I= 2 returns in TIME2 the time used in seconds since last call C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) COMMON / CASIO / TIME1,TIME2 COMMON / INFORM / IREAD,IWRITE,IPUNCH C----------------------------------------------------------------------- IF (I.EQ.0 .OR. I.EQ.2) THEN C call cpu_time(time2) time2=time2-time1 C IF (I.EQ.0) THEN IF (IWRITE.GT.0) WRITE (IWRITE,3000) TIME2 IF (IPUNCH.GT.0) WRITE (IPUNCH,3000) TIME2 ENDIF C TIME1 = TIME1+TIME2 RETURN C ENDIF C----------------------------------------------------------------------- IF (I.EQ.-1) THEN call cpu_time(time1) RETURN ENDIF C----------------------------------------------------------------------- C C Error C C----------------------------------------------------------------------- IF (IWRITE.GT.0) WRITE (IWRITE,3010) I IF (IPUNCH.GT.0) WRITE (IPUNCH,3010) I STOP C----------------------------------------------------------------------- 3000 FORMAT (/' Time used = ',F10.2,' sec') 3010 FORMAT (/' ERROR in QUARTZ.'/ ! +' Routine was called with parameter I = ',I3/ ! +' The parameter must be -1, 0 or 2.'/' Code is stopping.') END C C ******************* C SUBROUTINE RAT1(XX,IRAT) C C----------------------------------------------------------------------- C C This subroutine returns a rational approximation to the number XX. C It determines whether surd form is better and attempts to factorise C a surd. C C XX = ( IRAT(1)/IRAT(2) ) * SQRT ( IRAT(3)/IRAT(4) ) C C Subroutines called : RAT2 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) C C Argument variables C DOUBLE PRECISION XX INTEGER IRAT(4) C C Local variables C DOUBLE PRECISION XX1,XX2 INTEGER DEN1,DEN2,I,ISIGNX INTEGER ITEST,J,NUM1,NUM2 INTEGER NX,NXX,NY,NYY INTEGER PRIME(8),XSTO(8),YSTO(8) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc DATA PRIME/2,3,5,7,11,13,17,19/ C----------------------------------------------------------------------- ISIGNX = INT(SIGN(ONE,XX)) C XX1 = ABS(XX) CALL RAT2(XX1,NUM1,DEN1) C XX2 = XX1*XX1 CALL RAT2(XX2,NUM2,DEN2) C IF (NUM2.GE.NUM1 .AND. NUM1.GT.0) THEN NUM2 = 0 ENDIF C IF (NUM1.GT.NUM2 .AND. NUM2.GT.0) THEN NUM1 = 0 ENDIF C IF (NUM1.EQ.0 .AND. NUM2.EQ.0) THEN IRAT(1) = 0 IRAT(2) = 1 IRAT(3) = 1 IRAT(4) = 1 RETURN ENDIF C IF (NUM2.EQ.0) THEN IRAT(1) = SIGN(NUM1,ISIGNX) IRAT(2) = DEN1 IRAT(3) = 1 IRAT(4) = 1 RETURN ENDIF C IF (NUM1.EQ.0) THEN C DO I = 1,8 XSTO(I) = 0 YSTO(I) = 0 ENDDO C NX = NUM2 C DO I = 1,8 IF (NX.EQ.1) GOTO 20 ITEST = PRIME(I) DO J = 1,8 IF (MOD(NX,ITEST).NE.0) GOTO 10 NX = NX/ITEST XSTO(I) = XSTO(I)+1 ENDDO 10 CONTINUE ENDDO C 20 CONTINUE NXX = 1 C DO I = 1,8 30 CONTINUE IF (XSTO(I).LE.1) GOTO 40 NXX = NXX*PRIME(I) XSTO(I) = XSTO(I)-2 GOTO 30 40 CONTINUE IF (XSTO(I).EQ.1) NX = NX*PRIME(I) ENDDO C NY = DEN2 C DO I = 1,8 IF (NY.EQ.1) GOTO 60 ITEST = PRIME(I) DO J = 1,8 IF (MOD(NY,ITEST).NE.0) GOTO 50 NY = NY/ITEST YSTO(I) = YSTO(I)+1 ENDDO 50 CONTINUE ENDDO C 60 CONTINUE NYY = 1 C DO I = 1,8 70 CONTINUE IF (YSTO(I).LE.1) GOTO 80 NYY = NYY*PRIME(I) YSTO(I) = YSTO(I)-2 GOTO 70 80 CONTINUE IF (YSTO(I).EQ.1) NY = NY*PRIME(I) ENDDO C IRAT(1) = SIGN(NXX,ISIGNX) IRAT(2) = NYY IRAT(3) = NX IRAT(4) = NY RETURN C ENDIF C END C C ******************* C SUBROUTINE RAT2(XX,NUM,DEN) C C----------------------------------------------------------------------- C C This routine returns the rational approximation to XX as NUM/DEN. C C No routines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION DMAX PARAMETER (DMAX=1.D5) C C Argument variables C DOUBLE PRECISION XX INTEGER DEN,NUM C C Local variables C DOUBLE PRECISION P,X,YY INTEGER D(15),I,K,NUMSIG INTEGER T Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- X = ABS(XX) K = 1 D(K) = INT(X) X = X-D(K) P = ONE/DMAX C 10 CONTINUE IF (X.LE.P) GOTO 20 IF (K.EQ.15) GOTO 20 X = ONE/X K = K+1 D(K) = INT(X) X = X-D(K) P = P*D(K) GOTO 10 C 20 CONTINUE NUM = D(K) DEN = 1 DO I = K-1,1,-1 T = NUM NUM = D(I)*NUM+DEN DEN = T ENDDO C YY = ONE NUMSIG = NINT(SIGN(YY,XX)) NUM = NUM*NUMSIG C END C C ******************* C SUBROUTINE READA(IO4,ICOUL,IBREIT) C C----------------------------------------------------------------------- C C Routine for checking the angular dump. C C IO4 - stream for MCP/MCBP coefficients. C C ICOUL = 0 on exit if no MCP coefficients are read C ICOUL = 1 on exit if MCP coefficients are read C C IBREIT = 0 on exit if no MCBP coefficients are read C IBREIT = 1 on exit if MCBP coefficients are read C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER IBREIT,ICOUL,IO4 C C Local variables C DOUBLE PRECISION COEF INTEGER I,ISTORE,ITYP,ITYPE INTEGER JA,JAP,JB,JBP INTEGER NCFP,NUMB,NUMBEL,NUMBT INTEGER NUMC,NUMCEL,NUMCT,NWP C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3030) PRINT 3030 C NUMCT = 0 NUMBT = 0 NUMCEL = 0 NUMBEL = 0 C----------------------------------------------------------------------- C C Position stream IO4 which reads in MCP/MCBP coefficients. C C Check that NW and NCF are consistent with the dump. C REWIND IO4 READ (IO4) READ (IO4) NCFP,NWP IF (NW.NE.NWP .OR. NCF.NE.NCFP) GOTO 40 DO I = 1,7 READ (IO4) ENDDO C----------------------------------------------------------------------- DO JA = 1,NCF DO JB = JA,NCF C C Read coefficients for configuration pair JA,JB. C READ (IO4) JAP,JBP IF (JA.NE.JAP .OR. JB.NE.JBP) GOTO 30 NUMC = 0 NUMB = 0 C C Coefficients stored as : ISTORE,ITYP,COEF C 10 CONTINUE READ (IO4) ISTORE,ITYP,COEF IF (ISTORE.EQ.0) GOTO 20 C ITYPE = ABS(ITYP) C IF (ITYPE.LT.7) THEN NUMB = NUMB+1 IF (ITYP.LT.0) THEN NUMBEL = NUMBEL+1 ENDIF ELSE NUMC = NUMC+1 IF (ITYP.LT.0) THEN NUMCEL = NUMCEL+1 ENDIF ENDIF C GOTO 10 C 20 CONTINUE NUMCT = NUMCT+NUMC NUMBT = NUMBT+NUMB C ENDDO ENDDO C REWIND IO4 C WRITE (IWRITE,3020) NUMCT,NUMCEL,NUMBT,NUMBEL PRINT 3020,NUMCT,NUMCEL,NUMBT,NUMBEL C IF (NUMCT.EQ.0) THEN ICOUL = 0 ELSE ICOUL = 1 ENDIF C IF (NUMBT.EQ.0) THEN IBREIT = 0 ELSE IBREIT = 1 ENDIF C RETURN C----------------------------------------------------------------------- C C Error messages. C 30 CONTINUE WRITE (IWRITE,3000) WRITE (IPUNCH,3000) PRINT 3000 STOP C 40 CONTINUE WRITE (IWRITE,3010) WRITE (IPUNCH,3010) PRINT 3010 STOP C----------------------------------------------------------------------- 3000 FORMAT (/ ! +' STOPPING in READA - incorrect configuration labels on dump') 3010 FORMAT (/' STOPPING in READA - incorrect MCP/MCBP dump') 3020 FORMAT (/1X,I7,' MCP (Coulomb) angular coefficients read'/1X,I7, ! +' core (Coulomb) angular coefficients read'//1X,I7, ! +' MCBP (Breit) angular coefficients read'/1X,I7, ! +' core (Breit) angular coefficients read') 3030 FORMAT (/' >>>> routine READA called : read angular coefficients') END C C ******************* C SUBROUTINE REORDR(NST) C C----------------------------------------------------------------------- C C Routine to sort CSF into order of descending total J. C A linked list sorting method is used. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER NST C C Local variables C INTEGER I,ICF,IFIRST INTEGER IPOS(MXNC),J,K,L INTEGER M,MCHOP(MXNW),MCUP(10) INTEGER MQ(MXNW),MQS(3,MXNW),MTJPO,N INTEGER NEXT(MXNC),NST1 C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Exit if only one member in list. C IF (NST.EQ.NCF) RETURN C C Set up linked list giving desired order of CSF. C NEXT(NST) = 0 IFIRST = NST NST1 = NST+1 DO ICF = NST1,NCF M = IFIRST L = 0 10 CONTINUE IF (ITJPO(ICF).LT.ITJPO(M)) GOTO 20 IF (L.NE.0) GOTO 30 NEXT(ICF) = IFIRST IFIRST = ICF GOTO 40 C 20 CONTINUE L = M M = NEXT(L) IF (M.NE.0) GOTO 10 30 CONTINUE NEXT(ICF) = NEXT(L) NEXT(L) = ICF 40 CONTINUE ENDDO C C Invert list to give list of positions of CSF. C L = IFIRST DO I = NST,NCF IPOS(L) = I L = NEXT(L) ENDDO C C Reorder CSF. C DO I = NST,NCF L = IPOS(I) IF (L.EQ.I) GOTO 60 DO J = 1,NW DO M = 1,3 MQS(M,J) = JQS(M,J,I) ENDDO MQ(J) = IQ(J,I) MCHOP(J) = ICHOP(J,I) ENDDO MTJPO = ITJPO(I) DO J = 1,10 MCUP(J) = JCUP(J,I) ENDDO 50 CONTINUE K = L DO J = 1,NW DO M = 1,3 N = MQS(M,J) MQS(M,J) = JQS(M,J,K) JQS(M,J,K) = N ENDDO N = MQ(J) MQ(J) = IQ(J,K) IQ(J,K) = N N = MCHOP(J) MCHOP(J) = ICHOP(J,K) ICHOP(J,K) = N ENDDO N = MTJPO MTJPO = ITJPO(K) ITJPO(K) = N DO J = 1,10 N = MCUP(J) MCUP(J) = JCUP(J,K) JCUP(J,K) = N ENDDO L = IPOS(K) IPOS(K) = K IF (L.NE.I) GOTO 50 DO J = 1,NW DO M = 1,3 JQS(M,J,I) = MQS(M,J) ENDDO IQ(J,I) = MQ(J) ICHOP(J,I) = MCHOP(J) ENDDO ITJPO(I) = MTJPO DO J = 1,10 JCUP(J,I) = MCUP(J) ENDDO IPOS(I) = I 60 CONTINUE ENDDO C END C C ******************* C FUNCTION RINT(I,J,K) C C----------------------------------------------------------------------- C C The value of this function is the integral of the function C C R**K * ( PI(R)*PJ(R) + QI(R)*QJ(R) ) C C For example, when I = J and K = 1, this gives C the mean radius for orbital I. C C Subroutines called : QUAD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION RINT INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER I,J,K C C Local variables C DOUBLE PRECISION RESULT INTEGER I1,J1,K1,L INTEGER NGRID C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Tabulate integrand as required for subroutine QUAD C NGRID = MIN(MPOIN(I),MPOIN(J)) I1 = MPOS(I) J1 = MPOS(J) K1 = K+1 IF (ABS(K1).GT.1) GOTO 40 IF (K1) 10,20,30 C 10 CONTINUE DO L = 1,NGRID TA(L) = (PF(I1)*PF(J1)+QF(I1)*QF(J1))/RGRID(L) I1 = I1+1 J1 = J1+1 ENDDO GOTO 50 C 20 CONTINUE DO L = 1,NGRID TA(L) = PF(I1)*PF(J1)+QF(I1)*QF(J1) I1 = I1+1 J1 = J1+1 ENDDO GOTO 50 C 30 CONTINUE DO L = 1,NGRID TA(L) = RGRID(L)*(PF(I1)*PF(J1)+QF(I1)*QF(J1)) I1 = I1+1 J1 = J1+1 ENDDO GOTO 50 C 40 CONTINUE DO L = 1,NGRID TA(L) = (RGRID(L)**K1)*(PF(I1)*PF(J1)+QF(I1)*QF(J1)) I1 = I1+1 J1 = J1+1 ENDDO C C Call subroutine QUAD for integration C 50 CONTINUE CALL QUAD(NGRID,RESULT) RINT = RESULT C END C C ******************* C FUNCTION RINTI(J,K) C C----------------------------------------------------------------------- C C The value of this function is the one-electron integral C I(J,K) for orbitals J,K. C A central difference formula is used to approximate the C derivative. C C Subroutine called : QUAD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION RINTI INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION XXA PARAMETER (XXA=672.D0) DOUBLE PRECISION XXB PARAMETER (XXB=-168.D0) DOUBLE PRECISION XXC PARAMETER (XXC=32.D0) DOUBLE PRECISION XXD PARAMETER (XXD=-3.D0) DOUBLE PRECISION XXE PARAMETER (XXE=1.D0/840.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER J,K C C Local variables C DOUBLE PRECISION CA,CB,CC,CD DOUBLE PRECISION CE,PD(MXNP),PJ(MXNP) DOUBLE PRECISION PK(MXNP),QD(MXNP),QJ(MXNP) DOUBLE PRECISION QK(MXNP),RESULT,WA,WB INTEGER I,IJ,IK,M INTEGER MM,NGRID,NN C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Stop if orbitals J and K have different kappa values C if(j.eq.0.or.k.eq.0)stop 'rinti j/k=0' IF (NAK(J).NE.NAK(K)) THEN WRITE (IWRITE,3000) WRITE (IPUNCH,3000) STOP ENDIF C C Copy out orbital K C IK = MPOS(K) NGRID = MPOIN(K) DO I = 1,NGRID PK(I) = PF(IK) QK(I) = QF(IK) IK = IK+1 ENDDO C IF (NGRID.LT.N) THEN DO I = NGRID+1,N PK(I) = ZERO QK(I) = ZERO ENDDO ENDIF C C Copy out orbital J C IJ = MPOS(J) NGRID = MPOIN(J) DO I = 1,NGRID PJ(I) = PF(IJ) QJ(I) = QF(IJ) IJ = IJ+1 ENDDO C IF (NGRID.LT.N) THEN DO I = NGRID+1,N PJ(I) = ZERO QJ(I) = ZERO ENDDO ENDIF C C Calculate derivative C -------------------- C Set derivative zero near origin C First M points C M = 4 DO I = 1,M PD(I) = ZERO QD(I) = ZERO ENDDO C C Use central difference formula C for points M+1 to N-M C CE = XXE*C/H CA = XXA*CE CB = XXB*CE CC = XXC*CE CD = XXD*CE C MM = M+1 NN = N-M DO I = MM,NN PD(I) = CA*(PK(I+1)-PK(I-1))+CB*(PK(I+2)-PK(I-2))+CC*(PK(I+3)-PK! +(I-3))+CD*(PK(I+4)-PK(I-4)) QD(I) = CA*(QK(I+1)-QK(I-1))+CB*(QK(I+2)-QK(I-2))+CC*(QK(I+3)-QK! +(I-3))+CD*(QK(I+4)-QK(I-4)) ENDDO C C Form the integrand for QUAD C --------------------------- C WA = C*C WA = WA+WA WB = C*NAK(K) C C Set first M points of integrand to zero C QUAD will use a power series to estimate this contribution C DO I = 1,M TA(I) = ZERO ENDDO C C NN=MIN(NN,NGRID) DO I = MM,NN TA(I) = QJ(I)*(-(WA*RGRID(I)+ZZ(I))*QK(I)+WB*PK(I)+PD(I))-PJ(I)*! +(ZZ(I)*PK(I)-WB*QK(I)+QD(I)) ENDDO C CALL QUAD(NN,RESULT) RINTI = RESULT C IF (ITC(26).EQ.1) THEN WRITE (IWRITE,3010) NP(J),NH(J),NP(K),NH(K),RINTI ENDIF C 3000 FORMAT (/ ! +' Attempt to calculate I(J,K) for orbitals with different kappas') 3010 FORMAT (' I (',I2,A2,',',I2,A2,') = ',1P,E17.9) END C C ******************* C SUBROUTINE RKCO1(NPEEL,JLIST,NQ1,NQ2,IDQ,JA1,JB1,JA2,JB2) C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IDQ,JA1,JA2,JB1 INTEGER JB2,JLIST(NPLX),NPEEL INTEGER NQ1(MXNW),NQ2(MXNW) C C Local variables C INTEGER J,JWW,NDQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IDQ = 0 C JA1 = 0 JB1 = 0 JA2 = 0 JB2 = 0 C DO JWW = 1,NPEEL C J = JLIST(JWW) NDQ = NQ1(J)-NQ2(J) C IF (ABS(NDQ).GT.2) THEN IDQ = 99 RETURN ENDIF C IF (NDQ.EQ.0) GOTO 10 C IF (NDQ.GT.0) THEN C IF (NDQ.EQ.1) THEN C IF (JA1.GT.0) THEN JB1 = JWW ELSE JA1 = JWW ENDIF C IDQ = IDQ+1 C ELSE C JA1 = JWW IDQ = IDQ+2 C ENDIF C ELSE C IF (NDQ.EQ.-1) THEN C IF (JA2.GT.0) THEN JB2 = JWW ELSE JA2 = JWW ENDIF C IDQ = IDQ+1 C ELSE C JA2 = JWW IDQ = IDQ+2 C ENDIF C ENDIF C 10 CONTINUE ENDDO C END C C ******************* C SUBROUTINE RKCO2G(KWA,NPEEL,JLIST,NQ1,NQ2,JT1,JT2,IWRITE,IBUG2) C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IBUG2,IWRITE,JLIST(NPLX),JT1 INTEGER JT2,KWA,NPEEL INTEGER NQ1(MXNW),NQ2(MXNW) C C Local variables C INTEGER IB1,IB2,JA1,JA2 INTEGER JB1,JB2,JT3,K1 INTEGER KW Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO KW = KWA,NPEEL C K1 = JLIST(KW) IF (NQ1(K1)*NQ2(K1).EQ.0) GOTO 10 C JA1 = JT1 JA2 = JT2 JB1 = KW JB2 = KW C C Interchange JA1 and JB1 if necessary. C IF (JA1.GT.JB1) THEN JT3 = JB1 JB1 = JA1 JA1 = JT3 ELSE IF (JA1.EQ.JB1) THEN IB1 = JLIST(JB1) IF (NQ1(IB1).LE.1) GOTO 10 ENDIF ENDIF C C Interchange JA2 and JB2 if necessary C IF (JA2.GT.JB2) THEN JT3 = JB2 JB2 = JA2 JA2 = JT3 ELSE IF (JA2.EQ.JB2) THEN IB2 = JLIST(JB2) IF (NQ2(IB2).LE.1) GOTO 10 ENDIF ENDIF C IF (IBUG2.EQ.1) WRITE (IWRITE,3000) JA1,JB1,JA2,JB2 CALL CORG(JA1,JB1,JA2,JB2) C 10 CONTINUE ENDDO C----------------------------------------------------------------------- 3000 FORMAT (//10X,' JA1 =',I4,4X,' JB1 =',I4,4X,' JA2 =',I4, ! +' JB2 =',I4) END C C ******************* C SUBROUTINE RKCO3G(JT1,JT2,IWRITE,IBUG2,JJQ1,JJQ2,JLIS,JC1S,JC2S) C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IBUG2,IWRITE,JC1S(NPLX) INTEGER JC2S(NPLX),JJQ1(3,MXNW) INTEGER JJQ2(3,MXNW),JLIS(NPLX),JT1 INTEGER JT2 C C Local variables C INTEGER I,I1,II,IJ INTEGER IJW,IM,JA1,JA2 INTEGER JB1,JB2,JT3,KW INTEGER NPEELM C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- DO KW = 1,NCORE C IJW = KLIST(KW) DO I = 1,NPEEL IJ = JLIST(I) IF (IJW.LT.IJ) GOTO 10 ENDDO I = NPEEL+1 GOTO 20 C 10 CONTINUE IM = NPEEL-I+1 DO II = 1,IM JLIST(NPEEL+2-II) = JLIST(NPEEL+1-II) IF (NPEEL.EQ.II) GOTO 20 JJC1(NPEEL+1-II) = JJC1(NPEEL-II) JJC2(NPEEL+1-II) = JJC2(NPEEL-II) ENDDO C 20 CONTINUE IF (I.LT.3) THEN I1 = JLIST(1) JJC1(1) = JJQ1(3,I1) JJC2(1) = JJQ2(3,I1) ELSE JJC1(I-1) = JJC1(I-2) JJC2(I-1) = JJC2(I-2) ENDIF C JLIST(I) = IJW JA1 = JT1 IF (JT1.GE.I) JA1 = JA1 + 1 JB1 = I JA2 = JT2 IF (JT2.GE.I) JA2 = JA2 + 1 JB2 = I IF (JA1.GT.JB1) THEN JT3 = JB1 JB1 = JA1 JA1 = JT3 ENDIF C IF (JA2.GT.JB2) THEN JT3 = JB2 JB2 = JA2 JA2 = JT3 ENDIF C NPEEL = NPEEL+1 IF (IBUG2.EQ.1) THEN WRITE (IWRITE,3000) JA1,JB1,JA2,JB2,KW,KLIST(KW) WRITE (IWRITE,3010) (JLIST(I),I=1,NPEEL) NPEELM = NPEEL-1 WRITE (IWRITE,3020) (JJC1(I),I=1,NPEELM) WRITE (IWRITE,3030) (JJC2(I),I=1,NPEELM) ENDIF C CALL CORG(JA1,JB1,JA2,JB2) NPEEL = NPEEL-1 C C Reset the arrays JLIST, JJC1 and JJC2 C DO I = 1,NPEEL JLIST(I) = JLIS(I) ENDDO NPEELM = NPEEL-1 DO I = 1,NPEELM JJC1(I) = JC1S(I) JJC2(I) = JC2S(I) ENDDO C ENDDO C----------------------------------------------------------------------- 3000 FORMAT (//10X,' JA1 =',I4,4X,' JB1 =',I4,4X,' JA2 =',I4, ! +' JB2 =',I4,' K2 =',I4,' KW =',I4) 3010 FORMAT (' JLIST : ',15I4) 3020 FORMAT (' JJC1 : ',15I4) 3030 FORMAT (' JJC2 : ',15I4) END C C ******************* C SUBROUTINE RKCOG(JA,JB) C C----------------------------------------------------------------------- C C Configurations : JA, JB C C Analyse the tables of quantum numbers set in the common blocks C ANG10, ANG11, ANG12, ANG13 to determine all possible sets of C interacting orbitals which give a non-vanishing 2-electron matrix C element, and initiate the calculation of coefficients. C C The following conventions are in force - C C 1. labels 1,2 refer to L, R sides of matrix element respectively. C C 2. pointers: C JA1, JB1, JA2, JB2 point to the JLIST array of active orbitals. C IA1, IB1, IA2, IB2 point to the complete list of orbitals. C C Subroutines called: COR,CORD,SETUP,VIJOUT,RKCO1,RKCO2,RKCO3 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER JA,JB C C Local variables C INTEGER I,IDQ,IPCA,IT1 INTEGER IT2,J,JA1,JA2 INTEGER JB1,JB2,JC1S(NPLX) INTEGER JC2S(NPLX),JLIS(NPLX),JT1,JT2 INTEGER K1,KLAST,KW1,KW2 INTEGER KWA,NPEELM C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (ITJPO(JA).NE.ITJPO(JB)) RETURN CALL SETUP(JA,JB,IWRITE,IBUG2) IF (IBUG2.EQ.1) CALL VIJOUT(JA,JB,IWRITE) C IF (IBUG2.EQ.1) THEN WRITE (IWRITE,3000) NW,NCF,JA,JB WRITE (IWRITE,3010) (ITJPO(I),I=1,NCF) WRITE (IWRITE,3020) (ISPAR(I),I=1,NCF) DO I = 1,NW WRITE (IWRITE,3030) (IQ(I,J),J=1,NCF) ENDDO WRITE (IWRITE,3040) NPEEL,NCORE WRITE (IWRITE,3050) (JLIST(I),I=1,NPEEL) IF (NPEEL.GT.1) THEN NPEELM = NPEEL-1 WRITE (IWRITE,3060) (JJC1(I),I=1,NPEELM) WRITE (IWRITE,3070) (JJC2(I),I=1,NPEELM) ENDIF ENDIF C----------------------------------------------------------------------- C C 1.0 Analyse peel shell interactions C C 1.1 Analyse electron distribution in peel. C (The full procedure is needed only if the number of peel C orbitals NPEEL >= 2) C C----------------------------------------------------------------------- IF (NW.LT.1) GOTO 50 IF (NPEEL.EQ.0) GOTO 40 IF (NPEEL.EQ.1) GOTO 20 C----------------------------------------------------------------------- C C Find differences in occupations, NDQ, for each peel orbital in turn C and use it to set up labels of active orbitals, maintaining the C convention JA1 <= JB1, JA2 <= JB2. C C----------------------------------------------------------------------- CALL RKCO1(NPEEL,JLIST,NQ1,NQ2,IDQ,JA1,JB1,JA2,JB2) C----------------------------------------------------------------------- C C 1.2 Calculate coefficients for all possible sets of active shells. C C There are 4 cases, depending on the value of IDQ, the sum of C the absolute differences NDQ - C C 1.2.1 IDQ > 4 - matrix element null C C----------------------------------------------------------------------- IF (IDQ.GT.4) RETURN C----------------------------------------------------------------------- C C 1.2.2 IDQ = 4 - matrix element uniquely defined C C----------------------------------------------------------------------- IF (IDQ.EQ.4) THEN IF (JB1.EQ.0) JB1 = JA1 IF (JB2.EQ.0) JB2 = JA2 IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA2,JB2 CALL CORG(JA1,JB1,JA2,JB2) RETURN ENDIF C----------------------------------------------------------------------- C C 1.2.3 IDQ = 2 - one orbital fixed each side. C Include all possible spectators. C C IDQ = 0 - for a matrix element off-diagonal in coupling. C You must sum over all pairs of orbitals excluding C core-core. C C----------------------------------------------------------------------- IF (IDQ.EQ.2) THEN KLAST = 1 ELSE IF (IDQ.NE.0) GOTO 50 IF (JA.EQ.JB) GOTO 20 KLAST = NPEEL ENDIF C----------------------------------------------------------------------- C C Store the arrays JLIST, JJC1 and JJC2. C C----------------------------------------------------------------------- DO I = 1,NPEEL JLIS(I) = JLIST(I) ENDDO NPEELM = NPEEL-1 DO I = 1,NPEELM JC1S(I) = JJC1(I) JC2S(I) = JJC2(I) ENDDO C----------------------------------------------------------------------- DO KWA = 1,KLAST C IF (IDQ.EQ.0) THEN JA1 = KWA JA2 = KWA ENDIF C JT1 = JA1 JT2 = JA2 IT1 = JLIST(JA1) IT2 = JLIST(JA2) C CALL RKCO2G(KWA,NPEEL,JLIST,NQ1,NQ2,JT1,JT2,IWRITE,IBUG2) C IF (IDQ.EQ.0 .AND. NCORE.EQ.0) GOTO 10 IF (NCORE.EQ.0 .OR. NAK(IT1).NE.NAK(IT2)) RETURN C----------------------------------------------------------------------- C C This section calculates the terms arising from active electrons C that are in closed shells. C C----------------------------------------------------------------------- CALL RKCO3G(JT1,JT2,IWRITE,IBUG2,JJQ1,JJQ2,JLIS,JC1S,JC2S) C----------------------------------------------------------------------- 10 CONTINUE ENDDO C----------------------------------------------------------------------- RETURN C----------------------------------------------------------------------- C C 1.2.4 IDQ = 0 - diagonal case. C Include all pairs with JA1 = JA2, JB1 = JB2. C C----------------------------------------------------------------------- 20 CONTINUE DO KW1 = 1,NPEEL K1 = JLIST(KW1) JB1 = KW1 DO KW2 = 1,KW1 JA1 = KW2 IF (JA1.EQ.JB1 .AND. NQ1(K1).LE.1) GOTO 30 IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA1,JB1 CALL CORG(JA1,JB1,JA1,JB1) 30 CONTINUE ENDDO ENDDO C----------------------------------------------------------------------- C C 2.0 The diagonal case. Deal with contributions from core orbitals. C C----------------------------------------------------------------------- 40 CONTINUE IF (NCORE.EQ.0) RETURN C----------------------------------------------------------------------- DO KW1 = 1,NCORE JB1 = KW1 C----------------------------------------------------------------------- C C 2.1 Calculate contribution from core/core terms. C C----------------------------------------------------------------------- IPCA = 2 DO KW2 = 1,KW1 JA1 = KW2 IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA1,JB1 CALL CORD(JA1,IPCA,JB1) ENDDO C----------------------------------------------------------------------- C C 2.2 Calculate contribution from peel/core terms. C C----------------------------------------------------------------------- IF (NPEEL.GT.0) THEN IPCA = 1 DO KW2 = 1,NPEEL JA1 = KW2 IF (IBUG2.EQ.1) WRITE (IWRITE,3090) JA1,JB1,JA1,JB1 CALL CORD(JA1,IPCA,JB1) ENDDO ENDIF C----------------------------------------------------------------------- ENDDO C----------------------------------------------------------------------- RETURN C----------------------------------------------------------------------- C C 3.0 Diagnostic print - NW < 1 C C----------------------------------------------------------------------- 50 CONTINUE WRITE (IWRITE,3080) WRITE (IPUNCH,3080) STOP C----------------------------------------------------------------------- 3000 FORMAT (' RKCO called : NW NCF JA JB : ',4I4) 3010 FORMAT (' RKCO called : ITJPO : ',10I4) 3020 FORMAT (' RKCO called : ISPAR : ',10I4) 3030 FORMAT (' RKCO called : IQ : ',10I4) 3040 FORMAT (' RKCO called : NPEEL,NCORE : ',2I4) 3050 FORMAT (' RKCO called : JLIST : ',10I4) 3060 FORMAT (' RKCO called : JJC1 : ',10I4) 3070 FORMAT (' RKCO called : JJC2 : ',10I4) 3080 FORMAT (' ERROR in RKCO') 3090 FORMAT (//10X,' JA1 =',I3,4X,' JB1 =',I3,4X,' JA2 =',I3, ! +' JB2 =',I3/) END C C ******************* C FUNCTION RKINT(NGRAC,NGRID,RAC,RBD,K,IW) C C----------------------------------------------------------------------- C C This routine evaluates the Breit interaction integrals. C C If IW=0 then calculates U(R1,R2) integral C C If IW=1,2 then calculateS R BAR (K; A C / B D ; W) with C C W = WAC if IC=1 C = WBD if IC=2 C C Subroutines called: QUAD,YBRA,YZK C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION RKINT INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C DOUBLE PRECISION RAC(MXNP),RBD(MXNP) INTEGER IW,K,NGRAC,NGRID C C Local variables C DOUBLE PRECISION RESULT INTEGER I,KP C C Common variables C DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP) DOUBLE PRECISION WIJ(2) COMMON / BESS1 / WIJ,BESSJ,BESSN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IW.EQ.0) THEN C C IW=0 C ---- DO I = 1,NGRAC TA(I) = RGRID(I)*RAC(I) ENDDO CALL YZK(NGRAC,K) DO I = 1,NGRID TA(I) = RBD(I)*TB(I) ENDDO CALL QUAD(NGRID,RESULT) C ELSE C C IW=1,2 C ------ DO I = 1,NGRAC TA(I) = RAC(I)*(ONE+BESSJ(1,IW,I)) ENDDO KP = K+1 CALL YBRA(NGRAC,KP) DO I = 1,NGRID TA(I) = RBD(I)*(ONE+BESSN(1,IW,I))*TB(I)*RGRID(I) ENDDO CALL QUAD(NGRID,RESULT) ENDIF C RKINT = RESULT C END C C ******************* C SUBROUTINE RRITZ(NLAST) C C----------------------------------------------------------------------- C C This subroutine forms a new L-spinor basis [c.f. Grant & Quiney c Phys.Rev.A62, 022508 (2000)] from the non-orthogonal zero-order c basis generated by COULG, using Rayleigh-Ritz method - nrb 03/08. c c The maximum basis size per kappa is hardwired via MXFCT as, for c DRMPS calculations, the max total number of orbitals (all kappa) c given by dimension MXNW will be unnecessarily large. Does not c seem worth introducing another user set dimension parameter. C C DATA C ---- C NLAST index of last element used in PF and QF C C RESULTS C ------- C PF,QF the wave functions are tabulated in these common arrays C C C Subroutines called: QUAD, DSYGV (LAPACK), YZK C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE c implicit real*8(a-h,o-z) !makes life easier when testing C INCLUDE 'grasp0.inc' C C Parameter dimensions (local) C INTEGER MXFCT,MXFCT2,LWORK C PARAMETER (MXFCT=50) PARAMETER (MXFCT2=MXFCT+MXFCT) PARAMETER (LWORK=32*MXFCT2) C C Parameter variables C DOUBLE PRECISION XXA PARAMETER (XXA=672.D0) DOUBLE PRECISION XXB PARAMETER (XXB=-168.D0) DOUBLE PRECISION XXC PARAMETER (XXC=32.D0) DOUBLE PRECISION XXD PARAMETER (XXD=-3.D0) DOUBLE PRECISION XXE PARAMETER (XXE=1.D0/840.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER NLAST C C Local variables C DOUBLE PRECISION AMAT(MXFCT2,MXFCT2),BMAT(MXFCT2,MXFCT2) DOUBLE PRECISION DE(MXFCT2),WORK(LWORK),ZEFF(MXNP) DOUBLE PRECISION TP(MXFCT),TQ(MXFCT) DOUBLE PRECISION PK(MXNP),PJ(MXNP),QK(MXNP),QJ(MXNP),PD(MXNP) INTEGER IMAP(MXNW),IPAP(MXFCT) C DOUBLE PRECISION ZJ,SCR,TC,TC2,RESULT,SUMP,SUMQ DOUBLE PRECISION CA,CB,CC,CD,CE INTEGER I,IJ,K,IK,J,M,N1,N2,M1,M2,NMAX,NMAX2,INFO INTEGER LL,LMIN,LMAX,KAPPA,NPMIN,KEY INTEGER NGRID,NN,MM,NPOINT,ISUM,NADD C INTEGER NE LOGICAL LSPIN C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C INTEGER ICUT(MXNW) COMMON /NRBCUT/ICUT C C Common variables C DOUBLE PRECISION FX INTEGER ISTATX,NPMIN0 COMMON /NRBINF/FX,ISTATX,NPMIN0 C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION CXP(MXNW) COMMON / ORB03 / CXP C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- c WRITE(IWRITE,3010) c c Set initial Coulomb screening. c NE=0 DO I=NW,1,-1 IF(NE.EQ.0)KEY=I !outermost orbital index NE=NE+IQ(I,1) ENDDO NE=NE-1 SCR=NE ZJ=Z-SCR c c Find l-range, i.e. kappas to solve for, that contain l-spinors c assume both kappas required for valid l.gt.0 c LMIN=999 LMAX=0 DO I=1,NW SCR=CXP(I) LSPIN=SCR.LT.-TENTH IF(LSPIN)THEN KAPPA=NAK(I) LL=KAPPA IF(KAPPA.LT.0)LL=-LL-1 LMIN=MIN(LMIN,LL) LMAX=MAX(LMAX,LL) ENDIF ENDDO C IF(LMIN.GT.LMAX)RETURN !as no valid states C LL=LMIN KAPPA=LL IF(KAPPA.EQ.0)KAPPA=-1 c c Entry point for new kappa c 1 CONTINUE c c default npmin starts with lowest princ. qu. no. that is l-spinor, c but will start lower if npmin0 is initialized lower on input Record 11 c NPMIN=MAX(NPMIN0,LL+1) !incase npmin0 set too low for this l c c First, set-up a map of where the required orbitals lie. c Also, see if buffer space was set large enough to store new basis. c NMAX=0 DO I=1,NW IF(NAK(I).EQ.KAPPA)THEN SCR=CXP(I) LSPIN=SCR.LT.-TENTH IF(LSPIN)NPMIN=MIN(NPMIN,NP(I)) IF(NP(I).GE.NPMIN)THEN !We want this orbital IF(ICUT(I).EQ.0)THEN !Index of real extent IK=MPOIN(I) !Unbuffered ELSE IK=ICUT(I) !Buffered ENDIF DO N1=1,NMAX J=IMAP(N1) IF(IK.GT.MPOIN(J))THEN !Extent beyond buffer WRITE(IWRITE,1000)J,I,FX WRITE(*,*)'***SR.RRITZ WARNING: ORBITAL TRUNCATED' ENDIF ENDDO NMAX=NMAX+1 IMAP(NMAX)=I ENDIF ENDIF ENDDO C IF(NMAX.EQ.0)GO TO 900 !as this kappa has no valid states C IF(NMAX.GT.MXFCT)THEN WRITE(IWRITE,*)'**RRITZ DIMENSION MXFCT TOO SMALL, INCREASE TO:' X ,NMAX STOP '**RRITZ DIMENSION MXFCT TOO SMALL' ENDIF C C C******************************************************* C C SET-UP GALERKIN EQUATION: A*X=E*B*X C C******************************************************* C NMAX2=NMAX+NMAX C DO N1=1,NMAX2 !INITIALIZE LOWER T DO M1=N1,NMAX2 AMAT(M1,N1)=ZERO BMAT(M1,N1)=ZERO ENDDO ENDDO C C*************************** C ADD-IN POTENTIAL TERMS C*************************** C C This zeff=-r*pot, so zeff=-zj for pure coulomb (zj.gt.0). C IF(ISTATX.EQ.0)THEN C C Use coulomb potential for quasi one-electron problem. C DO I=1,N ZEFF(I)=-ZJ ENDDO C ELSE C C Use static potential, plus any finite nucleus contrib. C Use occupation nos from first config, omitting the outermost electron. C DO I = 1,N TA(I) = ZERO ENDDO C DO J = 1,NW ISUM=IQ(J,1) IF(J.EQ.KEY)ISUM=ISUM-1 IF(ISUM.GT.0)THEN IJ = MPOS(J) NGRID = MPOIN(J) DO I = 1,NGRID TA(I) = TA(I)+ISUM*(PF(IJ)*PF(IJ)+QF(IJ)*QF(IJ)) IJ = IJ+1 ENDDO ENDIF ENDDO C DO I = 1,N TA(I) = TA(I)*RGRID(I) ENDDO C CALL YZK(N,0) C DO I = 1,N ZEFF(I) = TB(I)-ZZ(I) ENDDO C ENDIF C C Loop over "+ & -" components C***************************** C DO N1=1,NMAX N2=NMAX+N1 C K=IMAP(N1) C C Copy out orbital K C IK = MPOS(K) NGRID = MPOIN(K) DO I = 1,NGRID PK(I) = PF(IK) QK(I) = QF(IK) IK = IK+1 ENDDO C IF (NGRID.LT.N) THEN DO I = NGRID+1,N PK(I) = ZERO QK(I) = ZERO ENDDO ENDIF C C Loop over "+ & -" components C***************************** C DO M1=N1,NMAX !(N.B. M.GE.N) M2=NMAX+M1 C J=IMAP(M1) C C Copy out orbital J C IJ = MPOS(J) NGRID = MPOIN(J) DO I = 1,NGRID PJ(I) = PF(IJ) QJ(I) = QF(IJ) IJ = IJ+1 ENDDO C IF (NGRID.LT.N) THEN DO I = NGRID+1,N PJ(I) = ZERO QJ(I) = ZERO ENDDO ENDIF C C Form the ++ integrand for QUAD C DO I=1,N TA(I)=PK(I)*PJ(I)*ZEFF(I) ENDDO C CALL QUAD(N,RESULT) C C Add contribution to ++ C AMAT(M1,N1)=AMAT(M1,N1)+RESULT C C Form the -- integrand for QUAD C DO I=1,N TA(I)=QK(I)*QJ(I)*ZEFF(I) ENDDO C CALL QUAD(N,RESULT) C C Add contribution to -- C AMAT(M2,N2)=AMAT(M2,N2)+RESULT C ENDDO C ENDDO cc c write(71,*)'SPEED OF LIGHT USED: C=',c cc c write(71,*)'**************************' c write(71,*)'**** POTENTIAL MATRIX ****' c write(71,*)'**************************' c do n1=1,nmax2 c write(71,*)'*** ',n1 c write(71,1001)(amat(i,n1)/(2*zj),i=1,nmax) c write(71,1001)(amat(i,n1)/(2*zj),i=nmax+1,nmax2) cc do i=1,nmax2 cc amat(i,n1)=zero cc enddo c enddo C C *********************** C ADD-IN KINETIC TERMS C *********************** C TC = C*KAPPA C C Loop over "+" component C************************ C DO N1=1,NMAX N2=NMAX+N1 C K=IMAP(N1) C C Copy out orbital K C IK = MPOS(K) NGRID = MPOIN(K) DO I = 1,NGRID PK(I) = PF(IK) IK = IK+1 ENDDO C IF (NGRID.LT.N) THEN DO I = NGRID+1,N PK(I) = ZERO ENDDO ENDIF C C Calculate derivative C -------------------- C C Set derivative zero near origin, for first M points C M = 4 DO I = 1,M PD(I) = ZERO ENDDO C C Use central difference formula for points M+1 to N-M C CE = XXE*C/H CA = XXA*CE CB = XXB*CE CC = XXC*CE CD = XXD*CE C MM = M+1 NN = N-M DO I = MM,NN PD(I) = CA*(PK(I+1)-PK(I-1))+CB*(PK(I+2)-PK(I-2))+CC*(PK(I+3) + -PK(I-3))+CD*(PK(I+4)-PK(I-4)) ENDDO C C Loop over "-" component C************************ C DO M1=1,NMAX M2=NMAX+M1 C J=IMAP(M1) C C Copy out orbital J C IJ = MPOS(J) NGRID = MPOIN(J) DO I = 1,NGRID QJ(I) = QF(IJ) IJ = IJ+1 ENDDO C IF (NGRID.LT.N) THEN DO I = NGRID+1,N QJ(I) = ZERO ENDDO ENDIF C C Form the integrand for QUAD C --------------------------- C C Set first M points of integrand to zero C QUAD will use a power series to estimate this contribution C DO I = 1,M TA(I) = ZERO ENDDO C DO I = MM,NN TA(I) = QJ(I)*(TC*PK(I)+PD(I)) ENDDO C CALL QUAD(NN,RESULT) C C Add contribution to -+ C AMAT(M2,N1)=AMAT(M2,N1)+RESULT C ENDDO C ENDDO cc c write(71,*)'************************' c write(71,*)'**** KINETIC MATRIX ****' c write(71,*)'************************' c do n1=1,nmax2 c write(71,*)'*** ',n1 c write(71,1001)(amat(i,n1)/(2*zj),i=1,nmax) c write(71,1001)(amat(i,n1)/(2*zj),i=nmax+1,nmax2) cc do i=1,nmax2 cc amat(i,n1)=zero cc enddo c enddo C C C********************* C ADD-IN GRAM MATRICES C********************* C C (uses either E or EPS, where E=C*C+EPS) C TC=C*C TC2=TC+TC NPOINT=0 C C DIAGONAL M=N C ------------ C DO N1=1,NMAX N2=NMAX+N1 C K=IMAP(N1) NGRID = MPOIN(K) NPOINT=MAX(NPOINT,NGRID) !for future ref. C C Form the ++ integrand for QUAD C IK = MPOS(K) DO I = 1,NGRID TA(I) = PF(IK)*PF(IK)*RGRID(I) IK = IK+1 ENDDO C CALL QUAD(NGRID,RESULT) C C Add contribution to ++ C AMAT(N1,N1)=AMAT(N1,N1) !+TC*RESULT !for E C BMAT(N1,N1)=BMAT(N1,N1)+RESULT C C Form the -- integrand for QUAD C IK = MPOS(K) DO I = 1,NGRID TA(I) = QF(IK)*QF(IK)*RGRID(I) IK = IK+1 ENDDO C CALL QUAD(NGRID,RESULT) C C Add contribution to -- C AMAT(N2,N2)=AMAT(N2,N2)-TC2*RESULT !+TC*RESULT !for E C BMAT(N2,N2)=BMAT(N2,N2)+RESULT C ENDDO C C SUB-DIAGONAL M=N-1 C ------------------ C DO N1=2,NMAX N2=NMAX+N1 C M1=N1-1 M2=NMAX+M1 C K=IMAP(N1) J=IMAP(M1) NGRID = MIN(MPOIN(K),MPOIN(J)) C C Form the ++ integrand for QUAD C IK = MPOS(K) IJ = MPOS(J) DO I = 1,NGRID TA(I) = PF(IK)*PF(IJ)*RGRID(I) IK = IK+1 IJ = IJ+1 ENDDO C CALL QUAD(NGRID,RESULT) C C Add contribution to ++ C AMAT(N1,M1)=AMAT(N1,M1) !+TC*RESULT !for E BMAT(N1,M1)=BMAT(N1,M1)+RESULT C C Form the -- integrand for QUAD C IK = MPOS(K) IJ = MPOS(J) DO I = 1,NGRID TA(I) = QF(IK)*QF(IJ)*RGRID(I) IK = IK+1 IJ = IJ+1 ENDDO C CALL QUAD(NGRID,RESULT) C C Add contribution to -- C AMAT(N2,M2)=AMAT(N2,M2)-TC2*RESULT !+TC*RESULT !for E C BMAT(N2,M2)=BMAT(N2,M2)+RESULT C ENDDO cc c write(71,*)'*********************' c write(71,*)'**** GRAM MATRIX ****' c write(71,*)'*********************' c do n1=1,nmax2 c write(71,*)'*** ',n1 c write(71,1001)(bmat(i,n1),i=1,nmax) c write(71,1001)(bmat(i,n1),i=nmax+1,nmax2) cc do i=1,nmax2 cc amat(i,n1)=zero cc bmat(i,n1)=zero cc enddo c enddo C C C******************************************************* C C NOW SOLVE GENRALIZED EIGEN-PROBLEM (A*X=E*B*X) C C******************************************************* C CALL DSYGV(1,'V','L',NMAX2,AMAT,MXFCT2,BMAT,MXFCT2,DE X ,WORK,LWORK,INFO) C IF(INFO.NE.0)THEN WRITE(*,*)'*** INFO=',INFO WRITE(IWRITE,*)'*** SR.RRITZ: DSYGV FAILED WITH INFO=',INFO STOP '*** SR.RRITZ: DSYGV FAILED' ENDIF C DO N1=1,NMAX IF(DE(N1).GT.-2*TC)THEN !+TC WRITE(IWRITE,*)'***SR.RRITZ: ERROR: POSITRON ENERGY EXCEEDS', X ' -C**2 A.U. FOR BASIS ORBITAL',IMAP(N1) STOP 'ERROR: POSITRON ENERGY EXCEEDS -C**2 A.U.' ENDIF ENDDO c cc WRITE(*,*)' ' cc WRITE(*,*)'POSITRON E-VALUES +C**2 (A.U.):' cc WRITE(*,*)'------------------------------' c WRITE(71,*)' ' c WRITE(71,*)'POSITRON E-VALUES +C**2 (A.U.):' c WRITE(71,*)'------------------------------' c DO N1=1,NMAX cc WRITE(*,1011)N1,DE(N1)+TC+TC c WRITE(71,1011)N1,DE(N1)+TC+TC !-TC !CONVGE ON ZERO FROM BELOW c WRITE(71,1001)(AMAT(I,N1),I=1,NMAX) c WRITE(71,1001)(AMAT(I,N1),I=NMAX+1,NMAX2) c ENDDO cc c WRITE(*,*)' ' c WRITE(*,*)'ELECTRON E-VALUES -C**2 (A.U.):' c WRITE(*,*)'------------------------------' c WRITE(71,*)' ' c WRITE(71,*)'ELECTRON E-VALUES -C**2 (A.U.):' c WRITE(71,*)'------------------------------' c DO N1=NMAX+1,NMAX2 c M1=N1-NMAX c WRITE(*,1011)M1,DE(N1) !-TC c WRITE(71,1011)M1,DE(N1) !-TC !SO BOUND CONVGE ON ZERO FROM BELOW c WRITE(71,1001)(AMAT(I,N1),I=1,NMAX) c WRITE(71,1001)(AMAT(I,N1),I=NMAX+1,NMAX2) c ENDDO cc c 1001 FORMAT(10(F8.4)) c 1011 FORMAT(I4,1PD22.12) C C************************************************************* C C NOW FORM NEW BASIS: (P',Q')=(P,Q)*X (ELECTRON STATES ONLY) C C NOTE: THE TAIL CANNOT BE EXTENDED BECAUSE OF PF,QF SET-UP. C SO, BUFFER SPACE WAS SET BACK IN COULG, THEN COLLAPSED HERE. C NOTE: THE LOOPING IS "INEFFICIENT" (OVER "ROWS" PF,QF) SO C AS TO AVOID OVERWRITING, ELSE WE NEED TO DUPLICATE PF,QF. C C************************************************************* C C C First, update Energy term (Epsilon) C DO N1=1,NMAX N2=NMAX+N1 K=IMAP(N1) E(K)=DE(N2) !-TC !IF DE=E=EPS+C*C ENDDO C C Next, form new basis functions. C DO I=1,NPOINT C C Load this radial point for all functions C DO N1=1,NMAX J=IMAP(N1) IF(I.LE.MPOIN(J))THEN IJ=MPOS(J)+I-1 IPAP(N1)=IJ TP(N1)=PF(IJ) TQ(N1)=QF(IJ) ELSE TP(N1)=ZERO TQ(N1)=ZERO ENDIF ENDDO C C Now form new basis at this point, for all functions C DO N1=1,NMAX J=IMAP(N1) IF(I.LE.MPOIN(J))THEN N2=NMAX+N1 C SUMP=ZERO SUMQ=ZERO DO M1=1,NMAX M2=NMAX+M1 SUMP=SUMP+TP(M1)*AMAT(M1,N2) SUMQ=SUMQ+TQ(M1)*AMAT(M2,N2) ENDDO C IJ=IPAP(N1) PF(IJ)=SUMP QF(IJ)=SUMQ ENDIF ENDDO C ENDDO C C Ditto for threshold C DO N1=1,NMAX J=IMAP(N1) TP(N1)=PZ(J) TQ(N1)=QZ(J) ENDDO C DO N1=1,NMAX N2=NMAX+N1 C SUMP=ZERO SUMQ=ZERO DO M1=1,NMAX M2=NMAX+M1 SUMP=SUMP+TP(M1)*AMAT(M1,N2) SUMQ=SUMQ+TQ(M1)*AMAT(M2,N2) ENDDO C J=IMAP(N1) PZ(J)=SUMP QZ(J)=SUMQ ENDDO C C Re-index for any unused buffer space C DO N1=1,NMAX J=IMAP(N1) IF(ICUT(J).GT.0)THEN !Was buffered C IJ=MPOS(J)+ICUT(J)-1 DO I=ICUT(J),MPOIN(J) !Search from original cut-off IF (ABS(PF(IJ)).LE.CUTOFF) GOTO 60 IJ=IJ+1 ENDDO C ICUT(J) = MPOIN(J) C write(*,*)'***SR.RRITZ: WAVEFUNCTION TRUNCATED, INCREASE BUFFER' GOTO 70 C 60 CONTINUE C NPOINT = I IF (MOD(NPOINT,2).EQ.1) THEN NADD = 8 ELSE NADD = 7 ENDIF IF (NPOINT+NADD.GT.MPOIN(J)) NADD = MPOIN(J) - NPOINT ICUT(J) = NPOINT+NADD !New cut-off C 70 CONTINUE C ENDIF ENDDO C C------------------- C NEXT KAPPA C------------------- C 900 IF(KAPPA.GT.0)THEN KAPPA=-KAPPA-1 GO TO 1 ELSE LL=LL+1 KAPPA=LL IF(LL.LE.LMAX)GO TO 1 ENDIF C C Now collapse back any unused buffer space C ISUM=0 DO J=2,NW IF(ICUT(J-1).GT.0)ISUM=ISUM+MPOIN(J-1)-ICUT(J-1) IJ=MPOS(J) DO I=1,MPOIN(J) PF(IJ-ISUM)=PF(IJ) QF(IJ-ISUM)=QF(IJ) IJ=IJ+1 ENDDO MPOS(J)=MPOS(J)-ISUM ENDDO IF(ICUT(NW).GT.0)ISUM=ISUM+MPOIN(NW)-ICUT(NW) C DO J=1,NW IF(ICUT(J).GT.0)MPOIN(J)=ICUT(J) ENDDO C NLAST=NLAST-ISUM C RETURN C 1000 FORMAT(//'***SR.RRITZ WARNING: NOT ENOUGH BUFFER SPACE SET ASIDE', X ' FOR ORBITAL',I3,' TO ACCOMMODATE ORBITAL', X I3,' WHEN FORMING NEW BASIS.'/'***INCREASE FX ON RECORD', X ' 11 FROM',F5.1) 3010 FORMAT (/' >>>> routine RRITZ called : form final L-spinor basis') C END C C ******************* C SUBROUTINE SCF(ERAL,MX,HIACC) C C----------------------------------------------------------------------- C C This subroutine controls the main sequence of the C calculation to produce a complete set of self-consistent C wave functions. C C ERAL: maximum discrepancy between estimated and C calculated wave functions C MX: error indicator C C Subroutines called : QUARTZ , LAGR , YPOT , XPOT , EIGENV , C HPOT , SOLV0 , RINT C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL EIGENV,RINT DOUBLE PRECISION EIGENV,RINT C C Parameter variables C DOUBLE PRECISION PEIGHT PARAMETER (PEIGHT=.8D0) DOUBLE PRECISION PNINE PARAMETER (PNINE=.9D0) DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION EPS2 PARAMETER (EPS2=1.D-2) C C Argument variables C DOUBLE PRECISION ERAL INTEGER MX LOGICAL HIACC C C Local variables C DOUBLE PRECISION AG,ASMT(10),ER(MXNW) DOUBLE PRECISION ESMT(10),VN,WA,WB DOUBLE PRECISION WC,WD,XCA,XCP DOUBLE PRECISION XCQ,XINC,ZFAC,ZMX DOUBLE PRECISION ZST INTEGER I,IJ,IMX,IPW INTEGER IPWL,IPY,ITCA,ITCB INTEGER ITCC,ITCD,ITR,J INTEGER JL,MF,NFIRST,NGRID INTEGER NLAST,NN,NPOINT C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION XCAX COMMON / CONVG / XCAX C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- MX = 0 ITR = 4*NW J = 0 XINC = XCAX*TENTH C WRITE (IWRITE,3010) C C Insert artificial values into the array ER, so that C the first operation will consist of one stage of iteration C for each function in their natural order C DO I = 1,NW ER(I) = ZERO ENDDO C WA = DBLE(NW) DO I = 1,NW IF (JFIX(I).EQ.0) ER(I) = 1000.D0*WA WA = WA-ONE ENDDO C C JL is the serial number of the function treated in the C previous iteration. In the first iteration it is zero. C C Determine WA, the largest discrepancy, and J, which C specifies which function shows this largest value. C 10 CONTINUE WA = -ONE JL = J C DO I = 1,NW WB = ABS(ER(I)) IF (WB.GT.WA) THEN WA = WB J = I ENDIF ENDDO C C Normal exit if required accuracy has been achieved C -------------------------------------------------- C IF (WA.LE.ERAL) RETURN C C ITR counts iterations downwards from the specified maximum C ITR = ITR-1 IF (ITR.LT.0) GOTO 110 C C Store atomic number in ZST. C IPY indicates which stage the automatic recovery process has reached. C IPY=0 normal computation of wave function C IPY=1 after initial failure, atomic number is C being increased C IPY=2 solution has been found with artificially C increased atomic number, which is now C being reduced. C This reduction of the atomic number in the third stage is C achieved in 10 stages, which are counted in IPW, stepping C down from 10 to zero. C ZST = Z ZMX = Z IPW = 10 IPY = 0 IPWL = 10 XCA = XCAX ZFAC = ONE C C Adjustment of off-diagonal parameters. C CALL LAGR(J) C C XCA is the factor multiplying exchange terms C Z is the effective atomic number C C Tabulate the direct and exchange potentials C ------------------------------------------- C 20 CONTINUE CALL YPOT(J,VN,ZFAC) CALL XPOT(J,XCA,XCP,XCQ) C C IF (XCA.LT.EPS10 .OR. E(J).LE.ZERO) THEN C C Compute estimate of eigenvalue, if no other estimate is C available, or if exchange terms are zero C WA = EIGENV(J) C ELSE C C Use eigenvalue from previous iteration, if any. C WA = E(J) ENDIF C C If estimate is not positive, use E = 0.1 C IF (WA.LE.ZERO) THEN WA = TENTH ENDIF C C Use estimate of PZ from previous iteration C AG = PZ(J) C C If in final stage of recovery from previous failure, C extrapolate estimates of E and PZ from previous C two iterations C IF (IPY.EQ.2 .AND. IPW.GT.1) THEN AG = ASMT(IPW)+ASMT(IPW)-ASMT(IPW-1) WA = ESMT(IPW)+ESMT(IPW)-ESMT(IPW-1) ENDIF C C Solve Dirac radial equations C ---------------------------- C IF (ITC(4).EQ.1) CALL HPOT(J,XCA) C CALL SOLV0(J,VN,XCA,XCP,XCQ,AG,WA,MF,HIACC,NPOINT) C C Failure 9 indicates table too short C extend by four steps C IF (MF.EQ.9) THEN C NLAST = MPOS(NW)+MPOIN(NW)-1 IF (NLAST+4.GT.MXNG) GOTO 120 C IF (J.LT.NW) THEN NFIRST = MPOS(J+1) DO NN = NLAST,NFIRST,-1 PF(NN+4) = PF(NN) QF(NN+4) = QF(NN) ENDDO DO NN = J+1,NW MPOS(NN) = MPOS(NN)+4 ENDDO ENDIF C NLAST = MPOS(J)+MPOIN(J)-1 DO NN = NLAST+1,NLAST+4 PF(NN) = ZERO QF(NN) = ZERO ENDDO MPOIN(J) = MPOIN(J)+4 IF (MPOIN(J).GT.N) N = MPOIN(J) IF (N.GT.MXNP) GOTO 130 C C .... and try again C GOTO 20 C ENDIF C C Successful iteration C -------------------- C IF (MF.EQ.0) THEN NGRID = MPOIN(J) C C Find largest difference between calculated and estimated functions C WC = ZERO IJ = MPOS(J) C DO I = 1,NGRID WA = P(I)-PF(IJ) WB = ABS(WA)+ABS(Q(I)-QF(IJ)) IF (WB.GT.WC) THEN WC = WB WD = WA IMX = I ENDIF IJ = IJ+1 ENDDO C C Avoid adjustment of mixing coefficient XAM unless previous C iteration involved the same function C IF (JL.NE.J .OR. IPY.EQ.1 .OR. IPWL.NE.IPW) GOTO 100 C C Increase XAM if new correction has opposite sign to C previous one, and more than half the magnitude C IF (WC-ABS(ER(J))*HALF) 100,100,30 30 CONTINUE IF (WD*ER(J)) 40,70,70 40 CONTINUE IF (XAM(J)-PEIGHT) 60,60,50 C C Do not increase XAM beyond 0.9 C 50 CONTINUE XAM(J) = PNINE GOTO 100 C 60 CONTINUE XAM(J) = XAM(J)+TENTH GOTO 100 C C Decrease XAM by 0.1 if new correction has same sign as C previous one, and more than half the magnitude C 70 CONTINUE IF (XAM(J)-TENTH) 80,80,90 C C Do not decrease XAM below zero C 80 CONTINUE XAM(J) = ZERO GOTO 100 C 90 CONTINUE XAM(J) = XAM(J)-TENTH C C Print one line record of iteration C ---------------------------------- C 100 CONTINUE ER(J) = SIGN(WC,WD) WB = RNT*EPH**(IMX-1) WRITE (IWRITE,3000) J,NP(J),NH(J),E(J),Z,XAM(J),XCA,WB,ER(J),NPO! +INT C IF (XAM(J).LT.EPS10) THEN IJ = MPOS(J) DO I = 1,NGRID PF(IJ) = P(I) QF(IJ) = Q(I) IJ = IJ+1 ENDDO C ELSE C C Tabulate new estimate as combination of old and computed functions C ------------------------------------------------------------------ C WB = XAM(J) WC = ONE-WB IJ = MPOS(J) DO I = 1,NGRID PF(IJ) = WC*P(I)+WB*PF(IJ) QF(IJ) = WC*Q(I)+WB*QF(IJ) IJ = IJ+1 ENDDO C C Re-normalise the result C ----------------------- C WA = ONE/SQRT(RINT(J,J,0)) IJ = MPOS(J) DO I = 1,NGRID PF(IJ) = PF(IJ)*WA QF(IJ) = QF(IJ)*WA IJ = IJ+1 ENDDO C ENDIF C C On final success, reset Z to true value and try another iteration C IF (IPY.EQ.0 .OR. (IPY.EQ.2.AND.IPW.EQ.10)) THEN Z = ZST GOTO 10 C ENDIF C C If this completes stage 1 of the recovery process, C begin stage 2, counting upwards from zero in IPW C ------------- C IPWL = IPW IF (IPY.EQ.1) THEN IPY = 2 ZMX = Z IPW = 0 ENDIF C C Store values of E and PZ for subsequent extrapolation C ASMT(IPW+1) = PZ(J) ESMT(IPW+1) = E(J) ITR = ITR-1 C C Repeat this step if change was significant C IF (ABS(ER(J)).GT.EPS2) GOTO 20 C C ... otherwise reduce Z and repeat C IPW = IPW+1 XCA = XCA+XINC Z = ZST+(ZMX-ZST)*(10-IPW)/10.0D0 ZFAC = Z/ZST GOTO 20 C ENDIF C C In case of failure, repeat computation with extra printing C ------------------ C Repeat computation with extra printing if option 13 is set C IF (ITC(13).EQ.1) THEN ITCA = ITC(19) ITCB = ITC(18) ITCC = ITC(17) ITCD = ITC(15) ITC(19) = 1 ITC(18) = 1 ITC(17) = 1 ITC(15) = 1 IF (ITC(4).EQ.1) CALL HPOT(J,XCA) CALL SOLV0(J,VN,XCA,XCP,XCQ,AG,WA,MF,HIACC,NPOINT) ITC(19) = ITCA ITC(18) = ITCB ITC(17) = ITCC ITC(15) = ITCD ENDIF C C Begin recovery by setting exchange terms to zero C IF (IPY.EQ.0) THEN IPY = 1 XCA = ZERO JL = J GOTO 20 ENDIF C C If failure with IPY=1 increase Z until convergence C IF (IPY.EQ.1) THEN Z = Z+TENTH ZFAC = Z/ZST IF (Z.GT.ZST+5.D0) THEN MF = 5 ELSE GOTO 20 ENDIF ENDIF C C If failure with IPY=2 abandon calculation C WRITE (IWRITE,3040) NP(J),NH(J) C IF (MF.EQ.-2) THEN WRITE (IWRITE,3050) CALL QUARTZ(0) STOP ENDIF C IF (MF.EQ.-1) THEN WRITE (IWRITE,3060) CALL QUARTZ(0) STOP ENDIF C IF (MF.EQ.1) THEN WRITE (IWRITE,3070) CALL QUARTZ(0) STOP ENDIF C IF (MF.EQ.2) THEN WRITE (IWRITE,3080) CALL QUARTZ(0) STOP ENDIF C IF (MF.EQ.3) THEN WRITE (IWRITE,3090) CALL QUARTZ(0) STOP ENDIF C IF (MF.EQ.4) THEN WRITE (IWRITE,3100) CALL QUARTZ(0) STOP ENDIF C IF (MF.EQ.5) THEN WRITE (IWRITE,3110) CALL QUARTZ(0) STOP ENDIF C----------------------------------------------------------------------- C error messages C----------------------------------------------------------------------- 110 CONTINUE MX = 1 WRITE (IWRITE,3020) IF (ITC(12).EQ.0) RETURN CALL QUARTZ(0) STOP C 120 CONTINUE WRITE (IWRITE,3030) NP(J),NH(J),NLAST,MXNG CALL QUARTZ(0) STOP C 130 CONTINUE WRITE (IWRITE,3120) CALL QUARTZ(0) STOP C 3000 FORMAT (1X,I2,1X,I2,A2,1P,E17.9,1X,0P,F7.2,F5.1,1P,E10.1,2E10.2,I4! +) 3010 FORMAT (/' >>>> routine SCF called'//12X,'eigenvalue',7X,'Z',5X, ! +'mix',4X,'XCA',6X,'RMAX',6X,'DMAX NPOINT'/) 3020 FORMAT (/' iteration limit exceeded in SCF') 3030 FORMAT (/' STOPPING in SCF for orbitaL ',I2,A2/ ! +' insufficient grid points'/ ! +' trying to extend the table to NLAST = ',I7, ! +' plus 4 which exceeds the dimension set by MXNG = ',I7) 3040 FORMAT (' failure in SCF process for ',I2,A2) 3050 FORMAT (' wrong number of zeros') 3060 FORMAT (' number of iterations exceeded') 3070 FORMAT (' solution cannot be normalised') 3080 FORMAT (' normalised solution has wrong sign') 3090 FORMAT (' no positive eigenvalue') 3100 FORMAT (' matching point is too far out') 3110 FORMAT (' Z increased beyond reasonable limit') 3120 FORMAT (/' STOPPING in SCF - insufficient grid points') END C C ******************* C SUBROUTINE SCORB(NLAST,J,ZA,RA,HA,NA,P1,Q1) C C----------------------------------------------------------------------- C C This routine takes the wavefunction read from dump and C 1. rescales with Z if necessary C 2. interpolates to new grid if necessary C C Routines called : QUAD,ZEFR C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) DOUBLE PRECISION SIX PARAMETER (SIX=6.D0) DOUBLE PRECISION TWF PARAMETER (TWF=24.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C DOUBLE PRECISION HA,P1,Q1,RA DOUBLE PRECISION ZA INTEGER J,NA,NLAST C C Local variables C DOUBLE PRECISION AP,AQ,BN,COP DOUBLE PRECISION COQ,EP,EPA,EPB DOUBLE PRECISION FACQ,FK,FKS,FNR DOUBLE PRECISION GA,HB,HR,R DOUBLE PRECISION RB,S,T,W DOUBLE PRECISION WP,WQ,ZB,ZF DOUBLE PRECISION ZX INTEGER I,IJ,K,L INTEGER NADD,NB,NGRID,NN INTEGER NPOINT,nx C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C integer icut(mxnw) common /nrbcut/icut C C Common variables C double precision fx integer istatx,npmin0 common /nrbinf/fx,istatx,npmin0 C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- FACQ = ONE S = ONE C ZB = Z RB = RNT HB = H NB = N C IF (ABS(ZA-ZB).LT.EPS10) GOTO 10 IF (ITC(21).EQ.1) GOTO 10 C C Z values differ - need to rescale with Z C EPA = EXP(HA) R = RA*RA EP = EPA*EPA DO I = 1,NA TA(I) = R*(P(I)*P(I)+Q(I)*Q(I)) R = R*EP ENDDO C H = HA CALL QUAD(NA,W) H = HB C CALL ZEFR(J,W,ZX) K = NAK(J) NN = NP(J) FK = DBLE(K) FKS = FK*FK ZF = ZB-ZA+ZX FNR = DBLE(NN-ABS(K)) COP = ZF/C COP = COP*COP COQ = SQRT(FKS-COP)+FNR COP = COQ*COQ+COP BN = SQRT(COP) COP = COQ*(COP+COP+COP-FKS)-BN*FK COQ = BN*ZF R = COP/(COQ+COQ) S = W/R FACQ = ZF/ZX GOTO 20 C 10 CONTINUE WP = ONE WQ = ONE NGRID = NA IF (ABS(RA-RB)+ABS(HA-HB).LT.EPS10) GOTO 70 C C Grids differ - need to interpolate. C uses central difference formula. C C 20 CONTINUE GA = GAMA(J) EPB = EPH WP = S**GA WQ = WP*FACQ AP = P(1)*WP AQ = Q(1)*WQ R = RB/RA T = LOG(R*S)/HA HR = HB/HA C DO I = 1,NB C L = INT(T+ONE) IF (L.GT.1) GOTO 30 COP = R**GA PC(I) = AP*COP QC(I) = AQ*COP R = R*EPB GOTO 40 C 30 CONTINUE IF (L.GT.NA) GOTO 50 IF (L.LT.3) L = 3 IF (L.GT.NA-2) L = NA - 2 W = T+ONE-DBLE(L) PC(I) = (W+ONE)*(W-ONE)*(W*((W-TWO)*P(L-2)+(W+TWO)*P(L+2))+SIX*(! +W+TWO)*(W-TWO)*P(L))/TWF-W*(W+TWO)*(W-TWO)*((W-ONE)*P(L-1)+(W+ONE)! +*P(L+1))/SIX QC(I) = FACQ*((W+ONE)*(W-ONE)*(W*((W-TWO)*Q(L-2)+(W+TWO)*Q(L+2))! ++SIX*(W+TWO)*(W-TWO)*Q(L))/TWF-W*(W+TWO)*(W-TWO)*((W-ONE)*Q(L-1)+(! +W+ONE)*Q(L+1))/SIX) 40 CONTINUE T = T+HR C ENDDO C NGRID = NB GOTO 60 C 50 CONTINUE NGRID = I-1 IF (MOD(NGRID,2).EQ.0) THEN NGRID = NGRID+1 PC(NGRID) = ZERO QC(NGRID) = ZERO ENDIF C 60 CONTINUE R = RB DO I = 1,NGRID TA(I) = R*(PC(I)*PC(I)+QC(I)*QC(I)) R = R*EPB ENDDO CALL QUAD(NGRID,W) W = ONE/SQRT(W) DO I = 1,NGRID P(I) = PC(I)*W Q(I) = QC(I)*W ENDDO C----------------------------------------------------------------------- 70 CONTINUE C C Determine cutoff point for the wave-function C DO I = NGRID,1,-1 IF (ABS(P(I)).GT.CUTOFF) GOTO 80 ENDDO WRITE (IWRITE,3010) NP(J),NH(J) WRITE (IPUNCH,3010) NP(J),NH(J) STOP C 80 CONTINUE NPOINT = I c c add buffer space for subsequent formation of new basis in rritz; c extend it radially by a factor fx. c if(np(j).ge.npmin0)then icut(j)=npoint !store real end nx=log(fx)/h nx=nx+mod(nx,2) else nx=0 endif C IF (MOD(NPOINT,2).EQ.0) NPOINT = NPOINT + 1 NADD = 4 c nadd=nadd+nx c IF (NPOINT+NADD.GT.N) NADD = N - NPOINT C IF (NADD.GT.0) THEN DO I = NPOINT+1,NPOINT+NADD P(I) = ZERO Q(I) = ZERO ENDDO NGRID = NPOINT+NADD ELSE NGRID = NPOINT ENDIF C IF (NLAST+NGRID.GT.MXNG) THEN WRITE (IWRITE,3000) NLAST + NGRID,MXNG WRITE (IPUNCH,3000) NLAST + NGRID,MXNG STOP ENDIF C IJ = NLAST+1 DO I = 1,NGRID PF(IJ) = P(I) QF(IJ) = Q(I) IJ = IJ+1 ENDDO PZ(J) = P1*WP QZ(J) = Q1*WQ MPOS(J) = NLAST+1 MPOIN(J) = NGRID NLAST = NLAST+NGRID C 3000 FORMAT (/' Dimension ERROR in routine SCORB'/ ! +' Program is STOPPING'/' You must increase MXNG to at least ',I9, ! +' from the present value of ',I9) 3010 FORMAT (/' Program is STOPPING'/' orbital ',I2,A2, ! +' appears to be zero everywhere') END C C ******************* C SUBROUTINE SETJ(IS,JS,KS,NS,KJ23) C C----------------------------------------------------------------------- C C Sets the tables required by the recoupling coefficient package. C NJSYM. (See P.G.Burke, C.P.C.(1970), Vol.1,P.241) C C This routine loads the common block /ANG00/ with parameters C for the first call of NJSYM involving direct integrals. C Subsequent exchange calls of NJSYM must be C preceeded by a call of MODJ23 to restore these arrays to their C correct initial state. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER MANGM PARAMETER (MANGM=60) INTEGER MTRIAD PARAMETER (MTRIAD=20) INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IS(2,2),JS(2,2),KJ23,KS(2,2) INTEGER NS C C Local variables C INTEGER I,II,IJ,IJ1 INTEGER IJ2,J,NS1,NS2 INTEGER NS3 C C Common variables C INTEGER J1(MANGM),J2(MTRIAD,3) INTEGER J3(MTRIAD,3),MMOM,NMOM LOGICAL FREE(MANGM) COMMON / ANG00 / MMOM,NMOM,J1,J2,J3,FREE C C Common variables C INTEGER JBQ1(3,MXNW),JBQ2(3,MXNW) INTEGER JTQ1(3),JTQ2(3) COMMON / ANG08 / JBQ1,JBQ2,JTQ1,JTQ2 C C Common variables C INTEGER J2S(MTRIAD,3),J3S(MTRIAD,3) COMMON / ANG09 / J2S,J3S C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C 1.0 Set J1 array C C----------------------------------------------------------------------- II = 0 DO IJ = 1,NS I = JLIST(IJ) II = II+1 J1(II) = JBQ1(3,I) ENDDO IF (NS.EQ.1) GOTO 10 NS1 = NS-1 DO I = 1,NS1 II = II+1 J1(II) = JJC1(I) ENDDO DO I = 1,NS1 II = II+1 J1(II) = JJC2(I) ENDDO 10 CONTINUE DO I = 1,2 II = II+1 IJ = IS(I,1) J1(II) = JJQ1(3,IJ) IF (I.EQ.1 .AND. IS(1,1).EQ.IS(2,1)) J1(II) = JTQ1(3) J1(II+4) = KS(I,1) ENDDO DO I = 1,2 II = II+1 IJ = IS(I,2) J1(II) = JJQ2(3,IJ) IF (I.EQ.1 .AND. IS(1,2).EQ.IS(2,2)) J1(II) = JTQ2(3) J1(II+4) = KS(I,2) ENDDO C----------------------------------------------------------------------- C C 2.0 Set J2,J3 arrays if not already available C C----------------------------------------------------------------------- NS2 = MAX(4,NS+2) IF (KJ23.GT.0) GOTO 60 C DO I = 4,NS2 J2(I,1) = NS+I-4 J2(I,2) = I-2 J2(I,3) = NS+I-3 J3(I,1) = J2(I,1)+NS-1 J3(I,2) = I-2 J3(I,3) = J2(I,3)+NS-1 ENDDO J2(4,1) = 1 J3(4,1) = 1 C----------------------------------------------------------------------- C C At this stage, the entries in rows corresponding to active shells C are set incorrectly. C C 3.0 Set rows 1 thro' 3 C C----------------------------------------------------------------------- NS3 = 3*NS J2(1,1) = NS3+5 J2(1,2) = NS3+7 J2(1,3) = NS3+3 J2(2,1) = JS(1,1) J2(2,2) = NS3+3 J2(2,3) = NS3-1 J2(3,1) = JS(2,1) J2(3,2) = NS3+4 J2(3,3) = NS3 C J3(1,1) = NS3+7 J3(1,2) = NS3+4 J3(1,3) = NS3+6 J3(2,1) = JS(1,2) J3(2,2) = NS3+5 J3(2,3) = NS3+1 J3(3,1) = JS(2,2) J3(3,2) = NS3+6 J3(3,3) = NS3+2 C----------------------------------------------------------------------- C C 4.0 Set remaining resultants C C----------------------------------------------------------------------- IJ1 = JS(1,1) IJ2 = JS(2,1) IF (IJ2.GT.1) J2(IJ2+2,2) = J2(3,3) IF (IJ2.EQ.1) J2(4,1) = J2(3,3) IF (IJ1.NE.IJ2) GOTO 20 J2(3,1) = J2(2,3) GOTO 30 C 20 CONTINUE IF (IJ1.GT.1) J2(IJ1+2,2) = J2(2,3) IF (IJ1.EQ.1) J2(4,1) = J2(2,3) C 30 CONTINUE IJ1 = JS(1,2) IJ2 = JS(2,2) IF (IJ2.GT.1) J3(IJ2+2,2) = J3(3,3) IF (IJ2.EQ.1) J3(4,1) = J3(3,3) IF (IJ1.NE.IJ2) GOTO 40 J3(3,1) = J3(2,3) GOTO 50 C 40 CONTINUE IF (IJ1.GT.1) J3(IJ1+2,2) = J3(2,3) IF (IJ1.EQ.1) J3(4,1) = J3(2,3) C----------------------------------------------------------------------- C C All arrays now set. Put up flag KJ23. C C----------------------------------------------------------------------- 50 CONTINUE KJ23 = 1 MMOM = NS3+7 NMOM = NS+3 C----------------------------------------------------------------------- C C 5.0 Save J2,J3 and return C C----------------------------------------------------------------------- DO J = 1,3 DO I = 1,NS2 J2S(I,J) = J2(I,J) J3S(I,J) = J3(I,J) ENDDO ENDDO RETURN C----------------------------------------------------------------------- C C 6.0 Reset J2,J3 from buffers if KJ23 has been set C C----------------------------------------------------------------------- 60 CONTINUE DO J = 1,3 DO I = 1,NS2 J2(I,J) = J2S(I,J) J3(I,J) = J3S(I,J) ENDDO ENDDO C----------------------------------------------------------------------- END C C ******************* C SUBROUTINE SETUP(JA,JB,IWRITE,IBUG2) C C----------------------------------------------------------------------- C C This generates the arrays defining the quantum numbers of the states C involved in the matrix element linking CSFs labelled by JA,JB. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IBUG2,IWRITE,JA,JB C C Local variables C INTEGER I,J,JCNT,JCNTOP INTEGER JW1,JW2,JWW,K C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ICHOP(MXNW,MXNC),IEXC INTEGER JCUP(10,MXNC),JQS(3,MXNW,MXNC) COMMON / ORB06 / JQS,JCUP,ICHOP,IEXC Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (IBUG2.EQ.1) THEN DO J = 1,NCF WRITE (IWRITE,3000) (JCUP(I,J),I=1,10) ENDDO DO J = 1,NCF WRITE (IWRITE,3010) (ICHOP(I,J),I=1,NW) ENDDO ENDIF C----------------------------------------------------------------------- C C List parameters defining all shells in both configurations C whether participating or not. C C----------------------------------------------------------------------- DO J = 1,NW NQ1(J) = IQ(J,JA) NQ2(J) = IQ(J,JB) ENDDO C----------------------------------------------------------------------- DO K = 1,3 DO J = 1,NW JJQ1(K,J) = JQS(K,J,JA) JJQ2(K,J) = JQS(K,J,JB) ENDDO ENDDO C----------------------------------------------------------------------- C C Define coupling schemes C C Set JLIST array to define those shells which are open in C either configuration, and KLIST array to locate the rest. C Exclude shells which are empty in both configurations. C C----------------------------------------------------------------------- NPEEL = 0 NCORE = 0 DO J = 1,NW C IF (ICHOP(J,JA).NE.-1 .OR. ICHOP(J,JB).NE.-1) THEN IF (ICHOP(J,JA).EQ.1 .AND. ICHOP(J,JB).EQ.1) THEN NCORE = NCORE+1 KLIST(NCORE) = J ELSE NPEEL = NPEEL+1 C C Note that in some cases an extra peel orbital is added to C the true peel orbitals. Therefore the dimension check is C against NPLX-1. C IF (NPEEL.GT.NPLX-1) THEN WRITE (IWRITE,3030) JA,JB,NPLX STOP ENDIF JLIST(NPEEL) = J ENDIF ENDIF C ENDDO C----------------------------------------------------------------------- C C Return if not more than one shell is open C C----------------------------------------------------------------------- IF (NPEEL.LE.1) RETURN C----------------------------------------------------------------------- C C Set arrays of coupling angular momenta interpolating C closed shells where necessary. C C Left hand side first ... C C----------------------------------------------------------------------- JCNT = 1 JCNTOP = 0 JW1 = JLIST(1) JW2 = JLIST(2) IF (ICHOP(JW1,JA).EQ.0) THEN JCNTOP = 1 IF (ICHOP(JW2,JA).EQ.0) THEN JJC1(1) = JCUP(JCNT,JA) JCNT = JCNT+1 ELSE JJC1(1) = JQS(3,JW1,JA) ENDIF ELSE JJC1(1) = JQS(3,JW2,JA) IF (ICHOP(JW2,JA).EQ.0) JCNTOP = 1 ENDIF C----------------------------------------------------------------------- IF (NPEEL.GE.3) THEN DO J = 3,NPEEL JWW = JLIST(J) IF (ICHOP(JWW,JA).EQ.0) THEN IF (JCNTOP.EQ.0) THEN JJC1(J-1) = JQS(3,JWW,JA) ELSE JJC1(J-1) = JCUP(JCNT,JA) JCNT = JCNT+1 ENDIF JCNTOP = JCNTOP+1 ELSE JJC1(J-1) = JJC1(J-2) ENDIF ENDDO ENDIF C----------------------------------------------------------------------- IF (IBUG2.EQ.1) THEN WRITE (IWRITE,3020) JCNT,JCNTOP IF (JCNT.GT.1) WRITE (IWRITE,3000) (JCUP(J,JA),J=1,JCNT-1) ENDIF C----------------------------------------------------------------------- C C ... and repeat for right hand side C C----------------------------------------------------------------------- JCNT = 1 JCNTOP = 0 JW1 = JLIST(1) JW2 = JLIST(2) IF (ICHOP(JW1,JB).EQ.0) THEN JCNTOP = 1 IF (ICHOP(JW2,JB).EQ.0) THEN JJC2(1) = JCUP(JCNT,JB) JCNT = JCNT+1 ELSE JJC2(1) = JQS(3,JW1,JB) ENDIF ELSE JJC2(1) = JQS(3,JW2,JB) IF (ICHOP(JW2,JB).EQ.0) JCNTOP = 1 ENDIF C----------------------------------------------------------------------- IF (NPEEL.GE.3) THEN DO J = 3,NPEEL JWW = JLIST(J) IF (ICHOP(JWW,JB).EQ.0) THEN IF (JCNTOP.EQ.0) THEN JJC2(J-1) = JQS(3,JWW,JB) ELSE JJC2(J-1) = JCUP(JCNT,JB) JCNT = JCNT+1 ENDIF JCNTOP = JCNTOP+1 ELSE JJC2(J-1) = JJC2(J-2) ENDIF ENDDO ENDIF C----------------------------------------------------------------------- IF (IBUG2.EQ.1) THEN WRITE (IWRITE,3020) JCNT,JCNTOP IF (JCNT.GT.1) WRITE (IWRITE,3000) (JCUP(J,JB),J=1,JCNT-1) ENDIF C----------------------------------------------------------------------- 3000 FORMAT (' SETUP called JCUP : ',10I4) 3010 FORMAT (' SETUP called ICHOP : ',10I4) 3020 FORMAT (' SETUP called JCNT JCNTOP : ',2I4) 3030 FORMAT (/' ERROR in routine SETUP'/ ! +' Too many peel shells for configurations : ',2I4/ ! +' The present version is limited to NPLX =',I4/ ! +' You must change the parameter NPLX.') END C C ******************* C FUNCTION SKINT(NGRAC,NGRBD,NGRID,RAC,RBD,K,IW) C C----------------------------------------------------------------------- C C This routine evaluates the Breit interaction integrals. C C It calculates the integral S (K; A C / B D :W) C C where W = WAC if IW=1 C = WBD if IW=2 C C Subroutine called: QUAD,YBRA C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION SKINT INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C DOUBLE PRECISION RAC(MXNP),RBD(MXNP) INTEGER IW,K,NGRAC,NGRBD INTEGER NGRID C C Local variables C DOUBLE PRECISION TKEEP(MXNP),VALU,W INTEGER I,KP2 C C Common variables C DOUBLE PRECISION BESSJ(2,2,MXNP),BESSN(2,2,MXNP) DOUBLE PRECISION WIJ(2) COMMON / BESS1 / WIJ,BESSJ,BESSN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- W = WIJ(IW) DO I = 1,NGRAC TA(I) = RAC(I) ENDDO CALL YBRA(NGRAC,K) DO I = 1,NGRAC TKEEP(I) = TB(I) TA(I) = -TA(I)*BESSJ(1,IW,I) ENDDO CALL YBRA(NGRAC,K) C C The following subtraction is CRITICAL and must be accurate to C order W**2 to obtain correct results. C (See comments in long write up) C DO I = 1,NGRID TA(I) = ((ONE+BESSN(2,IW,I))*TB(I)-TKEEP(I)*BESSN(2,IW,I))*RBD(I! +)/RGRID(I) ENDDO CALL QUAD(NGRID,VALU) SKINT = (((K+K+1)/W)**2)*VALU C DO I = 1,NGRBD TA(I) = RBD(I)*(ONE+BESSJ(2,IW,I)) ENDDO KP2 = K+2 CALL YBRA(NGRBD,KP2) DO I = 1,NGRID TA(I) = RAC(I)*(ONE+BESSN(1,IW,I))*TB(I)*RGRID(I)**3 ENDDO CALL QUAD(NGRID,VALU) CPN CPN Fixed bug here CPN SKINT = SKINT-VALU*W*W/((K+K+3)*(K+K-1)) C END C C ******************* C SUBROUTINE SKRCG(IS,KAPS,KS,KD1,KD2,KE1,KE2) C C----------------------------------------------------------------------- C C Determines the range of the tensor rank K for coulomb integral. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Argument variables C INTEGER IS(4),KAPS(4),KD1,KD2 INTEGER KE1,KE2,KS(4) C C Local variables C INTEGER ISD1,ISD2,ISE1,ISE2 INTEGER KD1A,KD1B,KD2A,KD2B INTEGER KE1A,KE1B,KE2A,KE2B Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- KD2 = 0 KE2 = 0 C C Direct terms - KD1=minimum K , KD2=number of terms C ISD1 = 1 IF (KAPS(1)*KAPS(3).LT.0) ISD1 = -1 ISD2 = 1 IF (KAPS(2)*KAPS(4).LT.0) ISD2 = -1 KD1A = ABS(KS(1)-KS(3)) IF (ISD1.LT.0) KD1A = KD1A + 2 KD1B = ABS(KS(2)-KS(4)) IF (ISD2.LT.0) KD1B = KD1B + 2 IF (MOD((KD1A-KD1B)/2,2).NE.0) GOTO 10 KD2A = KS(1)+KS(3)-2 IF (ISD1.GT.0) KD2A = KD2A - 2 KD2B = KS(2)+KS(4)-2 IF (ISD2.GT.0) KD2B = KD2B - 2 KD1 = MAX(KD1A,KD1B)/2 KD2 = MIN(KD2A,KD2B)/2 KD2 = (KD2-KD1)/2+1 C C Exchange terms - KE1=minimum K , KE2=number of terms C 10 CONTINUE IF (IS(1).EQ.IS(2) .OR. IS(3).EQ.IS(4)) RETURN ISE1 = 1 IF (KAPS(1)*KAPS(4).LT.0) ISE1 = -1 ISE2 = 1 IF (KAPS(2)*KAPS(3).LT.0) ISE2 = -1 KE1A = ABS(KS(1)-KS(4)) IF (ISE1.LT.0) KE1A = KE1A + 2 KE1B = ABS(KS(2)-KS(3)) IF (ISE2.LT.0) KE1B = KE1B + 2 IF (MOD((KE1A-KE1B)/2,2).NE.0) RETURN KE2A = KS(1)+KS(4)-2 IF (ISE1.GT.0) KE2A = KE2A - 2 KE2B = KS(2)+KS(3)-2 IF (ISE2.GT.0) KE2B = KE2B - 2 KE1 = MAX(KE1A,KE1B)/2 KE2 = MIN(KE2A,KE2B)/2 KE2 = (KE2-KE1)/2+1 C END C C ******************* C FUNCTION SLATER(IA,IB,IC,ID,K) C C----------------------------------------------------------------------- C C The value of this function is the Slater integral C as normally defined in terms of the four sets of C quantum numbers A,B,C,D. C C Subroutines called : YZK, QUAD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION SLATER INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER IA,IB,IC,ID INTEGER K C C Local variables C DOUBLE PRECISION RESULT INTEGER I,IIA,IIB,IIC INTEGER IID,NGRID C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Tabulate integrand for computation of YK(R) C NGRID = MIN(MPOIN(IB),MPOIN(ID)) IIB = MPOS(IB) IID = MPOS(ID) DO I = 1,NGRID TA(I) = RGRID(I)*(PF(IIB)*PF(IID)+QF(IIB)*QF(IID)) IIB = IIB+1 IID = IID+1 ENDDO C C tabulate YK(R) C CALL YZK(NGRID,K) C C multiply by second term, and obtain result by integration C NGRID = MIN(MPOIN(IA),MPOIN(IC)) IIA = MPOS(IA) IIC = MPOS(IC) DO I = 1,NGRID TA(I) = (PF(IIA)*PF(IIC)+QF(IIA)*QF(IIC))*TB(I) IIA = IIA+1 IIC = IIC+1 ENDDO C CALL QUAD(NGRID,RESULT) SLATER = RESULT C IF (ITC(26).EQ.1) THEN WRITE (IWRITE,3000) NP(IA),NH(IA),NP(IB),NH(IB),NP(IC),NH(IC),NP! +(ID),NH(ID),K,SLATER ENDIF C 3000 FORMAT (' R (',I2,A2,',',I2,A2,',',I2,A2,',',I2,A2,';',I2,') = ',1! +P,E17.9) END C C ******************* C SUBROUTINE SNRC(IS,KAPS,KS,ID1,ID2,NE1,NE2,IBRD,IBRE) C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Argument variables C INTEGER IBRD,IBRE,ID1,ID2 INTEGER IS(4),KAPS(4),KS(4),NE1 INTEGER NE2 C C Local variables C INTEGER IAC,IAD,ID1A,ID2A INTEGER NE1A,NE2A Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- ID2 = 0 NE2 = 0 C IAC = 1 IF ((KAPS(1)*KAPS(3)).LT.0) IAC = -1 C IAD = 1 IF ((KAPS(2)*KAPS(4)).LT.0) IAD = -1 C ID1 = ABS(KS(1)-KS(3))/2-1 IF (IAC.EQ.-1) ID1 = ID1 + 1 IF (ID1.EQ.-1) ID1 = 1 ID1A = ABS(KS(2)-KS(4))/2-1 IF (IAD.EQ.-1) ID1A = ID1A + 1 IF (ID1A.EQ.-1) ID1A = 1 C IF (MOD(ID1-ID1A,2).EQ.0) GOTO 10 C IBRD = -1 GOTO 20 C 10 CONTINUE ID2 = ABS(KS(1)+KS(3))/2 IF (IAC.EQ.-1) ID2 = ID2 + 1 ID2A = ABS(KS(2)+KS(4))/2 IF (IAD.EQ.-1) ID2A = ID2A + 1 ID1 = MAX(ID1,ID1A) ID2 = MIN(ID2,ID2A) ID2 = (ID2-ID1)/2+1 IBRD = 1 IF (IS(1).EQ.IS(3) .AND. IS(2).NE.IS(4)) IBRD = 2 IF (IS(1).NE.IS(3) .AND. IS(2).EQ.IS(4)) IBRD = 2 IF (IS(1).EQ.IS(3) .AND. IS(2).EQ.IS(4)) IBRD = 3 C 20 CONTINUE IF (IS(1).NE.IS(2) .AND. IS(3).NE.IS(4)) GOTO 30 IBRE = -1 RETURN C 30 CONTINUE IAC = 1 IF ((KAPS(1)*KAPS(4)).LT.0) IAC = -1 IAD = 1 IF ((KAPS(2)*KAPS(3)).LT.0) IAD = -1 C NE1 = ABS(KS(1)-KS(4))/2-1 IF (IAC.EQ.-1) NE1 = NE1 + 1 IF (NE1.EQ.-1) NE1 = 1 NE1A = ABS(KS(2)-KS(3))/2-1 IF (IAD.EQ.-1) NE1A = NE1A + 1 IF (NE1A.EQ.-1) NE1A = 1 C IF (MOD(NE1-NE1A,2).EQ.0) GOTO 40 C IBRE = -1 RETURN C 40 CONTINUE NE2 = ABS(KS(1)+KS(4))/2 IF (IAC.EQ.-1) NE2 = NE2 + 1 NE2A = ABS(KS(2)+KS(3))/2 IF (IAD.EQ.-1) NE2A = NE2A + 1 NE1 = MAX(NE1,NE1A) NE2 = MIN(NE2,NE2A) NE2 = (NE2-NE1)/2+1 IBRE = 1 IF (IS(1).EQ.IS(4) .AND. IS(2).NE.IS(3)) IBRE = 2 IF (IS(1).NE.IS(4) .AND. IS(2).EQ.IS(3)) IBRE = 2 IF (IS(1).EQ.IS(3) .AND. IS(2).EQ.IS(4)) IBRE = 4 C END C C ******************* C SUBROUTINE SOLV0(JORB,VN,XCF,ALX,ALY,AST,EST,MX,HIACC,NPOINT) C C----------------------------------------------------------------------- C C **** New version of SOLV **** C C This subroutine solves a single pair of Dirac radial equations. C The direct potentials are tabulated in YP and YQ. C The exchange potentials are tabulated in XTP and XTQ. C C DATA C C JORB serial number of wave function C VN coefficient of R in expansion of direct potential C XCF scale factor multiplying exchange term C ALX leading coefficient in series expansion of exchange (P) C ALY leading coefficient in series expansion of exchange (Q) C AST estimate of A. C EST estimate of eigenvalue E. C HIACC a logical variable which is set .TRUE. if higher order C terms are to be included in the deferred correction, to C give an error which varies as O(H**6). C C RESULTS C C MX should be zero. A non-zero value indicates failure. C E(JORB) the eigenvalue C NPOINT number of points in wave-function C C The wave functions will be tabulated in arrays P and Q. C Coefficients in series expansions are stored in PZ(JORB), QZ(JORB). C C Subroutines called : PRWF, SOLV1, OUT, IN, QUAD C C----------------------------------------------------------------------- C C maximum number of iterations is set here C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION CSOLV1 PARAMETER (CSOLV1=0.3D0) DOUBLE PRECISION CSOLV2 PARAMETER (CSOLV2=1.D2) DOUBLE PRECISION X1 PARAMETER (X1=1.D0/12.D0) DOUBLE PRECISION X2 PARAMETER (X2=-.25D0) DOUBLE PRECISION X3 PARAMETER (X3=-1.D0/120.D0) DOUBLE PRECISION X4 PARAMETER (X4=0.125D0) DOUBLE PRECISION X5 PARAMETER (X5=-1.D0/3.D0) INTEGER N11 PARAMETER (N11=MXNP+10) INTEGER NFMAX PARAMETER (NFMAX=25) C C Argument variables C DOUBLE PRECISION ALX,ALY,AST,EST DOUBLE PRECISION VN,XCF INTEGER JORB,MX,NPOINT LOGICAL HIACC C C Local variables C DOUBLE PRECISION ACL,DLA,DLE,ECL DOUBLE PRECISION FKJ,HH,QCJP,QEJP DOUBLE PRECISION QJP,QZE,WA,WAC DOUBLE PRECISION WB,WBC,WC,WCA DOUBLE PRECISION WCB,WD,WEA,WEB DOUBLE PRECISION WXA,WXB,WXY DOUBLE PRECISION XTPT(MXNP),XTQT(MXNP),YPT(MXNP) DOUBLE PRECISION YQT(MXNP) INTEGER I,IJ,JP,JPX INTEGER KJ,M,MAE,MAU INTEGER MF,NGRID,NODE,NODES INTEGER NTF C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP) DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP) COMMON / INT3 / XU,XV,XR,XS,XF,XG C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Use SOLV1 for the non-exchange case C ----------------------------------- C IF (XCF.LE.ZERO) THEN CALL SOLV1(JORB,VN,XCF,AST,EST,MX,HIACC,XTPT,XTQT,YPT,YQT,NPOINT! +) GOTO 100 ENDIF C NGRID = MPOIN(JORB) IF (ITC(19).EQ.1) WRITE (IWRITE,3020) NP(JORB),NH(JORB),VN,XCF,ALX! +,ALY,AST,EST,Z,NGRID C NPOINT = NGRID KJ = NAK(JORB) FKJ = DBLE(KJ) C C NODES is the number of zeros required in P(R) C IF (KJ.LT.0) THEN NODES = NP(JORB)+KJ ELSE NODES = NP(JORB)-KJ-1 ENDIF C MAU = 0 C C Begin from given estimates of A and E C ACL = AST ECL = EST C C Count iterations in NTF C NTF = NFMAX+1 C HH = -H*HALF WA = -FKJ*HH WAC = ONE+WA WBC = ONE-WA C C Tabulate modified direct potentials C =================================== C Clear exchange potential arrays C WD = HH/C DO I = 1,NGRID XTPT(I) = ZERO XTQT(I) = ZERO YPT(I) = WD*YP(I) YQT(I) = WD*YQ(I) ENDDO C C Set the P and Q arrays to zero for I>NGRID C IF (NGRID+2.LE.MXNP) THEN DO I = NGRID+1,NGRID+2 P(I) = ZERO Q(I) = ZERO ENDDO ELSE WRITE (IWRITE,3040) NGRID,MXNP WRITE (IPUNCH,3040) NGRID,MXNP STOP ENDIF C IJ = MPOS(JORB) DO I = 1,NGRID P(I) = PF(IJ) Q(I) = QF(IJ) IJ = IJ+1 ENDDO C C Tabulate modified exchange terms, including difference corrections C ================================ C IF (.NOT.HIACC) THEN C C The orbitals are still changing considerably, so use the C standard formula for the deferred correction. C DO I = 4,NGRID+1 XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X1*(P(I-3)-P(I))+X2*(P(I-2)! +-P(I-1)) XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X1*(Q(I-3)-Q(I))+X2*(Q(I-2)! +-Q(I-1)) ENDDO C ELSE C C When the orbitals are not changing significantly add the C corrections to give an error of O(H**6). C DO I = 5,NGRID+1 XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X3*(P(I-4)-P(I+1))+X4*(P(I-! +3)-P(I))+X5*(P(I-2)-P(I-1)) XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X3*(Q(I-4)-Q(I+1))+X4*(Q(I-! +3)-Q(I))+X5*(Q(I-2)-Q(I-1)) ENDDO ENDIF C C Begin iterations C ---------------- C If number of iterations exceeds NFMAX, return with failure -1 C 10 CONTINUE NTF = NTF-1 IF (NTF.EQ.0) THEN MX = -1 GOTO 100 ENDIF C C Copy exchange terms into working space C NGRID = MPOIN(JORB) DO I = 1,NGRID XU(I) = XTPT(I) XV(I) = XTQT(I) ENDDO C C Tabulate functions XF(R) and XG(R) C WC = HH*ECL/C WB = -H*C-WC JP = NGRID-2 DO I = 1,NGRID XF(I) = RGRID(I)*WB+YPT(I) XG(I) = RGRID(I)*WC-YQT(I) ENDDO C C Choose new estimate of A, if negative C IF (ACL.LE.ZERO) ACL = CSOLV2*ABS(FKJ) C C Print estimates of A and E, if option 19 is set C IF (ITC(19).EQ.1) WRITE (IWRITE,3010) NP(JORB),NH(JORB),ACL,ECL C C Outward integration C CALL OUT(NODES,JORB,VN,ACL,QZE,ALX,ALY,ECL,0,JP,M,MAU,MAE) C IF (M.EQ.2) THEN MX = 9 GOTO 100 ENDIF C MAU = MAE QJP = Q(JP) C C Inward integration - determines endpoint of integration C Return with failure 9 if inward integration fails C MF = 0 CALL IN(JORB,JP,MF,WAC,WBC) C IF (MF.LT.0) THEN MX = 9 GOTO 100 ENDIF C C Store results of trial integration C Note that MF is the last point - use this value for NGRID C NGRID = MF DO I = 1,NGRID PC(I) = P(I) QC(I) = Q(I) ENDDO C C Evaluate discrepancy between outward and inward integrations C and exit if accurate solution is obtained C DO I = 1,NGRID TA(I) = (P(I)*PC(I)+Q(I)*QC(I))*RGRID(I) ENDDO WXA = Q(JP)-QJP CALL QUAD(NGRID,WXB) IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QJP,Q(JP),! +WXA,WXB C WA = ABS(WXA*C)+ABS(WXB-ONE) IF (WA.LT.ACCY) GOTO 60 C C Set exchange terms to zero C DO I = 1,NGRID XU(I) = ZERO XV(I) = ZERO ENDDO C C Outward and inward integration for homogeneous equations C CALL OUT(NODES,JORB,VN,ACL,WA,ZERO,ZERO,ECL,JP,JP,M,MAE,MAE) QCJP = Q(JP) CALL IN(JORB,JP,MF,WAC,WBC) C DO I = 1,NGRID TA(I) = (P(I)*PC(I)+Q(I)*QC(I))*RGRID(I) ENDDO WCA = Q(JP)-QCJP CALL QUAD(NGRID,WCB) IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QCJP,Q(JP)! +,WCA,WCB C C Compute multiple of complementary function required C to give correctly normalised solution C DO I = 1,NGRID TA(I) = RGRID(I)*(P(I)*P(I)+Q(I)*Q(I)) ENDDO CALL QUAD(NGRID,WXY) WB = WCB*WCB-WXY*(WXB-ONE) C C Return with failure 1 if impossible to normalise solution C IF (WB.LE.ZERO) THEN MX = 1 GOTO 100 ENDIF C WB = SQRT(WB) IF (WCB.LE.ZERO) WB = -WB WA = -(WCB-WB)/WXY C C Return with failure 2 if normalised solution has wrong sign C IF (WA+ONE.LE.ZERO) THEN MX = 2 GOTO 100 ENDIF C C Add required multiple of complementary functions to trial solution C ACL = ACL*(ONE+WA) DO I = 1,NGRID PC(I) = PC(I)+WA*P(I) QC(I) = QC(I)+WA*Q(I) ENDDO WXA = WXA+WA*WCA IF (ITC(17).EQ.1) WRITE (IWRITE,3000) NP(JORB),NH(JORB),WA,WXA,WB,! +ACL,WXY C C Tabulate right hand side for variation equations C WA = HH/C DO I = 1,NGRID XU(I) = QC(I)*WA*RGRID(I) XV(I) = -PC(I)*WA*RGRID(I) ENDDO DO I = 2,NGRID XU(I-1) = XU(I)+XU(I-1) XV(I-1) = XV(I)+XV(I-1) ENDDO WB = QZE/C WC = -ACL/C C C Outward and inward integration for variation equations C CALL OUT(NODES,JORB,VN,ZERO,WA,WB,WC,ECL,JP,JP,M,MAE,MAE) QEJP = Q(JP) CALL IN(JORB,JP,MF,WAC,WBC) C DO I = 1,NGRID TA(I) = (P(I)*PC(I)+Q(I)*QC(I))*RGRID(I) ENDDO WEA = Q(JP)-QEJP CALL QUAD(NGRID,WEB) IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QEJP,Q(JP)! +,WEA,WEB C C Compute corrections to parameters A and E C DLA = WEB*WXA/(WEA*WCB-WEB*WCA) DLE = -WCB*DLA/WEB C C Reduce correction to A if too large C 20 CONTINUE IF (ABS(DLA).LT.CSOLV1) GOTO 30 DLA = DLA*HALF GOTO 20 C 30 CONTINUE ACL = ACL*(ONE+DLA) C C Reduce correction to E if too large C 40 CONTINUE IF (ABS(DLE/ECL).LT.CSOLV1) GOTO 50 DLE = DLE*HALF GOTO 40 C 50 CONTINUE ECL = ECL+DLE C C Repeat cycle with new estimates of A and E C GOTO 10 C C Normal exit from SOLV C --------------------- C 60 CONTINUE C C Normalise the solution C WB = ONE/SQRT(WXB) DO I = 1,NGRID P(I) = P(I)*WB Q(I) = Q(I)*WB ENDDO C C Print table of solution if option 16 requested C IF (ITC(16).EQ.1) CALL PRWF(JORB) C C Count number of zeros in table of P(R) C NODE = 0 JPX = JP+4 DO I = 3,JPX IF (P(I-1)*P(I-2)) 80,70,90 70 CONTINUE IF (P(I)*P(I-2)) 80,90,90 80 CONTINUE NODE = NODE+1 90 CONTINUE ENDDO C C Failure number -2 if wrong number of zeros C IF (NODE.NE.NODES) THEN MX = -2 GOTO 100 ENDIF C C Normal return, storing results C E(JORB) = ECL PZ(JORB) = ACL QZ(JORB) = QZE MX = 0 NPOINT = NGRID C IF (NGRID.LT.MPOIN(JORB)) THEN DO I = NGRID+1,MPOIN(JORB) P(I) = ZERO Q(I) = ZERO ENDDO ENDIF C 100 CONTINUE IF (ITC(19).EQ.1) THEN IF (MX.EQ.-2) WRITE (IWRITE,3060) NP(JORB),NH(JORB) IF (MX.EQ.-1) WRITE (IWRITE,3070) NP(JORB),NH(JORB) IF (MX.EQ.1) WRITE (IWRITE,3080) NP(JORB),NH(JORB) IF (MX.EQ.2) WRITE (IWRITE,3090) NP(JORB),NH(JORB) IF (MX.EQ.3) WRITE (IWRITE,3100) NP(JORB),NH(JORB) IF (MX.EQ.4) WRITE (IWRITE,3110) NP(JORB),NH(JORB) IF (MX.EQ.9) WRITE (IWRITE,3120) NP(JORB),NH(JORB) IF (MX.EQ.0) WRITE (IWRITE,3050) NP(JORB),NH(JORB) ENDIF C 3000 FORMAT (' SOLV17 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3010 FORMAT (' SOLV19 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3020 FORMAT (' SOLV19 ',I2,A2,2X,1P,4E12.4/' ',3E12.4,! +I5) 3030 FORMAT (' MATCH17 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3040 FORMAT (/ ! +' STOPPING in SOLV0 due to a dimension ERROR for the grid points'/! +' The number required is ',I4,' plus 2 which exceeds MXNP = ',I4) 3050 FORMAT (' SOLV19 ',I2,A2,' success') 3060 FORMAT (' SOLV19 ',I2,A2,' failure : wrong number of zeros') 3070 FORMAT (' SOLV19 ',I2,A2, ! +' failure : number of iterations exceeded') 3080 FORMAT (' SOLV19 ',I2,A2, ! +' failure : solution cannot be normalised') 3090 FORMAT (' SOLV19 ',I2,A2, ! +' failure : normalised solution has wrong sign') 3100 FORMAT (' SOLV19 ',I2,A2,' failure : no positive eigenvalue') 3110 FORMAT (' SOLV19 ',I2,A2, ! +' failure : matching point is too far out') 3120 FORMAT (' SOLV19 ',I2,A2,' failure : insufficient grid points') END C C ******************* C SUBROUTINE SOLV1(JORB,VN,XCF,AST,EST,MX,HIACC,XTPT,XTQT,YPT,YQT,NP! +OINT) C C----------------------------------------------------------------------- C C **** New version of SOLV **** C **** No exchange case **** C C This subroutine solves a single pair of Dirac radial equations. C The direct potentials are tabulated in YP and YQ. C The exchange potentials are tabulated in XTP and XTQ. C C DATA C C JORB serial number of wave function C VN coefficient of R in expansion of direct potential C XCF scale factor multiplying exchange term C AST estimate of A. C EST estimate of eigenvalue E. C HIACC a logical variable which is set .TRUE. if higher order C terms are to be included in the deferred correction, to C give an error which varies as O(H**6). C C RESULTS C C MX should be zero. A non-zero value indicates failure. C E(JORB) the eigenvalue C NPOINT number of points in wave-function C C The wave functions will be tabulated in arrays P and Q. C Coefficients in series expansions are stored in PZ(JORB), QZ(JORB). C C Subroutines called : PRWF, OUT, IN, QUAD C C----------------------------------------------------------------------- C C maximum number of iterations is set here C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION CSOLV1 PARAMETER (CSOLV1=0.3D0) DOUBLE PRECISION CSOLV2 PARAMETER (CSOLV2=1.D2) DOUBLE PRECISION X1 PARAMETER (X1=1.D0/12.D0) DOUBLE PRECISION X2 PARAMETER (X2=-.25D0) DOUBLE PRECISION X3 PARAMETER (X3=-1.D0/120.D0) DOUBLE PRECISION X4 PARAMETER (X4=0.125D0) DOUBLE PRECISION X5 PARAMETER (X5=-1.D0/3.D0) DOUBLE PRECISION EPS5 PARAMETER (EPS5=1.D-5) INTEGER N11 PARAMETER (N11=MXNP+10) INTEGER NFMAX PARAMETER (NFMAX=25) C C Argument variables C DOUBLE PRECISION AST,EST,VN,XCF DOUBLE PRECISION XTPT(MXNP),XTQT(MXNP),YPT(MXNP) DOUBLE PRECISION YQT(MXNP) INTEGER JORB,MX,NPOINT LOGICAL HIACC C C Local variables C DOUBLE PRECISION ACL,DLE,ECL,EHG DOUBLE PRECISION ELW,FKJ,HH,QJP DOUBLE PRECISION QZE,WA,WAC,WB DOUBLE PRECISION WBC,WC,WD,WXA DOUBLE PRECISION WXB INTEGER I,IJ,JP,JPX INTEGER KJ,M,MAE,MF INTEGER NGRID,NODE,NODES,NTF C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP) DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP) COMMON / INT3 / XU,XV,XR,XS,XF,XG C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NGRID = MPOIN(JORB) IF (ITC(19).EQ.1) WRITE (IWRITE,3020) NP(JORB),NH(JORB),VN,XCF,AST! +,EST,Z,NGRID C NPOINT = NGRID KJ = NAK(JORB) FKJ = DBLE(KJ) C C NODES is the number of zeros required in P(R) C IF (KJ.LT.0) THEN NODES = NP(JORB)+KJ ELSE NODES = NP(JORB)-KJ-1 ENDIF C C Begin from given estimates of A and E C ACL = AST ECL = EST C C Count iterations in NTF C NTF = NFMAX+1 C ELW = -ONE EHG = -ONE C HH = -H*HALF WA = -FKJ*HH WAC = ONE+WA WBC = ONE-WA C C Tabulate modified direct potentials C =================================== C Clear exchange potential arrays C WD = HH/C DO I = 1,NGRID XTPT(I) = ZERO XTQT(I) = ZERO YPT(I) = WD*YP(I) YQT(I) = WD*YQ(I) ENDDO C C Include difference corrections for XCF=0 C ============================== C IF (XCF.EQ.ZERO) THEN C C Set the P and Q arrays to zero for I.GT.NGRID C IF (NGRID+2.LE.MXNP) THEN DO I = NGRID+1,NGRID+2 P(I) = ZERO Q(I) = ZERO ENDDO ELSE WRITE (IWRITE,3040) NGRID,MXNP WRITE (IPUNCH,3040) NGRID,MXNP STOP ENDIF C IJ = MPOS(JORB) DO I = 1,NGRID P(I) = PF(IJ) Q(I) = QF(IJ) IJ = IJ+1 ENDDO C C Tabulate modified exchange terms, including difference corrections C ================================ C IF (.NOT.HIACC) THEN C C The orbitals are still changing considerably, so use the C standard formula for the deferred correction. C DO I = 4,NGRID+1 XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X1*(P(I-3)-P(I))+X2*(P(I-! +2)-P(I-1)) XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X1*(Q(I-3)-Q(I))+X2*(Q(I-! +2)-Q(I-1)) ENDDO C ELSE C C When the orbitals are not changing significantly add the C corrections to give an error of O(h**6). C DO I = 5,NGRID+1 XTPT(I-2) = HH*(XTP(I-1)+XTP(I-2))+X3*(P(I-4)-P(I+1))+X4*(P(! +I-3)-P(I))+X5*(P(I-2)-P(I-1)) XTQT(I-2) = HH*(XTQ(I-1)+XTQ(I-2))+X3*(Q(I-4)-Q(I+1))+X4*(Q(! +I-3)-Q(I))+X5*(Q(I-2)-Q(I-1)) ENDDO C ENDIF C ENDIF C C Begin iterations C ---------------- C If number of iterations exceeds NFMAX, return with failure -1 C 10 CONTINUE NTF = NTF-1 IF (NTF.EQ.0) THEN MX = -1 RETURN ENDIF C C Copy exchange terms into working space C NGRID = MPOIN(JORB) DO I = 1,NGRID XU(I) = XTPT(I) XV(I) = XTQT(I) ENDDO C C Tabulate functions XF(R) and XG(R) C WC = HH*ECL/C WB = -H*C-WC JP = NGRID-2 DO I = 1,NGRID XF(I) = RGRID(I)*WB+YPT(I) XG(I) = RGRID(I)*WC-YQT(I) ENDDO C C Choose new estimate of A, if negative C IF (ACL.LE.ZERO) ACL = CSOLV2*ABS(FKJ) C C Print estimates of A and E, if option 19 is set C IF (ITC(19).EQ.1) WRITE (IWRITE,3010) NP(JORB),NH(JORB),ACL,ECL C C Outward integration C CALL OUT(NODES,JORB,VN,ACL,QZE,ZERO,ZERO,ECL,0,JP,M,0,MAE) C C Test for failure C IF (M.LT.0) THEN C C Store low eigenvalue estimate C ELW = ECL IF (EHG+HALF.LE.ZERO) THEN C C If no high estimate available, use double the low estimate C ECL = ECL+ECL C ELSE C C Bisection if two estimates available C ECL = HALF*(ELW+EHG) ENDIF C GOTO 10 C ELSE IF (M.GT.0) THEN C C Store high estimate C EHG = ECL C C Failure number 3 if no positive eigenvalue C IF (ECL.LT.EPS5) THEN MX = 3 RETURN C ELSE IF (ELW+HALF.LE.ZERO) THEN C C If no low estimate available, use zero C ECL = ZERO C ELSE C C Bisection if two estimates available C ECL = HALF*(ELW+EHG) ENDIF C ENDIF C GOTO 10 C ENDIF C ENDIF C C Inward integration - determines endpoint of integration C ------------------ C Return with failure 9 if inward integration fails C QJP = Q(JP) MF = 0 CALL IN(JORB,JP,MF,WAC,WBC) IF (MF.LT.0) THEN MX = 9 RETURN ENDIF C C Note that MF is the last point - use this value for NGRID C NGRID = MF DO I = 1,NGRID TA(I) = (P(I)*P(I)+Q(I)*Q(I))*RGRID(I) ENDDO WXA = Q(JP)-QJP CALL QUAD(NGRID,WXB) IF (ITC(17).EQ.1) WRITE (IWRITE,3030) NP(JORB),NH(JORB),QJP,Q(JP),! +WXA,WXB C C Accept if sufficiently good fit C WA = ABS(WXA*C)+ABS(WXB-ONE) IF (WA.GT.ACCY) THEN C C Repeat cycle with corrected values of A and E C DLE = C*P(JP)*WXA/WXB ACL = ACL/SQRT(WXB) IF (ITC(18).EQ.1) WRITE (IWRITE,3000) NP(JORB),NH(JORB),DLE C C Reduce correction to E if too large C 20 CONTINUE IF (ABS(DLE/ECL).LT.CSOLV1) GOTO 30 DLE = DLE*HALF GOTO 20 C 30 CONTINUE IF (DLE.GT.ZERO) ELW = ECL IF (DLE.LT.ZERO) EHG = ECL ECL = ECL+DLE C C Repeat cycle with new estimates of A and E C GOTO 10 C ENDIF C C Normal exit from SOLV C --------------------- C C Normalise the solution C WB = ONE/SQRT(WXB) DO I = 1,NGRID P(I) = P(I)*WB Q(I) = Q(I)*WB ENDDO C C Print table of solution if option 16 requested C IF (ITC(16).EQ.1) CALL PRWF(JORB) C C Count number of zeros in table of P(R) C NODE = 0 JPX = JP+4 DO I = 3,JPX IF (P(I-1)*P(I-2)) 50,40,60 40 CONTINUE IF (P(I)*P(I-2)) 50,60,60 50 CONTINUE NODE = NODE+1 60 CONTINUE ENDDO C C FAILURE NUMBER -2 IF WRONG NUMBER OF ZEROS C IF (NODE.NE.NODES) THEN MX = -2 RETURN C ENDIF C C NORMAL RETURN, STORING RESULTS C E(JORB) = ECL PZ(JORB) = ACL QZ(JORB) = QZE MX = 0 NPOINT = NGRID C IF (NGRID.LT.MPOIN(JORB)) THEN DO I = NGRID+1,MPOIN(JORB) P(I) = ZERO Q(I) = ZERO ENDDO ENDIF C 3000 FORMAT (' *SOLV18 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3010 FORMAT (' *SOLV19 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3020 FORMAT (' *SOLV19 ',I2,A2,2X,1P,2E12.4,24X/' ',3E1! +2.4,I5) 3030 FORMAT (' MATCH17 ',I2,A2,2X,1P,4E12.4/' ',4E12.4) 3040 FORMAT (/ ! +' STOPPING in SOLV1 due to a dimension error for the grid points'/! +' The number required is ',I4,' plus 2 which exceeds MXNP = ',I4) END C C ******************* C SUBROUTINE SPEAKG(IMARK,ITYPE,IIA,IIB,IIC,IID,K,COEF) C C----------------------------------------------------------------------- C C Output MCP/MCBP coefficients to file on stream NOUT1 if NOUT1 > 0. C Also print these if IBUG1=1. C C ITYPE=1 to 6 .... Breit integrals C C ITYPE=7 one-electron integrals C ITYPE=8 direct Slater integrals C ITYPE=9 exchange Slater integrals C C If ITYPE<0 then the integral is part of the core contribution C i.e. only stored for the first CSF and must be included for others. C C If IMARK=1 then integral belongs to core/peel or core/core. C C SPEAKG C RAT1 C C Common block ANG02: C Elements used but never set: all C Common block ANG04: C Elements used but never set: JA JB NWA C Common block DEBUG: C Elements used but never set: IBUG1 C Elements never used, never set: IBUG2 IBUG3 IBUG4 IBUG5 IBUG6 C Common block INFORM: C Elements used but never set: IWRITE IPUNCH C Elements never used, never set: IREAD C Common block ORB00: C Elements used but never set: all C Common block ORB04: C Elements used but never set: NP C Elements never used, never set: NW NCF NAK IQ C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) C C Argument variables C DOUBLE PRECISION COEF INTEGER IIA,IIB,IIC,IID INTEGER IMARK,ITYPE,K C C Local variables C INTEGER IA,IB,IC,ID INTEGER IRAT(4),ISTORE,ITY,MODE INTEGER XA,XB,XC,XD C C Common variables C INTEGER NOUT1 COMMON / ANG02 / NOUT1 C C Common variables C INTEGER ITOT(9),JTOT(9),KTOT(9) COMMON / ANG03 / ITOT,JTOT,KTOT C C Common variables C INTEGER IME,JA,JB,NWA COMMON / ANG04 / IME,JA,JB,NWA C C Common variables C INTEGER IBUG1,IBUG2,IBUG3,IBUG4 INTEGER IBUG5,IBUG6 COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (ABS(COEF).LT.EPS10) RETURN C IA = IIA IB = IIB IC = IIC ID = IID C IF (ITYPE.LT.0) THEN ITY = ABS(ITYPE) JTOT(ITY) = JTOT(ITY)+1 ELSE ITOT(ITYPE) = ITOT(ITYPE)+1 ENDIF C----------------------------------------------------------------------- C C Breit angular coefficients C IF (ABS(ITYPE).LE.6) THEN C ISTORE = (((K*NWA+IA)*NWA+IB)*NWA+IC)*NWA+ID IF (NOUT1.GT.0) WRITE (NOUT1) ISTORE,ITYPE,COEF C IF (IBUG1.EQ.1) THEN C WRITE (IWRITE,3000) JA,JB,NP(IA),NH(IA),NP(IB),NH(IB),NP(IC),N! +H(IC),NP(ID),NH(ID),K,COEF,ISTORE,ITYPE IME = IME+1 C CALL RAT1(COEF,IRAT) C XA = IRAT(1) XB = IRAT(2) XC = IRAT(3) XD = IRAT(4) C IF (XD.EQ.1) THEN IF (XC.EQ.1) THEN IF (XB.EQ.1) THEN MODE = 1 ELSE MODE = 2 ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 7 ELSE MODE = 3 ENDIF ELSE MODE = 5 ENDIF ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 8 ELSE MODE = 6 ENDIF ELSE MODE = 4 ENDIF ENDIF C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3020) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA RETURN ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3030) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB RETURN ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3040) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC RETURN ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3050) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC,XD RETURN ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3060) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC RETURN ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3070) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC,XD RETURN ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3080) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XC RETURN ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3090) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XC,XD RETURN ENDIF C ENDIF C RETURN C ENDIF C----------------------------------------------------------------------- C C Coulomb angular coefficients C IF (ABS(ITYPE).EQ.7) THEN ISTORE = IC*NWA+ID IF (IMARK.EQ.1) THEN ISTORE = -ISTORE KTOT(7) = KTOT(7)+1 ENDIF IF (IBUG1.EQ.1) WRITE (IWRITE,3010) JA,JB,NP(IC),NH(IC),NP(ID),N! +H(ID),COEF,ISTORE,ITYPE ELSE ISTORE = (((K*NWA+IA)*NWA+IB)*NWA+IC)*NWA+ID IF (IMARK.EQ.1) THEN ISTORE = -ISTORE IF (ABS(ITYPE).EQ.8) KTOT(8) = KTOT(8) + 1 IF (ABS(ITYPE).EQ.9) KTOT(9) = KTOT(9) + 1 ENDIF IF (IBUG1.EQ.1) WRITE (IWRITE,3000) JA,JB,NP(IA),NH(IA),NP(IB),N! +H(IB),NP(IC),NH(IC),NP(ID),NH(ID),K,COEF,ISTORE,ITYPE ENDIF C IF (NOUT1.GT.0) WRITE (NOUT1) ISTORE,ITYPE,COEF C IF (IBUG1.EQ.1) THEN IME = IME+1 C C ITY = 0 I integral C = 1 F integral C = 2 G integral C = 3 R integral C IF (ABS(ITYPE).EQ.7) THEN ITY = 0 ELSE IF (IA.EQ.IC .AND. IB.EQ.ID) THEN ITY = 1 ELSE IF (IA.EQ.ID .AND. IB.EQ.IC) THEN ITY = 2 ELSE IF (IA.EQ.IB .AND. IC.EQ.ID) THEN ITY = 2 IB = IC ELSE ITY = 3 ENDIF ENDIF ENDIF ENDIF C CALL RAT1(COEF,IRAT) C XA = IRAT(1) XB = IRAT(2) XC = IRAT(3) XD = IRAT(4) C IF (XD.EQ.1) THEN IF (XC.EQ.1) THEN IF (XB.EQ.1) THEN MODE = 1 ELSE MODE = 2 ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 7 ELSE MODE = 3 ENDIF ELSE MODE = 5 ENDIF ENDIF ELSE IF (XB.EQ.1) THEN IF (XA.EQ.1) THEN MODE = 8 ELSE MODE = 6 ENDIF ELSE MODE = 4 ENDIF ENDIF C IF (ITY.EQ.3) THEN C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3100) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA RETURN ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3110) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB RETURN ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3120) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC RETURN ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3130) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC,XD RETURN ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3140) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XB,XC RETURN ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3150) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XA,XC,XD RETURN ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3160) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XC RETURN ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3170) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),NP(IC),NH(IC),NP(ID),NH(ID),XC,XD RETURN ENDIF C ENDIF C IF (ITY.EQ.2) THEN C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3180) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA RETURN ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3190) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XB RETURN ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3200) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XC RETURN ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3210) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XB,XC,XD RETURN ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3220) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XB,XC RETURN ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3230) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XC,XD RETURN ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3240) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XC RETURN ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3250) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XC,XD RETURN ENDIF C ENDIF C IF (ITY.EQ.1) THEN C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3260) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA RETURN ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3270) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XB RETURN ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3280) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XC RETURN ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3290) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XB,XC,XD RETURN ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3300) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XB,XC RETURN ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3310) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XA,XC,XD RETURN ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3320) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XC RETURN ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3330) ITYPE,JA,JB,K,NP(IA),NH(IA),NP(IB),NH(IB! +),XC,XD RETURN ENDIF C ENDIF C IF (ITY.EQ.0) THEN C IF (MODE.EQ.1) THEN WRITE (IPUNCH,3340) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XA RETURN ENDIF C IF (MODE.EQ.2) THEN WRITE (IPUNCH,3350) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XA,XB RETURN ENDIF C IF (MODE.EQ.3) THEN WRITE (IPUNCH,3360) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XA,XC RETURN ENDIF C IF (MODE.EQ.4) THEN WRITE (IPUNCH,3370) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XA,XB,XC,XD RETURN ENDIF C IF (MODE.EQ.5) THEN WRITE (IPUNCH,3380) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XA,XB,XC RETURN ENDIF C IF (MODE.EQ.6) THEN WRITE (IPUNCH,3390) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XA,XC,XD RETURN ENDIF C IF (MODE.EQ.7) THEN WRITE (IPUNCH,3400) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XC RETURN ENDIF C IF (MODE.EQ.8) THEN WRITE (IPUNCH,3410) ITYPE,JA,JB,NP(IC),NH(IC),NP(ID),NH(ID),! +XC,XD RETURN ENDIF C ENDIF C ENDIF C----------------------------------------------------------------------- 3000 FORMAT (1X,2I4,2X,4(I2,A2,1X),1X,I2,2X,1P,E16.9,2X,I9,2X,I2) 3010 FORMAT (1X,2I4,2X,2(1X,'**',2X),2(I2,A2,1X),5X,1P,E16.9,2X,I9,2X,I! +2) 3020 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',I7) 3030 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',I7,'/',I7) 3040 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',I7,' ',7X,! +' * S (',I7,' ',7X,')') 3050 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',I7,'/',I7,! +' * S (',I7,'/',I7,')') 3060 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',I7,'/',I7,! +' * S (',I7,' ',7X,')') 3070 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',I7,' ',7X,! +' * S (',I7,'/',I7,')') 3080 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',7X,' ',7X,! +' S (',I7,' ',7X,')') 3090 FORMAT (1X,I2,2I4,' X(',I2,';',3(I2,A2,','),I2,A2,') ',7X,' ',7X,! +' S (',I7,'/',I7,')') 3100 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',I7) 3110 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',I7,'/',I7) 3120 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',I7,' ',7X,! +' * S (',I7,' ',7X,')') 3130 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',I7,'/',I7,! +' * S (',I7,'/',I7,')') 3140 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',I7,'/',I7,! +' * S (',I7,' ',7X,')') 3150 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',I7,' ',7X,! +' * S (',I7,'/',I7,')') 3160 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',7X,' ',7X,! +' S (',I7,' ',7X,')') 3170 FORMAT (1X,I2,2I4,' R(',I2,';',3(I2,A2,','),I2,A2,') ',7X,' ',7X,! +' S (',I7,'/',I7,')') 3180 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7) 3190 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,'/'! +,I7) 3200 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,' '! +,7X,' * S (',I7,' ',7X,')') 3210 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,'/'! +,I7,' * S (',I7,'/',I7,')') 3220 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,'/'! +,I7,' * S (',I7,' ',7X,')') 3230 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,' '! +,7X,' * S (',I7,'/',I7,')') 3240 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',7X,' '! +,7X,' S (',I7,' ',7X,')') 3250 FORMAT (1X,I2,2I4,' G(',I2,';',I2,A2,',',I2,A2,')',10X,' ',7X,' '! +,7X,' S (',I7,'/',I7,')') 3260 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7) 3270 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,'/'! +,I7) 3280 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,' '! +,7X,' * S (',I7,' ',7X,')') 3290 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,'/'! +,I7,' * S (',I7,'/',I7,')') 3300 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,'/'! +,I7,' * S (',I7,' ',7X,')') 3310 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',I7,' '! +,7X,' * S (',I7,'/',I7,')') 3320 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',7X,' '! +,7X,' S (',I7,' ',7X,')') 3330 FORMAT (1X,I2,2I4,' F(',I2,';',I2,A2,',',I2,A2,')',10X,' ',7X,' '! +,7X,' S (',I7,'/',I7,')') 3340 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',I7) 3350 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',I7,'/',I7) 3360 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',I7,' ',7X,! +' * S (',I7,' ',7X,')') 3370 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',I7,'/',I7,! +' * S (',I7,'/',I7,')') 3380 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',I7,'/',I7,! +' * S (',I7,' ',7X,')') 3390 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',I7,' ',7X,! +' * S (',I7,'/',I7,')') 3400 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',7X,' ',7X,! +' S (',I7,' ',7X,')') 3410 FORMAT (1X,I2,2I4,' I( ;',I2,A2,',',I2,A2,')',10X,' ',7X,' ',7X,! +' S (',I7,'/',I7,')') END C C ******************* C SUBROUTINE SPME(I,J,HCOUL,HBAB,HMAG,IMOD) C C----------------------------------------------------------------------- C C This routine calculates the reduced matrix elements for pair I,J in C either Coulomb/Babuskin gauge or for magnetic case. C C These are defined in the Brink and Satchler sense - i.e. compatible C with Nick Pyper et al's MCT paper but not with Ian Grant's radiative C transitions paper. C C Subroutines called: CLRX,QUAD C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL CLRX DOUBLE PRECISION CLRX C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C DOUBLE PRECISION HBAB,HCOUL,HMAG INTEGER I,IMOD,J C C Local variables C DOUBLE PRECISION CIMLM,CIMLP,CIP,CIPLM DOUBLE PRECISION CIPLP,CJL,CLM,CLP DOUBLE PRECISION DFKI,DFKJ,FL,FLP DOUBLE PRECISION FORM,HGAUGE,TJJ,VALUE INTEGER I1,II,IPJ,J1 INTEGER NAKI,NAKJ,NGRID C C Common variables C DOUBLE PRECISION BJ(6,MXNP),DUM(2),TC(MXNP) DOUBLE PRECISION TD(MXNP) COMMON / BESS1 / DUM,BJ,TC,TD C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION ENLEV(MXNC),GAUGE1,GAUGE2 COMMON / LEVM / ENLEV,GAUGE1,GAUGE2 C C Common variables C INTEGER LTC(20) COMMON / OPT04 / LTC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER KK,LK COMMON / OSC2 / LK,KK C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C evaluate outside factor C TJJ = NKJ(J) NAKI = NAK(I) NAKJ = NAK(J) FORM = SQRT(TJJ+ONE)*CLRX(NAKI,LK,NAKJ) IPJ = (NKJ(I)-1)/2 IF (MOD(IPJ,2).NE.0) FORM = -FORM C NGRID = MIN(MPOIN(I),MPOIN(J)) C FL = LK FLP = FL+ONE DFKI = NAK(I) DFKJ = NAK(J) C IF (KK.EQ.0) THEN C C electric case C ------------- C HGAUGE = ZERO HBAB = ZERO C C tabulate arrays C C TB = PI*QJ+QI*PJ C TC = PI*QJ-QI*PJ C TD = PI*PJ+QI*QJ C IF (ABS(FORM).GT.EPS10) THEN I1 = MPOS(I) J1 = MPOS(J) DO II = 1,NGRID TB(II) = PF(I1)*QF(J1)+QF(I1)*PF(J1) TC(II) = PF(I1)*QF(J1)-QF(I1)*PF(J1) TD(II) = PF(I1)*PF(J1)+QF(I1)*QF(J1) I1 = I1+1 J1 = J1+1 ENDDO C C skip Coulomb part in certain circumstances C IF (IMOD.EQ.1) GOTO 10 C C calculate Coulomb coefficients C ----------------- C CLP = SQRT(FL/FLP) CLM = -SQRT(FLP/FL) CIPLP = CLP*(DFKI-DFKJ) CIMLP = CLP*FLP CIPLM = CLM*(DFKI-DFKJ) CIMLM = -CLM*FL C C tabulate Coulomb integrand C DO II = 1,NGRID TA(II) = RGRID(II)*(BJ(3,II)*(CIPLP*TB(II)+CIMLP*TC(II))+BJ(! +1,II)*(CIPLM*TB(II)+CIMLM*TC(II))) ENDDO CALL QUAD(NGRID,VALUE) HCOUL = FORM*VALUE C 10 CONTINUE C C calculate gauge dependent coefficients C --------------- C CJL = -(FL+FLP) CIP = DFKI-DFKJ C C tabulate gauge dependent integrand C DO II = 1,NGRID TA(II) = RGRID(II)*(BJ(2,II)*CJL*TD(II)+BJ(3,II)*(CIP*TB(II)! ++FLP*TC(II))+BJ(1,II)*(CIP*TB(II)-FL*TC(II))) ENDDO C C print gauge dependent integrand if requested C option 13 set C IF (LTC(13).EQ.1) WRITE (IWRITE,3000) NP(I),NH(I),NP(J),NH(J),! +(TA(II),II=1,NGRID) CALL QUAD(NGRID,VALUE) HGAUGE = FORM*VALUE C IF (LTC(19).EQ.1) THEN HBAB = HCOUL+GAUGE1*HGAUGE HCOUL = HCOUL+GAUGE2*HGAUGE ELSE HBAB = HCOUL+SQRT(FLP/FL)*HGAUGE ENDIF C ENDIF C C print Coulomb and gauge dependent integrals if requested C IF (LTC(7).EQ.1) WRITE (IWRITE,3010) NP(I),NH(I),NP(J),NH(J),HCO! +UL,HGAUGE,HBAB C ELSE C C magnetic case C ------------- C HMAG = ZERO IF (ABS(FORM).GT.EPS10) THEN I1 = MPOS(I) J1 = MPOS(J) DO II = 1,NGRID TA(II) = (PF(I1)*QF(J1)+QF(I1)*PF(J1))*BJ(2,II)*RGRID(II) I1 = I1+1 J1 = J1+1 ENDDO CALL QUAD(NGRID,VALUE) HMAG = -VALUE*(FL+FLP)*(DFKI+DFKJ)*FORM/SQRT(FL*FLP) ENDIF C IF (LTC(7).EQ.1) WRITE (IWRITE,3020) NP(I),NH(I),NP(J),NH(J),HMA! +G C ENDIF C 3000 FORMAT (/' SPME : local form of gauge dependent integral (',I2,A2,! +',',I2,A2,')'//(1X,1P,7E11.3)) 3010 FORMAT (' SPME : Coulomb, gauge, Babushkin matrix elements (',I2,A! +2,',',I2,A2,')'/1X,1P,3E13.5) 3020 FORMAT (' SPME : magnetic matrix element (',I2,A2,',',I2,A2,')'/1X! +,1P,E12.5) END C C ******************* C SUBROUTINE SSTC(IOPEN,ICFN,ICFR,NJ,COEFF) C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL FREE C PARAMETER (MANGM = 60) PARAMETER (MTRIAD=20) PARAMETER (M3MNGM = 3*MANGM) PARAMETER (M6J = 20) COMMON / NJS00 / J6C,J7C,J8C,JWC COMMON / NJS01 / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM), +JW(6,M6J) COMMON / NJS02 / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD) C INCLUDE 'grasp0.inc' C COMMON / ANG00 / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3), ! + FREE(MANGM) COMMON / INFORM / IREAD,IWRITE,IPUNCH COMMON / NRD01 / MLX(4),MQX(4),JPOS(4),NOPEN COMMON / NRD06 / LSV(5,4,MXNC) COMMON / ORB04 / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC) COMMON / ORB06 / JQS(3,MXNW,MXNC),JCUP(10,MXNC),ICHOP(MXNW,MXNC),! + IEXC COMMON / TCD / ICD2(3,3,3),NCD2(3),ICD3(5,5,6),NCD3(6), ! + ICD4(8,8,7),NCD4(7),ICD5(10,10,7),NCD5(7), ! + NDN(7,3),JJDN(10,7,3),LSDN(10,7,3) COMMON / TCP / ICP2(2,2),ICP3(3,3) C PARAMETER (EPS8=1.D-8) PARAMETER (ZERO=0.D0) PARAMETER (ONE=1.D0) PARAMETER (TWO=2.D0) C DIMENSION K1(40) C----------------------------------------------------------------------- C C Set up values C LL = MLX(IOPEN)*2+1 NQ = MQX(IOPEN) IF (LL.EQ.1) GOTO 30 NL = LSV(3,IOPEN,ICFN) NS = LSV(2,IOPEN,ICFN) NV = LSV(1,IOPEN,ICFN) JP = JPOS(IOPEN) NQR1 = IQ(JP-1,ICFR) NJ1 = JQS(3,JP-1,ICFR) NV1 = JQS(1,JP-1,ICFR) NJ2 = JQS(3,JP,ICFR) NV2 = JQS(1,JP,ICFR) C IF (NQ.GT.LL) GOTO 10 MQ = NQ MQ1 = NQR1 GOTO 20 C 10 CONTINUE MQ = LL+LL-NQ MQ1 = LL-NQR1-1 20 CONTINUE MQ2 = MQ-MQ1 IF (MQ.GT.1) GOTO 40 30 CONTINUE COEFF = ONE GOTO 230 C C P shell C 40 CONTINUE IF (LL.NE.3) GOTO 90 IF (MQ.EQ.3) GOTO 80 IF (NJ-3) 50,30,70 50 CONTINUE J = MQ1/2+1 K = (NL+1)/2 60 CONTINUE IN = ICP2(J,K) IF (NL.EQ.5) IN = -IN ID = 3 GOTO 180 C 70 CONTINUE J = MQ1+1 K = (NL-1)/2 GOTO 60 C 80 CONTINUE IF (NJ.NE.4) GOTO 30 K = (NL+1)/2 J = MQ1+1 IN = ICP3(J,K) ID = 18 GOTO 180 C 90 CONTINUE IF (LL.NE.5) GOTO 190 C C D shell C IF (MQ.GT.2) GOTO 100 IF (NJ.EQ.3 .OR. NJ.EQ.7) GOTO 30 K = (13-NJ)/4 J = (5-NS)/2 I = MQ1+1 IF (NL.LT.7 .AND. K.EQ.2) J = J + 1 IN = ICD2(I,J,K) ID = NCD2(K) GOTO 180 C 100 CONTINUE ICHKJJ = NJ2+10*(MQ2+10*(NJ1+10*MQ1)) ICHKLS = NL+10*(NS+10*NV) K = (NJ+1)/2 JQ = MQ-2 NC = NDN(K,JQ) DO IC = 1,NC IF (ICHKJJ.NE.JJDN(IC,K,JQ)) GOTO 110 I = IC GOTO 120 C 110 CONTINUE ENDDO GOTO 250 C 120 CONTINUE DO IC = 1,NC IF (ICHKLS.NE.LSDN(IC,K,JQ)) GOTO 130 J = IC GOTO 140 C 130 CONTINUE ENDDO GOTO 250 C 140 CONTINUE IF (MQ-4) 150,160,170 150 CONTINUE IN = ICD3(I,J,K) ID = NCD3(K) GOTO 180 C 160 CONTINUE IN = ICD4(I,J,K) ID = NCD4(K) GOTO 180 C 170 CONTINUE IN = ICD5(I,J,K) ID = NCD5(K) 180 CONTINUE IF (IN.EQ.0) GOTO 240 COEFF = SQRT(DBLE(ABS(IN))/DBLE(ID)) IF (IN.LT.0) COEFF = -COEFF GOTO 230 C 190 CONTINUE IF (MQ.GT.2) GOTO 260 C C Higher shells with no more than 2 electrons C IF (MOD(NJ+1,4).EQ.0) GOTO 30 DO K = 1,21 K1(K) = J1(K) ENDDO J1(1) = LL J1(2) = 2 J1(4) = LL J1(5) = 2 IF (NQR1.EQ.0) GOTO 200 J1(3) = LL-1 IF (NQR1.EQ.1) GOTO 210 J1(6) = LL-1 GOTO 220 C 200 CONTINUE J1(3) = LL+1 210 CONTINUE J1(6) = LL+1 220 CONTINUE DO K = 9,21,6 J1(K-2) = NL J1(K-1) = NS J1(K) = NJ DO J = 1,3 J1(J+K) = 1 ENDDO ENDDO CALL GENSUM (J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST, + J3TEST,COEFF) IF (NQR1.EQ.1) COEFF = COEFF*SQRT(TWO) DO K = 1,21 J1(K) = K1(K) ENDDO IF (ABS(COEFF).LT.EPS8) GOTO 240 C 230 CONTINUE IF (NQ.GT.LL) THEN IF (MOD(ABS(NV-NV1-NV2),4).EQ.2) COEFF = -COEFF ENDIF C RETURN C 240 CONTINUE COEFF = ZERO RETURN C C Error section C 250 CONTINUE WRITE (IWRITE,3000) WRITE (IPUNCH,3000) STOP C 260 CONTINUE WRITE (IWRITE,3010) WRITE (IPUNCH,3010) STOP C 3000 FORMAT (/' ERROR in SSTC : Configurations not found ... STOPPING') 3010 FORMAT (/ ! +' ERROR in SSTC : No more than 2 electrons allowed in shells wit',! +'h L > 2 ... STOPPING') END C C ******************* C SUBROUTINE STWAVE(NLAST,J,ICLEM) C C----------------------------------------------------------------------- C C This subroutine is used to produce estimates of the C wavefunctions by use of Slater-type orbitals. C Coefficients are read from input file in CIV3 format. C C DATA C C J Serial number of function required C ICLEM = 0 Slater-type coefficients C = 1 Clementi-type coefficients C C RESULT C C The wavefunctions are tabulated in arrays PF and C QF, with the series expansion coefficients in C arrays PZ, QZ. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N11 PARAMETER (N11=MXNP+10) INTEGER NSTO PARAMETER (NSTO=30) INTEGER NIRAD PARAMETER (NIRAD=20) C C Argument variables C INTEGER ICLEM,J,NLAST C C Local variables C DOUBLE PRECISION DP,PQNORM,R(0:NIRAD),S(NSTO) DOUBLE PRECISION TWOCE,ZE(NSTO) INTEGER I,IRAD(NSTO),K,KAPPA INTEGER LFACTR,M,MXIRAD,NADD INTEGER NGRID,NPOINT,nx C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C integer icut(mxnw) common /nrbcut/icut C C Common variables C double precision fx integer istatx,npmin0 common /nrbinf/fx,istatx,npmin0 C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION CUTOFF COMMON / PATZ / CUTOFF C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C read eigenvalue and Slater-type function coefficients C similar to CIV3 (ISTAND.EQ.1) format C READ (IREAD,*) E(J) READ (IREAD,*) M IF (M.GT.NSTO) THEN WRITE (IWRITE,3030) M,NSTO WRITE (IPUNCH,3030) M,NSTO STOP ENDIF READ (IREAD,*) (IRAD(K),K=1,M) READ (IREAD,*) (ZE(K),K=1,M) READ (IREAD,*) (S(K),K=1,M) C C convert to Slater-type coefficients if necessary C IF (ICLEM.EQ.1) THEN DO K = 1,M LFACTR = 1 DO I = 1,2*IRAD(K) LFACTR = LFACTR*I ENDDO S(K) = S(K)*(TWO*ZE(K))**(IRAD(K)+HALF)/SQRT(DBLE(LFACTR)) ENDDO ENDIF C C evaluate large component P of orbital over grid and find first C approximation to small component Q using Thomas-Fermi potential C KAPPA = NAK(J) TWOCE = TWO*C-E(J)/C R(0) = ONE C MXIRAD = 0 DO K = 1,M IF (IRAD(K).GT.MXIRAD) MXIRAD = IRAD(K) ENDDO IF (MXIRAD.GT.NIRAD) THEN WRITE (IWRITE,3040) MXIRAD,NIRAD WRITE (IPUNCH,3040) MXIRAD,NIRAD STOP ENDIF C DO I = 1,N P(I) = ZERO Q(I) = ZERO DO K = 1,MXIRAD R(K) = R(K-1)*RGRID(I) ENDDO DO K = 1,M DP = S(K)*R(IRAD(K)-1)*EXP(-ZE(K)*R(1)) P(I) = P(I)+DP*R(1) Q(I) = Q(I)+DP*(IRAD(K)-ZE(K)*R(1)+KAPPA) ENDDO Q(I) = Q(I)/(TWOCE+YP(I)/R(1)/C) ENDDO C C find number of points required for orbital C I = N 10 CONTINUE IF (ABS(P(I)).LT.CUTOFF) THEN I = I-1 IF (I.GT.0) GOTO 10 ENDIF C IF (I.EQ.0) THEN WRITE (IWRITE,3020) WRITE (IPUNCH,3020) STOP ELSEIF (I.EQ.N) THEN WRITE (IWRITE,3000) N WRITE (IPUNCH,3000) N STOP ENDIF C NPOINT = I c c add buffer space for subsequent formation of new basis in rritz; c extend it radially by a factor fx. c if(np(j).ge.npmin0)then icut(j)=npoint !store real end nx=log(fx)/h nx=nx+mod(nx,2) else nx=0 endif C IF (NPOINT.LT.N) THEN IF (MOD(NPOINT,2).EQ.1) THEN NADD = 8 ELSE NADD = 7 ENDIF c nadd=nadd+nx c IF (NPOINT+NADD.GT.N) NADD = N - NPOINT DO I = NPOINT+1,NPOINT+NADD P(I) = ZERO Q(I) = ZERO ENDDO NGRID = NPOINT+NADD ELSE NGRID = NPOINT ENDIF C C normalize C check sign of P near the nucleus, it should be positive C DO I = 1,NGRID TA(I) = (P(I)**2+Q(I)**2)*RGRID(I) ENDDO CALL QUAD(NGRID,PQNORM) PQNORM = 1/SQRT(PQNORM) IF (P(1).LT.ZERO) PQNORM = -PQNORM DO I = 1,NGRID P(I) = P(I)*PQNORM Q(I) = Q(I)*PQNORM ENDDO C C expansion coefficients for P and Q near origin C PZ(J) = P(1)/RGRID(1)**GAMA(J) IF (KAPPA.LT.0) THEN QZ(J) = PZ(J)*Z/(KAPPA-GAMA(J))/C ELSE QZ(J) = PZ(J)*C*(KAPPA+GAMA(J))/Z ENDIF C C store wavefunctions in arrays PF and QF C IF (NLAST+NGRID.GT.MXNG) THEN WRITE (IWRITE,3010) NLAST+NGRID,MXNG WRITE (IPUNCH,3010) NLAST+NGRID,MXNG STOP ENDIF K = NLAST+1 DO I = 1,NGRID PF(K) = P(I) QF(K) = Q(I) K = K+1 ENDDO MPOS(J) = NLAST+1 MPOIN(J) = NGRID NLAST = NLAST+NGRID C C write out wavefunction C IF (ITC(16).EQ.1) CALL PRWF(J) C 3000 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/ ! +' Wavefunction is too large at end of radial mesh.'/ ! +' You must increase MXNP from the present value ',I9) 3010 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/ ! +' You must increase MXNG to at least ',I9, ! +' from the present value of ',I9) 3020 FORMAT (/' ERROR in STWAVE: ... STOPPING'/ ! +' Wavefunction cutoff not found.') 3030 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/ ! +' You must increase NSTO to at least ',I9, ! +' from the present value of ',I9) 3040 FORMAT (/' ERROR in STWAVE: dimension ... STOPPING'/ ! +' You must increase NIRAD to at least ',I9, ! +' from the present value of ',I9) END C C ******************* C SUBROUTINE STWOPT C C----------------------------------------------------------------------- C C This subroutine is used to improve estimates of the C wavefunctions which Slater-type orbitals input. C C RESULT C C The wavefunctions are tabulated in arrays PF and C QF, with the series expansion coefficients in C arrays PZ, QZ. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL EIGENV DOUBLE PRECISION EIGENV C C Parameter variables C INTEGER N11 PARAMETER (N11=MXNP+10) INTEGER MXITER PARAMETER (MXITER=10) C C Local variables C DOUBLE PRECISION DIFF,DIFFQ,DP(MXNP) DOUBLE PRECISION DPF(MXNG),PQNORM,QOLD,TWOCE DOUBLE PRECISION VN,XCA,XCP,XCQ DOUBLE PRECISION YPOLD(MXNP),ZFAC INTEGER I,ITER,J,K INTEGER NGRID LOGICAL LEIGEN(MXNW) C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION XCAX COMMON / CONVG / XCAX C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF C C Common variables C INTEGER ILO(MXNW),IWO(MXNW),NWO COMMON / WRO / NWO,IWO,ILO Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) C C temporarily store static potential C XCA = XCAX ZFAC = ONE DO I = 1,N YPOLD(I) = YP(I) ENDDO C C iterations loop C ITER = 0 10 CONTINUE IF (ITER.LT.MXITER) THEN ITER = ITER+1 DIFF = ZERO C diagonalize hamiltonian CALL MATRIX C C loop over Slater-type orbitals C DO J = 1,NW IF (ILO(J).EQ.4.OR.ILO(J).EQ.5) THEN C C initialize arrays for this orbital including Lagrange multipliers C (note that LAGR uses array Q.) C NGRID = MPOIN(J) TWOCE = TWO*C-E(J)/C CALL LAGR(J) K = MPOS(J) DO I = 1,NGRID P(I) = PF(K) Q(I) = QF(K) K = K+1 ENDDO K = MPOS(J) IF (ITER.EQ.1) THEN C store DP/DR + KAPPA*P/R in arrays DP and DPF DO I = 1,NGRID DP(I) = Q(I)*(TWOCE+YPOLD(I)/RGRID(I)/C) DPF(K) = DP(I) K = K+1 ENDDO C decide whether to estimate orbital eigenvalues IF (E(J).LE.ZERO) THEN LEIGEN(J) = .TRUE. ELSE LEIGEN(J) = .FALSE. ENDIF ELSE DO I = 1,NGRID DP(I) = DPF(K) K = K+1 ENDDO ENDIF C C revaluate small component Q of orbital with new static and C exchange potentials, using approximate eigenvalue if C necessary, and then normalize C CALL YPOT(J,VN,ZFAC) CALL XPOT(J,XCA,XCP,XCQ) IF (LEIGEN(J)) E(J) = EIGENV(J) DIFFQ = ZERO DO I = 1,NGRID QOLD = Q(I) Q(I) = (DP(I)-XTP(I)/RGRID(I))/(TWOCE+YP(I)/RGRID(I)/C) DIFFQ = DIFFQ+ABS(QOLD-Q(I)) TA(I) = (P(I)**2+Q(I)**2)*RGRID(I) ENDDO CALL QUAD(NGRID,PQNORM) DIFF = DIFF+DIFFQ*C/NGRID+ABS(PQNORM-ONE) PQNORM = 1/SQRT(PQNORM) DO I = 1,NGRID P(I) = P(I)*PQNORM Q(I) = Q(I)*PQNORM DP(I) = DP(I)*PQNORM ENDDO C C expansion coefficients for P and Q near origin C and store wavefunctions in arrays PF and QF C PZ(J) = P(1)/RGRID(1)**GAMA(J) IF (NAK(J).LT.0) THEN QZ(J) = PZ(J)*Z/(NAK(J)-GAMA(J))/C ELSE QZ(J) = PZ(J)*C*(NAK(J)+GAMA(J))/Z ENDIF K = MPOS(J) DO I = 1,NGRID PF(K) = P(I) QF(K) = Q(I) DPF(K) = DP(I) K = K+1 ENDDO C C write out wavefunction C WRITE (IWRITE,3010) NP(J),NH(J),E(J),MPOIN(J) IF (ITC(16).EQ.1) CALL PRWF(J) C ENDIF ENDDO C IF (DIFF/NW.GE.ACCY) GOTO 10 ELSE WRITE (IWRITE,3020) ITER WRITE (IPUNCH,3020) ITER STOP ENDIF C 3000 FORMAT (/' >>>> routine STWOPT - optimise Slater-type orbitals'/) 3010 FORMAT (' *** Slater-type orbitals *** ',I2,A2,' E = ',1P,E12.5,2! +X,I4,' points') 3020 FORMAT (/' ERROR in routine STWOPT'/ ! +' orbitals not converged after ',I2,' iterations'/ ! +' program is STOPPING'/) END C C ******************* C SUBROUTINE SUMMRY(IWRITE) C C----------------------------------------------------------------------- C C This routine gives a final summary of the contributions to the C energy levels from zero-order, Breit, vacuum polarization and self C energy. these are given in a.u., cm-1, and eV. C The energy levels are written out in order of increasing energy. C C No subroutine called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) C C Argument variables C INTEGER IWRITE C C Local variables C DOUBLE PRECISION AM,CONST,ROW(7) INTEGER I,IJ,IP INTEGER J,KTC16,KTC17,KTC18 INTEGER KTC19,L C C Common variables C DOUBLE PRECISION ATW,FACTAN,FACTCM,FACTEV DOUBLE PRECISION FACTRY COMMON / ATOM / ATW,FACTRY,FACTCM,FACTEV,FACTAN C C Common variables C DOUBLE PRECISION COUVEC(MXNC,MXNC) COMMON / BRET1 / COUVEC C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION SFENG(MXNC),VPENG(MXNC) COMMON / ENRG2 / VPENG,SFENG C C Common variables C INTEGER KTC(20) COMMON / OPT03 / KTC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR C C Common variables C INTEGER LEV(MXNC) COMMON / PAT1 / LEV C C Common variables C INTEGER LORDER(MXNC) COMMON / PAT2 / LORDER C C Common variables C CHARACTER*80 IHED CHARACTER*20 RECORD COMMON / TITL / IHED,RECORD C C Common variables C DOUBLE PRECISION WFACT COMMON / WFAC / WFACT Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (ABS(ATW).LT.EPS10) THEN WRITE (IWRITE,3000) IHED(1:40),IHED(41:80),RECORD,WFACT ELSE WRITE (IWRITE,3010) IHED(1:40),IHED(41:80),RECORD,WFACT,ATW ENDIF C C Ryd print option 16 set C au print option 17 set C cm-1 print option 18 set C eV print option 19 set C KTC16 = KTC(16) KTC17 = KTC(17) KTC18 = KTC(18) KTC19 = KTC(19) C----------------------------------------------------------------------- 10 CONTINUE C IF (KTC16.EQ.1) THEN KTC16 = 0 CONST = FACTRY WRITE (IWRITE,3030) GOTO 20 ENDIF C IF (KTC17.EQ.1) THEN KTC17 = 0 CONST = ONE WRITE (IWRITE,3020) GOTO 20 ENDIF C IF (KTC18.EQ.1) THEN KTC18 = 0 CONST = FACTCM WRITE (IWRITE,3040) CONST GOTO 20 ENDIF C IF (KTC19.EQ.1) THEN KTC19 = 0 CONST = FACTEV WRITE (IWRITE,3050) CONST GOTO 20 ENDIF C RETURN C----------------------------------------------------------------------- 20 CONTINUE WRITE (IWRITE,3060) DO J = 1,NCPRIN C IF (J.EQ.1) THEN ROW(1) = COUENG(J)*CONST ROW(2) = BREENG(J)*CONST ROW(3) = ROW(1)+ROW(2) ROW(4) = VPENG(J)*CONST ROW(5) = SFENG(J)*CONST ROW(6) = ROW(4)+ROW(5) ROW(7) = ROW(3)+ROW(6) ELSE ROW(1) = (COUENG(J)-COUENG(1))*CONST ROW(2) = (BREENG(J)-BREENG(1))*CONST ROW(3) = ROW(1)+ROW(2) ROW(4) = (VPENG(J)-VPENG(1))*CONST ROW(5) = (SFENG(J)-SFENG(1))*CONST ROW(6) = ROW(4)+ROW(5) ROW(7) = ROW(3)+ROW(6) ENDIF C I = LEV(J) IJ = ITJPO(I)-1 IP = ISPAR(I) AM = COUVEC(I,J) C IF (MOD(IJ,2).EQ.0) THEN IJ = IJ/2 IF (IP.EQ.1) THEN IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3130) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ELSE WRITE (IWRITE,3140) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ENDIF ELSE IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3110) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ELSE WRITE (IWRITE,3120) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ENDIF ENDIF ELSE IF (IP.EQ.1) THEN IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3090) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ELSE WRITE (IWRITE,3100) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ENDIF ELSE IF (LORDER(J).EQ.0) THEN WRITE (IWRITE,3070) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ELSE WRITE (IWRITE,3080) J,IJ,I,AM,ROW(1),ROW(2),ROW(6),ROW(7) ENDIF ENDIF ENDIF C DO L = 1,NCF IF (L.NE.I) THEN AM = COUVEC(L,J) IF (AM*AM .GT. .01D0) WRITE (IWRITE,3150) L,AM ENDIF ENDDO C ENDDO C GOTO 10 C----------------------------------------------------------------------- 3000 FORMAT (/' >>>> routine SUMMRY called'//' Title : ',A40/ ! +' ',A40/' Run at : ',A20// ! +' WFACT (factor used to multiply frequency) = ',1P,E10.3/ ! +' atomic weight has been set to infinity') 3010 FORMAT (/' >>>> routine SUMMRY called'//' Title : ',A40/ ! +' ',A40/' Run at : ',A20// ! +' WFACT (factor used to multiply frequency) = ',1P,E10.3/ ! +' ATW (atomic weight) = ',0P,F10.4) 3020 FORMAT (/' Summary of contributions to energy levels in a.u.') 3030 FORMAT (/' Summary of contributions to energy levels in Ryd.') 3040 FORMAT (/' Summary of contributions to energy levels in cm-1'/ ! +' (1 a.u. =',1P,E17.10,' cm-1)') 3050 FORMAT (/' Summary of contributions to energy levels in eV'/ ! +' (1 a.u. =',1P,E17.10,' eV)') 3060 FORMAT (/ ! +' level CSF zero-order Breit QED ',! +'total'/) 3070 FORMAT (' ',I4,1X,I4,'/2 o ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3080 FORMAT (' * ',I4,1X,I4,'/2 o ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3090 FORMAT (' ',I4,1X,I4,'/2 e ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3100 FORMAT (' * ',I4,1X,I4,'/2 e ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3110 FORMAT (' ',I4,1X,I4,' o ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3120 FORMAT (' * ',I4,1X,I4,' o ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3130 FORMAT (' ',I4,1X,I4,' e ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3140 FORMAT (' * ',I4,1X,I4,' e ',I4,F5.2,1P,E16.8,2E10.2,E16.8) 3150 FORMAT (15X,I4,F5.2) END C C ******************* C SUBROUTINE TFPOT C C----------------------------------------------------------------------- C C Calculation of the universal Thomas-Fermi potential. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION W1 PARAMETER (W1=0.8853D0) DOUBLE PRECISION W2 PARAMETER (W2=0.60112D0) DOUBLE PRECISION W3 PARAMETER (W3=1.81061D0) DOUBLE PRECISION W4 PARAMETER (W4=0.04793D0) DOUBLE PRECISION W5 PARAMETER (W5=0.21465D0) DOUBLE PRECISION W6 PARAMETER (W6=0.77112D0) DOUBLE PRECISION W7 PARAMETER (W7=1.39515D0) DOUBLE PRECISION W8 PARAMETER (W8=1.81061D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION THREE PARAMETER (THREE=3.D0) DOUBLE PRECISION THIRD PARAMETER (THIRD=ONE/THREE) C C Local variables C DOUBLE PRECISION DGZ,WA,WB,WC DOUBLE PRECISION WD,WE,WF,WX INTEGER I,IDGZ C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C The Thomas-Fermi potential is stored in array YP C C----------------------------------------------------------------------- DGZ = Z DO I = 1,NW DGZ = DGZ-IQ(I,1) ENDDO C IDGZ = NINT(DGZ) WRITE (IWRITE,3000) IDGZ C WA = DGZ+ONE WB = Z-WA WC = RNT*WB**THIRD/W1 WC = SQRT(WC) WX = SQRT(EPH) C DO I = 1,N C C Rational function approximation to the universal C Thomas-Fermi function C WD = WC*(W2*WC+W3)+ONE WE = WC*(WC*(WC*(WC*(W4*WC+W5)+W6)+W7)+W8)+ONE C C Potential function for atomic number Z, degree of C ionisation DGZ C WF = WD/WE YP(I) = (ZZ(I)-WA)*WF*WF+WA WC = WC*WX C ENDDO C 3000 FORMAT (/' >>>> routine TFPOT called to evaluate the Thomas-Fermi'! +/' >>>> potential for degree of ionization = ',I4/) END C C ******************* C SUBROUTINE TFWAVE(NLAST,J,MF) C C----------------------------------------------------------------------- C C This subroutine is used to produce estimates of the wave functions C by use of the Thomas-Fermi approximation. C C Subroutine SOLV0 is used to obtain the radial wave functions C corresponding to the potential Y(R) obtained in TFPOT. C C DATA C ---- C NLAST index of last element used in PF and QF C J serial number of function required C C RESULT C ------ C The wave functions are tabulated in arrays PF and QF, with the C series expansion coefficients in arrays PZ, QZ. C MF is non-zero if a failure occurs. C C Subroutine called : SOLV0 C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C INTEGER J,MF,NLAST C C Local variables C DOUBLE PRECISION AST,GAMJ,ONEM,VN DOUBLE PRECISION WA INTEGER I,IJ,MX,NADD INTEGER NGRID,NPOINT,nx LOGICAL HIACC C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION P(MXNP),PC(MXNP),Q(MXNP) DOUBLE PRECISION QC(MXNP) COMMON / INT2 / P,Q,PC,QC C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C integer icut(mxnw) common /nrbcut/icut C C Common variables C double precision fx integer istatx,npmin0 common /nrbinf/fx,istatx,npmin0 C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C DOUBLE PRECISION E(MXNW) COMMON / ORB01 / E C C Common variables C DOUBLE PRECISION GAMA(MXNW),XAM(MXNW) COMMON / ORB02 / GAMA,XAM C C Common variables C DOUBLE PRECISION CXP(MXNW) COMMON / ORB03 / CXP C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WA = CXP(J) WA = (Z-WA)/NP(J) WA = WA*WA*HALF C C Replace very small estimates by a tenth C IF (WA.LT.TENTH) WA = TENTH C C Estimate of leading coefficient PZ C GAMJ = GAMA(J) AST = Z**(GAMJ+HALF) IF (NAK(J).GT.0) AST = AST*Z/ (C*C) AST = AST*TENTH C C Compute radial wave functions C DO I = 1,N YQ(I) = YP(I) XTP(I) = ZERO XTQ(I) = ZERO ENDDO C ONEM = -ONE C C Estimate slope of potential C VN = ZERO IF (NUCTYP.NE.0) VN = YP(1)/RNT C C Solve the equations with no exchange C HIACC = .FALSE. CALL SOLV0(J,VN,ONEM,ZERO,ZERO,AST,WA,MX,HIACC,NPOINT) C C Failure : C IF (MX.NE.0) THEN MF = 1 WRITE (IWRITE,3000) NP(J),NH(J),E(J) RETURN ENDIF C C Success : C Store wave functions in arrays PF and QF C c c add buffer space for subsequent formation of new basis in rritz; c extend it radially by a factor fx. c if(np(j).ge.npmin0)then icut(j)=npoint !store real end nx=log(fx)/h nx=nx+mod(nx,2) else nx=0 endif C IF (NPOINT.LT.N) THEN IF (MOD(NPOINT,2).EQ.1) THEN NADD = 8 ELSE NADD = 7 ENDIF c nadd=nadd+nx c IF (NPOINT+NADD.GT.N) NADD = N - NPOINT DO I = NPOINT+1,NPOINT+NADD P(I) = ZERO Q(I) = ZERO ENDDO NGRID = NPOINT+NADD ELSE NGRID = NPOINT ENDIF C IF (NLAST+NGRID.GT.MXNG) THEN WRITE (IWRITE,3010) NLAST + NGRID,MXNG WRITE (IPUNCH,3010) NLAST + NGRID,MXNG STOP ENDIF C IJ = NLAST+1 DO I = 1,NGRID PF(IJ) = P(I) QF(IJ) = Q(I) IJ = IJ+1 ENDDO C MF = 0 MPOS(J) = NLAST+1 MPOIN(J) = NGRID NLAST = NLAST+NGRID C 3000 FORMAT (' FAILURE in TFWAVE for ',I2,A2,' eigenvalue = ',1P,E12.5) 3010 FORMAT (/' ERROR in TFWAVE : dimension ... STOPPING'/ ! +' You must increase MXNG to at least ',I9, ! +' from the present value of ',I9/) END C C ******************* C SUBROUTINE TMSOUT C C----------------------------------------------------------------------- C C Prints table of terms set by BLOCK DATA. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE C C Local variables C INTEGER I,II,JI,JJ INTEGER K,KK,KKK C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C INTEGER ITAB(16),JTAB(16),NROWS INTEGER NTAB(255) COMMON / TERMS / NROWS,ITAB,JTAB,NTAB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) WRITE (IWRITE,3010) NROWS, (ITAB(I),I=1,NROWS) WRITE (IWRITE,3020) DO I = 1,NROWS JI = JTAB(I) JJ = 3*ITAB(I) KK = JI+1 KKK = JJ+JI II = I-1 WRITE (IWRITE,3030) II, (NTAB(K),K=KK,KKK) ENDDO C----------------------------------------------------------------------- 3000 FORMAT (/40X,'Table of possible terms'//) 3010 FORMAT (1X,I3,' rows of this table (NTAB) are defined.'/ ! +' The lengths (ITAB) of the rows are, respectively,'/1X,16I5) 3020 FORMAT (/' List of NTAB. '/ ! +' Each triad of numbers corresponds to (V,W,2J+1),'/ ! +' where V is seniority,'/ ! +' and W distinguishes states with the same values of V,J.'/) 3030 FORMAT (' Row ',I2,' ,',8(I8,2I3)/(1X,I16,2I3,7(I8,2I3))) END C C ******************* C SUBROUTINE TNSRJJ(KA,IOPAR,JA,JB,IA1,IA2,VSHELL) C C----------------------------------------------------------------------- C C The main program for evaluating the reduced matrix elements of one C particle operator for configurations in JJ-coupling. C C Subroutines called: CFP,FIXJ,IROW1,ITRIG,NJSYM,GENSUM, C SETUP,VIJOUT C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) LOGICAL FREE LOGICAL FAIL C PARAMETER (MANGM = 60) PARAMETER (MTRIAD=20) PARAMETER (M3MNGM = 3*MANGM) PARAMETER (M6J = 20) COMMON / NJS00 / J6C,J7C,J8C,JWC COMMON / NJS01 / J6(M3MNGM),J7(M3MNGM),J8(M3MNGM), +JW(6,M6J) COMMON / NJS02 / ICOUNT,J2TEST(MTRIAD),J3TEST(MTRIAD) C INCLUDE 'grasp0.inc' PARAMETER (NPLX=14) C COMMON / ANG00 / MMOM,NMOM,J1(MANGM),J2(MTRIAD,3),J3(MTRIAD,3), ! + FREE(MANGM) COMMON / ANG08 / JBQ1(3,MXNW),JBQ2(3,MXNW),JTQ1(3),JTQ2(3) COMMON / ANG10 / JJC1(NPLX),JJC2(NPLX) COMMON / ANG11 / NQ1(MXNW),NQ2(MXNW) COMMON / ANG12 / JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG13 / JLIST(NPLX),KLIST(MXNW),NPEEL,NCORE COMMON / DEBUG / IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6 COMMON / INFORM / IREAD,IWRITE,IPUNCH COMMON / ORB04 / NW,NCF,NP(MXNW),NAK(MXNW),IQ(MXNW,MXNC) COMMON / ORB06 / JQS(3,MXNW,MXNC),JCUP(10,MXNC),ICHOP(MXNW,MXNC),! + IEXC COMMON / ORB07 / ITJPO(MXNC),ISPAR(MXNC) COMMON / TERMS / NROWS,ITAB(16),JTAB(16),NTAB(255) C DIMENSION VSHELL(MXNW) DIMENSION IS(2),KS(2) DIMENSION JLIS(NPLX),JC1S(NPLX),JC2S(NPLX) C PARAMETER (EPS10=1.D-10) PARAMETER (ZERO=0.D0) C----------------------------------------------------------------------- IA1 = 0 KK = KA+KA+1 IF (ITRIG(ITJPO(JA),ITJPO(JB),KK).EQ.0) RETURN IF (IOPAR.NE.0 .AND. ISPAR(JA)*ISPAR(JB)*IOPAR.NE.1) RETURN C CALL SETUP(JA,JB,IWRITE,IBUG2) IF (IBUG4.EQ.1) CALL VIJOUT(JA,JB,IWRITE) C DO IJ = 1,NW VSHELL(IJ) = ZERO ENDDO C----------------------------------------------------------------------- C C Analyse peel shell interactions C IDQ = 0 JA1 = 0 JA2 = 0 C IF (NPEEL.EQ.0) GOTO 50 C DO JWW = 1,NPEEL IJ = JLIST(JWW) NDQ = NQ1(IJ)-NQ2(IJ) IF (ABS(NDQ).GT.1) GOTO 240 IF (NDQ) 20,40,10 10 CONTINUE JA1 = JWW GOTO 30 C 20 CONTINUE JA2 = JWW 30 CONTINUE IDQ = IDQ+1 40 CONTINUE ENDDO C IF (IDQ.GT.2) GOTO 240 C----------------------------------------------------------------------- C C Evaluate the array VSHELL C C There are two possibilities : C C If IDQ=0, then loop over all shells by index ISH C If IDQ=2, then one orbital fixed on each side C C----------------------------------------------------------------------- NS = NPEEL IF (IDQ.EQ.2) GOTO 130 C----------------------------------------------------------------------- C C loop over shells when IDQ=0 C C----------------------------------------------------------------------- 50 CONTINUE ISH = 0 IF (NPEEL.EQ.0) GOTO 60 DO I = 1,NPEEL JLIS(I) = JLIST(I) ENDDO IF (NPEEL.EQ.1) GOTO 60 NPEELM = NPEEL-1 DO I = 1,NPEELM JC1S(I) = JJC1(I) JC2S(I) = JJC2(I) ENDDO C----------------------------------------------------------------------- C C If ISH > NW, then loop is over and return C C----------------------------------------------------------------------- 60 CONTINUE ISH = ISH+1 IF (ISH.GT.NW) RETURN IF (ICHOP(ISH,JA).EQ.-1) GOTO 60 IF (IBUG6.EQ.1) WRITE (IWRITE,3040) ISH IF (ICHOP(ISH,JA).EQ.0) GOTO 110 C----------------------------------------------------------------------- C C Case one C The ISHth shell is in the core or in the peel and closed for both C sides C C----------------------------------------------------------------------- I = 1 IF (NPEEL.EQ.0) GOTO 100 DO I = 1,NPEEL IJ = JLIST(I) IF (ISH.LT.IJ) GOTO 70 ENDDO I = NPEEL+1 GOTO 80 C 70 CONTINUE IM = NPEEL-I+1 DO II = 1,IM JLIST(NPEEL+2-II) = JLIST(NPEEL+1-II) IF (NPEEL.EQ.II) GOTO 80 JJC1(NPEEL+1-II) = JJC1(NPEEL-II) JJC2(NPEEL+1-II) = JJC2(NPEEL-II) ENDDO 80 CONTINUE IF (I.LT.3) GOTO 90 JJC1(I-1) = JJC1(I-2) JJC2(I-1) = JJC2(I-2) GOTO 100 C 90 CONTINUE I1 = JLIST(1) JJC1(1) = JJQ1(3,I1) JJC2(1) = JJQ2(3,I1) 100 CONTINUE JLIST(I) = ISH JA1 = I JA2 = I NS = NPEEL+1 GOTO 130 C----------------------------------------------------------------------- C C Case two C The ISHth shell is in the peel and open for either side C C----------------------------------------------------------------------- 110 CONTINUE NS = NPEEL DO JWW = 1,NPEEL NX = ISH-JLIST(JWW) IF (NX.EQ.0) GOTO 120 ENDDO 120 CONTINUE JA1 = JWW JA2 = JWW C----------------------------------------------------------------------- C C ****** main computation ****** C C JA1 , JA2 are the indices of interacting shells in JLIST C IA1 , IA2 are the indices of interacting shells in NW C C----------------------------------------------------------------------- 130 CONTINUE IA1 = JLIST(JA1) IA2 = JLIST(JA2) KS1 = 2*ABS(NAK(IA1)) KS2 = 2*ABS(NAK(IA2)) C----------------------------------------------------------------------- C C check triangular condition for the active shells C C----------------------------------------------------------------------- IF (ITRIG(KS1,KS2,KK).EQ.1) GOTO 140 IF (IDQ.EQ.2) RETURN GOTO 220 C----------------------------------------------------------------------- C C set tables of quantum numbers of non-interacting spectator shells C C----------------------------------------------------------------------- 140 CONTINUE DO JWW = 1,NS IJ = JLIST(JWW) IF (IJ.EQ.IA1) GOTO 150 DO K = 1,3 JBQ1(K,IJ) = JJQ1(K,IJ) ENDDO C 150 CONTINUE IF (IJ.EQ.IA2) GOTO 160 DO K = 1,3 JBQ2(K,IJ) = JJQ2(K,IJ) ENDDO IF (IJ.EQ.IA1 .OR. IJ.EQ.IA2) GOTO 160 DO K = 1,3 * correction due to Froese Fischer, Gaigalas and Ralchenko (2006) * detected in GRASP92 * IF (JBQ1(K,IJ).NE.JBQ2(K,IJ)) GOTO 250 IF (JBQ1(K,IJ).NE.JBQ2(K,IJ)) GOTO 220 ENDDO 160 CONTINUE ENDDO C----------------------------------------------------------------------- C C ****** loop over parent states ****** C C----------------------------------------------------------------------- IS(1) = IA1 IS(2) = IA2 KS(1) = KS1 KS(2) = KS2 VAL = ZERO KJ23 = 0 IX = 0 FAIL = .FALSE. C**2 NELCTS = NQ2(IA2) L2 = IROW1(NELCTS,KS2) LLS2 = ITAB(L2) LS2 = JTAB(L2) C DO LB = 1,LLS2 LS2 = LS2+3 IT1 = NTAB(LS2) IT2 = KS2 IT3 = JJQ2(3,IA2) IF (ITRIG(IT1,IT2,IT3).EQ.0) GOTO 200 IF (ABS(NTAB(LS2-2)-JJQ2(1,IA2)).NE.1) GOTO 200 DO K = 1,3 JBQ2(K,IA2) = NTAB(LS2+K-3) ENDDO C**1 NELCTS = NQ1(IA1) L1 = IROW1(NELCTS,KS1) LLS1 = ITAB(L1) LS1 = JTAB(L1) C DO LA = 1,LLS1 LS1 = LS1+3 IT1 = NTAB(LS1) IT2 = KS1 IT3 = JJQ1(3,IA1) IF (ITRIG(IT1,IT2,IT3).EQ.0) GOTO 190 IF (ABS(NTAB(LS1-2)-JJQ1(1,IA1)).NE.1) GOTO 190 DO K = 1,3 JBQ1(K,IA1) = NTAB(LS1+K-3) ENDDO C DO K = 1,3 IF (JBQ1(K,IA1).NE.JBQ2(K,IA1)) GOTO 190 IF (JBQ1(K,IA2).NE.JBQ2(K,IA2)) GOTO 190 ENDDO C----------------------------------------------------------------------- C C parent shells now defined C C----------------------------------------------------------------------- CALL FIXJ(JA1,JA2,KA,IS,KS,NS,KJ23) KJ23 = 1 C----------------------------------------------------------------------- C C evaluate recoupling coefficient C C----------------------------------------------------------------------- IF (IX.EQ.0) THEN CALL NJSYM (RECUPS,-1,FAIL) IX = 1 ENDIF C IF (FAIL) GOTO 210 CALL GENSUM (J6C,J7C,J8C,JWC,J6,J7,J8,JW,ICOUNT,J2TEST, + J3TEST,RECUPS) IF (IBUG6.EQ.1) WRITE (IWRITE,3030) RECUPS IF (ABS(RECUPS).LT.EPS10) GOTO 190 C----------------------------------------------------------------------- C C evaluates 2 CFPs C C----------------------------------------------------------------------- IF (KS1.EQ.2) GOTO 170 II = IA1 NEL = NQ1(II) IVP = JBQ1(1,II) IWP = JBQ1(2,II) IJP = JBQ1(3,II)-1 IVD = JJQ1(1,II) IWD = JJQ1(2,II) IJD = JJQ1(3,II)-1 CALL CFP(KS1,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C) IF (IBUG6.EQ.1) WRITE (IWRITE,3020) KS1,NEL,IJD,IVD,IWD,IJP,IV! +P,IWP,C IF (ABS(C).LT.EPS10) GOTO 190 RECUPS = RECUPS*C C 170 CONTINUE IF (KS2.EQ.2) GOTO 180 II = IA2 NEL = NQ2(II) IVD = JJQ2(1,II) IWD = JJQ2(2,II) IJD = JJQ2(3,II)-1 IVP = JBQ2(1,II) IWP = JBQ2(2,II) IJP = JBQ2(3,II)-1 CALL CFP(KS2,NEL,IJD,IVD,IWD,IJP,IVP,IWP,C) IF (IBUG6.EQ.1) WRITE (IWRITE,3020) KS2,NEL,IJD,IVD,IWD,IJP,IV! +P,IWP,C IF (ABS(C).LT.EPS10) GOTO 190 RECUPS = RECUPS*C C 180 CONTINUE VAL = VAL+RECUPS 190 CONTINUE ENDDO 200 CONTINUE ENDDO C C *** end of loop over parent states *** C 210 CONTINUE IF (IDQ.EQ.2) GOTO 230 C----------------------------------------------------------------------- C C ****** IDQ=0 case ****** C C----------------------------------------------------------------------- VSHELL(ISH) = VAL*DBLE(NQ1(IA1)) C----------------------------------------------------------------------- C C loop over all shells when IDQ=0 C C----------------------------------------------------------------------- 220 CONTINUE IF (NPEEL.EQ.0) GOTO 60 DO I = 1,NPEEL JLIST(I) = JLIS(I) ENDDO IF (NPEEL.EQ.1) GOTO 60 NPEELM = NPEEL-1 DO I = 1,NPEELM JJC1(I) = JC1S(I) JJC2(I) = JC2S(I) ENDDO GOTO 60 C----------------------------------------------------------------------- C C ****** IDQ=2 case ****** C C permutation factor for IDQ=2 C C----------------------------------------------------------------------- 230 CONTINUE VAL = VAL*SQRT(DBLE(NQ1(IA1)*NQ2(IA2))) LLD1 = MIN(IA1,IA2)+1 LLD2 = MAX(IA1,IA2) IDL = 1 IF (IA1.LT.IA2) IDL = 0 DO K = LLD1,LLD2 IDL = IDL+NQ1(K) ENDDO IF (MOD(IDL,2).NE.0) VAL = -VAL VSHELL(1) = VAL RETURN C----------------------------------------------------------------------- 240 CONTINUE IF (IBUG6.EQ.1) WRITE (IWRITE,3000) RETURN C----------------------------------------------------------------------- 250 CONTINUE IF (IBUG6.EQ.1) WRITE (IWRITE,3010) C----------------------------------------------------------------------- 3000 FORMAT (' one side has more than one interacting electron') 3010 FORMAT ( ! +' spectator quantum numbers not diagonal for non-interacting she',! +'lls') 3020 FORMAT (' CFP ',I3,I4,I7,2I4,I7,2I4,1P,E20.9) 3030 FORMAT (/' recoupling coeff=',1P,E20.9) 3040 FORMAT (//' ISH=',I3) END C C ******************* C SUBROUTINE TRANS(NWM,NMAN) C C----------------------------------------------------------------------- C C This subroutine calculates the JJ-LS transformation coeficients. C C NWM - number of NR orbitals C NMAN - number of NR CSFs C C Subroutines called : NRCSF C C----------------------------------------------------------------------- C C TRANS C | C NRCSF C | C ------------------------------- C | | | | C LSTERM JCLIST NJSYM JJLS C | C ---------------------- C | | | C SSTC DRACAH GENSUM C | C GENSUM C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) INTEGER NOPENX PARAMETER (NOPENX=4) C C Argument variables C INTEGER NMAN,NWM C C Local variables C INTEGER I,II,J,JF INTEGER JMAN,L,NFULL,NL INTEGER NOP,NOP1,NQ,NST C C Common variables C DOUBLE PRECISION TC(MXNC,MXNC) COMMON / NRD00 / TC C C Common variables C INTEGER JPOS(4),MLX(4),MQX(4),NOPEN COMMON / NRD01 / MLX,MQX,JPOS,NOPEN C C Common variables C INTEGER NLX(MXNW),NPX(MXNW),NQX(MXNW,MXNC) COMMON / NRD03 / NPX,NLX,NQX C C Common variables C INTEGER IPOS(MXNW),KPOS(4,MXNC) INTEGER NPOS(MXNC) COMMON / NRD04 / IPOS,NPOS,KPOS C C Common variables C INTEGER JSCUP(8,MXNC) COMMON / NRD05 / JSCUP C C Common variables C INTEGER JFX(MXNC),KOPEN(MXNC) COMMON / NRD08 / JFX,KOPEN C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER ISPAR(MXNC),ITJPO(MXNC) COMMON / ORB07 / ITJPO,ISPAR Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Set transformation coefficients to zero C DO I = 1,MXNC DO J = 1,MXNC TC(I,J) = ZERO ENDDO ENDDO C DO I = 1,8 DO J = 1,MXNC JSCUP(I,J) = 0 ENDDO ENDDO C C LOOP OVER EACH NON-RELATIVISTIC CONFIGURATION IN TURN C ----------------------------------------------------- C NST = 1 DO JMAN = 1,NMAN NOPEN = KOPEN(JMAN) JF = JFX(JMAN) NCF = NPOS(JMAN) C C SET UP THE ARRAYS MLX,MQX,JPOS C ------------------------------ C NOP = 0 DO I = 1,NWM NL = NLX(I) NQ = NQX(I,JMAN) NFULL = 4*NL+2 IF (NQ.EQ.NFULL .OR. NQ.EQ.0) GOTO 10 NOP = NOP+1 MLX(NOP) = NL MQX(NOP) = NQ JPOS(NOP) = IPOS(I) 10 CONTINUE ENDDO C C FOUR OPEN SHELLS MUST ALWAYS BE DEFINED C AND THE FOLLOWING CODE INCLUDES EXTRA DUMMY ORBITALS C TO ENSURE THIS C IF (NOP.LT.NOPENX) THEN NOP1 = NOP+1 II = 1 DO I = NOP1,NOPENX MLX(I) = 0 MQX(I) = 0 JPOS(I) = NW+II II = II+1 ENDDO ENDIF C C CALCULATE JJ-LS TRANSFORMATION MATRICES C --------------------------------------- C IF (NCF.GE.NST) THEN IF (NOPEN.EQ.0) THEN TC(NCF,NCF) = ONE C ELSE L = NST JF = JF+1 IF (JF.GT.0) THEN CALL NRCSF(L,NCF,JF) C ELSE JF = ITJPO(NST) DO I = NST,NCF IF (ITJPO(I).EQ.JF) GOTO 20 CALL NRCSF(L,I-1,JF) L = I JF = ITJPO(I) 20 CONTINUE ENDDO CALL NRCSF(L,NCF,JF) ENDIF C ENDIF C ENDIF C NST = NCF+1 ENDDO C END C C ******************* C SUBROUTINE VACPOL C C----------------------------------------------------------------------- C C This routine sets up the vacuum polarization potential for a point C charge Z at each grid point using the analytic functions defined by C L. Wayne Fullerton and G. A. Rinker Jr. in Phys. Rev. A Vol 13, page C 1283, (1976). C C Actually R* their potential is tabulated as we shall only require C this when we integrate. C C The potential is accumulated in array TB(I),I=1,N which is in common C block /TATB/. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Statement functions C DOUBLE PRECISION B,CF,D,E DOUBLE PRECISION P C C Parameter variables C DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) DOUBLE PRECISION THREE PARAMETER (THREE=3.D0) DOUBLE PRECISION P0 PARAMETER (P0=-0.71740181754D0) DOUBLE PRECISION P1 PARAMETER (P1=1.1780972274D0) DOUBLE PRECISION P2 PARAMETER (P2=-0.37499963087D0) DOUBLE PRECISION P3 PARAMETER (P3=0.1308967553D0) DOUBLE PRECISION P4 PARAMETER (P4=-0.038258286439D0) DOUBLE PRECISION P5 PARAMETER (P5=-0.0000242972873D0) DOUBLE PRECISION P6 PARAMETER (P6=-0.3592014867D-3) DOUBLE PRECISION P7 PARAMETER (P7=-0.171700907D-4) DOUBLE PRECISION B0 PARAMETER (B0=-64.0514843293D0) DOUBLE PRECISION B1 PARAMETER (B1=0.711722714285D0) DOUBLE PRECISION CF0 PARAMETER (CF0=64.0514843287D0) DOUBLE PRECISION CF1 PARAMETER (CF1=-0.711722686403D0) DOUBLE PRECISION CF2 PARAMETER (CF2=0.0008042207748D0) DOUBLE PRECISION D0 PARAMETER (D0=217.2386409D0) DOUBLE PRECISION D1 PARAMETER (D1=1643.364528D0) DOUBLE PRECISION D2 PARAMETER (D2=2122.244512D0) DOUBLE PRECISION D3 PARAMETER (D3=-45.12004044D0) DOUBLE PRECISION E0 PARAMETER (E0=115.5589983D0) DOUBLE PRECISION E1 PARAMETER (E1=1292.191441D0) DOUBLE PRECISION E2 PARAMETER (E2=3831.198012D0) DOUBLE PRECISION E3 PARAMETER (E3=2904.410075D0) DOUBLE PRECISION XX PARAMETER (XX=163.0D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Local variables C DOUBLE PRECISION FACTOR,X,Y INTEGER I C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C DOUBLE PRECISION XCON1 DOUBLE PRECISION XCON2 DOUBLE PRECISION XCON3 DOUBLE PRECISION XCON4 DOUBLE PRECISION XCL DOUBLE PRECISION XPI DOUBLE PRECISION XTAU COMMON / XCONS / XCON1, XCON2, XCON3, XCON4, XCL, XPI, XTAU Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C The following are the analytic functions needed: C P(X) = P0+X*(P1+X*(P2+X*(P3+X*(P4+X*(P5+X*(P6+X*P7)))))) B(X) = B0+X*(B1+X) CF(X) = CF0+X*(CF1+X*CF2) D(X) = D0+X*(D1+X*(D2+X*(D3+X))) E(X) = E0+X*(E1+X*(E2+X*E3)) C----------------------------------------------------------------------- FACTOR = -(TWO*Z)/(THREE*XPI*XCL) C DO I = 1,N X = TWO*RGRID(I)*XCL IF (X.LE.ONE) THEN Y = X*X TB(I) = FACTOR*(P(X)+LOG(X)*B(Y)/CF(Y)) ELSE IF (X.GE.XX) THEN TB(I) = ZERO ELSE Y = ONE/X TB(I) = FACTOR*EXP(-X)*D(Y)/E(Y)/X**(THREE/TWO) ENDIF ENDIF ENDDO C END C C ******************* C SUBROUTINE VIJOUT(JA,JB,IWRITE) C C----------------------------------------------------------------------- C C Prints out tables of configurational quantum numbers defined C by SETUP for current matrix element. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C CHARACTER*2 IJ1 PARAMETER (IJ1 = '/2') CHARACTER*2 IJ2 PARAMETER (IJ2 = ' ') INTEGER NPLX PARAMETER (NPLX=14) C C Argument variables C INTEGER IWRITE,JA,JB C C Local variables C CHARACTER*2 IC(2) INTEGER I,J,JC(2),JWW C C Common variables C INTEGER JJC1(NPLX),JJC2(NPLX) COMMON / ANG10 / JJC1,JJC2 C C Common variables C INTEGER NQ1(MXNW),NQ2(MXNW) COMMON / ANG11 / NQ1,NQ2 C C Common variables C INTEGER JJQ1(3,MXNW),JJQ2(3,MXNW) COMMON / ANG12 / JJQ1,JJQ2 C C Common variables C INTEGER JLIST(NPLX),KLIST(MXNW),NCORE,NPEEL COMMON / ANG13 / JLIST,KLIST,NPEEL,NCORE Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IF (NPEEL.EQ.0) GOTO 50 C----------------------------------------------------------------------- C C PRINT ACTIVE SHELL QUANTUM NUMBERS C FROM JLIST TABLE C C----------------------------------------------------------------------- WRITE (IWRITE,3000) JA,JB WRITE (IWRITE,3010) C----------------------------------------------------------------------- DO J = 1,NPEEL JWW = JLIST(J) JC(1) = JJQ1(3,JWW)-1 IC(1) = IJ1 IF (MOD(JC(1),2).EQ.1) GOTO 10 JC(1) = JC(1)/2 IC(1) = IJ2 10 CONTINUE JC(2) = JJQ2(3,JWW)-1 IC(2) = IJ1 IF (MOD(JC(2),2).EQ.1) GOTO 20 JC(2) = JC(2)/2 IC(2) = IJ2 20 CONTINUE WRITE (IWRITE,3020) JWW,NQ1(JWW),JJQ1(1,JWW),JJQ1(2,JWW),JC(1),I! +C(1),NQ2(JWW),JJQ2(1,JWW),JJQ2(2,JWW),JC(2),IC(2) ENDDO C----------------------------------------------------------------------- IF (NPEEL.LT.2) GOTO 50 C----------------------------------------------------------------------- C C PRINT COUPLING ANGULAR MOMENTA C IF NPEEL.GE.2 C C----------------------------------------------------------------------- WRITE (IWRITE,3030) C----------------------------------------------------------------------- DO J = 2,NPEEL JC(1) = JJC1(J-1)-1 IC(1) = IJ1 IF (MOD(JC(1),2).EQ.1) GOTO 30 JC(1) = JC(1)/2 IC(1) = IJ2 30 CONTINUE JC(2) = JJC2(J-1)-1 IC(2) = IJ1 IF (MOD(JC(2),2).EQ.1) GOTO 40 JC(2) = JC(2)/2 IC(2) = IJ2 40 CONTINUE WRITE (IWRITE,3040) (JC(I),IC(I),I=1,2) ENDDO C----------------------------------------------------------------------- 50 CONTINUE WRITE (IWRITE,3050) NCORE C----------------------------------------------------------------------- 3000 FORMAT (//' Configuration(',I3,') -',23X,'Configuration(',I3, ! +') -'//) 3010 FORMAT (6X,'Shell',4X,'Q',4X,'V',2X,'W',2X,'J',19X,'Q',4X,'V',2X, ! +'W',2X,'J'//) 3020 FORMAT (7X,I3,I6,I5,2I3,A2,15X,I3,I5,2I3,A2) 3030 FORMAT (//' Coupling schemes - ') 3040 FORMAT (14X,I2,A2,27X,I2,A2) 3050 FORMAT (//' There are ',I3,' inactive closed shells.'/) END C C ******************* C FUNCTION XA(JA,JB,K) C C----------------------------------------------------------------------- C C Determine coefficient required for XPOT. C C Subroutines called : CLRX C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION XA INCLUDE 'grasp0.inc' C C External functions C EXTERNAL CLRX DOUBLE PRECISION CLRX C C Parameter variables C INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) C C Argument variables C INTEGER JA,JB,K C C Local variables C DOUBLE PRECISION COEF,WA,WX INTEGER ICOEF,IFA,IFB,IL INTEGER ILCX,ILDA,ILDB,ILDN INTEGER IQA,IQB,IRS,ITR INTEGER KA,KB C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C integer jtc(20) common / opt02 / jtc C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IFA = NKJ(JA)+1 IFB = NKJ(JB)+1 KA = NAK(JA) KB = NAK(JB) WA = ZERO ICOEF = 0 C DO ITR = 1,NCF IQA = IQ(JA,ITR) IQB = IQ(JB,ITR) IF (IQA.LT.IFA .AND. IQB.LT.IFB .and. jtc(13).ne.0) GOTO 10 !nrb C C One orbital is in closed shell C IF (ICOEF.EQ.0) THEN COEF = CLRX(KA,K,KB)**2 ICOEF = 1 ENDIF C WX = -IQA*IQB*COEF GOTO 30 C C Both orbitals are in open shells C 10 CONTINUE IF (NMCP.EQ.0) GOTO 40 IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR ILDN = NNLDR(IRS) IF (ILDN.LE.0) GOTO 40 ILDA = NSLDF(IRS) ILDB = ILDA+ILDN-1 C C Form code number C IF (JA.GT.JB) THEN ILCX = (((K*NW1+JB)*NW1+JA)*NW1+JA)*NW1+JB ELSE ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JB)*NW1+JA ENDIF C DO IL = ILDA,ILDB IF (ILCX.EQ.ISLDR(IL)) GOTO 20 ENDDO GOTO 40 C 20 CONTINUE WX = XSLDR(IL) C 30 CONTINUE WA = WA+WX*COUENG(ITR)*COUENG(ITR) 40 CONTINUE ENDDO C XA = WA/UCF(JA) END C C ******************* C SUBROUTINE XB(JC,JB,JD,K,WA) C C----------------------------------------------------------------------- C C This subroutine is called by subroutine XPOT to accumulate C a list of the terms involved in tabulating exchange C potentials. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Argument variables C DOUBLE PRECISION WA INTEGER JB,JC,JD,K C C Local variables C INTEGER I,ILCX C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION CXCF(MXNE) INTEGER JXCF(MXNE),NSCF,NSCFY COMMON / MCPC / CXCF,JXCF,NSCF,NSCFY Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- ILCX = ((K*NW1+JD)*NW1+JB)*NW1+JC C C If list is empty, add entry and set NSCF=1 C IF (NSCF.LE.0) GOTO 10 DO I = 1,NSCF C C Test if term already present C IF (ILCX.EQ.JXCF(I)) GOTO 20 ENDDO C C If term not present, add new entry to table C 10 CONTINUE NSCF = NSCF+1 IF (NSCF.GT.MXNE) GOTO 30 IF (NSCF.GT.NSCFY) NSCFY = NSCF JXCF(NSCF) = ILCX CXCF(NSCF) = WA RETURN C C If term already present, add new coefficient to entry C 20 CONTINUE CXCF(I) = CXCF(I)+WA RETURN C 30 CONTINUE WRITE (IWRITE,3000) WRITE (IPUNCH,3000) STOP C 3000 FORMAT (/' ERROR in XB : dimension of NSCF ... STOPPING'/ ! +' Increase the value of MXNE') END C C ******************* C SUBROUTINE XPOT(J,XCF,ALX,ALY) C C----------------------------------------------------------------------- C C This subroutine tabulates the exchange terms XP(R) and XQ(R). C C Data C C J : serial number of orbital C XCF : scale factor for multipying exchange terms C C Results C C XTP,XTQ : arrays containing exchange terms C ALX,ALY : leading coefficients in the expansions of the exchange C terms in powers of R C C Subroutines called : XA,XB,QUAD,YZK C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL XA DOUBLE PRECISION XA C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N10 PARAMETER (N10=MXNX*MXNC) INTEGER N11 PARAMETER (N11=MXNP+10) INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) C C Argument variables C DOUBLE PRECISION ALX,ALY,XCF INTEGER J C C Local variables C DOUBLE PRECISION RESULT,TOT,WA INTEGER I,IA,IB,ICF INTEGER ICFP,IJ,IJLB,IJLC INTEGER IJLD,IL,ILCX,ILDN INTEGER IRS,ITR,JAA,JBB INTEGER JJ,JLA,JLB,JLC INTEGER JLD,JTR,K,KA INTEGER KL,KM,KN,L INTEGER NCFM,NGRID,NGRID1,NKLNKJ INTEGER NKTEST C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER ICCMIN(MXNC),NCMIN COMMON / DEF07 / NCMIN,ICCMIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION PZ(MXNW),QZ(MXNW) COMMON / EXCO / PZ,QZ C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C DOUBLE PRECISION XF(MXNP),XG(MXNP),XR(MXNP) DOUBLE PRECISION XS(MXNP),XU(MXNP),XV(MXNP) COMMON / INT3 / XU,XV,XR,XS,XF,XG C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C DOUBLE PRECISION CXCF(MXNE) INTEGER JXCF(MXNE),NSCF,NSCFY COMMON / MCPC / CXCF,JXCF,NSCF,NSCFY C C Common variables C DOUBLE PRECISION ECV(MXNO) INTEGER IECC(MXNO),NEC COMMON / OFFD / ECV,IECC,NEC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION CCR(N10),CHK(N10) COMMON / SEMI / CHK,CCR C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C clear for accumulation of sums C ALX = ZERO ALY = ZERO DO I = 1,N XTP(I) = ZERO XTQ(I) = ZERO ENDDO C IF (XCF.LT.EPS10) RETURN C----------------------------------------------------------------------- C C sum over all orbitals, avoiding serial number J C DO L = 1,NW C IF (JFIX(J).EQ.1 .AND. JFIX(L).EQ.0) GOTO 80 IF (L.EQ.J) GOTO 80 C C tabulate mixed density C NGRID = MIN(MPOIN(J),MPOIN(L)) IJ = MPOS(J) IL = MPOS(L) DO I = 1,NGRID XU(I) = PF(IJ)*PF(IL)+QF(IJ)*QF(IL) XV(I) = XU(I)*RGRID(I) IJ = IJ+1 IL = IL+1 ENDDO C C determine bounds for summation over K C KM = (NKJ(J)+NKJ(L))/2 KN = ABS(NKJ(J)-NKJ(L))/2 NKLNKJ = NAK(L)*NAK(J) C IF (NKLNKJ.LT.0) GOTO 50 C C tabulate integrand for expansion coefficients C IF (NKLNKJ.GT.NAK(J)**2) GOTO 60 C IF (KN-1) 10,20,30 10 CONTINUE DO I = 1,NGRID TA(I) = XU(I) ENDDO GOTO 40 C 20 CONTINUE DO I = 1,NGRID TA(I) = XU(I)/RGRID(I) ENDDO GOTO 40 C 30 CONTINUE DO I = 1,NGRID TA(I) = XU(I)/(RGRID(I)**KN) ENDDO C 40 CONTINUE CALL QUAD(NGRID,RESULT) WA = XA(J,L,KN)*XCF/C C IF (ABS(WA).LT.EPS10) GOTO 60 ALX = ALX+RESULT*QZ(L)*WA ALY = ALY-RESULT*PZ(L)*WA GOTO 60 C 50 CONTINUE KN = KN+1 C 60 CONTINUE DO K = KN,KM,2 C WA = XA(J,L,K) WA = WA*XCF/C C IF (ABS(WA).LT.EPS10) GOTO 70 C C form integrand for subroutine YZK C DO I = 1,NGRID TA(I) = XV(I) ENDDO C C tabulate function YK(R) C CALL YZK(NGRID,K) C C add contributions from exchange terms C IL = MPOS(L) DO I = 1,NGRID XTP(I) = XTP(I)+TB(I)*QF(IL)*WA XTQ(I) = XTQ(I)-TB(I)*PF(IL)*WA IL = IL+1 ENDDO C 70 CONTINUE ENDDO C C add contributions from off-diagonal parameters C ---------------------------------------------- C IF (NEC.GT.0) THEN C IF (J.LT.L) THEN KA = NW1*L+J ELSE KA = NW1*J+L ENDIF C DO I = 1,NEC IF (IECC(I).EQ.KA) THEN C WA = ECV(I)*XCF/(UCF(J)*C) C IF (ABS(WA).GT.EPS10) THEN C C add contribution to leading coefficients C ALX = ALX+WA*QZ(L) ALY = ALY-WA*PZ(L) C C add contributions to exchange terms C KL = MPOS(L) DO K = 1,NGRID XTP(K) = XTP(K)+WA*QF(KL)*RGRID(K) XTQ(K) = XTQ(K)-WA*PF(KL)*RGRID(K) KL = KL+1 ENDDO C ENDIF C ENDIF ENDDO C ENDIF C 80 CONTINUE ENDDO C----------------------------------------------------------------------- C C add contributions from open shell orbitals C ------------------------------------------ C IF (NCMIN.EQ.0) RETURN IF (NMCP.EQ.0) RETURN C NSCF = 0 NCFM = NCF-1 DO ITR = 1,NCFM ICFP = ITR+1 DO JTR = ICFP,NCF IRS = (ITR-1)*(NCF+NCF-ITR)/2+JTR ILDN = NNLDR(IRS) C IF (ILDN.GT.0) THEN JAA = NSLDF(IRS) JBB = JAA+ILDN-1 DO JJ = JAA,JBB C C extract quantum number from coded forms C ILCX = ISLDR(JJ) JLA = MOD(ILCX,NW1) ILCX = ILCX/NW1 JLB = MOD(ILCX,NW1) ILCX = ILCX/NW1 JLC = MOD(ILCX,NW1) IF (JLC.EQ.0) GOTO 90 ILCX = ILCX/NW1 JLD = MOD(ILCX,NW1) K = ILCX/NW1 C IF (NCMIN.LE.1) THEN WA = XSLDR(JJ)*COUENG(ITR)*COUENG(JTR) ELSE TOT = ZERO IA = ITR IB = JTR DO I = 1,NCMIN TOT = TOT+CCR(IA)*CCR(IB) IA = IA+NCF IB = IB+NCF ENDDO WA = XSLDR(JJ)*TOT/NCMIN ENDIF C C accumulate coefficients from each of the four parameters C in turn C IF (JLA.EQ.J) CALL XB(JLC,JLB,JLD,K,WA) IF (JLB.EQ.J) CALL XB(JLD,JLA,JLC,K,WA) IF (JLC.EQ.J) CALL XB(JLA,JLB,JLD,K,WA) IF (JLD.EQ.J) CALL XB(JLB,JLA,JLC,K,WA) 90 CONTINUE ENDDO ENDIF C ENDDO ENDDO C----------------------------------------------------------------------- IF (NSCF.GT.0) THEN C C retrieve successive terms C DO ICF = 1,NSCF ILCX = JXCF(ICF) JLC = MOD(ILCX,NW1) IF (JFIX(J).EQ.1 .AND. JFIX(JLC).EQ.0) GOTO 150 ILCX = ILCX/NW1 JLB = MOD(ILCX,NW1) IF (JFIX(J).EQ.1 .AND. JFIX(JLB).EQ.0) GOTO 150 ILCX = ILCX/NW1 JLD = MOD(ILCX,NW1) IF (JFIX(J).EQ.1 .AND. JFIX(JLD).EQ.0) GOTO 150 K = ILCX/NW1 C C determine coefficient C WA = CXCF(ICF)*XCF/(C*UCF(J)) C IF (ABS(WA).GE.EPS10) THEN C C form integrand for subroutine YZK C NGRID = MIN(MPOIN(JLB),MPOIN(JLD)) IJLB = MPOS(JLB) IJLD = MPOS(JLD) DO I = 1,NGRID TA(I) = (PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD))*RGRID(I)*WA IJLB = IJLB+1 IJLD = IJLD+1 ENDDO C C tabulate YK(R) C CALL YZK(NGRID,K) C C add contributions to exchange terms C ----------------------------------- C NGRID1 = MIN(NGRID,MPOIN(JLC)) IJLC = MPOS(JLC) DO I = 1,NGRID1 XTP(I) = XTP(I)+TB(I)*QF(IJLC) XTQ(I) = XTQ(I)-TB(I)*PF(IJLC) IJLC = IJLC+1 ENDDO C C add contributions to leading coefficients C ----------------------------------------- C NKTEST = NAK(JLC)*NAK(J) IF (NKTEST.GT.NAK(J)**2) GOTO 140 IF (NKTEST.LT.0) GOTO 140 IF (K.GT.ABS(NAK(J)-NAK(JLC))) GOTO 140 C NGRID = MIN(MPOIN(JLB),MPOIN(JLD)) IJLB = MPOS(JLB) IJLD = MPOS(JLD) C IF (K-1) 100,110,120 C 100 CONTINUE DO I = 1,NGRID TA(I) = PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD) IJLB = IJLB+1 IJLD = IJLD+1 ENDDO GOTO 130 C 110 CONTINUE DO I = 1,NGRID TA(I) = (PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD))/RGRID(I) IJLB = IJLB+1 IJLD = IJLD+1 ENDDO GOTO 130 C 120 CONTINUE DO I = 1,NGRID TA(I) = (PF(IJLB)*PF(IJLD)+QF(IJLB)*QF(IJLD))/(RGRID(I)**K! +) IJLB = IJLB+1 IJLD = IJLD+1 ENDDO C 130 CONTINUE CALL QUAD(NGRID,RESULT) ALX = ALX+RESULT*QZ(JLC)*WA ALY = ALY-RESULT*PZ(JLC)*WA C 140 CONTINUE ENDIF C 150 CONTINUE ENDDO ENDIF C END C C ******************* C FUNCTION YA(JA,JB,K) C C----------------------------------------------------------------------- C C Determine coefficient required by YPOT. C C Subroutines called : CLRX C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE DOUBLE PRECISION YA INCLUDE 'grasp0.inc' C C External functions C EXTERNAL CLRX DOUBLE PRECISION CLRX C C Parameter variables C INTEGER N18 PARAMETER (N18=MXNC*(MXNC+1)/2) C C Argument variables C INTEGER JA,JB,K C C Local variables C DOUBLE PRECISION COEF,WA,WX INTEGER ICOEF,IFA,IFB,IL INTEGER ILCX,ILDA,ILDB,ILDN INTEGER IQA,IQB,IRS,ITR INTEGER KA C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C DOUBLE PRECISION XSLDR(MXNM) INTEGER ISLDR(MXNM),NMCP COMMON / MCPA / XSLDR,ISLDR,NMCP C C Common variables C INTEGER NNLDR(N18),NSLDF(N18) COMMON / MCPB / NNLDR,NSLDF C C Common variables C integer jtc(20) common / opt02 / jtc C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- IFA = NKJ(JA)+1 IFB = NKJ(JB)+1 KA = NAK(JA) WA = ZERO ICOEF = 0 C DO ITR = 1,NCF IQA = IQ(JA,ITR) IQB = IQ(JB,ITR) IF (IQA.LT.IFA .AND. IQB.LT.IFB .and. jtc(13).ne.0) GOTO 10 !nrb C C One orbital is in a closed shell C IF (JA.NE.JB.or.iqa.eq.0) GOTO 40 IF (ICOEF.EQ.0) THEN COEF = CLRX(KA,K,KA)**2 ICOEF = 1 ENDIF C WX = -IQA*IQA*COEF c c mod for pure SCF run with no use of MCP.DAT data - nrb 25/09/09 c if(jtc(13).eq.0.and.iqa.lt.ifa)then wx=wx*dble(ifa*(iqa-1))/dble((ifa-1)*iqa) endif c GOTO 30 C C Both orbitals are in open shells C 10 CONTINUE IF (NMCP.EQ.0) GOTO 40 IRS = (ITR-1)*(NCF+NCF-ITR)/2+ITR ILDN = NNLDR(IRS) IF (ILDN.LE.0) GOTO 40 ILDA = NSLDF(IRS) ILDB = ILDA+ILDN-1 C C Construct code number C IF (JA.GT.JB) THEN ILCX = (((K*NW1+JB)*NW1+JA)*NW1+JB)*NW1+JA ELSE ILCX = (((K*NW1+JA)*NW1+JB)*NW1+JA)*NW1+JB ENDIF C C Hunt in table C DO IL = ILDA,ILDB IF (ILCX.EQ.ISLDR(IL)) GOTO 20 ENDDO GOTO 40 C 20 CONTINUE WX = XSLDR(IL) IF (JA.EQ.JB) WX = WX + WX C 30 CONTINUE WA = WA+WX*COUENG(ITR)*COUENG(ITR) 40 CONTINUE ENDDO C YA = WA/UCF(JA) C END C C ******************* C SUBROUTINE YBRA(NGRID,K) C C----------------------------------------------------------------------- C C This routine calculates the function Y(K BAR) occuring in the C computation of Breit interaction integrals. This function is C calculated by the same outward integration used to compute the C function Z in the evaluation of Slater integrals. C C The function Y(K BAR) is returned in the array TB C C Data C C TA : common array containing a table of the integrand, F(R). C K : value of K. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS30 PARAMETER (EPS30=1.D-30) DOUBLE PRECISION Y0 PARAMETER (Y0=13.D0/24.D0) DOUBLE PRECISION Y1 PARAMETER (Y1=1.D0/24.D0) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER K,NGRID C C Local variables C DOUBLE PRECISION FK,FL,RATIO,WA DOUBLE PRECISION WB,WC,WD,WE INTEGER I,J C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C Find estimate for initial slope from first two non-zero values of TA C DO J = 1,NGRID TB(J) = ZERO ENDDO C DO J = 1,NGRID IF (ABS(TA(J)).LT.EPS30) GOTO 10 RATIO = TA(J+1)/TA(J) IF (RATIO.GT.ZERO) GOTO 20 10 CONTINUE ENDDO RETURN C 20 CONTINUE FL = LOG(RATIO)/H FK = DBLE(K) WA = FK+FL C C Two starting values for outward integration C TB(1) = TA(1)/WA TB(2) = TA(2)/WA C C Coefficients in outward recurrence relation C WA = EXP(-FK*H) WD = Y0*H WC = WD*WA WE = -Y1*H WB = WE*WA*WA WE = WE/WA C C Add two extra zeros at end of table C TA(NGRID+2) = ZERO TA(NGRID+1) = ZERO C C Outward integration C DO I = 2,NGRID TB(I+1) = WA*TB(I)+WB*TA(I-1)+WC*TA(I)+WD*TA(I+1)+WE*TA(I+2) ENDDO C END C C ******************* C SUBROUTINE YPOT(J,VN,ZFAC) C C----------------------------------------------------------------------- C C This subroutine tabulates the potential function Y(R) for orbital J. C The function is tabulated in the arrays YP and YQ. Also VN is C calculated. VN is the second term in the expansion of Y(R) C Y(R)= Z+VN*R + ... C C Subroutines called : YA, QUAD, YZK C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C External functions C EXTERNAL YA DOUBLE PRECISION YA C C Parameter variables C DOUBLE PRECISION EPS10 PARAMETER (EPS10=1.D-10) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C DOUBLE PRECISION VN,ZFAC INTEGER J C C Local variables C DOUBLE PRECISION QA,QB,WA,WX INTEGER I,IL,K,KB INTEGER KBA,L,NGRID C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION BREENG(MXNC),COUENG(MXNC) COMMON / ENRG1 / COUENG,BREENG C C Common variables C INTEGER JFIX(MXNW) COMMON / FIXD / JFIX C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C DOUBLE PRECISION PARM(4),Z1 INTEGER NPARM,NUCTYP COMMON / NPAR / PARM,Z1,NUCTYP,NPARM C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION XTP(MXNP),XTQ(MXNP),YP(MXNP) DOUBLE PRECISION YQ(MXNP) COMMON / POTE / YP,YQ,XTP,XTQ C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C clear for total density C DO I = 1,N TA(I) = ZERO ENDDO C C loop over the orbitals C DO L = 1,NW C IF (JFIX(J).EQ.1 .AND. JFIX(L).EQ.0) GOTO 10 C WA = ZERO DO I = 1,NCF QA = DBLE(IQ(J,I)) QB = DBLE(IQ(L,I)) WX = QA*QB IF (L.EQ.J) WX = WX - QA WA = WA+COUENG(I)*COUENG(I)*WX ENDDO WA = WA/UCF(J) C C add contribution to density C IF (ABS(WA).GE.EPS10) THEN NGRID = MPOIN(L) IL = MPOS(L) DO I = 1,NGRID TA(I) = TA(I)+(PF(IL)*PF(IL)+QF(IL)*QF(IL))*WA IL = IL+1 ENDDO ENDIF C 10 CONTINUE ENDDO C C compute VN C ---------- C CALL QUAD(N,VN) VN = -VN+Z1*ZFAC C C tabulate integrand for subroutine YZK C DO I = 1,N TA(I) = TA(I)*RGRID(I) ENDDO C C result includes all terms with K = 0 C CALL YZK(N,0) DO I = 1,N YP(I) = ZZ(I)*ZFAC-TB(I) ENDDO C C now compute other values of K C ----------------------------- C KB = NKJ(J)-1 DO L = 1,NW IF (JFIX(J).EQ.1 .AND. JFIX(L).EQ.0) GOTO 20 C KBA = NKJ(L)-1 IF (KB.LT.KBA) KBA = KB C IF (KBA.GT.0) THEN DO K = 2,KBA,2 WA = YA(J,L,K) C IF (ABS(WA).GE.EPS10) THEN C C tabulate integrand C NGRID = MPOIN(L) IL = MPOS(L) DO I = 1,NGRID TA(I) = WA*RGRID(I)*(PF(IL)*PF(IL)+QF(IL)*QF(IL)) IL = IL+1 ENDDO C C form YK(R) C CALL YZK(NGRID,K) C C add contribution to Y(R) C DO I = 1,NGRID YP(I) = YP(I)-TB(I) ENDDO ENDIF C ENDDO ENDIF C 20 CONTINUE ENDDO C DO I = 1,N YQ(I) = YP(I) ENDDO C END C C ******************* C SUBROUTINE YPOTX C C----------------------------------------------------------------------- C C This subroutine evaluates the static potential. C C Subroutines called : YZK C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C INTEGER N11 PARAMETER (N11=MXNP+10) C C Local variables C DOUBLE PRECISION DGZ,EXCESS,STEP1,STEP2 INTEGER I,IJ,J,NGRID INTEGER NLAST C C Common variables C DOUBLE PRECISION HALF,ONE,TEN,TENTH DOUBLE PRECISION THREE,TWO,ZERO COMMON / CONS / ZERO,HALF,TENTH,ONE,TWO,THREE,TEN C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION RGRID(MXNP) COMMON / GRID / RGRID C C Common variables C DOUBLE PRECISION EAV,UCF(MXNW) COMMON / HMAT / EAV,UCF C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C DOUBLE PRECISION ZZ(MXNP) COMMON / NPOT / ZZ C C Common variables C INTEGER ITC(50) COMMON / OPT01 / ITC C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER MPOIN(MXNW),MPOS(MXNW) COMMON / PATY / MPOIN,MPOS C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB C C Common variables C DOUBLE PRECISION PF(MXNG),QF(MXNG) COMMON / WAVE / PF,QF Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- WRITE (IWRITE,3000) C DO I = 1,N TA(I) = ZERO ENDDO C DO J = 1,NW IJ = MPOS(J) NGRID = MPOIN(J) DO I = 1,NGRID TA(I) = TA(I)+UCF(J)*(PF(IJ)*PF(IJ)+QF(IJ)*QF(IJ)) IJ = IJ+1 ENDDO ENDDO C DO I = 1,N TA(I) = TA(I)*RGRID(I) ENDDO C----------------------------------------------------------------------- STEP1 = RGRID(2)-RGRID(1) STEP2 = RGRID(N)-RGRID(N-1) WRITE (IWRITE,3040) N,H,EPH,RGRID(1),RGRID(N),STEP1,STEP2 C CALL YZK(N,0) C DO I = 1,N TA(I) = TB(I)-ZZ(I) ENDDO C----------------------------------------------------------------------- C C Write out the logarithmic grid and static potential. C IF (ITC(42).EQ.1) THEN WRITE (IWRITE,3010) (RGRID(I),I=1,N) WRITE (IWRITE,3020) (TA(I),I=1,N) WRITE (IWRITE,3030) (TB(I),I=1,N) ENDIF C WRITE (IWRITE,3060) TA(N) WRITE (IWRITE,3070) ZZ(N) C DGZ = Z DO I = 1,NW DGZ = DGZ-IQ(I,1) ENDDO C EXCESS = TA(N)+DGZ WRITE (IWRITE,3050) EXCESS C NLAST = MPOS(NW)+MPOIN(NW)-1 C WRITE (IWRITE,3080) NLAST,MXNG,N,MXNP C----------------------------------------------------------------------- 3000 FORMAT (/' >>>> routine YPOTX called') 3010 FORMAT (/' log grid'/' --------'/(1X,1P,6E12.4)) 3020 FORMAT (/' static potential'/1X,16('-')/(1X,1P,6E12.4)) 3030 FORMAT (/' total charge'/1X,16('-')/(1X,1P,6E12.4)) 3040 FORMAT (/' logarithmic grid is defined as follows :'// ! +' N (number of points) = ',I4/' H (stepsize) = '! +,1P,E12.5/' EXP(H) = ',E12.5/ ! +' first grid point (RNT) = ',E12.5/ ! +' last grid point = ',E12.5/ ! +' initial stepsize = ',E12.5/ ! +' final stepsize = ',E12.5) 3050 FORMAT (' excess (static potential+residual charge) = ',1P,E14.7) 3060 FORMAT (/' last point in static potential = ',1P,E14.7) 3070 FORMAT (' last point in nuclear potential = ',1P,E14.7) 3080 FORMAT (/' number of w.f. points = ',I7, ! +' (max=',I7,')'/ ! +' number of grid points = ',I7,' (max=',! +I7,')') END C C ******************* C SUBROUTINE YZK(NGRID,K) C C----------------------------------------------------------------------- C C This subroutine evaluates potentials Y(K,R) which are used to form C the SCF potentials and Slater integrals. C Y(K,R)=R*I C where I<> denotes the integral from zero to infinity over S C If Z(K,R)=J/R**K where J<> denotes the integral from C zero to R over S, then we can obtain a pair of coupled equations C for Y and Z. These are solved , outward for Z and inward for Y. C C initially : TA contains S*F(S) for I=1,..,NGRID C finally : TB contains Y(K,R) for I=1,..,NGRID C C Note that the array TA is zero for I>NGRID with the point being C controlled by the parameter CUTOFF. Therefore it is assumed C that when the point NGRID is reached C Y = Z = CONSTANT/R**K C This is also assumed for the point NGRID-1. C C TA is tabulated to N+2 C TB is tabulated to N+3 C TC is tabulated to N+2 C C This version uses a five point central difference formula, C which corresponds to Simpson's rule plus a correction to give C an error varying as O(H**6). The method thus steps two points C at once, and the errors at odd and even points are independent. C The method is described by Charlotte Froese Fischer in her book C 'The Hartree Fock Method For Atoms', Wiley, 1977. However this C routine does not subtract the error in the Z0 function at large C R from the value of Z0 at all R. In the MCDF programs RNT C is usually 1.0E-5, which is much smaller than in MCHF. In this C case the use of an expansion technique for ZK at small R C introduces no significant error, and the accuracy of the Z0 C functions at large R is limited by the precision of the computer. C This routine may need to be modified if RNT is to be increased C beyond 1.0E-3. C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS35 PARAMETER (EPS35=1.D-35) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.D0) DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION THREE PARAMETER (THREE=3.D0) DOUBLE PRECISION FOUR PARAMETER (FOUR=4.D0) DOUBLE PRECISION THIRD PARAMETER (THIRD=ONE/THREE) DOUBLE PRECISION YY0 PARAMETER (YY0=-1.D0/9.D1) DOUBLE PRECISION YY1 PARAMETER (YY1=-3.4D1) DOUBLE PRECISION YY2 PARAMETER (YY2=-1.14D2) INTEGER N11 PARAMETER (N11=MXNP+10) C C Argument variables C INTEGER K,NGRID C C Local variables C DOUBLE PRECISION CA,CB,CC,CD DOUBLE PRECISION CE,EMP,FK,FL DOUBLE PRECISION RATIO,TC(N11),WA,WB DOUBLE PRECISION WC,WK,WKL,WKS DOUBLE PRECISION XA,XB,YA,YB DOUBLE PRECISION YC,YD,YE INTEGER I,J C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C DOUBLE PRECISION TA(N11),TB(N11) COMMON / TATB / TA,TB Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- C C find the power dependence of TA near the origin C DO J = 1,NGRID IF (ABS(TA(J)).LT.EPS35) GOTO 10 RATIO = TA(J+1)/TA(J) IF (RATIO.GT.ZERO) GOTO 20 10 CONTINUE ENDDO do j=1,ngrid tb(j)=zero enddo RETURN C 20 CONTINUE FL = LOG(RATIO)/H EMP = ONE/EPH WA = EMP**FL C C copy TA into TB. Move elements by one to allow a zeroth C element to be included. C TB(1) = WA*TA(1) DO I = 1,NGRID TB(I+1) = TA(I) ENDDO C TB(NGRID+2) = ZERO TB(NGRID+3) = ZERO C C set up constants for integration C C Simpson's rule C CB = H*THIRD CA = CB*FOUR C C five point central difference formula C CC = H*YY0 CD = YY1*CC CE = YY2*CC C FK = K C C solve equations for Z(K,R) outwards C TA contains Z(K,R) C WK = EMP**FK WKS = WK*WK WA = CB*WKS WB = CA*WK WC = CB C YA = CC*WKS*WK YB = CD*WKS YC = CE*WK YD = CD YE = CC/WK C C start outwards integration by using the power dependence C of TA at the first two points, then Simpson's rule at C the third C WKL = ONE/(FK+FL) TA(1) = TB(1)*WKL TA(2) = TB(2)*WKL TA(3) = WKS*TA(1)+WA*TB(1)+WB*TB(2)+WC*TB(3) C C main outwards integration using five point central formula C DO J = 4,NGRID+2 TC(J) = YA*TB(J-3)+YB*TB(J-2)+YC*TB(J-1)+YD*TB(J)+YE*TB(J+1) ENDDO C DO J = 4,NGRID+2 TA(J) = WKS*TA(J-2)+TC(J) ENDDO C C complete the table using Z=Y=CONSTANT/R**K C IF (NGRID+2.LT.N) THEN DO I = NGRID+3,N+1 TA(I) = TA(I-1)*WK ENDDO DO I = NGRID+1,N TB(I) = TA(I+1) ENDDO ENDIF C C solve equations for Y(K,R) inwards C TB contains Y(K,R) C WK = WK*EMP WKS = WK*WK XB = FK+FK+ONE XA = XB*WK C WA = CB*XA*WK WB = CA*XA WC = CA*XB C YA = CC*XA*WKS YB = CD*XA*WK YC = CE*XA YD = CD*XB YE = CC*XB/WK C C main integration with five point central difference C TB(NGRID) = TA(NGRID+1) TB(NGRID-1) = TA(NGRID) DO J = NGRID-2,2,-1 TC(J) = YA*TA(J+4)+YB*TA(J+3)+YC*TA(J+2)+YD*TA(J+1)+YE*TA(J) ENDDO C DO J = NGRID-2,2,-1 TB(J) = WKS*TB(J+2)+TC(J) ENDDO C C complete inward integration with Simpson's rule for first point C TB(1) = WKS*TB(3)+WA*TA(4)+WB*TA(3)+WC*TA(2) C END C C ******************* C SUBROUTINE ZEFR(J,R,ZE) C C----------------------------------------------------------------------- C C This subroutine calculates an effective charge ZE such C that in a coulomb field of charge ZE the mean radius C of orbital J is equal to the input value R . C Find ZE such that -R=0 C The Newton method is used with accuracy EPS6 and maximum C number of iterations ITR . c c Fix for L-spinors - nrb 09/01/08 c C C No subroutines called. C C----------------------------------------------------------------------- Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc IMPLICIT NONE INCLUDE 'grasp0.inc' C C Parameter variables C DOUBLE PRECISION EPS5 PARAMETER (EPS5=1.D-5) DOUBLE PRECISION EPS6 PARAMETER (EPS6=1.D-6) INTEGER ITR PARAMETER (ITR=30) C C Argument variables C DOUBLE PRECISION R,ZE INTEGER J C C Local variables C DOUBLE PRECISION A(3),B(3),BN,FK DOUBLE PRECISION FKS,FNR,WA,WB INTEGER I,II,K,L INTEGER MK,NN,NNS C C Common variables C DOUBLE PRECISION ACCY,C,EPH,H DOUBLE PRECISION RNT,Z INTEGER N,NCPRIN,NW1 COMMON / DEF01 / Z,RNT,H,EPH,ACCY,C,N,NW1,NCPRIN C C Common variables C INTEGER IPUNCH,IREAD,IWRITE COMMON / INFORM / IREAD,IWRITE,IPUNCH C C Common variables C CHARACTER*2 NH(MXNW) COMMON / ORB00 / NH C C Common variables C INTEGER IQ(MXNW,MXNC),NAK(MXNW),NCF INTEGER NP(MXNW),NW COMMON / ORB04 / NW,NCF,NP,NAK,IQ C C Common variables C INTEGER NKJ(MXNW),NKL(MXNW) COMMON / ORB05 / NKL,NKJ Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NN = NP(J) K = NAK(J) L = NKL(J) MK = ABS(K) NNS = NN*NN C C Initial estimate using non-relativistic formula. C A(3) = DBLE(NNS+NNS+NNS-L*(L+1))/(R+R) FK = DBLE(K) FKS = FK*FK FNR = DBLE(NN-MK) C C Begin iterations on the relativistic formula. C I = 1 10 CONTINUE A(1) = A(3)-EPS5 A(2) = A(3)+EPS5 DO II = 1,3 WA = A(II)/C WA = WA*WA if(fks-wa.lt.0)go to 50 !catch L-spinors WB = SQRT(FKS-WA)+FNR WA = WB*WB+WA if(wa.lt.0)go to 50 !catch L-spinors BN = SQRT(WA) WA = WB*(WA+WA+WA-FKS)-BN*FK WB = A(II)*BN B(II) = WA/(WB+WB)-R ENDDO WB = A(3) WA = EPS5*B(3)/(B(2)-B(1)) A(3) = A(3)-(WA+WA) IF (ABS(A(3)-WB)-EPS6) 40,40,20 20 CONTINUE I = I+1 IF (I-ITR) 10,10,30 30 CONTINUE WRITE (IWRITE,3000) NP(J),NH(J) C 40 CONTINUE ZE = A(3) c return c 50 ze=z return C 3000 FORMAT (' WARNING in ZEFR : iteration limit exceeded for ',I2,A2) END