C N. R. BADNELL UoS v24.24.2 11/01/14 C C A U T O S T R U C T U R E C ************************* C (Copyright (c) 1985-2011 BADNELL) C C incorporating C C S U P E R S T R U C T U R E C *************************** C (Copyright (c) 1969-1984 EISSNER/JONES/NUSSBAUMER/STOREY) C C*********************************************************************** C C COMBINED SOURCE DECK FOR SERIAL (F77 & F95) AND PARALLEL VERSIONS C - EACH VERSION CAN BE PRODUCED BY A SIMPLE EDIT STRING - C ALL THREE ARE PROVIDED AT HTTP://AMDPP.PHYS.STRATH.AC.UK/AUTOS C C*********************************************************************** cparc !par cparc + Parallel + !par cparc !par cparc v23.10 Parallelization of collision strengths by LSp, Jp !par cparc v22.16 Parallelization of collision algebra by LSp, Jp !par cparc v21.14 nproc restriction removed !par cparc v20.2 First parallelization of resonant l-loop (CPB) !par cparc !par cpar!***************************************************************!par cparc !par cpar module mpi ! For broken mpi f90 build !par cpar include 'mpif.h' ! Can comment-out if O.K. !par cpar end !par cparc !par cpar module comm_interface !par cparc !par cpar use mpi !par cparc !par cpar implicit none !par cparc !par cpar public comm_init ! Initialize MPI !par cpar public comm_barrier ! MPI barrier !par cpar public comm_finalize ! Terminate MPI !par cpar integer*4, public :: iam !par cpar integer*4, public :: nproc !par cparc !par cpar SAVE !par cparc !par cpar private !par cpar integer*4 :: mpicom !par cparc !par cpar CONTAINS !par cparc !par cpar!---------------------------------------------------------------!par cpar subroutine comm_init() !par cparc !par cpar implicit none !par cparc !par cpar integer*4 :: ier !par cparc !par cpar mpicom = MPI_COMM_WORLD !par cparc !par cpar call mpi_init(ier) !par cpar call mpi_comm_rank(mpicom, iam, ier) !par cpar call mpi_comm_size(mpicom, nproc, ier) !par cparc !par cpar return !par cparc !par cpar end subroutine comm_init !par cparc !par cpar!---------------------------------------------------------------!par cpar subroutine comm_barrier() !par cparc !par cpar implicit none !par cparc !par cpar integer*4 :: ier !par cparc !par cpar call mpi_barrier(mpicom, ier) !par cparc !par cpar return !par cparc !par cpar end subroutine comm_barrier !par cpar!---------------------------------------------------------------!par cparc !par cpar subroutine comm_finalize() !par cparc !par cpar implicit none !par cparc !par cpar integer*4 :: ier !par cparc !par cpar call mpi_finalize(ier) !par cparc !par cpar return !par cparc !par cpar end subroutine comm_finalize !par cpar!---------------------------------------------------------------!par cparc !par cpar end module comm_interface !par cparc !par cparc***************************************************************!par C !F95 C ******************* !F95 C !F95 MODULE COMMON_COEFF !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F95 C X ,NADP(MXADJ) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BCOEFF !F95 REAL*8 DRKP !F95 INTEGER*8 NRKP !F95 INTEGER QRLP,IRLP,NADP !F95 C !F95 ALLOCATABLE :: DRKP(:),QRLP(:,:),NRKP(:),NADP(:) !F95 C !F95 END MODULE COMMON_COEFF !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_COEFFS !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 REAL*8 DRKPS !F95 INTEGER NRKPS,QRLPS !F95 C !F95 ALLOCATABLE :: DRKPS(:),NRKPS(:),QRLPS(:,:) !F95 C !F95 END MODULE COMMON_COEFFS !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_DMQSS3 !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F95 C X ,NADR(0:MXAJS) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BDMQSS3 !F95 REAL*8 DSS !F95 INTEGER*8 MSS !F95 INTEGER QSS,NADR !F95 C !F95 ALLOCATABLE :: DSS(:),MSS(:),QSS(:,:),NADR(:) !F95 C !F95 END MODULE COMMON_DMQSS3 !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_DMQSSS !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 REAL*8 DSSS !F95 INTEGER MSSS,QSSS !F95 C !F95 ALLOCATABLE :: DSSS(:),MSSS(:),QSSS(:,:) !F95 C !F95 END MODULE COMMON_DMQSSS !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_DXRL !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F95 C X ,NAD(0:MAXAD) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BDXRL !F95 REAL*8 DRK !F95 INTEGER*8 NRK !F95 INTEGER QRL,IRL,NAD !F95 C !F95 ALLOCATABLE :: DRK(:),QRL(:,:),NRK(:),NAD(:) !F95 C !F95 END MODULE COMMON_DXRL !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_DXRLS !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F95 C X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BFALLS !F95 REAL*8 DRKS,DEKS !F95 INTEGER NRKS !F95 INTEGER QRLS,IRLS,IRKS !F95 C !F95 ALLOCATABLE :: DRKS(:),DEKS(:),QRLS(:,:),NRKS(:),BFALLS(:) !F95 C !F95 END MODULE COMMON_DXRLS !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NSTS !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F95 C X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 INTEGER NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 C !F95 ALLOCATABLE :: NADS(:),NSTJ(:),NSTJD(:),IORIG(:),JORIG(:) !F95 X ,JPLANT(:) !F95 C !F95 END MODULE COMMON_NSTS !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NSTS1 !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F95 C X ,IORIG1(MXS1I),JORIG1(MXS1I) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 INTEGER NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 C !F95 ALLOCATABLE :: NADS1(:),NSTJ1(:),NSTJ1D(:),IORIG1(:),JORIG1(:)!F95 C !F95 END MODULE COMMON_NSTS1 !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NSTS2 !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F95 C X ,IORIG2(MXS2I),JORIG2(MXS2I) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 INTEGER NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 C !F95 ALLOCATABLE :: NADS2(:),NSTJ2(:),NSTJ2D(:),IORIG2(:),JORIG2(:)!F95 C !F95 END MODULE COMMON_NSTS2 !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NRBEKP !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NRBEKP/NED(2,MAXSL,MAXTM) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BNRBEKP !F95 INTEGER NED !F95 C !F95 ALLOCATABLE :: NED(:,:,:) !F95 C !F95 END MODULE COMMON_NRBEKP !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NRBFL0 !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F95 C PARAMETER (MXD03=MXD02+1) !F95 C PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F95 C !F95 C COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F95 C X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F95 C X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BNRBFL0 !F95 INTEGER KINTI,KINTF,KEN2,KPTCFM,MPOINT,KINT !F95 C !F95 ALLOCATABLE :: KINTI(:),KINTF(:),KEN2(:),KPTCFM(:,:,:) !F95 X ,MPOINT(:,:) !F95 C !F95 END MODULE COMMON_NRBFL0 !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NRBMKP !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NRBMKP/NMD1(2,MAXJG,MAXLV),NMD2(2,MAXJG,MAXLV) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BNRBMKP !F95 INTEGER NMD1,NMD2 !F95 C !F95 ALLOCATABLE :: NMD1(:,:,:),NMD2(:,:,:) !F95 C !F95 END MODULE COMMON_NRBMKP !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NRBNF1 !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BNRBNF1,BFALL !F95 REAL*8 DEK !F95 C !F95 ALLOCATABLE :: DEK(:),BFALL(:) !F95 C !F95 END MODULE COMMON_NRBNF1 !F95 C !F95 C ******************* !F95 C !F95 MODULE COMMON_NRBRN2 !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C MODULE REPLACEMENT FOR !F95 C COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 LOGICAL BNRBRN2,BINDB !F95 INTEGER MENGB !F95 C !F95 ALLOCATABLE :: BINDB(:,:) !F95 C !F95 END MODULE COMMON_NRBRN2 !F95 C C*********************************************************************** C C----------------------------------------------------------------------- C Cadas703 SUBROUTINE ASDECK24 C C----------------------------------------------------------------------- C PROGRAM MAIN cparc !par cpar use comm_interface, only : iam,nproc,comm_init, !par cpar A comm_barrier,comm_finalize !par C !F95 USE COMMON_COEFF, ONLY: BCOEFF,DRKP,QRLP,NRKP,NADP !F95 USE COMMON_DMQSS3, ONLY: BDMQSS3,DSS,MSS,QSS,NADR !F95 USE COMMON_DXRL, ONLY: BDXRL,DRK,QRL,NRK,NAD !F95 USE COMMON_NRBEKP, ONLY: BNRBEKP,NED !F95 USE COMMON_NRBMKP, ONLY: BNRBMKP,NMD1,NMD2 !F95 USE COMMON_NRBNF1, ONLY: BNRBNF1,DEK,BFALL !F95 USE COMMON_NRBRN2, ONLY: BNRBRN2,BINDB !F95 C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (MXD01=14) PARAMETER (MXD14=100) C C UNIX-F77 CF77 REAL*4 TIME,TTIME !F77 C LOGICAL BNAME,EX C CHARACTER(LEN=6) NAM CHARACTER(LEN=3) NAM0 cparc !par cpar character(len=1) :: num(0:9) !par C COMMON /BASIC/NF,MGAP(11) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBNAM/BNAME,NF0 COMMON /NRBUNI/IUNIT(MXD14),NUNIT cparc !par cpar data num/'0','1','2','3','4','5','6','7','8','9'/ !par cparc !par cparc---------------------------------------------------------------!par cparc !par cparc initialize for parallel !par cparc !par cparc---------------------------------------------------------------!par cparc !par cpar call comm_init() !par cpar write(0,*)'Starting proc', iam !par C C----------------------------------------------------------------------- C C START TIME COUNTER C C----------------------------------------------------------------------- C CF77 TTIME=0.0 !F77 TIME=0.0D0 !F95 CALL CPU_TIME(TTIME) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 C INITIALIZE ALLOCATE FLAGS !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 BCOEFF=.FALSE. !F95 BDMQSS3=.FALSE. !F95 BDXRL=.FALSE. !F95 BNRBEKP=.FALSE. !F95 BNRBMKP=.FALSE. !F95 BNRBNF1=.FALSE. !F95 BNRBRN2=.FALSE. !F95 C C----------------------------------------------------------------------- C C SUMMARY OF FILE/UNIT USAGE C C----------------------------------------------------------------------- C C NUNIT IS THE MAX UNIT NUMBER IN CURRENT USE C C IUNIT KEEPS TRACK OF WHETHER A UNIT IS OPEN OR CLOSED, AS NEEDED, OR C NOT. NOTE, CORRESPONDING (OUTPUT) FILE MAY EXIST FROM A PREVIOUS RUN, C SO ITS EXISTENCE IS OF NO USE IN THIS CASE. C NUNIT=33 IF(NUNIT.GT.MXD14)THEN WRITE(0,*)'*** ERROR: UNIT NUMBER TOO LARGE, INCREASE MXD14 TO:' X ,NUNIT NUNIT=0 NF=-1 GO TO 1999 ENDIF DO I=1,NUNIT !INITIALIZE ALL CLOSED IUNIT(I)=0 ENDDO C C C FILES OPENED IN RELEVANT SUBPROGRAM, ONLY IF NEEDED, ARE COMMENTED OUT C HERE FOR INFO ONLY. C C OPEN(1,FILE='TCC.DAT',STATUS='REPLACE') ! OPTIONAL TCC'S JAJOM C OPEN(2,FILE='CASC',STATUS='REPLACE') ! OPTIONAL CASCADE COEFFS C OPEN(3,FILE='CONFIG.DAT',STATUS='UNKNOWN') ! OPTIONAL CONFIGS C OPEN(4,FILE='TCCDW.DAT',STATUS='REPLACE') ! OPTIONAL TCC'S STGICF C C UNIT 5 IS THE READ INPUT DATAFILE, ALL MACHINES C cparc !par cpar iunit(5)=-1 !par C C UNCOMMENT cpar ABOVE IF *NOT* RE-DIRECTING FROM COMMAND LINE (serial) C IF(IUNIT(5).LT.0)THEN INQUIRE(FILE='das',EXIST=EX) IF(EX)THEN IUNIT(5)=1 OPEN(5,FILE='das',STATUS='OLD') !STANDARD INPUT ELSE WRITE(0,*)'UNIT5 USER INPUT FILE "das" MISSING, ' X ,'BUT IS REQUIRED!' NF=-1 GO TO 1999 ENDIF ENDIF C C INQUIRE CHECKS FOR OPTIONAL INPUT FILES, REST MAYBE OUTPUT TO C IUNIT(6)=1 NAM0='' cparc !par cpar i1=iam/100 !par cpar i2=(iam-10*i1)/10 !par cpar i3=iam-100*i1-10*i2 !par cpar nam0=num(i1)//num(i2)//num(i3) !par cparc !par NAM='olg'//NAM0 OPEN(6,FILE=NAM,STATUS='REPLACE') !STANDARD OUTPUT C C OPEN(7,FILE='ols',STATUS='REPLACE') !LS AA, AR RATES & ENERGIES C OPEN(8,FILE='oic',STATUS='REPLACE') !IC " " " C INQUIRE(FILE='hffcin',EXIST=EX) IF(EX)THEN IUNIT(9)=1 OPEN(9,FILE='hffcin',STATUS='OLD') !OPT POT (E.G. HF-FC, FAC) ENDIF INQUIRE(FILE='potin',EXIST=EX) IF(EX)THEN IF(IUNIT(9).EQ.0)THEN IUNIT(9)=1 OPEN(9,FILE='potin',STATUS='OLD') !OPT POTS (E.G. HF-FC, FAC) ELSE WRITE(6,*)'FILES "hffcin" AND "potin" BOTH PRESENT, IGNORING', X ' THE LATTER...' WRITE(0,*)'FILES "hffcin" AND "potin" BOTH PRESENT, IGNORING', X ' THE LATTER...' ENDIF ENDIF C C OPEN(10,FILE='RESTART',FORM='UNFORMATTED',STATUS='UNKNOWN') !ALGEB C IUNIT(11)=1 OPEN(11,STATUS='SCRATCH',FORM='UNFORMATTED') !NEED I SAY MORE C INQUIRE(FILE='radwin',EXIST=EX) IF(EX)THEN IUNIT(12)=1 OPEN(12,FILE='radwin',STATUS='OLD') !INPUT BOUND ORBS (OPT) ENDIF C C OPEN(13,FILE='radout',STATUS='REPLACE') !OUTPUT BOUND ORBS (OPT) C C OPEN(14,FILE='TERMS',STATUS='REPLACE') !TERM LIST FOR STG2 ETC C OPEN(15,FILE='LEVELS',STATUS='REPLACE') !LEVEL LIST FOR STGJK ETC C C OPEN(16,FILE='OVRLAP',STATUS='REPLACE') !ORBITAL OVERLAP LIST C C OPEN(17,FILE='opls',STATUS='REPLACE') !LS PHOTOIONIZATION DATA C OPEN(18,FILE='opic',STATUS='REPLACE') !IC " " C INQUIRE(FILE='SHFTLS',EXIST=EX) IF(EX)THEN IUNIT(19)=1 OPEN(19,FILE='SHFTLS',STATUS='OLD') !TERM ENERGY CORRECTIONS ENDIF C INQUIRE(FILE='SHFTIC',EXIST=EX) IF(EX)THEN IUNIT(20)=1 OPEN(20,FILE='SHFTIC',STATUS='OLD') !LEVEL ENERGY CORRECTIONS ENDIF C C OPEN(21,FILE='adasex.in.form',STATUS='REPLACE') !adasex TEMPLATE C OPEN(22,FILE='adasexj.in.form',STATUS='REPLACE') !adasexj TEMPLATE C C OPEN(23,FILE='OMGINFLS',STATUS='REPLACE')!INFINITE ENERGY OMEGA-LS C OPEN(24,FILE='OMGINFIC',STATUS='REPLACE')!INFINITE ENERGY OMEGA-IC C C OPEN(25,FILE='adf04ls',STATUS='REPLACE') !FINITE ENERGY OMEGA-LS C OPEN(26,FILE='adf04ic',STATUS='REPLACE') !FINITE ENERGY OMEGA-IC C C OPEN(27,FILE='olsu',FORM='UNFORMATTED',STATUS='REPLACE') !AS ols C OPEN(28,FILE='oicu',FORM='UNFORMATTED',STATUS='REPLACE') !AS oic C C OPEN(29,FILE='oplsu',FORM='UNFORMATTED',STATUS='REPLACE') !AS opls C OPEN(30,FILE='opicu',FORM='UNFORMATTED',STATUS='REPLACE') !AS opic C C OPEN(31,FILE='ITANAL',STATUS='OLD') !TERM ENERGY CONTRIBUTIONS C C OPEN(32,FILE='DISKDC',FORM='UNFORMATTED',STATUS='REPLACE') !FOR DC C OPEN(33,FILE='DSKDMP',FORM='UNFORMATTED',STATUS='REPLACE') !FOR DC C C----------------------------------------------------------------------- C C SR.ZERO PRINTS DIMENSIONS FOR THIS RUN C C----------------------------------------------------------------------- C CALL ZERO C C----------------------------------------------------------------------- C C SR.TARGET DESCRIBES BOTH BOUND-BOUND AND BOUND-CONTINUUM PROBLEMS, C TREATING THE LATTER AS AN (N+1)-ELECTRON STRUCTURE PROBLEM. C C----------------------------------------------------------------------- C CALL TARGET(TIME,TTIME) C if(nf.ne.nf0)write(0,*)'nf,nf0=',nf,nf0 IF(NF.Le.0.OR.NF0.LT.0)GO TO 1999 C C----------------------------------------------------------------------- C C SR.DEIE DESCRIBES DIRECT ELECTRON-IMPACT EXCITATION C C----------------------------------------------------------------------- C IF(IABS(IDW).EQ.1)CALL DEIE(TIME,TTIME) C C----------------------------------------------------------------------- C C SR.DEII DESCRIBES DIRECT ELECTRON-IMPACT IONIZATION (PLACEHOLDER) C C----------------------------------------------------------------------- C C IF(IABS(IDW).EQ.2)CALL DEII(TIME,TTIME) C C----------------------------------------------------------------------- C 1999 CONTINUE C C----------------------------------------------------------------------- C C CLOSE-OFF ANY UNITS STILL OPEN C C----------------------------------------------------------------------- C DO I=1,NUNIT IF(IUNIT(I).GT.0)CLOSE(I) ENDDO C !F95 C-------------------------------------------------------------------!F95 C !F95 C DE-ALLOCATE ANYTHING LEFT ALLOCATED (I.E. JOB HAS ALREADY FAILED) !F95 C !F95 C-------------------------------------------------------------------!F95 C !F95 IF(BCOEFF)DEALLOCATE (DRKP,QRLP,NRKP,NADP,STAT=IERR) !F95 IF(BDXRL)DEALLOCATE (DRK,QRL,NRK,NAD,STAT=IERR) !F95 IF(BDMQSS3)DEALLOCATE (DSS,MSS,QSS,NADR,STAT=IERR) !F95 IF(BNRBEKP)DEALLOCATE (NED,STAT=IERR) !F95 IF(BNRBMKP)DEALLOCATE (NMD1,NMD2,STAT=IERR) !F95 IF(BNRBNF1)DEALLOCATE (DEK,BFALL,STAT=IERR) !F95 IF(BNRBRN2)DEALLOCATE (BINDB,STAT=IERR) !F95 C !F95 cparc !par cparc---------------------------------------------------------------!par cparc !par cparc finish-up parallel !par cparc !par cparc---------------------------------------------------------------!par cparc !par cpar write(0,*)'Ending proc', iam !par cpar call comm_barrier() !par cpar call comm_finalize() !par C IF(NF.Lt.0.OR.NF0.Lt.0)THEN STOP ' !!! ABNORMAL END - SEE OLG FILE ): !!!' ELSE STOP !' (: *** NORMAL END *** ' !COMMENT-OUT FOR SILENT SUCCESS ENDIF C C----------------------------------------------------------------------- C Cadas703 RETURN C C----------------------------------------------------------------------- C END CADASC CADASC ******************* CADASC CADAS real*8 function adasip(elemu,iz1) CADASC CADASC------------------------------------------------------------------ CADASC Get ionisation potential for arbitrary ionisation stage CADASC CADASC The user must have a valid ADASCENT environment variable set. CADASC CADASC Compile and link : CADASC f77 adasip.for -L/home/adas/lib -ladaslib CADASC------------------------------------------------------------------ CADASC CADAS implicit none CADASc CADASC------------------------------------------------------------------ CADAS integer iz1 , i , L1 , L2 CADASC------------------------------------------------------------------ CADAS real*8 fip CADASC------------------------------------------------------------------ CADAS logical badas CADASC------------------------------------------------------------------ CADAS character(len=2) elem , esym ,elemu CADAS character(len=30) adascent CADAS character(len=120) dsfull CADASC------------------------------------------------------------------ CADAS common /hps/badas CADASC------------------------------------------------------------------ CADASc CADAS badas=.true. CADASc CADASctest CADASc elemu = 'FE' CADASc iz1 = 13 CADASc CADAS call xxcase(elemu, elem, 'LC') ! for lowercase CADASc CADAS call getenv("ADASCENT",adascent) CADASc CADASc---------------------hps 19 Aug 2011 ---------------------------------- CADASc adascent='/home/hps/adas_dev/adas' CADASc----------------------------------------------------------------------- CADASc CADAS do i = len(adascent), 1, -1 CADAS if (adascent(i:i).NE.' ') goto 20 CADAS end do CADAS 20 L1 = i CADAS do i = len(elem), 1, -1 CADAS if (elem(i:i).NE.' ') goto 30 CADAS end do CADAS 30 L2 = i CADASc CADAS dsfull = adascent(1:L1)//'/adf00/'//elem(1:L2)//'.dat' CADASc CADAS open(unit=99, file=dsfull) CADASc CADAS read(99, '(A)')esym ! skip line 1 CADAS do i = 1, iz1 ! skip lines up to stage of interest CADAS read(99, '(A)')esym CADAS end do CADAS read(99, *)i, fip CADASc CADAS adasip = fip * 8066.0693 CADASc CADASctest print *, 'Ionisation potential : ', adasip CADASc CADAS close(99) CADASc CADAS end C !ADAS C ******************* !ADAS c !ADAS real*8 function adasip(elemu,iz1) !ADAS c !ADAS c dummy routine for normal (non-ADAS) useage. !ADAS c !ADAS implicit none !ADAS c !ADAS real*8 dzero !ADAS integer iz1,idum !ADAS character(len=2) elemu,cdum !ADAS logical badas !ADAS c !ADAS parameter (dzero=0.0d0) !ADAS c !ADAS common /hps/badas !ADAS c !ADAS badas=.false. !.true. for test !ADAS c !ADAS c suppress compiler warnings (sigh...) !ADAS c !ADAS cdum=elemu !ADAS idum=iz1 !ADAS c !ADAS adasip=dzero !ADAS c !ADAS return !ADAS end !ADAS C C ******************* C SUBROUTINE ALGEB(IRET) C C----------------------------------------------------------------------- C C SR.ALGEB CONTROLS THE ALGEBRAIC BRANCH, INCLUDING RESTART FACILITY. C C NOTE: ANGULAR QUANTUM NUMBERS WILL BE INTERNALLY STORED AS TWICE C THEIR VALUE; THIS ALLOWS FOR INTEGER NOTATION AND MEETS THE C REQUIREMENTS OF THE COPENHAGEN PACKAGE OF ANGULAR SUBROUTINES. C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_COEFF, ONLY: BCOEFF,DRKP,QRLP,IRLP,NRKP,NADP !F95 USE COMMON_DMQSS3, ONLY: BDMQSS3,DSS,MSS,QSS,NADR !F95 USE COMMON_DXRL, ONLY: BDXRL,DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_NRBEKP, ONLY: BNRBEKP,NED !F95 USE COMMON_NRBMKP, ONLY: BNRBMKP,NMD1,NMD2 !F95 USE COMMON_NRBNF1, ONLY: BNRBNF1,DEK,BFALL !F95 USE COMMON_NRBRN2, ONLY: BNRBRN2,BINDB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXIDC=MAXDC) !OPT FOR MEMORY !F77 CF77C PARAMETER (MXIDC=1) !OPT FOR SPEED !F77 C PARAMETER (MXD01=14) PARAMETER (MXD08=21*(MAXCF+5)) !S.S. NO. CF INPUT LINES*21 PARAMETER (MXD12=100) PARAMETER (MXD14=100) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C CF77 PARAMETER (MXXDQ=2*MXST0+MXEST) !F77 CF77 PARAMETER (MXD1=MAXDI/MAXDK, !F77 CF77 X MXD2=MAXDK/MAXDI, !F77 CF77 X MXD3=MXD1+MXD2, !F77 CF77 X MXD4=MAXDI*MXD1/MXD3+MAXDK*MXD2/MXD3+1, !F77 CF77 X MXD0=MXD4*MXD4, !F77 CF77 X MXD5=MXXDQ/MXD0, !F77 CF77 X MXD6=MXD0/MXXDQ, !F77 CF77 X MXD7=MXD5+MXD6, !F77 CF77 X MXD8=MXXDQ*MXD5/MXD7+MXD0*MXD6/MXD7+1, !F77 CF77 X MXQBUF=MXD8) !F77 c PARAMETER (DZERO=0.0D0) C LOGICAL BLOOP,BREL,BJUMPR,BFOT,BFANO,BNAME,BSTART,BPASS,BMVD,BREL0 X ,BANAL,BEX,BDISK,btime,btimex X ,BALLDC,BQXXX,BQLMS,BMNAM !F95 CF77 X ,BFALL,BINDB !F77 C CF77 INTEGER*8 NRK,NRKP,MSS !F77 C CHARACTER(LEN=2) NAME0 CHARACTER(LEN=4) CODE,MLIT CHARACTER(LEN=9) NAME cparc !par cpar character(len=1) :: num(0:9) !par C INTEGER*8 MDCF8,MDCFT8 C REAL*8 DC !*4 NOT RECOMMENDED DATA LREC/8/ !SET TO BYTE LENGTH OF DC ARRAY C CF77 DIMENSION DC(0:MAXDC),IDC(MXIDC),MAM(MXST0),NAM(MXST0) !F77 CF77 DIMENSION QBMS(MXST0),QBML(MXST0),QLMC(MXEST),QLMS(MXEST) !F77 C ALLOCATABLE :: DC(:),IDC(:),MAM(:),NAM(:) !F95 X ,QBMS(:),QBML(:),QLMC(:),QLMS(:) !F95 C DIMENSION JYI(MAXCF),JYF(MAXCF) C COMMON /BASIC/NF,MBASE(11) COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JJ(MAXLV),NGR(MAXLV) COMMON /MQVC/MODE,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF) COMMON /NXRL/IRK,IRK0,IOS,IOS0 COMMON /NXRLP/IRKP,IRKP0 COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL,NL000 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /SSWRK/IWRK1(MXD08),IWRK2(MXD08) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL0/IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS,MLIT(2) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTXX,NTJ(MAXCF),NFJ(MAXLV) X ,KUTSO COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM CF77 COMMON /NRBALQ/QBUFF(MXQBUF) !F77 COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDUM/MXDC0,MXGR0 !NOT USED ANYWHERE, BUT RESTART COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) CF77 COMMON /NRBEKP/NED(2,MAXSL,MAXTM) !F77 COMMON /NRBFAN/BFANO COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBKUT/KDUM,LSKUT(MAXSL),NASTK !KCUT IN /MQVC/ COMMON /NRBKUTP/KCUTP,LSKUTP(MAXSL),NASTKP COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLIM/ECNTRB,ITANAL,BANAL(MAXCF) !ALGEBRAIC COMMON /NRBLOO/BLOOP,LNEW,LCON,LSUM,LMAX COMMON /NRBLS/LSPI(MAXSL),NAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP CF77 COMMON /NRBMKP/NMD1(2,MAXJG,MAXLV),NMD2(2,MAXJG,MAXLV) !F77 COMMON /NRBNAM/BNAME,NF0 CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBNV/MAXNV COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBPNT/NTGP(MAXCT),NTGS(MAXCT),NTP1,NTP2 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBUNI/IUNIT(MXD14),NUNIT common /nrbtim/iw,iwp,btime,btimex cparc !par cpar data num/'0','1','2','3','4','5','6','7','8','9'/ !par C CF77 EQUIVALENCE (QBUFF(1),QBMS(1)),(QBUFF(1+MXST0),QBML(1)) !F77 CF77 X ,(QBUFF(1+2*MXST0),QLMC(1)) !F77 C MSTART=0 !to silence ftnchek MXMTGD=3*2**26 !MAX REC LEN FOR DC ARRAY MXMTGD=MXMTGD*(8/LREC) C C SET NEW L FOR L-LOOP, OR RETURN AND EXIT C IF(BLOOP)THEN LSUM=LSUM+1 IF(LNEW.LT.LMAX)REWIND(5) !REWIND USER INPUT FILE IF(LNEW.EQ.LMAX)LSUM=0 IF(BNAME.AND.LNEW.EQ.LMAX)THEN IRET=1 RETURN ENDIF ENDIF C BMNAM=.FALSE. !F95 BQXXX=.FALSE. !F95 BQLMS=.FALSE. !F95 BALLDC=.FALSE. !F95 C NF0=0 C C READ USER INPUT, AND SET-UP ACCORDINGLY. C IRET=1 SIGNALS A TERMINATOR AND SO FLAGS EXIT WITHOUT CALL TO MINIM C C*********************************************************************** C CALL ALGEB0(DC0,MAXEL) !-0- C C*********************************************************************** C IF(NF.LT.0)GO TO 80 C IRET=IRET0 IF(IRET.EQ.1)GO TO 998 !RETURN C C MAKE BEST USE OF ARRAYS QLMC,QLMS(MAXEL,MAXST) - OPTIMIZE MAXST. C MAXST=MXEST/MAXEL IF(MAXST.GT.MXST0)MAXST=MXST0 C C SCRATCH C MRP=MR+1 REWIND(MRP) C C T-TERM SELECTION C IF(ITANAL.NE.0)THEN !WANTED, IF(IUNIT(31).EQ.0)THEN !BUT NOT YET OPENED INQUIRE(FILE='ITANAL',EXIST=BEX) IF(BEX)THEN OPEN(31,FILE='ITANAL',STATUS='OLD') IUNIT(31)=1 ELSE WRITE(0,*)'USER INPUT ITANAL REQUIRES FILE "ITANAL", ' X ,'BUT NOT FOUND!' WRITE(6,*)'USER INPUT REQUIRES FILE "ITANAL", ' X ,'BUT NOT FOUND: ITANAL=',ITANAL GO TO 995 ENDIF ELSEIF(IUNIT(31).GT.0)THEN !FOR L-LOOP REWIND(31) ENDIF ENDIF C C INITIALIZE FOR RESTART C IRL5=6 !5+1 NOW ALG3/4 SEPARATE MST5=MOD(MSTRT0,IRL5) BSTART=(MST5.EQ.0.OR.MPRINT.LT.-3).AND.IDW.EQ.0 IF(MST5.NE.0)BPASS=.FALSE. C C INITIAL DISKDC STORAGE C BDISK=MOD(KUTDSK,1000).LT.KM.AND.MST5.NE.5 !IF 5 THE ALGEB DONE IF(BDISK)THEN IUD=32 !DISKDC MDCF8=0 MDCFT8=0 ENDIF MDCBUF=0 !BEST NOT UNDEFINED C IF(BSTART)GO TO 71 !<----- NO RESTART ----- C IF(IUNIT(MR).EQ.0)THEN !RESTART FILE if(idw.eq.0)then NAME0='' cparc !par cpar i1=iam/10 !par cpar i2=iam-(10*(iam/10)) !par cpar name0=num(i1)//num(i2) !par cparc !par NAME='RESTART'//NAME0 INQUIRE(FILE=NAME,EXIST=BEX) C IF(IABS(MST5).EQ.1)THEN OPEN(MR,FILE=NAME,FORM='UNFORMATTED',STATUS='UNKNOWN') IF(.NOT.BEX)LORIG=LMIN ELSE IF(BEX)THEN OPEN(MR,FILE=NAME,FORM='UNFORMATTED',STATUS='OLD') ELSE WRITE(0,*)'USER INPUT MSTART REQUIRES FILE "RESTART", ' X ,'BUT NOT FOUND!' WRITE(6,*)'USER INPUT REQUIRES FILE "RESTART", ' X ,'BUT NOT FOUND: MSTART=',MSTRT0 GO TO 995 ENDIF ENDIF else OPEN(MR,FORM='UNFORMATTED',STATUS='SCRATCH') endif IUNIT(MR)=1 IF(BEX)REWIND(MR) ENDIF C IF(IDW.EQ.0.and.mstrt0.ne.5)THEN WRITE(0,*)'***ATTENTION: NOW MSTART=5 RESTARTS A COMPLETED' X ,' ALGEBRA RUN,' WRITE(0,*)' AS ALGEB3 AND ALGEB4 ARE RESTARTED SEPARATELY ***' ENDIF C GO TO 60 C C WRITE RESTART INFO AFTER EVERY CALL TO ALGEBN, N=1,2,3,4 C 76 WRITE(6,800)MLIT,MSTRT0 C IF(IABS(MSTRT0).GE.IRL5)THEN !EXIT AFTER ONE STAGE NF=0 GO TO 999 ENDIF C MSTRT0=MSTRT0+MSTRT0/MSTART IF(MSTRT0.LT.0)THEN !REWIND AND RE-READ AT EACH STEP IF(BLOOP)THEN !NEED TO BACKSPACE APPROPRIATE NREC WRITE(6,*)'*** ERROR: CANOT USE MSTART.LT.0 WITH L-LOOP' WRITE(0,*)'*** ERROR: CANOT USE MSTART.LT.0 WITH L-LOOP' GO TO 995 ENDIF REWIND(MR) GO TO 60 ENDIF C IF(MSTART.EQ.1)GO TO 75 !<--------------- RESTART SWITCH IF(MSTART.EQ.2)GO TO 77 !<--------------- RESTART SWITCH IF(MSTART.EQ.3)GO TO 72 !<--------------- RESTART SWITCH IF(MSTART.GT.3)GO TO 79 !<--------------- RESTART SWITCH C 60 CONTINUE C C LORIG IS FIRST L FOR WHICH RESTART ALGEBRA WAS WRITTEN (=LMIN DEFAULT) C LMIN IS FIRST L FOR WHICH RESTART ALGEBRA IS TO BE READ C PARTIAL ALGEBRA RUNS CANNOT BE HANDLED BY L-LOOP, I.E. ONLY MSTART=1,5 C IF(BLOOP.AND.LSUM.EQ.0.AND.LMIN.NE.LORIG)THEN IF(LMIN.LT.LORIG)THEN WRITE(6,1007)LORIG,LMIN WRITE(0,*)'ERROR IN RESTART ALGEBRA L-LOOP' GO TO 995 ENDIF C NREC=7 !NOW ALG3/4 SEPARATE(SAME FOR LS&IC) MRD=NREC*(LMIN-LORIG) DO M=1,MRD READ(MR,END=41) ENDDO GO TO 42 41 WRITE(6,*)'*** ATTEMPT TO READ PAST END OF RESTART FILE...' WRITE(0,*)'*** ATTEMPT TO READ PAST END OF RESTART FILE...' GO TO 995 ENDIF C 42 MSTART=MOD(IABS(MSTRT0),IRL5) C IF(MSTART.GT.1)GO TO 73 !<--------------- RESTART SWITCH C 71 MSTART=1 C C ALLOCATE (QBMS(MXST0),QBML(MXST0),QLMC(MXEST),QLMS(MXEST) !F95 X,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR QXXX' !F95 GO TO 999 !F95 ENDIF !F95 BQXXX=.TRUE. !F95 BQLMS=.TRUE. !F95 C !F95 MXIDC=MAXDC !F95 IF(DC0.LT.DZERO)MXIDC=1 !F95 C !F95 ALLOCATE (DC(0:MAXDC),IDC(MXIDC),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR DC,IDC' !F95 GO TO 999 !F95 ENDIF !F95 BALLDC=.TRUE. !F95 C DC(0)=DC0 !FLAGS OPT MEMORY OR SPEED C C INITIALIZE (OPEN) WRITE/READ DC ARRAY TO/FROM DISK. C IF(BDISK)CALL DISKDC(IUD,DC,IDC,0,0,0,0,0,MSTRT0) c if(btime)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for algeb1' !par cpar else !par write(iw,*)'Starting algeb1' cpar endif !par if(bloop)write(iw,*)'l=',lnew call cpu_time(timei) endif C C*********************************************************************** C CALL ALGEB1(DC,IDC,QLMC,QLMS,QBML,QBMS,JYI,JYF,MAXST,MAXEL) !-1- C C*********************************************************************** C if(btime)then call cpu_time(timef) times=timef-timei c if(bloop)write(iw,*)'l=',lnew cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for algeb1:' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iw) !par cpar else !par write(iw,*)'Ending algeb1: time=',nint(times),'sec' cpar endif !par endif c IF(NF.LE.0)GO TO 80 C NSS=JYF(KM) !TOT NO. SLATER STATES NEEDED C !F95 ALLOCATE (MAM(NSS),NAM(NSS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR MAM,NAM' !F95 GO TO 999 !F95 ENDIF !F95 BMNAM=.TRUE. !F95 C IF(BSTART)GO TO 75 !<----- NO RESTART ----- C IF(IDW.NE.0)THEN !DW DUMP IS NOW AFTER ALGEB3 SO CAN STRIKE-OUT BSTART=.TRUE. !M_S CASES NOT NEEDED FOR BP WHEN NO 2-FS GO TO 75 ENDIF C IF(BREL)NPRINT=MIN(-5,NPRINT-5) NTT=NTG(KM) !!TOTAL NO. OF TERMS USED NESS=MAXEL*NSS !NO. ELECTRONS*SLATER STATES IF(DC0.LT.DZERO)THEN MDCBUF=-MDCBUF MTGDI=1 IDC(1)=0 ELSE MTGDI=MTGD ENDIF CC WRITE(MR) X MLIT,MXORB,NW,NF,MODE,KCUT,KUTDSK,QQCUT,QCL0,QCS0,MDCBUF !REC1 X,MTGD,MTGDI,NTT,NSS,MAXEL,KM,NPRINT,MA,MB,MAXNV,IRLX,ITANAL X,((NEL(I,J),I=1,MXORB),J=1,KM),((NNL(I,J),I=1,NW),J=1,3) X,((QCG(I,J),I=1,MAXEL),J=1,KM),(QL(I),I=1,MXORB) X,(QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),(MSTAT(I),I=1,KM) X,(IEQ(I),I=0,MXORB),(IGRCF(I),I=1,MXORB),(BANAL(I),I=1,KM) X,(KGCF(I),I=0,KM),((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KM) C MDCBUF=IABS(MDCBUF) C IF(BPASS)GO TO 76 C WRITE(MR)(QLMS(I),I=1,NESS) !REC2 CC NMTGD=MTGD/MXMTGD MTGD0=0 MTGD1=-1 DO N=1,NMTGD MTGD1=MTGD1+MXMTGD WRITE(MR)(DC(I),I=MTGD0,MTGD1) !REC3 MTGD0=MTGD1+1 ENDDO WRITE(MR)(DC(I),I=MTGD0,MTGD) !REC3 CC IMTGD=(MTGDI-1)/MXMTGD IMTGD=IMTGD/(LREC/4) MTGD0=1 MTGD1=0 DO N=1,IMTGD MTGD1=MTGD1+MXMTGD*(LREC/4) WRITE(MR)(IDC(I),I=MTGD0,MTGD1) !REC3 MTGD0=MTGD1+1 ENDDO WRITE(MR)(IDC(I),I=MTGD0,MTGDI) !REC3 CC WRITE(MR)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC3 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) CC GO TO 76 CC 73 READ(MR,ERR=994) X MLIT,MXORB,NW,NF,MODE,KCUT,KUTDSK,QQCUT,QCL0,QCS0,MDCBUF !REC1 X,MTGD,MTGDI,NTT,NSS,MAXEL,KM,NPRNT0,MA,MB,MAXNV,IRLX,ITANAL X,((NEL(I,J),I=1,MXORB),J=1,KM),((NNL(I,J),I=1,NW),J=1,3) X,((QCG(I,J),I=1,MAXEL),J=1,KM),(QL(I),I=1,MXORB) X,(QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),(MSTAT(I),I=1,KM) X,(IEQ(I),I=0,MXORB),(IGRCF(I),I=1,MXORB),(BANAL(I),I=1,KM) X,(KGCF(I),I=0,KM),((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KM) CC IF(BDISK)THEN IF(MDCBUF.LT.0)THEN MDCBUF=-MDCBUF MXTGDI=1 ELSE MXTGDI=MDCBUF ENDIF MXTGD=MDCBUF ELSE MXTGD=MTGD MXTGDI=MTGDI ENDIF C NMTGD=MTGD/MXMTGD IMTGD=(MTGDI-1)/MXMTGD IMTGD=IMTGD/(LREC/4) NESS=MAXEL*NSS C IF(MSTART.EQ.2)THEN C ALLOCATE (QLMS(NESS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR QLMS' !F95 GO TO 999 !F95 ENDIF !F95 BQLMS=.TRUE. !F95 CC READ(MR)(QLMS(I),I=1,NESS) !REC2 CC ENDIF C IF(MSTART.LT.5)THEN C !F95 ALLOCATE (QBMS(NSS),QBML(NSS),QLMC(NESS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR QXXX' !F95 GO TO 999 !F95 ENDIF !F95 BQXXX=.TRUE. !F95 C !F95 ALLOCATE (MAM(NSS),NAM(NSS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR MAM,NAM' !F95 GO TO 999 !F95 ENDIF !F95 BMNAM=.TRUE. !F95 C !F95 ALLOCATE (DC(0:MXTGD),IDC(MXTGDI),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR DC,IDC' !F95 GO TO 999 !F95 ENDIF !F95 BALLDC=.TRUE. !F95 C C INITIALIZE (OPEN) WRITE/READ DC ARRAY TO/FROM DISK. C IF(BDISK)CALL DISKDC(IUD,DC,IDC,0,0,0,0,0,MSTRT0) C ENDIF C BREL0=NPRNT0.LE.-5 MPRINT=MOD(NPRNT0,5) IF(MPRNT0.GT.MPRINT)NPRINT=MPRINT+5*(NPRINT/5) BREL=BREL.OR.NPRINT.LE.-5 C IF(BREL.AND..NOT.BREL0)THEN WRITE(0,1011) WRITE(6,1011) GO TO 994 !AS MEMORY NOT ALLOCATED !F95 ENDIF C WRITE(6,700)MLIT,MSTART C IF(MSTART.GT.2)GO TO 74 !<--------------- RESTART SWITCH CC MTGD0=0 MTGD1=-1 DO N=1,NMTGD MTGD1=MTGD1+MXMTGD READ(MR,ERR=994)(DC(I),I=MTGD0,MTGD1) !REC3 MTGD0=MTGD1+1 ENDDO READ(MR,ERR=994)(DC(I),I=MTGD0,MTGD) !REC3 CC MTGD0=1 MTGD1=0 DO N=1,IMTGD MTGD1=MTGD1+MXMTGD*(LREC/4) READ(MR,ERR=994)(IDC(I),I=MTGD0,MTGD1) !REC3 MTGD0=MTGD1+1 ENDDO READ(MR,ERR=994)(IDC(I),I=MTGD0,MTGDI) !REC3 CC READ(MR,ERR=994)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC3 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) CC 75 MSTART=2 c if(btime)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for algeb2' !par cpar else !par write(iw,*)'Starting algeb2' cpar endif !par if(bloop)write(iw,*)'l=',lnew call cpu_time(timei) endif C C*********************************************************************** C CALL ALGEB2(DC,IDC,MAM,NAM,QLMC,QLMS,QBML,QBMS,JYI,JYF,MAXEL) !-2- C C*********************************************************************** C if(btime)then call cpu_time(timef) times=timef-timei c if(bloop)write(iw,*)'l=',lnew cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for algeb2:' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iw) !par cpar else !par write(iw,*)'Ending algeb2: time=',nint(times),'sec' cpar endif !par endif c DEALLOCATE (QLMS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: DE-ALLOCATION FAILS FOR QLMS' !F95 GO TO 999 !F95 ENDIF !F95 BQLMS=.FALSE. !F95 C C IF(NF.LE.0)GO TO 80 C IF(BSTART)GO TO 77 !<----- NO RESTART ----- C IF(.NOT.BPASS)THEN DO N=1,NMTGD+IMTGD+3 BACKSPACE(MR) !REC3 ENDDO BACKSPACE(MR) !REC2 ENDIF C IRKK=MAX(IOS,IRK) IRKO=1 IF(KUTOO.NE.0)IRKO=IRK C NSL0=KDMT(2) !NO. OF GROUPS IF(MPOL0.GE.0)THEN MXORB2=(MXORB*(MXORB+1))/2 LHM=MPOLE/4 IF(BREL)LHM=LHM+1 ELSE MXORB2=1 LHM=0 ENDIF IF(MPRNT0.EQ.-2)THEN ID1=1 ID2=1 ELSE ID1=NSL0 ID2=NTT ENDIF C IF(IADD.GT.2**29)GO TO 996 !*4 RECL > 2GB IF(IRKK.GT.2**28)GO TO 996 !*8 RECL > 2GB CC WRITE(MR)IADD,IRK,IRKO,IRL,MTGD,MPOL0,MPOLE,IOS,NXLL !REC2 X ,KDM,NSL0,NMETA C WRITE(MR)(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0) !REC3 X ,(QLI(I),I=1,NSL0),(QPI(I),I=1,NSL0),(NMETAG(I),I=1,NSL0) X ,((KGSL(I,J),I=1,KM),J=1,NSL0),(NADG(I),I=1,NSL0) X ,(NFI(I),I=1,NTT),(NFK(I),I=1,NTT),(NFQ(I),I=1,NTT) WRITE(MR)(NAD(I),I=0,IADD) WRITE(MR)(DRK(I),I=1,IRKK) WRITE(MR)(NRK(I),I=1,IRKK) WRITE(MR)(((NED(I,J,K),I=1,2),J=1,ID1),K=1,ID2) !SHOULD BE O.K. WRITE(MR)((QRL(J,I),J=1,5),I=1,IRL) X ,(DEK(I),I=1,IRKO),(BFALL(I),I=1,IRKO) !OFF, LARGE CASES X ,((BINDB(I,LH),I=1,MXORB2),LH=0,LHM) LREC3=6 C IF(BPASS)GO TO 76 CC MTGD0=0 MTGD1=-1 DO N=1,NMTGD MTGD1=MTGD1+MXMTGD WRITE(MR)(DC(I),I=MTGD0,MTGD1) !REC4 MTGD0=MTGD1+1 ENDDO WRITE(MR)(DC(I),I=MTGD0,MTGD) !REC4 CC MTGD0=1 MTGD1=0 DO N=1,IMTGD MTGD1=MTGD1+MXMTGD*(LREC/4) WRITE(MR)(IDC(I),I=MTGD0,MTGD1) !REC4 MTGD0=MTGD1+1 ENDDO WRITE(MR)(IDC(I),I=MTGD0,MTGDI) !REC4 CC WRITE(MR)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC4 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) GO TO 76 CC 74 READ(MR,ERR=994)IADD,IRK,IRKO,IRL,MTGD,MPOL0,MPOLX,IOS,NXLL !REC2 X ,KDM,NSL0,NMETA CC MPOLE=MIN(MPOLE,MPOLX) IF(MPOL0.GE.0)THEN MXORB2=(MXORB*(MXORB+1))/2 LHM=MPOLE/4 if(brel0)lhm=lhm+1 ELSE MXORB2=1 LHM=0 ENDIF C IRKK=MAX(IRK,IOS) IF(IRKO.EQ.1)KUTOO=0 IF(MPRINT.EQ.-2)THEN ID1=1 ID2=1 ELSE ID1=NSL0 ID2=NTT ENDIF C !F95 C EX-COMMON/DXRL/ !F95 ALLOCATE (DRK(IRKK),QRL(5,IRL),NRK(IRKK),NAD(0:IADD) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR DRK,QRL,NRK,NAD' !F95 GO TO 999 !F95 ENDIF !F95 BDXRL=.TRUE. !F95 C !F95 C EX-COMMON/NRBEKP/ !F95 ALLOCATE (NED(2,ID1,ID2),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR NED' !F95 GO TO 999 !F95 ENDIF !F95 BNRBEKP=.TRUE. !F95 C !F95 C EX-COMMON/NRBNF1/ !F95 ALLOCATE (DEK(IRKO),BFALL(IRKO),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR DEK, BFALL' !F95 GO TO 999 !F95 ENDIF !F95 BNRBNF1=.TRUE. !F95 C !F95 C EX-COMMON/NRBRN2/ !F95 ALLOCATE (BINDB(MXORB2,0:LHM),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR BINDB' !F95 GO TO 999 !F95 ENDIF !F95 BNRBRN2=.TRUE. !F95 CC READ(MR,ERR=994)(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0) !REC3 X ,(QLI(I),I=1,NSL0),(QPI(I),I=1,NSL0),(NMETAG(I),I=1,NSL0) X ,((KGSL(I,J),I=1,KM),J=1,NSL0),(NADG(I),I=1,NSL0) X ,(NFI(I),I=1,NTT),(NFK(I),I=1,NTT),(NFQ(I),I=1,NTT) READ(MR,ERR=994)(NAD(I),I=0,IADD) READ(MR,ERR=994)(DRK(I),I=1,IRKK) READ(MR,ERR=994)(NRK(I),I=1,IRKK) READ(MR,ERR=994)(((NED(I,J,K),I=1,2),J=1,ID1),K=1,ID2) READ(MR,ERR=994)((QRL(J,I),J=1,5),I=1,IRL) X ,(DEK(I),I=1,IRKO),(BFALL(I),I=1,IRKO) X ,((BINDB(I,LH),I=1,MXORB2),LH=0,LHM) C IF(MSTART.GT.3)GO TO 78 CC MTGD0=0 MTGD1=-1 DO N=1,NMTGD MTGD1=MTGD1+MXMTGD READ(MR,ERR=994)(DC(I),I=MTGD0,MTGD1) !REC4 MTGD0=MTGD1+1 ENDDO READ(MR,ERR=994)(DC(I),I=MTGD0,MTGD) !REC4 CC MTGD0=1 MTGD1=0 DO N=1,IMTGD MTGD1=MTGD1+MXMTGD*(LREC/4) READ(MR,ERR=994)(IDC(I),I=MTGD0,MTGD1) !REC4 MTGD0=MTGD1+1 ENDDO READ(MR,ERR=994)(IDC(I),I=MTGD0,MTGDI) !REC4 CC READ(MR,ERR=994)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC4 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) CC 77 MSTART=3 c if(btime)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for algeb3' !par cpar else !par write(iw,*)'Starting algeb3' cpar endif !par if(bloop)write(iw,*)'l=',lnew call cpu_time(timei) endif C C*********************************************************************** C CALL ALGEB3(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL) !-3- C C*********************************************************************** C if(btime)then call cpu_time(timef) times=timef-timei c if(bloop)write(iw,*)'l=',lnew cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for algeb3:' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iw) !par cpar else !par write(iw,*)'Ending algeb3: time=',nint(times),'sec' cpar endif !par endif c IF(NF.LE.0)GO TO 80 C IF(BSTART)GO TO 72 !<----- NO RESTART ----- C C NJO=JSP(1) C IF(NJO.LT.0)GO TO 79 !NO LONGER POSSIBLE,=0 OFF C NCJ=QBML(1) !TOT NO. LEVELS IADJ0=0 IF(NL.GT.0)IADJ0=IADJ CC IF(.NOT.BPASS)THEN DO N=1,NMTGD+IMTGD+3 BACKSPACE(MR) !REC4 ENDDO ENDIF C WRITE(MR)NJO,IRS,NL,IADJ,IADJ0,IRKP,IRLP,NCJ,NMETAJ !REC4 C IF(IADJ.GT.2**29)GO TO 996 !*4 RECL > 2GB IF(IRKP.GT.2**28)GO TO 996 !*8 RECL > 2GB IF(IADJ0.GT.2**29)GO TO 996 !*4 RECL > 2GB IF(IRS.GT.2**28)GO TO 996 !*8 RECL > 2GB CC IF(NJO.EQ.0)THEN !LS WRITE(MR)NJO !REC5 LREC5=1 ELSE WRITE(MR)NJO,(NRR(I),I=1,NCJ),(NT(I),I=1,NJO) !REC5 X ,(JJ(I),I=1,NCJ),(NGR(I),I=1,NCJ),(NMETGJ(I),I=1,NJO) X ,((NSLJ(J,I),J=1,NSL0),I=1,NJO),(NGSLJ(I),I=1,NJO) X ,(NTJ(I),I=1,KM),(NFJ(I),I=1,NCJ) X ,((QRLP(J,I),J=1,4),I=1,IRLP),((QSS(J,I),J=1,5),I=1,NL) WRITE(MR)(NADP(I),I=1,IADJ) WRITE(MR)(DRKP(I),I=1,IRKP) WRITE(MR)(NRKP(I),I=1,IRKP) WRITE(MR)(NADR(I),I=0,IADJ0) WRITE(MR)(DSS(I),I=1,IRS) WRITE(MR)(MSS(I),I=1,IRS) LREC5=7 C IF(BPASS)GO TO 76 CC MTGD0=0 MTGD1=-1 DO N=1,NMTGD MTGD1=MTGD1+MXMTGD WRITE(MR)(DC(I),I=MTGD0,MTGD1) !REC6 MTGD0=MTGD1+1 ENDDO WRITE(MR)(DC(I),I=MTGD0,MTGD) !REC6 CC MTGD0=1 MTGD1=0 DO N=1,IMTGD MTGD1=MTGD1+MXMTGD*(LREC/4) WRITE(MR)(IDC(I),I=MTGD0,MTGD1) !REC6 MTGD0=MTGD1+1 ENDDO WRITE(MR)(IDC(I),I=MTGD0,MTGDI) !REC6 CC WRITE(MR)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC6 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) ENDIF GO TO 76 CC 78 READ(MR,ERR=994)NJO,IRS,NL,IADJ,IADJ0,IRKP,IRLP,NCJ,NMETAJ !REC4 CC IF(IABS(MOD0).GT.1.OR.NJO.EQ.0)THEN READ(MR,ERR=994)NJO !REC5 NJO=0 ELSE C SET ALLOCATE SIZE !F95 IF(MSTART.GT.4)THEN !SINCE MAXIMAL !F95 IRKXX=IRKP !F95 IRLXX=IRLP !F95 IRSXX=IRS !F95 NLXX=NL !F95 ELSE !NOT YET MAXIMAL !F95 IRKXX=MXSOC !F95 IRLXX=MXSOI !F95 IRSXX=MXRSS !F95 NLXX=MAXMI !F95 ENDIF !F95 C !F95 C EX-COMMON/COEFF/ !F95 ALLOCATE (DRKP(IRKXX),QRLP(4,IRLXX),NRKP(IRKXX),NADP(IADJ) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB:ALLOCATION FAILS FOR DRKP,QRLP,NRKP,NADP'!F95 GO TO 999 !F95 ENDIF !F95 BCOEFF=.TRUE. !F95 C !F95 C EX-COMMON/DMQSS3/ !F95 ALLOCATE (DSS(IRSXX),MSS(IRSXX),QSS(5,NLXX),NADR(0:IADJ0) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR DSS,MSS,QSS,NADR' !F95 GO TO 999 !F95 ENDIF !F95 BDMQSS3=.TRUE. !F95 CC READ(MR,ERR=994)NJO,(NRR(I),I=1,NCJ),(NT(I),I=1,NJO) !REC5 X ,(JJ(I),I=1,NCJ),(NGR(I),I=1,NCJ),(NMETGJ(I),I=1,NJO) X ,((NSLJ(J,I),J=1,NSL0),I=1,NJO),(NGSLJ(I),I=1,NJO) X ,(NTJ(I),I=1,KM),(NFJ(I),I=1,NCJ) X ,((QRLP(J,I),J=1,4),I=1,IRLP),((QSS(J,I),J=1,5),I=1,NL) READ(MR,ERR=994)(NADP(I),I=1,IADJ) READ(MR,ERR=994)(DRKP(I),I=1,IRKP) READ(MR,ERR=994)(NRKP(I),I=1,IRKP) READ(MR,ERR=994)(NADR(I),I=0,IADJ0) !+/- ALGEB4 READ(MR,ERR=994)(DSS(I),I=1,IRS) READ(MR,ERR=994)(MSS(I),I=1,IRS) C IF(MSTART.EQ.4)THEN MTGD0=0 MTGD1=-1 DO N=1,NMTGD MTGD1=MTGD1+MXMTGD READ(MR,ERR=994)(DC(I),I=MTGD0,MTGD1) !REC6 MTGD0=MTGD1+1 ENDDO READ(MR,ERR=994)(DC(I),I=MTGD0,MTGD) !REC6 CC MTGD0=1 MTGD1=0 DO N=1,IMTGD MTGD1=MTGD1+MXMTGD*(LREC/4) READ(MR,ERR=994)(IDC(I),I=MTGD0,MTGD1) !REC6 MTGD0=MTGD1+1 ENDDO READ(MR,ERR=994)(IDC(I),I=MTGD0,MTGDI) !REC6 CC READ(MR,ERR=994)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC6 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) ENDIF ENDIF CC IF(MSTART.GT.4)THEN NL000=NL GO TO 70 ENDIF C 72 MSTART=4 c if(btime)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for algeb4' !par cpar else !par write(iw,*)'Starting algeb4' cpar endif !par if(bloop)write(iw,*)'l=',lnew call cpu_time(timei) endif C C*********************************************************************** C CALL ALGEB4(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL) !-4- C C*********************************************************************** C if(btime)then call cpu_time(timef) times=timef-timei c if(bloop)write(iw,*)'l=',lnew cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for algeb4:' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iw) !par cpar else !par write(iw,*)'Ending algeb4: time=',nint(times),'sec' cpar endif !par endif c IF(NF.LE.0)GO TO 80 C IF(BSTART)GO TO 79 !<----- NO RESTART ----- C C NJO=JSP(1) C IF(NJO.LT.0)GO TO 79 !NO LONGER POSSIBLE,=0 OFF C IF(NJO.GT.0.AND..NOT.BPASS)THEN DO N=1,NMTGD+IMTGD+3 BACKSPACE(MR) !REC6 ENDDO ENDIF C IF(NL000.LT.NL)NL000=NL000+1 CC IF(NL000.LE.NL.AND.(NJO.LE.0.OR.MPOLE.LT.6))THEN !.LT.6 FOR M2 WRITE(MR)NL !REC6 WRITE(MR)MBP1MX !REC7 ELSE DO L=1,LREC5 BACKSPACE(MR) !REC5 ENDDO BACKSPACE(MR) !REC4 DO L=1,LREC3 BACKSPACE(MR) !REC3 ENDDO CC WRITE(MR)(NSL(I),I=1,NSL0),(QSI(I),I=1,NSL0) !REC3 X ,(QLI(I),I=1,NSL0),(QPI(I),I=1,NSL0),(NMETAG(I),I=1,NSL0) X ,((KGSL(I,J),I=1,KM),J=1,NSL0),(NADG(I),I=1,NSL0) X ,(NFI(I),I=1,NTT),(NFK(I),I=1,NTT),(NFQ(I),I=1,NTT) WRITE(MR)(NAD(I),I=0,IADD) WRITE(MR)(DRK(I),I=1,IRKK) WRITE(MR)(NRK(I),I=1,IRKK) WRITE(MR)(((NED(I,J,K),I=1,2),J=1,ID1),K=1,ID2) WRITE(MR)((QRL(J,I),J=1,5),I=1,IRL) X ,(DEK(I),I=1,IRKO),(BFALL(I),I=1,IRKO) X ,((BINDB(I,LH),I=1,MXORB2),LH=0,LHM) C WRITE(MR)NJO,IRS,NL000,IADJ,IADJ0,IRKP,IRLP,NCJ,NMETAJ !REC4 C WRITE(MR)NJO,(NRR(I),I=1,NCJ),(NT(I),I=1,NJO) !REC5 X ,(JJ(I),I=1,NCJ),(NGR(I),I=1,NCJ),(NMETGJ(I),I=1,NJO) X ,((NSLJ(J,I),J=1,NSL0),I=1,NJO),(NGSLJ(I),I=1,NJO) X ,(NTJ(I),I=1,KM),(NFJ(I),I=1,NCJ) X ,((QRLP(J,I),J=1,4),I=1,IRLP),((QSS(J,I),J=1,5),I=1,NL000) WRITE(MR)(NADP(I),I=1,IADJ) !^^^ WRITE(MR)(DRKP(I),I=1,IRKP) WRITE(MR)(NRKP(I),I=1,IRKP) WRITE(MR)(NADR(I),I=0,IADJ0) WRITE(MR)(DSS(I),I=1,IRS) WRITE(MR)(MSS(I),I=1,IRS) C WRITE(MR)NL !REC6 WRITE(MR)MBP1MX,MBP2MX,MEKVMX !REC7 X ,(((NMD1(I,J,K),I=1,2),J=1,NJO),K=1,NCJ) X ,(((NMD2(I,J,K),I=1,2),J=1,NJO),K=1,NCJ) ENDIF GO TO 76 CC 70 READ(MR,ERR=994)NL !REC6 CC c write(0,*)nl,nl000,mbp1mx IF(IABS(MOD0).GT.1.OR.(NL000.LE.NL.OR.MBP1MX.LT.0) X .AND.MPOLE.LT.6)THEN !6 FOR M2 C EX-COMMON/NRBMKP/ !F95 ALLOCATE (NMD1(1,1,1),NMD2(1,1,1),STAT=IERR) !F95 CC READ(MR,ERR=994)MBP1MX !REC7 CC IF(IABS(MOD0).GT.1.OR.KUTSS.EQ.-1)NL=0 NL000=NL MBP1MX=-2 MBP2MX=0 MEKVMX=-2 NMD1(1,1,1)=-1 NMD2(1,1,1)=-1 ELSE C EX-COMMON/NRBMKP/ !F95 ALLOCATE (NMD1(2,NJO,NCJ),NMD2(2,NJO,NCJ),STAT=IERR) !F95 CC READ(MR,ERR=994)MBP1MX,MBP2MX,MEKVMX !REC7 X ,(((NMD1(I,J,K),I=1,2),J=1,NJO),K=1,NCJ) X ,(((NMD2(I,J,K),I=1,2),J=1,NJO),K=1,NCJ) CC ENDIF IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: ALLOCATION FAILS FOR NMD1,NMD2' !F95 GO TO 999 !F95 ENDIF !F95 BNRBMKP=.TRUE. !F95 C C----------------------------------------------------------------------- C 79 CONTINUE C IF(IDW.NE.0)THEN C C SEE IF WE CAN REDUCE THE TARGET SLATER-STATE EXPANSION FOR THE C COLLISION PROBLEM AT HAND. C CALL REDSS(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL) C NPRNT0=NPRINT IF(BREL)NPRNT0=MIN(-5,NPRINT-5) C NTT=NTG(KM) !TOTAL NO. OF TERMS USED NSS=JYF(KM) !TOT NO. SLATER STATES NEEDED NESS=MAXEL*NSS !NO. ELECTRONS*SLATER STATES IF(DC0.LT.DZERO)THEN MDCBUF=-MDCBUF MTGDI=1 IDC(1)=0 ELSE MTGDI=MTGD ENDIF C REWIND(MR) C C THIS DUMP IS JUST THE RESTART DUMP AFTER THE CALL TO ALGEB1 C ANY/EVERYTHING ELSE IS RE-CREATED OR STILL HELD IN MEMORY. C TBD: ALL IS DUMPED/RE-CREATED SO THAT CAN IMPLEMENT COLLISON ALGEBRA C RESTARTX. C WRITE(MR) X MLIT,MXORB,NW,NF,MODE,KCUT,KUTDSK,QQCUT,QCL0,QCS0,MDCBUF !REC1 X ,MTGD,MTGDI,NTT,NSS,MAXEL,KM,NPRNT0,MA,MB,MAXNV,IRLX,ITANAL X ,((NEL(I,J),I=1,MXORB),J=1,KM),((NNL(I,J),I=1,NW),J=1,3) X ,((QCG(I,J),I=1,MAXEL),J=1,KM),(QL(I),I=1,MXORB) X ,(QN(I),I=1,MXORB),(DEY(I),I=1,MXORB),(MSTAT(I),I=1,KM) X ,(IEQ(I),I=0,MXORB),(IGRCF(I),I=1,MXORB),(BANAL(I),I=1,KM) X ,(KGCF(I),I=0,KM),((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KM) C WRITE(MR)(DC(I),I=0,MTGD) !REC3 WRITE(MR)(IDC(I),I=1,MTGDI) !REC3 WRITE(MR)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC3 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) C ENDIF C 80 CONTINUE C IF(MPRINT.LE.-3)THEN WRITE(6,190)MPRINT IF(NF.GT.0)NF=0 ENDIF C IF(NF.LT.0.AND..NOT.BSTART.AND.BPASS.AND.MSTART.GT.1)WRITE(6,1012) c write(0,*)nl,nl000,mbp1mx,mbp2mx,mekvmx,mpole C IF(BREL)NPRINT=MOD(NPRINT,5) C C 990 CONTINUE C C FINALIZE: C C IDW=0 (CLOSE) WRITE/READ DC ARRAY TO/FROM DISK C IDW>0 REPOINT/REWIND FOR ALGX BRANCH C IF(BDISK.AND.IUNIT(IUD).GT.0) x CALL DISKDC(IUD,DC,IDC,IDW,0,0,0,0,MSTRT0) C C DE-ALLOCATE C IF(BALLDC)THEN !F95 DEALLOCATE (DC,IDC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: DE-ALLOCATION FAILS FOR DC,IDC' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BMNAM)THEN !F95 DEALLOCATE (MAM,NAM,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: DE-ALLOCATION FAILS FOR MAM,NAM' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BQXXX)THEN !F95 DEALLOCATE (QBMS,QBML,QLMC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: DE-ALLOCATION FAILS FOR QXXX' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BQLMS)THEN !F95 DEALLOCATE (QLMS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB: DE-ALLOCATION FAILS FOR QLMS' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C CF77 IF(DC0.GT.DZERO.AND.MXIDC.NE.MAXDC)THEN !F77 CF77 WRITE(6,*)"CODE HARDWIRED FOR SPEED, SET CPU='SEC'" !F77 CF77 WRITE(0,*)"CODE HARDWIRED FOR SPEED, SET CPU='SEC'" !F77 CF77 NF=-1 !F77 CF77 RETURN !F77 CF77 ENDIF !F77 CF77 IF(DC0.LT.DZERO.AND.MXIDC.EQ.MAXDC)THEN !F77 CF77 WRITE(6,*)'WARNING: CODE HARDWIRED FOR MIN MEMORY, BUT '!F77 CF77 X ,'YOU ARE NOT USING IT - MAY CAUSE YOU TO INFLATE MAXDC' !F77 CF77 WRITE(6,*)"*** SET CPU='MEM'" !F77 CF77 WRITE(0,*)'WARNING: CODE HARDWIRED FOR MIN MEMORY, BUT '!F77 CF77 X ,'YOU ARE NOT USING IT - MAY CAUSE YOU TO INFLATE MAXDC' !F77 CF77 WRITE(0,*)"*** SET CPU='MEM'" !F77 CF77 ENDIF !F77 C 998 RETURN C C 994 WRITE(6,*)'*** RESTART ERROR - PROBABLY DUE TO INCONSISTENT', X ' MSTART FOR STATE OF RESTART FILE...' WRITE(0,*)'*** RESTART ERROR - CHECK MSTART ***' NF=0 GO TO 990 C 995 NF=-1 GO TO 990 C 996 WRITE(6,*)'*** RECORD LENGTH .GT. 2GB, CANNOT USE RESTART:', X ' MSTART=',MSTART NF=0 GO TO 990 C 999 NF=0 GO TO 990 C C C COMMENT TO SR VCU AND VCG (CALLED IN SR ALGEB1) C MODE.EQ.0: ALL VCC FOR ALL COMPLETE TERMS I OF CONFG CF TO BE STORED C PROVIDED KCUT=CFMAX (RATHER THAN=0) IS SPECIFIED C MODE.EQ.1: ONLY VCC FOR SLATERSTATES WITH !ML+MS!=MIN OF ALL TERMS I C MODE.EQ.2: ONLY VCC FOR SLATERSTATES WITH ML=0,!MS!=MIN OF ALL TERMS C MODE.EQ.-1,M-.EQ.-2 EQUIV+1,2 FOR ML,MS.LT.0, BUT ALL -,-.GT.0 KEPT C .GE.3: ONLY SLSTATES AND VCC WITH ML=L,MS=S OF TERM 2S=QCS0,2L=QCL0 C 190 FORMAT(/' THIS WAS NO MORE THAN A DIMENSION CHECK -- MPRINT=',I2/) 700 FORMAT(//"RESTART FILE '",2A4,"' READ BACK WITH MSTART=",I2//) 800 FORMAT(//"SR.ALGEB CREATES RESTART FILE '",2A4,"', MSTART=",I2/) 1007 FORMAT(' ERROR IN RESTART ALGEBRA L-LOOP, FIRST L WRITTEN=',I3 X,' BUT FIRST L TO BE READ=',I3) 1011 FORMAT('*** WARNING: READ OF RESTART FILE GENERATED BY NON-', X 'RELATIVISTIC ORBITAL RUN - RETARDATION NEGLECTED!!') 1012 FORMAT(//'INCOMPLETE ALGEBRA RUN, BUT RESTART CANNOT BE RECOVERED' X/'FIX PROBLEM AND RUN WITH MSTART=1, SET BPASS=.FALSE. TO BE ABLE' X/' TO RECOVER ANY FUTURE INCOMPLETE RUN.') C END C C ******************* C SUBROUTINE ALGEB0(DC0,MAXEL) C C----------------------------------------------------------------------- C C SR.ALGEB0 READS USER INPUT, CONFIGURATIONS ETC, CONTROLLING ANGULAR C ALGEBRA OPERATION AND SETS-UP ACCORDINGLY FOR ITS SUBSEQUENT C GENERATION. C ALSO, CASE A.S., AUTOMATICALLY GENERATES N+1 ELECTRON CONFIGS FROM C N-ELECTRON TARGET, FOR BOUND-CONTINUUM PROBLEMS (DR/RR ETC.) C C THIS ROUTINE IS SOMEWHAT MESSY DUE RETENTION OF EARLIER INPUT C FORMATS, SOME OF WHICH MAY NO LONGER WORK....... C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam,nproc, !par cpar A comm_barrier,comm_finalize !par C USE COMMON_NRBRN2, ONLY: MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BDR,BLOOP,BREL,BJUMPR,BFOT,BFANO,BNAME,BMVD,BPASS,BANAL X ,BTHRSH,BDISK x ,btime,btimex CF77 X ,BINDB !F77 C CHARACTER(LEN=8) TITLE,RTITLE CHARACTER(LEN=4) MLIT,MLIT0,MLIT1,PHASE,CODE,COD,RUN CHARACTER(LEN=4) CUP,RAD,BORN,BASIS CHARACTER(LEN=3) CPU,TARGET CHARACTER(LEN=1) XDR,XDR0,QLIT,C2C C INTEGER*8 MDCF8,MDCFT8 C PARAMETER (MXD08=21*(MAXCF+5)) !S.S. NO. CF INPUT LINES*21 PARAMETER (MXD12=100) PARAMETER (MXD14=100) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C DIMENSION MLIT0(2),MLIT1(2),COD(20),QLIT(0:10),C2C(21) DIMENSION KCFS0(MAXCF),I2I(21),KORDER(MAXCF) C COMMON /BASIC/NF,KX,KG,K1,K2,MGAP(7) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODE,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF) COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /SSWRK/IWRK1(MXD08),IWRK2(MXD08) COMMON /NRBAL0/IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS,MLIT(2) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MGP(2),KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTXX,NTJ(MAXCF),NFJ(MAXLV) X ,KUTSO COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDW/IDW X ,NASTB,MINSTB,MAXSTB,MINLTB,MAXLTB X ,NASTJB,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBFAN/BFANO COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBJ/JPI(MAXJG),NASTJ,MINJT,MAXJT COMMON /NRBJP/JPIP(MAXJG),NASTJP,MINJTP,MAXJTP COMMON /NRBKUTP/KCUTP,LSKUTP(MAXSL),NASTKP COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLIM/ECNTRB,ITANAL,BANAL(MAXCF) !ALGEBRAIC COMMON /NRBLOO/BLOOP,LNEW,LCON,LSUM,LMAX COMMON /NRBLS/LSPI(MAXSL),NAST,MINST,MAXST,MINLT,MAXLT,IPAR COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP COMMON /NRBNAM/BNAME,NF0 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBUNI/IUNIT(MXD14),NUNIT common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex C EQUIVALENCE (RTITLE,MLIT(1)),(TITLE,MLIT1(1)),(PHASE,MLIT0(1)) C C NAMELIST/SALGEB/MPRINT,RAD,MODE,CUP,K1,K2,KORB1,KORB2,XDR,RUN,LCON X,TITLE,MSTRT0,MDEL,QCS0,QCL0,KCUT,KUTSO,KUTOO,KUTSS,QCUT,MCFSS X,MSTART,NAST,KCOR1,KCOR2,MXVORB,MXCONF,IDIAG,MAXLAM,BORN,KPOLE X,KPOL0,KPOLM,PHASE,BASIS,MBP1MX,MBP2MX,MEKVMX,ICFG,NXTRA,LXTRA X,LCON0,IFILL,QQCUT,KUTM1,ISCALR,MINST,MAXST,MINLT,MAXLT,KSUBCF X,MXCCF,KCUTP,NASTP,MINSTP,MAXSTP,MINLTP,MAXLTP,KCUTCC,KCUTI X,IPAR,NASTJ,MINJT,MAXJT,IDW,INAST,INASTJ,NASTJP,MINJTP,MAXJTP X,MAXJFS,FACTL,FACTJ,NMETA,NMETAJ,NMETAG,NMETGJ,LCONDW,LCONDWJ X,KUTSSX,KUTOOX,MAXLX,MXLAMX,LRGLAM,MAXLOO,TARGET,LVMIN,LVMAX X,CPU,KUTDSK,BDISK,BPASS,RTITLE,ITANAL,ECNTRB x ,iw,iwp,btime,btimex,ione !ione0 C NAMELIST/DRR/NMIN,NMAX,NS0,NRAD,JND,LMIN,LMAX,LCON,LORIG,LINC X,NSX,NSW C DATA QLIT/' ','0','1','2','3','4','F','S','Q','W','X'/ C QKCUT=ICHAR('1') LBLNK=ICHAR(' ') C IF(MOD(MXDFS,2).NE.0)THEN !MUST BE EVEN WRITE(6,*)'SET FACTORIAL ARRAY MXDFS EVEN, E.G.',MXDFS+1 WRITE(0,*)'SET FACTORIAL ARRAY MXDFS EVEN, E.G.',MXDFS+1 GO TO 999 ENDIF C MXDFS0=40 !CHECK FACTORIAL ARRAY FOR STUPIDITY IF(MXDFS.LT.MXDFS0)THEN WRITE(6,*)'INCREASE FACTORIAL ARRAY TO MXDFS=',MXDFS0 WRITE(0,*)'INCREASE FACTORIAL ARRAY, MXDFS' GO TO 999 ENDIF C MXDFS0=680 !REAL*8 GOOD TO ABOUT MXDFS=680 IF(MXDFS.GT.MXDFS0)THEN !THIS GIVES MAX L APPROX MXDFS0/4=170 WRITE(6,*)'DECREASE FACTORIAL ARRAY TO MXDFS=',MXDFS0 WRITE(0,*)'DECREASE FACTORIAL ARRAY, MXDFS' GO TO 999 ENDIF C C SOME INITIALISATIONS C btime=.false. !detailed structure timing btimex=.false. !detailed collision timing iw=0 !=0 to screen, =6 to file, if btime .true. cpar iwp=6 !suppress some screen writes !par c KM=999 KUTDSK=KM !NO USE OF DISKDC DC0=DONE NF=0 IRET0=0 IDW=0 MR=10 IDR=0 BFOT=.FALSE. BMVD=.FALSE. KPOLE=-999 KPOL0=-999 KPOLM=100 IEQ(0)=0 MENGB=-2 IRLX=0 IDIAG=0 ! TRY SR.DIAG FIRST FOR DIAGONALIZATION OF S/L**2 ICFG=0 QQCUT=0 ! 1 ALL 2FS, 2 SO, 3 SOO, 4 SS MAXLAM=1000 KUTM1=0 ISCALR=0 ITANAL=0 ECNTRB=9999999 C INASTJ=0 NASTJ=0 MINJT=0 MAXJT=2000 NASTJP=0 MINJTP=0 MAXJTP=2000 INAST=0 NAST=0 MINST=0 MAXST=100 MINLT=0 MAXLT=1000 IPAR=2 NASTP=0 MINSTP=0 MAXSTP=100 MINLTP=0 MAXLTP=1000 MAXLX=MAXLT MAXLOO=MAXLT MXLAMX=1000 MAXJFS=-999 KUTSSX=-999 KUTOOX=-999 LFACT=100 JFACT=200 C NMETA=0 NMETAJ=0 DO I=1,MAXSL NMETAG(I)=0 ENDDO DO I=1,MAXJG NMETGJ(I)=0 ENDDO ione0=0 !algxls/fs ione, elastic needed for mixing ione=1 !=1/0 exc/inc elastic transitions: idw.ne.0 C LCONDW=0 LCONDWJ=0 LRGLAM=-999 !TOP-UP FLAG (L/2J) LVMIN=0 !RYDBERG L-RANGE FOR THRESHOLD DW LVMAX=-1 !WRITES TO ADF04 FOR ADF46 BBGP USE C KSUBCF=999 !FULL SUBCONFIGURATION RESOLUTION KCUTP=-999 !PARENT CF CORRELATION KCUTCC=0 !N+1 BOUND CF CORRELATION KCUTI=0 !CONT CORE RE-ARRANGE CORRELATION C DO I=1,MAXCF KCFSS(I)=0 ENDDO C C READ CODE C CODE(1).EQ.'S.S.' FOR ORIGINAL EISSNER (SS) INPUT OF CONFIGURATIONS C CODE(1).EQ.'A.S.' FOR OCCUPATION NUMBERS. C CODE(2-20) FOR INFORMATION PURPOSES. C READ(5,1000)COD WRITE(6,1001)COD C CODE=COD(1) IF(CODE.NE.'S.S.'.AND.CODE.NE.'A.S.')THEN WRITE(6,1002)CODE WRITE(0,*)"INPUT ERROR:NEED 'S.S.' OR 'A.S.' AT START OF LINE 1" GO TO 999 ENDIF C C ORIGINAL SS INPUT (EISSNER NOTATION) C IF(CODE.EQ.'S.S.')THEN C C IN IF-LOOP 96 CARDS ARE READ UNTIL A TERMINATOR IS FOUND C (A CARD THAT IS BLANK IN T10,I2 IS REFERRED TO AS A C-TERMINATOR). C I=0 KH=I 96 KG=KH I=I+21 IF(I.LE.MXD08)THEN KF=KH+1 KH=I ENDIF C READ(5,50)MSTRT0,IFREE,QCS0,QCL0,XDR0,(I2I(J),C2C(J),J=1,21) X ,MLIT C J=0 DO K=KF,KH J=J+1 IWRK2(K)=I2I(J) IWRK1(K)=ICHAR(C2C(J)) ENDDO C C A TERMINATOR AS FIRST CONFIGURATION CARD CANCELS THE JOB C IF(IWRK2(1).EQ.0)THEN IRET0=1 GO TO 996 !RETURN ENDIF C C OTHERWISE (T10,21(I2,Z1)) EXCEPT ON THE TERMINATOR ARE READ AS A C STRING OF Q=MOD(C(I2),50) EQUIVALENT ELECTRONS NL=FUNCTION(C(Z1)); C Q+50 STANDS FOR: THESE Q ELECTRONS FORM A CONFIGURATION TOGETHER C WITH WHAT STANDS LEFT OF IT. C EXAMPLE: ' 22523 12533' IN COLUMNS 10..21 WILL BE INTERPRETED (IN C SR ALGEB1) AS TWO CONFIGURATIONS, 2S**2+2P**2 AND 2S+2P**3, C PROVIDED THE TERMINATOR IS BLANK IN COLUMNS 16..60; THEN K=C(Z1)= C 1,2,3,..9,A,..F STANDS FOR 1S,2S,2P,..4D,4F,..5G. C THE STRING MAY BE BROKEN BY A MULTIPLE OF THREE GAPS AFTER ANY C CONFIGURATION, BUT ON THE NEXT CARD IT MUST CONTINUE IN T10,I2,Z1. C C MPRINT=-5,-6,-7: SAME AS 0,-1,-2 BUT KAPPA-AVERAGE RADIAL FUNCTIONS. C IF(KF.EQ.1)THEN IF(MLIT(1).EQ.' ')MLIT(1)='NAME' BNAME=MLIT(1).EQ.'NAME' IF(BNAME)THEN K1=0 K2=0 MPRINT=-2 MODE=-999 XDR=' ' TITLE=' ' PHASE=' ' ELSE MPRINT=MSTRT0 MODE=IFREE MLIT0(1)=MLIT(1) MLIT0(2)=MLIT(2) K1=QCS0 K2=QCL0 XDR=XDR0 ENDIF ENDIF C C ON THE SECOND AND FOLLOWING CARDS COLUMNS 1..9 AND 73..80 ARE C IGNORED; THE LAST 8 COLUMNS OF THE FIRST CARD ARE PRINTED AT THE C BEGINNING OF THE HEADLINE (AS LITERAL DATA); C(T1,I2)=BLANK SUP- C PRESSES PRINTOUT OF SLATER STATES AND OF ALL ANGULAR COEFFICIENTS. C C(T3,I2)=MODE IS INPUT TO SR VCU AND IS DESCRIBED BELOW; C FOR THE PROBLEMS DEALT WITH HERE MODE=-1 SUFFICES. C C(T5,I2)=K1 AND C(T7,I2)=K2 WILL BE INTERPRETED AS FOLLWS: K1..K2 C FORM A CORE CONFIGURATION C0 OF CLOSED SUBSHELLS WHICH WILL BE ADD C ED ONTO ALL CONFIGURATIONS LISTED IN THE STRING BEHIND (AN ORBITAL C (N,L) SPECIFIED IN BOTH PLACES WILL BE IGNORED IN THE LATTER). C IF(IWRK2(KF).NE.0)GO TO 96 IF(I.GT.MXD08)THEN !NOT ENOUGH BUFFER SPACE KGG=I GO TO 97 ENDIF C C ELSE C C C 'A.S.' R-MATRIX STYLE INPUT, AND SO ..... C BNAME=.TRUE. K1=0 K2=0 MPRINT=-2 MODE=-999 XDR=' ' PHASE=' ' TITLE=' ' C ENDIF C C SYNCHRONISE FILES C IF(.NOT.BLOOP.OR.LSUM.LE.0)THEN IF(IUNIT(7).GT.0)BACKSPACE(7) IF(IUNIT(8).GT.0)BACKSPACE(8) IF(IUNIT(17).GT.0)BACKSPACE(17) IF(IUNIT(18).GT.0)BACKSPACE(18) IF(IUNIT(27).GT.0)BACKSPACE(27) IF(IUNIT(28).GT.0)BACKSPACE(28) IF(IUNIT(29).GT.0)BACKSPACE(29) IF(IUNIT(30).GT.0)BACKSPACE(30) ENDIF C C IF(CODE.EQ.'S.S.')THEN C C C COLUMNS 16..60 OF THE TERMINATOR ALLOW FOR REDEFINING K=1,2,3..15: C IF THE K'TH (I2,I1) IS NOT BLANK NK=C(I2)+LK=C(I1) (IN ALGEB1). C IF(T63,A1) IS NON-ZERO CODING CONTINUES ON NEXT CARD 15(I2,A1) C COLUMNS 16 TO 60. C THIS PROVIDES AN ALTERNATIVE DEFINITION OF ORBITALS TO SCREENING C PARAMETER IN SR.MINIM ( IF BOTH ARE USED THE LATTER HOLDS TRUE) C NAMELY: C N=1-69 BOUND ORBITALS CALCULATED IN SR.RADIAL C N=70-79 ORBITALS INPUT FROM SR.RADWIN C N=80-89 VALENCE ORBITALS TO BE SUMMED OVER IN DR PART OF PROGRAM C N=90-99 CONTINUUM ORBITALS CALCULATED IN SR.RADCON C C EVT IF(IWRK1(KH).EQ.QX)GO TO 96 , WHERE DATA..QX/'X'/. C IF(.NOT.BNAME)THEN C C IFREE COULD SERVE TO SPECIFY INDIVIDUAL RESTARTFILES C IF(IFREE.GT.0)MR=IFREE !REDEFINE RESTART UNIT NUMBER C QCUT=IWRK1(KH) MDEL=IFREE !OMIT RADIATION WITH N-N' .LT. MDEL KCUT=IWRK2(KF+1) IF(IWRK1(KF).EQ.QKCUT)KCUT=KCUT+100 KUTSS=IWRK2(KH) MCFSS=0 C MCFSS=IWRK2(KH-1) C KUTOO=0 KUTOO=IWRK2(KH-1) KUTSO=IWRK2(KG+19) MBP1MX=-1 MBP2MX=1 MEKVMX=1 BPASS=.FALSE. ENDIF C KGG=KG+18 I=KH 63 IF(IWRK1(KGG).EQ.LBLNK)GO TO 61 I=I+21 IF(I.LE.MXD08)THEN KF=KH+1 KH=I ENDIF READ(5,51)(I2I(J),C2C(J),J=1,21) J=0 DO K=KF,KH J=J+1 IWRK2(K)=I2I(J) IWRK1(K)=ICHAR(C2C(J)) ENDDO IF(I.LE.MXD08)KGG=KGG+21 GO TO 63 61 IF(I.GT.MXD08)THEN !NOT ENOUGH BUFFER SPACE KGG=I GO TO 97 ENDIF C ENDIF C C BOTH CODES ('A.S.' IS NAME ONLY ALLOWED). C IF(BNAME)THEN C MSTRT0=0 MSTART=0 BPASS=.TRUE. MCFSS=0 KUTSS=-1 KUTSO=-1 KUTOO=0 MDEL=0 KCUT=0 QCS0=0 QCL0=0 QCUT=0 RTITLE=' ' CUP=' ' RAD=' ' !TAKES DEFAULT MPRINT=-2, NONE RUN=' ' KORB1=0 KORB2=0 KCOR1=0 KCOR2=0 C NAST=0 LRANGE=-1 BORN=' ' BASIS=' ' MBP1MX=-1 !MAX MULTIPOLE 1-BODY BP MK MBP2MX=0 !MAX MULTIPOLE 2-BODY BP MK - ONLY M1 MEKVMX=-1 !MAX MULTIPOLE FOR EK REL VEL FACTL=DONE FACTJ=DONE CPU='MEM' !OPTIMIZE FOR MEMORY ANYTHING ELSE SPEED TARGET='NEW' !FLAG USE OF OLD/NEW TERMS/LEVELS FILES BDISK=.FALSE. !STORE *ALL* DC ARRAY ON DISK C C THESE NEXT ARE ONLY USED BY 'A.S.' C MXVORB=0 !MUST BE RESET MXCONF=0 !MUST BE RESET MXCCF=-1 NXTRA=-1 LXTRA=-1 LCON=0 LCON0=0 IFILL=-1 C C READ(5,SALGEB,END=997,ERR=997) ! <------------------ NAMELIST C c ione=mod(iabs(ione),2) iw=iabs(6*(mod(iw,7)/6)) iwp=iabs(6*(mod(iwp,7)/6)) C IF(CPU.NE.'MEM')DC0=-DONE !THEN OPTIMIZE VCC FOR SPEED IF(BDISK.AND.KUTDSK.EQ.999)KUTDSK=0 C IF(MSTRT0.GE.5)KUTDSK=999 C MXCCF0=MXCCF IF(MXCCF.LT.0)MXCCF=0 C IF(IFILL.LT.0)IFILL=11 IF(LCON.LT.0)LCON=0 LCONT=LCON IF(LCON0.LT.0)LCON0=0 C IF(RUN.EQ.'BBGP')THEN RUN='DE' IF(LVMAX.LT.0)LVMAX=8 ENDIF C IF(RUN.EQ.'DE')THEN LVMAX=MIN(LVMAX,20) BTHRSH=LVMAX.GE.0.AND.LVMAX.GE.LVMIN IF(BTHRSH)LVMIN=MAX(0,LVMIN) ELSE BTHRSH=.FALSE. ENDIF IF(.NOT.BTHRSH)THEN LVMAX=-1 LVMIN=0 ENDIF C IF(RUN.EQ.'DE')IDW=1 IF(RUN.EQ.'DI')IDW=2 C C DIMENSION CHECK MODE IS OBSOLETE - (NOW) ONLY 10% FASTER BUT C SIGNIFICANTLY OVERESTIMATES SOME DIMENSIONS - SO SUPRESS C IFLAG=0 IF(RUN.EQ.'DIM1'.OR.RUN.EQ.'DIM2')THEN IF(IDW.NE.0)THEN IDW=-IABS(IDW) RUN=' ' ELSE IFLAG=1 ENDIF ENDIF IF(RAD.EQ.'DIM1'.OR.RAD.EQ.'DIM2')THEN IF(IDW.NE.0)THEN IDW=-IABS(IDW) RAD=' ' ELSE IFLAG=2 ENDIF ENDIF IF(IDW.LT.0)THEN IDW=-IDW IFLAG=3 ENDIF IF(IFLAG.EQ.1.OR.IFLAG.EQ.2)THEN WRITE(0,*)'NOTE: THIS IS ONLY A *PARTIAL* DIMENSION TEST' WRITE(6,1120) ENDIF IF(IFLAG.EQ.3)THEN WRITE(0,*)'CURRENTLY, THERE IS NO DIMENSION CHECK MODE HERE..' WRITE(6,1121) ENDIF C C SET BORN SWITCHES (INTERACTS WITH RAD) C IF(RAD.EQ.'NO')THEN IF(BORN.EQ.' ')BORN='NO' IF(BORN.NE.'NO')THEN WRITE(6,*)'***SWITCHING-OFF BORN SINCE RAD.EQ."NO"' WRITE(0,*)'***SWITCHING-OFF BORN SINCE RAD.EQ."NO"' BORN='NO' ENDIF ENDIF IF(RAD.EQ.'ALL')THEN IF(BORN.NE.'YES'.AND.BORN.NE.'NO')BORN='INF' IF(BORN.EQ.'NO')MENGB=-1 KPOLM=MIN(KPOLM,5) RAD='BP' ENDIF IF(IDW.EQ.0)THEN IF(BORN.EQ.' ')BORN='NO' IF(RUN.NE.' '.AND.BORN.NE.'NO')THEN WRITE(6,*)'***SWITCHING-OFF BORN SINCE RUN.NE." "' WRITE(0,*)'***SWITCHING-OFF BORN SINCE RUN.NE." "' BORN='NO' ENDIF ELSE IF(BTHRSH)THEN IF(LRGLAM.GT.0)THEN WRITE(6,*)'***SWITCHING-OFF TOP-UP SINCE NONE FOR' X ,' THRESHOLD PARTIAL COLLISION STRENGTHS (LVMAX.GE.0)' WRITE(0,*)'***SWITCHING-OFF TOP-UP SINCE NONE FOR' X ,' THRESHOLD PARTIAL COLLISION STRENGTHS (LVMAX.GE.0)' ENDIF LRGLAM=-2 ENDIF IF(BORN.EQ.'YES')THEN WRITE(6,*)'*** CANNOT GENERATE FINITE ENERGY BORN WITH RUN="' X ,RUN,'"' WRITE(6,*)'*** SWITCHING OFF FINITE ENERGY BORN...' WRITE(0,*)'*** SWITCHING OFF FINITE ENERGY BORN...' BORN='INF' ELSEIF(BORN.EQ.'NO')THEN MENGB=-1 !GET DIPOLE & FLAG BORN IF(RAD.EQ.'NO')THEN ITEST=IABS(INAST)+IABS(INASTJ) IF(LRGLAM.GT.0.OR.LRGLAM.EQ.-999.AND.ITEST.EQ.0)THEN WRITE(6,*)'*** DIPOLE LIMIT REQUIRED FOR TOP-UP' X ,', SWITCHING-ON RADIATION, SWITCH-OFF TOP-UP IF' X ,' REALLY WANT RAD="NO"' WRITE(0,*)'*** SWITCHING-ON DIPOLE LIMIT FOR TOP-UP' KPOLE=1 ELSE MENGB=-2 WRITE(0,*)'*** NO ADF04 AS RAD="NO" !!!' ENDIF ELSE IF(BTHRSH)THEN IF(MPRINT.GE.0)THEN KPOLE=MAX(KPOLE,2) ELSE KPOLE=MAX(KPOLE,1) ENDIF ENDIF WRITE(6,*)'*** INFINITE ENERGY BORN REQUIRED FOR A' X ,' COMPLETE ADF04, PRESSING ON REGARDLESS...' WRITE(0,*)'*** ADF04 INCOMPLETE AS BORN="NO" !!!' ENDIF ELSE BORN='INF' ENDIF ENDIF IF(BORN.EQ.'YES')MENGB=0 !FINITE ENERGY BORN IF(BORN.EQ.'INF')MENGB=1 !INFINITE ENERGY BORN IF(MENGB.LT.0.AND.BORN.NE.'NO')THEN WRITE(6,*)'*** UNRECOGNIZED BORN OPTION: "',BORN,'"' WRITE(0,*)'*** UNRECOGNIZED BORN OPTION!' GO TO 999 ENDIF if(rad.eq.'NO'.and.born.eq.'NO'.and.mprint.gt.0)kpole=-1 C C SET RELAXED ORBITAL SWITCHED C IF(BASIS.NE.' ')THEN !NEW ORBITAL BASIS FOR EACH CFG IEQ(0)=-1 IRLX=1 IF(BASIS.EQ.'RLX2')IRLX=2 ENDIF C C SET COUPLING SWITCHES C IF(CUP.EQ.' '.AND.MODE.EQ.-999)CUP='LS' IF(KUTOO.EQ.-1)KUTOO=0 IF(CUP.EQ.'LS'.AND.KUTOO.NE.0)THEN WRITE(0,*)" *** SWITCHING-OFF KUTOO AS CUP='LS' ..." WRITE(6,*)" *** SWITCHING-OFF KUTOO AS CUP='LS' ..." KUTOO=0 ENDIF C BMVD=CUP.EQ.'LSM'.OR.CUP.EQ.'MVD' IF(BMVD)THEN CUP='LS' ELSE BMVD=CUP.EQ.'ICM' IF(BMVD)CUP='IC' ENDIF C IF(CUP.EQ.'JK'.OR.CUP.EQ.'jK')THEN IF(IDW.EQ.0)WRITE(6,*)'*** JK-COUPLING NOT USED FOR A ', X 'STRUCTURE RUN, SWITCHING TO IC' CUP='IC' !IF IDW.NE.0 WE ONLY HAVE JK, NO NEED TO FLAG ENDIF IF(CUP.EQ.'JKR'.OR.CUP.EQ.'jKR')THEN IF(IDW.EQ.0)WRITE(6,*)'*** JK-COUPLING NOT USED FOR A ', X 'STRUCTURE RUN, SWITCHING TO ICR' CUP='ICR' !IF IDW.NE.0 WE ONLY HAVE JK, NO NEED TO FLAG ENDIF C IF(CUP.EQ.'LS'.OR.CUP.EQ.'LSR')MODE=-2 IF(CUP.EQ.'IC'.OR.CUP.EQ.'ICR')MODE=-1 C IF(MODE.EQ.-999)THEN WRITE(6,*)'*** UNRECOGNIZED CUP OPTION: "',CUP,'"' WRITE(0,*)'*** UNRECOGNIZED CUP OPTION' GO TO 999 ENDIF C C SET RADIATION SWICTHES C IF(MBP2MX.GT.1)THEN WRITE(6,*)'*** ERROR: 2-BODY BP CORRECTION TO M1 ONLY, NOT: M' X ,MBP2MX WRITE(0,*)' *** ERROR: 2-BODY BP CORRECTION TO M1 ONLY' GO TO 999 ENDIF IF(MEKVMX.GT.1)THEN WRITE(6,*)' *** ERROR: BP CORRECTION TO E1 VEL ONLY, NOT: E', X MEKVMX WRITE(0,*)' *** ERROR: BP CORRECTION TO E1 VEL ONLY' GO TO 999 ENDIF C IF(RAD.NE.' '.AND.MBP1MX.LT.0)MBP1MX=0 C IF(RAD.EQ.'BP1')THEN MBP1MX=0 MBP2MX=-1 MEKVMX=1 RAD='M2' ENDIF IF(RAD.EQ.'BP'.OR.RAD.EQ.'BP2')THEN MBP1MX=0 c MBP1MX=2 MBP2MX=1 MEKVMX=1 RAD='M2' ENDIF IF(RAD.EQ.'M1BP')THEN MBP1MX=0 MBP2MX=1 MEKVMX=1 RAD='M1' ENDIF IF(RAD.EQ.'M2BP')THEN MBP1MX=2 MBP2MX=1 MEKVMX=1 RAD='M2' ENDIF IF(RAD.EQ.'M3BP')THEN MBP1MX=3 MBP2MX=1 MEKVMX=1 RAD='M3' ENDIF IF(RAD.EQ.'M1')THEN IF(KPOLM.GE.100)KPOLM=1 RAD='E2' ENDIF IF(RAD.EQ.'M2')THEN IF(KPOLM.GE.100)KPOLM=2 RAD='E3' ENDIF IF(RAD.EQ.'M3')THEN IF(KPOLM.GE.100)KPOLM=3 RAD='E4' ENDIF C IF(RAD.NE.'YES'.AND.RAD.NE.'NO'.AND.RAD.NE.' '.AND. X RAD.NE.'E1'.AND.RAD.NE.'E2'.AND.RAD.NE.'E3'.AND.RAD.NE.'E4' X .AND.RAD.NE.'DIM1'.AND.RAD.NE.'DIM2')THEN WRITE(6,*)'*** UNRECOGNIZED RAD OPTION: "',RAD,'"' WRITE(0,*)'*** UNRECOGNIZED RAD OPTION' GO TO 999 ENDIF C IF(MENGB.GE.-1)THEN IF(KPOLE.LT.-100)KPOLE=6 KPOL0=0 IF(IDW*KPOLM.GE.100)KPOLM=1 MPRINT=MAX(0,MPRINT) ENDIF IF(RAD.EQ.'E1'.OR.RAD.EQ.'YES')KPOLE=MAX(1,KPOLE) IF(RAD.EQ.'E2')KPOLE=MAX(2,KPOLE) IF(RAD.EQ.'E3')KPOLE=MAX(3,KPOLE) IF(RAD.EQ.'E4')KPOLE=MAX(4,KPOLE) IF(KPOLM.GE.100)KPOLM=KPOLE-1 MPOLE=2*KPOLE !KPOLE=EK MPOL0=2*KPOL0 MPOLM=2*KPOLM !KPOLM=MK MBP1MX=2*MBP1MX MBP2MX=2*MBP2MX MEKVMX=2*MEKVMX IF(KPOLE.EQ.1)MPRINT=MAX(-1,MPRINT) IF(KPOLE.GT.1)MPRINT=MAX(0,MPRINT) QCUT=ICHAR(QLIT(QCUT)) !OLD M1+BP CUT C C SET RUN SWITCHES: C (DR, RR, PE, PI, DE, RE, YLD - ALLOWED, DI NOT YET CODED) C BDR=RUN.EQ.'DR'.OR.RUN.EQ.'RR'.OR.RUN.EQ.'RE'.OR.RUN.EQ.'PE' BFOT=RUN.EQ.'RR'.OR.RUN.EQ.'PI' IF(BDR)IDR=1 IF(RUN.EQ.'PE')THEN IDR=-1 RUN='DR' !PE JUST INVERSE OF DR ENDIF C IF(IDW.NE.0)THEN BPASS=.FALSE. !NEED DC ARRAY WRITTEN IF(RUN.EQ.'DIM1'.OR.RUN.EQ.'DIM2')THEN IDW=-IABS(IDW) RUN=' ' ENDIF IF(RAD.EQ.'DIM1'.OR.RAD.EQ.'DIM2')THEN IDW=-IABS(IDW) RAD=' ' ENDIF RUN=' ' IF(FACTL.GT.1.D0.AND.FACTL.LT.1.26D0)LFACT=NINT(100*FACTL) IF(FACTJ.GT.1.D0.AND.FACTJ.LT.1.26D0)JFACT=NINT(200*FACTJ) IF(MXCCF.GT.0)THEN WRITE(6,*)' ***ATTENTION: YOU HAVE SPECIFIED CORRELATION ', X 'CONFIGS FOR DIRECT EXCITATION...ATTEMPTING TO IGNORE THEM!' WRITE(0,*)' ***ATTENTION: YOU HAVE SPECIFIED CORRELATION ', X 'CONFIGS FOR DIRECT EXCITATION...ATTEMPTING TO IGNORE THEM!' ENDIF IF(NMETA.LE.0)THEN IF(BTHRSH)THEN NMETA=MAXTM !all for Augers ELSE NMETA=1 !defaults to ground term ENDIF ENDIF IF(NMETAJ.eq.0)THEN IF(BTHRSH)THEN NMETAJ=MAXLV-1 !all for Augers ELSE NMETAJ=MAXLV+1 !defaults to levels of ground term ENDIF ENDIF if(nmetaj.gt.0)then !omit 2fs between excited terms nmetag(0)=-1 !that only s.o. mix with metastables else !include all allowed by a.m. selectn nmetag(0)=0 nmetaj=-nmetaj endif ELSE IF(BDR.OR.MXCCF.GT.0)THEN NMETA=0 NMETAJ=0 ELSE IF(NMETA.LT.0)NMETA=0 IF(NMETAJ.LT.0)NMETAJ=MAXLV+1 ENDIF ENDIF C C NMETA=MAX(NMETA,0) C NMETA=MIN(NMETA,MAXTM) IF(IABS(MODE).GT.1)NMETAJ=0 C IF(TARGET.EQ.'OLD')THEN NMETA=-NMETA NMETAJ=-NMETAJ ELSEIF(TARGET.NE.'NEW')THEN WRITE(6,*)'*** UNRECOGNIZED TARGET OPTION: "',TARGET,'"' WRITE(0,*)'*** UNRECOGNIZED TARGET OPTION' GO TO 999 ENDIF C IF(RUN.NE.' ')THEN !CHECK FOR ALLOWED RUN VALUE IF(.NOT.BDR.AND..NOT.BFOT)THEN IF(RUN.EQ.'DI')THEN WRITE(6,*)'*** DIRECT ELECTRON IONIZATION NOT YET CODED' WRITE(0,*)'*** DIRECT ELECTRON IONIZATION NOT YET CODED' GO TO 999 ENDIF IF(RUN.EQ.'REDA')THEN !'YLD' SHOULD NOT NEED A FLAG NOW WRITE(6,*)"*** RUN REDA AS 'RE' THEN 'YLD'" WRITE(0,*)"*** RUN REDA AS 'RE' THEN 'YLD'" GO TO 999 ENDIF IF(RUN.NE.'YLD'.AND.RUN.NE.'DIM1'.AND.RUN.NE.'DIM2')THEN WRITE(0,1200) WRITE(6,1200) WRITE(6,*)'*** UNRECOGNIZED RUN OPTION: "',RUN,'"' WRITE(0,*)'*** UNRECOGNIZED RUN OPTION' GO TO 999 ENDIF ENDIF ENDIF C C MAP HIGH LEVEL SWITCHES ON TO LOW LEVEL C IF(MSTART.NE.0)MSTRT0=MSTART !RESTART SWITCH if(mstrt0.ne.0.and.IDW.NE.0) x stop "temp: restart not yet coded for RUN='DE' OR 'DI'" C IF(RUN.EQ.'DIM1'.OR.RAD.EQ.'DIM1')MPRINT=-4 !E1 DIMENSION CHECK IF(RUN.EQ.'DIM2'.OR.RAD.EQ.'DIM2')MPRINT=-3 !E2 DIMENSION CHECK C IF(MPRINT.EQ.-2.AND.(BFOT.OR.RUN.EQ.'DR'.OR.RUN.EQ.'YLD'))THEN IF(RAD.EQ.' ')THEN MPRINT=-1 !SWITCH-ON E1 ELSE WRITE(6,*)" ***ATTENTION: YOU HAVE SET RUN.EQ.'",RUN X ,"' BUT ALSO RAD.EQ.'",RAD,"', WHICH DOESN'T MAKE MUCH SENSE..." WRITE(0,*)'***ATTENTION: YOU HAVE SET A RUN/RAD COMBINATION' X ,' WHICH DOES NOT MAKE MUCH SENSE...' ENDIF ENDIF c IF(CUP.EQ.'ICR')MPRINT=MPRINT-5 C IF(KORB1.GT.0)K1=KORB1 IF(KORB2.NE.0)K2=KORB2 IF(KCOR1.GT.0)K1=KCOR1 IF(KCOR2.NE.0)K2=KCOR2 C C SET K2.LT.0 TO READ ALL NL DEFN'S BUT ONLY VALENCE OCCUPATION NOS. C IF(K2.LE.0)THEN KS=0 ELSE KS=K2 ENDIF C ENDIF C C END OF MAIN BNAME READS C KCUTP0=KCUTP IF(KCUTP.EQ.-999)THEN KCUTP=KCUT ELSEIF(KCUT.NE.KCUTP)THEN WRITE(6,*)' ***ATTENTION: YOU HAVE SPECIFIED KCUTP .NE. KCUT...' X ,KCUTP,KCUT,' I HOPE YOU KNOW WHAT YOU ARE DOING!' WRITE(0,*)' ***ATTENTION: YOU HAVE SPECIFIED KCUTP .NE. KCUT...' ENDIF C IF(KCUT.LT.0)KCUT=0 IF(KCUTP.LT.0)KCUTP=0 IF(KCUTCC.LT.0)KCUTCC=0 C IF(KPOLE.LT.-100)MPOLE=4 !2K-POLE IF(KPOL0.LT.-100)MPOL0=2 IF(MDEL.GT.0)MDEL=1 !JAC-DIAG IF(XDR.EQ.'X'.OR.XDR.EQ.'P')THEN BDR=.TRUE. IDR=1 ENDIF IF(XDR.EQ.'F'.OR.XDR.EQ.'P')BFOT=.TRUE. C C MTEST=MPRINT C IF(BFOT.AND.MTEST.EQ.0)MPRINT=-1 C IF(BFOT.AND.MTEST.EQ.-5)MPRINT=-6 NPRINT=MPRINT MPRINT=MOD(MPRINT,5) MPRNT0=MPRINT MOD0=MODE BREL=NPRINT.LT.-4.OR.CUP.EQ.'ICR'.OR.CUP.EQ.'LSR' !HISTORIC... C !SHOULD BE SET IN SRADCON C SET PHASE CONVENTION C DEFAULT: CONDON & SHORTLEY. FANO NOT CODED FOR 2FS C BFANO=MLIT0(1).EQ.'FANO' IF(BFANO)THEN IF(KUTSS.NE.-1.AND.IABS(MODE).LE.1)THEN !2-FS NOT CODED FOR FANO WRITE(6,*)'CANNOT USE FANO PHASE WITH 2-BODY F-S' WRITE(0,*)'CANNOT USE FANO PHASE WITH 2-BODY F-S' GO TO 999 ENDIF IF(IDW.NE.0)THEN !DW NOT CODED FOR FANO WRITE(6,*)'CANNOT USE FANO PHASE WITH DW DIRECT EXCITATION' WRITE(0,*)'CANNOT USE FANO PHASE WITH DW DIRECT EXCITATION' GO TO 999 ENDIF WRITE(6,145) ENDIF IF(BNAME)THEN MLIT0(1)=MLIT1(1) MLIT0(2)=MLIT1(2) ENDIF C C RESET -1 TO 0, I.E. -1 SWITCHES-OFF 2NFS C.F. KUTSS. IF(KUTOO.EQ.-1)KUTOO=0 C IF(KUTSO.EQ.-1.AND.KUTSS.EQ.-9)THEN !WARN USER WRITE(0,*) X' *** WARNING: TWO-BODY FINE-STRUCTURE IS NOW RESTRICTED TO BEING' WRITE(0,*) X' *WITHIN* A CONFIGURATION AS KUTSO=-1 OVERRIDES KUTSS=-9' WRITE(6,*) X' *** WARNING: TWO-BODY FINE-STRUCTURE IS NOW RESTRICTED TO BEING' X,' *WITHIN* A CONFIGURATION AS KUTSO=-1 OVERRIDES KUTSS=-9' ENDIF C C***+AND-OPTIONS INTERCHANGED 23/11/91 TO ALLOW KUTSO WITHIN A KUTSO=-KUTSO C*** CONFIGURATION ONLY FOR .GT. 9 CONFIGS WITH I2 FORMAT. C C C IF MCFSS (T67,I2) .GT. 0 ON FIRST TERMINATOR MCFSS CONFIGURATION C NUMBERS ARE READ-IN FOR WHICH TWO-BODY FINE-STRUCTURE OF SR.RES C ARE TO APPLY 15(I3) IN COLUMNS 1 TO 60 AFTER REDEFINING ORBITALS. C THESE ARE IN ADDITION TO THOSE SPECIFIED BY KUTSS (T70,I2). NO C INTERACTIONS BETWEEN TWO SETS UNLESS SPECIFIED IN BOTH. C IF(MCFSS.GT.0)THEN IF(CODE.EQ.'S.S.')THEN KGG=KGG+MCFSS I=KH+MCFSS IF(I.LE.MXD08)THEN KF=KH+1 KH=I ENDIF READ(5,*)(IWRK2(I),I=KF,KH) COLD 52 FORMAT(24I3) DO I=KF,KH J=IWRK2(I) IF(J.LE.MAXCF)KCFSS(J)=1 ENDDO ELSE MCFSS=MIN(MCFSS,MAXCF) READ(5,*)(KCFS0(I),I=1,MCFSS) DO I=1,MCFSS J=KCFS0(I) KCFSS(J)=1 ENDDO ENDIF ENDIF C IF(CODE.EQ.'A.S.')THEN c c initialize so we can later check for any undefined nel, remove evently do j=1,maxcf do i=1,maxgr nel(i,j)=-1 enddo enddo C C READ NL DEFINITIONS. CORE BASE CONFIGS WILL CONTAIN MXVORBS C IF(MXVORB.NE.0)THEN C MXORB=IABS(K2)+IABS(MXVORB) IF(MXORB.GT.MAXGR)THEN WRITE(6,1004)MXORB WRITE(0,*)'SR.ALGEB: TOO MANY ORBITALS, INCREASE MAXGR' GO TO 999 ENDIF IF(K1.GT.1)THEN WRITE(6,1005)K1 WRITE(0,*)'SR.ALGEB:CLOSED SHELLS MUST BE ORBITALS 1,2,3...' GO TO 999 ENDIF C IF(MXVORB.GT.0)THEN !REDEFINE, MAYBE READ(5,*)(QN(I),QL(I),I=KS+1,MXORB) ELSE !STANDARD ORDER MXVORB=-MXVORB II=INT(SQRT(DTWO*MXORB))+1 K=0 DO I=1,II DO L=1,I K=K+1 IF(K.LE.MXORB)THEN QN(K)=I QL(K)=L-1 ENDIF ENDDO ENDDO ENDIF C IF(LCON.EQ.0)THEN DO I=KS+1,MXORB IF(QN(I).LT.80)LCON=MAX(LCON,QL(I)) ENDDO LCON=2*LCON+1 !AS QL=L HERE, NOT 2*L YET if(bdr)then lcon=min(5,lcon) if(iabs(mode).le.1.and..not.bfot)lcon=max(5,lcon) endif LCONT=LCON IF((RUN.NE.' '.OR.MXCCF.GT.0).AND.IDW.EQ.0) X WRITE(6,*)'***ATTENTION: LCON RE-SET TO',LCON ENDIF C MXORBR=MXORB IF(NXTRA.GT.0.AND.ICFG.NE.0)THEN !FILL-IN IF(LXTRA.LT.0)LXTRA=QL(MXORBR) K=MXORB IMX=MIN(LXTRA,QN(MXORBR)-1) DO I=QL(MXORBR)+1,IMX !COMPLETE SUBSHELL K=K+1 IF(K.LE.MAXGR)THEN QN(K)=QN(MXORBR) QL(K)=I ENDIF ENDDO DO N=QN(MXORBR)+1,NXTRA LMX=MIN(LXTRA,N-1) DO L=0,LMX K=K+1 IF(K.LE.MAXGR)THEN QN(K)=N QL(K)=L ENDIF ENDDO ENDDO MXORB=K IF(K.GT.MAXGR)THEN WRITE(6,1004)MXORB WRITE(0,*)'SR.ALGEB: TOO MANY ORBITALS, INCREASE MAXGR' GO TO 999 ENDIF ENDIF C ELSE WRITE(0,*) X 'INPUT MXVORB IN NAMELIST SALGEB MUST BE SET .NE. ZERO' GO TO 999 ENDIF C C READ CONFIGURATION INPUT. C IF(MXCONF.GT.0.OR.ICFG.LT.0)THEN C CALL CONFG0(ICFG,K2,MXORBR,MXORB,MXCONF,MXCCF,IFILL) C IF(NF.LT.0)GO TO 996 !RETURN C I0=IABS(K2)+1 !SO ALL CLOSED MUST BE BEFORE ALL OPEN C IF(MXCONF.GT.MAXCF)THEN WRITE(6,1006)MXCONF WRITE(0,*)'*** INCREASE MXCONF' GO TO 999 ENDIF C IF(IDW.NE.0)THEN MXCONF=MXCONF-MXCCF MXCCF=0 ENDIF C C SET-UP N+1 PROBLEM, FOR TARGET SEPCIFIED C IF(RUN.NE.' '.OR.MXCCF.GT.0)THEN IVAL=0 !ASSUME SINGLE RYD ORBITAL ISUM=0 DO I=1,MXORB IF(QN(I).GE.90)GO TO 70 !CONT ORB ALREADY SET, ASSUME N+1 IF(QN(I).GE.80)THEN !SEE IF ANY CORE RE-ARRANGEMENT IVAL=I ISUM=ISUM+1 ENDIF ENDDO C KT=MXCONF-MXCCF !NO OF TARGET CFGS JVAL=0 IF(IVAL.GT.0)THEN !SPECIFY RYD IN TARGET FOR CORE RE-ARRANGE C IF(.NOT.BDR)THEN WRITE(6,*)'***ALGEB ERROR: RUN NOT SET FOR RYD ORBS',RUN WRITE(0,*)'***ALGEB ERROR: RUN NOT SET FOR RYD ORBS' GO TO 999 ENDIF IF(ISUM.GT.1)THEN WRITE(6,*)'***ALGEB ERROR: CAN ONLY SET ONE RYDBERG ORB' WRITE(0,*)'***ALGEB ERROR: CAN ONLY SET ONE RYDBERG ORB' GO TO 999 ENDIF IF(IVAL.NE.MXORB)THEN WRITE(6,*)'***ALGEB ERROR: RYDBERG ORB MUST BE LAST SET' WRITE(0,*)'***ALGEB ERROR: RYDBERG ORB MUST BE LAST SET' GO TO 999 ENDIF C DO K=KT,1,-1 !SEE WHICH TARGET CONFIGS TO SKIP RYD IF(NEL(MXORB,K).NE.0)THEN JVAL=JVAL+1 K0=K ENDIF ENDDO C IF(JVAL.EQ.0)THEN !GET USER TO RESET INCASE IN N+1 WRITE(6,*)'***ALGEB ERROR: RYD ORB NOT USED, SO REMOVE' WRITE(0,*)'***ALGEB ERROR: RYD ORB NOT USED, SO REMOVE' GO TO 999 ENDIF IF(KT-JVAL.NE.K0-1)THEN WRITE(6,*)'***ALGEB ERROR: MUST LIST RYD TARG CFGS LAST' WRITE(0,*)'***ALGEB ERROR: MUST LIST RYD TARG CFGS LAST' GO TO 999 ENDIF C IVAL=1 ENDIF C IRYD=0 IF(BDR)IRYD=1 !FLAG SPACE FOR RYDBERG CFGS (NON-CORE) IF(LCON.LT.1)THEN LCON=3 WRITE(6,*)'***ATTENTION: LCON RE-SET TO',LCON ENDIF IF(JVAL.GT.0.AND.LCON0.EQ.0)THEN LCON0=3 WRITE(6,*)'***ATTENTION: LCON0 RE-SET TO',LCON0 ENDIF C MXCONF=(KT-JVAL)*(LCON+IRYD)+JVAL*LCON0+MXCCF IF(MXCONF.GT.MAXCF)THEN WRITE(6,1006)MXCONF WRITE(0,*)'*** INCREASE MAXCF' GO TO 999 ENDIF C I80=IRYD-IVAL M=MXORB+LCON+LCON0+I80 IF(M.GT.MAXGR)THEN WRITE(6,1004)M WRITE(0,*)'SR.ALGEB: TOO MANY ORBITALS, INCREASE MAXGR' GO TO 999 ENDIF IF(I80.GT.0)THEN MXORB=MXORB+I80 QN(MXORB)=80 QL(MXORB)=LCON/2 ENDIF C KM=MXCONF-MXCCF !NO OF CONT + RYD CFGS KK=KM LLL=LCON+LCON0 DO K=KT,1,-1 IF(IVAL.GT.0.AND.NEL(MXORB,K).NE.0)THEN KK=KK-LCON0 DO L=1,LCON0 KK=KK+1 DO I=I0,MXORB NEL(I,KK)=NEL(I,K) ENDDO DO LL=1,LLL NEL(MXORB+LL,KK)=0 ENDDO NEL(MXORB+LCON+L,KK)=1 ENDDO KK=KK-LCON0 ELSE IF(I80.GT.0)NEL(MXORB,K)=0 C KK=(K-1)*LCON+IRYD*KT KK=KK-LCON DO L=1,LCON KK=KK+1 DO I=I0,MXORB NEL(I,KK)=NEL(I,K) ENDDO DO LL=1,LLL NEL(MXORB+LL,KK)=0 ENDDO NEL(MXORB+L,KK)=1 ENDDO IF(IRYD.GT.0)THEN NEL(MXORB,K)=NEL(MXORB,K)+IRYD DO LL=1,LLL NEL(MXORB+LL,K)=0 ENDDO ENDIF KK=KK-LCON ENDIF ENDDO C C PROCESS ANY N+1 CFGS C IF((RUN.EQ.'PI'.OR.RUN.EQ.'DR'.OR.RUN.EQ.'YLD') X .AND.MXCCF.EQ.0)THEN WRITE(6,1008)RUN IF((RUN.EQ.'PI'.OR.RUN.EQ.'YLD').AND.MXCCF0.LT.0)THEN WRITE(0,*)'NO INITIAL N+1 BOUND CFGS SPECIFIED!' GO TO 999 ENDIF WRITE(0,*)'DR/PE WARNING: NO N+1 BOUND CFGS SPECIFIED!' ENDIF C IF(MXCCF.GT.0)THEN !MOVE N+1 CFGS BACK M0=MAXCF+1 I2=MXORB-I80 I1=LCON+LCON0+I80 DO K=MXCCF,1,-1 KM=KM+1 M=M0-K c write(0,*)km,m,'*',(nel(i,m),i=i0,mxorb) DO I=I0,I2 NEL(I,KM)=NEL(I,M) ENDDO DO I=1,I1 NEL(I2+I,KM)=0 ENDDO ENDDO ENDIF DO L=1,LCON QN(MXORB+L)=90 QL(MXORB+L)=L-1 ENDDO MXORB=MXORB+LCON DO L=1,LCON0 QN(MXORB+L)=99 QL(MXORB+L)=L-1 ENDDO MXORB=MXORB+LCON0 MXVORB=MXORB-I0+1 LCONT=LCON C C C NOW BUBBLE SORT TO SEPARATE SPECTROSCOPIC AND CORRELATION. C IN THIS INSTANCE USER INPUT KCUT/P REFER TO KT TARGET CFS AS C USER DOES NOT KNOW NO. OF N+1 CFS RESULTANT, SO KCUT AND C KCUTP SHOULD BE THE SAME, IF NOT TAKE KCUTP. C USE KCUTCC TO SPECIFY SUBSET OF THE MXCCF N+1 BOUND CFGS C THIS IS RELATIVE TO MXCFF ONLY AND IS INDEPENDENT OF KCUT/P. C IF(KCUT+KCUTP+KCUTCC.GT.0)THEN C IF(KCUTP.GT.0.AND.KCUTP.NE.KCUT)THEN IF(KCUT.GT.0)THEN WRITE(0,*)'***ATTENTION, USING KCUTP TO DEFINE TARGET' WRITE(6,*)'***ATTENTION, USING KCUTP TO DEFINE TARGET' ENDIF KCUT=KCUTP ENDIF C IF(KCUTCC.EQ.0)KCUTCC=MXCCF C KM=(KT-JVAL)*(LCON+IRYD) IF(KCUT+KCUTI.EQ.0)THEN !NO RE-ORDER, JUST RESET KCUT KCUTP=KM+JVAL*LCON0+KCUTCC ELSE !LABEL FOR SORTING IF(KCUTI.EQ.0)KCUTI=JVAL KCUTP=0 IF(BDR)THEN KA=1 KB=KCUT DO K=KA,KB KORDER(K)=1 !RYD SPECTROSCOPIC ENDDO KCUTP=KCUTP+KB-KA+1 KA=KB+1 KB=KT-JVAL DO K=KA,KB KORDER(K)=5 !RYD CORRELATION ENDDO ELSE KB=0 ENDIF KA=KB+1 KB=KB+KCUT*LCON DO K=KA,KB KORDER(K)=2 !CONT SPECTROSCOPIC ENDDO KCUTP=KCUTP+KB-KA+1 KA=KB+1 KB=KM DO K=KA,KB KORDER(K)=6 !CONT CORRELATION ENDDO KA=KB+1 KB=KB+KCUTI*LCON0 DO K=KA,KB KORDER(K)=3 !CORE CONT SPECTROSCOPIC ENDDO KCUTP=KCUTP+KB-KA+1 KA=KB+1 KB=KM+JVAL*LCON0 DO K=KA,KB KORDER(K)=7 !CORE CONT CORRELATION ENDDO KA=KB+1 KB=KB+KCUTCC DO K=KA,KB KORDER(K)=4 !N+1 SPECTROSCOPIC ENDDO KCUTP=KCUTP+KB-KA+1 KA=KB+1 KB=MXCONF DO K=KA,KB KORDER(K)=8 !N+1 CORRELATION ENDDO c c do i=1,mxconf c write(6,*)i,korder(i) c enddo C BEGIN SORT DO I=1,MXCONF K=I IP=KORDER(K) DO J=I+1,MXCONF IF(KORDER(J).LT.IP)THEN K=J IP=KORDER(J) ENDIF ENDDO IF(K.NE.I)THEN KORDER(K)=KORDER(I) KORDER(I)=IP DO J=I0,MXORB IP=NEL(J,I) NEL(J,I)=NEL(J,K) NEL(J,K)=IP ENDDO ENDIF ENDDO ENDIF KCUT=KCUTP ENDIF C C END ANY N+1 SET-UP C ENDIF C C WRITE CF OUTPUT IN CONFIG.DAT FORMAT C WRITE(6,*) WRITE(6,*)MXCONF,MXORB WRITE(6,*)(QN(I),QL(I),I=I0,MXORB) DO K=1,MXCONF WRITE(6,1010)K,(NEL(I,K),I=I0,MXORB) do i=i0,mxorb !check, remove evently if(nel(i,k).lt.0)then !not defined write(6,*)'*** Bug, orbital not defined, setting =0' write(0,*)'*** Bug, orbital not defined, setting =0',k,i nel(i,k)=0 endif enddo IF(KCUT.GT.0.AND.K.EQ.KCUT)WRITE(6,*) ENDDO WRITE(6,1111) C C CHECK CFS C 70 KM=MXCONF DO J=1,KM C cold READ(5,*)(NEL(I,J),I=I0,MXORB) C IF(IEQ(0).LT.0)THEN !ZEROIZE DO I=MXORB+1,MAXGR NEL(I,J)=0 ENDDO ENDIF C DO L=1,J-1 DO I=I0,MXORB IF(NEL(I,L).NE.NEL(I,J))GO TO 69 ENDDO C WRITE(6,*) WRITE(6,*)'***SR.ALGEB: CONFIGURATIONS',L,' AND',J, X ' ARE IDENTICAL!' WRITE(0,*)'SR.ALGEB: DUPLICATE CONFIGURATIONS PRESENT!' GO TO 999 69 ENDDO C ENDDO C ELSE WRITE(0,*) X 'SR.ALGEB: INPUT MXCONF IN NAMELIST SALGEB MUST BE SET GT ZERO' GO TO 999 ENDIF C ENDIF C IF(KCUTP0.LE.0)KCUTP=0 C C END READ OF A.S. CONFIG INPUT C C C*********************************************************************** C C ORBITAL INPUT DATA (IF XDR.NE.' ' OR RUN.EQ.' DR',' RR','RE','PE') C FOR RYDBERG VALENCE ELECTRON (DEFINED BY INPUT N IN RANGE 80-89) C TO BE LOOPED OVER, N INCREMENTED BY 1 AT A TIME FROM NMIN TO NMAX. C NSW=N-VALUE FOR SWITCH TO APPROXIMATING BOUND ORBITAL BY CONTINUUM, C WHERE NSW=(L*L)/4+NS0 AND L IS THE A.M. (NS0 DEFAULTS TO 15). C N.B. THIS APPROXIMATION SHOULD BE TESTED-OUT CAREFULLY. FOR HIGHER C RESIDUAL CHARGES LMAX WILL INCREASE BUT IT SHOULD PROVE POSSIBLE TO C TO REDUCE NSW TO E.G. L+NS0 WHERE NS0=20 SAY. C NRAD=N-VALUE FOR SWITCH TO NEGLECTING RADIATION BY VALENCE ELECTRON C JND ADDITIONAL N-VALUES TO BE READ-IN IN ASCENDING ORDER AND SHOULD C DIFFER BY AT LEAST 2 SINCE AN ADDITIONAL POINT IS INSERTED C BETWEEN EACH INPUT POINT SUCH THAT STEP LENGTH FOR SIMPSON RULE C SUM OVER N HAS STEP LENGTH=N1**(-2)-N2**(-2)=N2**(-2)-N3**(-2) C FOR TRANSFORMATION U=N**(-2). C LMIN .LE. LMAX LOOPS OVER L FOR A SINGLE VALENCE ELECTRON. C LCON=NO. OF CONTINUUM ORBITALS, THEIR A.M. DETERMINED BY PROGRAM. C C*********************************************************************** C IF(BDR)THEN LORIG=-1 LINC=1 NSX=35 NSW=-1 IF(BNAME)THEN NMIN=5 NMAX=5 NS0=15 NRAD=1000 JND=0 LMIN=-1 LMAX=-1 LCON=-1 C READ(5,DRR,END=998,ERR=998) ! <------------------- NAMELIST C ELSE C READ(5,101)NMIN,NMAX,NS0,NRAD,JND,LMIN,LMAX,LCON C ENDIF cparc !par cpar if(linc.ne.1)then !par cpar write(6,*) !par cpar x 'LINC must equal 1 (default) for parallel operation' !par cpar call comm_barrier() !par cpar call comm_finalize() !par cpar if(iam.eq.0)write(0,*) !par cpar x 'LINC must equal 1 (default) for parallel operation' !par cpar go to 999 !par cpar endif !par cparc !par cpar lrangp=lmax-lmin+1 !par cpar if(nproc.gt.lrangp)then !par cpar write(6,*)'Too many processors for specified l-range,'!par cpar x ,' use nproc=',lrangp !par cpar call comm_barrier() !par cpar call comm_finalize() !par cpar if(iam.eq.0)write(0,*) !par cpar x 'Too many processors for specified l-range'!par cpar go to 999 !par cpar endif !par cpar lperproc=lrangp/nproc !par cpar lxtra=lrangp-lperproc*nproc !par cparc !par cpar lmin=lmin+iam*lperproc+min(lxtra,iam) !par cpar lmax=lmin+lperproc-1 !par cpar if(iam.lt.lxtra)lmax=lmax+1 !par cparc if(iam.eq.0)write(0,*)iam,lmin,lmax !par C BLOOP=LMIN.LE.LMAX.AND.LMIN.GT.-1 IF(BLOOP)LNEW=LMIN+LSUM*LINC IF(LORIG.LT.0)LORIG=LMIN !NEEDED FOR PARALLEL C IF(LCON.LT.0.AND.LCONT.GT.0)LCON=LCONT IF(LCON.LT.1)LCON=3 IF(LCONT.GT.0.AND.LCONT.NE.LCON)THEN WRITE(6,1009)LCON,LCONT LCON=LCONT ENDIF C MXDFS0=4*(LMAX+LCON+10) !RE-CHECK FACTORIAL ARRAY IF(MXDFS0.GT.MXDFS)THEN !REAL*8 GOOD TO ABOUT MXDFS=680 WRITE(6,*)'INCREASE FACTORIAL ARRAY TO MXDFS=',MXDFS0 WRITE(0,*)'INCREASE FACTORIAL ARRAY, MXDFS' GO TO 999 ENDIF C NMIN=MAX(NMIN,LMIN+1) IF(NS0.LT.1)NS0=15 IF(NSX.LT.1)NSX=35 IF(NRAD.LT.1)NRAD=1000 IF(JND.LE.0)GO TO 106 c IF(2*JND.GT.MXD12)THEN JND=MXD12/2 WRITE(6,105)JND ENDIF C READ(5,*)(NDR(2*J-1),J=1,JND) C IF(NMAX.LT.0.OR.NMAX.LT.NMIN)GO TO 108 IF(NDR(1).EQ.NMAX+1)GO TO 108 c if(nmin.gt.0)go to 104 !debug, no extra n-values C DO J=JND,1,-1 J2=J+J NDR(J2+1)=NDR(J2-1) ENDDO C JND=JND+1 NDR(1)=NMAX+1 C 108 IF(JND.LT.2)GO TO 104 J22=JND C DO J=2,J22 J2=J+J IF(NDR(J2-1).LE.NDR(J2-3)+1)THEN JND=JND-1 IF(JND.LT.J)GO TO 104 DO I=J,JND J2=J+J NDR(J2-1)=NDR(J2+1) ENDDO ENDIF ENDDO C 104 IF(JND.GT.1)THEN DO J=2,JND J1=J+J-3 J2=J1+2 T1=NDR(J1) T2=NDR(J2) T=DONE/(SQRT(DHALF/(T1*T1)+DHALF/(T2*T2)))+DHALF NDR(J1+1)=INT(T) ENDDO JND=JND+JND-1 ENDIF cpar elseif(idw.eq.0.and.iam.eq.0)then !par cpar write(0,*)'***STRUCTURE RUN HAS *NOT* BEEN PARALLELIZED'!par cpar write(0,*)'***EACH PROCESSOR IS RUNNING A DUPLICATE JOB'!par ENDIF c C----------------------------------------------------------------------- C C ENTRY POINT FOR A NON L-LOOPING RUN C 106 IF(.NOT.BLOOP)LMAX=-1 C C C----------------------------------------------------------------------- C C READ NAST/P SELECTED (2S+1) L P C OR, NAST/P.LT.0, FLAG USE OF RANGE OF 2S+1,L GIVEN BY C MINST/P,MAXST/P,MINLT/P,MAXLT/P READ IN NAMELIST, C FOR PARENT (NASTP) OR FULL CF (NAST). C C FOR PARENTS, NASTP SPECIFIES THE NO. OF SETS OF DATA TO FOLLOW, C WHICH CONSISTS OF A CF NO. AND A LOCAL NASTP VALUE, FOLLOWED BY C THE 2S+1,L,P PARENT TERMS. C *** IF A CONFIG IS NOT LISTED THEN *ALL* OF ITS TERMS ARE INCLUDED. C C FOR FULL CF, 2S+1,L,P ARE GLOBAL I.E. THE SAME FOR ALL CFS, SO JUST C THESE ARE REQUIRED. C C (N.B. SPIN RE-LABELLED AS MINSP,MAXSP OUTSIDE OF THIS SUBROUTINE TO C AVOID CONFLICT WITH HISTORIC MAXST SLATER STATE VARIABLE.) C IN ADDITION, WHEN LOOPING OVER RYDBERG ORBITAL WITH A.M. LNEW C CAN RESTRICT ***TOTAL*** L-VALUES WITH LRANGE. C C *** ONLY NEED READ *DISTINCT* SYMMETRIES, I.E. MAXSL POSSIBLE C C CASE IDW.GT.0 (EIE,EII) THEN NASTP REFERS TO N-ELECTRON TARGET AND C NAST REFERS TO THE N+1 SYMMETRIES C NOTE: *IF* USER SPECIFIES INAST C THEN INTERNALLY RE-SET NASTP=NAST & NAST=INAST C C----------------------------------------------------------------------- C IF(IDW.NE.0)THEN IF(INAST.GT.0)THEN IF(NASTP.GT.0)THEN WRITE(6,1112)INAST,NAST,NASTP WRITE(0,*) X '***CONFUSION OVER INPUT: SET INAST/NAST .OR. NAST/NASTP' GO TO 999 ENDIF C ELSE ALIGN NASTP=NAST NAST=INAST ELSE IF(NASTP.LE.0)THEN !ASSUME NAST IS TARGET NASTP=NAST NAST=0 ENDIF ENDIF C IF(ABS(MODE).LE.1)THEN !IC IF(INASTJ.GT.0)THEN IF(NASTJP.GT.0)THEN WRITE(6,1113)INASTJ,NASTJ,NASTJP WRITE(0,*) X '***CONFUSION OVER INPUT: SET INASTJ/NASTJ .OR. NASTJ/NASTJP' GO TO 999 ENDIF C ELSE ALIGN NASTJP=NASTJ NASTJ=INASTJ ELSE IF(NASTJP.LE.0)THEN !ASSUME NAST IS TARGET NASTJP=NASTJ NASTJ=0 ENDIF ENDIF ENDIF ENDIF C ILMAX=0 C C FIRST LOOP OVER FOR PARENT TERMS (TARGET FOR IDW.NE.0) C IF(NASTP.GT.0)THEN IF(IDW.EQ.0)THEN !"STRUCTURE" DO I=1,MAXCF !INITIALIZE NLSPIP(I)=0 ENDDO DO I=1,NASTP READ(5,*)IPCF,NPCF !CF SPECIFIC IF(IPCF.LE.0.OR.IPCF.GT.MAXCF)THEN WRITE(6,*)' *** ILLEGAL CONFIGURATION NO.:',IPCF WRITE(0,*)' *** ILLEGAL CONFIGURATION NO.' GO TO 999 ENDIF DO N=1,NPCF READ(5,*)IS,IL,IP IF(N.LE.MAXSL)LSPIP(N,IPCF)=10000*IS+10*IL+IP ILMAX=MAX(ILMAX,IL) ENDDO IF(NPCF.GT.MAXSL)THEN WRITE(6,747)NPCF NPCF=MAXSL ENDIF NLSPIP(IPCF)=NPCF ENDDO ELSE DO I=1,NASTP READ(5,*)IS,IL,IP IF(I.LE.MAXSL)LSPIP(I,1)=10000*IS+10*IL+IP !GLOBAL HERE ILMAX=MAX(ILMAX,IL) ENDDO IF(NASTP.GT.MAXSL)THEN WRITE(6,747)NASTP NASTP=MAXSL ENDIF ENDIF ENDIF C C NOW FOR FULL CF (TERMS/SYMMETRIES) C IF(NAST.GT.0)THEN DO I=1,NAST READ(5,*)IS,IL,IP IF(I.LE.MAXSL)LSPI(I)=10000*IS+10*IL+IP ILMAX=MAX(ILMAX,IL) ENDDO IF(NAST.GT.MAXSL)THEN WRITE(6,747)NAST NAST=MAXSL ENDIF ELSEIF(NAST.LT.0)THEN IF(BLOOP.AND.LRANGE.GE.0)THEN MINLT=LNEW-LRANGE MAXLT=LNEW+LRANGE ENDIF ENDIF C IF(IDW.NE.0)THEN !BACK-UP THEN COPY-IN FOR TARGET MX=MAX(NAST,NASTP) DO I=1,MX II=LSPI(I) LSPI(I)=LSPIP(I,1) LSPIP(I,1)=II ENDDO IF(NAST.LE.0)THEN IF(MINLT.LT.0)MINLT=0 IF(MAXLT.LT.0)THEN IF(NASTJ.GT.0)THEN WRITE(6,*)'*** HINT: CASE INASTJ.GT.0 MAYBE FASTER IF YOU' X ,' SET MAXLT EXPLICITLY' WRITE(0,*)'*** HINT: CASE INASTJ.GT.0 MAYBE FASTER IF YOU' X ,' SET MAXLT EXPLICITLY' ENDIF MAXLT=30 ENDIF IF(MAXLT.LT.250)ILMAX=MAX(ILMAX,MAXLT) ENDIF MINLTB=MINLT MAXLTB=MAXLT MINSTB=MINST MAXSTB=MAXST MINLT=MINLTP MAXLT=MAXLTP MINST=MINSTP MAXST=MAXSTP NASTB=NAST NAST=NASTP NASTP=0 !I.E. NO TARGET PARENTS NOW MINSTP=0 MAXSTP=2000 MINLTP=0 MAXLTP=2000 ENDIF C C DITTO BUT EXTEND TO LEVELS JP (2*J, P=0,1) C IF(ABS(MODE).LE.1)THEN !IC IJMAX=0 C IF(NASTJP.GT.0)THEN IF(IDW.EQ.0)THEN !AS THERE ARE NO STRUCTURE PARENTS WRITE(6,*)'*** ATTENTION: NASTJP IS IGNORED FOR IDW=',IDW WRITE(0,*)'*** ATTENTION: NASTJP IS IGNORED FOR IDW=',IDW ENDIF DO I=1,NASTJP READ(5,*)IL,IP IF(I.LE.MAXJG)JPIP(I)=10*IL+IP IJMAX=MAX(IJMAX,IL) ENDDO IF(NASTJP.GT.MAXJG)THEN WRITE(6,748)NASTJ NASTJP=MAXJG ENDIF ENDIF C IF(NASTJ.GT.0)THEN DO I=1,NASTJ READ(5,*)IL,IP IF(I.LE.MAXJG)JPI(I)=10*IL+IP IJMAX=MAX(IJMAX,IL) ENDDO IF(NASTJ.GT.MAXJG)THEN WRITE(6,748)NASTJ NASTJ=MAXJG ENDIF ENDIF C IF(IDW.NE.0)THEN !BACK-UP THEN COPY-IN FOR TARGET MX=MAX(NASTJ,NASTJP) DO I=1,MX II=JPI(I) JPI(I)=JPIP(I) JPIP(I)=II ENDDO IF(NASTJ.LE.0)THEN IF(NASTB.GT.0)THEN WRITE(6,*)'***ERROR: YOU MUST SPECIFY INASTJ JP ', X 'IF YOU SPECIFY INAST LSP SYMMETRIES ELSE MADNESS ENSUES!' WRITE(0,*)'***ERROR: MUST SPECIFY INASTJ IF YOU ', X 'SPECIFY INAST' GO TO 999 ENDIF IF(MINJT.LT.0)THEN MINJT=2*MINLT IF(MAXSTB.LT.100)THEN MINJT=MINJT+MIN(MINJT,MAXSTB-1) ELSE MINJT=MINJT+MIN(MINJT,12) !SO BEST SPECIFY ENDIF ENDIF IF(MAXJT.LT.0)THEN MAXJT=2*MAXLT IF(MAXSTB.LT.100)THEN MAXJT=MAXJT-MAXSTB+1 ELSE MAXJT=MAXJT-12 !SO BEST SPECIFY ENDIF ENDIF IF(MAXJT.LT.500)IJMAX=MAX(IJMAX,MAXJT) ENDIF MINJTB=MINJT MAXJTB=MAXJT MINJT=MINJTP MAXJT=MAXJTP NASTJB=NASTJ NASTJ=NASTJP NASTJP=0 !FOR FUTURE SAFETY MINJTP=0 MAXJTP=2000 ENDIF C IJMAX=IJMAX/2 ILMAX=MAX(ILMAX,IJMAX) ENDIF C MXDFS0=4*(ILMAX+10) !RE-CHECK FACTORIAL ARRAY IF(MXDFS0.GT.MXDFS)THEN !REAL*8 GOOD TO ABOUT MXDFS=680 WRITE(6,*)'INCREASE FACTORIAL ARRAY TO MXDFS=',MXDFS0 WRITE(0,*)'INCREASE FACTORIAL ARRAY, MXDFS' GO TO 999 ENDIF C C----------------------------------------------------------------------- C C DECODE NUMBER OF VALENCE ELECTRONS FROM FIRST CONFIGURATION. C IF(CODE.EQ.'S.S.')THEN MAXEL=IWRK2(1) DO I=2,KG IF(IWRK2(I).LE.50)GO TO 95 MAXEL=IWRK2(I)-50+MAXEL ENDDO ELSE MAXEL=0 DO I=1,MXVORB MAXEL=MAXEL+NEL(IABS(K2)+I,1) ENDDO ENDIF C 95 IF(IDW.NE.0)MAXEL=MAXEL+1 !NEED SPACE FOR CONT C IF(MAXEL.GT.MXEL0)THEN WRITE(6,199)MXEL0 NF=-1 ENDIF C C FLAG IF THERE WAS NOT ENOUGH BUFFER SPACE TO READ-IN CONFIGS. C 97 IF(CODE.EQ.'S.S.')THEN IF(TITLE.NE.' ')WRITE(6,100)MLIT0 IF(KGG.GT.MXD08)THEN WRITE(6,195)MXD08,KGG NF=-1 ENDIF ENDIF C KUTXX=KUTSS !AS IN /NRBAL3/ AND /OUTP1/ C C 996 RETURN C 997 WRITE(6,1997) WRITE(0,*)'*** SR.ALGEB0: ERROR READING NAMELIST SALGEB!' !FATAL GO TO 999 C 998 WRITE(6,1998) WRITE(0,*)'*** SR.ALGEB0: ERROR READING NAMELIST DRR!' !FATAL C 999 NF=-1 GO TO 996 C C 50 FORMAT(4I2, A1, 21(I2,A1), 2A4) 51 FORMAT(9X,21(I2,A1)) 100 FORMAT(///' ',2A4) 101 FORMAT(8I5) 105 FORMAT(//' SR.ALGEB: NUMBER OF N VALUES FOR DR HAS BEEN REDUCED TO X',I3/) 145 FORMAT(//' ***** FANO PHASE CONVENTION IN USE *****'/) 195 FORMAT(///' SR.ALGEB: YOU ARE TRYING TO READ MORE CONFIGURATION IN XPUT THAN THE BUFFER CAN HOLD-'/11X, 'AS BUFFER THE PROGRAM USES T XHE ARRAYS OF SIZE *MXD08=',I6,'.'/11X, 'EACH C CARD,AND THE TERM XINATOR, REQUIRE 21 LOCATIONS.'/11X ,'CASE SKIPPED. PUNCH MORE CONF XIGURATIONS ON A CARD, OR AUGMENT MXD08 TO',I6/11X,'***LIKELY MAXCF XTOO SMALL***') 199 FORMAT(' SR.ALGEB: STORAGE FOR ONLY',I3, ' ELECTRONS PROVIDED -- X AUGMENT *MXEL0.') 747 FORMAT(//' INCREASE MAXSL IN PARAMETER STATEMENTS TO',I4) 748 FORMAT(//' INCREASE MAXJG IN PARAMETER STATEMENTS TO',I4) 1000 FORMAT(20A4) 1001 FORMAT(////1X,105('-')//1X,20A4//1X,105('-')//) 1002 FORMAT(' ****INPUT CODE ERROR: CURRENTLY ONLY S.S. AND A.S. ARE' X,' ALLOWED WHILE YOUR INPUT IS "',A4,'"') 1004 FORMAT(' TOO MANY ORBITALS, INCREASE DIMENSION OF MAXGR TO:',I4) 1005 FORMAT(' A.S. CODE REQUIRES KCOR1=1 (OR 0), REDEFINE ORBITALS SO' X,' THAT CLOSED SHELLS ARE 1,2,3 ETC. CURRENTLY KCOR1=',I2) 1006 FORMAT(' TOO MANY CONFIGURATIONS, INCREASE DIMENSION OF MAXCF TO:' X,I4) 1008 FORMAT('*** ATTENTION: RUN=',A4,' BUT NO N+1 BOUND CFGS SPECIFIED' X/' SET MXCCF.GT.0 TO SPECIFY AS FOR N CFGS, OR .LT.0 FOR INTERNAL' X,' GENERATION'/) 1009 FORMAT('***NOTE: LCON HAS BEEN OVERWRITTEN BY EARLIER DEFINITION:' X,2I3) 1010 FORMAT(I3,':',(60I2)) 1111 FORMAT(//1X,136('-')//) 1112 FORMAT(/'***CONFUSION OVER INPUT: SET INAST/NAST .OR. NAST/NASTP'/ X 'YOU HAVE SET INAST,NAST,NASTP=',3I5) 1113 FORMAT( X /'***CONFUSION OVER INPUT: SET INASTJ/NASTJ .OR. NASTJ/NASTPJ'/ X 'YOU HAVE SET INASTJ,NASTJ,NASTJP=',3I5) 1120 FORMAT(/'*** COMMENT: HISTORIC DIMENSION CHECK MODE IS OBSOLETE -' X,' ONLY 10% FASTER, AND IT SIGNIFICANTLY OVERESTIMATED'/13X,'SOME' X,' DIMENSIONS. A FAST, ACCURATE, BUT *PARTIAL* DIMENSION' X,' TEST HAS BEEN IMPLEMENTED INSTEAD.'/7X,'NOTE: NZION=0 EXITS' X,' AT THE END OF A FULL ALGEBRA RUN.'//) 1121 FORMAT(/"*** THERE IS, CURRENTLY, NO DIMENSION CHECK FOR RUN='DE'" X,' - SWITCHING-OFF!'/3X,' REMOVE THE "SRADCON" NAMELIST TO EXIT' X,' AT THE END OF THE COLLISION ALGEBRA.'//) 1200 FORMAT(//1X,'THANK-YOU FOR CHOOSING AUTOSTRUCTURE (AS) AS YOUR ', X'ATOMIC CODE!'//5X,'AS IS A GENERAL DISTORTED-WAVE (DW) CODE'// X5X,'PLEASE SET THE DESIRED RUN OPTION FROM THE LIST BELOW:'// X5X,'RUN=" " FOR ATOMIC STRUCTURE (DEFAULT)'/ X5X,'RUN="DR" FOR DIELECTRONIC RECOMBINATION'/ X5X,'RUN="RR" FOR RADIATIVE RECOMBINATION'/ X5X,'RUN="PI" FOR PHOTOIONIZATION'/ X5X,'RUN="PE" FOR PHOTOEXCITATION-AUTOIONIZATION'/ X5X,'RUN="DE" FOR DIRECT EXCITATION'/ X5X,'RUN="RE" FOR RESONANT EXCITATION'/ X5X,'RUN="DI" FOR DIRECT IONIZATION (NOT YET AVAILABLE)'// X' HAVE A GREAT DAY!'/) 1997 FORMAT('*** SR.ALGEB0: ERROR READING NAMELIST SALGEB!'/4X, X'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES') 1998 FORMAT('*** SR.ALGEB0: ERROR READING NAMELIST DRR!'/4X, X'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES') C END C C ******************* C SUBROUTINE ALGEB1(DC,IDC,QLML,QLMS,QBML,QBMS,JYI,JYF,MAXST,MAXEL) C C----------------------------------------------------------------------- C C SR.ALGEB1 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.1 OF E+N C IT CALCULATES SLATER-STATES AND VECTOR COUPLING COEFFICIENTS (VCC) C FOR THE KM INPUT CONFIGURATIONS (FROM THE CODED INPUT IN QBML+QBMS C WHICH IS DECODED IN CONFG1). C C OUTPUT: FOR ANY OF THE KM CONFIGURATIONS KF: 1-QCP(KF)=PARITY, C SLST'S NL'S AS QCG(I,KF),I=1,NF=GROUP NUMBER K OF I'TH ELECTRON C THE OTHER QUANTUM NUMBERS ARE IN SECTIONS J=JYI(KF)...JYF(KF) OF C QLMS,QLML(I,J)=2* LITTLE MS,ML OF I'TH ELECTRON IN SLST J; C QBMS,QBML(J)=2* TOTAL MS,ML OF SLST J (=SUM OVER LITTLE M'S). C TERMS QTGS,QTGL(I),I=NTG(KF-1)+1,NTG(KF)=2*S,2*L C (QMCS,QMCL=2*SMAX,2*LMAX OF ALL THE NTG(KM) TERMS); C DC(JTGD(KF)+J)=VCC OF J'TH SLST TO TERM I, WITH I,J LIMITS ABOVE C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) C PARAMETER (DZERO=0.0D0) C LOGICAL BPRINT,BLP1,BLP2,BLF,BLT,BNGE80,BPARNT,BFAST,BANAL,BDISK C X ,LP0 C CHARACTER(LEN=4) CODE CHARACTER(LEN=7) LABT C INTEGER*8 MDCF8,MDCFT8,M8 C REAL*8 DC DIMENSION DC(0:*),IDC(*) DIMENSION QLMS(MAXEL,*),QBMS(*),QLML(MAXEL,*),QBML(*) X ,JYI(*),JYF(*) X ,QLP(MAXGR),LL(MXEL0),KSUB(0:MAXGR) X ,NDI(MAXDF),DS(MAXDF),DE(MAXDF) !VCU X ,DFS(MXDFS) C COMMON /BASIC/NF,KY,KG,JA,JB,JSP1,MGAP(6) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODD,KCUT,QCLX,QCSX,NEL(MAXGR,MAXCF) COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,ND,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF), X QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBJ/JPI(MAXJG),NASTJ,MINJT,MAXJT COMMON /NRBKUT/KCUTDM,LSKUT(MAXSL),NASTK !KCUT IN /MQVC/ COMMON /NRBKUTP/KCUTP,LSKUTP(MAXSL),NASTKP COMMON /NRBLIM/ECNTRB,ITANAL,BANAL(MAXCF) !ALGEBRAIC COMMON /NRBLS/LSPI(MAXSL),NAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP COMMON /NRBNV/MAXNV COMMON /NRBPNT/NTGP(MAXCT),NTGS(MAXCT),NTP1,NTP2 COMMON /NRBVCX/NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB,QCGS(MXEL0) C EQUIVALENCE (LL(1),NDI(1)),(BLP2,BDSKLP) C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C MAXNV=0 C C DECODE CONFIGS AND (OPTIONALLY) SET-UP FOR RELAXED ORBITALS C NF=MAXEL !INITIALIZE TO CHECK CF INPUT IF(IDW.NE.0)NF=NF-1 C CALL CONFG1(QLP) C IF(NF.LE.0)GO TO 109 !PROBLEM WITH CONFIG INPUT (BLF=.TRUE.) C C C NOW COMPUTE IN SR.VCU/VCG SLATERSTATES (SLST) OF CONFIGURATIONS C KF=1..KM, RESULTING TERMS SL AND VECTOR COUPLING COEFFICIENTS (VCC) C WHICH MAY ALSO BE STORED ON DISKDC; C INPUT NEL(K,KF) C KDM=KM !NO. OF CONFIGS. FOR /TERMS/ C IF(KCUT*KCUT.LT.KCUT*KM)THEN IF(MODD.EQ.0)THEN MODD=-1 WRITE(6,130) ENDIF ENDIF C IF(KUTDSK.LT.1000)THEN !MAY SWITCH, THEN CHECK PRELOAD TEST KFBUFF=KUTDSK !BUFFER BY CF, SMALL MEM BUT SLOWER ELSE KFBUFF=KM !BUFFER ALL CF'S IN GROUP(S), IF MEM ALLOWS KUTDSK=KUTDSK-1000 ENDIF C DFS(1)=1 DFS(2)=1 DO I=3,MXDFS,2 DFS(I)=-DFS(I-2) DFS(I+1)=(I-1)*DFS(I-1)/32 ENDDO C MTGD=0 JB=1 NTG(0)=0 JTGD(0)=0 KGCF(0)=0 C BPRINT=(MPRINT.GE.0.OR.MPRINT.EQ.-1).AND. X IDW.EQ.0.and.qn(mxorb).lt.80 BLP2=MPRINT.GE.2 BLP1=MPRINT.GE.1 c LP0=MPRINT.EQ.0 BLF=.FALSE. C NASTKP=0 !INIT. PARENT SYMMETRY SELECTION NASTK=0 !INIT. SYMMETRY SELECTION QCS0=0 !INITIALIZE GLOBAL MAX S QCL0=0 !INITIALIZE GLOBAL MAX L C MOD0=MODD !HOLD ORIGINAL INFO KCUT0=KCUT KCUTP00=KCUTP NAST0=NAST NASTP0=NASTP NASTJ0=NASTJ ITANL0=ITANAL idw0=idw c c ttvcu=0. c ttvcg=0. C C LOOP OVER CFS C DO KF=1,KM C IF(KF.EQ.KCUT+1.AND.KCUT.NE.0)WRITE(6,120) IF(ITANL0.NE.0)REWIND(31) ITANAL=-IABS(ITANL0) BANAL(KF)=.FALSE. BDISK=KF.GT.KUTDSK !USE DISKDC KGCF(KF)=0 C BNGE80=.FALSE. KSUB0=MXORB DO K=MXORB,1,-1 !NL-SUBSHELL RESOLUTION N=NEL(K,KF) IF(N.GT.0)THEN IF(.NOT.BNGE80)BNGE80=QN(K).GE.80 !RYD OR CONT CF KSUB(KSUB0)=K KSUB0=KSUB0-1 IF(MXORB-KSUB0.EQ.KSUBCF+1)GO TO 5 !NO MORE RESOLUTION ENDIF ENDDO C 5 CONTINUE IF(BNGE80)THEN !APPLY KCUT TO PARENT TERMS BPARNT=.TRUE. KCUTP0=KCUT0 ELSE !SEE WHETHER TO APPLY KCUTP TO REMAINING PARENT TERMS BPARNT=.true. !.FALSE. APPLIES TO RYD/CONT CF ONLY, USES KCUT KCUTP0=KCUTP00 !.TRUE. APPLIES TO BOUND AS WELL, IF KCUTP SET ENDIF C KSUB(KSUB0)=0 K0=-1 DO K=KSUB0,MXORB K0=K0+1 KSUB(K0)=KSUB(K) C write(0,*)kf,k0,ksub(k0) ENDDO KSUB0=K0 C IF(IDW.NE.0)MODD=0 IF(KSUB0.GT.1)THEN !NEED ALL M_X AND MUST NOT SELECT YET MODD=0 KCUT=0 NAST=0 NASTJ=0 idw=0 ENDIF C IF(BPARNT.AND.KSUB0.EQ.2)THEN KCUTP=KCUTP0 !MUST SELECT PARENT IN VCU, VCG TOO LATE NASTP=NASTP0 IF(BNGE80)ITANAL=IABS(ITANAL) !VCU NOT YET CODED ELSE KCUTP=0 !MAYBE SELECT PARENT IN VCG NASTP=0 ENDIF C NF=0 QCP(KF)=0 !INITIALIZE FOR PARITY NTGA=NTG(KF-1) QBMS(1)=2 !INIT. NO. OF SS USED BY VCU FOR KF ONLY LABT='PARENTS' C C LOOP OVER SUBCONFIGURATIONS C c tvcg=0. c tvcu=0. c DO KS=1,KSUB0 C KSI=KSUB(KS-1)+1 !KSI,KSF DEFINES SUBSHELL RANGE FOR VCU KSF=KSUB(KS) JBS=JB C c call cpu_time(timei) c C CALL VCU(DC,IDC,QLML,QLMS,QBML,QBMS,DE,DS,NDI,MAXST,MAXEL) C IF(NFS.LE.0)GO TO 109 IF(NB.LT.0)GO TO 6 !DIMENSION FAILURE, BAIL OUT c c call cpu_time(timef) c tvcu=tvcu+timef-timei c write(71,*)'vcu',timef-timei c call flush(71) C C IF(KS.EQ.KSUB0)THEN !NOW RESTRICT M_X AND SELECT idw=idw0 JSP1=0 IF(IDW.EQ.0)THEN MODD=MOD0 ELSE IF(IABS(MOD0).LE.1)JSP1=1 ENDIF KCUT=KCUT0 NAST=NAST0 NASTJ=NASTJ0 MAXST=-MAXST !FLAG BFINAL IF(.NOT.BNGE80)ITANAL=IABS(ITANAL) ENDIF IF(BPARNT.AND.KS.EQ.KSUB0-1)THEN KCUTP=KCUTP0 NASTP=NASTP0 IF(BNGE80)ITANAL=IABS(ITANAL) ENDIF c c call cpu_time(timei) c C CALL VCG(DC,IDC,QLML,QLMS,QBML,QBMS,DFS,MAXST,MAXEL) C IF(NF.LE.0)GO TO 109 C c c call cpu_time(timef) c tvcg=tvcg+timef-timei c write(71,*)'vcg',timef-timei c call flush(71) c KCUTP=0 NASTP=0 C IF(BLP2.AND.NB.EQ.0)THEN !WRITE PARENTS NF0=NF-NFS WRITE(6,30)KF,NB,(QN(QCG(I,KF)),QLP(QCG(I,KF)),I=1,NF0) WRITE(6,21)NTP1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=1,NTP1) WRITE(6,29)KS,NB,(QN(QCGS(I)),QLP(QCGS(I)),I=1,NFS) I1=NTP2-NTP1 I2=NTP1+1 WRITE(6,21)I1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=I2,NTP2) IF(KS.GT.1)THEN NT=NTG(KF-1) M=NTG(KF) NK=M-NT !NO. OF TERMS SELECTED I=NT DO N=1,NK I=I+1 J=NTGP(I)-NT L=NTGS(I)-NT WRITE(6,82)I,N,QTGS(I)+1,QTGL(I)/2,QTGD(I), X J,NFI(J)+1,NFK(J)/2,NFQ(J), X L-NTP1,NFI(L)+1,NFK(L)/2,NFQ(L) ENDDO ENDIF ENDIF C BLT=NB.GT.0 !ACCURACY FAILURE (DIMENSION IF NB.LT.0) IF(NB.NE.0)GO TO 6 !BAIL OUT OF SUBCONFIGURATION LOOP C ENDDO !END LOOP OVER SUBCONFIGURATIONS C -------------------------------- KGCF(KF)=KGCF(KF)+KGCF(KF-1) c c write(71,*)'cf=',kf,' vcu time=',tvcu c write(71,*)'cf=',kf,' vcg time=',tvcg c ttvcu=ttvcu+tvcu c ttvcg=ttvcg+tvcg c call flush(71) c C C UPDATE GLOBAL MAX S,L (MAY HAVE BEEN INPUT VIA QCSX,QCLX IN /MQVC/) C QCS0=MAX(QCSX,QCS0) QCL0=MAX(QCLX,QCL0) C C WRITE-OUT DETAILS, TERM INFO ETC C 6 MODD=MOD0 !CASE IDW.GT.0 NASTP=NASTP0 ITANAL=ITANL0 C DO I=1,NF K=QCG(I,KF) IF(QN(K).LT.80.AND.QN(K).GT.MAXNV.AND.KCUT*KCUT.GE.KCUT*KF) X MAXNV=MOD(QN(K),70) QLMS(I,1)=QN(K) LL(I)=QLP(K) QLML(I,1)=QL(K) ENDDO C C NB.LT.0: STORAGE EXCEEDED; NB.GT.0: ACCURACY OR PHASE FAILURE C NB=0: SLATER STATES AND VCC PROPERLY COMPUTED BY VCU/VCE C CC WRITE(6,30)KF,NB,(QN(QCG(I,KF)),QLP(QCG(I,KF)),I=1,NF) C M8=INT(NB) IF(BDISK.AND.M8.EQ.0)M8=MDCF8 WRITE(6,30)KF,M8,(QLMS(I,1),LL(I),I=1,NF) C IF(ND.EQ.0)GO TO 99 !NO. OF TERMS IN CF C MSTAT(KF)=QBMS(1)-1 !FOR CONFIG KF HERE c write(0,*)qbms(1)-1 QBMS(1)=JA-1+QBMS(1)-1 !NOW GLOBAL C NT=NTG(KF-1) M=NTG(KF) NK=M-NT !NO. OF TERMS SELECTED IF(NK.EQ.0)GO TO 11 !.AND.NB.EQ.0 ND=NK !COMMENT-OUT TO SEE NO. TERMS IN CF K=NT+1 C WRITE(6,20)JA,JB,QBMS(1),MAXST,MTGD,MAXDC,MAXDF,MODD C IF(BLP1.AND.KSUB0.GT.1)THEN !WRITE FINAL PARENTS LABT='FINAL ' WRITE(6,21)NTP1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=1,NTP1) LABT='PARENTS' I1=NTP2-NTP1 I2=NTP1+1 WRITE(6,21)I1,LABT,(NFI(I)+1,NFK(I)/2,NFQ(I),I=I2,NTP2) I=NT DO N=1,NK I=I+1 J=NTGP(I)-NT L=NTGS(I)-NT WRITE(6,82)I,N,QTGS(I)+1,QTGL(I)/2,QTGD(I), X J,NFI(J)+1,NFK(J)/2,NFQ(J), X L-NTP1,NFI(L)+1,NFK(L)/2,NFQ(L) ENDDO ENDIF C LABT='TERMS ' IF(BPRINT)THEN WRITE(6,21)ND,LABT,(QTGS(I)+1,QTGL(I)/2,QTGD(I),I=K,M) ELSE WRITE(6,21)ND,LABT ENDIF C IF(NB.LT.0)GO TO 99 IF(.NOT.BLP2)GO TO 11 C WRITE(6,70)KF,(QLMS(I,1),QLML(I,1),I=1,NF) WRITE(6,81)JB,NB,MAXST C DO J=JA,JB L=QBMS(J)+QBML(J) WRITE(6,80)J,QBML(J),QBMS(J),L,(QLML(I,J),QLMS(I,J),I=1,NF) ENDDO C WRITE(6,110)ND,(QTGS(I),QTGL(I),QTGD(I),I=K,M) C IF(.NOT.BLT.AND..NOT.BDISK)THEN N=NTG(KF) DO J=JA,JB L1=1+(NK-1)/MAXDF I1=0 DO L=1,L1 I0=I1+1 I1=MIN(NK,L*MAXDF) N=0 DO I=I0,I1 N=N+1 IF(BFAST)THEN K=J+JTGD(I+NT) !relative start flagged DS(N)=DC(K) ELSE K1=JTGD(I-1+NT)+1 !absolute end flagged K2=JTGD(I+NT) DO K=K1,K2 !FOR SMALL CASES IF(IDC(K).EQ.J)THEN DS(N)=DC(K) GO TO 10 ENDIF ENDDO DS(N)=DZERO 10 CONTINUE ENDIF ENDDO WRITE(6,59)J,(DS(I),I=1,N) ENDDO ENDDO WRITE(6,110) ENDIF C 11 JYI(KF)=JA IF(BLT)THEN BLF=.TRUE. IF(NB.LE.MAXDF)THEN WRITE(6,96) ELSE WRITE(6,98) ENDIF ENDIF JYF(KF)=JB C ENDDO !END LOOP OVER CONFIGURATIONS C ----------------------------- C N=NTG(KM) C C REPLACE GLOBAL MAX S,L C QCSX=QCS0 QCLX=QCL0 C C IF(BDISK)THEN MDCFT8=MDCFT8+MDCF8 !pick-up final config IF(KUTDSK.LT.KFBUFF)THEN MDCBUF=MAXDC !SINCE UNKNOWN AHEAD OF TIME IF(MDCFT8.LE.MAXDC)THEN M=INT(MDCFT8) MDCBUF=MIN(MDCBUF,MTGD+M) !FOR ANY SUBSEQUENT ALLOCATE ENDIF ELSE MDCBUF=MDCBUF+MDCBUF+MTGD !SINCE NEED TO HOLD TWO SLICES IF(MDCBUF.GT.MAXDC)THEN WRITE(6,140)MDCBUF NF=-1 ENDIF ENDIF ENDIF C MTGDMX=0 CALL DIMUSE('MAXDC',MTGDMX) JBMX=0 CALL DIMUSE('MXST0',JBMX) MXCTM=0 CALL DIMUSE('MAXCT',MXCTM) WRITE(6,19)MXCTM,MAXCT,JBMX,MXST0,MTGDMX,MAXDC IF(BDISK)WRITE(6,22)MDCFT8 c c write(71,*)'total vcu time=',ttvcu c write(71,*)'total vcg time=',ttvcg c call flush(71) C if(tvcg.gt.0)stop'test algeb1' C IF(NTG(KM).EQ.0)GO TO 9 IF(BLF)GO TO 9 C COLD ND=KM !NO OF CONFIGS PASSED TO ALGEB2 IN /QTG/, SIGH GO TO 109 C 99 WRITE(6,90) 9 NF=0 109 CONTINUE C RETURN C 19 FORMAT(//I6,'=TERMS',5X,'MAXCT=',I6,5X,I7,9X,'=JB, MXST0=',I7,19X X ,I9,'=MTGD, MAXDC=',I9,' BUFFER STORAGE USED') 20 FORMAT(' SLATER-STATES STORED IN' ,I7,'=JA',I7,'(',I7, ')=JB, MAX XST=', I7, ', VCC STORED UP TO ',I9,'=MTGD, MAXDC=',I9, '; MAXDF X=',I4,'; MOD=',I2) 21 FORMAT(I5, ' SPECTROSCOPIC ',A7,' (2S+1 L DP):', X 1X, 9(2X,I3,I2,I3)/(41X,9(2X,I3,I2,I3)) ) 22 FORMAT(/47X,"TOTAL NUMBER OF VCC'S STORED ON DISK:",I12/) 29 FORMAT(//' SUBCONFIGURATION=', I4,',',I4, ' ON DISK, (N-L)-COMBIN XATIONS ', 12(I4,I2) ) 30 FORMAT(//' CONFIGURATION CF=', I4,',',I11,' ON DISK, (N-L)-COMBIN XATIONS ', 12(I4,I2)/64X, 12(I4,I2) ) 59 FORMAT(I4,16F8.4/(4X,16F8.4)) 70 FORMAT( /I4, '=CF 2ML 2MS 2MJ', 1X, (14(I5,I3)) ) 80 FORMAT( I6, I5,I4,I4, 1X, (14(I5,I3)) ) 81 FORMAT(I6,I6,I8) 82 FORMAT(I5,I5,I4,I2,I3,2X,':',1X,I4,I4,I2,I3,2X,I4,I4,I2,I3) 90 FORMAT(//"SR.ALGEB1: STORAGE EXCEEDED IN VCU - OR VCG - CALL" //" X'DISK'=-3 IF TOO MANY SLATER STATES ((JB').GT.MAXST), -2 IF TOO ", X"MANY TERMS (SUM(ND).GT.MAXCT), -1 IF TOO MANY VCC (MTGD.GT.MAXDC) X"// " AUGMENT MXEST OR MXST0 (IN CASE -3), AUGMENT ", X"MAXTM (-2), AUGMENT MAXDC (-1)") 96 FORMAT(//' SR.ALGEB1: SR VCU HAS FAILED -IN PHASES OR ACCURACY'//) 98 FORMAT( " SR.ALGEB1: WORKING ARRAYS D2,DU,DV,DS,DE,NDI TOO SMALL X ('DISK'.GT. MAXDF)") 110 FORMAT(/I4,16(I3,I2,I3)/(4X,16(I3,I2,I3))) 120 FORMAT(/ / "ATTENTION: THE FOLLOWING CF'S ARE MERE CORRELATION CON XFIGURATIONS") 130 FORMAT(// ' MOD=0 RESET TO -1, BECAUSE SR.VCU DOES NOT LIKE CORREL XATION CONFIGURATIONS IN THAT MODE.') 140 FORMAT(/'*** SR.ALGEB1: INCREASE MAXDC TO AT LEAST: ',I9,' FOR', X' SUBSEQUENT USE BY ALGEB2,3,4') C END C C ******************* C SUBROUTINE ALGEB2(DC,IDC,MAM,NAM,QLML,QLMS,QBML,QBMS,JYI,JYF,MAXEL X) C C----------------------------------------------------------------------- C C SR.ALGEB2 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N: C IT CALCULATES THE PURELY ALGEBRAIC COEFFICIENTS FOR EACH NONVAN- C ISHING ENERGY MATRIX ELEMENT, ASSUMING ELECTROSTATIC INTERACTION; C ALSO, REDUCED ELECTRIC MULTIPOLE MATRIX ELEMENTS ARE COMPUTED. C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_DXRL, ONLY: BDXRL,DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_DXRLS, ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 USE COMMON_NRBEKP, ONLY: BNRBEKP,NED !F95 USE COMMON_NRBNF1, ONLY: BNRBNF1,DEK,BFALL !F95 USE COMMON_NRBRN2, ONLY: BNRBRN2,BINDB !F95 CB X,MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) PARAMETER (MXD14=100) PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) PARAMETER (MXD20=20) PARAMETER (MXD27=MAXCF*MAXCF) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (MG=-2) C INTEGER*8 MDCF8,MDCFT8 CF77 INTEGER*8 NRK !F77 C LOGICAL BVC,LP,SKP,AM,BM,BKUTOO,BDLBD,LX,BFAST,BPRINT !,BBORN X ,BREL,BJUMPR,BMVD,BMOD2,EQGRP,EQCFS,EX,EXJ,BFOT X ,BXIST,btime,btimex X ,BAMBM !F95 CF77 X ,BFALL,BFALLS,BINDB !F77 C CHARACTER(LEN=4) CODE,MBLANK,MYRGE C REAL*8 DC C DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*),JYI(*),JYF(*) X ,QLML(MAXEL,*),QBML(*),QLMS(MAXEL,*),QBMS(*) C DIMENSION DFS(MXDFS),DVC(MXD20),JMG(MAXJG),kstart(maxcf,2) CF77 X ,AM(MXST0),BM(MXST0) !F77 C ALLOCATABLE :: AM(:),BM(:) !F95 C COMMON /BASIC/NF,KF,KG,NC,ND,mb1,mb2,ND1,NDP1,ND2,NDP2,NGAP COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRL/IRK,IRK0,IOS,IOS0 CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBBBB/BXIST(2*MXD19) COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBIAD/IADD,IADJ,IADJT CF77 COMMON /NRBEKP/NED(2,MAXSL,MAXTM) !F77 COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLS/LSPI(MAXSL),NAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBUNI/IUNIT(MXD14),NUNIT common /nrbtim/iw,iwp,btime,btimex common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C C DATA MBLANK/' '/ C MVC(M,MA)=( (M+2)*M/2+MA )/2+1 C C C----------------------------------------------------------------------- C C INITIALIZATIONS C C----------------------------------------------------------------------- C KDM=KM !NO. OF CONFIGS. FOR /TERMS/ C BPRINT=MPRINT.GT.0.OR.MPRINT.EQ.0.AND.IDW.EQ.0 C BAMBM=.FALSE. !F95 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C MOD2=MODD !CAN RE-SET TO TEST VARIOUS TOTAL ML,MS c mod2=1 !MODD.LE.0 NOW BMOD2=(MOD2+1)/2.EQ.1 !SLOWER C BKUTOO=KUTOO.NE.0 BDLBD=IABS(MODD).LT.2.OR.BKUTOO C IF(BKUTOO)THEN IF(MXRKO.LT.MAXRK)THEN WRITE(6,*)'***INCREASE MXRKO TO MAXRK, OR SET KUTOO=-1' WRITE(6,*)'***CHECK MXRLO AND MXROS AS WELL!' WRITE(0,*)'***INCREASE MXRKO TO MAXRK, OR SET KUTOO=-1' GO TO 99 ENDIF IF(MXRLO.LT.MAXRL)THEN WRITE(6,*)'***INCREASE MXRLO TO MAXRL, OR SET KUTOO=-1' WRITE(6,*)'***CHECK MXRKO AND MXROS AS WELL!' WRITE(0,*)'***INCREASE MXRLO TO MAXRL, OR SET KUTOO=-1' GO TO 99 ENDIF IF(MXROS.LT.MXRKS)THEN WRITE(6,*)'***INCREASE MXROS TO MXRKS, OR SET KUTOO=-1' WRITE(6,*)'***CHECK MXRKO AND MXRLO AS WELL!' WRITE(0,*)'***INCREASE MXROS TO MXRKS, OR SET KUTOO=-1' GO TO 99 ENDIF ENDIF IF(MXRLS.LT.MAXRL)THEN WRITE(6,*)'***INCREASE MXRLS TO MAXRL' WRITE(0,*)'***INCREASE MXRLS TO MAXRL' GO TO 99 ENDIF C C CAN MAKE BIG CASES MORE EFFICIENT IF WE NO LONGER ALLOW THIS - NRB C IF(MPRINT.NE.MG.AND.MODD.GT.0)THEN WRITE(6,*)'***MOD.GT.0 WILL NO LONGER COMPUTE RADIATION' WRITE(6,*)'***SET MOD.LE.0 OR SWITCH-OFF RADIATION' WRITE(0,*)'***MOD.GT.0 WILL NO LONGER COMPUTE RADIATION' GO TO 99 ENDIF C C FOR MPRINT.GE.0 MPOLE HAS ALREADY BEEN SET (DEFAULT=4) C IF(MPRINT.EQ.-1.OR.MPRINT.EQ.-4)MPOLE=2 IF(MPRINT.EQ.MG)MPOLE=-1 !FOR INFO IF(MPOLE.GT.2*MXBLM)THEN WRITE(6,955)MPOLE/2,MXBLM WRITE(0,955)MPOLE/2,MXBLM MPOLE=2*MXBLM ENDIF C MPOLX=MPOLE MXPOL=MAX(1,MPOLX/2+1) IF(MXPOL.GT.MXD20)THEN WRITE(6,*)'ALGEB2: DO YOU REALLY NEED ALL THESE MULTIPOLES?' WRITE(0,*)'ALGEB2: DO YOU REALLY NEED ALL THESE MULTIPOLES?' GO TO 99 ENDIF C CB BBORN=MENGB.GE.0 !BORN CODING NOW USED MORE GENERALLY CB IF(BBORN)THEN IF(MPOL0.GE.0)THEN !BORN CODING NOW USED MORE GENERALLY MXORB2=(MXORB*(MXORB+1))/2 LHM=MPOLE/4 IF(BREL)LHM=LHM+1 ELSE MXORB2=1 LHM=0 ENDIF C C----------------------------------------------------------------------- C !F95 C EX-COMMON/NRBEKP/ !F95 IF(MPRINT.EQ.MG)THEN !F95 ID1=1 !F95 ID2=1 !F95 ELSE !F95 ID1=MAXSL !F95 ID2=MAXTM !F95 ENDIF !F95 ALLOCATE (NED(2,ID1,ID2),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR NED' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BNRBEKP=.TRUE. !F95 C !F95 C EX-COMMON/NRBRN2/ !F95 ALLOCATE (BINDB(MXORB2,0:LHM),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR BINDB' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BNRBRN2=.TRUE. !F95 C !F95 C----------------------------------------------------------------------- C DO LH=0,LHM DO I=1,MXORB2 BINDB(I,LH)=.FALSE. ENDDO ENDDO cold MXORB2=MXORB*MXORB C IF(NASTP.NE.0)THEN WRITE(6,1111) WRITE(6,1116) IF(NASTP.GT.0)THEN DO IPCF=1,MAXCF NPCF=NLSPIP(IPCF) IF(NPCF.GT.0)THEN WRITE(6,1118)IPCF WRITE(6,1113) DO I=1,NPCF IS=LSPIP(I,IPCF)/10000 IP=LSPIP(I,IPCF)-IS*10000 IL=IP/10 IP=IP-IL*10 WRITE(6,1114)I,IS,IL,IP ENDDO ENDIF ENDDO ELSE WRITE(6,1117)MINSTP,MAXSTP,MINLTP,min(99,MAXLTP) ENDIF IF(NAST.EQ.0)THEN WRITE(6,1111) ELSE WRITE(6,*)' ' ENDIF ENDIF C IF(NAST.NE.0)THEN IF(NASTP.EQ.0)THEN WRITE(6,1111) ELSE WRITE(6,*)' ' ENDIF WRITE(6,1112) IF(NAST.GT.0)THEN WRITE(6,1113) DO I=1,NAST IS=LSPI(I)/10000 IP=LSPI(I)-IS*10000 IL=IP/10 IP=IP-IL*10 WRITE(6,1114)I,IS,IL,IP ENDDO ELSE WRITE(6,1115)MINSP,MAXSP,MINLT,min(99,MAXLT) ENDIF WRITE(6,1111) ENDIF C C PACK CORE M_S AND M_L INTO M_L C DO I=1,NW NNL(I,2)=(NNL(I,3)+1)/2+NNL(I,2) ENDDO C C PACK QLMS AND QLML INTO ONE ARRAY C DO J=JYI(1),JYF(KM) DO I=1,NF QLML(I,J)=(QLMS(I,J)+1)/2+QLML(I,J) ENDDO ENDDO C C RETABULATE THE NCI=NTG(KM) TERMS CASL OF THE KM CONFIGURATIONS C ACCORDING TO TOTAL S,L,KPC(=PARITY 0,2 FOR EVEN,ODD); ONE OBTAINS C NSL0 BLOCKS OF LENGTH NSL(N), WITH QSI(N)=2S,QLI(N)=2L,QPI(N)=KP; C WRITE(6,400) C LX=.FALSE. NCTOT=0 NCI=0 NSL0=0 NN=0 ISXDI=1 IAXDI=1 IAXUC=0 IXAAI=0 c lusum=0 C DO I=1,MAXSL DO K=1,KM KGSL(K,I)=0 ENDDO ENDDO C QCL=QMCL !L C 51 QCS=QMCS !S C 52 KCP=0 !P C 53 NC=0 NCC=0 c do i=1,mxorb ncc0(i)=0 enddo mx0=mxorb+1 C DO K=1,KM IF(QCP(K).EQ.KCP)THEN NG=NTG(K-1)+1 NT=NTG(K) QCS0=QTGS(NG) QCL0=QTGL(NG) K0=1 ND0=0 DO I=NG,NT IF(QTGL(I).NE.QCL0.OR.QTGS(I).NE.QCS0)THEN QCS0=QTGS(I) QCL0=QTGL(I) K0=K0+1 ENDIF IF(QTGL(I).EQ.QCL.AND.QTGS(I).EQ.QCS)THEN NCI=NCI+1 LP=NCI.GT.MAXTM II=QCG(NF,K) ii=ieq(ii) IF(QN(II).GE.90)THEN NCC=NCC+1 ncc0(ii)=ncc0(ii)+1 mx0=min(mx0,ii) else NC=NC+1 endif ND=NSL0+1 ND0=K0 if(bprint)WRITE(6,180)NCI,QCS+1,QCL/2,KCP/2,K,I,ND IF(.NOT.LP)THEN NFQ(NCI)=ND NFK(NCI)=K NFI(NCI)=I ENDIF ELSE IF(QTGL(I).LT.QCL)GO TO 55 !BAIL OUT ENDIF ENDDO 55 IF(ND0.GT.0)KGSL(K,ND)=ND0 !GROUP NO. WITHIN CF ENDIF ENDDO C IF(NC+ncc.GT.0)THEN NN=((NC+1)*NC)/2+NN c isxdi=max(isxdi,nc) iorb(mx0-1)=nc*nc do i=mx0,mxorb n=ncc0(i) iorb(i)=iorb(i-1)+n*n if(n.gt.0)then nn=((n+1)*n)/2+nn isxdi=max(isxdi,n) nc=nc+n endif enddo c if(bfot)then !need c-c e-vectors nctot=nctot+iorb(mxorb) else !only b-b iaxuc=max(iaxuc,nctot+iorb(mxorb)) !need buffer nctot=nctot+iorb(mx0-1) !so can overwite c-c endif c write(6,*)nc,nn,nctot C WRITE(6,197)ND,QCS+1,QCL/2,KCP/2,NC C IAXDI=MAX(IAXDI,NC) IF(NC.GT.MAXDI)THEN IF(MAXDI.GT.0)WRITE(6,1966) !F95 CF77 WRITE(6,196) NC,MAXDI !F77 CF77 LX=.TRUE. !F77 ENDIF C LU=NCC*(NC-NCC) IXAAI=MAX(LU,IXAAI) NN=NN+LU c c lusum=lusum+lu c write(6,*)lu,nn c write(6,*)'lusum=',lusum C BVC=ND.GT.MAXSL NSL0=ND IF(.NOT.BVC)THEN QLI(ND)=QCL QSI(ND)=QCS QPI(ND)=KCP NSL(ND)=NC NGRPI(ND)=NCI-NC ENDIF ENDIF C KCP=KCP+2 IF(KCP.LE.2)GO TO 53 !LOOP UP TO NEXT PARITY C QCS=QCS-2 IF(QCS.GE.0)GO TO 52 !LOOP UP FOR NEXT SPIN C QCL=QCL-2 IF(QCL.GE.0)GO TO 51 !LOOP UP FOR NEXT ORB A.M. C LP=LP.OR.BVC CF77 JOS=0 !F77 CF77 IF(LP)JOS=-1 !F77 IF(LP)GO TO 94 !DIMENSION EXCEEDED, BAIL OUT C IADD=NN C IF(IADD.GT.MAXAD)THEN IF(MAXAD.GT.0)WRITE(6,133)IADD,MAXAD !F95 CF77 GO TO 91 !DITTO !F77 ENDIF C C THESE 3 DIMENSIONS ARE FOR INFO ONLY. NOT NEEDED UNTIL DIAGON. C NOTE: IF MODE=3 OR 4 IS SET IN MINIM THEN THE ACTUAL DIMENSIONS C REQUIRED (ALLOCATED F95) WILL BE LARGER. THESE MODES ARE (SMALL) C TEST CASES, NOT PRODUCTION RUNS, SO NOT LIKELY AN ISSUE. WOULD C NEED USER TO SET MODE IN ALGEB, AND CODE DIAGON DIMENSION VARIATION. C WRITE(6,1979)ISXDI,IAXDI,MAXDI WRITE(6,198)NCTOT,IAXUC,MAXUC WRITE(6,1988)IXAAI,MXAAI C IF(NCTOT.GT.MAXUC)THEN IF(MAXUC.GT.0)WRITE(6,1999) !F95 CF77 WRITE(6,199) !F77 CF77 IF(MPRINT.GT.-2)THEN !F77 CF77 WRITE(0,*)'INCREASE MAXUC FOR RADIATIVE DATA' !F77 CF77 GO TO 99 !F77 CF77 ENDIF !F77 ENDIF C IF(IXAAI.GT.MXAAI)THEN IF(MXAAI.GT.0)WRITE(6,299)IXAAI !F95 CF77 WRITE(6,298)IXAAI !F77 CF77 LX=.TRUE. !F77 ENDIF C IF(LX)THEN WRITE(6,200) WRITE(0,*)'*** INCREASE MXAAI OR MAXDI' GO TO 99 ENDIF C C----------------------------------------------------------------------- C C SET METASTABLE LSP GROUPS BASED-ON PRE-EXISTING TERMS/LEVELS FILES C SO AS TO RESTRICT UNNECESSARY BORN INTEGRAL EVALUATION ETC. C C----------------------------------------------------------------------- C EX=.FALSE. IF(NMETA.LT.0.AND..NOT.BVC)THEN NMETA=-NMETA INQUIRE(FILE='TERMS',EXIST=EX) IF(EX)THEN OPEN(14,FILE='TERMS',STATUS='OLD') READ(14,*,END=331) DO K=1,NSL0 !ASSUME WE CAN RESTRICT NMETAG(K)=1 ENDDO DO N=1,NMETA READ(14,992,END=331)ISP,LSP,IPP,NDUM,NDUM,DUM,MYRGE IF(MYRGE.NE.MBLANK)THEN !CANNOT RESTRICT DO K=1,NSL0 NMETAG(K)=0 ENDDO GO TO 331 ENDIF IF(ISP.GT.0)THEN ISP=ISP-1 LSP=LSP+LSP IPP=IPP+IPP DO K=1,NSL0 IF(ISP.EQ.QSI(K).AND.LSP.EQ.QLI(K).AND.IPP.EQ.QPI(K) X )THEN NMETAG(K)=0 GO TO 330 ENDIF ENDDO ELSE GO TO 331 ENDIF 330 ENDDO 331 CLOSE(14) IUNIT(14)=-1 c write(6,*)'lsp groups' c do k=1,nsl0 c write(6,*)k,nmetag(k) c enddo ELSE WRITE(6,1120) WRITE(0,1120) ENDIF cw ELSE cw IF(IDW.NE.0.AND.NMETA.GT.0)THEN cw WRITE(6,1121) cw WRITE(0,1121) cw ENDIF ENDIF C IF(NMETAJ.LT.0.AND..NOT.BVC)THEN !CATCH EK, ALGEB3 TOO LATE INQUIRE(FILE='LEVELS',EXIST=EXJ) IF(EXJ)THEN NMETJ0=NMETAJ NMETAJ=-NMETAJ OPEN(15,FILE='LEVELS',STATUS='OLD') READ(15,*,END=333) IF(.NOT.EX)THEN !ASSUME WE CAN RESTRICT, IF NOT ALREADY SO DO K=1,NSL0 NMETAG(K)=1 ENDDO ENDIF READ(15,993,END=333)JSP,IP0,IS0,LS0,ICF0,NDUM,DUM,MYRGE IS0=IABS(IS0) REWIND(15) READ(15,*,END=333) NMG=0 DO N=1,MAXLV READ(15,993,END=333)JSP,IPP,ISP,LSP,ICF,NDUM,DUM,MYRGE IF(MYRGE.NE.MBLANK)THEN !CANNOT RESTRICT DO K=1,NSL0 NMETAG(K)=0 ENDDO GO TO 333 ENDIF JSP=JSP+1 IF(ISP.LT.0)THEN JSP=-JSP ISP=-ISP ENDIF IF(ISP.GT.0)THEN IF(NMETAJ/MAXLV.GT.0)THEN IF(ISP.NE.IS0.OR.LSP.NE.LS0 X .OR.IPP.NE.IP0.OR.ICF.NE.ICF0)THEN NMETAJ=N-1 ELSE ICF0=ICF IS0=ISP LS0=LSP IP0=IPP ENDIF ENDIF DO M=1,NMG IF(JSP.EQ.JMG(M))GO TO 334 ENDDO IF(N.LE.NMETAJ)THEN NMG=NMG+1 JMG(NMG)=JSP ELSE GO TO 332 ENDIF 334 ISP=ISP-1 LSP=LSP+LSP IPP=IPP+IPP DO K=1,NSL0 IF(ISP.EQ.QSI(K).AND.LSP.EQ.QLI(K).AND.IPP.EQ.QPI(K) X )THEN NMETAG(K)=0 GO TO 332 ENDIF ENDDO ELSE GO TO 333 ENDIF 332 ENDDO 333 CLOSE(15) IUNIT(15)=-1 NMETAJ=NMETJ0 !RE-INSTATE c write(6,*)'lsjp groups' c do k=1,nsl0 c write(6,*)k,nmetag(k) c enddo ENDIF ENDIF C C----------------------------------------------------------------------- C C CHECK BUFFERS FOR DC ARRAY IF DISKDC IN USE C C----------------------------------------------------------------------- C MDCBUF2=0 IF(KUTDSK.LT.KM)THEN IEND=MTGD !FOR DISKDC MTGD1=MTGD+1 CALL DISKDC(IUD,DC,IDC,1,0,0,0,0,0) !REPOINT C IF(KUTDSK.LT.KFBUFF)THEN DO K=1,NSL0 MTGD1=MTGD+1 !RESTORE DO KF=KUTDSK+1,KFBUFF NGSYM=KGSL(KF,K) !POS WITHIN CF IF(NGSYM.GT.0)THEN ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,0,0) C MTGD1=IFIN+1 ENDIF ENDDO IFIN=MTGD1-1 MDCBUF2=MAX(MDCBUF2,IFIN) ENDDO IF(MDCBUF2.GT.MDCBUF)THEN WRITE(6,140)MDCBUF2 GO TO 99 ENDIF c write(6,*)'ALGEB2 flgl; ',mdcbuf2 c write(76,*)'ALGEB2 flgl' MDCBUF2=0 ELSE MDCBUF2=MDCBUF DO K=KFBUFF+1,KM KSTART(K,1)=0 ENDDO ENDIF ENDIF C C----------------------------------------------------------------------- C IF(MPRINT.LT.MG)THEN IF(.NOT.BKUTOO) X WRITE(6,150)MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL,MXDFS IF(BKUTOO) X WRITE(6,151)MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL,MXDFS,KUTOO IF(MAXLAM.NE.1000)WRITE(6,152)MAXLAM WRITE(6,120)IADD,NSL0,NCI,NCI,0,0 WRITE(6,1190)MDCBUF2,MAXDC ENDIF C C----------------------------------------------------------------------- C !F95 C EX-COMMON/DXRL/ !F95 ALLOCATE (DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),NAD(0:IADD) !F95 X ,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR DRK,QRL,NRK,NAD' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BDXRL=.TRUE. !F95 C !F95 C EX-COMMON/NRBNF1/ !F95 IRKO=1 !F95 IF(BKUTOO)IRKO=MXRKO !F95 ALLOCATE (DEK(IRKO),BFALL(IRKO),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR DEK, BFALL' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BNRBNF1=.TRUE. !F95 C !F95 C EX-COMMON/DXRLS/ !F95 IROS=1 !F95 IF(BKUTOO)IROS=MXROS !F95 ALLOCATE (DRKS(MXRKS),DEKS(IROS),QRLS(5,MXRLS),NRKS(MXRKS) !F95 X ,BFALLS(IROS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR DRKS,DEKS,QRLS ETC'!F95 NF=0 !F95 GO TO 90 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS/ !F95 ALLOCATE (NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F95 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR NADS,NSTJ,IORIG ETC'!F95 NF=0 !F95 GO TO 90 !F95 ENDIF !F95 C !F95 C LOCAL !F95 JMX=JYF(KM) !F95 C !F95 ALLOCATE (AM(JMX),BM(JMX),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: ALLOCATION FAILS FOR AM,BM' !F95 NF=0 !F95 GO TO 90 !F95 ENDIF !F95 BAMBM=.TRUE. !F95 C C----------------------------------------------------------------------- C IF(MPRINT.LT.MG)GO TO 90 !EXIT TERM DIMENSION CHECK C C----------------------------------------------------------------------- C C CALCULATE SOME (PRODUCTS OF) CLEBSCH-GORDAN COEFFICIENTS: C C VCA=C(L1,L2,L,0,0,0)*C(L1,L2,KT,ML1,ML2,MLK)/(L+1) C VCB=C(L1,L2,L,0,0,0)*C(L1,L2,KT+2,ML1,ML2,MLK) C DFS(1)=1 DFS(2)=1 DO I=3,MXDFS,2 DFS(I)=-DFS(I-2) DFS(I+1)=(I-1)*DFS(I-1)/32 ENDDO C MXLL=-1 NXLL=-1 SKP=MPRINT+2.LT.MG !NO SKIP NOW. OLD +0 -3,-4 SKIP IF(.NOT.SKP)THEN DO K=1,MXORB IF(DEY(K).NE.DZERO.AND.QL(K).GT.MXLL)MXLL=QL(K) ENDDO NXLL=MXLL BVC=MXLL.LE.2*MAXLL IF(.NOT.BVC)MXLL=2*MAXLL C M1=0 46 M2=0 C 45 MK=IABS(M1-M2) C 44 MKT=MK+2 DVC0=VCC(M1,M2,MK,0,0,0,DFS,MXDFS) ML1=-M1 C 42 MB1=MVC(M1,ML1) ML2=-M2 C 43 MB2=MVC(M2,ML2) DA=DZERO DD=DZERO MLK=ML1+ML2 C IF(IABS(MLK).LE.MKT)THEN IF(BDLBD)DD=VCC(M1,M2,MKT,ML1,ML2,MLK,DFS,MXDFS)*DVC0 IF(IABS(MLK).LE.MK) X DA=(VCC(M1,M2,MK, ML1,ML2,MLK,DFS,MXDFS)/(MK+1))*DVC0 ENDIF C MLK=MK/4+1 VCA(MB1,MB2,MLK)=DA VCB(MB1,MB2,MLK)=DD C ML2=ML2+2 IF(ML2.LE.M2)GO TO 43 C ML1=ML1+2 IF(ML1.LE.M1)GO TO 42 C MK=MK+4 IF(MK.LE.M1+M2)GO TO 44 C M2=M2+2 IF(M2.LE.MXLL)GO TO 45 C M1=M1+2 IF(M1.LE.MXLL)GO TO 46 ENDIF C C----------------------------------------------------------------------- C C PREPARE TO CALCULATE THE ALGEBRA OF THE ENERGY MATRIX IN SL COUPLING C I.E., THE COEFFICIENTS A AND B, AS WELL AS FOR EK RADIATION C THIS SECTION SHOULD BE STUDIED TOGETHER WITH (COMMENTS IN) SR.FLGL C AND SR.EKALG C C----------------------------------------------------------------------- C IF(.NOT.BKUTOO) XWRITE(6,150)MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL,MXDFS IF(BKUTOO) XWRITE(6,151)MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL,MXDFS,KUTOO IF(MAXLAM.NE.1000)WRITE(6,152)MAXLAM C C DRK(K),K=1,NAD(N=0) WILL BE THE COEFFICIENTS TO THE CLOSED SHELL C CONFIGURATION C0-IT CONTRIBUTES TO ALL DIAGONAL , EJN-EQ6 C CHOICE OF ML,MS ACCORDING TO TIME OPTIMUM AND STATES AVAILABLE C IOS=0 JOS=1 IRK=0 IRL=0 NAD(0)=0 AM(1)=.FALSE. C IF(NW.GT.0)THEN NCOR=-1 KCF1=NFK(1) NADS(-1)=-1 NADG(1)=0 ELSE NCOR=0 NADS(-1)=0 ENDIF C KMX=(KM*(KM+1))/2 C MXIRKS=0 MXIRLS=0 JOSS=1 C IF(BMOD2)THEN !SLOWER QMS=NF-(NF/2)*2 QML=0 WRITE(6,*)'SR.ALGEB2: FLGL USING NON-DEFAULT MS, ML:',QMS,QML WRITE(0,*)'SR.ALGEB2: FLGL USING NON-DEFAULT MS, ML:',QMS,QML DO J=JYI(1),JYF(KM) AM(J)=QBML(J).NE.QML .OR. QBMS(J).NE.QMS ENDDO DO NCF=1,KMX NADS(NCF)=0 ENDDO ENDIF C LP=MPRINT.GT.0 C C**************************** C EXPAND THE NSL0 SUBMATRICES SLP=QSI(K)+1,QLI(K)/2,1-QPI(K) C**************************** C if(btime)then time1=dzero time2=dzero endif c NCI=0 DO 61 K=1,NSL0 !START LOOP OVER SLP GROUPS C NC=NSL(K) IF(NCOR.GE.0)NADG(K)=NCOR C if(btime)call cpu_time(timei) c IF(.NOT.BMOD2)THEN !CHOOSE MIN SLATER STATE SET QMS=QSI(K) QML=QLI(K) QMP=QPI(K) C DO NCF=1,KMX NADS(NCF)=0 ENDDO C !PRE-SELECT CONFIGS DO KK=1,KM IF(KGSL(KK,K).GT.0)THEN !CF CONTRIBS TO GROUP DO J=JYI(KK),JYF(KK) AM(J)=QBML(J).NE.QML .OR. QBMS(J).NE.QMS ENDDO ELSE K1=(KK*(KK-1))/2 K2=K1+KK K1=K1+1 DO NCF=K1,K2 NADS(NCF)=-1 ENDDO NCF=K2 DO K0=KK+1,KM NCF=NCF+K0-1 NADS(NCF)=-1 ENDDO ENDIF ENDDO KONE=1 ELSE KONE=K ENDIF C IF(KONE.EQ.1)THEN !UPDATE SLATER-STATE INTERACTION C CALL FLGL1(KCF1,KM,NF,JYI,JYF,QLML,AM,DFS,MAXEL) C MXIRKS=MAX(MXIRKS,IRKS) MXIRLS=MAX(MXIRLS,IRLS) IF(IRLS.GT.MXRLS)JOSS=-1 IF(IRKS.GT.MXRKS)JOSS=0 IF(JOSS.LE.0)GO TO 67 !DIMENSION EXCEEDED, BAIL OUT IF(NF.LT.0)GO TO 999 C IF(AM(1))THEN WRITE(6,1955) AM(1)=.FALSE. ENDIF C ENDIF C if(btime)then call cpu_time(timef) time1=time1+timef-timei endif c IF(KUTDSK.LT.KFBUFF)THEN MTGD1=MTGD+1 !RESTORE DO KF=KUTDSK+1,KFBUFF !LOAD NEW SL GROUP VCC KSTART(KF,1)=0 NGSYM=KGSL(KF,K) !POS WITHIN CF IF(NGSYM.GT.0)THEN ISTRT=MTGD1 KSTART(KF,1)=ISTRT C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,1,0) C MTGD1=IFIN+1 IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ENDDO IFIN=MTGD1-1 MDCBUF2=MAX(MDCBUF2,IFIN) ENDIF c if(btime)call cpu_time(timei) C istrt0=0 KF0=0 56 DO ND1=1,NC !BEGIN LOOP OVER INITIAL TERMS C ND=ND1+NCI KF=NFK(ND) c ii=ieq(qcg(nf,kf)) kcf=0 if(qn(ii).ge.90)kcf=ii !continuum C IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN ISTRT=KSTART(KF,1) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF NGSYM=KGSL(KF,K) !POS WITHIN CF ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IEND,KF,NGSYM,1,0) C IF(IEND.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT0=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KF0=KF ENDIF C II=NFI(ND) IF(BFAST)THEN ND2=JTGD(II)+ISTRT0 !relative start flagged ELSE do j=jyi(kf),jyf(kf) mam(j)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt0 k2=k2+istrt0 do k12=k1,k2 j=idc(k12) mam(j)=k12 enddo ENDIF C istrt=0 KG0=0 DO NDP1=1,ND1 !BEGIN LOOP OVER FINAL TERMS C NG=NDP1+NCI KG=NFK(NG) c jj=ieq(qcg(nf,kg)) kcg=0 if(qn(jj).ge.90)kcg=jj if(kcf.ne.kcg.and.kcf*kcg.ne.0)go to 60 !does not contrib C EQCFS=KG.EQ.KF IF(EQCFS)THEN IF(NCOR.LT.0)THEN KK=0 ELSE KK=(KF*(KF+1))/2 ENDIF ELSE c if(kf.lt.kg)stop 'flgl2: kf.lt.kg' KK=(KF*(KF-1))/2 + KG ENDIF C IRK0=IRK+1 IF(NADS(KK).LE.NADS(KK-1))GO TO 37 !CONFIGS INCOMPATIBLE C IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN ISTRT=KSTART(KG,1) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF LGSYM=KGSL(KG,K) !POS WITHIN CF ISTRT=IEND+1 !AS KF BUFFERED C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KG0=KG ENDIF C JJ=NFI(NG) IF(BFAST)THEN NDP2=JTGD(JJ)+ISTRT !relative start flagged ELSE do j=jyi(kg),jyf(kg) nam(j)=0 enddo k2=jtgd(jj) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(jj-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt k2=k2+istrt do k12=k1,k2 j=idc(k12) nam(j)=k12 enddo ENDIF C CALL FLGL2(DC,mam,nam,KK) C 37 NCOR=NCOR+1 C IF(IRL.GT.MAXRL)JOS=-1 IF(IRK.GT.MAXRK)JOS=0 IF(JOS.LE.0)GO TO 67 !DIMENSION EXCEEDED, BAIL OUT IF(NF.LT.0)GO TO 999 C IF(LP.AND.IRK.GE.IRK0)THEN IF(IRK-IRK0.NE.5)THEN WRITE(6,120)NCOR,K,ND,NG,IRK,IRL X ,(NRK(I),DRK(I),I=IRK0,IRK) ELSE WRITE(6,119)NCOR,K,ND,NG,IRK,IRL X ,(NRK(I),DRK(I),I=IRK0,IRK) ENDIF IF(BKUTOO)WRITE(6,121)(NRK(I),DEK(I),I=IRK0,IRK) WRITE(6,120) ENDIF C NAD(NCOR)=IRK IF(NCOR.EQ.0)GO TO 56 !THEN THAT WAS CLOSED-SHELL CORE C 60 ENDDO !END LOOP OVER FINAL TERMS C ENDDO !END LOOP OVER INITIAL TERMS C if(btime)then call cpu_time(timef) time2=time2+timef-timei endif c NCI=NCI+NC C 61 CONTINUE !END LOOP OVER SLP GROUPS c c do i=1,irks c write(6,3333)i,nrks(i),nstj(i),nstjd(i),drks(i) c 3333 format(i5,i3,2i5,f10.6) c enddo c if(btime)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for algeb2:' !par cpar write(iwp,*)' flgl1 time=',nint(time1),'sec' !par cpar write(iwp,*)' flgl2 time=',nint(time2),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'flgl1 time=',nint(time1),'sec' write(iw,*)'flgl2 time=',nint(time2),'sec' c call flush(iw) cpar endif !par endif C C C RESULTS C DRK(K),K=NAD(N-1)+1,NAD(N)=STRUCTURE COEFFICIENTS, C AND NRK(K)=SLATER INTEGRAL ADRESSES L, OF THE N'TH ENERGY MATRIX C ELEMENT; (T!H!T') IS N-NUMBERED IN REDUCED TRIANGULAR ORDER-COM- C PARE THE FIRST THREE COLUMNS OF THE COEFFICIENT TABLE, IT REVEALS C MOST FEATURES. THE FOUR ELECTRON ARGUMENTS (1,2,3..FOR 1S,2S,2P..) C OF THE L'TH SLATER INTEGRAL ARE IN QRL(1-4,L), QRL(5,L)=2*LAMBDA. C QRL(5,L)=-1 INDICATES A NONTRIVIAL, OFF-DIAGONAL ONE-BODY INTEGRAL C MM=IRL+IRK-IRK0 IF(AM(1))WRITE(6,195)MM C IF(IADD.NE.NCOR)THEN WRITE(6,*)'SR.ALGEB2 GLOBAL INDEX ERROR:',IADD,NCOR NF=-1 GO TO 999 ENDIF C 67 IF(.NOT.LP.OR.JOS.LE.0.OR.JOSS.LE.0)THEN WRITE(6,120)NCOR,NSL0,ND,NG,IRK,IRL IF(JOS.LT.0)GO TO 93 IF(JOS.EQ.0)GO TO 95 WRITE(6,122)MXRKS,MXRLS,MXIRKS,MXIRLS WRITE(6,1190)MDCBUF2,MAXDC IF(JOSS.LT.0)GO TO 930 IF(JOSS.EQ.0)GO TO 950 WRITE(6,900)MPRINT ELSE C C PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST C WRITE(6,122)MXRKS,MXRLS,MXIRKS,MXIRLS WRITE(6,1190)MDCBUF2,MAXDC IF(IRL.GT.0)THEN IF(BKUTOO)WRITE(6,301)KUTOO IF(.NOT.BKUTOO)WRITE(6,300) DO L=1,IRL WRITE(6,700)L,(QRL(I,L), I=1,5) ENDDO ENDIF ENDIF C C C----------------------------------------------------------------------- C C WORK OUT REDUCED ELECTRIC 2K-MULTIPOLE MATRIX ELEMENTS C OMIT EK RAD FOR C-C CONFIGURATIONS (AND B-C IF NO PHOTOIONIZATION) C C----------------------------------------------------------------------- C IF(MPRINT.EQ.MG)GO TO 10 C IF(LP)WRITE(6,600) IF(.NOT.LP)WRITE(6,601) C C FLAG EXISTENCE, OR NOT, OF ONE-BODY INTERACTIONS BETWEEN C CONFIGURATION PAIRS C IFOTMX=0 IF(BFOT)IFOTMX=1 C KK=0 DO KF=1,KM !BEGIN KF LOOP II=QCG(NF,KF) IFOT1=0 IF(QN(II).GE.90)IFOT1=1 !CONTINUUM C DO KG=1,KF !BEGIN KG LOOP KK=KK+1 C BXIST(KK)=.FALSE. C II=QCG(NF,KG) IFOT2=0 IF(QN(II).GE.90)IFOT2=1 IF((IFOT1+IFOT2).GT.IFOTMX)GO TO 69 !DOES NOT CONTRIB C C FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF AND KG DIFFER C AND THEN SEE IF THIS CF PAIR CONTRIBUTES C IF(KF.NE.KG)THEN DO I=1,NF QLML(I,1)=QCG(I,KG) ENDDO MK=0 DO I=1,NF DO L=1,NF IF(IEQ(QLML(L,1)).EQ.IEQ(QCG(I,KF)))THEN QLML(L,1)=0 GO TO 68 ENDIF ENDDO MK=MK+1 IF(MK.GT.1)GO TO 69 !KF-KG DIFFER BY MORE THAN 1 PAIR M1=I 68 ENDDO DO L=1,NF IF(QLML(L,1).NE.0)THEN M2=L GO TO 70 ENDIF ENDDO 70 M1=QCG(M1,KF) M2=QCG(M2,KG) M1=QL(M1) M2=QL(M2) IF(M1+M2.LT.MPOL0)GO TO 69 !NO VALID MULTIPOLE IF(IABS(M1-M2).GT.MPOLE)GO TO 69 !NO VALID MULTIPOLE ELSE M2=0 DO I=1,NF M1=QCG(I,KG) M2=MAX(M2,QL(M1)) ENDDO M1=M2 IF(M1+M2.LT.MPOL0)GO TO 69 !NO VALID MULTIPOLE if(mpol0.eq.mpole.and.mod(mpol0,4).ne.0)go to 69 !odd only ENDIF C C FLAG KF-KG NEEDED C BXIST(KK)=.TRUE. C 69 ENDDO !END LOOP KG C ENDDO !END LOOP KF C IF(KUTDSK.LT.KM)THEN IEND=MTGD !FOR DISKDC MTGD1=MTGD+1 CALL DISKDC(IUD,DC,IDC,1,0,0,0,0,0) !REPOINT C IF(KUTDSK.LT.KFBUFF)THEN MDCBUF2=0 DO K=1,NSL0 MTGD1=MTGD+1 !RESTORE DO KF=KUTDSK+1,KFBUFF NGSYM=KGSL(KF,K) !POS WITHIN CF IF(NGSYM.GT.0)THEN c do kg=1,km k1=max(kf,kg) k2=min(kf,kg) kk=(k1*(k1-1))/2+k2 if(bxist(kk))go to 81 !need this kf enddo go to 82 c 81 ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,0,0) C MTGD1=IFIN+1 ENDIF 82 ENDDO IFIN=MTGD1-1 MDCBUF2=MAX(MDCBUF2,IFIN) ENDDO MDCBUF2=MDCBUF2+MDCBUF2-mtgd !MAY OVERESTIMATE FOR E1 BUT IC> IF(MDCBUF2.GT.MDCBUF)THEN WRITE(6,141)MDCBUF2 ENDIF c write(6,*)'ALGEB2 ekalg: ',mdcbuf2 c write(76,*)'ALGEB2 ekalg' MDCBUF2=0 ELSE DO I=1,2 DO K=KFBUFF+1,KM KSTART(K,I)=0 ENDDO ENDDO ENDIF ENDIF C C C----------------------------------------------------------------------- C C START CALCULATION OF THE ALGEBRA FOR ELECTRIC MULTIPOLES C C----------------------------------------------------------------------- C MX000=-MXIRKS !REMOVE "-" AND COMMENT-OUT NEXT 2 LINES TO MXIRKS=0 !SUPPRESS E_K SS STORAGE, UNLESS .GT. FOR H MXIRLS=0 IOS=IRK c if(btime)then time1=dzero time2=dzero endif c KMX=KM*KM !FOR INEQUIVALENT GROUPS MCI=0 DO NC=1,NSL0 !BEGIN LOOP OVER INITIAL GROUPS MC=NSL(NC) C QML1=QLI(NC) !ENSURE NON-ZERO DVC QMS1=QSI(NC) C IF(KUTDSK.LT.KFBUFF)THEN MTGD1=MTGD+1 !RESTORE DO KF=KUTDSK+1,KFBUFF !LOAD INITIAL GROUP VCC KSTART(KF,1)=0 NGSYM=KGSL(KF,NC) !POS WITHIN CF IF(NGSYM.GT.0)THEN c do kg=1,km k1=max(kf,kg) k2=min(kf,kg) kk=(k1*(k1-1))/2+k2 if(bxist(kk))then do nd=1,nc !check symms lgsym=kgsl(kg,nd) if(lgsym.gt.0)then if(qsi(nd).eq.qsi(nc).and. x nmetag(nc)+nmetag(nd).le.1)then mmin=max(mpol0,iabs(qli(nc)-qli(nd))) if(mod(qpi(nd)+qpi(nc)+mmin,4).ne.0)mmin=mmin+2 mmax=min(mpole,qli(nc)+qli(nd)) if(mod(qpi(nd)+qpi(nc)+mmax,4).ne.0)mmax=mmax-2 if(mmin.le.mmax)go to 71 !we have a winner endif endif enddo endif enddo kstart(kf,1)=mtgd1!dummy, else alternate kf read triggered go to 72 !no valid kf-kg so skip this kf read c 71 ISTRT=MTGD1 KSTART(KF,1)=ISTRT c c write(6,*)'*** kf=',kf,' nc=',nc C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,1,0) C MTGD1=IFIN+1 IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF 72 ENDDO MHOLD=MTGD1 ENDIF C !PRE-SELECT CONFIGS DO KK=1,KM IF(KGSL(KK,NC).GT.0)THEN !CF CONTRIBS TO GROUP DO J=JYI(KK),JYF(KK) AM(J)=QBML(J).NE.QML1 .OR. QBMS(J).NE.QMS1 ENDDO ENDIF ENDDO C MCIP=0 DO ND=1,NC !BEGIN LOOP OVER FINAL GROUPS MCP=NSL(ND) C EQGRP=NC.EQ.ND !WITHIN A GROUP C C PRE-SELECT SYMMETRIES... C IF(QSI(ND).NE.QSI(NC).OR.NMETAG(NC)+NMETAG(ND).GT.1)THEN NED(1,ND,MCI+1)=0 GO TO 79 ENDIF C MMIN=MAX(MPOL0,IABS(QLI(NC)-QLI(ND))) IF(MOD(QPI(ND)+QPI(NC)+MMIN,4).NE.0)MMIN=MMIN+2 MMAX=MIN(MPOLE,QLI(NC)+QLI(ND)) IF(MOD(QPI(ND)+QPI(NC)+MMAX,4).NE.0)MMAX=MMAX-2 C IF(MMIN.GT.MMAX)THEN NED(1,ND,MCI+1)=0 GO TO 79 ENDIF C if(btime)call cpu_time(timei) c QML2=QLI(ND) !ENSURE NON-ZERO DVC QMS2=QSI(ND) C MB1=QLI(NC) MB2=QLI(ND) ML1=QML1 ML2=-QML2 MLK=ML1+ML2 C DO MK=MMIN,MMAX,4 MM=MK/4+1 DVC(MM)=VCC(MB1,MB2,MK,ML1,ML2,MLK,DFS,MXDFS) c X *(-1)**(MB2+ML2) IF(DVC(MM).EQ.DZERO)then !this should not happen write(6,*)'algeb2: dvc=0 - report to nrb' write(6,*)mb1/2,mb2/2,mk/2,' ',ml1/2,ml2/2,mlk/2 write(0,*)'algeb2: dvc=0 - report to nrb' c write(0,*)mb1/2,mb2/2,mk/2,' ',ml1/2,ml2/2,mlk/2 endif ENDDO C BM(1)=EQGRP DO NCF=1,KMX !INITIALIZE NADS(NCF)=0 ENDDO IF(.NOT.EQGRP)THEN !(RE-)SET FOR KF DO KK=1,KM IF(KGSL(KK,NC).LE.0)THEN !CF DOES NOT CONTRIB K1=KM*(KK-1) K2=K1+KM K1=K1+1 DO NCF=K1,K2 NADS(NCF)=-1 ENDDO ENDIF ENDDO KK=0 DO KF=1,KM DO KG=1,KF KK=KK+1 IF(.NOT.BXIST(KK))THEN NCF=KM*(KF-1)+KG NADS(NCF)=-1 NCF=KM*(KG-1)+KF NADS(NCF)=-1 ENDIF ENDDO ENDDO ELSE KK=0 DO KF=1,KM DO KG=1,KF KK=KK+1 IF(.NOT.BXIST(KK))NADS(KK)=-1 ENDDO ENDDO ENDIF C !PRE-SELECT CONFIGS DO KK=1,KM IF(KGSL(KK,ND).GT.0)THEN !CF CONTRIBS TO GROUP DO J=JYI(KK),JYF(KK) BM(J)=QBML(J).NE.QML2 .OR. QBMS(J).NE.QMS2 ENDDO ELSE !CF DOES NOT CONTRIB IF(.NOT.EQGRP)THEN NCF=KK DO K0=1,KM NADS(NCF)=-1 NCF=NCF+KM ENDDO ELSE K1=(KK*(KK-1))/2 K2=K1+KK K1=K1+1 DO NCF=K1,K2 NADS(NCF)=-1 ENDDO NCF=K2 DO K0=KK+1,KM NCF=NCF+K0-1 NADS(NCF)=-1 ENDDO ENDIF ENDIF ENDDO C C DETERMINE SLATER STATE INTERACTIONS BETWEEN THESE GROUPS C CALL EKALG1(KM,NF,MMIN,MMAX,AM,BM,QLML,JYI,JYF,DFS,MAXEL) c if(btime)then call cpu_time(timef) time1=time1+timef-timei endif C MXIRKS=MAX(MXIRKS,IRKS) IF(MXIRKS.GT.MXRKS)GO TO 950 !DIMENSION EXCEEDED, BAIL OUT MXIRLS=MAX(MXIRLS,IRLS) IF(MXIRLS.GT.MXRLS)GO TO 930 !DIMENSION EXCEEDED, BAIL OUT IF(NF.LT.0)GO TO 999 C IF(IRKS.EQ.0)THEN !THERE ARE NO INTERACTIONS NED(1,ND,MCI+1)=0 GO TO 79 ENDIF C IF(KUTDSK.LT.KFBUFF)THEN MTGD1=MHOLD !RESTORE DO KG=KUTDSK+1,KFBUFF !LOAD FINAL GROUP VCC IF(EQGRP)THEN KSTART(KG,2)=KSTART(KG,1) ELSE KSTART(KG,2)=0 LGSYM=KGSL(KG,ND) !POS WITHIN CF IF(LGSYM.GT.0)THEN c do kf=1,km kk=km*(kf-1)+kg if(nads(kk).gt.nads(kk-1))go to 73 !need this kg enddo go to 74 c 73 ISTRT=MTGD1 KSTART(KG,2)=ISTRT c c write(6,*)'--- kg=',kg,' nd=',nd C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C MTGD1=IFIN+1 IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ENDIF 74 ENDDO IFIN=MTGD1-1 MDCBUF2=MAX(MDCBUF2,IFIN) ENDIF c if(btime)call cpu_time(timei) C istrt0=0 KF0=0 DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS C ND1=MD1+MCI NED(1,ND,ND1)=IOS+1 NED(2,ND,ND1)=IOS C KF=NFK(ND1) C IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN ISTRT=KSTART(KF,1) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF NGSYM=KGSL(KF,NC) !POS WITHIN CF ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IEND,KF,NGSYM,1,0) C IF(IEND.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT0=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KF0=KF ENDIF C II=NFI(ND1) IF(BFAST)THEN ND2=JTGD(II)+ISTRT0 !relative start flagged ELSE do j=jyi(kf),jyf(kf) mam(j)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt0 k2=k2+istrt0 do k12=k1,k2 j=idc(k12) mam(j)=k12 enddo ENDIF C istrt=0 KG0=0 DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS C NDP1=MDP1+MCIP IF(NDP1.GT.ND1)GO TO 11 KG=NFK(NDP1) C IF(EQGRP)THEN !KG.LE.KF HERE KK=(KF*(KF-1))/2 + KG ELSE KK=(KF-1)*KM+KG ENDIF C IF(NADS(KK).GT.NADS(KK-1))THEN c c write(6,*)'kf=',kf,' kg=',kg C IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN ISTRT=KSTART(KG,2) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF LGSYM=KGSL(KG,ND) !POS WITHIN CF ISTRT=IEND+1 !AS KG BUFFERED C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KG0=KG ENDIF C JJ=NFI(NDP1) IF(BFAST)THEN NDP2=JTGD(JJ)+ISTRT !relative start flagged ELSE do j=jyi(kg),jyf(kg) nam(j)=0 enddo k2=jtgd(jj) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(jj-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt k2=k2+istrt do k12=k1,k2 j=idc(k12) nam(j)=k12 enddo ENDIF C CALL EKALG2(DC,mam,nam,KK,DVC,JOS,IXY) C IF(IXY.GT.0)GO TO 92 !IXY.NE.0, DIMENSION EXCEEDED IF(IXY.LT.0)GO TO 93 IF(NF.LT.0)GO TO 999 C ENDIF C ENDDO !END LOOP OVER FINAL TERMS 11 NED(2,ND,ND1)=IOS ENDDO !END LOOP OVER INITIAL TERMS c if(btime)then call cpu_time(timef) time2=time2+timef-timei endif c 79 CONTINUE C MCIP=MCIP+MCP ENDDO !END LOOP OVER FINAL GROUPS MCI=MCI+MC ENDDO !END LOOP OVER INITIAL GROUPS C C IF(IOS.GE.IOS0)JOS=JOS-1 C if(btime)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for algeb2:' !par cpar write(iwp,*)' ekalg1 time=',nint(time1),'sec' !par cpar write(iwp,*)' ekalg2 time=',nint(time2),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'ekalg1 time=',nint(time1),'sec' write(iw,*)'ekalg2 time=',nint(time2),'sec' c call flush(iw) cpar endif !par endif c IF(.NOT.LP)THEN WRITE(6,701)JOS,NCI,NCI,MPOLE/2,MPOLE/2,IOS IF(MXIRKS.GT.MX000)WRITE(6,122)MXRKS,MXRLS,MXIRKS,MXIRLS WRITE(6,1190)MDCBUF2,MAXDC WRITE(6,900)MPRINT ELSE IF(MXIRKS.GT.MX000)WRITE(6,122)MXRKS,MXRLS,MXIRKS,MXIRLS WRITE(6,1190)MDCBUF2,MAXDC ENDIF GO TO 90 C 10 WRITE(6,1000) C NED(1,1,1)=-1 NED(2,1,1)=-1 C 90 CONTINUE C !F95 C EX-COMMON /NSTS/ !F95 IF(ALLOCATED(NADS))THEN !F95 DEALLOCATE (NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: DE-ALLOCATION FAILS FOR NADS,NSTJ, ETC'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/DXRLS/ !F95 IF(ALLOCATED(DRKS))THEN !F95 DEALLOCATE (DRKS,DEKS,QRLS,NRKS,BFALLS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: DE-ALLOCATION FAILS FOR DRKS,DEKS, ETC'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BAMBM)THEN !F95 DEALLOCATE (AM,BM,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB2: DE-ALLOCATION FAILS FOR AM,BM' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 RETURN !<-------------------- NORMAL RETURN C C E R R O R M E S S A G E S C CF77 91 WRITE(6,191)IADD !F77 CF77 IF(JOS.LT.0)GO TO 94 !F77 CF77 IF(JOS.EQ.0)GO TO 99 !F77 CF77 GO TO 99 !F77 95 WRITE(6,188) MPOLE=-1 92 IF(MPOLE.GE.4)WRITE(6,192) IF(MPOLE.EQ.2)WRITE(6,189) IF(IRL.LE.MAXRL)GO TO 96 93 WRITE(6,193) 96 IF(MPRINT.EQ.MG-1)GO TO 90 GO TO 99 94 WRITE(6,194)NCI, ND GO TO 99 930 WRITE(6,1930) GO TO 99 950 WRITE(6,1880) C 99 WRITE(6,190) c NF=0 c GO TO 90 C 999 NF=-1 GO TO 90 C 119 FORMAT(I9,I3, 2I6, I9,I5, 6(I6,F11.6)) 120 FORMAT(I9,I3, 2I6, I9,I5, 6(I6,F11.6)/(38X,6(I6,F11.6))) 121 FORMAT((38X,6(I6,F11.6))) 122 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXRKS,MXRLS) ',I8,I6, X10X,'USED: ',I8,I6) 133 FORMAT('SR.ALGEB2: ALLOCATION INCREASES NUMBER OF MATRIX ' !F95 X,' ELEMENTS IADD =',I10,'.GT.MAXAD=',I10) !F95 140 FORMAT(/'*** SR.ALGEB2: INCREASE MAXDC TO AT LEAST: ',I9,' FOR', X' H-BUFFER') 141 FORMAT(/'*** SR.ALGEB2: MAY NEED TO INCREASE MAXDC TO AT LEAST: ', XI9,' FOR',' E_K-BUFFER, WILL PLOUGH ON REGARDLESS...') 150 FORMAT(/ /' SLATER COEFFICIENTS F(A,...) FOR CONSTRUCTING ( T X ! H ! TP ) = SUM( F(A,...) * R(A,...) ); NCYC=0: COMMON DIAGO XNAL CORE TERM'/ I9,I3,2I6,I9,I5, ' STORAGE RESTRICTIONS FOR X (MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL), MXDFS=',I3/ X ' NCYC GR T TP MNF MNR',6(3X,'I(R) F(A,...)')) 151 FORMAT(/ /' SLATER COEFFICIENTS F(A,...) FOR CONSTRUCTING ( T X ! H ! TP ) = SUM( F(A,...) * R(A,...) ); NCYC=0: COMMON DIAGO XNAL CORE TERM'/ I9,I3,2I6,I9,I5, ' STORAGE RESTRICTIONS FOR X (MAXAD,MAXSL,MAXTM,MAXTM,MAXRK,MAXRL), MXDFS=',I3, X5X,'***** KUTOO=',I2,' *****' X/ ' NCYC GR T TP MNF MNR',6(3X,'I(R) F(A,...)')) 152 FORMAT(/' **** SLATER MULTIPOLE EXPANSION LIMITED TO LAMDA=',I3/) 180 FORMAT(I5,3I4,25X,I3,I6,I3) 188 FORMAT(/' SR.ALGEB2: *MAXRK TOO SMALL, ARRAYS DRK AND NRK ') 1880 FORMAT(/' SR.ALGEB2: *MXRKS TOO SMALL, ARRAYS DRKS AND NRKS ') 189 FORMAT(/' SR.ALGEB2: *MAXRK TOO SMALL, ARRAYS DRK AND NRK;'/ X' MAYBE SUFFICIENT IF NO RADIATIVE RATES (MPRINT=-2) REQUIRED.' ) 190 FORMAT( ' SR.ALGEB2: STORAGE EXCEEDED - CASE SKIPPED') CF77 191 FORMAT(/' SR.ALGEB2: *MAXAD=',I10, !F77 CF77 X' REQUIRED FOR NAD(MAXAD)') !F77 192 FORMAT(/' SR.ALGEB2: *MAXRK TOO SMALL, ARRAYS DRK AND NRK;'/' ', X'MAYBE SUFFICIENT IF NO RADIATIVE RATES (MPRINT=-2) OR DIPOLE ONLY X (MPRINT=-1) REQUIRED' ) 193 FORMAT(/' SR.ALGEB2: *MAXRL TOO SMALL, ARRAYS DRL AND QRL') 1930 FORMAT(/' SR.ALGEB2: *MXRLS TOO SMALL, ARRAYS DRLS AND QRLS') 194 FORMAT(/' SR.ALGEB2: *MAXTM=',I6,' AND MAXSL=',I3,' REQUIRED') 195 FORMAT(/28X,'WARNING: SHORTAGE OF BUFFER SPACE RESULTS IN EXCESSIV XE SCANNING'/28X,'******* THIS CASE MAY BE FASTER IF YOU CHOOSE', X'*MAXRL .GT.',I6) 1955 FORMAT(/28X,'WARNING: SHORTAGE OF BUFFER SPACE RESULTS IN EXCESSIV XE SCANNING'/28X,'******* THIS CASE MAY BE FASTER IF YOU CHOOSE', X'TO INCREASE *MAXRL') CF77 196 FORMAT(' WARNING: FAILURE EXPECTED IN SR.DIAGON,',I5, !F77 CF77 X'.GT.MAXDI=',I5) !F77 1966 FORMAT(' NOTE: ALLOCATION IN SR.DIAGON WILL INCREASE SIZE OF',!F95 X' SL MATRIX MAXDI AS BELOW') !F95 197 FORMAT(' ',56X,'GROUP=',I3,4X,'2S+1=',I2,2X,'L=',I2,3X,'PI=',I2 X,4X,'NC=',I5//) 1979 FORMAT(/76X,'(',I5,')',I9,7X,'MAXDI=',I9) 198 FORMAT(/72X,'(',I9,')',I9,7X,'MAXUC=',I9) 1988 FORMAT(/83X,I9,7X,'MXAAI=',I9) 1999 FORMAT(' NOTE: ALLOCATION IN SR.DIAGON WILL INCREASE NO. OF ',!F95 X'MATRIX ELEMENTS MAXUC AS ABOVE, IF RADIATIVE RATES REQUIRED')!F95 CF77 199 FORMAT(' WARNING: FAILURE EXPECTED IN DIAGON IF' !F77 CF77 X,' RADIATIVE RATES REQUIRED INCREASE MAXUC AS ABOVE' //) !F77 200 FORMAT(/' SR.ALGEB2: INCREASE MXAAI OR MAXDI - SEE ABOVE') CF77 298 FORMAT(/' TOO MANY BOUND-FREE INTERACTIONS, INCREASE ' !F77 CF77 X,'MXAAI TO',I9) !F77 299 FORMAT(/' TOO MANY BOUND-FREE INTERACTIONS, EXPECT ' !F95 X,'ALLOCATION IN ','DIAGON, TO INCREASE MXAAI TO',I9) !F95 300 FORMAT(/ ' I(R) R( A, B, C, D, 2LBD )=SLATER-INTEGRALS X A,B,C,D=1,2,3,..15: 1S,2S,2P,..5G-ORBITAL',9X,'REFERENCE LIST') 301 FORMAT(//' I(R) R( A, B, C, D, 2LBD )=SLATER-INTEGRALS' X,' AND ETA( A, B, C, D, 2LBD) REFERENCE LIST, KUTOO=',I2) 400 FORMAT(//' T 2S+1 L (P-0/1 FOR EVEN/ODD)',8X,'CF NT GR', X 20X,'**** TERM TABLE ****') 600 FORMAT( ' IOSC T TP, B D, MNF, = / C(L,LP,K;ML,MLP) / SF, 2ML 2MLP K; SF=(-1)**(LP-MLP X)/V(2K+1)') 601 FORMAT( ' IOSC T TP B D MNF') 700 FORMAT( I5, 2X,2(I5,I4),I7, F13.5,2F19.5, 6X,2I4, 5X,'E',I1,I6) 701 FORMAT( I6,I6,I6,I5,I4,I9) 900 FORMAT(/ ' *** PRINTOUT OF COEFFICIENTS SUPPRESSED - MPRINT(MODULO X 5)=',I2/) 992 FORMAT(3I2,I5,I5,F18.6,3X,A4) 993 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4) 955 FORMAT(//'*******SR.ALGEB2: INCREASE MXBLM TO:',I3, X ' *******2K-POLE RADIATION REDUCED TO K=',I3//) 1000 FORMAT(/' SR.ALGEB2: RADIATIVE CALCULATIONS SKIPPED'/12X,30('*')) 1111 FORMAT(//1X,136('-')//) 1112 FORMAT(' *** USER-SUPPLIED TERM SYMMETRY RESTRICTIONS:'//) 1113 FORMAT(' T 2S+1 L (P-0/1 FOR EVEN/ODD)') 1114 FORMAT(1X,4I4) 1115 FORMAT(' MINST =',I2,3X,'MAXST =',I2,5X,'MINLT =',I2,3X X,'MAXLT =',I2) 1116 FORMAT(' *** USER-SUPPLIED PARENT TERM SYMMETRY RESTRICTIONS:'//) 1117 FORMAT(' MINSTP=',I2,3X,'MAXSTP=',I2,5X,'MINLTP=',I2,3X X,'MAXLTP=',I2) 1118 FORMAT(' CF=',I3/) 1120 FORMAT(/'*** ALGEB2: YOU HAVE FLAGGED READ OF AN OLD TERMS' X,' FILE, BUT NONE CAN BE FOUND...'/12X,'SWITCH-OFF FLAG AND' X,' RE-RUN (FOR ENERGIES ONLY) TO GENERATE ONE (EFFEICIENTLY)') cw 1121 FORMAT(/'*** IN LARGE CASES IT IS MORE EFFICIENT TO READ A' cw X,' "TERMS" FILE GENERATED BY A PRIOR (ENERGIES ONLY) RUN') 1190 FORMAT(/87X,I9,'=MTGD, MAXDC=',I9 X ,' BUFFER STORAGE USED') C END C C ******************* C SUBROUTINE ALGEB3(DC,IDC,MAM,NAM,QLML,QBML,QBMS,JYI,JYF,MAXEL) C C----------------------------------------------------------------------- C C SR.ALGEB3 DEALS WITH THE CALCULATION OF THE ALGEBRA OF THE FINE C STRUCTURE INTERACTIONS (SPIN-ORBIT,RESIDUAL MUTUAL-SPIN-ORBIT AND C SPIN-SPIN). NOW SOLVES SLATER-STATE PROBLEM BY LSJP GROUP - NRB. C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_COEFF, ONLY: BCOEFF,DRKP,QRLP,IRLP,NRKP,NADP !F95 USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_DMQSS3, ONLY: BDMQSS3,DSS,MSS,QSS,NADR !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 USE COMMON_NRBRN2, ONLY: MENGB !F95 USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 C PARAMETER (MXD14=100) PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) PARAMETER (MXD27=MAXCF*MAXCF) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-6) PARAMETER (TTYNY=TYNY/1.D3) C INTEGER SJ,SJP C INTEGER*8 MDCF8,MDCFT8 CF77 INTEGER*8 NRKP,MSS !F77 C CHARACTER(LEN=1) LIT CHARACTER(LEN=4) CODE,MBLANK,MYRGE C LOGICAL LF,BVC,LX,BDLBD,EQUGRP,LX1,LX2,B1BODY,B2BODY,BMOD3,B1B,B2B X ,BFOT,BFAST,BFASTSO,EQCFS,BPRINT,EXJ,G2BODY X ,bswap,btime,btimex X ,bm1bp !F95 CF77 X ,BINDB !F77 C REAL*8 DC DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*),JYI(*),JYF(*) X ,QLML(MAXEL,*),QBML(*),QBMS(*) X ,nej(2),mej(2) DIMENSION DFS(MXDFS),LIT(8),QJI(MAXJG),kstart(maxcf,mxsyj) C COMMON /BASIC/NF,KF,KG,J1,J2,J1P,J2P,NLEV,NJ2,NJP2,MGAP(2) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 COMMON /COMRES/DVC12,LX,ICLRS,ICLRR COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JJ(MAXLV),NGR(MAXLV) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRLP/IRKP,IRKP0 COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL,NL000 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT) X ,QCP(MAXCF),QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTXX,NTJ(MAXCF),NFJ(MAXLV) X ,KUTSO COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM !F95 COMMON /NRBBBB/B1B(MXD19),B2B(MXD19) COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBJ/JPI(MAXJG),NASTJ,MINJT,MAXJT COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 COMMON /NRBUNI/IUNIT(MXD14),NUNIT common /nrbtim/iw,iwp,btime,btimex common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C C DATA MBLANK/' '/ DATA LIT(1),LIT(2),LIT(3),LIT(4)/' ','A','B','C'/ DATA LIT(5),LIT(6),LIT(7),LIT(8)/'*','a','b','c'/ C MVC(MLX,MLY)=((MLX+2)*MLX/2+MLY)/2+1 C C if(iunit(12).ne.0)then !for radwin i69=69 else i69=79 endif c C IF IABS(MODD).GT.1 NOT ENOUGH VCC'S ARE AVAILABLE FOR CALCULATING C FINESTRUCTURE INTERACTIONS. C NJO=0 IF(IABS(MODD).GT.1)GO TO 101 C C----------------------------------------------------------------------- C C INITIALIZATIONS C C----------------------------------------------------------------------- C BPRINT=MPRINT.GT.0.OR.MPRINT.EQ.0.AND.IDW.EQ.0 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C MOD3=MODD !CAN RE-SET TO TEST VARIOUS TOTAL MJ c mod3=1 !MODD.LE.0 NOW BMOD3=(MOD3+1)/2.EQ.1 !SLOWER C BFASTSO=KUTSS.EQ.-1 !IF NO 2-BODY PRE-SET 1-BODY SO SS INTS c bfastso=.false. !force if .true. uses too much memory IF(BFASTSO)THEN NSS=JYF(KM) !F95 CF77 NSS=MXST0 !F77 ELSE IF(MXS2I.LT.MAXMI)THEN WRITE(6,*)'***INCREASE MXS2I TO MAXMI' WRITE(0,*)'***INCREASE MXS2I TO MAXMI' GO TO 90 ENDIF ENDIF C G2BODY=.TRUE. !F77 C C ALIGNS TO THE DEFAULT REQUIREMENTS FOR KUTSS=0 AND -1 C MKT=KUTSS IF((MKT+3)/2.EQ.1)MKT=1+MKT MUTSO=KUTSO MUTSO=IABS(MUTSO) c c Test swap bra/ket. This is because there is an apparent anti/symmetry c in the N-coefficient/integral combinations which is not readily taken c into account. This means that the H symmetry is not readily apparent, c which needs to be recognized when comparing with algxfs. c bswap=.false. c LX=.FALSE. MPRNT1=MPRINT IF(MPRNT1.EQ.0.AND.MENGB.GE.0)MPRNT1=-1 !I.E. BBORN C IF(NASTJ.NE.0)THEN WRITE(6,1111) WRITE(6,1112) IF(NASTJ.GT.0)THEN WRITE(6,1113) DO I=1,NASTJ IJ=JPI(I)/10 IP=JPI(I)-IJ*10 WRITE(6,1114)I,IJ,IP ENDDO ELSE WRITE(6,1115)MINJT,MAXJT ENDIF WRITE(6,1111) ENDIF C C THE FOLLOWING SECTION SETS UP THE STATES ACCORDING TO THEIR C J-VALUES: J=TOTAL ANGULAR MOMENTUM. C JACT=QMCL+QMCS WRITE(6,400) C NJ=0 NP=0 NCTOT=0 ISXDK=1 IAXDK=1 IAXJU=0 IXAAK=0 c lusum=0 C 60 KPI=0 C 61 IF(NASTJ.GT.0)THEN !SELECT BY JPI JT=10*JACT+KPI/2 DO I=1,NASTJ IF(JT.EQ.JPI(I))GO TO 62 !WANT ENDDO GO TO 64 !DON'T WANT ELSEIF(NASTJ.LT.0)THEN !SELECT BY MINJT,MAXJT IF(JACT.LT.MINJT.OR.JACT.GT.MAXJT)GO TO 64 !DON'T WANT ENDIF C 62 N0=0 NCC=0 NDJ=NJO+1 !NDJ IS JP GROUP NUMBER NGSLJ(NDJ)=0 c do i=1,mxorb ncc0(i)=0 enddo mx0=mxorb+1 lu=0 C C DO LOOP TO FIND NUMBER OF LEVELS WHICH CAN RESULT IN GIVEN J C IT=0 DO I=1,NSL0 NC=NSL(I) IT=IT+NC IF(QPI(I).NE.KPI)GO TO 63 C LJ=QLI(I) SJ=QSI(I) IF(IABS(LJ-SJ).GT.JACT.OR.(LJ+SJ).LT.JACT)GO TO 63 C IT=IT-NC NGSLJ(NDJ)=NGSLJ(NDJ)+1 NSLJ(NGSLJ(NDJ),NDJ)=I c nc0=ncc N00=0 DO N=1,NC C IT=IT+1 NJ=NJ+1 KG=NFK(IT) II=QCG(NF,KG) ii=ieq(ii) IF(QN(II).GE.90)THEN NCC=NCC+1 ncc0(ii)=ncc0(ii)+1 mx0=min(mx0,ii) else N00=N00+1 endif c if(bprint)WRITE(6,180)NJ,SJ+1,LJ/2,JACT,KG,IT LF=NJ.GT.MAXLV IF(LF)GO TO 63 NRR(NJ)=IT JJ(NJ)=JACT NGR(NJ)=NDJ C ENDDO N0=N0+N00 lu=lu+n00*(ncc-nc0) !if no 2-fs C 63 ENDDO C IF(N0+ncc.GT.0)THEN NP=((N0+1)*N0)/2+NP c isxdk=max(isxdk,n0) iorb(mx0-1)=n0*n0 do i=mx0,mxorb n=ncc0(i) iorb(i)=iorb(i-1)+n*n if(n.gt.0)then np=((n+1)*n)/2+np isxdk=max(isxdk,n) n0=n0+n endif enddo c if(bfot)then !need c-c e-vectors nctot=nctot+iorb(mxorb) else !only b-b iaxju=max(iaxju,nctot+iorb(mxorb)) !need buffer nctot=nctot+iorb(mx0-1) !so can overwite c-c endif c write(6,*)n0,np,nctot C WRITE(6,181)NDJ,JACT,KPI/2,N0 C IAXDK=MAX(IAXDK,N0) IF(N0.GT.MAXDK)THEN !AS NOT ALL ALLOCATED IN DIAGFS IF(MAXDK.GT.0)WRITE(6,1777) !F95 CF77 WRITE(6,777)N0,MAXDK !F77 CF77 LX=.TRUE. !F77 ENDIF C IF(.NOT.BFASTSO)then LU=NCC*(N0-NCC) !WE HAVE 2-FS, NEED ND.NE.NC B-C INTERACTIONS NP=NP+LU ! & NEED 2-FS POINTERS (NOW SKIP IF LS ONLY) endif IXAAK=MAX(LU,IXAAK) c c lusum=lusum+lu c write(6,*)lu,np c write(6,*)'lusum=',lusum C BVC=NDJ.GT.MAXJG NJO=NDJ IF(.NOT.BVC)THEN NT(NDJ)=N0 QJI(NDJ)=JACT ENDIF ENDIF C 64 KPI=KPI+2 IF(KPI.EQ.2)GO TO 61 !LOOP BACK UP FOR SECOND PARITY C JACT=JACT-2 IF(JACT.GE.0)GO TO 60 !LOOP BACK UP FOR NEXT 2J C NLEV=NJ C LF=LF.OR.BVC IF(LF)THEN WRITE(6,670)NLEV,MAXLV,NJO,MAXJG GO TO 90 ENDIF C IADJ=NP C IF(IADJ.GT.MXADJ)THEN IF(MXADJ.GT.0)WRITE(6,3054)IADJ,MXADJ !F95 CF77 WRITE(6,3055)IADJ,MXADJ !F77 CF77 GO TO 90 !F77 ENDIF C C THESE 3 DIMENSIONS ARE FOR INFO ONLY. NOT NEEDED UNTIL DIAGFS. C NOTE: IF MODE=3 OR 4 IS SET IN MINIM THEN THE ACTUAL DIMENSIONS C REQUIRED (ALLOCATED F95) WILL BE LARGER. THESE MODES ARE (SMALL) C TEST CASES, NOT PRODUCTION RUNS, SO NOT LIKELY AN ISSUE. WOULD C NEED USER TO SET MODE IN ALGEB, AND CODE DIAGFS DIMENSION VARIATION. C WRITE(6,131)ISXDK,IAXDK,MAXDK WRITE(6,134)NCTOT,IAXJU,MAXJU WRITE(6,132)IXAAK,MXAAK C IF(NCTOT.GT.MAXJU)THEN IF(MAXJU.GT.0)WRITE(6,133) !F95 CF77 WRITE(6,135) !F77 CF77 IF(MPRNT1.GT.-2)THEN !F77 CF77 WRITE(0,*)'INCREASE MAXJU FOR RADIATIVE DATA' !F77 CF77 GO TO 90 !F77 CF77 ENDIF !F77 ENDIF C IF(IXAAK.GT.MXAAK)THEN IF(MXAAK.GT.0)WRITE(6,299)IXAAK !F95 CF77 WRITE(6,298)IXAAK !F77 CF77 LX=.TRUE. !F77 ENDIF C IF(LX)THEN WRITE(6,136) WRITE(0,*)'*** INCREASE MXAAK OR MAXDK' GO TO 90 ENDIF C C INDEX POSITION OF LEVEL WITHIN A CONFIG. C DO K=1,KM NTJ(K)=0 DO J=1,NLEV IT=NRR(J) IF(NFK(IT).EQ.K)THEN NTJ(K)=NTJ(K)+1 NFJ(J)=NTJ(K) ENDIF ENDDO ENDDO C C----------------------------------------------------------------------- C C SET METASTABLE jp GROUPS BASED-ON PRE-EXISTING LEVELS FILE C SO AS TO RESTRICT UNNECESSARY MK EVALUATION ETC. C C----------------------------------------------------------------------- C IF(NMETAJ.LT.0.AND..NOT.BVC)THEN C NMETJ0=NMETAJ NMETAJ=-NMETAJ INQUIRE(FILE='LEVELS',EXIST=EXJ) IF(EXJ)THEN OPEN(15,FILE='LEVELS',STATUS='OLD') READ(15,*,END=333) DO K=1,NJO !ASSUME WE CAN RESTRICT NMETGJ(K)=1 ENDDO READ(15,993,END=333)JSP,IP0,IS0,LS0,ICF0,NDUM,DUM,MYRGE IS0=IABS(IS0) REWIND(15) READ(15,*,END=333) DO N=1,NMETAJ READ(15,993,END=333)JSP,IPP,ISP,LSP,ICF,NDUM,DUM,MYRGE IF(MYRGE.NE.MBLANK)THEN !CANNOT RESTRICT DO K=1,NJO NMETGJ(K)=0 ENDDO GO TO 333 ENDIF ISP=IABS(ISP) IF(ISP.GT.0)THEN IF(NMETAJ/MAXLV.GT.0)THEN IF(ISP.NE.IS0.OR.LSP.NE.LS0 X .OR.IPP.NE.IP0.OR.ICF.NE.ICF0)GO TO 333 ICF0=ICF IS0=ISP LS0=LSP IP0=IPP ENDIF ISP=ISP-1 LSP=LSP+LSP IPP=IPP+IPP DO KK=1,NJO IF(JSP.EQ.QJI(KK))THEN KP=NSLJ(1,KK) IF(IPP.EQ.QPI(KP))THEN NMETGJ(KK)=0 DO KP=1,NGSLJ(KK) K=NSLJ(KP,KK) if(nmetag(k).ne.0)stop 'algeb3: nmetag error' NMETAG(K)=0 ENDDO GO TO 332 ENDIF ENDIF ENDDO ELSE GO TO 333 ENDIF 332 ENDDO 333 CLOSE(15) IUNIT(15)=-1 C NMETAJ=NMETJ0 !RE-INSTATE c write(6,*)'jp groups' c do k=1,njo c write(6,*)k,nmetgj(k) c enddo c write(6,*)'lsp groups' c do k=1,nsl0 c write(6,*)k,nmetag(k) c enddo ELSE WRITE(6,1122) WRITE(0,1122) ENDIF cw ELSE cw IF(IDW.NE.0.AND.NMETAJ.GT.0)THEN cw WRITE(6,1123) cw WRITE(0,1123) cw ENDIF ENDIF C C----------------------------------------------------------------------- C C FLAG EXISTENCE, OR NOT, OF ONE- AND TWO-BODY INTERACTIONS BETWEEN C CONFIGURATION PAIRS C C----------------------------------------------------------------------- C c iflagc=0 KK=0 DO KF=1,KM !BEGIN KF LOOP II=IEQ(QCG(NF,KF)) KCF=0 IF(QN(II).GE.90)KCF=II !CONTINUUM if(qn(ii).ge.60.and.qn(ii).le.i69)kcf=-ii !omit ryd ci c iflagc=max(iflagc,kcf) C DO KG=1,KF !BEGIN KG LOOP KK=KK+1 B1BODY=.FALSE. B2BODY=.FALSE. C C FIRST CHECK GLOBAL SWITCHES C II=IEQ(QCG(NF,KG)) KCG=0 IF(QN(II).GE.90)KCG=II if(qn(ii).ge.60.and.qn(ii).le.i69)kcg=-ii !omit ryd ci IF(KCF.NE.KCG.AND.KCF*KCG.NE.0)GO TO 73 !DOES NOT CONTRIB if(kcf.ne.kcg.and.(kcf+kcg).lt.0)go to 73 c omit corr-corr' c if(kf.ne.kg.and.kcf+kcg+iflagc.gt.0.and.kg.gt.kcut)go to 73 C IF(KUTSO.GT.0)THEN IF(KF.GT.MUTSO.OR.KG.GT.MUTSO)THEN IF(KF.NE.KG)GO TO 73 ENDIF ELSEIF(KUTSO.LT.0)THEN IF(KF.NE.KG)GO TO 73 IF(KF.GT.MUTSO)GO TO 73 ENDIF C C NOW, FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF, KG DIFFER C DO M=1,NF QLML(M,1)=QCG(M,KG) ENDDO MK=0 DO M=1,NF ICG=IEQ(QCG(M,KF)) DO L=1,NF IF(IEQ(QLML(L,1)).EQ.ICG)THEN QLML(L,1)=0 GO TO 53 ENDIF ENDDO MK=MK+2 IF(MK.EQ.2)LD1=QCG(M,KF) 53 ENDDO C IF(MK-4.GT.0)GO TO 73 !THREE PAIRS OR MORE IF(MK-4.EQ.0.AND.MKT.GE.0)GO TO 73 !TWO, BUT NO TWO-BODY C C SEE IF WE NEED TWO-BODY C IF(MKT.NE.-9)THEN IF(MKT.GE.0.AND.MK.NE.0)GO TO 15 IF(KCFSS(KF)*KCFSS(KG).LE.0)THEN IF(KF.GT.IABS(MKT))GO TO 15 IF(KG.GT.IABS(MKT))GO TO 15 ENDIF ENDIF IF(NF.GT.1)B2BODY=.TRUE. 15 IF(.NOT.B2BODY.AND.MK.EQ.4)GO TO 73 C C SEE IF ONE-BODY EXISTS C IF(MK.EQ.2)THEN DO L=1,NF IF(QLML(L,1).NE.0)THEN LD2=QCG(L,KG) GO TO 54 ENDIF ENDDO write(6,*)'algeb3: should not be here - report to nrb' write(0,*)'algeb3: should not be here - report to nrb' 54 IF(QL(LD1).NE.QL(LD2))THEN IF(.NOT.B2BODY)GO TO 73 LDD=-1 ELSE LDD=QL(LD1) ENDIF ELSEIF(MK.EQ.4)THEN LDD=-1 ELSE LDD=1 ENDIF B1BODY=LDD.GT.0 C C FLAG WHETHER KF-KG NEEDED C 73 B1B(KK)=B1BODY B2B(KK)=B2BODY C ENDDO !END LOOP KG C ENDDO !END LOOP KF C C----------------------------------------------------------------------- C C SET-UP LOCATIONS OF ONE-BODY SPIN-ORBIT SLATER-SLATE INTERACTIONS C C----------------------------------------------------------------------- C KINT=0 IF(.NOT.BFASTSO)GO TO 555 !SKIP C C SET POINTERS TO ML BOUNDARIES C !F77 CF77 IF(QMCL/2.GT.MXD02)THEN !F77 CF77 WRITE(6,*)'*** SR.ALGXLS: INCREASE MXD02 TO:',QMCL/2 !F77 CF77 WRITE(0,*)'*** SR.ALGXLS: INCREASE MXD02 TO:',QMCL/2 !F77 CF77 GO TO 90 !F77 CF77 ENDIF !F77 C C EX-COMMON/NRBFL0/ !F95 C !F95 MXD02=QMCL/2 !F95 MXD03=MXD02+1 !F95 IF(KUTSO.EQ.-1)THEN !NORMAL !F95 IXD19=KM !F95 ELSE !MAXIMAL FOR KUTSO=0, COULD REDUCE ELSEWISE !F95 IXD19=(KM*(KM+1))/2 !F95 ENDIF !F95 C !F95 ALLOCATE (KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F95 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:IXD19) !F95 X ,MPOINT(-MXD02:MXD03,KM) !F95 X ,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR KPTCFM,MPOINT ETC.' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C C----------------------------------------------------------------------- C IF(MPRINT.LT.-2)GO TO 555 !SKIP MXSTX DIMENSION CHECK C C----------------------------------------------------------------------- C DO K=1,KM J=JYI(K) ML0=QBML(J) ML=ML0/2 J=J-1 DO M=MXD03,ML,-1 MPOINT(M,K)=J ENDDO DO J=JYI(K),JYF(K) ML=QBML(J) IF(ML.LT.ML0)THEN ML0=ML0/2 ML1=1+ML/2 DO M=ML0,ML1,-1 MPOINT(M,K)=J-1 ENDDO ML0=ML ENDIF ENDDO ML=ML/2 MPOINT(ML,K)=JYF(K) ML=ML-1 DO M=ML,-MXD02,-1 MPOINT(M,K)=JYF(K) ENDDO ENDDO C C SET-UP POINTERS TO 1-BODY SLATER-STATE INTERACTIONS C KK=0 KPTCFM(MXD03,MXD02,1)=0 c if(btime)call cpu_time(timei) C KB=0 KG1=1 DO KF=1,KM IF(KUTSO.EQ.-1)KG1=KF DO KG=KG1,KF KK=KK+1 C IF(B1B(KB+KG))THEN CALL SPOR0(KK,QLML,MAXEL) ELSE DO M=MXD02,-MXD02,-1 DO MP=MXD02,-MXD02,-1 KPTCFM(MP,M,KK)=KINT ENDDO ENDDO ENDIF c c write(0,*)'*** kg, kf, kint:',kg,kf,kint c IF(KK.GT.1)KPTCFM(MXD03,MXD02,KK)=KPTCFM(-MXD02,-MXD02,KK-1) C MPP=-MXD02 DO M=MXD02-1,-MXD02,-1 IF(KF.EQ.KG)MPP=M+1 KPTCFM(MXD03,M,KK)=KPTCFM(MPP,M+1,KK) c kptcfm(mxd03,m,kk)=kptcfm(m,mxd03,kk) ENDDO c c checks and debug print (remove/comment-out eventually) c c do m=mxd02,-mxd02,-1 c if(kf.eq.kg)mpp=m c do mp=mxd02,mpp,-1 c do k=kptcfm(mp+1,m,kk)+1,kptcfm(mp,m,kk) c if(k.gt.mxstx)stop 'increase mxstx' c j=kinti(k) c jd=kintf(k) c if(qbml(jd).ne.2*mp.or.qbml(j).ne.2*m)then c write(6,*)kg,jd,mp,qbml(jd)/2,' cf j ml qbml', c x kf,j,m,qbml(j)/2,' kint=',k c stop 'algeb3: ml-mismatch' c endif c enddo c enddo c enddo C ENDDO KB=KB+KF ENDDO c if(btime)then call cpu_time(timef) time0=timef-timei c cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for algeb3:' !par cpar write(iwp,*)' spor0 time=',nint(time0),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'spor0 time=',nint(time0),'sec' c call flush(iw) cpar endif !par endif C IF(KINT.GT.MXSTX)THEN WRITE(6,*)'SR:ALGEB3: INCREASE MXSTX TO:',KINT WRITE(0,*)'INCREASE MXSTX TO:',KINT GO TO 90 ENDIF C 555 CONTINUE C C----------------------------------------------------------------------- C C CHECK BUFFERS FOR DC ARRAY IF DISKDC IN USE C C----------------------------------------------------------------------- C MDCBUF3=0 IF(KUTDSK.LT.KM)THEN IEND=MTGD !FOR DISKDC MTGD1=MTGD+1 CALL DISKDC(IUD,DC,IDC,1,0,0,0,0,0) !REPOINT C IF(KUTDSK.LT.KFBUFF)THEN NGJX=0 !DIM FOR ALLOCATE DO K=1,NJO NGJX=MAX(NGJX,NGSLJ(K)) MTGD1=MTGD+1 !RESTORE DO NGJ1=1,NGSLJ(K) NC=NSLJ(NGJ1,K) DO KF=KUTDSK+1,KFBUFF NGSYM=KGSL(KF,NC) !POS WITHIN CF IF(NGSYM.GT.0)THEN ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,0,0) C MTGD1=IFIN+1 ENDIF ENDDO ENDDO IFIN=MTGD1-1 MDCBUF3=MAX(MDCBUF3,IFIN) ENDDO IF(MDCBUF3.GT.MDCBUF)THEN WRITE(6,140)MDCBUF3 GO TO 90 ENDIF c write(6,*)'ALGEB3: ',mdcbuf3 c write(76,*)'ALGEB3' MDCBUF3=0 ELSE MDCBUF3=MDCBUF NGJX=0 !DIM FOR ALLOCATE DO K=1,NJO NGJX=MAX(NGJX,NGSLJ(K)) ENDDO nx=min(ngjx,mxsyj) DO N=1,nx DO K=KFBUFF+1,KM KSTART(K,N)=0 ENDDO ENDDO ENDIF if(ngjx.gt.mxsyj)then write(6,*)'*** sr/algeb3: increase mxsyj to',ngjx go to 90 endif ENDIF C C----------------------------------------------------------------------- C IF(MPRINT.LT.-2)THEN WRITE(6,3033)-KUTSO,KUTSS, LIT(QQCUT) WRITE(6,3050) MXADJ,MAXLV,MAXLV,MXSOC,MXSOI, X MXADJ,MAXLV,MAXLV,MXRSS,MAXMI WRITE(6,110)IADJ,NJ,NJ,0,0 WRITE(6,1202)NP,NJ,NJ,IRS,NL WRITE(6,122)MXS1C,MXS1I,0,0,mxstx,kint IF(KUTSS.NE.-1)WRITE(6,123)MXS2C,MXS2I,0,0 WRITE(6,190)MDCBUF3,MAXDC ENDIF C C----------------------------------------------------------------------- C !F95 C EX-COMMON/COEFF/ !F95 ALLOCATE (DRKP(MXSOC),QRLP(4,MXSOI),NRKP(MXSOC),NADP(IADJ) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR DRKP,QRLP,NRKP,NADP'!F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 BCOEFF=.TRUE. !F95 C !F95 C EX-COMMON/COEFFS/ !F95 ALLOCATE (DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR DRKPS,QRLPS,NRKPS' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS1/ !F95 ALLOCATE (NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F95 X ,IORIG1(MXS1I),JORIG1(MXS1I),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR NADS1,NSTJ1, ETC' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 C ex-ALGEB4 !F95 C here M1+BP=.not.bm1bp !F95 bm1bp=MPRINT.EQ.-2.OR.MPRINT.EQ.-1.OR.MPRINT.EQ.-4.OR. !F95 X MAX(MPOL0,4).GT.MPOLE.OR. !F95 X MBP1MX.LT.2.AND.MPOLE.LT.6.AND.MEKVMX.LT.2 !F95 C SET ALLOCATE SIZE !F95 IF(bm1bp.and.KUTSS.EQ.-1)THEN !FOR ANY RESTART !F95 G2BODY=.FALSE. !F95 IRSXX=0 !F95 NLXX=0 !F95 IADJXX=0 !F95 IS2CXX=0 !F95 IS2IXX=0 !F95 IXD27=0 !F95 ELSE !F95 G2BODY=.TRUE. !F95 IRSXX=MXRSS !F95 NLXX=MAXMI !F95 IADJXX=IADJ !F95 IS2CXX=MXS2C !F95 IS2IXX=MXS2I !F95 IXD27=MXD27 !F95 ENDIF !F95 B2BODY=G2BODY !F95 C !F95 C EX-COMMON/DMQSS3/ !F95 ALLOCATE (DSS(IRSXX),MSS(IRSXX),QSS(5,NLXX),NADR(0:IADJXX) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR DSS,MSS,QSS,NADR' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 BDMQSS3=.TRUE. !F95 C !F95 C EX-COMMON/DMQSSS/ !F95 ALLOCATE (DSSS(IS2CXX),MSSS(IS2CXX),QSSS(5,IS2IXX) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR DSSS,MSSS,QSSS' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS2/ !F95 ALLOCATE (NADS2(0:IXD27),NSTJ2(IS2CXX),NSTJ2D(IS2CXX) !F95 X ,IORIG2(IS2IXX),JORIG2(IS2IXX),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: ALLOCATION FAILS FOR NADS2,NSTJ2, ETC' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C C----------------------------------------------------------------------- C IF(MPRINT.LT.-2)GO TO 999 !EXIT LEVEL DIMENSION CHECK C C----------------------------------------------------------------------- C C CALCULATE SOME (PRODUCTS OF) CLEBSCH-GORDAN COEFFICIENTS: C C VCA=C(L1,L2,L,0,0,0)*C(L1,L2,KT,ML1,ML2,MLK)/(L+1) C VCB=C(L1,L2,L,0,0,0)*C(L1,L2,KT+2,ML1,ML2,MLK) C DFS(1)=1 DFS(2)=1 DO I=3,MXDFS,2 DFS(I)=-DFS(I-2) DFS(I+1)=(I-1)*DFS(I-1)/32 ENDDO C IF(BDLBD)GO TO 50 C MXLL=NXLL IF(MXLL.LT.0.OR.KUTSS.EQ.-1)GO TO 50 C BVC=MXLL.LE.2*MAXLL IF(.NOT.BVC)MXLL=2*MAXLL C M1=0 46 M2=0 C 45 MK=IABS(M1-M2) C 44 MK2=MK+2 DVC=VCC(M1,M2,MK,0,0,0,DFS,MXDFS) ML1=-M1 C 42 MB1=MVC(M1,ML1) ML2=-M2 C 43 MB2=MVC(M2,ML2) DA=DZERO DD=DZERO MLK=ML1+ML2 C IF(IABS(MLK).LE.MK2)THEN DD=VCC(M1,M2,MK2,ML1,ML2,MLK,DFS,MXDFS)*DVC IF(IABS(MLK).LE.MK) X DA=(VCC(M1,M2,MK,ML1,ML2,MLK,DFS,MXDFS)/(MK+1))*DVC ENDIF C MLK=MK/4+1 VCA(MB1,MB2,MLK)=DA VCB(MB1,MB2,MLK)=DD C ML2=ML2+2 IF(ML2.LE.M2)GO TO 43 C ML1=ML1+2 IF(ML1.LE.M1)GO TO 42 C MK=MK+4 IF(MK.LE.M1+M2)GO TO 44 C M2=M2+2 IF(M2.LE.MXLL)GO TO 45 C M1=M1+2 IF(M1.LE.MXLL)GO TO 46 C 50 CONTINUE C C----------------------------------------------------------------------- C C PREPARE TO CALCULATE THE ALGEBRA OF THE FINESTRUCTURE INTERACTIONS C I.E., THE COEFFICIENTS C,D,AND E. C THIS SECTION SHOULD BE STUDIED TOGETHER WITH (COMMENTS IN) SR.SPOR C AND SR.RES C C----------------------------------------------------------------------- C IF(MPRNT1.LE.0)WRITE(6,3056) IF(MCFSS.GE.1)THEN WRITE(6,3042) DO I=1,MAXCF IF(KCFSS(I).GE.1)WRITE(6,3043)I ENDDO ENDIF C WRITE(6,3033)-KUTSO,KUTSS, LIT(QQCUT) WRITE(6,3050) MXADJ,MAXLV,MAXLV,MXSOC,MXSOI, X MXADJ,MAXLV,MAXLV,MXRSS,MAXMI C C INITIALIZE FOR J-LOOP C NL=0 IRKP=0 IRS=0 IRLP=0 MXIRKS=0 MXIRLS=0 MXIRSS=0 MXNLS=0 KPI=0 KPIS=0 C NADR(0)=0 !CURRENTLY, NOT USED BY IDW=0 NADS1(0)=0 NADS2(0)=0 NCJ=0 NP=0 J1=2 J1P=2 C !TEST ALTERNATIVE QMJ IF(BMOD3)THEN JACT=JJ(1) QMJ=JACT-(JACT/2)*2 !0 or 1 i.e. min ENDIF C C****************************** C EXPAND OVER THE NJO JP GROUPS WHERE C****************************** C NT IS THE NUMBER OF LEVELS IN A JP GROUP C if(btime)then time1=dzero time2=dzero endif c DO 103 K=1,NJO !BEGIN JPI LOOP C JACT=JJ(NCJ+1) IF(.NOT.BMOD3)QMJ=JACT !QMJ=TWICE AZIMUTHAL COMPNT OF J c qmj=jact/2 C IF(KUTDSK.LT.KFBUFF)MTGD1=MTGD+1 !RESTORE C NCJ0=0 DO 1150 NGJ1=1,NGSLJ(K) !BEGIN SL LOOP NC=NSLJ(NGJ1,K) N0=NSL(NC) LJ=QLI(NC) SJ=QSI(NC) C DO KF=KUTDSK+1,KFBUFF !PRELOAD NEW SL GROUP VCC KSTART(KF,NGJ1)=0 NGSYM=KGSL(KF,NC) !POS WITHIN CF IF(NGSYM.GT.0)THEN ISTRT=MTGD1 KSTART(KF,NGJ1)=ISTRT C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,1,0) C MTGD1=IFIN+1 IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ENDDO C NCJP0=0 DO 1140 NGJP1=1,NGJ1 !BEGIN S'L' LOOP ND=NSLJ(NGJP1,K) N0P=NSL(ND) LJP=QLI(ND) SJP=QSI(ND) C if(btime)call cpu_time(timei) c IFLG0=0 IF(SJP+SJ.EQ.0)GO TO 70 IF(LJP+LJ.EQ.0)GO TO 70 IFLG0=1 C EQUGRP=NGJ1.EQ.NGJP1 if(equgrp.and.nc.ne.nd)stop 'equgrp.and.nc.ne.nd' if(.not.equgrp.and.nc.eq.nd)stop '.not.equgrp.and.nc.eq.nd' C IRKPS=0 IRLPS=0 IRSS=0 NLS=0 C KK=0 KG2=KM DO KF0=1,KM !BEGIN LOOP KF kf=kf0 !for bswap C IFLG=0 IF(KGSL(KF,NC).GT.0)IFLG=1 !CF CONTRIBS TO SL GROUP C IF(EQUGRP)KG2=KF C DO KG0=1,KG2 !BEGIN LOOP KG kg=kg0 !for bswap KK=KK+1 IF(IFLG.EQ.0)GO TO 733 !JUST INDEX C IF(.NOT.EQUGRP)THEN K0=MIN(KF,KG) K1=MAX(KF,KG) KB=(K1*(K1-1))/2+K0 ELSE KB=KK ENDIF C B1BODY=B1B(KB) B2BODY=B2B(KB) IF(.NOT.B1BODY.AND..NOT.B2BODY)GO TO 733 C IF(KGSL(KG,ND).GT.0)THEN !CF CONTRIBS TO S'L' GROUP IFLGG=1 ELSE IFLGG=0 GO TO 733 !NO, IT DOESN'T ENDIF C IF(BFASTSO)THEN EQCFS=KF.EQ.KG IF(KUTSO.EQ.-1)THEN i1=1 i2=2 K2=KF !KF=KG HERE ELSE if(kf.ge.kg)then i1=1 i2=2 K2=(KF*(KF-1))/2+KG else i1=2 i2=1 K2=(KG*(KG-1))/2+KF endif ENDIF ENDIF c if(bswap)then !test swap bra/ket j=kf kf=kg kg=j j=sj sj=sjp sjp=j j=lj lj=ljp ljp=j endif c JA=JYI(KF) JB=JYF(KF) JAP=JYI(KG) JBP=JYF(KG) C IRKPS0=IRKPS+1 IRLPS0=IRLPS IRSS0=IRSS+1 NLS00=NLS C ICLRR=0 IF(B2BODY)ICLRR=1 ICLRS=1 C C------------------------------------------------------------- C NOW LOOP-OVER ALL POSSIBLE ML,MS,ML',MS' THAT FORM MJ C AND PICK-OUT THE CORRESPONDING SLATERSTATES, FOR ALL KF,KG. C------------------------------------------------------------- C QMS=SJ 611 QML=QMJ-QMS LX1=QMS.NE.-SJ.AND.QML.NE.LJ IF(QML.LT.-LJ)GO TO 616 C IF(.NOT.BFASTSO)THEN C C MAM(I) IS CONSTRUCTED SO THAT IT CAN BE USED TO SELECT INITIAL STATES C HAVING THE CORRECT ML,MS. C J2=1 DO J=JA,JB IF(QBML(J).EQ.QML.AND.QBMS(J).EQ.QMS)THEN J2=J2+1 MAM(J2)=J ENDIF ENDDO IF(J2.LT.J1)GO TO 616 ENDIF C DVCL1=VCC(LJ,SJ,JACT,QML,QMS,QMJ,DFS,MXDFS) IF(ABS(DVCL1).LT.TTYNY)GO TO 616 C QMSP=SJP 622 QMLP=QMJ-QMSP LX2=QMSP.NE.-SJP.AND.QMLP.NE.LJP IF(QMLP.LT.-LJP)GO TO 615 C J1P=IABS(J1P) J2P=1 IF(IABS(QMSP-QMS).GT.2)THEN !NO 1-BODY IF(.NOT.B2BODY.OR.IABS(QMSP-QMS).GT.4)GO TO 615 !NO 2-BODY GO TO 633 !AS IABS(QMSP-QMS).EQ.4 ENDIF C C SELECT SLATE STATES/INTERACTIONS C IF(.NOT.BFASTSO)THEN C C NAM(I) IS CONSTRUCTED SO THAT IT CAN BE USED TO SELECT FINAL STATES C HAVING THE CORRECT MLP,MSP. C DO J=JAP,JBP IF(QBML(J).EQ.QMLP.AND.QBMS(J).EQ.QMSP)THEN J2P=J2P+1 NAM(J2P)=J ENDIF ENDDO C ELSE C C SET POINTERS THAT SELECT SLATER STATE INTERACTIONS FOR QML & QMLP C if(eqcfs)then if(qmlp.ge.qml)then i1=1 i2=2 else i1=2 i2=1 endif endif c mej(i1)=qml/2 mej(i2)=qmlp/2 k1=kptcfm(mej(2),mej(1),k2) mej(2)=mej(2)+1 k0=kptcfm(mej(2),mej(1),k2)+1 C C MAM(J2) IS CONSTRUCTED TO SELECT INITIAL & FINAL STATES C HAVING THE CORRECT QML, QMS & QMLP,QMSP. C c If non-trivial time taken in this search, do a double sweep as in c v22.11. The coding below does seem to inhibit compiler optimization. C c write(6,*)qml,qms,' ml ms ',qmlp,qmsp,' k0 k1 ',k0,k1 c J2=1 do ky=k0,k1 nej(i1)=kinti(ky) nej(i2)=kintf(ky) j=nej(1) jp=nej(2) jjp=jp kp=ky 137 IF(QBMS(J).EQ.QMS.AND.QBMS(JP).EQ.QMSP)THEN J2=J2+1 if(j2.gt.nss)then write(6,*)'sr.algeb3: mxst0/nss exceeded...' write(0,*)'sr.algeb3: mxst0/nss exceeded...' go to 999 endif if(eqcfs.and.qmlp.lt.qml)kp=-kp MAM(J2)=kp ENDIF if(eqcfs.and.QML.eq.QMLP.and.j.ne.jjp)then jp=j j=jjp kp=-kp go to 137 endif enddo J1P=J1 J2P=J2 ENDIF C IF(.NOT.B2BODY.AND.J2P.LT.J1P)GO TO 615 C 633 DVCL2=VCC(LJP,SJP,JACT,QMLP,QMSP,QMJ,DFS,MXDFS) C DVC12=DVCL1*DVCL2 IF(ABS(DVC12).LT.TYNY)GO TO 615 C LX=LX1.OR.LX2 C C------------------------------------------------------------- C CALCULATE THE SLATER-STATE INTERACTION BETWEEN CFS KF AND KG C------------------------------------------------------------- C 52 IF(B1BODY.AND.J2P.GE.J1P)THEN C C IF(.NOT.BFASTSO)THEN CALL SPOR1(QLML,MAXEL,MAM,NAM,KPIS) !<-- 1-BODY ELSE CALL SPOR1F(QLML,MAXEL,MAM,KPIS) !<-- 1-BODY ENDIF C C MXIRKS=MAX(MXIRKS,IRKPS) MXIRLS=MAX(MXIRLS,IRLPS) IF(KPIS.NE.0)GO TO 619 !DIM MXS1C AND/OR MXS1I EXCEEDED IF(NF.LT.0)GO TO 999 C IF(ICLRS.EQ.0)THEN IF(ICLRR.EQ.0)GO TO 733 J1P=IABS(J1P) ENDIF C ENDIF C IF(.NOT.B2BODY)GO TO 615 !CASE BFASTSO.EQ.TRUE C IF(IABS(QMSP-QMS).EQ.4)THEN !NOW ADD 2-BODY SS DO J=JAP,JBP IF(QBML(J).EQ.QMLP.AND.QBMS(J).EQ.QMSP)THEN J2P=J2P+1 NAM(J2P)=J ENDIF ENDDO ENDIF C 55 IF(J2P.GE.J1P)THEN C c write(6,*)qms,qml,qmsp,qmlp,qmj,irss,j1,j2,j1p,j2p C CALL RES1(QLML,MAXEL,DFS,MAM,NAM,KPIS) !<-- 2-BODY C C MXIRSS=MAX(MXIRSS,IRSS) MXNLS=MAX(MXNLS,NLS) IF(KPIS.NE.0)GO TO 619 !DIM MXS2C AND/OR MXS2I EXCEEDED IF(NF.LT.0)GO TO 999 C IF(ICLRR.EQ.0)THEN IF(ICLRS.EQ.0)GO TO 733 GO TO 617 ENDIF C ENDIF C C------------------------------------------------------------- C IF LX=.TRUE. THE TRANSFORMATION TO THE J,MJ REPRESENTATION C IS NOT YET COMPLETE. C------------------------------------------------------------- C 615 QMSP=QMSP-2 C IF(LX2)GO TO 622 C 616 QMS=QMS-2 C IF(LX1)GO TO 611 C C CLEAR ARRAYS, IF NOT ALREADY DONE C 617 IF(ICLRS.NE.0)THEN ICLRS=-ICLRS B1BODY=.TRUE. J1P=-IABS(J1P) GO TO 52 ENDIF C IF(ICLRR.NE.0)THEN ICLRR=-ICLRR J1P=-IABS(J1P) GO TO 55 ENDIF C 733 NADS1(KK)=IRKPS IF(G2BODY)NADS2(KK)=IRSS C c write(6,*)'***** kf,kg:',kf,kg,nads2(kk)-nads2(kk-1) c do ijk=nads2(kk-1)+1,nads2(kk) c jq=msss(ijk) c write(6,776)nstj2(ijk),nstj2d(ijk),msss(ijk),dsss(ijk) c x ,(qsss(iq,jq),iq=1,5) c 776 format(3i5,f12.6,5i5) c enddo c if(bswap.and.iflg*iflgg.gt.0)then !test swap bra/ket j=kf kf=kg kg=j j=sj sj=sjp sjp=j j=lj lj=ljp ljp=j endif c ENDDO !END LOOP KG C ENDDO !END LOOP KF C C 70 CONTINUE C CF77 IF(IRSS.GT.0.AND.MXAJS.NE.MXADJ.and.mxadj.gt.0)THEN !F77 CF77 WRITE(6,401) !F77 CF77 WRITE(0,*) !F77 CF77 X 'ERROR: SET MXAJS=MXADJ FOR TWO-BODY FINE-STRUCTURE' !F77 CF77 GO TO 90 !F77 CF77 ENDIF !F77 c if(btime)then call cpu_time(timef) time1=time1+timef-timei endif C C C------------------------------------------------------------------ C NOW DETERMINE THE INTERACTION BETWEEN JP LEVELS OF THE LSP GROUPS C------------------------------------------------------------------ c if(btime)call cpu_time(timei) C istrt0=0 KF0=0 DO NJ11=1,N0 !BEGIN SLJ LOOP C NJ1=NJ11+NCJ0 NJ=NJ1+NCJ IT=NRR(NJ) KF=NFK(IT) c if(ixaak.gt.0)then ii=ieq(qcg(nf,kf)) kcf=0 if(qn(ii).ge.90)kcf=ii !continuum endif C IF(IFLG0.EQ.0)GO TO 74 C IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN ISTRT=KSTART(KF,NGJ1) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF NGSYM=KGSL(KF,NC) !POS WITHIN CF ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IEND,KF,NGSYM,1,0) C IF(IEND.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT0=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KF0=KF ENDIF C II=NFI(IT) IF(BFAST)THEN NJ2=JTGD(II)+ISTRT0 !relative start flagged ELSE do j=jyi(kf),jyf(kf) mam(j)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt0 k2=k2+istrt0 do k12=k1,k2 j=idc(k12) mam(j)=k12 enddo ENDIF C 74 IF(NC.EQ.ND)N0P=NJ11 C istrt=0 KG0=0 DO NJP11=1,N0P !BEGIN S'L'J LOOP C NJP1=NJP11+NCJP0 NJG=NJP1+NCJ ITP=NRR(NJG) KG=NFK(ITP) c if(ixaak.gt.0)then ll=ieq(qcg(nf,kg)) kcg=0 if(qn(ll).ge.90)kcg=ll if(kcf.ne.kcg.and.kcf*kcg.ne.0)go to 80 !c-c does not contrb if(bfastso.and.(kcf+kcg).ne.0.and.kcf*kcg.eq.0) !.&.nc.ne.nd x go to 80 !no 2-fs and nc.ne.nd and b-c endif C NP=NP+1 IF(IFLG0.EQ.0)GO TO 618 !NO INTRACTNS 0-0 C C CALCULATE THE ALGEBRAIC CONTRIBUTION TO THE MATRIX ELEMENT. C IF(EQUGRP)THEN !KG.LE.KF HERE KK=(KF*(KF-1))/2 + KG ELSE KK=KM*(KF-1)+KG ENDIF C B1BODY=NADS1(KK).GT.NADS1(KK-1) IF(G2BODY)B2BODY=NADS2(KK).GT.NADS2(KK-1) C IF(B1BODY.OR.B2BODY)THEN C IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN ISTRT=KSTART(KG,NGJP1) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF LGSYM=KGSL(KG,ND) !POS WITHIN CF ISTRT=IEND+1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KG0=KG ENDIF C LL=NFI(ITP) IF(BFAST)THEN NJP2=JTGD(LL)+ISTRT !relative start flagged ELSE do j=jyi(kg),jyf(kg) nam(j)=0 enddo k2=jtgd(ll) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ll-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt k2=k2+istrt do k12=k1,k2 j=idc(k12) nam(j)=k12 enddo ENDIF c if(bswap)then !test swap bra/ket j=nj nj=njg njg=j if(bfast)then j=nj2 nj2=njp2 njp2=j else if(kf.ne.kg)then do j=jyi(kf),jyf(kf) nam(j)=mam(j) enddo do j=jyi(kg),jyf(kg) mam(j)=nam(j) enddo else do j=jyi(kf),jyf(kf) l=mam(j) mam(j)=nam(j) nam(j)=l enddo endif endif endif C ENDIF C IRKP0=IRKP+1 IF(B1BODY)THEN C C CALL SPOR2(DC,mam,nam ,KK,KPI) !<-- 1-BODY C C IF(KPI.NE.0)GO TO 619 ENDIF C IRS0=IRS+1 IF(B2BODY)THEN C C CALL RES2(DC,mam,nam ,KK,KPI) !<-- 2-BODY C C IF(KPI.NE.0)GO TO 619 ENDIF C C C PRINT THE ALGEBRAIC COEFFICIENTS OF THE SPIN-ORBIT MATRIX ELEMENT C IF THEY ARE NOT ZERO. C IF(MPRINT.GT.0)THEN IF(IRKP.EQ.IRKP0)THEN WRITE(6,109)NP,NJ,NJG,IRKP,IRLP X ,(NRKP(N),DRKP(N),N=IRKP0,IRKP) ELSEIF(IRKP.GT.IRKP0)THEN WRITE(6,110)NP,NJ,NJG,IRKP,IRLP X ,(NRKP(N),DRKP(N),N=IRKP0,IRKP) ELSE WRITE(6,109) ENDIF IF(IRS-IRS0.EQ.2)THEN WRITE(6,1201)NP,NJ,NJG,IRS,NL,(MSS(N),DSS(N),N=IRS0,IRS) ELSEIF(IRS.GE.IRS0)THEN WRITE(6,1202)NP,NJ,NJG,IRS,NL,(MSS(N),DSS(N),N=IRS0,IRS) ENDIF ELSEIF(MPRINT+idw.EQ.0)THEN IF(NJG.EQ.NJ)WRITE(6,130)NP,NJ,NJG,IRKP,IRLP,IRS,NL ENDIF c if(bswap)then !test swap bra/ket j=nj2 nj2=njp2 njp2=j j=nj nj=njg njg=j endif C C NADP IS THE ADDRESS ARRAY WHICH GIVES THE POSITION OF THE LAST C SPIN-ORBIT PARAMETER ASSOCIATED WITH AN M.E. (J,MJ!F(SO)!JP,MJP) C NADR SIMILARLY FOR 2-BODY FINE-STRUCTURE. (C.F. NAD FOR LS.) C 618 NADP(NP)=IRKP IF(G2BODY)NADR(NP)=IRS !GLOBAL TEST C 80 ENDDO !END S'L'J LOOP C ENDDO !END SLJ LOOP c if(btime)then call cpu_time(timef) time2=time2+timef-timei endif C NCJP0=NCJP0+N0P 1140 ENDDO !END S'L' LOOP C NCJ0=NCJ0+N0 1150 ENDDO !END SL LOOP C IF(KUTDSK.LT.KFBUFF)THEN IFIN=MTGD1-1 MDCBUF3=MAX(MDCBUF3,IFIN) ENDIF C NCJ=NT(K)+NCJ 103 ENDDO !END JP LOOP C c if(btime)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for algeb3:' !par cpar write(iwp,*)' spor1+res1 time=',nint(time1),'sec' !par cpar write(iwp,*)' spor2+res2 time=',nint(time2),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'spor1+res1 time=',nint(time1),'sec' write(iw,*)'spor2+res2 time=',nint(time2),'sec' c call flush(iw) cpar endif !par endif C C QBML(1)=NCJ QBMS(1)=NP IF(IADJ.NE.NP)THEN WRITE(6,*)'SR.ALGEB3 GLOBAL INDEX ERROR:',IADJ,NP NF=-1 GO TO 999 ENDIF C IF(MPRNT1.GE.0)THEN WRITE(6,122)MXS1C,MXS1I,MXIRKS,MXIRLS,mxstx,kint IF(IRSS.GT.0)WRITE(6,123)MXS2C,MXS2I,MXIRSS,MXNLS WRITE(6,190)MDCBUF3,MAXDC ENDIF IF(MPRNT1.EQ.0)GO TO 999 !RETURN IF(MPRNT1.GT.0)GO TO 620 C NJG=NCJ 619 WRITE(6,110)NP,NJ,NJG,IRKP,IRLP WRITE(6,1202)NP,NJ,NJG,IRS,NL C IF(KPI.LT.0)GO TO 99 IF(KPI.GT.0)GO TO 991 C WRITE(6,122)MXS1C,MXS1I,MXIRKS,MXIRLS,mxstx,kint IF(IRSS.GT.0)WRITE(6,123)MXS2C,MXS2I,MXIRSS,MXNLS WRITE(6,190)MDCBUF3,MAXDC IF(KPIS.LT.0)GO TO 990 IF(KPIS.GT.0)GO TO 9910 C GO TO 999 !RETURN C 620 IF(IRLP.GT.0)THEN WRITE(6,2001) !NO. S-O BY THEIR ARGUMENTS DO L=1,IRLP WRITE(6,2002)L,(QRLP(K,L),K=1,2) ENDDO ENDIF C IF(NL.GT.0)THEN !TWO-BODY WRITE(6,2011) DO L=1,NL IF(QSS(5,L).GT.197)THEN WRITE(6,244) L,(QSS(K,L),K=1,5) ELSE WRITE(6,2444) L,(QSS(K,L),K=1,5) ENDIF ENDDO ENDIF C GO TO 999 !RETURN C 101 WRITE(6,100) GO TO 999 !RETURN C C PRINT FAILURE DIAGNOSTIC C 99 WRITE(6,1210) GO TO 90 990 WRITE(6,1211) GO TO 90 991 WRITE(6,1203) GO TO 90 9910 WRITE(6,1204) C 90 WRITE(6,1377) WRITE(0,*) 'DIMENSION FAILURE IN ALGEB3' NF=-1 COLD NJO=-1 !SWITCH-OFF IC, BUT CONTINUE LS RUN C 999 CONTINUE c do i=1,mxorb if(qn(i).ge.60.and.qn(i).le.i69)qn(i)=mod(qn(i),60) enddo C !F95 C EX-COMMON /NSTS2/ !F95 IF(ALLOCATED(NADS2))THEN !F95 DEALLOCATE (NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: DE-ALLOCATION FAILS FOR NADS2,NSTJ2...'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/DMQSSS/ !F95 IF(ALLOCATED(DSSS))THEN !F95 DEALLOCATE (DSSS,MSSS,QSSS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: DE-ALLOCATION FAILS FOR DSSS,MSSS,QSSS'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS1/ !F95 IF(ALLOCATED(NADS1))THEN !F95 DEALLOCATE (NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: DE-ALLOCATION FAILS FOR NADS1,NSTJ1...'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/COEFFS/ !F95 IF(ALLOCATED(DRKPS))THEN !F95 DEALLOCATE (DRKPS,QRLPS,NRKPS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: DE-ALLOCATION FAILS FOR DRKPS,QRLPS..'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/NRBFL0/ !F95 IF(ALLOCATED(KINTI))THEN !F95 DEALLOCATE (KINTI,KINTF,KEN2,KPTCFM,MPOINT,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB3: DE-ALLOCATION FAILS FOR KPTCFM, ETC.' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C RETURN !<-------------------RETURN C 100 FORMAT( /" NOT ENOUGH VCC'S AVAILABLE FOR CALCULATION OF RELATIVIS XTIC CORRECTIONS: CHANGE MOD TO 1,-1 OR 0") 109 FORMAT(I9,2I6,I9,2I6,F12.6) 110 FORMAT(I9,2I6,I9,2I6,F12.6/(36X,I6,F12.6)) 122 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS1C,MXS1I) ',I8,I6, X10X,'USED: ',I8,I6/34X,'(MXSTX)',7X,I8,16X,'USED: ',I8) 123 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS2C,MXS2I) ',I8,I6, X10X,'USED: ',I8,I6) 130 FORMAT(I9,2I6,I9,I6,44X,I9,I6) 131 FORMAT(/75X,'(',I5,')',I10,7X,'MAXDK=',I9) 132 FORMAT(/83X,I9,7X,'MXAAK=',I9) 133 FORMAT(' EXPECT ALLOCATION IN SR.DIAGFS TO INCREASE NO. OF ', !F95 X'MATRIX ELEMENTS MAXJU AS ABOVE, IF RADIATIVE RATES REQUIRED')!F95 134 FORMAT(/71X,'(',I9,')',I10,7X,'MAXJU=',I9) CF77 135 FORMAT(/ 'FAILURE EXPECTED IN DIAGFS IF RADIATIVE RATES' !F77 CF77 X,' REQUIRED',1X,'INCREASE MAXJU AS ABOVE'//) !F77 136 FORMAT(/'SR.ALGEB3: INCREASE MXAAK OR MAXDK - SEE ABOVE') 140 FORMAT(/'*** SR.ALGEB3: INCREASE MAXDC TO AT LEAST: ',I9,' FOR', X' H-BUFFER') 180 FORMAT(6I5) 181 FORMAT(' ',44X,'JGROUP=',I3,4X,'2J=',I2,3X,'PARITY=',I3,4X,'N0=', XI5//) 190 FORMAT(/87X,I9,'=MTGD, MAXDC=',I9 X ,' BUFFER STORAGE USED') 244 FORMAT(I6,7X,4I5,I7) CF77 298 FORMAT(/' TOO MANY BOUND-FREE INTERACTIONS, EXPECT ' !F77 CF77 X,'FAILURE IN ','DIAGFS, INCREASE MXAAK TO',I9) !F77 299 FORMAT(/' TOO MANY BOUND-FREE INTERACTIONS, EXPECT ' !F95 X,'ALLOCATION IN ','DIAGFS, TO INCREASE MXAAK TO',I9) !F95 400 FORMAT(//' LV 2S+1 L 2J CF T',44X X,'**** LEVEL TABLE ****') CF77 401 FORMAT(/'***ERROR: SET MXAJS=MXADJ FOR TWO-BODY' !F77 CF77 X,' FINE-STRUCTURE') !F77 670 FORMAT(/' SR.ALGEB3: TOO MANY LEVELS,',I5,'.GT.MAXLV=',I5, ' - X OR TOO MANY (J,P) GROUPS,',I3,'.GT.MAXJG=',I3) CF77 777 FORMAT(/' SIZE OF AN SLJ SUB-MX TOO LARGE IN SR.ALGEB3,' !F77 CF77 X,I6,'.GT.MAXDK=',I5,'. WILL FAIL LATER IN SR.DIAGFS.'//) !F77 1777 FORMAT(' NOTE: ALLOCATION IN SR.DIAGFS WILL INCREASE SIZE OF',!F95 X' SLJ MATRIX MAXDK AS BELOW') !F95 993 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4) 1111 FORMAT(//1X,136('-')//) 1112 FORMAT(' *** USER-SUPPLIED LEVEL SYMMETRY RESTRICTIONS:'//) 1113 FORMAT(' LV 2J P') 1114 FORMAT(1X,3I4) 1115 FORMAT(' MINJT=',I2,3X,'MAXJT=',I2) 1122 FORMAT(/'*** ALGEB3: YOU HAVE FLAGGED READ OF AN OLD LEVELS' X,' FILE, BUT NONE CAN BE FOUND...'/12X,'SWITCH-OFF FLAG AND' X,' RE-RUN (FOR ENERGIES ONLY) TO GENERATE ONE (EFFEICIENTLY)') cw 1123 FORMAT(/'*** IN LARGE CASES IT IS MORE EFFICIENT TO READ A' cw X,' "LEVELS" FILE GENERATED BY A PRIOR (ENERGIES ONLY) RUN') 1201 FORMAT(59X,I9,2I6,I9,I6,3(I5,F9.4)) 1202 FORMAT(59X,I9,2I6,I9,I6,3(I5,F9.4)/(95X,3(I5,F9.4))) 1203 FORMAT(' STORAGE MAYBE EXCEEDED IN SR.RES2: INCREASE MXRSS OR' X,' MAXMI') 1204 FORMAT(' STORAGE EXCEEDED IN SR.RES1: INCREASE MXS2C OR' X,' MXS2I') 1210 FORMAT(' STORAGE EXCEEDED IN SR.SPOR2: AUGMENT MXSOC OR' X,' MXSOI') 1211 FORMAT(' STORAGE EXCEEDED IN SR.SPOR1: INCREASE MXS1C OR' X,' MXS1I') 1377 FORMAT(//' ****DIMENSION FAILURE IN SR.ALGEB3 ***'//) 2001 FORMAT(/' SPIN-ORBIT PARAMETER REFERENCE LIST'/' I(Z)',6X, X 'ZETA( A B)= SPIN-ORBIT PARAMETERS') 2002 FORMAT(I6,12X,2I5) 2011 FORMAT(/' REFERENCE LIST OF MAGNETIC INTEGRALS N AND V' X /' INDEX',5X,'N( A B C D 2LBD+200)',7X, X 'INDEX',2X,'V( A B C D 2LBD+100)') 2444 FORMAT(51X,I6,4X,4I5,I7) 3033 FORMAT(//' ALGEBRA OF THE SPIN-ORBIT INTERACTION ',4X,'KUTSO =', XI3,9X,' ALGEBRA OF THE SPIN-SPIN (C), MUTUAL SPIN-ORBIT (A)' /67X X,'AND THE SPIN-OTHER-ORBIT (B) INTERACTIONS',10X,'KUTSS =',I3,A1) 3042 FORMAT(// ' CONFIGURATIONS FOR WHICH TWO-BODY FINE-STRUCTURE INT XERACTIONS ARE EVALUATED; IN ADDITION TO THOSE SPECIFIED BELOW BY K XUTSS' /) 3043 FORMAT(I4) 3050 FORMAT(4X,'MXADJ MAXLV MAXLV MXSOC MXSOI',27X,'MXADJ MAXLV MAXL XV MXRSS MAXMI'/I9,2I6,I9,I6,2X,'STORAGE RESTRICTIONS',1X,I9,2I6 X,I9,I6/7X,'NP',4X,'LV',3X,'LVP',7X,'CN',3X,'IND',2X,'I(Z)',6X, X 'C(A,B)',12X,'NP',4X,'LV',3X,'LVP',7X,'CN',3X,'IND', X 3(3X,'I(Y) X(A-D)')) 3054 FORMAT('SR.ALGEB3: ALLOCATION INCREASES NUMBER OF MATRIX ' !F95 X,' ELEMENTS IADJ =',I10,' .GT. MXADJ=',I10) !F95 CF77 3055 FORMAT(' STORAGE EXCEEDED IN SR.ALGEB3: NUMBER OF MATRIX '!F77 CF77 X,' ELEMENTS IADJ =',I10,' .GT. MXADJ=',I10) !F77 3056 FORMAT(/' *** PRINTOUT OF COEFFICIENTS C, D AND E SUPPRESSED BY' X,' MPRINT .LE. 0') C END C C ******************* C C SUBROUTINE ALGEB4(DC,IDC,MAM,NAM,QLML,QBML,QBMS,JYI,JYF,MAXEL) CC ********** DUMMY ROUTINE ********** CC C IMPLICIT REAL*8 (A-H,O-P,R-Z) C IMPLICIT INTEGER (Q) CC C INCLUDE './PARAM' CC C REAL*8 DC C DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*),JYI(*),JYF(*) C X ,QLML(MAXEL,*),QBML(*),QBMS(*) C C COMMON /NXRNL/NL000,NL C C NL=NL000 C C RETURN C END C C ******************* C SUBROUTINE ALGEB4(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL) C C----------------------------------------------------------------------- C C SR.ALGEB4 WORKS OUT RADIATIVE MK ALGEBRA, INCLUDING BP CORRECTIONS C TO M1 AND E1VEL. C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_COEFF, ONLY: DRKP,IRLP,NRKP !,NADP !F95 USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 USE COMMON_NRBMKP, ONLY: BNRBMKP,NMD1,NMD2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) CF77 PARAMETER (MXD22=MAXSL/2) !NO OF SLP GROUPS IN JP GROUP !F77 CF77 PARAMETER (IXD22=MXD22) !F77 CF77 PARAMETER (MXD23=10*MAXDK) !TEMP VECTOR TO SHUFFLE COEFFS!F77 CF77 PARAMETER (IXD23=MXD23) !F77 PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) C INTEGER*8 NTMP,MDCF8,MDCFT8 CF77 INTEGER*8 NRKP,MSS !F77 C LOGICAL LPT,LX1,LX2,DEBUG1,MSKIP,OSKIP,E1CASE,M1BODY,BODD,BEVEN X ,EQUGRP,BFAST,B1B,B2B,B1BODY,B2BODY,BQCUT,BFOT x ,btime,btimex X ,BLOCAL !F95 C CHARACTER(LEN=1) CQLIT,MP CHARACTER(LEN=4) CODE C REAL*8 DC DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*),JYI(*),JYF(*) X ,QLMC(MAXEL,*),QBML(*),QBMS(*) DIMENSION CQLIT(10),DFS(MXDFS),ITMP(MXEL0),kstart(maxcf,2) CF77 X ,MMD1(2,MXD22,MAXDK),MMD2(2,MXD22,MAXDK) !F77 CF77 X ,TMP(MXD23),NTMP(MXD23) !F77 C ALLOCATABLE MMD1(:,:,:),MMD2(:,:,:),TMP(:),NTMP(:) !F95 C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,NLEV,ND1,NDP1,ND2,NDP2 COMMON /CMKALG1/DVC12,VC1(6*MXVAR),MJS1,MJL1,MJS2,MJL2 X,MJJL,MJJR,QLIT(10),LX1,LX2,MSKIP,OSKIP,M1BODY,NC,ND,ICLR COMMON /CMKALG2/DVC,MJ1,MJ2,MLAM,E1CASE CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JJ(MAXLV),NGR(MAXLV) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRLP/IRKP,IRKP0 COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL000,NL COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT) X ,QCP(MAXCF),QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM COMMON /NRBBBB/B1B(MXD19),B2B(MXD19) COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) CF77 COMMON /NRBMKP/NMD1(2,MAXJG,MAXLV),NMD2(2,MAXJG,MAXLV) !F77 COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 common /nrbtim/iw,iwp,btime,btimex C DATA MG/-2/,DEBUG1/.FALSE./ X ,CQLIT/'0','1','2','3','4','F','S','Q','W','X'/ C C BLOCAL=.FALSE. !F95 C NL=NL000-1 C IF(NJO.LE.0)GO TO 97 C BECAUSE ALL I.C. CALCULATIONS HAVE BEEN SWITCHED OFF. C IF(MPRINT.EQ.MG)GO TO 97 C BECAUSE ON INPUT RADIATIVE CALCULATIONS HAVE BEEN SUPPRESSED. C IF(MPRINT.EQ.-1.OR.MPRINT.EQ.-4)GO TO 97 C BECAUSE ELECTRIC DIPOLE ONLY. C MMAX0=MIN(MPOLE-2,MPOLM) MMIN0=MAX(MPOL0-2,2) IF(MMIN0.GT.MMAX0)GO TO 97 C BECAUSE NO VALID MAGNETIC MULTIPOLE. C IF(MBP1MX.LT.2.AND.MMAX0.LT.4.AND.MEKVMX.LT.2)GO TO 97 C BECAUSE ONLY ORDINARY M1 (USE TRIVIAL DIAGFS CODING) C IF(MXAJS.NE.MXADJ)THEN WRITE(6,401) WRITE(0,*) X 'ERROR: SET MXAJS=MXADJ FOR MAGNETIC MULTIPOLE RADIATION' NF=-1 GO TO 999 ENDIF C IF(NLEV.EQ.0)NLEV=QBML(1) !RESTART C !F95 C EX-COMMON/NRBMKP/ !F95 ALLOCATE (NMD1(2,NJO,NLEV),NMD2(2,NJO,NLEV),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: ALLOCATION FAILS FOR NMD1,NMD2' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 BNRBMKP=.TRUE. !F95 C !F95 C EX-COMMON/COEFFS/ !F95 ALLOCATE (DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: ALLOCATION FAILS FOR DRKPS,QRLPS,NRKPS' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 C EX-COMMON/DMQSSS/ !F95 ALLOCATE (DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: ALLOCATION FAILS FOR DSSS,MSSS,QSSS' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS1/ !F95 ALLOCATE (NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F95 X ,IORIG1(MXS1I),JORIG1(MXS1I),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: ALLOCATION FAILS FOR NADS1,NSTJ1, ETC' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS2/ !F95 ALLOCATE (NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F95 X ,IORIG2(MXS2I),JORIG2(MXS2I),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: ALLOCATION FAILS FOR NADS2,NSTJ2, ETC' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C !F95 IAXDK=0 !F95 IXD22=0 !F95 DO N=1,NJO !F95 IAXDK=MAX(IAXDK,NT(N)) !F95 IXD22=MAX(IXD22,NGSLJ(N)) !F95 ENDDO !F95 IXD23=10*IAXDK+1000 !F95 C !F95 C LOCAL (TBD: USE ACTUAL DIMENSIONS FOR MXD23) !F95 ALLOCATE (MMD1(2,IXD22,IAXDK),MMD2(2,IXD22,IAXDK) !F95 X ,TMP(IXD23),NTMP(IXD23),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: ALLOCATION FAILS FOR MMDX,TMP' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 BLOCAL=.TRUE. !F95 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C C CHECK KCUT (AND VIA OLD QCUT) DO I=1,10 QLIT(I)=ICHAR(CQLIT(I)) ENDDO C LPT=MPRINT.GT.0 C KUT=KCUT DO I=1,7 IF(QLIT(I).EQ.QCUT)THEN IF(I.EQ.6)THEN KUT=KM GO TO 20 ENDIF IF(I.LT.6)THEN KUT=I-1 GO TO 20 ENDIF KUT=KUTSS ENDIF ENDDO C IF(KUT.LT.0)GO TO 98 !NONE, FLAG AND RETURN IF(KUT.EQ.0)KUT=KM IF(KUTM1.NE.0)KUT=IABS(KUTM1) C 20 IF(IABS(MBP2MX).GT.0)THEN !THERE EXISTS 1/2-BODY BP ALG WRITE(6,600)KUT,CHAR(QCUT) ELSE !JUST 1-BODY NON-BP WRITE(6,601) ENDIF C C FLAG EXISTENCE, OR NOT, OF ONE- AND TWO-BODY INTERACTIONS BETWEEN C CONFIGURATION PAIRS C IFOTMX=0 IF(BFOT)IFOTMX=1 C KK=0 DO KF=1,KM !BEGIN KF LOOP II=IEQ(QCG(NF,KF)) KCF=0 IF(QN(II).GE.90)KCF=1 !CONTINUUM C DO KG=1,KF !BEGIN KG LOOP KK=KK+1 C B1BODY=.FALSE. B2BODY=.FALSE. C II=IEQ(QCG(NF,KG)) KCG=0 IF(QN(II).GE.90)KCG=1 IF(KCF+KCG.GT.IFOTMX)GO TO 173 !DOES NOT CONTRIB C E1CASE=QCP(KF).NE.QCP(KG) MSKIP=KG.GT.KUT.AND.KF.GT.KUT OSKIP=KF.GT.KUT.OR.KG.GT.KUT IF(E1CASE)OSKIP=MSKIP BQCUT=QCUT.NE.QLIT(8).AND.QCUT.NE.QLIT(9) X .AND.KUTM1.GE.0 !SO MSKIP=OSKIP C C FIND NUMBER MK/2 OF ELECTRON PAIRS IN WHICH KF AND KG DIFFER C AND THEN SEE IF THIS CF PAIR CONTRIBUTES C DO I=1,NF ITMP(I)=QCG(I,KG) ENDDO MK=0 DO I=1,NF ICG=IEQ(QCG(I,KF)) DO L=1,NF IF(IEQ(ITMP(L)).EQ.ICG)THEN ITMP(L)=0 GO TO 151 ENDIF ENDDO MK=MK+2 IF(MK.EQ.2)LD1=QCG(I,KF) 151 ENDDO C IF(MK.GT.4)GO TO 173 !THREE PAIRS OR MORE IF(MK.EQ.4.AND.(MBP2MX.LE.0.OR.E1CASE))GO TO 173 !NO TWO-BODY C C SEE IF WE NEED TWO-BODY C IF(.NOT.OSKIP.AND.NF.GT.1.AND..NOT.E1CASE)B2BODY=.TRUE. !AS M1 IF(.NOT.B2BODY.AND.MK.EQ.4)GO TO 173 C C SEE IF ONE-BODY EXISTS C IF(MK.EQ.2)THEN DO L=1,NF IF(ITMP(L).NE.0)THEN LD2=QCG(L,KG) GO TO 54 ENDIF ENDDO 54 LDD=IABS(QL(LD1)-QL(LD2)) IF(LDD.GT.MPOLE)LDD=-1 ELSEIF(MK.EQ.4)THEN LDD=-1 ELSE LDD=1 ENDIF B1BODY=LDD.GE.0 C C FLAG WHETHER KF-KG NEEDED C 173 B1B(KK)=B1BODY B2B(KK)=B2BODY c c write(0,*)kf,kg,b1body,b2body C ENDDO !END LOOP KG C ENDDO !END LOOP KF C C C----------------------------------------------------------------------- C C START CALCULATION OF THE ALGEBRA FOR MAGNETIC MULTIPOLES C VIZ. 1-BODY ALL MULTIPOLES AND 2-BODY BP CORRECTIONS TO DIPOLE C C----------------------------------------------------------------------- C C NCI=QBML(1) !TOTAL NUMBER OF LEVELS C NHOLD=QBMS(1) C !INITIALIZE POINTERS C IRKP=NADP(NHOLD) !=IRKP0+1 c c if(irlp.ne.irlp0) !case mstart=4 as irlp0 c xwrite(0,*)'notify nrb',irlp0,irlp !not read from restart c COLD IRLP0=IRLP !was irlp=irlp0, only wrong if irlp0.ne.irlp,ibid c cnew irlp=-irlp !flag end of structure integrals for mkalg2 c NL=NL000 ja=2 jap=2 C DFS(1)=1 DFS(2)=1 DO J=3,MXDFS,2 DFS(J)=-DFS(J-2) DFS(J+1)=(J-1)*DFS(J-1)/32 ENDDO C NC=(NXLL+2)*3 !m1+bp only DO J=1,NC LL=(J/2)*2 LM=LL-2 IF(LL.NE.J) LM=LL+2 VC1(J)=VCC(LL,2,LM,0,0,0,DFS,MXDFS) ENDDO C MXIRKS=0 MXIRLS=0 MXIRSS=0 MXNLS=0 C DO J=1,NLEV !INITIALIZE (FOR SAFETY) DO K=1,NJO NMD1(1,K,J)=0 NMD1(2,K,J)=-1 NMD2(1,K,J)=0 NMD2(2,K,J)=-1 ENDDO ENDDO C MDCBUF4=0 IF(KUTDSK.LT.KM)THEN IEND=MTGD !FOR DISKDC MTGD1=MTGD+1 CALL DISKDC(IUD,DC,IDC,1,0,0,0,0,0) !REPOINT C IF(KUTDSK.LT.KFBUFF)THEN DO K=1,NSL0 MTGD1=MTGD+1 !RESTORE DO KF=KUTDSK+1,KFBUFF NGSYM=KGSL(KF,K) !POS WITHIN CF IF(NGSYM.GT.0)THEN c do kg=1,km k1=max(kf,kg) k2=min(kf,kg) kk=(k1*(k1-1))/2+k2 if(b1b(kk).or.b2b(kk))go to 81 !need this kf enddo go to 82 c 81 ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,0,0) C MTGD1=IFIN+1 ENDIF 82 ENDDO IFIN=MTGD1-1 MDCBUF4=MAX(MDCBUF4,IFIN) ENDDO MDCBUF4=MDCBUF4+MDCBUF4-mtgd IF(MDCBUF4.GT.MDCBUF)THEN WRITE(6,141)MDCBUF4 ENDIF c write(6,*)'ALGEB4: ',mdcbuf4 c write(76,*)'ALGEB4' MDCBUF4=0 ELSE MDCBUF4=MDCBUF DO I=1,2 DO K=KFBUFF+1,KM KSTART(K,I)=0 ENDDO ENDDO ENDIF ENDIF C if(btime)then time1=dzero time2=dzero endif C C START LOOP STRCUTURE C NCJ=0 DO 1110 K=1,NJO !BEGIN UPPER LOOP OVER JP GROUPS MJJL=JJ(NCJ+1) C NCJ0=0 DO 1115 NGJ1=1,NGSLJ(K) !BEGIN UPPER LOOP OVER SLP GROUPS C NC=NSLJ(NGJ1,K) MJL1=QLI(NC) MJS1=QSI(NC) N0=NSL(NC) C IF(KUTDSK.LT.KFBUFF)THEN MTGD1=MTGD+1 !RESTORE DO KF=KUTDSK+1,KFBUFF !LOAD INITIAL GROUP VCC KSTART(KF,1)=0 NGSYM=KGSL(KF,NC) !POS WITHIN CF IF(NGSYM.GT.0)THEN c do kg=1,km k1=max(kf,kg) k2=min(kf,kg) kk=(k1*(k1-1))/2+k2 if(b1b(kk).or.b2b(kk))go to 71 !need this kf enddo kstart(kf,1)=mtgd1!dummy, else alternate kf read triggered go to 72 c 71 ISTRT=MTGD1 KSTART(KF,1)=ISTRT C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KF,NGSYM,1,0) C MTGD1=IFIN+1 IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF 72 ENDDO MHOLD=MTGD1 IFIN=MTGD1-1 ENDIF C NCJP=0 DO KP=1,K !BEGIN LOWER LOOP OVER JP GROUPS C IF(NMETGJ(K)+NMETGJ(KP).GT.1)GO TO 2500 IF(K.EQ.KP.AND.NT(K).EQ.1)GO TO 2500 C MJJR=JJ(NCJP+1) ND=NSLJ(1,KP) E1CASE=QPI(ND).NE.QPI(NC) MMIN=MAX(MMIN0,ABS(MJJR-MJJL)) MMAX=MIN(MMAX0,MJJR+MJJL) IF(E1CASE)E1CASE=MMIN.EQ.2.AND.MEKVMX.GT.0 IF(.NOT.E1CASE)THEN IF(MOD(QPI(ND)+QPI(NC)+MMIN,4).EQ.0)MMIN=MMIN+2 IF(MOD(QPI(ND)+QPI(NC)+MMAX,4).EQ.0)MMAX=MMAX-2 BODD=(1-MOD(MMIN,4)).GT.0.OR.(MMAX-MMIN).GT.0 BEVEN=(1-MOD(MMIN,4)).LT.0.OR.(MMAX-MMIN).GT.0 ELSE BODD=.TRUE. BEVEN=(MMAX-MMIN).GT.0 ENDIF IF(MMIN.GT.MMAX)GO TO 2500 C NCJP0=0 NGJP1X=NGSLJ(KP) IF(NGJP1X.GT.IXD22)GO TO 91 IF(K.EQ.KP)NGJP1X=NGJ1 DO NGJP1=1,NGJP1X !BEGIN LOWER LOOP OVER SLP GROUPS C ND=NSLJ(NGJP1,KP) MJL2=QLI(ND) MJS2=QSI(ND) N0P=NSL(ND) C EQUGRP=K.EQ.KP.and.nc.eq.nd !nc.eq.nd missing since v18 if(equgrp.and.ngj1.ne.ngjp1)stop 'equgrp.and.ngj1.ne.ngjp1' if(k.eq.kp.and.nc.ne.nd.and.ngj1.eq.ngjp1) x stop '.not.equgrp.and.ngj1.eq.ngjp1' c if(btime)call cpu_time(timei) C IRKPS=0 IRLPS=0 IRSS=0 NLS=0 C NADS1(0)=0 NADS2(0)=0 C KK=0 K2=KM DO KF=1,KM !BEGIN KF LOOP C IFLG=0 IF(KGSL(KF,NC).GT.0)IFLG=1 !CF CONTRIBS TO SL GROUP C IF(EQUGRP)K2=KF C DO KG=1,K2 !BEGIN KG LOOP KK=KK+1 IF(IFLG.EQ.0)GO TO 70 !JUST INDEX C IF(.NOT.EQUGRP)THEN K0=MIN(KF,KG) K1=MAX(KF,KG) KB=(K1*(K1-1))/2+K0 ELSE KB=KK ENDIF C B1BODY=B1B(KB) B2BODY=B2B(KB) IF(.NOT.B1BODY.AND..NOT.B2BODY)GO TO 70 IF(QCP(KG).NE.QPI(ND))GO TO 70 IF(QCP(KF).EQ.QCP(KG).AND..NOT.BEVEN)GO TO 70 IF(QCP(KF).NE.QCP(KG).AND..NOT.BODD)GO TO 70 IF(.NOT.B1BODY.AND.MBP2MX.LT.MMIN)GO TO 70 !NO 2-BODY HERE C IF(KGSL(KG,ND).LE.0)GO TO 70 !CF DOES NOT CONTRIB TO S'L' C MSKIP=KG.GT.KUT.AND.KF.GT.KUT OSKIP=KF.GT.KUT.OR.KG.GT.KUT IF(E1CASE)OSKIP=MSKIP IF(BQCUT)MSKIP=OSKIP IF(B1BODY)THEN MK=2 IF(KF.EQ.KG)MK=0 ELSE MK=4 ENDIF C C NOW DETERMINE INTERACTION BETWEEN KF AND KG FOR THESE CSLJP GROUPS C JL1=JYI(KF) JL2=JYF(KF) JR1=JYI(KG) JR2=JYF(KG) c write(6,*)"$",k,ngj1,kf,kp,ngjp1,kg C IRKPS0=IRKPS+1 IRLPS0=IRLPS IRSS0=IRSS+1 NLS00=NLS C C BEGIN LOOP OVER MAGNETIC MULTIPOLES MLAM/2: C MLAM=MPOL0-2,MPOLE-2,4 AS MPOL E C E1CASE=QPI(ND).NE.QPI(NC).and..not.oskip !RE-INITIALIZE IF(E1CASE)E1CASE=MMIN.EQ.2.AND.MEKVMX.GT.0 C MLAM=MMIN 426 MLAMH=MLAM/2 C IF(DEBUG1)THEN MP='M' IF(E1CASE)MP='E' ENDIF C M1BODY=E1CASE.OR.MLAM.GT.MBP2MX !SO NO 2-BODY BP TO MK c C IF(MBP1MX+MBP2MX.EQ.0.AND.MLAM.EQ.2.AND.IT.NE.ITP.AND..NOT.E1CASE) IF(MLAM.EQ.2)THEN IF(E1CASE)THEN C ????? ELSE IF(MBP1MX+MBP2MX.EQ.0.AND.IT.NE.ITP) X GO TO 417 !ORDINARY M1 IF(MSKIP.AND.KF.NE.KG)GO TO 417 ENDIF ENDIF c write(6,*)ngj1,ngjp1,mjjr,mjjl,nc,nd,mmin,mlam,mmax,e1case C C FIND A NONVANISHING MULTIPOLE MATRIX ELEMENT C ICLR=1 K0=0 MJ1=MJJL 21 MJ2=MJJR 22 MLK=MJ1-MJ2 ML2=-MJ2 C DVC=VCC(MJJL,MJJR,MLAM,MJ1,ML2,MLK,DFS,MXDFS) C IF(DVC.NE.DZERO)THEN IF(MODD.LE.0)GO TO 24 IF(MJ1.LE.1.AND.MJ2.LE.1)GO TO 24 K0=1 ENDIF C MJ2=MJ2-2 IF(MJ2.GE.0)GO TO 22 MJ1=MJ1-2 IF(MJ1.GE.0)GO TO 21 IF(MODD*K0.LE.0)GO TO 417 WRITE(6,800) GO TO 98 C C---- BEGIN TAKE OUT C 24 IRKPS0=IRKPS+1 IRLPS0=IRLPS IRSS0=IRSS+1 NLS00=NLS C MS1=MJS1 C IF(DEBUG)WRITE(6,400)IRKP,ND1,NDP1,MJJL,MJJR 30 ML1=MJ1-MS1 LX1=MS1.NE.-MJS1.AND.ML1.NE.MJL1 IF(ML1.LT.-MJL1)GO TO 40 C JB=1 DO I=JL1,JL2 IF(QBML(I).EQ.ML1.AND.QBMS(I).EQ.MS1)THEN JB=JB+1 MAM(JB)=I ENDIF ENDDO C IF(JB.LT.JA)GO TO 40 C DVCL1=VCC(MJL1,MJS1,MJJL,ML1,MS1,MJ1,DFS,MXDFS) C MS2=MJS2 32 ML2=MJ2-MS2 LX2=MS2.NE.-MJS2.AND.ML2.NE.MJL2 IF(ML2.LT.-MJL2)GO TO 39 IF(IABS(MS2-MS1).GT.2)GO TO 39 !42 C RDD IF(IABS(ML2-ML1).GT.4)GO TO 39 C IF(MK.EQ.0.AND.ML2.EQ.ML1.AND.MS2.EQ.MS1)THEN JBP=JB DO I=JAP,JBP NAM(I)=MAM(I) ENDDO ELSE JBP=1 DO I=JR1,JR2 IF(QBML(I).EQ.ML2.AND.QBMS(I).EQ.MS2)THEN JBP=JBP+1 NAM(JBP)=I ENDIF ENDDO IF(JBP.LT.JAP)GO TO 39 ENDIF C DD2=VCC(MJL2,MJS2,MJJR,ML2,MS2,MJ2,DFS,MXDFS) C DVC12=DVCL1*DD2 IF(DVC12.EQ.DZERO)GO TO 39 C IF(DEBUG1)WRITE(6,701)MK,MS1,ML1,MS2,ML2,IRKP,DVC,DVCL1,DD2 X ,JAP,JBP,MP,MLAMH C C DETERMINE SLATER STATE INTERACTION C 42 CALL MKALG1(QLMC,MAXEL,DFS,MAM,NAM) C MXIRKS=MAX(MXIRKS,IRKPS) MXIRLS=MAX(MXIRLS,IRLPS) MXIRSS=MAX(MXIRSS,IRSS) MXNLS=MAX(MXNLS,NLS) C IF(NF.EQ.0)GO TO 99 IF(NF.LT.0)GO TO 999 C C IF .T. COMPUTE FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=MJ C 39 MS2=MS2-2 IF(LX2)GO TO 32 C 40 MS1=MS1-2 IF(LX1)GO TO 30 C ICLR=-ICLR IF(ICLR.NE.0)GO TO 42 C C---- END TAKE OUT C 417 MLAM=MLAM+4 IF(E1CASE)THEN MLAM=MLAM-2 E1CASE=.FALSE. ENDIF IF(MLAM.LE.MMAX)GO TO 426 C 70 NADS1(KK)=IRKPS NADS2(KK)=IRSS c write(6,*)kk,irkps,irss C ENDDO !END LOOP KG C ENDDO !END LOOP KF C if(btime)then call cpu_time(timef) time1=time1+timef-timei endif C C NOW DETERMINE THE INTERACTION BETWEEN JP LEVELS OF THE CLSP GROUPS C E1CASE=QPI(ND).NE.QPI(NC) !.and..not.oskip !RE-INITIALIZE M1BODY=E1CASE.OR.MMIN.GT.MBP2MX !SO NO 2-BODY BP TO MK C IF(KUTDSK.LT.KFBUFF)THEN MTGD1=MHOLD !RESTORE DO KG=KUTDSK+1,KFBUFF !LOAD FINAL GROUP VCC IF(NC.EQ.ND)THEN KSTART(KG,2)=KSTART(KG,1) ELSE KSTART(KG,2)=0 LGSYM=KGSL(KG,ND) !POS WITHIN CF IF(LGSYM.GT.0)THEN c k1=1 if(equgrp)k1=kg do kf=k1,km if(equgrp)then kk=(kf*(kf-1))/2 + kg else kk=km*(kf-1)+kg endif b1body=nads1(kk).gt.nads1(kk-1) b2body=nads2(kk).gt.nads2(kk-1) if(b1body.or.b2body)go to 73 !need this kg enddo go to 74 c 73 ISTRT=MTGD1 KSTART(KG,2)=ISTRT C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C MTGD1=IFIN+1 IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ENDIF 74 ENDDO IFIN=MTGD1-1 MDCBUF4=MAX(MDCBUF4,IFIN) ENDIF c if(btime)call cpu_time(timei) C istrt0=0 KF0=0 DO NJ11=1,N0 !BEGIN UPPER LOOP OVER LEVELS C NJ1=NCJ0+NJ11 ND1=NJ1+NCJ MMD2(1,NGJP1,NJ11)=IRS+1 MMD1(1,NGJP1,NJ11)=IRKP+1 C IT=NRR(ND1) KF=NFK(IT) C IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN ISTRT=0 ISTRT=KSTART(KF,1) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF NGSYM=KGSL(KF,NC) !POS WITHIN CF ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IEND,KF,NGSYM,1,0) C IF(IEND.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT0=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KF0=KF ENDIF C II=NFI(IT) IF(BFAST)THEN ND2=JTGD(II)+ISTRT0 !relative start flagged ELSE do j=jyi(kf),jyf(kf) mam(j)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt0 k2=k2+istrt0 do k12=k1,k2 j=idc(k12) mam(j)=k12 enddo ENDIF C NJP11X=N0P IF(K.EQ.KP.AND.NGJP1.EQ.NGJ1)NJP11X=NJ11 C istrt=0 KG0=0 DO NJP11=1,NJP11X !BEGIN LOWER LOOP OVER LEVELS C NJP1=NCJP0+NJP11 NDP1=NJP1+NCJP c write(6,*)'nd1=',nd1,'ndp1=',ndp1 C ITP=NRR(NDP1) KG=NFK(ITP) c c MSKIP=KF.GT.KUT.OR.KG.GT.KUT !.and.mlam.eq.2 !mlam not set c IF(ITP.NE.IT.AND.MSKIP)GO TO 25 !Use test before mkalg1 C C CALCULATE THE ALGEBRAIC CONTRIBUTION TO THE MATRIX ELEMENT. C IF(EQUGRP)THEN !KG.LE.KF HERE KK=(KF*(KF-1))/2 + KG c if(kf.lt.kg)stop 'algeb4: kf.lt.kg' ELSE KK=KM*(KF-1)+KG ENDIF C B1BODY=NADS1(KK).GT.NADS1(KK-1) B2BODY=NADS2(KK).GT.NADS2(KK-1) C IF(B1BODY.OR.B2BODY)THEN C IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN ISTRT=KSTART(KG,2) IF(ISTRT.EQ.0)THEN !BUFFERED BY CF LGSYM=KGSL(KG,ND) !POS WITHIN CF ISTRT=IEND+1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C IF(IFIN.LT.0)THEN !FAILURE TO READ REQUIRED DATA NF=-1 GO TO 999 ENDIF ENDIF ISTRT=ISTRT-MTGD-1 !I.E. ORIGINAL MTGD1 KG0=KG ENDIF C LL=NFI(ITP) IF(BFAST)THEN NDP2=JTGD(LL)+ISTRT !relative start flagged ELSE do j=jyi(kg),jyf(kg) nam(j)=0 enddo k2=jtgd(ll) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ll-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt k2=k2+istrt do k12=k1,k2 j=idc(k12) nam(j)=k12 enddo ENDIF C IRKP0=IRKP+1 IRS0=IRS+1 C CALL MKALG2(DC,mam,nam,KK) C IF(NF.EQ.0)GO TO 99 IF(NF.LT.0)GO TO 999 C ENDIF C ENDDO !25 !END LOWER LOOP OVER LEVELS C MMD2(2,NGJP1,NJ11)=IRS MMD1(2,NGJP1,NJ11)=IRKP C c c write(6,*)k,kp,ngjp1,nj11,nd1,mmd2(1,ngjp1,nj11) c x,mmd2(2,ngjp1,nj11) c do m=mmd1(1,ngjp1,nj11),mmd1(2,ngjp1,nj11) c n1=nrkp(m)/mxsoi c n2=nrkp(m)-n1*mxsoi c write(6,*)m,n1+1,(qrlp(n3,n2),n3=1,4) c enddo C ENDDO !END UPPER LOOP OVER LEVELS c if(btime)then call cpu_time(timef) time2=time2+timef-timei endif C NCJP0=NCJP0+N0P ENDDO !END LOWER LOOP OVER SLP GROUPS C C C SHUFFLE COEFFS SO ALL LOWER LEVELS (WITHIN JP) ARE SEQUENTIAL FOR A C GIVEN UPPER LEVEL. (CURRENTLY, ONLY TRUE FOR LOWER LEVELS WITHIN SLP.) C c write(6,*)'begin shuffle' c DO NJ11=1,N0 !BEGIN LOOP OVER UPPER LEVELS OF SLP GROUP C NJ1=NCJ0+NJ11 ND1=NJ1+NCJ IF(NJ11.EQ.N0)GO TO 114 C DO NGJP1=2,NGJP1X !BEGIN LOOP OVER LOWER SLP GROUPS C C 1-BODY C M1=MMD1(1,NGJP1,NJ11) M2=MMD1(2,NGJP1,NJ11) MX=M2-M1+1 IF(MX.GT.IXD23)GO TO 96 C L1=MMD1(2,NGJP1-1,NJ11)+1 L2=L1+MX-1 IF(MX.EQ.0)GO TO 112 C N1=MMD1(1,1,NJ11+1) N2=MMD1(2,NGJP1-1,N0) c c write(6,*)'shuffle',nj11,ngjp1-1,m1,m2,n1,n2 C IF(N1.LE.N2)THEN MM=0 DO M=M1,M2 MM=MM+1 NTMP(MM)=NRKP(M) TMP(MM)=DRKP(M) ENDDO DO N=N2,N1,-1 NN=MX+N NRKP(NN)=NRKP(N) DRKP(NN)=DRKP(N) ENDDO MM=0 DO L=L1,L2 MM=MM+1 NRKP(L)=NTMP(MM) DRKP(L)=TMP(MM) ENDDO ENDIF C DO N=NJ11+1,N0 DO I=1,NGJP1-1 MMD1(1,I,N)=MMD1(1,I,N)+MX MMD1(2,I,N)=MMD1(2,I,N)+MX ENDDO ENDDO C 112 MMD1(1,NGJP1,NJ11)=L1 MMD1(2,NGJP1,NJ11)=L2 C C NOW 2-BODY C IF(.NOT.M1BODY)THEN M1=MMD2(1,NGJP1,NJ11) M2=MMD2(2,NGJP1,NJ11) MX=M2-M1+1 IF(MX.GT.IXD23)GO TO 96 C L1=MMD2(2,NGJP1-1,NJ11)+1 L2=L1+MX-1 IF(MX.EQ.0)GO TO 113 C N1=MMD2(1,1,NJ11+1) N2=MMD2(2,NGJP1-1,N0) C IF(N1.LE.N2)THEN MM=0 DO M=M1,M2 MM=MM+1 NTMP(MM)=MSS(M) TMP(MM)=DSS(M) ENDDO DO N=N2,N1,-1 NN=MX+N MSS(NN)=MSS(N) DSS(NN)=DSS(N) ENDDO MM=0 DO L=L1,L2 MM=MM+1 MSS(L)=NTMP(MM) DSS(L)=TMP(MM) ENDDO ENDIF C DO N=NJ11+1,N0 DO I=1,NGJP1-1 MMD2(1,I,N)=MMD2(1,I,N)+MX MMD2(2,I,N)=MMD2(2,I,N)+MX ENDDO ENDDO 113 MMD2(1,NGJP1,NJ11)=L1 MMD2(2,NGJP1,NJ11)=L2 ENDIF C ENDDO !END LOOP OVER LOWER SLP GROUPS C C NOW SET GLOBAL INDEX FOR DIAGFS C 114 DO N=1,NGJP1X N1=MMD1(1,N,NJ11) N2=MMD1(2,N,NJ11) IF(N1.LE.N2)GO TO 116 ENDDO M2=N2 GO TO 117 116 DO M=NGJP1X,N,-1 M1=MMD1(1,M,NJ11) M2=MMD1(2,M,NJ11) IF(M1.LE.M2)GO TO 117 ENDDO 117 NMD1(1,KP,ND1)=N1 NMD1(2,KP,ND1)=M2 c c do n=1,ngjp1x c write(6,*)mmd1(1,n,nj11),mmd1(2,n,nj11) c enddo c write(6,*)"*",n1,m2 c IF(.NOT.M1BODY)THEN DO N=1,NGJP1X N1=MMD2(1,N,NJ11) N2=MMD2(2,N,NJ11) IF(N1.LE.N2)GO TO 118 ENDDO M2=N2 GO TO 119 118 DO M=NGJP1X,N,-1 M1=MMD2(1,M,NJ11) M2=MMD2(2,M,NJ11) IF(M1.LE.M2)GO TO 119 ENDDO 119 NMD2(1,KP,ND1)=N1 NMD2(2,KP,ND1)=M2 c write(6,*)"**",n1,m2 ENDIF c c write(6,*)k,kp,ngjp1,nj11,nd1,nmd2(1,kp,nd1),nmd2(2,kp,nd1) c do m=nmd1(1,kp,nd1),nmd1(2,kp,nd1) c n1=nrkp(m)/mxsoi c n2=nrkp(m)-n1*mxsoi c write(6,3377)m,n1+1,(qrlp(n3,n2),n3=1,4),drkp(m) c 3377 format(2i3,4i2,f10.5) c enddo c ENDDO !END LOOP OVER UPPER LEVELS OF SLP GROUP C c write(6,*)'end shuffle' C 2500 NCJP=NCJP+NT(KP) ENDDO !END LOWER LOOP OVER JP GROUPS C NCJ0=NCJ0+N0 1115 CONTINUE !END UPPER LOOP OVER SLP GROUPS C NCJ=NCJ+NT(K) 1110 CONTINUE !END UPPER LOOP OVER JP GROUPS C C c IRLP0=IRLP !not used further IF(.NOT.LPT)WRITE(6,704)IRKP,ND1,NDP1,MG,MG,IRLP,ND1,NDP1,IRS,NL IF(LPT.AND.NL.GT.NL000)WRITE(6,300) X (L,(QSS(I,L),I=1,5),L=NL000+1,NL) WRITE(6,122)MXS1C,MXS1I,MXIRKS,MXIRLS IF(IRSS.GE.IRSS0)WRITE(6,123)MXS2C,MXS2I,MXIRSS,MXNLS WRITE(6,1190)MDCBUF4,MAXDC c if(btime)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for algeb4:' !par cpar write(iwp,*)' mkalg1 time=',nint(time1),'sec' !par cpar write(iwp,*)' mkalg2 time=',nint(time2),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'mkalg1 time=',nint(time1),'sec' write(iw,*)'mkalg2 time=',nint(time2),'sec' c call flush(iw) cpar endif !par endif C 999 CONTINUE c irlp=iabs(irlp) !case no mk, remove flag from structure integrals C !F95 C EX-COMMON /NSTS2/ !F95 IF(ALLOCATED(NADS2))THEN !F95 DEALLOCATE (NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: DE-ALLOCATION FAILS FOR NADS2,NSTJ2...'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS1/ !F95 IF(ALLOCATED(NADS1))THEN !F95 DEALLOCATE (NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: DE-ALLOCATION FAILS FOR NADS1,NSTJ1...'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/DMQSSS/ !F95 IF(ALLOCATED(DSSS))THEN !F95 DEALLOCATE (DSSS,MSSS,QSSS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: DE-ALLOCATION FAILS FOR DSSS,MSSS,QSSS'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/COEFFS/ !F95 IF(ALLOCATED(DRKPS))THEN !F95 DEALLOCATE (DRKPS,QRLPS,NRKPS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: DE-ALLOCATION FAILS FOR DRKPS,QRLPS..'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BLOCAL)THEN !F95 DEALLOCATE (MMD1,MMD2,TMP,NTMP,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGEB4: DE-ALLOCATION FAILS FOR MMDX,TMP' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 RETURN C C E R R O R M E S S A G E S C 91 WRITE(6,991)MAXSL,NGJP1X*2 GO TO 99 96 WRITE(6,996)IXD23,MX C 99 WRITE(6,990) WRITE(6,704)IRKP,ND1,NDP1,MG,MG,IRLP,ND1,NDP1,IRS,NL C WRITE(0,*)'***SR.ALGEB4: STORAGE EXCEEDED ***' NF=-1 C 97 CONTINUE C !F95 C EX-COMMON/NRBMKP/ !F95 ALLOCATE (NMD1(1,1,1),NMD2(1,1,1),STAT=IERR) !F95 BNRBMKP=.TRUE. !F95 C 98 NMD2(1,1,1)=-1 NMD1(1,1,1)=-1 C GO TO 999 C 122 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS1C,MXS1I) ',I8,I6, X10X,'USED: ',I8,I6) 123 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS2C,MXS2I) ',I8,I6, X10X,'USED: ',I8,I6) 141 FORMAT(/'*** SR.ALGEB4: MAY NEED TO INCREASE MAXDC TO AT LEAST: ', XI9,' FOR',' M_K-BUFFER, WILL PLOUGH ON REGARDLESS...') 990 FORMAT(' ***SR.ALGEB4: STORAGE EXCEEDED - INCREASE DIMENSION', X' INDICATED OR REDUCE/SWITCH-OFF MK OR BP RADIATIVE CORRECTIONS.') 991 FORMAT(/' SR.ALGEB4: INCREASE MAXSL FROM',I5,' TO',I5) 996 FORMAT(/' SR.ALGEB4: INCREASE MXD23 FROM',I6,' TO',I6) 300 FORMAT(/' REFERENCE TABLE FOR RADIATIVE MAGNETIC TWO-BODY TERMS'/ X (I14,4I3,I5)) C 400 FORMAT(57X,2I6,I9,I6,3(I7,F9.4)/(84X,3(I7,F9.4))) 401 FORMAT(/'ERROR: SET MXAJS=MXADJ FOR MAGNETIC MULTIPOLE RADIATION') 600 FORMAT(/' CN LV LVP, B D, IND',6X,'1-BODY',4X X,'REL.RAD.ALGEBRA',8X X,'2-BODY FOR M1: CONFIGURATIONS INCLUDED UP TO CF =' X,I3,'(',A1,')') 601 FORMAT(/' MAGNETIC MULTIPOLE ALGEBRA'/ X' CN LV LVP, B D, IND',3X, X' = / C(J,JP,K;MJ,MJP)' X,7X,'2MJ',1X,'2MJP',2X,'K') 701 FORMAT(I9,3I6,I4,I6, F13.5,2F19.5, 6X,2I4, 3X,A1,I1,I4) 704 FORMAT(I9,3I6,I4,I6,31X,2I6,I9,I6) 800 FORMAT(49X,'NOT ENOUGH SLATER STATES STORED; CHANGE MODE TO' X,' -1 IF RADIATIVE DATA REQUIRED') 1190 FORMAT(/87X,I9,'=MTGD, MAXDC=',I9 X ,' BUFFER STORAGE USED') C END C C ******************* C SUBROUTINE ALGX C C----------------------------------------------------------------------- C C SR.ALGX CALCULATES EIE COLLISION ALGEBRA. C C IT CALLS: C SR.ALGXLS C SR.ALGXFS C SR.NUMSYM C SR.SYMLS C SR.SYMLSJ C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam,nproc, !par cpar A comm_barrier,comm_finalize !par C USE COMMON_NRBFL0, ONLY: BNRBFL0,KINTI,KINTF,KEN2,KPTCFM !F95 X ,MPOINT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C C SYNC WITH ALGEB CF77 PARAMETER (MXIDC=MAXDC) !OPT FOR MEMORY !F77 CF77C PARAMETER (MXIDC=1) !OPT FOR SPEED !F77 C C PARAMETER (MXD14=100) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C CF77 PARAMETER (MXXDQ=2*MXST0+MXEST) !F77 CF77 PARAMETER (MXD1=MAXDI/MAXDK, !F77 CF77 X MXD2=MAXDK/MAXDI, !F77 CF77 X MXD3=MXD1+MXD2, !F77 CF77 X MXD4=MAXDI*MXD1/MXD3+MAXDK*MXD2/MXD3+1, !F77 CF77 X MXD0=MXD4*MXD4, !F77 CF77 X MXD5=MXXDQ/MXD0, !F77 CF77 X MXD6=MXD0/MXXDQ, !F77 CF77 X MXD7=MXD5+MXD6, !F77 CF77 X MXD8=MXXDQ*MXD5/MXD7+MXD0*MXD6/MXD7+1, !F77 CF77 X MXQBUF=MXD8) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) C PARAMETER (MG=-2) C INTEGER SJ C INTEGER*8 MDCF8,MDCFT8 C LOGICAL BVC,BDLBD,SKP,BXIST0,BXIST1,BKUTOO,BKUTSS,BPASS,BPRNT0 X ,BTEST,BECOR,BGLS,BGIC,BANAL,BREL,BJUMPR,BMVD,BDISK x ,bcutfs X ,BALLDC,BQXXX,BMNAM !F95 C CHARACTER(LEN=4) MLIT C REAL*8 DC !*4 NOT RECOMMENDED DATA LREC/8/ !SET TO BYTE LENGTH OF DC ARRAY C CF77 DIMENSION DC(0:MAXDC),IDC(MXIDC),MAM(MXST0),NAM(MXST0) !F77 CF77 DIMENSION QBMS(MXST0),QBML(MXST0),QLMC(MXEST) !F77 C ALLOCATABLE :: DC(:),IDC(:),MAM(:),NAM(:) !F95 X ,QBMS(:),QBML(:),QLMC(:) !F95 C DIMENSION JYI(MAXCF),JYF(MAXCF),DFS(MXDFS),DUM(MAXGR)!DUM->DEY TBD C COMMON /BASIC/NF,KX,KG,K1,K2,MGAP(7) COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JJ(MAXLV),NGR(MAXLV) COMMON /MQVC/MODE,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF) c COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL0/IRET0,LORIG,LMIN,MPRNT0,MOD0,MSTRT0,BPASS,MLIT(2) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MA,MB,KSUBCF CF77 COMMON /NRBALQ/QBUFF(MXQBUF) !F77 COMMON /NRBBBB/BXIST0(MAXCF,MAXCF),BXIST1(MAXCF) COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDUM/MXDC0,MXGR0 !NOT USED ANYWHERE, BUT RESTART COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW3/KACT(MAXCF,MAXCF) COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDW9/DSPECJ(MAXLV),INDXJ(MAXLV),JNDXJ(MAXLV),NSPECJ X ,NENERJ COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT COMMON /NRBJP/JPIP(MAXJG),NASTJP,MINJTP,MAXJTP COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLIM/ECNTRB,ITANAL,BANAL(MAXCF) !ALGEBRAIC COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C COMMON /NRBUNI/IUNIT(MXD14),NUNIT C MVC(M,MA)=( (M+2)*M/2+MA )/2+1 C CF77 EQUIVALENCE (QBUFF(1),QBMS(1)),(QBUFF(1+MXST0),QBML(1)) !F77 CF77 X ,(QBUFF(1+2*MXST0),QLMC(1)) !F77 C C----------------------------------------------------------------------- C WRITE(6,5000) C MXMTGD=3*2**26 !MAX REC LEN FOR DC ARRAY MXMTGD=MXMTGD*(8/LREC) C BMNAM=.FALSE. !F95 BQXXX=.FALSE. !F95 BALLDC=.FALSE. !F95 C BPRNT0=JPRINT.NE.-3 BTEST=BPRNT0 !.TRUE. !DETAILED PRINTOUT C C RE-POINT RESTART FILE C REWIND(MR) C C----------------------------------------------------------------------- C RECOVER TARGET HEADER INFO FROM ALGEB1 C----------------------------------------------------------------------- C READ(MR) X MLIT,MXORB,NW,NF,MODE,KCUT,KUTDSK,QQCUT,QCL0,QCS0,MDCBUF !REC1 X,MTGD,MTGDI,NTT,NSS,MAXEL,KM,NPRINT,MA,MB,MAXNV,IRLX,ITANAL X,((NEL(I,J),I=1,MXORB),J=1,KM),((NNL(I,J),I=1,NW),J=1,3) X,((QCG(I,J),I=1,MAXEL),J=1,KM),(QL(I),I=1,MXORB) X,(QN(I),I=1,MXORB),(DUM(I),I=1,MXORB),(MSTAT(I),I=1,KM) X,(IEQ(I),I=0,MXORB),(IGRCF(I),I=1,MXORB),(BANAL(I),I=1,KM) X,(KGCF(I),I=0,KM),((NKSL(I,J),I=1,KGCF(J)-KGCF(J-1)),J=1,KM) C BREL=NPRINT.LT.-4 !INCASE BYPASS ALGEB0 IF(BREL)NPRINT=MOD(NPRINT,5) C BDISK=KUTDSK.LT.KM !USE DISKDC IF(BDISK)THEN IF(MDCBUF.LT.0)THEN MDCBUF=-MDCBUF MXTGDI=1 ELSE MXTGDI=MDCBUF ENDIF MXTGD=MDCBUF ELSE MXTGD=MTGD MXTGDI=MTGDI ENDIF C NMTGD=MTGD/MXMTGD IF(NMTGD.GT.0)THEN WRITE(0,*)'DC ARRAY TOO LARGE...' WRITE(6,1010) GO TO 995 ENDIF C NESS=MAXEL*NSS C !F95 ALLOCATE (DC(0:MXTGD),IDC(MXTGDI),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: ALLOCATION FAILS FOR DC,IDC' !F95 GO TO 999 !F95 ENDIF !F95 BALLDC=.TRUE. !F95 C !F95 ALLOCATE (QBMS(NSS),QBML(NSS),QLMC(NESS),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: ALLOCATION FAILS FOR QXXX' !F95 GO TO 999 !F95 ENDIF !F95 BQXXX=.TRUE. !F95 C !F95 ALLOCATE (MAM(NSS),NAM(NSS),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: ALLOCATION FAILS FOR MAM,NAM' !F95 GO TO 999 !F95 ENDIF !F95 BMNAM=.TRUE. !F95 C C----------------------------------------------------------------------- C RECOVER TARGET ALGEBRA (SLATER-STATES ETC) FROM ALGEB1, AFTER ALGEB3 C----------------------------------------------------------------------- C READ(MR)(DC(I),I=0,MTGD) !REC3 READ(MR)(IDC(I),I=1,MTGDI) !REC3 READ(MR)(JYI(I),I=1,KM),(JYF(I),I=1,KM) !REC3 X ,(QBML(I),I=1,NSS),(QBMS(I),I=1,NSS),(QLMC(I),I=1,NESS) X ,(NTG(I),I=0,KM),(JTGD(I),I=0,NTT),(QCP(I),I=1,KM) X ,(QTGS(I),I=1,NTT),(QTGL(I),I=1,NTT),(QTGD(I),I=1,NTT) c if(bdisk.and.dc(0).gt.dzero.and.mxtgdi.ne.mdcbuf)!just conceivable x stop 'algx buffer flag error as exactly one VCC in memory mtgd=1' C C----------------------------------------------------------------------- C RECOVER TARGET DIAGON SO WE CAN SET METASTABLE AND CORRELATION ALGEBRA C----------------------------------------------------------------------- C READ(MR,END=10)NMETA !NDUM IF WANT NMETA=0 READ(MR)(NMETAG(I),I=1,NSL0) NENERG=0 READ(MR)N,KCUT BECOR=N.LT.0 IF(BECOR)N=-N NENERG=N READ(MR)(INDEX(I),I=1,NENERG) READ(MR)(DSPECE(I),I=1,NENERG) !RYD NOW ! C C REDUCE NENERG ENERGIES TO THE NSPECE NON-CORRELATION. C THIS MAKES IT EASY TO HANDLE INTERSPERSED SPEC/CORR. C C ALSO, SET REVERSE INDEX(I), JNDEX(J): C INDEX MAPS SPEC E.O. I=1,2,3 TO S.O. C JNDEX MAPS *ALL S.O. I=1,2,3 TO SPEC E.O. C FOR CORR S.O. THE FULL E.O. POSITION IS SET. SUBSEQUENTLY, WE ONLY C CARE THAT IT HAS BEEN FLAGGED NEGATIVE FOR CORR. THE ACTUAL VALUE C IS NOT NEEDED/USED. C NSPECE=0 DO J=1,NENERG I=INDEX(J) if(i.lt.0)then jndex(-i)=-j else NSPECE=NSPECE+1 JNDEX(I)=NSPECE !=J IN ORIG E.O. INDEX(NSPECE)=I DSPECE(NSPECE)=DSPECE(J) endif ENDDO C 10 IF(NENERG.EQ.0)THEN IF(NZION.NE.0)THEN !SHOULDN'T HAPPEN WRITE(6,*)'*** SR.ALGX: MISSING LS TARGET INFO' WRITE(0,*)'*** SR.ALGX: MISSING LS TARGET INFO' GO TO 995 ENDIF C ELSE JUST AN ALGEBRA RUN ENDIF C C RE-RETABULATE THE NCI=NTG(KM) TERMS CASL OF THE KM CONFIGURATIONS C ACCORDING TO TOTAL S,L,KPC(=PARITY 0,2 FOR EVEN,ODD); ONE OBTAINS C NSL0 BLOCKS OF LENGTH NSL(N), WITH QSI(N)=2S,QLI(N)=2L,QPI(N)=KP; C NGRPI(ND): GROUP ND STARTS AT NCI=NGRPI(ND)+1 IN TERM LIST C WRITE(6,400)NMETA C NCTOT=0 NCI=0 NSL0=0 NN=0 C QCL=QCL0 !2L C 151 QCS=QCS0 !2S C 152 KCP=0 !2P C 153 NC=0 C DO K=1,KM IF(QCP(K).EQ.KCP)THEN NG0=NTG(K-1)+1 NT0=NTG(K) QCS00=QTGS(NG0) QCL00=QTGL(NG0) K0=1 ND0=0 DO I=NG0,NT0 IF(QTGL(I).NE.QCL00.OR.QTGS(I).NE.QCS00)THEN QCS00=QTGS(I) QCL00=QTGL(I) K0=K0+1 ENDIF IF(QTGL(I).EQ.QCL.AND.QTGS(I).EQ.QCS)THEN NC=NC+1 NCI=NCI+1 ND=NSL0+1 ND0=K0 IF(BTEST)WRITE(6,180)NCI,QCS+1,QCL/2,KCP/2,K,I,ND NFQ(NCI)=ND NFK(NCI)=K NFI(NCI)=I ELSE IF(QTGL(I).LT.QCL)GO TO 155 !BAIL OUT ENDIF ENDDO 155 IF(ND0.GT.0)KGSL(K,ND)=ND0 !GROUP NO. WITHIN CF ENDIF ENDDO C IF(NC.GT.0)THEN NCTOT=NCTOT+NC*NC c if(btest)write(6,182)nc NN=((NC+1)*NC)/2+NN NSL0=ND QLI(ND)=QCL QSI(ND)=QCS QPI(ND)=KCP NSL(ND)=NC NGRPI(ND)=NCI-NC ENDIF C KCP=KCP+2 IF(KCP.LE.2)GO TO 153 !LOOP UP TO NEXT PARITY C QCS=QCS-2 IF(QCS.GE.0)GO TO 152 !LOOP UP FOR NEXT SPIN C QCL=QCL-2 IF(QCL.GE.0)GO TO 151 !LOOP UP FOR NEXT ORB A.M. C IADD=NN C IF(NCI.NE.NENERG.AND.NZION.NE.0)THEN WRITE(6,170)NCI,NENERG WRITE(0,170)NCI,NENERG GO TO 995 ENDIF c c if(btest)write(6,198)nctot,maxuc C C LOWEST (ENERGY) NMETA INITIAL TERMS TO ALL EXCITED STATES ONLY, C SO FLAG GROUPS FOR OMISSION WHICH ONLY INTERACT VIA EXCITED STATES C DEFAULT (NMETA=0) IS "ALL". C (IF USER SETS NMETA.LT.0 THEN THEY COULD SPECIFY NMETAG DIRECTLY VIA C SALGEB NAMELIST... NOT CURRENTLY ALLOWED, BUT BP RUN SETS NMETAG C IN ALGX AND THEN RESETS .LT.0 TO SKIP HERE.) C IF(IABS(MODE).GT.1)THEN C NMETA=IABS(NMETA) NMETA=MIN(NMETA,NSPECE) C DO N=1,NSL0 !OR BGLS=IUNIT(14).LT.0 IF(NMETAG(N).NE.0)THEN !WAS SET IN STRUCTURE RUN BGLS=.TRUE. GO TO 15 ENDIF ENDDO BGLS=.FALSE. !WAS NOT 15 IF(NMETA.GT.0)THEN IF(.NOT.BGLS)THEN !SET NOW DO N=1,NSL0 NMETAG(N)=1 ENDDO ENDIF DO N=1,NMETA I=INDEX(N) c if(i.gt.0)then !else correlation ND=NFQ(I) IF(BGLS)THEN IF(NMETAG(ND).NE.0)THEN !ABORT WRITE(0,114) WRITE(6,114) GO TO 995 ENDIF ELSE NMETAG(ND)=0 ENDIF c write(0,*)i,nd c endif ENDDO elseif(nmeta.eq.0)then !shouldn't get here now stop 'algx error: nmeta.eq.0...' ENDIF c c write(6,*)'lsp groups' c do k=1,nsl0 c write(6,*)k,nmetag(k) c enddo C GO TO 20 C ENDIF C C----------------------------------------------------------------------- C RECOVER TARGET DIAGFS SO WE CAN SET METASTABLE AND CORRELATION ALGEBRA C----------------------------------------------------------------------- C READ(MR) !NCTOT !SKIP LS, AS NOT USED CURRENTLY READ(MR) !(TFU(I),I=1,NCTOT) !SKIP LS, AS NOT USED CURRENTLY C READ(MR,END=50)NMETAJ !NDUM IF WANT NMETAJ=0 READ(MR)(NMETGJ(I),I=1,NJO) NENERJ=0 READ(MR)N,KCUT BECOR=N.LT.0 IF(BECOR)N=-N NENERJ=N READ(MR)(INDXJ(I),I=1,NENERJ) READ(MR)(DSPECJ(I),I=1,NENERJ) !RYD NOW ! C C REDUCE NENERJ ENERGIES TO THE NSPECJ NON-CORRELATION. C THIS MAKES IT EASY TO HANDLE INTERSPERSED SPEC/CORR. C C ALSO, SET REVERSE INDXJ(I), JNDXJ(J): C INDXJ MAPS SPEC E.O. I=1,2,3 TO S.O. C JNDXJ MAPS *ALL S.O. I=1,2,3 TO SPEC E.O. C FOR CORR S.O. THE FULL E.O. POSITION IS SET. SUBSEQUENTLY, WE ONLY C CARE THAT IT HAS BEEN FLAGGED NEGATIVE FOR CORR. THE ACTUAL VALUE C IS NOT NEEDED/USED. C NSPECJ=0 DO J=1,NENERJ I=INDXJ(J) if(i.lt.0)then jndxj(-i)=-j else NSPECJ=NSPECJ+1 JNDXJ(I)=NSPECJ !=J IN ORIG E.O. INDXJ(NSPECJ)=I DSPECJ(NSPECJ)=DSPECJ(J) endif ENDDO C 50 IF(NENERJ.EQ.0)THEN IF(NZION.NE.0)THEN !SHOULDN'T HAPPEN WRITE(6,*)'*** SR.ALGX: MISSING IC TARGET INFO' WRITE(0,*)'*** SR.ALGX: MISSING IC TARGET INFO' GO TO 995 ENDIF C ELSE JUST AN ALGEBRA RUN ENDIF C C THE FOLLOWING SECTION SETS UP THE STATES ACCORDING TO THEIR C J-VALUES: J=TOTAL ANGULAR MOMENTUM. C bcutfs=nmetag(0).ne.0 !may use other values in future im=-1 if(bcutfs)im=1 c WRITE(6,401)NMETAJ*im C NJO=0 NJ=0 NP=0 NCTOT=0 C JACT=QCL0+QCS0 C 60 KPI=0 C 61 IF(NASTJP.GT.0)THEN !SELECT BY JPI JT=10*JACT+KPI/2 DO I=1,NASTJP IF(JT.EQ.JPIP(I))GO TO 62 !WANT ENDDO GO TO 64 !DON'T WANT ELSEIF(NASTJP.LT.0)THEN !SELECT BY MINJT,MAXJT IF(JACT.LT.MINJTP.OR.JACT.GT.MAXJTP)GO TO 64 !DON'T WANT ENDIF C 62 N0=0 NDJ=NJO+1 !NDJ IS JP GROUP NUMBER NGSLJ(NDJ)=0 C C DO LOOP TO FIND NUMBER OF LEVELS WHICH CAN RESULT IN GIVEN J C IT=0 DO I=1,NSL0 NC=NSL(I) IT=IT+NC IF(QPI(I).NE.KPI)GO TO 63 C LJ=QLI(I) SJ=QSI(I) IF(IABS(LJ-SJ).GT.JACT.OR.(LJ+SJ).LT.JACT)GO TO 63 C IT=IT-NC NGSLJ(NDJ)=NGSLJ(NDJ)+1 NSLJ(NGSLJ(NDJ),NDJ)=I DO N=1,NC IT=IT+1 NJ=NJ+1 N0=N0+1 IF(BTEST)THEN KG=NFK(IT) WRITE(6,181)NJ,SJ+1,LJ/2,JACT,KG,IT ENDIF NRR(NJ)=IT JJ(NJ)=JACT NGR(NJ)=NDJ ENDDO C 63 ENDDO C IF(N0.GT.0)THEN NJO=NDJ NP=((N0+1)*N0)/2+NP NCTOT=NCTOT+N0*N0 c if(btest)write(6,181)ndj,jact,kpi/2,n0 NT(NDJ)=N0 ENDIF C 64 KPI=KPI+2 IF(KPI.EQ.2)GO TO 61 !LOOP BACK UP FOR SECOND PARITY C JACT=JACT-2 IF(JACT.GE.0)GO TO 60 !LOOP BACK UP FOR NEXT 2J C IADJ=NP C IF(NJ.NE.NENERJ.AND.NZION.NE.0)THEN WRITE(6,175)NJ,NENERJ WRITE(0,175)NJ,NENERJ GO TO 995 ENDIF C c if(btest)write(6,134)nctot,maxju C C NOW SET NMETAG, WHICH DEFINES THE LS(J) GROUP INTERACTIONS WE NEED, C BASED UPON NMETAJ. C PROBABLY DON'T WANT TO LET USER JOE OVERRIDE, I.E. RE-SET NMETA.GT.0. c c Default nmetaj.gt.0 will neglect 2fs between excited levels that at c most spin-orbit mix with the metastable levels. (Passed via nmetag(0)) c User input nmetaj.lt.0 includes all allowed by a.m. selection. c c bcutfs=nmetag(0).ne.0 !may use other values in future C C NMETGJ IS NOT CURRENTLY USED IN THE ALGX BRANCH (USED BY TARGET MK) C RATHER, THE CONSTITUENT NMETAG GROUPS ARE USED/FLAGGED C *THIS*, NMETGJ USE, MAY CHANGE AND SO WE SET IT UP CORRECTLY. C NMETAJ=IABS(NMETAJ) NMETAJ=MIN(NMETAJ,NSPECJ) c i0=0 if(bcutfs)i0=-1 C DO N=1,NJO !OR BGLS=IUNIT(15).LT.0 IF(NMETGJ(N).NE.0)THEN !WAS SET IN STRUCTURE RUN BGIC=.TRUE. GO TO 16 ENDIF ENDDO BGIC=.FALSE. !WAS NOT 16 IF(NMETAJ.GT.0)THEN IF(.NOT.BGIC)THEN !SET NOW DO N=1,NJO NMETGJ(N)=1 ENDDO ENDIF DO N=1,NMETAJ I=INDXJ(N) c if(i.gt.0)then !else correlation NDJ=NGR(I) !J-GROUP IF(BGIC)THEN IF(NMETGJ(NDJ).NE.0)THEN !ABORT WRITE(0,115) WRITE(6,115) GO TO 995 ENDIF ELSE NMETGJ(NDJ)=0 ENDIF c write(0,*)i,ndj c endif ENDDO IF(.NOT.BGIC)THEN !SINCE CONTROLLED BY NMETAJ DO K=1,NSL0 NMETAG(K)=1 ENDDO ENDIF DO N=1,NJO IF(NMETGJ(N).EQ.0)THEN NCN0=NGSLJ(N) DO NC0=1,NCN0 ND=NSLJ(NC0,N) IF(BGIC)THEN IF(NMETAG(ND).gt.0)THEN !ABORT WRITE(0,115) WRITE(6,115) GO TO 995 else nmetag(nd)=i0 ENDIF ELSE NMETAG(ND)=i0 ENDIF ENDDO ENDIF ENDDO if(bcutfs)then do n=1,nmetaj i=indxj(n) it=nrr(i) nd=nfq(it) nmetag(nd)=0 c write(0,*)n,i,it,nd enddo endif c do n=1,nsl0 c write(0,*)n,nmetag(n) c enddo elseif(nmetaj.eq.0)then !shouldn't get here now stop 'algx error: nmetaj.eq.0...' ENDIF c c write(6,*)'jp groups' c do k=1,njo c write(6,*)k,nmetgj(k) c enddo c write(6,*)'lsp groups' c do k=1,nsl0 c write(6,*)k,nmetag(k) c enddo C C----------------------------------------------------------------------- C RE-INSTATE LS-SYMMETRY SELECTION C----------------------------------------------------------------------- C 20 INAST=INAST0 DO I=1,INAST0 LSPI(I)=LSPIP(I,1) ENDDO MINLT=MINLTB MAXLT=MAXLTB MINSP=MINSTB MAXSP=MAXSTB C C----------------------------------------------------------------------- C RE-INSTATE J-SYMMETRY SELECTION C----------------------------------------------------------------------- C INASTJ=INASTJ0 DO I=1,INASTJ0 JPI(I)=JPIP(I) ENDDO MINJT=MINJTB MAXJT=MAXJTB C C----------------------------------------------------------------------- C (RE-)INITIALIZE C----------------------------------------------------------------------- C IF(KUTOOX.EQ.-999)KUTOOX=-1 !OR KUTOO IF(KUTOOX.EQ.-1)KUTOOX=0 !ALIGN BKUTOO=KUTOOX.NE.0 BDLBD=IABS(MODE).LT.2.OR.BKUTOO C WRITE(6,1000) C C----------------------------------------------------------------------- C COMPUTE CLEBSCH-GORDAN VCC TABLES VCA & VCB C FOR PRACTICAL PURPOSES, WE GO AS FAR AS DIMENSIONS ALLOW. C----------------------------------------------------------------------- C NXLL=-1 DO K=1,MXORB IF(DEY(K).NE.DZERO.AND.QL(K).GT.NXLL)NXLL=QL(K) ENDDO C DFS(1)=1 DFS(2)=1 DO I=3,MXDFS,2 DFS(I)=-DFS(I-2) DFS(I+1)=(I-1)*DFS(I-1)/32 ENDDO C MXLL=-1 SKP=IDW.LT.0 !MPRINT.LT.MG IF(.NOT.SKP)THEN BVC=.FALSE. IF(.NOT.BVC)MXLL=2*MAXLL C M1=0 46 M2=0 C 45 MK=IABS(M1-M2) C 44 MKT=MK+2 DVC0=VCC(M1,M2,MK,0,0,0,DFS,MXDFS) ML1=-M1 C 42 MB1=MVC(M1,ML1) ML2=-M2 C 43 MB2=MVC(M2,ML2) DA=DZERO DD=DZERO MLK=ML1+ML2 IF(IABS(MLK).LE.MKT)THEN IF(BDLBD)DD=VCC(M1,M2,MKT,ML1,ML2,MLK,DFS,MXDFS)*DVC0 IF(IABS(MLK).LE.MK) X DA=(VCC(M1,M2,MK, ML1,ML2,MLK,DFS,MXDFS)/(MK+1))*DVC0 ENDIF MLK=MK/4+1 VCA(MB1,MB2,MLK)=DA VCB(MB1,MB2,MLK)=DD C ML2=ML2+2 IF(ML2.LE.M2)GO TO 43 C ML1=ML1+2 IF(ML1.LE.M1)GO TO 42 C MK=MK+4 IF(MK.LE.M1+M2)GO TO 44 C M2=M2+2 IF(M2.LE.MXLL)GO TO 45 C M1=M1+2 IF(M1.LE.MXLL)GO TO 46 ENDIF C C----------------------------------------------------------------------- C SET BXIST0=.FALSE. IF TWO CFGS DIFFER IN MORE THAN ONE ELECTRON PAIR C----------------------------------------------------------------------- C KDM=KM !FOR /TERMS/ C DO KF=1,KM DO KG=1,KF BXIST0(KF,KG)=.TRUE. BXIST0(KG,KF)=.TRUE. KACT(KF,KG)=0 KACT(KG,KF)=0 DO I=1,NF QLMC(I)=QCG(I,KG) ENDDO K=0 DO I=1,NF DO L=1,NF IF(IEQ(QLMC(L)).EQ.IEQ(QCG(I,KF)))THEN QLMC(L)=0 GO TO 51 ELSE IF(QLMC(L).NE.0)L0=L ENDIF ENDDO K=K+1 IF(K.GT.1)THEN BXIST0(KF,KG)=.FALSE. BXIST0(KG,KF)=.FALSE. GO TO 52 ENDIF KACT(KF,KG)=QCG(I,KF) KACT(KG,KF)=QLMC(L0) 51 ENDDO 52 ENDDO ENDDO C FLAG NF+1 AS CONT. NF1=NF+1 M1=MXORB+1 DO K=1,KM QCG(NF1,K)=M1 ENDDO C C----------------------------------------------------------------------- C DETERMINE CONTINUUM EXPANSION (LS) C----------------------------------------------------------------------- C IF(LCONDW.LE.0)THEN i1=0 LCONDW=(QCL0+2)/2 !MAX NO OF CONT-L THAT CAN FORM SLP ELSE i1=mod(lcondw+1,2) LCONDW=(LCONDW-1)/2 IC=QCL0/2 if(lcondw.lt.ic)WRITE(6,1005)LCONDW,IC LCONDW=LCONDW+1 ENDIF LC=-LCONDW LCONDW=2*LCONDW-1 !ALLOW FOR BOTH TARGET PARITIES lcondw=lcondw+i1 C IF(MXORB+LCONDW.GT.MAXGR)THEN WRITE(6,*)'*** INCREASE MAXGR TO:',MXORB+LCONDW WRITE(0,*)'*** INCREASE MAXGR TO:',MXORB+LCONDW GO TO 995 ENDIF C MPOSC=MXORB LW=LCONDW C C----------------------------------------------------------------------- C DETERMINE CONTINUUM EXPANSION (LSJ) C----------------------------------------------------------------------- C BKUTSS=IABS(MODE).LE.1.AND.KUTSSX.NE.-1.AND.KUTSSX.NE.-999 C IF(BKUTSS)THEN C IF(LCONDWJ.LE.0)THEN i1=mod(qcs0+1,2) LCONDWJ=(QCL0+QCS0+3)/2 !MAX NO OF CONT-L THAT CAN FORM SLJP ELSE LCONDWJ=MAX(LCONDW,LCONDWJ) !ELSE INDEX PAIN i1=mod(lcondwj+1,2) LCONDWJ=(LCONDWJ-1)/2 IC=(QCL0+QCS0+3)/2-1 if(lcondwj.lt.ic)WRITE(6,2005)LCONDWJ,IC LCONDWJ=LCONDWJ+1 ENDIF LCJ=-LCONDWJ LCONDWJ=2*LCONDWJ-1 !ALLOW FOR BOTH TARGET PARITIES lcondwj=lcondwj+i1 C IF(MXORB+LCONDWJ.GT.MAXGR)THEN WRITE(6,*)'*** INCREASE MAXGR TO:',MXORB+LCONDWJ WRITE(0,*)'*** INCREASE MAXGR TO:',MXORB+LCONDWJ GO TO 995 ENDIF C MPOSC=MPOSC+(LCONDWJ-1)/2-(LCONDW-1)/2 !BUFFER SPACE LW=LCONDWJ C ELSE C LCONDWJ=LCONDW C ENDIF c if(bkutoo.and.lcondwj.eq.1)then !note: SET lcondw, not lcondwj! write(6,*)'*** buffer space too small, switch-off 2-nfs or' x ,'set lcondw=2' write(0,*)'*** increase lcondw to 2' go to 995 endif C C----------------------------------------------------------------------- C INITIALZE CONTINUUM ORBITAL LOCATIONS (LABEL & FLAG EXISTENCE) C----------------------------------------------------------------------- C DO L=1,LW I=MXORB+L QN(I)=90 DEY(I)=DONE ENDDO WRITE(6,1001) C DO L=1,LCONDW I=MPOSC+L LC=LC+1 IF(LC.LT.0)WRITE(6,1002)I,IABS(LC) IF(LC.EQ.0)WRITE(6,1003)I IF(LC.GT.0)WRITE(6,1004)I,LC ENDDO C C----------------------------------------------------------------------- C PERFORM CONSISTENCY CHECKS ON LS & J, I.E. THAT WE HAVE REQUIRED SLP C FOR JP AND THAT MAXLX IS SET APPROPRIATELY FOR MAXJFS. C----------------------------------------------------------------------- C IF(IABS(MODE).LE.1.AND.INAST0.LE.0)THEN C IF(INASTJ0.LE.0)THEN C M01=QCS0+1-2*((QCS0+1)/2) IF(MOD(MINJT,2).EQ.MOD(QCS0,2))THEN MINJT=MINJT-1 MINJT=MAX(M01,MINJT) ENDIF IF(MAXJT.LT.200.AND.MOD(MAXJT,2).EQ.MOD(QCS0,2))MAXJT=MAXJT+1 C IF(LVMAX.GE.0)THEN !BTHRSH: CHECK BY CHANNEL LV (FOR BBGP) C MAXJ=2*LVMAX+QCL0+QCS0+1 IF(MAXJT.EQ.2000)MAXJT=MAXJ IF(MAXJT.GT.MAXJ)THEN WRITE(6,1007) WRITE(6,1015)MAXJ,LVMAX WRITE(6,1007) MAXJT=MAXJ ELSEIF(MAXJT.LT.MAXJ)THEN WRITE(6,1007) WRITE(6,1016)MAXJT,LVMAX,MAXJ WRITE(6,1007) C MAXJT=MAXJ !ALLOW USER TO RESTRICT BY J ENDIF MAXLT=(MAXJT+QCS0+1)/2 !DO NOT ALLOW USER TO RESTRICT BY L C MINJ=2*LVMIN-QCL0-QCS0-1 MINJ=MAX(M01,MINJ) IF(MINJT.GT.MINJ)THEN WRITE(6,1007) WRITE(6,1017)MINJT,LVMIN,MINJ WRITE(6,1007) C MINJT=MINJ !ALLOW USER TO RESTRICT BY J ELSEIF(MINJT.LT.MINJ)THEN WRITE(6,1007) WRITE(6,1018)MINJ,LVMIN WRITE(6,1007) MINJT=MINJ ENDIF MINLT=(MINJT-QCS0-1)/2 !DO NOT ALLOW USER TO RESTRICT BY L MINLT=MAX(0,MINLT) C ELSE !CHECK BY TOTAL L (FOR DW) C IF(MAXLT.EQ.1000)MAXLT=30+(QCS0+1)/2 IF(MAXLT.GT.100)THEN MAXLT=100 WRITE(0,*)'*** AR.ALGX: REDUCING MAXLT TO',MAXLT MINLT=MIN(MINLT,MAXLT) ENDIF IF(MAXJT.GT.200)THEN IF(MAXJT.NE.2000)WRITE(0,*)'*** AR.ALGX: REDUCING MAXJT' MAXJT=2*MAXLT-QCS0-1 MINJT=MIN(MINJT,MAXJT) ELSE MAXL=(MAXJT+QCS0+1)/2 IF(MAXLT.GT.MAXL)THEN WRITE(6,1007) WRITE(6,1008)MAXL,MAXJT WRITE(6,1007) MAXLT=MAXL ELSEIF(MAXLT.LT.MAXL)THEN WRITE(6,1007) WRITE(6,1009)MAXL,MAXJT WRITE(6,1007) MAXLT=MAXL !DO NOT ALLOW USER TO RESTRICT BY L ENDIF ENDIF C MINL=(MINJT-QCS0-1)/2 MINL=MAX(0,MINL) IF(MINLT.GT.MINL)THEN WRITE(6,1007) WRITE(6,1011)MINL,MINJT WRITE(6,1007) MINLT=MINL !DO NOT ALLOW USER TO RESTRICT BY L ELSEIF(MINLT.LT.MINL)THEN WRITE(6,1007) WRITE(6,1012)MINL,MINJT WRITE(6,1007) MINLT=MINL ENDIF C ENDIF C ELSE !INASTJ0.GT.0 C MTEST=MOD(QCS0,2) IFLAGJ=0 JCOUNT=-1 INAST=0 DO I=1,INASTJ0 IJ=JPI(I)/10 IPJ=JPI(I)-IJ*10 IF(MOD(IJ,2).EQ.MTEST)THEN IF(IFLAGJ.EQ.0)WRITE(6,1113) IFLAGJ=IFLAGJ+1 WRITE(6,1114)I,IJ,IPJ ELSE CALL NUMSYM(IJ,IPJ,JCOUNT) ENDIF ENDDO IF(IFLAGJ.GT.0)THEN WRITE(6,1120) WRITE(0,*) X '***SR.ALGX ERROR:',IFLAGJ,' ILLEGAL TOTAL 2J REQUESTED' NF=-1 GO TO 990 ENDIF INAST0=INAST !RE-SYNC. C ENDIF C IF(MAXJFS.GE.0)THEN C MLAM0=MXLAMX IF(MXLAMX.EQ.1000)THEN !MAX EXCHANGE MULTIPOLE IF(MAXLX.GE.100)THEN MXLAMX=NXLL+3 !TWICE MAX ORB L+3 (was +1) c mxlamx=max(mxlamx,3) ELSE C MXLAMX=(MAXLX+1)/2 MXLAMX=MAXLX-NXLL/2 ENDIF ENDIF C IF(MAXLX.GE.100)MAXLX=2*MXLAMX !MAX L FOR EXCHANGE IF(MAXLX.GE.100)MAXLX=MXLAMX+NXLL/2 !MAX L FOR EXCHANGE JTEST=MAXJFS IF(INASTJ.LE.0)JTEST=MIN(MAXJT,MAXJFS) IL=(JTEST+QCS0+1)/2 IF(IL.GT.MAXLX)THEN WRITE(6,1119)IL 1119 FORMAT(/'NOTE: MAX EXCHANGE L HAS BEEN INCREASED FOR 2-BODY' X ,' FINE-STRUCTURE TO MAXLX=',I3) WRITE(0,*) X 'NOTE: MAXLX IS INCREASED FOR 2-BODY FINE-STRUCTURE' MAXLX=IL ENDIF ENDIF C ENDIF C C----------------------------------------------------------------------- C C INITIALIZE FOR PARALLEL OPERATION. C C----------------------------------------------------------------------- cparc !par cpar if(iabs(mode).gt.1)then !par cpar call psymls(iam,nproc) !par cpar else !par cpar call psymj(iam,nproc) !par cpar endif !par cparc !par cpar if(nf.lt.0)then !par cpar call comm_finalize() !par cpar go to 990 !par cpar endif !par cparc !par C C----------------------------------------------------------------------- C C SET-UP LSP SYMMETRIES & CHANNEL LIST C C----------------------------------------------------------------------- C CALL SYMLS C IF(NF.LT.0)GO TO 990 C C----------------------------------------------------------------------- C C FORM 2-BODY NON-FINE-STRUCTURE COLLISION ALGEBRA IN LS-COUPLING C C----------------------------------------------------------------------- C CALL ALGXLS(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,DFS,MAXEL) C IF(NF.LE.0)GO TO 990 C INASTJ=0 C IF(IABS(MODE).GT.1)GO TO 901 !QUICK RETURN (LS) C C----------------------------------------------------------------------- C C SET-UP LSJ SYMMETRIES & CHANNEL LIST, INC. SET-UP FOR FINE-STRUCTURE C C----------------------------------------------------------------------- C IF(KUTSSX.EQ.-1.AND.MAXJFS.GE.0)THEN WRITE(6,1006)KUTSSX,MAXJFS WRITE(0,1006)KUTSSX,MAXJFS GO TO 995 ENDIF IF(KUTSSX.EQ.-999)KUTSSX=-1 ! or KUTSS (slow) IF(MAXJFS.EQ.-999)MAXJFS=2*MAXLX-QCS0-1 IF(KUTSSX.EQ.-1)MAXJFS=-1 C CALL SYMLSJ C IF(NF.LT.0)GO TO 990 C INASTJ0=0 C IF(KUTSSX.EQ.-1)GO TO 903 !NO OPERATORS SET FOR 2FS IF(MAXJFS.LT.0)GO TO 902 !NO J SET FOR 2FS C WRITE(6,2000)MAXJFS C WRITE(6,2001) C LC=LCJ DO L=1,LCONDWJ I=MXORB+L LC=LC+1 IF(LC.LT.0)WRITE(6,2002)I,IABS(LC) IF(LC.EQ.0)WRITE(6,2003)I IF(LC.GT.0)WRITE(6,2004)I,LC ENDDO C C----------------------------------------------------------------------- C C FORM 2-BODY FINE-STRUCTURE COLLISION ALGEBRA IN LSJ-COUPLING C C----------------------------------------------------------------------- C CALL ALGXFS(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,DFS,MAXEL) C IF(NF.LE.0)GO TO 990 C C----------------------------------------------------------------------- C 900 IF(IDW.LT.0)THEN WRITE(6,190)IDW NF=0 ENDIF C 990 CONTINUE C !F95 C FINALIZE (CLOSE) WRITE/READ DC ARRAY TO/FROM DISK. C IF(BDISK)CALL DISKDC(IUD,DC,IDC,0,0,0,0,0,0) !MSTART) C IF(BALLDC)THEN !F95 DEALLOCATE (DC,IDC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: DE-ALLOCATION FAILS FOR DC,IDC' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BQXXX)THEN !F95 DEALLOCATE (QBMS,QBML,QLMC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: DE-ALLOCATION FAILS FOR QXXX' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BMNAM)THEN !F95 DEALLOCATE (MAM,NAM,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: DE-ALLOCATION FAILS FOR MAM,NAM' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/NRBFL0/ !F95 IF(BNRBFL0)THEN !F95 DEALLOCATE (KINTI,KINTF,KEN2,KPTCFM,MPOINT,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGX: DE-ALLOCATION FAILS FOR KPTCFM ETC.' !F95 NF=0 !F95 ENDIF !F95 BNRBFL0=.FALSE. !F95 ENDIF !F95 C C----------------------------------------------------------------------- C RETURN C 901 WRITE(6,100) KUTSSX=-1 GO TO 900 C 902 WRITE(6,102) C KUTSSX=-1 !ALLOW BKUTSS FOR DWXBP GO TO 900 C 903 WRITE(6,103) GO TO 900 C 995 NF=-1 GO TO 990 C 999 NF=0 !F95 GO TO 990 !F95 C C 100 FORMAT( /" NOT ENOUGH VCC'S AVAILABLE FOR CALCULATION OF" X," RELATIVISTIC CORRECTIONS: CHANGE MOD TO 1,-1 OR 0") 102 FORMAT(/' *** NO TWO-BODY FINE-STRUCTURE POSSIBLE: SET MAXJFS NON' X,'-NEGATIVE') 103 FORMAT(/' *** NO TWO-BODY FINE-STRUCTURE POSSIBLE: SET KUTSSX TO ' X,'1 OR -9 ETC.') 114 FORMAT('*** SR.ALGX: NMETA INCONSISTANCY, EITHER CREATE A NEW' X,' "TERMS" FILE (BEST) OR DO NOT FLAG TO READ OLD FILE.') 115 FORMAT('*** SR.ALGX: NMETAJ INCONSISTANCY, EITHER CREATE A NEW' X,' "LEVELS" FILE (BEST) OR DO NOT FLAG TO READ OLD FILE.') c 134 FORMAT(/82X,I9,5X,'MAXJU=',I9) 170 FORMAT(/' SR.ALGX: MIS-MATCH BETWEEN ALGEB/DIAGON TARGET TERMS:' X,2I5) 175 FORMAT(/' SR.ALGX: MIS-MATCH BETWEEN ALGEB/DIAFS TARGET LEVELS:' X,2I5) 180 FORMAT(I5,3I4,25X,I3,I6,I3) 181 FORMAT(6I5) 190 FORMAT(/' THIS WAS NO MORE THAN A DIMENSION CHECK -- IDW=',I2/) c 198 FORMAT(/56X,I9,5X,'MAXUC=',I9) 400 FORMAT(//' T 2S+1 L (P-0/1 FOR EVEN/ODD)',8X,'CF NT GR', X 15X,'**** TARGET TERMS ****',15X,'NMETA=',I4) 401 FORMAT(//' LV 2S+1 L 2J CF T',39X X,'**** TARGET LEVELS ****',14X,'NMETAJ=',I5) 1000 FORMAT(///1X,136('-')//52X,'*** COLLISION ALGEBRA (LS) ***' X //1X,136('-')//) 1001 FORMAT(/' CONTINUUM ORBITAL INDEXING FOR TOTAL L:'/ X 60X,' GAM',2X,'SMALL L') 1002 FORMAT(60X,I4,3X,'L-',I2) 1003 FORMAT(60X,I4,3X,'L ',I2) 1004 FORMAT(60X,I4,3X,'L+',I2) 1005 FORMAT(/' WARNING SR.ALGX: YOU HAVE RESTRICTED THE CONTINUUM' X ,' EXPANSION TO: L +/-',I2/29X,'WHILE THE FULL' X ,' EXPANSION EXTENDS TO: L +/-',I2/) 1006 FORMAT('*** ERROR, SR.ALGX: YOU HAVE SPECIFIED CONFLICTING', X' OPTIONS FOR FINE-STRUCTURE COLLISION ALGEBRA; KUTSSX, MAXJFS=' X,2I4) 1007 FORMAT(//1X,136('-')//) 1008 FORMAT(/' NOTE: REDUCING MAXLT TO',I3,', THAT NEEDED BY MAXJT=' X,I4,' (=2J)') 1009 FORMAT(/' NOTE: INCREASING MAXLT TO',I3,', THAT NEEDED BY MAXJT=' X,I4,' (=2J)') 1010 FORMAT(/' DC ARRAY TOO LARGE TO READ (NEED NMTGD SET-UP) - TBD') 1011 FORMAT(/' NOTE: REDUCING MINLT TO',I3,', THAT NEEDED BY MINJT=' X,I3,' (=2J)') 1012 FORMAT(/' NOTE: INCREASING MINLT TO',I3,', THAT NEEDED BY MINJT=' X,I3,' (=2J)') 1113 FORMAT(' SYJ 2J P') 1114 FORMAT(1X,3I4) 1015 FORMAT(/' NOTE: REDUCING MAXJT TO',I4,' (=2J)' X,', THAT NEEDED BY LVMAX=',I3) 1016 FORMAT(/' ***WARNING: YOU HAVE SET MAXJT=',I4,' (=2J)' X,', LESS THAN THAT FORMALLY NEEDED BY LVMAX=',I3/22X X,'SET MAXJT=',I4,7X,' TO SATISFY TRIANGLE RELATION') 1017 FORMAT(/' ***WARNING: YOU HAVE SET MINJT=',I3,' (=2J)' X,', GREATER THAT FORMALLY NEEDED BY LVMIN=',I3/22X X,'SET MINJT=',I3,7X,' TO SATISFY TRIANGLE RELATION') 1018 FORMAT(/' NOTE: INCREASING MINJT TO',I3,' (=2J)' X,', THAT NEEDED BY LVMIN=',I3) 1120 FORMAT('***SR.ALGX ERROR: REQUESTED TOTAL 2J NOT POSSIBLE FOR ' X ,'THIS ATOMIC TARGET - ADD/SUBTRACT 1 TO/FROM 2J') 2000 FORMAT(//1X,136('-')//52X,'*** COLLISION ALGEBRA (LSJ) ***' X //1X,136('-')///61X,'MAXJFS=',I3/61X,10('-')/) 2001 FORMAT(/' CONTINUUM ORBITAL INDEXING FOR TOTAL J:'/ X 57X,' GAM',4X,'SMALL L') 2002 FORMAT(57X,I4,3X,'INT(J)-',I2) 2003 FORMAT(57X,I4,3X,'INT(J) ',I2) 2004 FORMAT(57X,I4,3X,'INT(J)+',I2) 2005 FORMAT(/' WARNING SR.ALGX: YOU HAVE RESTRICTED THE LSJ CONTINUUM' X ,' EXPANSION TO: INT(J) +/-',I2/33X,'WHILE THE FULL' X ,' EXPANSION EXTENDS TO: INT(J) +/-',I2/) 5000 FORMAT(///1X,136('-')//50X,'*** ELECTRON-IMPACT EXCITATION ***' X //1X,136('-')//) C END C C ******************* C SUBROUTINE ALGXFS(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,DFS,MAXEL) C C----------------------------------------------------------------------- C C SR.ALGXFS CALCULATES 2-BODY FS EIE COLLISION ALGEBRA IN LSJ-COUPLING. C C IT CALLS: C FN.QPTLSJ C SR.RESX1 C SR.RESX2 C FN.VCC C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_DMQSS3, ONLY: BDMQSS3,DSS,MSS,QSS,NADR !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KPTCFM !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-5) PARAMETER (TTYNY=TYNY/1.D3) C INTEGER SA,SAP C LOGICAL BXIST0,BXIST2,BXIST1,B2BODY,LX1,LX2,BFAST X ,LX,LXS1,LXS2,LXL1,LXL2,EQGRP,EQCFS,EQUAL,EQUALM x ,eqgrpl,eqgrpl0,btime,btimex,becor !,bcor,bcorr C CHARACTER(LEN=1) LIT C REAL*8 DC C INTEGER*8 MDCF8,MDCFT8 CF77 INTEGER*8 MSS !F77 C DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*) DIMENSION QLMC(MAXEL,*),QBML(*),QBMS(*),JYI(*),JYF(*),DFS(*) X ,LIT(8) X ,nej(2),mej(2),qnf1(mxst0) DIMENSION BXIST2(MAXCF,MAXCF) C COMMON /BASIC/NF,KF,KG,J1,J2,J1P,J2P,ND1,NDP1,LL(2),NGAP COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CMDVC/DVC12,LX,ICLRR,EQUALM COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL,NL000 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBBBB/BXIST0(MAXCF,MAXCF),BXIST1(MAXCF) COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX C COMMON /NRBDW3/KACT(MAXCF,MAXCF) COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDWJ/JSYMM(MXSYJ,MAXJG),NCHGJ(MAXJG),NADGJ(MAXJG) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) C COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) !target COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT C COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex C C DATA LIT(1),LIT(2),LIT(3),LIT(4)/' ','A','B','C'/ DATA LIT(5),LIT(6),LIT(7),LIT(8)/'*','a','b','c'/ C EQUIVALENCE (LI,LL(1)),(LF,LL(2)) C C SUPPRESS COMPILER WARNINGS (SIGH...) C QDUM=QBML(1) C C----------------------------------------------------------------------- C c some test set-up switches that user joe should not need to touch. c c if elastic is dropped here then it has an effect on inelastic c transitions between terms of same symmetry because they are mixed c cold ione0=0 !=0 retain elastic here c c if bcor then we have algebraic correlation, and we know how ordered c c bcor=km*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NADJ(NCORJ) c c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- c if(btimex)then if(iabs(modd).le.1)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for algxfs' !par cpar else !par write(iw,*)'Starting algxfs' cpar endif !par endif call cpu_time(timei) time0=timei endif C C INITIALIZATIONS C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C IF(KUTDSK.LT.KM)THEN IEND=MTGD !FOR DISKDC MTGD1=MTGD+1 CTEST CALL DISKDC(IUD,DC,IDC,1,0,0,0,0,0) !REPOINT ENDIF C MXX=KF !SYMLSJ TRANSFER NCHMX=KG ! " " C NF1=NF+1 C NSS=JYF(KM) !F95 CF77 NSS=MXST0 !F77 C IF(KUTSSX.NE.-9)THEN !RESET BXIST0 FOR 2FS WRITE(6,102)KUTSSX !WARNING MKT=KUTSSX IF((MKT+3)/2.EQ.1)MKT=1+MKT !ALIGNS DEFAULT KUTSSX=0 AND -1 DO KF=1,KM DO KG=1,KF B2BODY=.FALSE. IF(MKT.GE.0.AND.KF.NE.KG)GO TO 15 c IF(KCFSS(KF)*KCFSS(KG).LE.0)THEN !or could use target kcfss IF(KF.GT.IABS(MKT))GO TO 15 IF(KG.GT.IABS(MKT))GO TO 15 c ENDIF B2BODY=BXIST0(KG,KF) 15 BXIST0(KG,KF)=B2BODY BXIST0(KF,KG)=B2BODY ENDDO ENDDO ENDIF C C INASTJ0 WAS THE NUMBER OF USER INPUT SYMMETRIES, NOW RE-SET TO C LAST SYMMETRY THAT CONTRIBS TO MAXJFS - THUS USER INPUT SHOULD BE C IN ASCENDING J. DEFAULT USAGE IS MINJT,MAXJT I.E. INAST0.LE. INPUT. C INASTJ IS THE TOTAL NUMBER OF JP SYMMS TO BE USED. C DO J=1,INASTJ IJ=JPI(J)/10 IF(IJ.LE.MAXJFS)INASTJ0=J ENDDO C C EX-COMMON/DMQSS3/ !F95 ALLOCATE (DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI),NADR(0:IADJ) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXFS: ALLOCATION FAILS FOR DSS,MSS,QSS,NADR' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BDMQSS3=.TRUE. !F95 C !F95 C EX-COMMON/DMQSSS/ !F95 ALLOCATE (DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXFS: ALLOCATION FAILS FOR DSSS,MSSS,QSSS' !F95 NF=0 !F95 GO TO 900 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS2/ !F95 ALLOCATE (NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F95 X ,IORIG2(MXS2I),JORIG2(MXS2I),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXFS: ALLOCATION FAILS FOR NADS2,NSTJ2, ETC' !F95 NF=0 !F95 GO TO 900 !F95 ENDIF !F95 C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C NOW GENERATE LSJ PARTIAL WAVE ALGEBRA, LOOPING OVER INITIAL AND FINAL C LS CHANNELS RESOLVED BY CONTINUUM L,S=1/2 COUPLED TO TARGET SYMMETRY C GROUPS, THEN RESOLVE BY INDIVIDUAL LEVELS. C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C WRITE(6,3033) KUTSSX,LIT(QQCUT) WRITE(6,3050) MXADJ,MAXJG,MXSYJ,MXSYJ,MAXDK,MAXDK,MXRSS,MAXMI C IF(IADJ.GT.MXADJ)THEN IF(MXADJ.GT.0)WRITE(6,3054)IADJ,MXADJ !F95 CF77 WRITE(6,3055)IADJ,MXADJ !F77 CF77 GO TO 999 !F77 ENDIF C CF77 IF(IADJ.GT.0)THEN CF77 IF(MXAJS.NE.MXADJ.and.mxadj.gt.0)THEN CF77 WRITE(6,401) CF77 WRITE(0,*) CF77 GO TO 999 CF77 ENDIF CF77 ENDIF C KPI=0 NL=0 IRS=0 MXIRSS=0 MXNLS=0 KPI=1 KPIS=1 C NADS2(0)=0 NADR(0)=0 NCORJ=0 C C----------------------------------------------------------------------- C LOOP OVER TOTAL SYMMETRIES C----------------------------------------------------------------------- C DO KX=1,INASTJ0 C MTJ=JPI(KX)/10 MTP=JPI(KX)-MTJ*10 MTP=MTP+MTP c if(mtj.gt.maxjfs)go to 99 !case non-sequential C MTMJ=MTJ ct if(mtj.ne.0)mtmj=mtj-2 C c write(0,*)kx,nadgj(kx),ncorj if(ncorj.ne.nadgj(kx))stop 'ncorj.ne.nadgj(kx)'!shouldn't happen c INASTX=NCHGJ(KX) C C----------------------------------------------------------------------- C if(btimex)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'Starting proc',iam !par cpar x ,'symmetry',kx,':',mtj,mtp/2 !par cpar call flush(iwp) !par cpar else !par write(iw,*)'Starting symmetry',kx,' :',mtj,mtp/2 cpar endif !par cparc !par time1=dzero time2=dzero call cpu_time(timei) times=timei endif C C----------------------------------------------------------------------- C DO IXX=1,INASTX !BEGIN LOOP OVER INITIAL LS SYMMS C IX=JSYMM(IXX,KX) C NCN=NCHG(IX) C IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 C !ALIGN IF(MTP.NE.IP+IP)STOP 'IXX ERROR' MTS=IS-1 MTL=IL+IL C DO JXX=1,IXX !BEGIN LOOP OVER FINAL LS SYMMS C JX=JSYMM(JXX,KX) C NCNP=NCHG(JX) C ISP=LSPI(JX)/10000 IPP=LSPI(JX)-ISP*10000 ILP=IPP/10 IPP=IPP-ILP*10 C IF(MTP.NE.IPP+IPP)STOP 'JXX ERROR' MTSP=ISP-1 MTLP=ILP+ILP C !ALIGN IF(MTSP+MTS.EQ.0)GO TO 70 !will need same test on forming H IF(MTLP+MTL.EQ.0)GO TO 70 ! ditto C NCH=0 NCHI=0 NCHI0=0 c c write(0,*)'start algxfs',kx,ixx,jxx,ncorj C DO NC0=1,NCN !BEGIN LOOP OVER INITIAL GROUPS L1=LLCH(1,NC0,IX) L2=LLCH(2,NC0,IX) NC=ITARG(NC0,IX) MC=NSL(NC) SA=QSI(NC) LA=QLI(NC) MCI=NGRPI(NC) ND1=NC C !PRE-SELECT CONFIGS DO KK=1,KM BXIST1(KK)=KGSL(KK,NC).GT.0 !CF DOES/NOT CONTRIB ENDDO C NCHP=0 NCHIP=0 NCHIP0=0 c if(ix.eq.jx)ncnp=nc0 !sync with ls C DO ND0=1,NCNP !BEGIN LOOP OVER FINAL GROUPS L1P=LLCH(1,ND0,JX) L2P=LLCH(2,ND0,JX) ND=ITARG(ND0,JX) MCP=NSL(ND) SAP=QSI(ND) IF(iabs(NMETAG(NC))+iabs(NMETAG(ND)).EQ.2)GO TO 69 !LS SELEC LAP=QLI(ND) MCIP=NGRPI(ND) NDP1=ND C EQGRP=IX.EQ.JX.AND.NC.EQ.ND !WITHIN A GROUP C DO KF=1,KM !INITIALIZE IF(BXIST1(KF))THEN DO KG=1,KM BXIST2(KG,KF)=BXIST0(KG,KF) ENDDO ELSE DO KG=1,KM BXIST2(KG,KF)=.FALSE. ENDDO ENDIF ENDDO C !PRE-SELECT CONFIGS DO KG=1,KM IF(KGSL(KG,ND).LE.0)THEN !CF DOES NOT CONTRIB DO KF=1,KM BXIST2(KG,KF)=.FALSE. ENDDO ENDIF ENDDO C C------------------------------------------------------------ C DETERMINE SLATER STATE INTERACTIONS BETWEEN GROUP CHANNELS C------------------------------------------------------------ C NCHI=NCHI0 DO LI=L1,L2,4 !LOOP OVER INITIAL CHANNEL L C lf2=l2p if(eqgrp)lf2=li c NCHIP=NCHIP0 DO LF=L1P,lf2,4 !LOOP OVER FINAL CHANNEL L C IRSS=0 NLS=0 J1=2 eqgrpl=eqgrpl0.and.eqgrp.and.li.eq.lf c qcor=qptlsj(kx,ixx,jxx,nc0,nd0,li,lf) if(qcor.ne.ncorj)then write(0,*)kx,ixx,jxx,nc0,nd0,li,lf,ncorj,qcor stop 'ncorj mis-match' endif C KK=0 KG2=KM DO KF=1,KM !BEGIN LOOP OVER INITIAL CONFGS C IF(eqgrpl)KG2=KF DO KG=1,KG2 !BEGIN LOOP OVER FINAL CONFGS KK=KK+1 C IF(.NOT.BXIST2(KG,KF))GO TO 733 C EQCFS=KF.EQ.KG EQUAL=EQGRPL.AND.EQCFS ctest equal=.false. EQUALM=EQUAL C if(kf.ge.kg)then i1=1 i2=2 K2=(KF*(KF-1))/2+KG else i1=2 i2=1 K2=(KG*(KG-1))/2+KF endif c !FOR BASIS='RLX' DO I=NW+1,MXORB IGRGR(I)=0 ENDDO c DO I=NF,1,-1 II=QCG(I,KF) DO L=NF,1,-1 J=QCG(L,KG) IF(IEQ(J).EQ.IEQ(II))THEN IF(IGRGR(II).EQ.0)IGRGR(II)=J ENDIF ENDDO ENDDO C IRSS0=IRSS+1 NLS00=NLS C ICLRR=1 C C----------------------------------------------------------------------- C LOOP-OVER ALL POSSIBLE ML,MS, ML',MS' THAT FORM MTML,MTMS, MTML',MTMS' C AND PICK-OUT THE CORRESPONDING SLATERSTATES, FOR THE KF,KG. C----------------------------------------------------------------------- C MTMS=MTS 611 MTML=MTMJ-MTMS LX1=MTMS.NE.-MTS.AND.MTML.NE.MTL IF(MTML.LT.-MTL)GO TO 616 C DVCJ1=VCC(MTL,MTS,MTJ,MTML,MTMS,MTMJ,DFS,MXDFS) C MTMSP=MTSP 622 MTMLP=MTMJ-MTMSP LX2=MTMSP.NE.-MTSP.AND.MTMLP.NE.MTLP IF(MTMLP.LT.-MTLP)GO TO 615 if(iabs(mtmsp-mtms).gt.4)go to 615 C DVCJ2=VCC(MTLP,MTSP,MTJ,MTMLP,MTMSP,MTMJ,DFS,MXDFS) c c write(6,*)mtms,mtml,mtmsp,mtmlp,mtmj,irss C QML=LA 600 LXL1=QML.NE.-LA ML=MTML-QML IF(ML.GT.LI)GO TO 615 IF(-ML.GT.LI)GO TO 604 DVCL1=VCC(LA,LI,MTL,QML,ML,MTML,DFS,MXDFS) C QMS=SA 601 LXS1=QMS.NE.-SA MS=MTMS-QMS IF(MS.GT.1)GO TO 604 IF(-MS.GT.1)GO TO 605 c c write(6,*)sa,'1',mts,qms,ms,mtms,' x ' c x ,la,li,mtl,qml,ml,mtml C DVCS1=VCC(SA,1,MTS,QMS,MS,MTMS,DFS,MXDFS) DVC1=DVCL1*DVCS1*DVCJ1 IF(ABS(DVC1).LT.TTYNY)GO TO 605 c c write(6,*)sa,'1',mts,qms,ms,mtms,' xx ' c x ,la,li,mtl,qml,ml,mtml c write(6,*)dvcs1,dvcl1 C QMLP=LAP cls IF(EQUAL)QMLP=QML 602 LXL2=QMLP.NE.-LAP MLP=MTMLP-QMLP IF(MLP.GT.LF)GO TO 605 IF(-MLP.GT.LF)GO TO 607 DVCL2=VCC(LAP,LF,MTLP,QMLP,MLP,MTMLP,DFS,MXDFS) C QMSP=SAP cls IF(EQUAL)QMSP=QMS 603 LXS2=QMSP.NE.-SAP MSP=MTMSP-QMSP IF(MSP.GT.1)GO TO 606 IF(-MSP.GT.1)GO TO 607 c c write(6,*)sap,'1',mtsp,qmsp,msp,mtmsp,' y ' c x ,lap,lf,mtlp,qmlp,mlp,mtmlp C C SET POINTERS THAT SELECT SLATER STATE INTERACTIONS FOR QML & QMLP C if(eqcfs)then if(qmlp.ge.qml)then i1=1 i2=2 else i1=2 i2=1 endif endif c mej(i1)=qml/2 mej(i2)=qmlp/2 k1=kptcfm(mej(2),mej(1),k2) mej(2)=mej(2)+1 k0=kptcfm(mej(2),mej(1),k2)+1 C C NAM(J2) IS CONSTRUCTED TO SELECT INITIAL & FINAL STATES C HAVING THE CORRECT QML, QMS & QMLP,QMSP. C c If non-trivial time taken in this search, do a double sweep as in c v22.11. The coding below does seem to inhibit compiler optimization. C J2=1 do k=k0,k1 nej(i1)=kinti(k) nej(i2)=kintf(k) j=nej(1) jp=nej(2) jp0=jp kp=k 137 IF(QBMS(J).EQ.QMS.AND.QBMS(JP).EQ.QMSP)THEN J2=J2+1 if(j2.gt.nss)then write(6,*)'sr.algxfs: mxst0/nss exceeded...' write(0,*)'sr.algxfs: mxst0/nss exceeded...' go to 999 endif if(eqcfs.and.qmlp.lt.qml)kp=-kp MAM(J2)=kp QLMC(NF1,J)=(MS+1)/2+ML if(j.ne.jp)then QLMC(NF1,JP)=(MSP+1)/2+MLP else qnf1(jp)=(msp+1)/2+mlp endif ENDIF if(eqcfs.and.QML.eq.QMLP.and.j.ne.jp0)then jp=j j=jp0 kp=-kp go to 137 endif enddo c IF(J2.LT.J1)GO TO 607 C DVCS2=VCC(SAP,1,MTSP,QMSP,MSP,MTMSP,DFS,MXDFS) DVC2=DVCL2*DVCS2*DVCJ2 C DVC12=DVC1*DVC2 IF(ABS(DVC12).LT.TYNY)GO TO 607 IF(EQUAL)THEN cls IF(QMS.NE.QMSP)DVC12=DVC12+DVC12 cls IF(QML.NE.QMLP)DVC12=DVC12+DVC12 EQUALM=QMS.EQ.QMSP.AND.QML.EQ.QMLP ENDIF c c write(6,*)sap,'1',mtsp,qmsp,msp,mtmsp,' yy ' c x ,lap,lf,mtlp,qmlp,mlp,mtmlp c write(6,*)dvcs2,dvcl2 c write(6,*)dvc12 C LX=LXL1.OR.LXL2.OR.LXS1.OR.LXS2 .OR. LX1.OR.LX2 C C------------------------------------------------------------- C CALCULATE THE SLATER-STATE INTERACTION BETWEEN CFS KF AND KG C------------------------------------------------------------- C if(btimex)call cpu_time(timei) c 55 CALL RESX1(QLMC,MAM,qnf1,DFS,MAXEL) c if(btimex)then call cpu_time(timef) time1=time1+timef-timei endif C MXIRSS=MAX(MXIRSS,IRSS) MXNLS=MAX(MXNLS,NLS) IF(IRSS.GT.MXS2C)KPIS=0 IF(NLS.GT.MXS2I)KPIS=-1 IF(KPIS.LE.0)GO TO 619 IF(NF.LT.0)GO TO 999 C IF(ICLRR.EQ.0)GO TO 617 C C--------------------------------------------------------------------- C IF LXL,S,1,2=.TRUE. THE TRANSFORMATION TO THE LS,L'S' REPRESENTATION C IS NOT YET COMPLETE. C--------------------------------------------------------------------- C 607 QMSP=QMSP-2 IF(LXS2)GO TO 603 C 606 QMLP=QMLP-2 IF(LXL2)GO TO 602 C 605 QMS=QMS-2 IF(LXS1)GO TO 601 C 604 QML=QML-2 IF(LXL1)GO TO 600 C C-------------------------------------------------------------- C IF LX1,2=.TRUE. THE TRANSFORMATION TO THE J,MJ REPRESENTATION C IS NOT YET COMPLETE. C-------------------------------------------------------------- C 615 MTMSP=MTMSP-2 C IF(LX2)GO TO 622 C 616 MTMS=MTMS-2 C IF(LX1)GO TO 611 C C CLEAR ARRAYS, IF NOT ALREADY DONE C 617 IF(ICLRR.NE.0)THEN ICLRR=-ICLRR GO TO 55 ENDIF C 733 NADS2(KK)=IRSS C c nkk=nads2(kk)-nads2(kk-1) c write(6,*)'***** kf,kg:',kf,kg,nkk c if(nkk.eq.xxx)then !select particular value for breakpoint c write(0,*)'we are here' c endif c do ijk=nads2(kk-1)+1,nads2(kk) c write(6,777)nstj2(ijk),nstj2d(ijk),msss(ijk),dsss(ijk) c 777 format(3i5,f12.6) c enddo c do ijk=nls00+1,nls c write(6,778)ijk,(qsss(lll,ijk),lll=1,5) c 778 format(i4,2x,5i4) c enddo c ENDDO !END LOOP KG C ENDDO !END LOOP KF C C------------------------------------------------------------------ C NOW DETERMINE THE INTERACTION BETWEEN TERMS OF THE LSP GROUPS C------------------------------------------------------------------ C if(btimex)call cpu_time(timei) c istrt0=0 KF0=0 DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS J1=MD1+MCI j=jndex(j1) KF=NFK(J1) C IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN NGSYM=KGSL(KF,NC) !POS WITHIN CF ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IEND,KF,NGSYM,1,0) C ISTRT0=ISTRT-MTGD1 !ALLOW FOR RE-DEFINITION IF(IEND.LT.0)GO TO 999 !FAIL TO READ REQUIRED DATA KF0=KF ENDIF C II=NFI(J1) IF(BFAST)THEN J2=JTGD(II)+ISTRT0 !relative start flagged do jj=jyi(kf),jyf(kf) jy=j2+jj if(abs(dc(jy)).lt.tyny)then mam(jj)=0 else mam(jj)=jy endif enddo ELSE do jj=jyi(kf),jyf(kf) mam(jj)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt0 k2=k2+istrt0 do k12=k1,k2 jj=idc(k12) mam(jj)=k12 enddo ENDIF C istrt=0 KG0=0 DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS J1P=MDP1+MCIP IF(eqgrpl.and.J1P.GT.J1-ione0)GO TO 11 c if(becor)ncorj=ncorj+1 !need for dwxbp reversed symms c jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)go to 10 !neglect corr-corr, alg or ener C KG=NFK(J1P) C IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN LGSYM=KGSL(KG,ND) !POS WITHIN CF ISTRT=IEND+1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C ISTRT=ISTRT-MTGD1 !ALLOW FOR RE-DEFINITION IF(IFIN.LT.0)GO TO 999 !FAIL TO READ REQUIRED DATA KG0=KG ENDIF C II=NFI(J1P) IF(BFAST)THEN !nam not used, only mam J2P=JTGD(II)+ISTRT !relative start flagged ELSE do jj=jyi(kg),jyf(kg) nam(jj)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt k2=k2+istrt do k12=k1,k2 jj=idc(k12) nam(jj)=k12 enddo ENDIF C IF(eqgrpl)THEN !KG.LE.KF HERE KK=(KF*(KF-1))/2 + KG if(kf.lt.kg)stop'algxfs: kf.lt.kg?' ELSE KK=KM*(KF-1)+KG ENDIF C CALL RESX2(DC,mam,nam,KK) C if(.not.becor)NCORJ=NCORJ+1 !reverse of above C IF(IRS.GT.MXRSS)KPI=0 IF(NL.GT.MAXMI)KPI=-1 IF(KPI.LE.0)GO TO 619 IF(NF.LT.0)GO TO 999 C IF(MPRINT.GT.0)THEN NCH=NCHI+MD1 NCHP=NCHIP+MDP1 IF(IRS-IRS0.EQ.5)THEN WRITE(6,1201)NCORJ,KX,IX,JX,NCH,NCHP,IRS,NL, X (MSS(N),DSS(N),N=IRS0,IRS) ELSEIF(IRS.GE.IRS0)THEN WRITE(6,1202)NCORJ,KX,IX,JX,NCH,NCHP,IRS,NL, X (MSS(N),DSS(N),N=IRS0,IRS) ENDIF WRITE(6,1201) ELSEIF(MPRINT.EQ.0)THEN IF(NCHP.EQ.NCH)WRITE(6,130)NCORJ,KX,IX,JX, X NCH,NCHP,IRS,NL ENDIF C 10 NADR(NCORJ)=IRS !MUST BE ALLOWED C ENDDO !END LOOP OVER FINAL TERMS C 11 ENDDO !END LOOP OVER INITIAL TERMS c if(btimex)then call cpu_time(timef) time2=time2+timef-timei endif C NCHIP=NCHIP+MCP ENDDO !END LOOP OVER FINAL L C NCHI=NCHI+MC ENDDO !END LOOP OVER INITIAL L C 69 NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP !=NCHIP ENDDO !END LOOP OVER FINAL GROUPS C NCHI0=NCHI0+((L2-L1)/4+1)*MC !=NCHI ENDDO !END LOOP OVER INITIAL GROUPS C 70 ENDDO !END LOOP OVER FINAL LS SYMMS C ENDDO !END LOOP OVER INITIAL LS SYMMS C C----------------------------------------------------------------------- C if(btimex)then call cpu_time(timef) times=timef-times c cpar if(iam.ge.0)then !par c c ccpar write(iwp,*)'resx1',time1 !par ccpar write(iwp,*)'resx2',time2 !par c cpar write(iwp,*)'Ending proc',iam,'symmetry',kx,':' !par cpar x ,'time=',nint(times),'sec' !par cpar else !par c c write(iw,*)'resx1',time1 c write(iw,*)'resx2',time2 c write(iw,*)'Ending symmetry',kx,' :' x ,'time=',nint(times),'sec' cpar endif !par endif C C----------------------------------------------------------------------- C 99 ENDDO !END LOOP OVER JP SYMMETRIES C IF(IADJ.NE.NCORJ)THEN WRITE(6,*)'GLOBAL INDEX ERROR:',IADJ,NCORJ !remove evntly GO TO 999 ENDIF C IADJ=NCORJ C C RESULTS C IF(MPRINT.GE.0)WRITE(6,123)MXS2C,MXS2I,MXIRSS,MXNLS IF(MPRINT.EQ.0)GO TO 900 !RETURN IF(MPRINT.GT.0)GO TO 620 C 619 WRITE(6,1202)NCORJ,INASTJ0,MXX,MXX,NCHMX,NCHMX,IRS,NL IF(KPI.LE.0)GO TO 991 C WRITE(6,123)MXS2C,MXS2I,MXIRSS,MXNLS IF(KPIS.LE.0)GO TO 9910 C GO TO 900 !RETURN C 620 WRITE(6,2011) M197=197-LCONDWJ-3 DO L=1,NL IF(QSS(5,L).GT.M197)THEN WRITE(6,244)L,(QSS(K,L),K=1,5) ELSE WRITE(6,2444)L,(QSS(K,L),K=1,5) if(qss(5,l).gt.150)stop 'N&V Index error...' ENDIF ENDDO C C----------------------------------------------------------------------- C if(btimex)then call cpu_time(timef) times=timef-time0 c c if(iabs(modd).le.1)then c cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for algxfs:' !par cpar x ,' time=',nint(times),'sec' !par cpar else !par write(iw,*)'Ending algxfs: time=',nint(times),'sec' cpar endif !par c endif endif C C----------------------------------------------------------------------- C GO TO 900 !RETURN C C PRINT FAILURE DIAGNOSTIC (DIMENSION FAILURE NOT SEPARATE) C 991 IF(KPI.EQ.0)WRITE(6,1203) IF(KPI.LT.0)WRITE(6,1204) GO TO 999 9910 IF(KPIS.EQ.0)WRITE(6,1205) IF(KPIS.LT.0)WRITE(6,1206) C 999 WRITE(6,190) NF=-1 !<-------------------- ABNORMAL RETURN C 900 CONTINUE C !F95 C EX-COMMON /NSTS2/ !F95 IF(ALLOCATED(NADS2))THEN !F95 DEALLOCATE (NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXFS: DE-ALLOCATION FAILS FOR NADS2,NSTJ2...'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 C EX-COMMON/DMQSSS/ !F95 IF(ALLOCATED(DSSS))THEN !F95 DEALLOCATE (DSSS,MSSS,QSSS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXFS: DE-ALLOCATION FAILS FOR DSSS,MSSS,QSSS'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C RETURN !<------------------- RETURN C 102 FORMAT(/' ATTENTION: FINE-STRUCTURE COLLISION ALGEBRA IS ', X 'RESTRICTED BETWEEN TARGET CFS AS SPECIFIED BY KUTSSX=',I4) 123 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXS2C,MXS2I) ',I8,I6, X10X,'USED: ',I8,I6) 130 FORMAT(I9,I5,2I4,2I5,I9,I6) 190 FORMAT( ' SR.ALGXFS: FAILURE - CASE SKIPPED') 244 FORMAT(I6,7X,4I5,I7) CF77 401 FORMAT(/'***ERROR: SET MXAJS=MXADJ FOR TWO-BODY' !F77 CF77 X,' FINE-STRUCTURE') !F77 1201 FORMAT(I9,I5,2I4,2I5,I9,I6,6(I6,F9.4)) 1202 FORMAT(I9,I5,2I4,2I5,I9,I6,6(I6,F9.4)/(47X,6(I6,F9.4))) 1203 FORMAT(' *** STORAGE MAYBE EXCEEDED IN SR.RESX2: INCREASE MXRSS') 1204 FORMAT(' *** STORAGE MAYBE EXCEEDED IN SR.RESX2: INCREASE MAXMI') 1205 FORMAT(' *** STORAGE EXCEEDED IN SR.RESX1: INCREASE MXS2C') 1206 FORMAT(' *** STORAGE EXCEEDED IN SR.RESX1: INCREASE MXS2I') 2011 FORMAT(/' REFERENCE LIST OF MAGNETIC INTEGRALS N AND V', X' (EXCHANGE LAMBDA = LBD + INT(J))' X /' INDEX',5X,'N( A B C D 2LBD+200)',7X, X 'INDEX',2X,'V( A B C D 2LBD+100)') 2444 FORMAT(51X,I6,4X,4I5,I7) 3033 FORMAT(//' ALGEBRA OF THE MUTUAL SPIN-ORBIT (A), SPIN-OTHER-' X,'ORBIT (B) AND SPIN-SPIN (C) INTERACTIONS:',10X,'KUTSSX =',I3,A1) 3050 FORMAT(I9,I5,2I4,2I5,I9,I6,' STORAGE RESTRICTIONS FOR ', X'(MXADJ,MAXJG,MXSYJ,MXSYJ,MAXDK,MAXDK,MXRSS,MAXMI)' X/7X,'NP',2X,'SYJ',2X,'SY',1X,'SYP',3X,'CH',2X,'CHP',7X, X'CN',3X,'IND',6(3X,'I(Y) X(A-D)')) 3054 FORMAT('SR.ALGXFS: ALLOCATION INCREASES NUMBER OF FS MATRIX' !F95 X,' ELEMENTS IADJ =',I10,' .GT. MXAJS=',I10) !F95 CF77 3055 FORMAT(' SR.ALGXFS: NUMBER OF FS MATRIX' !F77 CF77 X,' ELEMENTS IADJ =',I10,' .GT. MXAJS=',I10) !F77 C END C C ******************* C SUBROUTINE ALGXLS(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,DFS,MAXEL) C C----------------------------------------------------------------------- C C SR.ALGXLS CALCULATES EIE 2-BODY NFS COLLISION ALGEBRA IN LS-COUPLING. C IT HAS SIMILARITIES WITH WE'S COLALG (OF COURSE). C C IT CALLS: C SR.FLGLX0 C SR.FLGLX1 C SR.FLGLX2 C SR.FLGLX3 C FN.VCC C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_DXRL, ONLY: BDXRL,DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_DXRLS, ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 USE COMMON_NRBNF1, ONLY: BNRBNF1,DEK,BFALL !F95 USE COMMON_NRBFL0, ONLY: BNRBFL0,KINTI,KINTF,KEN2,KPTCFM,KINT !F95 X ,MPOINT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C PARAMETER (MXD27=MAXCF*MAXCF) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-5) PARAMETER (TTYNY=TYNY/1.D3) C INTEGER SA,SAP C INTEGER*8 MDCF8,MDCFT8 CF77 INTEGER*8 NRK !F77 C LOGICAL BVC,BXIST0,BXIST2,BKUTOO,BDLBD,BXIST1,BFAST X ,LX,LP,LXS1,LXS2,LXL1,LXL2,EQGRP,EQCFS,EQUAL,EQUALM x ,eqgrpl,eqgrpl0,btime,btimex,becor !,bcor,bcorr CF77 X ,BFALL,BFALLS !F77 C REAL*8 DC C DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*) DIMENSION QLMC(MAXEL,*),QBML(*),JYI(*),QBMS(*),JYF(*),DFS(*) X ,nej(2),mej(2) DIMENSION BXIST2(MAXCF,MAXCF) C COMMON /BASIC/NF,KF,KG,J1,J2,J1P,J2P,ND1,NDP1,LL(2),NGAP COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD c COMMON /CHARY/DEY(MAXGR) COMMON /CMDVC/DVC12,LX,ICLRR,EQUALM COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 c COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION c X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRL/IRK,IRK0,IOS,IOS0 CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /XSSADR/IRKS0,IRLS0 COMMON /NRBBBB/BXIST0(MAXCF,MAXCF),BXIST1(MAXCF) COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ X ,LVMIN,LVMAX C COMMON /NRBDW3/KACT(MAXCF,MAXCF) COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) C COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex C EQUIVALENCE (LI,LL(1)),(LF,LL(2)) C C----------------------------------------------------------------------- C c some test set-up switches that user joe should not need to touch. c c if elastic is dropped here then it has an effect on inelastic c transitions between terms of same symmetry because they are mixed c cold ione0=0 !=0 retain elastic here c c if bcor then we have algebraic correlation, and we know how ordered c c bcor=km*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD(NCOR) c c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- c if(btimex)then c if(iabs(modd).le.1)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for algxls' !par cpar else !par write(iw,*)'Starting algxls' cpar endif !par c endif call cpu_time(timei) time0=timei endif C C INITIALIZATIONS C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C IF(KUTDSK.LT.KM)THEN IEND=MTGD !FOR DISKDC MTGD1=MTGD+1 CTEST CALL DISKDC(IUD,DC,IDC,1,0,0,0,0,0) !REPOINT ENDIF C KOLDOO=KUTOOX BKUTOO=KUTOOX.NE.0 BDLBD=IABS(MODD).LT.2.OR.BKUTOO C LP=MPRINT.GT.0 C NSS=JYF(KM) !F95 CF77 NSS=MXST0 !F77 C NF1=NF+1 c KSP=NF1-(NF1/2)*2 !TEST ONLY C INASTX=KF !SYMLS TRANSFER NCHMX=KG ! " " C IF(MAXLT.LT.0)THEN MTLO1=-1 MTLO2=-1 ELSE MTLO1=MAX(MAXLX,1,MINLT-1) MTLO1=2*MTLO1+2 !SCALE FROM ONE L PER PI MTLO2=MTLO1+2 ENDIF C DO I=1,MAXGR IGRGR(I)=I ENDDO C C SET POINTERS TO ML BOUNDARIES C !F77 CF77 IF(QMCL/2.GT.MXD02)THEN !F77 CF77 WRITE(6,*)'*** SR.ALGXLS: INCREASE MXD02 TO:',QMCL/2 !F77 CF77 WRITE(0,*)'*** SR.ALGXLS: INCREASE MXD02 TO:',QMCL/2 !F77 CF77 GO TO 999 !F77 CF77 ENDIF !F77 C C EX-COMMON/NRBFL0/ !F95 C !F95 MXD02=QMCL/2 !F95 MXD03=MXD02+1 !F95 IXD19=(KM*(KM+1))/2 !F95 C !F95 ALLOCATE (KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F95 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:IXD19) !F95 X ,MPOINT(-MXD02:MXD03,KM) !F95 X ,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: ALLOCATION FAILS FOR KPTCFM,MPOINT ETC.' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BNRBFL0=.TRUE. !F95 C DO K=1,KM J=JYI(K) ML0=QBML(J) ML=ML0/2 J=J-1 DO M=MXD03,ML,-1 MPOINT(M,K)=J ENDDO DO J=JYI(K),JYF(K) ML=QBML(J) IF(ML.LT.ML0)THEN ML0=ML0/2 ML1=1+ML/2 DO M=ML0,ML1,-1 MPOINT(M,K)=J-1 ENDDO ML0=ML ENDIF ENDDO ML=ML/2 MPOINT(ML,K)=JYF(K) ML=ML-1 DO M=ML,-MXD02,-1 MPOINT(M,K)=JYF(K) ENDDO ENDDO C C SET-UP POINTERS TO SLATER-STATE INTERACTIONS C KK=0 KINT=0 KPTCFM(MXD03,MXD02,1)=0 C DO KF=1,KM DO KG=1,KF KK=KK+1 C IF(BXIST0(KG,KF))THEN CALL FLGLX0(KK,QLMC,MAXEL) ELSE DO M=MXD02,-MXD02,-1 DO MP=MXD02,-MXD02,-1 KPTCFM(MP,M,KK)=KINT ENDDO ENDDO ENDIF c c write(0,*)'*** kg, kf, kint:',kg,kf,kint c IF(KK.GT.1)KPTCFM(MXD03,MXD02,KK)=KPTCFM(-MXD02,-MXD02,KK-1) C MPP=-MXD02 DO M=MXD02-1,-MXD02,-1 IF(KF.EQ.KG)MPP=M+1 KPTCFM(MXD03,M,KK)=KPTCFM(MPP,M+1,KK) c kptcfm(mxd03,m,kk)=kptcfm(m,mxd03,kk) ENDDO c c checks and debug print (remove/comment-out eventually) c c do m=mxd02,-mxd02,-1 c if(kf.eq.kg)mpp=m c do mp=mxd02,mpp,-1 c do k=kptcfm(mp+1,m,kk)+1,kptcfm(mp,m,kk) c if(k.gt.mxstx)stop 'increase mxstx' c j=kinti(k) c jd=kintf(k) c if(qbml(jd).ne.2*mp.or.qbml(j).ne.2*m)then c write(6,*)kg,jd,mp,qbml(jd)/2,' cf j ml qbml', c x kf,j,m,qbml(j)/2,' kint=',k c stop 'algxls: ml-mismatch' c endif c enddo c enddo c enddo C ENDDO ENDDO C IF(KINT.GT.MXSTX)THEN WRITE(6,*)'SR:ALGXLS: INCREASE MXSTX TO:',KINT WRITE(0,*)'INCREASE MXSTX TO:',KINT GO TO 999 ENDIF C C EX-COMMON/DXRL/ !F95 ALLOCATE (DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),NAD(0:IADD) !F95 X ,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: ALLOCATION FAILS FOR DRK,QRL,NRK,NAD' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BDXRL=.TRUE. !F95 C !F95 C EX-COMMON/NRBNF1/ !F95 IRKO=1 !F95 IF(BKUTOO)IRKO=MXRKO !F95 ALLOCATE (DEK(IRKO),BFALL(IRKO),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: ALLOCATION FAILS FOR DEK, BFALL' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 BNRBNF1=.TRUE. !F95 C !F95 C EX-COMMON/DXRLS/ !F95 IROS=1 !F95 IF(BKUTOO)IROS=MXROS !F95 ALLOCATE (DRKS(MXRKS),DEKS(IROS),QRLS(5,MXRLS),NRKS(MXRKS) !F95 X ,BFALLS(IROS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: ALLOCATION FAILS FOR DRKS,DEKS,QRLS ETC'!F95 NF=0 !F95 GO TO 99 !F95 ENDIF !F95 C !F95 C EX-COMMON /NSTS/ !F95 ALLOCATE (NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F95 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: ALLOCATION FAILS FOR NADS,NSTJ,IORIG ETC'!F95 NF=0 !F95 GO TO 99 !F95 ENDIF !F95 C !F95 C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C NOW GENERATE PARTIAL WAVE ALGEBRA, LOOPING OVER INITIAL AND FINAL C CHANNELS RESOLVED BY CONTINUUM L,S=1/2 COUPLED TO TARGET SYMMETRY C GROUPS, THEN RESOLVE BY INDIVIDUAL TERMS. C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C IF(.NOT.BKUTOO) XWRITE(6,150)MAXAD,MAXSL,MAXDI,MAXDI,MAXRK,MAXRL,MXDFS IF(BKUTOO) XWRITE(6,151)MAXAD,MAXSL,MAXDI,MAXDI,MAXRK,MAXRL,MXDFS,KUTOOX C JOS=0 J=IADD !NNN IF(IADD.GT.MAXAD)THEN IF(MAXAD.GT.0)WRITE(6,133)IADD,MAXAD !F95 CF77 GO TO 91 !DIMENSION EXCEEDED, BAIL OUT !F77 ENDIF C JOS=1 IRK=0 IRL=0 NAD(0)=0 NCOR=0 C MXIRKS=0 MXIRLS=0 JOSS=1 NADS(0)=0 C C----------------------------------------------------------------------- C LOOP OVER TOTAL SYMMETRIES C----------------------------------------------------------------------- C DO IX=1,INASTX C IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 c nwt=is if(il.gt.maxlx)nwt=-2*is+2 C C----------------------------------------------------------------------- C if(btimex)then if(iabs(modd).gt.1)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'Starting proc',iam !par cpar x ,'algxls symmetry',ix,':',nwt,il,ip !par cpar call flush(iwp) !par cpar else !par write(iw,*)'Starting algxls symmetry',ix,':',nwt,il,ip cpar endif !par endif time1=dzero time2=dzero call cpu_time(timei) times=timei endif C C----------------------------------------------------------------------- C C !ALIGN MTS=IS-1 MTL=IL+IL MTP=IP+IP C MTML=MTL !0 !TEST ONLY, SLOW!! MTMS=MTS !KSP !*MUST* ADJUST VCG MS.ge.-1 C IF(BKUTOO.AND.IL.GT.MAXLOO)THEN KUTOOX=0 BKUTOO=.FALSE. ENDIF C c write(0,*)ix,nadg(ix),ncor if(ncor.ne.nadg(ix))stop 'ncor.ne.nadg(ix)' !shouldn't happen c NCN=NCHG(IX) C NCHI=0 NCHI0=0 C DO NC0=1,NCN !BEGIN LOOP OVER INITIAL GROUPS L1=LLCH(1,NC0,IX) L2=LLCH(2,NC0,IX) NC=ITARG(NC0,IX) MC=NSL(NC) SA=QSI(NC) LA=QLI(NC) MCI=NGRPI(NC) ND1=NC C !PRE-SELECT CONFIGS DO KK=1,KM BXIST1(KK)=KGSL(KK,NC).GT.0 !CF DOES/NOT CONTRIB ENDDO C NCHIP=0 NCHIP0=0 C DO ND0=1,NC0 !BEGIN LOOP OVER FINAL GROUPS L1P=LLCH(1,ND0,IX) L2P=LLCH(2,ND0,IX) ND=ITARG(ND0,IX) MCP=NSL(ND) SAP=QSI(ND) IF(ABS(SA-SAP).GT.2)GO TO 69 !unnecessary... IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 69 LAP=QLI(ND) MCIP=NGRPI(ND) NDP1=ND C EQGRP=NC.EQ.ND !WITHIN A GROUP C DO KF=1,KM !INITIALIZE IF(BXIST1(KF))THEN DO KG=1,KM BXIST2(KG,KF)=BXIST0(KG,KF) ENDDO ELSE DO KG=1,KM BXIST2(KG,KF)=.FALSE. ENDDO ENDIF ENDDO C !PRE-SELECT CONFIGS DO KG=1,KM IF(KGSL(KG,ND).LE.0)THEN !CF DOES NOT CONTRIB DO KF=1,KM BXIST2(KG,KF)=.FALSE. ENDDO ENDIF ENDDO C C------------------------------------------------------------ C DETERMINE SLATER STATE INTERACTIONS BETWEEN GROUP CHANNELS C------------------------------------------------------------ C NCHI=NCHI0 DO LI=L1,L2,4 !LOOP OVER INITIAL CHANNEL L C lf2=l2p if(eqgrp)lf2=li c NCHIP=NCHIP0 DO LF=L1P,lf2,4 !LOOP OVER FINAL CHANNEL L C IRKS=0 IRLS=0 JPLANT(1)=0 J1=2 eqgrpl=eqgrpl0.and.eqgrp.and.li.eq.lf C KK=0 KG2=KM DO KF=1,KM !BEGIN LOOP OVER INITIAL CONFGS C IF(eqgrpl)KG2=KF DO KG=1,KG2 !BEGIN LOOP OVER FINAL CONFGS KK=KK+1 C IF(.NOT.BXIST2(KG,KF))GO TO 733 C EQCFS=KF.EQ.KG EQUAL=EQGRPL.AND.EQCFS ctest equal=.false. EQUALM=EQUAL C if(kf.ge.kg)then i1=1 i2=2 K2=(KF*(KF-1))/2+KG else i1=2 i2=1 K2=(KG*(KG-1))/2+KF endif c !FOR BASIS='RLX' DO I=NW+1,MXORB IGRGR(I)=0 ENDDO c DO I=NF,1,-1 II=QCG(I,KF) DO L=NF,1,-1 JJ=QCG(L,KG) IF(IEQ(JJ).EQ.IEQ(II))THEN IF(IGRGR(II).EQ.0)IGRGR(II)=JJ ENDIF ENDDO ENDDO C IRKS0=IRKS+1 IRLS0=IRLS C ICLRR=1 C C------------------------------------------------------------- C NOW LOOP-OVER ALL POSSIBLE ML,MS,ML',MS' THAT FORM MTML,MTMS C AND PICK-OUT THE CORRESPONDING SLATERSTATES, FOR THE KF,KG. C------------------------------------------------------------- C QML=LA 600 LXL1=QML.NE.-LA ML=MTML-QML IF(ML.GT.LI)GO TO 617 IF(-ML.GT.LI)GO TO 604 DVCL1=VCC(LA,LI,MTL,QML,ML,MTML,DFS,MXDFS) C QMS=SA 601 LXS1=QMS.NE.-SA MS=MTMS-QMS IF(MS.GT.1)GO TO 604 IF(-MS.GT.1)GO TO 605 c c write(6,*)sa,'1',mts,qms,ms,mtms,' x ' c x ,la,li,mtl,qml,ml,mtml C DVCS1=VCC(SA,1,MTS,QMS,MS,MTMS,DFS,MXDFS) DVC1=DVCL1*DVCS1 IF(ABS(DVC1).LT.TTYNY)GO TO 605 c c write(6,*)sa,'1',mts,qms,ms,mtms,' xx ' c x ,la,li,mtl,qml,ml,mtml c write(6,*)dvcs1,dvcl1 C QMLP=LAP IF(EQUAL)QMLP=QML 602 LXL2=QMLP.NE.-LAP MLP=MTML-QMLP IF(MLP.GT.LF)GO TO 605 IF(-MLP.GT.LF)GO TO 607 DVCL2=VCC(LAP,LF,MTL,QMLP,MLP,MTML,DFS,MXDFS) C QMSP=SAP IF(EQUAL)QMSP=QMS 603 LXS2=QMSP.NE.-SAP MSP=MTMS-QMSP IF(MSP.GT.1)GO TO 606 IF(-MSP.GT.1)GO TO 607 c c write(6,*)sap,'1',mts,qmsp,msp,mtms,' y ' c x ,lap,lf,mtl,qmlp,mlp,mtml C C SET POINTERS THAT SELECT SLATER STATE INTERACTIONS FOR QML & QMLP C if(eqcfs)then if(qmlp.ge.qml)then i1=1 i2=2 else i1=2 i2=1 endif endif c mej(i1)=qml/2 mej(i2)=qmlp/2 k1=kptcfm(mej(2),mej(1),k2) mej(2)=mej(2)+1 k0=kptcfm(mej(2),mej(1),k2)+1 C C MAM(J2) IS CONSTRUCTED TO SELECT INITIAL & FINAL STATES C HAVING THE CORRECT QML, QMS & QMLP,QMSP. C c If non-trivial time taken in this search, do a double sweep as in c v22.11. The coding below does seem to inhibit compiler optimization. C c write(6,*)qml,qms,' ml ms ',qmlp,qmsp,' k0 k1 ',k0,k1 c J2=1 do k=k0,k1 nej(i1)=kinti(k) nej(i2)=kintf(k) j=nej(1) jp=nej(2) jj=jp kp=k 137 IF(QBMS(J).EQ.QMS.AND.QBMS(JP).EQ.QMSP)THEN J2=J2+1 if(j2.gt.nss)then write(6,*)'sr.algxls: mxst0/nss exceeded...' write(0,*)'sr.algxls: mxst0/nss exceeded...' go to 999 endif if(eqcfs.and.qmlp.lt.qml)kp=-kp MAM(J2)=kp QLMC(NF1,J)=(MS+1)/2+ML QLMC(NF1,JP)=(MSP+1)/2+MLP ENDIF if(eqcfs.and.QML.eq.QMLP.and.j.ne.jj)then jp=j j=jj kp=-kp go to 137 endif enddo c IF(J2.LT.J1)GO TO 607 C DVCS2=VCC(SAP,1,MTS,QMSP,MSP,MTMS,DFS,MXDFS) DVC2=DVCL2*DVCS2 C DVC12=DVC1*DVC2 IF(ABS(DVC12).LT.TYNY)GO TO 607 IF(EQUAL)THEN IF(QMS.NE.QMSP)DVC12=DVC12+DVC12 IF(QML.NE.QMLP)DVC12=DVC12+DVC12 EQUALM=QMS.EQ.QMSP.AND.QML.EQ.QMLP ENDIF c c write(6,*)sap,'1',mts,qmsp,msp,mtms,' yy ' c x x ,lap,lf,mtl,qmlp,mlp,mtml c write(6,*)dvcs2,dvcl2 c write(6,*)dvc12 C LX=LXL1.OR.LXL2.OR.LXS1.OR.LXS2 C C------------------------------------------------------------- C CALCULATE THE SLATER-STATE INTERACTION BETWEEN CFS KF AND KG C------------------------------------------------------------- C if(btimex)call cpu_time(timei) c 55 CALL FLGLX1(QLMC,MAM,DFS,MAXEL) c if(btimex)then call cpu_time(timef) time1=time1+timef-timei endif C MXIRKS=MAX(MXIRKS,IRKS) MXIRLS=MAX(MXIRLS,IRLS) IF(IRLS.GT.MXRLS)JOSS=-1 IF(IRKS.GT.MXRKS)JOSS=0 IF(JOSS.LE.0)GO TO 67 !DIMENSION EXCEEDED IF(NF.LT.0)GO TO 999 C IF(ICLRR.EQ.0)GO TO 617 C C-------------------------------------------------------------- C IF LX=.TRUE. THE TRANSFORMATION TO THE LS,L'S' REPRESENTATION C IS NOT YET COMPLETE. C-------------------------------------------------------------- C 607 QMSP=QMSP-2 IF(LXS2)GO TO 603 C 606 QMLP=QMLP-2 IF(LXL2)GO TO 602 C 605 QMS=QMS-2 IF(LXS1)GO TO 601 C 604 QML=QML-2 IF(LXL1)GO TO 600 C C CLEAR ARRAYS, IF NOT ALREADY DONE C 617 IF(ICLRR.NE.0)THEN ICLRR=-ICLRR GO TO 55 ENDIF C 733 NADS(KK)=IRKS C c write(6,*)'***** kf,kg:',kf,kg,nads(kk)-nads(kk-1) c do ijk=nads(kk-1)+1,nads(kk) c write(6,777)nstj(ijk),nstjd(ijk),nrks(ijk),drks(ijk) c 777 format(3i5,f12.6) c enddo c do ijk=1,irls c write(6,778)ijk,(qrls(lll,ijk),lll=1,5) c 778 format(i4,2x,5i4) c enddo ENDDO !END LOOP KG C ENDDO !END LOOP KF C C------------------------------------------------------------------ C NOW DETERMINE THE INTERACTION BETWEEN TERMS OF THE LSP GROUPS C------------------------------------------------------------------ C if(btimex)call cpu_time(timei) c istrt0=0 KF0=0 DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS J1=MD1+MCI j=jndex(j1) KF=NFK(J1) C IF(KF.GT.KUTDSK.AND.KF.NE.KF0)THEN NGSYM=KGSL(KF,NC) !POS WITHIN CF ISTRT=MTGD1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IEND,KF,NGSYM,1,0) C ISTRT0=ISTRT-MTGD1 !ALLOW FOR RE-DEFINITION IF(IEND.LT.0)GO TO 999 !FAIL TO READ REQUIRED DATA KF0=KF ENDIF C II=NFI(J1) IF(BFAST)THEN J2=JTGD(II)+ISTRT0 !relative start flagged do jj=jyi(kf),jyf(kf) jx=j2+jj if(abs(dc(jx)).lt.tyny)then mam(jj)=0 else mam(jj)=jx endif enddo ELSE do jj=jyi(kf),jyf(kf) mam(jj)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt0 k2=k2+istrt0 do k12=k1,k2 jj=idc(k12) mam(jj)=k12 enddo ENDIF C istrt=0 KG0=0 DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS J1P=MDP1+MCIP IF(eqgrpl.and.J1P.GT.J1-ione0)GO TO 11 c jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then !neglect corr.-corr. if(becor)then ncor=ncor+1 !needed for bp, but not strictly ls go to 10 endif go to 11 endif C KG=NFK(J1P) C IF(KG.GT.KUTDSK.AND.KG.NE.KG0)THEN LGSYM=KGSL(KG,ND) !POS WITHIN CF ISTRT=IEND+1 C CALL DISKDC(IUD,DC,IDC,ISTRT,IFIN,KG,LGSYM,1,0) C ISTRT=ISTRT-MTGD1 !ALLOW FOR RE-DEFINITION IF(IFIN.LT.0)GO TO 999 !FAIL TO READ REQUIRED DATA KG0=KG ENDIF C II=NFI(J1P) IF(BFAST)THEN J2P=JTGD(II)+ISTRT !relative start flagged c do jj=jyi(kg),jyf(kg) !slower, no gain in flglx2 c if(abs(dc(j2p+jj)).lt.tyny)then c nam(jj)=0 c else c nam(jj)=j2p+jj c endif c enddo ELSE do jj=jyi(kg),jyf(kg) nam(jj)=0 enddo k2=jtgd(ii) !absolute end flagged if(k2.lt.0)then !bdisk first k2=-k2 k1=mtgd else k1=jtgd(ii-1) !start k1=iabs(k1) !case bdisk second endif k1=k1+1+istrt k2=k2+istrt do k12=k1,k2 jj=idc(k12) nam(jj)=k12 enddo ENDIF C IF(eqgrpl)THEN !KG.LE.KF HERE KK=(KF*(KF-1))/2 + KG if(kf.lt.kg)stop'algxls: kf.lt.kg?' ELSE KK=KM*(KF-1)+KG ENDIF C CALL FLGLX2(DC,mam,nam,KK) C NCOR=NCOR+1 !reverse of above C IF(IRL.GT.MAXRL)JOS=-1 IF(IRK.GT.MAXRK)JOS=0 IF(JOS.LE.0)GO TO 67 !DIMENSION EXCEEDED IF(NF.LT.0)GO TO 999 C IF(LP)THEN !.AND.IRK.GE.IRK0 NCH=NCHI+MD1 NCHP=NCHIP+MDP1 IF(IRK-IRK0.NE.5)THEN WRITE(6,120)NCOR,IX,NCH,NCHP,IRK,IRL X ,(NRK(I),DRK(I),I=IRK0,IRK) ELSE WRITE(6,119)NCOR,IX,NCH,NCHP,IRK,IRL X ,(NRK(I),DRK(I),I=IRK0,IRK) ENDIF IF(BKUTOO)WRITE(6,121)(NRK(I),DEK(I),I=IRK0,IRK) WRITE(6,120) ENDIF C c write(72,*)ix,md1,mdp1,j,jp,ncor,irk 10 NAD(NCOR)=IRK C ENDDO !END LOOP OVER FINAL TERMS C 11 ENDDO !END LOOP OVER INITIAL TERMS c if(btimex)then call cpu_time(timef) time2=time2+timef-timei endif C NCHIP=NCHIP+MCP ENDDO !END LOOP OVER FINAL L C NCHI=NCHI+MC ENDDO !END LOOP OVER INITIAL L C 69 NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP !=NCHIP ENDDO !END LOOP OVER FINAL GROUPS C NCHI0=NCHI0+((L2-L1)/4+1)*MC !=NCHI ENDDO !END LOOP OVER INITIAL GROUPS C IF(MTL.LT.MTLO1)NCOR1=NCOR IF(MTL.LT.MTLO2)NCOR2=NCOR C KUTOOX=KOLDOO BKUTOO=KUTOOX.NE.0 C C----------------------------------------------------------------------- C if(btimex)then call cpu_time(timef) times=timef-times c if(iabs(modd).gt.1)then c cpar if(iam.ge.0)then !par c ccpar write(iwp,*)'flglx1',time1 !par ccpar write(iwp,*)'flglx2',time2 !par c cpar write(iwp,*)'Ending proc',iam !par cpar x ,'algxls symmetry',ix,':',' nchan=',nchi !par cpar x ,'time=',nint(times),'sec' !par cpar else !par c c write(iw,*)'flglx1',time1 c write(iw,*)'flglx2',time2 c write(iw,*)'Ending algxls symmetry ',ix,':',' nchan=',nchi x ,'time=',nint(times),'sec' cpar endif !par endif endif C C----------------------------------------------------------------------- C ENDDO !END LOOP OVER SYMMETRIES C C C------------------------------------------------------------------- C C NOW EXCHANGE CAN BE NEGLECTED, ADD-IN HIGHER-L DIRECT VIA SYMMETRY C RELATION. C C------------------------------------------------------------------- C MTLN=0 IFLAG1=0 IFLAG2=0 C DO IX=INASTX+1,INAST C if(btimex.and.iabs(modd).gt.1.and.ix.eq.inastx+1)then c cpar if(iam.ge.0)then !par cpar write(iw,*)'Proc',iam !par cpar x ,'Scaling loop:',mtlo1/2,mtlo2/2 !par cpar else !par c write(iw,*)'Scaling loop:',mtlo1/2,mtlo2/2 cpar endif !par endif C IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 c if(btimex.and.iabs(modd).gt.1) x write(iw,*)'Symmetry ',ix,':',-2*is+2,il,ip C !ALIGN MTS=IS-1 MTL=IL+IL MTP=IP+IP C IF(BKUTOO.AND.IL.GT.MAXLOO)THEN KUTOOX=0 BKUTOO=.FALSE. ENDIF C IF(MTL.GT.MTLN)THEN MTLN=MTL IF(MOD(MTLO1,4).EQ.MOD(MTL,4))THEN IFLAG1=IABS(IFLAG1)+1 IFLAG2=-IABS(IFLAG2) NCORX=NCOR1 MTLO=MTLO1 ELSEif(mod(mtlo2,4).eq.mod(mtl,4))then IFLAG2=IABS(IFLAG2)+1 IFLAG1=-IABS(IFLAG1) NCORX=NCOR2 MTLO=MTLO2 else stop 'algxls: index error on flgl symmetry set-up' ENDIF ENDIF C c write(0,*)ix,nadg(ix),ncor if(ncor.ne.nadg(ix))stop 'nx ncor.ne.nadg(ix)' !shouldn't happen c NCN=NCHG(IX) C NCHI=0 NCHI0=0 C DO NC0=1,NCN !BEGIN LOOP OVER INITIAL GROUPS L1=LLCH(1,NC0,IX) L2=LLCH(2,NC0,IX) NC=ITARG(NC0,IX) MC=NSL(NC) SA=QSI(NC) LA=QLI(NC) MCI=NGRPI(NC) C NCHIP=0 NCHIP0=0 C DO ND0=1,NC0 !BEGIN LOOP OVER FINAL GROUPS L1P=LLCH(1,ND0,IX) L2P=LLCH(2,ND0,IX) ND=ITARG(ND0,IX) MCP=NSL(ND) SAP=QSI(ND) IF(ABS(SA-SAP).GT.2)GO TO 68 !unnecessary... IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 68 LAP=QLI(ND) MCIP=NGRPI(ND) EQGRP=NC.EQ.ND !WITHIN A GROUP C NCHI=NCHI0 DO LI=L1,L2,4 !LOOP OVER INITIAL CHANNEL L C lf2=l2p if(eqgrp)lf2=li c NCHIP=NCHIP0 DO LF=L1P,Lf2,4 !LOOP OVER FINAL CHANNEL L c eqgrpl=eqgrpl0.and.eqgrp.and.li.eq.lf C DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS J1=MD1+MCI j=jndex(j1) C DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS J1P=MDP1+MCIP IF(eqgrpl.and.J1P.GT.J1-ione0)GO TO 13 c jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then !neglect corr.-corr. if(becor)then ncor=ncor+1 ncorx=ncorx+1 go to 12 endif go to 13 endif C NCORX=NCORX+1 C CALL FLGLX3(IFLAG1,IFLAG2,LA,LAP,LI,LF,MTL,MTLO X ,NCORX,DFS) C NCOR=NCOR+1 C IF(IRL.GT.MAXRL)JOS=-1 IF(IRK.GT.MAXRK.OR.NCORX.EQ.0)JOS=0 IF(JOS.LE.0)GO TO 67 !DIMENSION EXCEEDED IF(NF.LT.0)GO TO 999 C IF(LP)THEN !.AND.IRK.GE.IRK0 NCH=NCHI+MD1 NCHP=NCHIP+MDP1 IF(IRK-IRK0.NE.5)THEN WRITE(6,120)NCOR,IX,NCH,NCHP,IRK,IRL X ,(NRK(I),DRK(I),I=IRK0,IRK) ELSE WRITE(6,119)NCOR,IX,NCH,NCHP,IRK,IRL X ,(NRK(I),DRK(I),I=IRK0,IRK) ENDIF IF(BKUTOO)WRITE(6,121)(NRK(I),DEK(I),I=IRK0,IRK) WRITE(6,120) ENDIF C c write(72,*)ix,md1,mdp1,j,jp,ncor,irk 12 NAD(NCOR)=IRK C ENDDO !END LOOP OVER FINAL TERMS C 13 ENDDO !END LOOP OVER INITIAL TERMS C NCHIP=NCHIP+MCP ENDDO !END LOOP OVER FINAL L C NCHI=NCHI+MC ENDDO !END LOOP OVER INITIAL L C 68 NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP !=NCHIP ENDDO !END LOOP OVER FINAL GROUPS C NCHI0=NCHI0+((L2-L1)/4+1)*MC !=NCHI ENDDO !END LOOP OVER INITIAL GROUPS C KUTOOX=KOLDOO BKUTOO=KUTOOX.NE.0 C ENDDO !END LOOP OVER NX SYMMETRIES C C RESULTS C IF(IADD.NE.NCOR)THEN WRITE(6,*)'SR.ALGXLS: GLOBAL INDEX ERROR:',IADD,NCOR !test GO TO 999 ENDIF c write(0,*)iadd C IADD=NCOR C 67 IF(.NOT.LP.OR.JOS.LE.0.OR.JOSS.LE.0)THEN WRITE(6,120)NCOR,INAST,NCHMX,NCHMX,IRK,IRL IF(JOS.LT.0)GO TO 92 IF(JOS.EQ.0)GO TO 95 WRITE(6,122)MXRKS,MXRLS,MXIRKS,MXIRLS,mxstx,kint IF(JOSS.LT.0)GO TO 93 IF(JOSS.EQ.0)GO TO 89 WRITE(6,900)MPRINT ELSE C C PRINT SLATER INTEGRAL (ADRESS REFERENCE) LIST C WRITE(6,122)MXRKS,MXRLS,MXIRKS,MXIRLS,mxstx,kint IF(IRL.GT.0)THEN IF(BKUTOO)WRITE(6,301)KUTOOX IF(.NOT.BKUTOO)WRITE(6,300) DO L=1,IRL WRITE(6,700)L,(QRL(I,L), I=1,5) ENDDO ENDIF ENDIF C GO TO 99 !RETURN C C E R R O R M E S S A G E S C CF77 91 WRITE(6,191)J !F77 CF77 GO TO 999 !F77 95 WRITE(6,188) IF(IRL.LE.MAXRL)GO TO 999 92 WRITE(6,192) 93 WRITE(6,193) GO TO 999 89 WRITE(6,189) C 999 WRITE(6,190) NF=-1 !ABORT C 99 CONTINUE C !F95 IF(ALLOCATED(NADS))THEN !F95 DEALLOCATE (NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: DE-ALLOCATION FAILS FOR NADS,NSTJ, ETC'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(ALLOCATED(DRKS))THEN !F95 DEALLOCATE (DRKS,DEKS,QRLS,NRKS,BFALLS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'ALGXLS: DE-ALLOCATION FAILS FOR DRKS,DEKS, ETC'!F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C C----------------------------------------------------------------------- C if(btimex)then call cpu_time(timef) times=timef-time0 c C if(iabs(modd).le.1)then c cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for algxls:' !par cpar x ,' time=',nint(times),'sec' !par cpar else !par write(iw,*)'Ending algxls: time=',nint(times),'sec' cpar endif !par C endif endif C C----------------------------------------------------------------------- C RETURN C 119 FORMAT(I8,I3, 2I5, I8,I5, 6(I6,F11.6)) 120 FORMAT(I8,I3, 2I5, I8,I5, 6(I6,F11.6)/(34X,6(I6,F11.6))) 121 FORMAT((34X,6(I6,F11.6))) 122 FORMAT(/' SLATER STATE INTERACTION STORAGE (MXRKS,MXRLS) ',I8,I6, X10X,'USED: ',I8,I6/34X,'(MXSTX)',7X,I8,16X,'USED: ',I8) 133 FORMAT('SR.ALGXLS: ALLOCATION INCREASES NUMBER OF LS MATRIX' !F95 X,' ELEMENTS IADD =',I10,' .GT. MAXAD =',I10) !F95 150 FORMAT(/ /' SLATER COEFFICIENTS F(A,...) FOR CONSTRUCTING ( CH X ! H ! CHP ) = SUM( F(A,...) * R(A,...) )' X / I8,I3,2I5,I8,I5, ' STORAGE RESTRICTIONS FOR X (MAXAD,MAXSL,MAXDI,MAXDI,MAXRK,MAXRL), MXDFS=',I3/ X ' NCYC SY CH CHP MNF MNR',6(3X,'I(R) F(A,...)')) 151 FORMAT(/ /' SLATER COEFFICIENTS F(A,...) FOR CONSTRUCTING ( CH X ! H ! CHP ) = SUM( F(A,...) * R(A,...) )' X / I8,I3,2I5,I8,I5, ' STORAGE RESTRICTIONS FOR X (MAXAD,MAXSL,MAXDI,MAXDI,MAXRK,MAXRL), MXDFS=',I3, X5X,'***** KUTOOX=',I2,' *****' X/ ' NCYC SY CH CHP MNF MNR',6(3X,'I(R) F(A,...)')) 188 FORMAT(/' SR.ALGXLS: *MAXRK TOO SMALL, ARRAYS DRK AND NRK ') 189 FORMAT(/' SR.ALGXLS: *MXRKS TOO SMALL, ARRAYS DRKS AND NRKS ') 190 FORMAT( ' SR.ALGXLS: FAILURE - CASE SKIPPED') CF77 191 FORMAT(/' SR.ALGXLS: *MAXAD=',I10, !F77 CF77 X ' REQUIRED FOR NAD(MAXAD)') !F77 192 FORMAT(/' SR.ALGXLS: *MAXRL TOO SMALL, ARRAYS DRL AND QRL') 193 FORMAT(/' SR.ALGXLS: *MXRLS TOO SMALL, ARRAYS DRLS AND QRLS') 300 FORMAT(/ ' I(R) R( A, B, C, D, 2LBD )=SLATER-INTEGRALS ' X,' REFERENCE LIST (EXCHANGE LAMBDA = LBD + LTOT)') 301 FORMAT(//' I(R) R( A, B, C, D, 2LBD )=SLATER-INTEGRALS' X,' AND ETA( A, B, C, D, 2LBD) REFERENCE LIST (LBDX=LBD+LTOT),' X,' KUTOOX=',I2) 700 FORMAT( I5, 2X,2(I5,I4),I7, F13.5,2F19.5, 6X,2I4, 5X,'E',I1,I6) 900 FORMAT(/ ' *** PRINTOUT OF COEFFICIENTS SUPPRESSED - MPRINT(MODULO X 5)=',I2/) C END C C ******************* C REAL*8 FUNCTION ARGAM(EL,A) C C----------------------------------------------------------------------- C C BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE C C FN.ARGAM CALCULATES ARGGAMMA(EL+1+I*A), C WHERE EL+1 IS NOT LESS THAN ZERO C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DSEVEN=7.0D0) PARAMETER (DTEN=1.0D1) PARAMETER (DHALF=0.5D0) PARAMETER (D21=21.0D0) PARAMETER (D210=210.0D0) PARAMETER (D250=250.0D0) PARAMETER (D2520=2520.0D0) PARAMETER (D35=35.0D0) PARAMETER (D45=45.0D0) PARAMETER (D63=63.0D0) PARAMETER (D105=105.0D0) PARAMETER (D315=315.0D0) PARAMETER (D20=20.0D0) PARAMETER (D1M1=1.0D-1) C B=ABS(A) B=D250*B**(DONE/DFOUR)-A*A J1=0 C=EL+DONE D=C*C Z=DZERO C IF(D.LT.B)THEN B=SQRT (B) J1=INT(B-C+DONE) C DO J=1,J1 D=J-1 D=C+D D=A/D D1=ABS(D) IF(D1.LT.D1M1)THEN D1=D*D D2=-D35*D1+D45 D2=-D1*D2+D63 D2=-D1*D2+D105 D1=D-D*D1*D2/D315 ELSE D1=ATAN (D) ENDIF Z=Z+D1 ENDDO ENDIF C D=J1 D=C+D D0=D*D U=A*A D1=DONE/(D0+U) D2=D1*D1 D3=DTEN*D0*D0-D20*D0*U+DTWO*U*U D3=D3*D2-D21*D0+DSEVEN*U D3=D3*D2+D210 D1=A*D3*D1/D2520 C ARGAM=-Z+DHALF*A*LOG(D0+U)+(D-DHALF)*ATAN(A/D)-A-D1 C RETURN END C C ***********ASYMPTOPIA*********** C SUBROUTINE ASS2PX(X1,H,X,F0,F1,P0,P1,G0,G1,EI0,EJ0,CI0,CJ0,QI,QJ X,UI,UJ,Z0,NI,REM) C C----------------------------------------------------------------------- C C BADNELL AND BURGESS D.A.M.T.P. CAMBRIDGE C C SR.ASS2PX CALCS LONG RANGE INTEGRAL OUT TO POINT WHERE CAN USE AMP.- C PHASE METHOD IN SR.ASSX. MODIFIED VERSION OF A. BURGESS'S SR.ASS2. C THIS VERSION EVALUATES INTEGRAL G*P WHERE P IS THE DERIVATIVE OF F. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DTEN=1.0D1) PARAMETER (D20=20.0D0) PARAMETER (DTWELV=1.2D1) PARAMETER (D60=60.0D0) PARAMETER (D100=100.0D0) PARAMETER (D5M4=5.0D-4) PARAMETER (D1P6=1.0D6) PARAMETER (DHALF=0.5D0) PARAMETER (DQUART=DONE/DFOUR) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C LOGICAL BREL,BJUMPR,BMVD,BNORM C COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C TKIJ=ABS(SQRT(EI0)-SQRT(EJ0)) TEST=(DONE-Z0)*D5M4 T=DONE IF(NI.LE.-1)T=D100 IF(TKIJ.LT.TEST/T)TKIJ=D1P6 COLD TEST=TEST*DTEN IF(TKIJ.LT.TEST)TKIJ=TEST c if(-z0.lt.d5m4)then eztst=d100 elseif(ei0/z0**2.lt.d5m4)then eztst=-d5m4*z0 else eztst=-ei0/z0 endif C HH=H*H H1=HH/DTWELV REM=DZERO X=X1 A3=P1*G1*X**NI C IF(BREL)THEN EI=EI0+DQUART*DALF*EI0*EI0 EJ=EJ0+DQUART*DALF*EJ0*EJ0 ZI=Z0+DHALF*DALF*Z0*EI0 ZJ=Z0+DHALF*DALF*Z0*EJ0 CI=CI0-DALF*Z0*Z0 CJ=CJ0-DALF*Z0*Z0 C CHANGE NORM BACK TO THAT OF ORIGINAL EQUATION/SOLUTION: 1+(E+V)*D4 C (LIKELY OVER-KILL SINCE UNAFFECTED BY A CONSTANT FACTOR, ONLY ANY C REMAINING ASYMPTOTIC R-DEPENDENCE - SET BNORM=.TRUE. TO TEST.) BNORM=.FALSE. !.TRUE. !TEST IF(BNORM)THEN D4=DQUART*DALF Z2=Z0+Z0 T0=DONE/(X-H) TF0=DONE+D4*(EI0-Z2*T0) TG0=DONE+D4*(EJ0-Z2*T0) TF0=SQRT(TF0) TG0=SQRT(TG0) F0=F0/TF0 P0=P0/TF0 !NEGLECT F0 G0=G0/TG0 T1=DONE/X TF1=DONE+D4*(EI0-Z2*T1) TG1=DONE+D4*(EJ0-Z2*T1) TF1=SQRT(TF1) TG1=SQRT(TG1) F1=F1/TF1 P1=P1/TF1 G1=G1/TG1 ENDIF ELSE EI=EI0 EJ=EJ0 ZI=Z0 ZJ=Z0 CI=CI0 CJ=CJ0 BNORM=.FALSE. ENDIF C ZI2=ZI+ZI ZJ2=ZJ+ZJ CI2=CI+CI CJ2=CJ+CJ C T=DONE/(X-H) VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T V0=VI W0=-F0*(ZI2+CI2*T)*T*T VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T TI=F0*(DONE+VI*H1) TJ=G0*(DONE+VJ*H1) T=DONE/X VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T VP=VI WP=-F1*(ZI2+CI2*T)*T*T VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T TI=(DONE+H1*VI)*F1-TI TJ=(DONE+H1*VJ)*G1-TJ BI=F1*(DONE+H1*VI) BJ=G1*(DONE+H1*VJ) C 1 DO I=1,2 TI=TI-HH*VI*F1 TJ=TJ-HH*VJ*G1 BI=BI+TI BJ=BJ+TJ X=X+H T=DONE/X VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T VM=V0 V0=VP VP=VI PM=P0 F0=F1 P0=P1 G0=G1 F1=BI/(DONE+H1*VI) WM=W0 W0=WP WP=-F1*(ZI2+CI2*T)*T*T TT=(DTWO-DTEN*H1*V0)*P0-(DONE+H1*VM)*PM P1=(TT+(WP+DTEN*W0+WM)*H1)/(DONE+H1*VI) C BP=P1*(DONE+H1*VI) G1=BJ/(DONE+H1*VJ) ENDDO C A1=A3 A2=P0*G0*(X-H)**NI A3=P1*G1*X**NI C IF(BNORM)THEN T0=DONE/(X-H) TF0=DONE+D4*(EI0-Z2*T0) TG0=DONE+D4*(EJ0-Z2*T0) T1=T TF1=DONE+D4*(EI0-Z2*T1) TG1=DONE+D4*(EJ0-Z2*T1) A2=A2*SQRT(TF0*TG0) A3=A3*SQRT(TF1*TG1) ENDIF C REM=REM+A1+DFOUR*A2+A3 C CHECK CONVERGENCE IF(TKIJ*X.LT.D20)GO TO 1 IF((VJ*X*X-CJ2).LT.D60)GO TO 1 IF((VI*X*X-CI2).LT.D60)GO TO 1 if(eztst*x.lt.dten)go to 1 C IF(BNORM)THEN !CONVERT TO FINAL NORM F0=F0*SQRT(TF0) P0=P0*SQRT(TF0) G0=G0*SQRT(TG0) F1=F1*SQRT(TF1) P1=P1*SQRT(TF1) G1=G1*SQRT(TG1) ENDIF C REM=H*REM/DTHREE C RETURN END C C ***********ASYMPTOPIA*********** C SUBROUTINE ASS2X(X1,H,X,F0,F1,G0,G1,EI0,EJ0,CI0,CJ0,QI,QJ,UI,UJ,Z0 X,NI,REM) C C----------------------------------------------------------------------- C C BADNELL AND BURGESS D.A.M.T.P. CAMBRIDGE C C SR.ASS2X CALCS LONG RANGE INTEGRAL OUT TO POINT WHERE CAN USE AMP- C PHASE METHOD IN ASSX. MODIFIED VERSION OF A. BURGESS'S SR.ASS2. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) COLD PARAMETER (DTEN=1.0D1) PARAMETER (DTWELV=1.2D1) PARAMETER (D20=20.0D0) PARAMETER (D60=60.0D0) PARAMETER (D100=100.0D0) PARAMETER (D5M4=5.0D-4) PARAMETER (D1P6=1.0D6) PARAMETER (DHALF=0.5D0) PARAMETER (DQUART=DONE/DFOUR) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C LOGICAL BREL,BJUMPR,BMVD,BNORM C COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C TKIJ=ABS(SQRT(EI0)-SQRT(EJ0)) TEST=(DONE-Z0)*D5M4 T=DONE IF(NI.LE.-1)T=D100 IF(TKIJ.LT.TEST/T)TKIJ=D1P6 COLD TEST=TEST*DTEN IF(TKIJ.LT.TEST)TKIJ=TEST C HH=H*H H1=HH/DTWELV REM=DZERO X=X1 A3=F1*G1*X**NI C IF(BREL)THEN EI=EI0+DQUART*DALF*EI0*EI0 EJ=EJ0+DQUART*DALF*EJ0*EJ0 ZI=Z0+DHALF*DALF*Z0*EI0 ZJ=Z0+DHALF*DALF*Z0*EJ0 CI=CI0-DALF*Z0*Z0 CJ=CJ0-DALF*Z0*Z0 C CHANGE NORM BACK TO THAT OF ORIGINAL EQUATION/SOLUTION: 1+(E+V)*D4 C (LIKELY OVER-KILL SINCE UNAFFECTED BY A CONSTANT FACTOR, ONLY ANY C REMAINING ASYMPTOTIC R-DEPENDENCE - SET BNORM=.TRUE. TO TEST.) BNORM=.FALSE. !.TRUE. !TEST IF(BNORM)THEN D4=DQUART*DALF Z2=Z0+Z0 T0=DONE/(X-H) TF0=DONE+D4*(EI0-Z2*T0) TG0=DONE+D4*(EJ0-Z2*T0) TF0=SQRT(TF0) TG0=SQRT(TG0) F0=F0/TF0 G0=G0/TG0 T1=DONE/X TF1=DONE+D4*(EI0-Z2*T1) TG1=DONE+D4*(EJ0-Z2*T1) TF1=SQRT(TF1) TG1=SQRT(TG1) F1=F1/TF1 G1=G1/TG1 ENDIF ELSE EI=EI0 EJ=EJ0 ZI=Z0 ZJ=Z0 CI=CI0 CJ=CJ0 BNORM=.FALSE. ENDIF C ZI2=ZI+ZI ZJ2=ZJ+ZJ CI2=CI+CI CJ2=CJ+CJ C T=DONE/(X-H) VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T TI=F0*(DONE+VI*H1) TJ=G0*(DONE+VJ*H1) T=DONE/X VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T TI=(DONE+H1*VI)*F1-TI TJ=(DONE+H1*VJ)*G1-TJ BI=F1*(DONE+H1*VI) BJ=G1*(DONE+H1*VJ) C 1 DO I=1,2 TI=TI-HH*VI*F1 TJ=TJ-HH*VJ*G1 BI=BI+TI BJ=BJ+TJ X=X+H T=DONE/X VI=EI-(ZI2+(CI+(QI+UI*T)*T)*T)*T VJ=EJ-(ZJ2+(CJ+(QJ+UJ*T)*T)*T)*T F0=F1 G0=G1 F1=BI/(DONE+H1*VI) G1=BJ/(DONE+H1*VJ) ENDDO C A1=A3 A2=F0*G0*(X-H)**NI A3=F1*G1*X**NI C IF(BNORM)THEN T0=DONE/(X-H) TF0=DONE+D4*(EI0-Z2*T0) TG0=DONE+D4*(EJ0-Z2*T0) T1=T TF1=DONE+D4*(EI0-Z2*T1) TG1=DONE+D4*(EJ0-Z2*T1) A2=A2*SQRT(TF0*TG0) A3=A3*SQRT(TF1*TG1) ENDIF C REM=REM+A1+DFOUR*A2+A3 C CHECK CONVERGENCE IF(TKIJ*X.LT.D20)GO TO 1 IF((VJ*X*X-CJ2).LT.D60)GO TO 1 IF((VI*X*X-CI2).LT.D60)GO TO 1 C IF(BNORM)THEN !CONVERT TO FINAL NORM F0=F0*SQRT(TF0) G0=G0*SQRT(TG0) F1=F1*SQRT(TF1) G1=G1*SQRT(TG1) ENDIF C REM=H*REM/DTHREE C RETURN END C C ************ C SUBROUTINE ASSX(X,N,TI,TJ,EI0,EJ0,Z0,LI0,LJ0,ci,cj,QI,QJ,UI,UJ X ,REM) C C----------------------------------------------------------------------- C C BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE C C SR.ASSX CALCS LONG-RANGE INTEGRAL FROM X TO INFINITY, N=-(LAMBDA+1). C C CASE EI .NE. EJ AMP. PHASE METHOD. C CASE EI=EJ PHI+ AMP. PHASE METHOD, PHI- SUBSTITUTION & SIMPSONS RULE. C BASED ON A. BURGESS'S SR.ASS, MODIFIED AND EXTENDED TO TREAT EI=EJ. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (NMAX=10) PARAMETER (N2MX=2*NMAX) PARAMETER (MAXNST=65) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DTEN=1.0D1) PARAMETER (DHALF=0.5D0) PARAMETER (D1M10=1.0D-10) PARAMETER (D5M4=5.0D-4) PARAMETER (D32M6=3.2D-6) PARAMETER (DQUART=DONE/DFOUR) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C LOGICAL BREL,BJUMPR,BMVD C COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit c common /nrbnfg/fnorm,gnorm C DIMENSION AI(N2MX),AJ(N2MX),B(N2MX),C(N2MX),D(N2MX),E(N2MX) X,F(N2MX),G(N2MX),H(N2MX),R(MAXNST),P(N2MX),Q(N2MX),V(N2MX) C IF(LI0+LJ0.EQ.0.OR.LI0.LT.0.OR.LJ0.LT.0)THEN!NO LONG RANGE CONTRIB REM=DZERO !BAIL OUT RETURN ENDIF C ELI=LI0 ELJ=LJ0 C TEST=D32M6 TKIJ=ABS(SQRT(EI0)-SQRT(EJ0)) PI=ACOS(-DONE) C c for SUN S11 bug: if sub argument is ci0,cj0; ci,cj re-instated at end c ci0=ci cj0=cj c IF(BREL)THEN EI=EI0+DQUART*DALF*EI0*EI0 EJ=EJ0+DQUART*DALF*EJ0*EJ0 ZI=Z0+DHALF*DALF*Z0*EI0 ZJ=Z0+DHALF*DALF*Z0*EJ0 CI=CI0-DALF*Z0*Z0 CJ=CJ0-DALF*Z0*Z0 LI=-LI0-1 LJ=-LJ0-1 ELSE EI=EI0 EJ=EJ0 ZI=Z0 ZJ=Z0 CI=CI0 CJ=CJ0 LI=LI0 LJ=LJ0 ENDIF C PHI=PHASEX(EI,CI,QI,UI,LI,ZI,X)+TI*PI PHJ=PHASEX(EJ,CJ,QJ,UJ,LJ,ZJ,X)+TJ*PI C CALL DNAMP(AI0,AI,EI,CI,QI,UI,ZI,X,NMAX,5) CALL DNAMP(AJ0,AJ,EJ,CJ,QJ,UJ,ZJ,X,NMAX,5) C c fnorm=ai0*sin(phi) c gnorm=aj0*sin(phj) c ETIJ=(TI-TJ)*PI C CALL DNAQ(AI0,AI,B0,B,-DTWO,NMAX,2) CALL DNAQ(AJ0,AJ,C0,C,-DTWO,NMAX,2) C D0=B0+C0 DO I=1,NMAX D(I)=B(I)+C(I) ENDDO C CALL DNAQ(D0,D,V0,V,-DONE,NMAX,3) CALL DNPROD(AI0,AI,AJ0,AJ,D0,D,NMAX) C E0=X**N DEN=N E(1)=DEN*E0/X DO I=2,NMAX DEN=DEN-DONE E(I)=DEN*E(I-1)/X ENDDO C CALL DNPROD(D0,D,E0,E,F0,F,NMAX) CALL DNPROD(V0,V,F0,F,E0,E,NMAX) C H0=E0 IMAX=NMAX-1 C DO I=1,IMAX E0=E(1) JMAX=NMAX-I DO J=1,JMAX E(J)=E(J+1) ENDDO C CALL DNPROD(V0,V,E0,E,Q0,Q,JMAX) C E0=Q0 DO J=1,JMAX E(J)=Q(J) ENDDO H(I)=E0 ENDDO C H(NMAX)=V0*E(1) S=-DONE U=H0 R3=U T1=ABS(R3) I=0 C 16 I=I+2 IF(I.GT.NMAX)GO TO 19 T2=ABS(H(I)) IF(T2.GT.T1)GO TO 19 U=S*H(I) R3=R3+U S=-S T1=T2 GO TO 16 C 19 R3=R3-DHALF*U S=-DONE U=H(1) R4=U T1=ABS(R4) I=1 C 21 I=I+2 IF(I.GT.NMAX)GO TO 24 T2=ABS(H(I)) IF(T2.GT.T1)GO TO 24 U=S*H(I) R4=R4+U S=-S T1=T2 GO TO 21 C 24 R4=R4-DHALF*U S2=SIN(PHI+PHJ) C2=COS(PHI+PHJ) RP=R3*S2+R4*C2 C TEZT=D5M4*(DONE-Z0) IF(TKIJ.LT.TEZT)GO TO 25 IF(TKIJ.GT.DTEN*TEZT)GO TO 20 IF(N.LE.-1)GO TO 25 C C SLOW CONVERGENCE IN CASE EI-EJ SMALL BUT NON-ZERO, RM BETTER EVALUATED C IN ASS2. CASE ONLY ARISES IF ONE OF THE INTERPOLATION ENERGIES C IS CLOSE TO ZERO (=ZERO IS NO PROBLEM). CHOOSING INTERPOLATION C ENERGY=ZERO OR .GT. 4.E-4*(ASYMPTOTIC CHARGE +1)**2 C IS MUCH MORE FASTER AND ACCURATE. C REM=RP/DTWO GO TO 999 !RETURN C 20 C0=B0-C0 DO I=1,NMAX C(I)=B(I)-C(I) ENDDO C CALL DNAQ(C0,C,B0,B,-DONE,NMAX,3) C CALL DNPROD(B0,B,F0,F,D0,D,NMAX) C G0=D0 IMAX=NMAX-1 C DO I=1,IMAX D0=D(1) JMAX=NMAX-I DO J=1,JMAX D(J)=D(J+1) ENDDO C CALL DNPROD(B0,B,D0,D,P0,P,JMAX) C D0=P0 DO J=1,JMAX D(J)=P(J) ENDDO G(I)=D0 ENDDO C G(NMAX)=B0*D(1) S=DONE U=-G0 R1=U T1=ABS(R1) I=0 C 6 I=I+2 IF(I.GT.NMAX)GO TO 9 T2=ABS(G(I)) IF(T2.GT.T1)GO TO 9 U=S*G(I) R1=R1+U S=-S T1=T2 GO TO 6 C 9 R1=R1-DHALF*U S=DONE U=-G(1) R2=U T1=ABS(R2) I=1 C 11 I=I+2 IF(I.GT.NMAX)GO TO 14 T2=ABS(G(I)) IF(T2.GT.T1)GO TO 14 U=S*G(I) R2=R2+U S=-S T1=T2 GO TO 11 C 14 R2=R2-DHALF*U S1=SIN(PHI-PHJ) C1=COS(PHI-PHJ) RM=R1*S1+R2*C1 REM=(RM+RP)/DTWO C GO TO 999 !RETURN C C CALCS INTEGRAL [X,INFINITY) OF: C AMP1(R)*AMP2(R)*COS(PH2-PH1)/(2*R**(LAM+1) C FOR EI=EJ WITH SUB: C U=(DARSIN((DTWO/R-B1)/DEL)+SI)/DTL (AS DEFINED BELOW.) C 25 TL=(CI+CJ)/DTWO DTL=SQRT(TL) PH0=(ELJ-ELI)*PI Z2=-ZI-ZI B1=Z2/TL DEL=SQRT(DFOUR*EI/TL+B1*B1) SI=PI/DTWO IF(EI.GT.DZERO)SI=ASIN(B1/DEL) N2=N+2 AM=DZERO IF(N2.EQ.0)AM=DONE C IF(EI.GT.D1M10)THEN DEI=SQRT(EI) ZE=ZI/DEI AGI=ARGAM(ELI,ZE) AGJ=ARGAM(ELJ,ZE) PH0=PH0/DTWO+AGI-AGJ ENDIF C RM=DZERO R(1)=AM*COS(PH0+ETIJ) CU=EI+Z2/X-TL/(X*X) IF(CU.LT.DZERO)GO TO 99 !ABORT C CU=SQRT(CU) R(3)=AI0*AJ0*COS(PHI-PHJ)*CU*X**N2 NST=1 HT=(ASIN((DTWO/X-B1)/DEL)+SI)/DTL C 31 RM0=RM NST=NST+NST HT=HT/DTWO NS2=NST+2 RM=R(1) UH=HT C DO K=4,NS2,2 XH=DTWO/(B1+DEL*SIN(UH*DTL-SI)) CU=EI+Z2/XH-TL/(XH*XH) IF(CU.LT.DZERO)GO TO 99 !ABORT CU=SQRT(CU) C CALL DNAMP(AI1,AI,EI,CI,QI,UI,ZI,XH,NMAX,5) CALL DNAMP(AJ1,AJ,EJ,CJ,QJ,UJ,ZJ,XH,NMAX,5) !EI=EJ, ZI=ZJ C PI1=PHASEX(EI,CI,QI,UI,LI,ZI,XH) PJ1=PHASEX(EJ,CJ,QJ,UJ,LJ,ZJ,XH) C R(K-2)=AI1*AJ1*COS(PI1-PJ1+ETIJ)*CU*XH**N2 UH=UH+HT+HT ENDDO C DO K=4,NST,2 RM=RM+DFOUR*R(K-2)+DTWO*R(K-1) ENDDO C RM=(RM+DFOUR*R(NST)+R(NST+1))*HT/DTHREE C IF(ABS(RM-RM0).GT.TEST)THEN !NOT YET CONVERGED NSN=NST+NST IF(NSN.LT.MAXNST)THEN NSN=NSN+3 DO K=1,NST R(NSN-K-K)=R(NS2-K) ENDDO GO TO 31 !NEXT ITERATION ENDIF IF(ABS(RM).GT.DONE)WRITE(6,100)TEST,RM0,RM !FAILURE ENDIF C REM=(RM+RP)/DTWO !CONVERGED RESULT C 999 CONTINUE C IF(BREL)THEN !CORRECT NORMALIZATION TF=DONE+DQUART*DALF*EI0 ! -2*z0/x) TG=DONE+DQUART*DALF*EJ0 ! -2*z0/x) TF=SQRT(TF) TG=SQRT(TG) REM=REM*TF*TG c fnorm=fnorm*tf c gnorm=gnorm*tg ENDIF c !re-instate for SUN S11 bug ci=ci0 cj=cj0 C RETURN C 99 REM=RP/DTWO !RM NOT CONVERGED GO TO 999 !RETURN C 100 FORMAT('*****WARNING IN SR.ASSX, LONG-RANGE INTEGRALS HAVE FAILED' X,'TO CONVERGE TO WITHIN',1PE7.1/ ' FOR EI=EJ, CHECK WHETHER ' X,'ACCURACY IS SUFFICIENT, RM0=',E14.7,3X,'RM=',E14.7) C END C C ************ C SUBROUTINE BDCF3(F,E,N,L,Z,J0,J1,X) C C----------------------------------------------------------------------- C C ALAN BURGESS, D.A.M.T.P. CAMBRIDGE C C SR.BDCF3 EVALUATES A BOUND COULOMB FUNCTION FROM SERIES. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (D3HALF=1.5D0) PARAMETER (DQUART=0.25D0) PARAMETER (D8TH=0.125D0) PARAMETER (D1P12=1.0D12) PARAMETER (TOL=1400.0D0) PARAMETER (SUPFCT=55.0D0) C PARAMETER (ENFFCT=1.0D-6) C DIMENSION F(J1),X(J1) C C EL=L GNU=-Z/SQRT(-E) C T1=GNU+EL+DONE IF(T1.GT.SUPFCT)THEN WRITE(6,*)'****ERROR: BDCF3, N+L TOO LARGE FOR GAMA7' WRITE(0,*)'****ERROR: BDCF3, N+L TOO LARGE FOR GAMA7' L=-1 J=J0 GO TO 6 ENDIF C T2=GNU-EL IF(T2.LT.DHALF)T2=DONE !SAFE LOWER BOUND C T3=GAMA7(T1)*GAMA7(T2) B=SQRT(-Z/T3)/GNU B=B*(-1)**(N-L+1) C DO J=J0,J1 C R=-Z*X(J) T=DTWO*R/GNU T3=DONE/T S=DONE A=DONE K0=INT(GNU+GNU+D3HALF+T) TH=K0 TH=GNU+GNU+DONE+T-TH C DO K=1,K0 TK=K A=A*(TK-GNU+EL)*(GNU-TK+EL+DONE)*T3/TK T1=ABS(A) T2=ABS(S)*T3/TK IF(T2.GT.T1*D1P12)GO TO 2 S=S+A ENDDO C T1=(GNU-EL)*(GNU+EL+DONE) T2=-DTWO*GNU*T1 C=-DHALF+D8TH*T3*((DTWO*TH-DONE)+(TH*TH-D3HALF*TH+DQUART X -DTWO*T1)*T3) S=S+C*A 2 IF(T.GT.TOL)GO TO 6 F(J)=(T**GNU)*S*EXP(-DHALF*T)*B C ENDDO C IF(F(1).LT.DZERO)THEN WRITE(6,*)'****ERROR: BDCF3, EXPANSION FAILED TO CONVERGE' WRITE(0,*)'****ERROR: BDCF3, EXPANSION FAILED TO CONVERGE' L=-1 J=J0 GO TO 6 ENDIF C RETURN C 6 DO I=J,J1 F(I)=DZERO ENDDO C RETURN END C C ******************* C REAL*8 FUNCTION BESSJ(L,X) C C----------------------------------------------------------------------- C C FN.BESSJ EVALUATES A SPHERICAL BESSEL FUNCTION OF THE FIRST KIND. C C L=ORDER C X=ARGUEMENT C BJ=J_L(X) SAID BESSEL. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D1M5=1.0D-5) C PARAMETER (JMAX=6) C C C START WITH POWER SERIES C BJ=DONE BJ0=DONE L2=L+L T2=-X*X/2 DO J=1,JMAX BJ0=BJ0*T2/(J*(2*(L+J)+1)) BJ=BJ+BJ0 IF(ABS(BJ0).LT.ABS(BJ)*D1M5)THEN BJ=BJ*X**L DO I=2,L2,2 BJ=BJ/(I+1) ENDDO BESSJ=BJ GO TO 500 !CONVERGED ENDIF ENDDO C C NOT CONVERGED, C USE RECURRENCE RELATION STARTING AT J0=SIN(*X)/X AND J1=(J0-COS(X))/X C BESSJ=SIN(X)/X IF(L.EQ.0)RETURN C BESSJ0=BESSJ BESSJ=(BESSJ0-COS(X))/X IF(L.EQ.1)RETURN C BESSJ1=BESSJ DO I=2,L BESSJ2=(2*I-1)*BESSJ1/X-BESSJ0 BESSJ0=BESSJ1 BESSJ1=BESSJ2 ENDDO C BESSJ=BESSJ2 C 500 RETURN END C C ******************* C REAL*8 FUNCTION BESSJP(L,X) C C----------------------------------------------------------------------- C C FN.BESSJP EVALUATES THE DERIVATIVE OF SPHERICAL BESSEL FUNCTION OF C THE FIRST KIND, TRIVIALLY FROM RECURRENCE RELATION. C C L=ORDER C X=ARGUEMENT C BJ=J_L(X) SAID BESSEL. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C BESSJP=-BESSJ(L+1,X) C IF(L.EQ.0)RETURN C BESSJP=(L*BESSJ(L-1,X)+(L+1)*BESSJP)/(2*L+1) C RETURN END C C ******************* C REAL*8 FUNCTION BESSN(L,X) C C----------------------------------------------------------------------- C C FN.BESSN EVALUATES SPHERICAL BESSEL FUNCTION OF THE SECOND KIND C C L=ORDER C X=ARGUEMENT C BESSN=N_L(X) SAID BESSEL. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D1M5=1.0D-5) C PARAMETER (NMAX=6) C C C START WITH POWER SERIES C BN=DONE BN0=DONE L2=L+L T2=-X*X/2 DO N=1,NMAX BN0=-BN0*T2/(N*(2*(L-N)+1)) BN=BN+BN0 IF(ABS(BN0).LT.ABS(BN)*D1M5)THEN BN=-BN/X**(L+1) DO I=2,L2,2 BN=BN*(I-1) ENDDO BESSN=BN GO TO 500 !CONVERGED ENDIF ENDDO C C NOT CONVERGED, USE RECURRENCE RELATION STARTING WITH C N0=-COS(*X)/X AND N1=(N0-SIN(X))/X C BESSN=-COS(X)/X IF(L.EQ.0)RETURN C BESSN0=BESSN BESSN=(BESSN0-SIN(X))/X IF(L.EQ.1)RETURN C BESSN1=BESSN DO I=2,L BESSN2=(2*I-1)*BESSN1/X-BESSN0 BESSN0=BESSN1 BESSN1=BESSN2 ENDDO C BESSN=BESSN2 C 500 RETURN END C C ******************* C SUBROUTINE BORN(LAM,K1,K2,K3,K4,LL,LIMR,MENGB,MV0,MV1,V0,V1 X ,BINT,OINT,TM2) c C----------------------------------------------------------------------- C C Adapted SR.BORN from Alan Burgess, DAMTP Cambridge: c Computes the Born integrals specified in the appendix to C Burgess, Chidichimo and Tully (J.Phys.B,30,33-57,1997). CN.B. ID sets the maximum number of points used for tabulation of C radial functions, and for the integrations over r and over K. C The value of ID MUST be a power of 2, and be at least 2**M0 C where M0 is the number of Romberg iterations. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C LOGICAL CF C INCLUDE './PARAM' C PARAMETER (ID=1024) !N.B. MAXB1 LARGE C PARAMETER (DZERO=0.0D0) PARAMETER (D1PT5=1.5D0) PARAMETER (D1M5=1.0D-5) PARAMETER (D5M4=5.0D-4) PARAMETER (D1M3=1.0D-3) PARAMETER (DHALF=0.5D0) PARAMETER (DNINE=9.0D0) C COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /MQVC/MDUM,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) C DIMENSION F1(0:ID),F2(0:ID),F12(0:ID),F34(0:ID) DIMENSION P1(0:ID),P2(0:ID),S3(0:ID) DIMENSION LIMR(*),LL(*),BINT(*),V0(*),V1(*) C IPS=0 IF(KCUT.GT.0)THEN IF(DADJUS(K1).LT.DZERO)IPS=IPS+1 IF(DADJUS(K2).LT.DZERO)IPS=IPS+1 IF(DADJUS(K3).LT.DZERO)IPS=IPS+1 IF(DADJUS(K4).LT.DZERO)IPS=IPS+1 ENDIF C IF((IPS.LE.0.OR.IPS.LE.2.AND.LAM.LE.2).AND. X (MENGB.EQ.1.OR.LAM.EQ.0))THEN !INFINITE ENERGY / OMG TO 4 S.F. TOLR=D1M5 M0=6 ELSE !FINITE ENERGY / OMG TO 3 S.F. IF(IPS.LE.2.OR.IPS.LE.4.AND.LAM.EQ.0)THEN TOLR=D5M4 M0=5 ELSE TOLR=D1M3 M0=4 ENDIF ENDIF C C TOLR=1.D-7 !HIGH PRECISION CHECK OF BORN INTEGRALS C M0=8 C CF=K3.NE.K1.OR.K4.NE.K2 IF(2**M0.GT.ID)THEN WRITE(6,*)'BORN ERROR: 2**M0 .GT. ID' WRITE(0,*)'BORN ERROR: 2**M0 .GT. ID' LAM=-1 RETURN ENDIF C I1=ID M=MAX(LIMR(K1),LIMR(K2)) IF(DX(LIMR(K1)+LIMR(K2)-M)*D1PT5.GT.DX(M))I1=I1/2 R1=DX(M) H1=R1/I1 C CALL PNL(I1,H1,LL(K1),DX,DPNL(1,K1),LIMR(K1),F1) CALL PNL(I1,H1,LL(K2),DX,DPNL(1,K2),LIMR(K2),F2) C CALL NORMS(I1,H1,LAM,F1,F2,F12,B11,B22,B12,TM12,VM12) C TM2=DZERO IF(LAM.EQ.1)TM2=TM12*TM12/DNINE IF(CF)THEN I2=ID M=MAX(LIMR(K3),LIMR(K4)) IF(DX(LIMR(K3)+LIMR(K4)-M)*D1PT5.GT.DX(M))I2=I2/2 R2=DX(M) H2=R2/I2 C CALL PNL(I2,H2,LL(K3),DX,DPNL(1,K3),LIMR(K3),F1) CALL PNL(I2,H2,LL(K4),DX,DPNL(1,K4),LIMR(K4),F2) C CALL NORMS(I2,H2,LAM,F1,F2,F34,B33,B44,B34,TM34,VM34) C IF(LAM.EQ.1)TM2=DSQRT(TM2*TM34*TM34/DNINE) ELSE R2=R1 I2=I1 DO I=1,I1 F34(I)=F12(I) ENDDO VM34=VM12 ENDIF C VM=(VM12+VM34)*DHALF IF(MENGB.GT.1)THEN !FINITE ENERGY CASE IE=0 DO J0=1,MV0 J11=J0+1 DO J1=J11,MV1 IE=IE+1 C CALL ROMB(ID,CF,LAM,R1,I1,F12,R2,I2,F34,VM,V0(J0),V1(J1) X ,M0,F1,F2,S3,P1,P2,BINT(IE),OINT,EB,EO,TOLR,TM2) C IF(LAM.EQ.1)BINT(IE)= X BINT(IE)+TM2*DLOG((V0(J0)+VM)/(V1(J1)+VM)) !OMIT LOG(V1/V0) c X BINT(IE)+TM2*DLOG(V1(J1)*(V0(J0)+VM)/(V0(J0)*(V1(J1)+VM))) ENDDO ENDDO ELSE !INFINITE ENERGY CASE C CALL ROMB(ID,CF,LAM,R1,I1,F12,R2,I2,F34,VM,V0(1),V1(1) X ,M0,F1,F2,S3,P1,P2,BINT(1),OINT,EB,EO,TOLR,TM2) C ENDIF C RETURN END C C ******************* C SUBROUTINE BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS X ,DB0,DB1,OMG1,OBO,OMEGA) C C----------------------------------------------------------------------- C C SR.BRNINT INTERPOLATES BORN OMEGAS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D1PT2=1.2D0) C LOGICAL BPRNT0,BFLAG C DIMENSION V0(*),V1(*),XB(*),XS(0:*),DB0(*),DB1(*),OMEGA(0:*) X ,OBO(*) C DATA BFLAG/.TRUE./ C IROW(ILI,ILF,IONE,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE))/2 C NPB=NLAGB/2 MV11=MV1-1 C DO NX=1,MXNXB XE=DSQRT(XB(NX)*DRY) TKMIN=XE*(DONE-XS(NX)) TKMAX=XE*(DONE+XS(NX)) C c find tkmin interp. points C IF(TKMIN.LT.V0(1))THEN c write(0,*)'tkmin out of bounds (lower)',tkmin,v0(1) ctest stop'tkmin out of bounds (lower)' NB01=1 NB02=NLAGB GO TO 272 ENDIF IF(TKMIN.GT.D1PT2*V0(MV0))THEN IF(BPRNT0)THEN write(6,*)'tkmin out of bounds (upper)',tkmin,v0(mv0) write(6,*) X 'Upper-state above the ionization limit? SET KCUT !!' IF(BFLAG)THEN write(0,*) X 'Upper-state above the ionization limit? SET KCUT !!' BFLAG=.FALSE. ENDIF ENDIF cold nlagb=-1 cold return ctest stop'tkmin out of bounds (upper)' NB02=MV0 NB01=NB02-NLAGB+1 GO TO 272 ENDIF C DO L=1,MV0 IF(V0(L).GT.TKMIN)THEN NB02=L+NPB-1 NB01=L-NPB IF(NB01.LE.0)THEN NB02=NLAGB NB01=1 ELSEIF(NB02.GT.MV0)THEN NB02=MV0 NB01=NB02-NLAGB+1 ENDIF GO TO 272 ENDIF ENDDO NB02=MV0 NB01=NB02-NLAGB+1 C WEIGHTS 272 DO L=NB01,NB02 DD0=DONE DO M=NB01,NB02 IF(L.NE.M)THEN DD0=DD0*(TKMIN-V0(M)) DD0=DD0/(V0(L)-V0(M)) ENDIF ENDDO DB0(L)=DD0 ENDDO C c find tkmax interp. points C IF(TKMAX.LT.V1(1))THEN c write(0,*)'tkmax out of bounds (lower)',tkmax,v1(1) ctest stop'tkmax out of bounds (lower)' NB11=1 NB12=NLAGB GO TO 273 ENDIF DO L=1,MV11 IF(V1(L).GT.TKMAX)THEN NB12=L+NPB-1 NB11=L-NPB IF(NB11.LE.0)THEN NB11=1 NB12=NLAGB ELSEIF(NB12.GT.MV11)THEN NB12=MV11 NB11=NB12-(NLAGB-1)+1 ENDIF GO TO 273 ENDIF ENDDO IF(TKMAX.GT.D1PT2*V1(MV11))THEN IF(BPRNT0)THEN write(6,*)'tkmax out of bounds (upper)',tkmax,v1(mv11) write(6,*)'Is this a K-shell excitation?' ENDIF ctest stop'tkmax out of bounds (upper)' NB12=MV1 NB11=NB12-1 ELSE NB12=MV1 NB11=NB12-(NLAGB-1)+1 ENDIF C WEIGHTS 273 DO L=NB11,NB12 DD0=DONE DO M=NB11,NB12 IF(L.NE.M)THEN DD0=DD0*(TKMAX-V1(M)) DD0=DD0/(V1(L)-V1(M)) ENDIF ENDDO DB1(L)=DD0 ENDDO C C INTERPOLATE BORN INTEGRAL OVER K_MIN AND K_MAX MOM. TRANSFER LIMITS. C XOBO=DZERO DO I0=NB01,NB02 DO I1=NB11,NB12 IF(I1.GT.I0)THEN IE=IROW(I0,I1,1,MV1) XOBO=XOBO+DB0(I0)*DB1(I1)*OBO(IE) ELSEIF(I1.LT.I0)THEN IE=IROW(I1,I0,1,MV1) XOBO=XOBO-DB0(I0)*DB1(I1)*OBO(IE) ENDIF ENDDO ENDDO XOBO=XOBO+OMG1*LOG(TKMAX/TKMIN) !IF(NGROUP.EQ.1) OMEGA(NX)=XOBO !INTERPOLATED BORN INTGRAL ENDDO C RETURN END C*********************************************************************** C*********************************************************************** C C J. BURNS BOX FUNCTION GENERATOR C C*********************************************************************** C*********************************************************************** C SUBROUTINE BXCUNT(IN_INT,IANSTEPS,DTF,DARFUNC,ISIZE,INODES) C C----------------------------------------------------------------------- C C SR.BXCUNT COUNTS THE NUMBER OF NODES TO SEE IF WE HAVE THE REQUIRED C ORBITAL. C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN_INT,INODES,IINDEX,II,IN,ISIZE,IANSTEPS(*) C REAL*8 DARFUNC(*),DM,DF1,DF2,DTF,DZERO C PARAMETER (DZERO=0.0D0) C C IINDEX=2 INODES=0 C DO II=1,IN_INT DO IN=2,IANSTEPS(II) IF(IINDEX.GE.(ISIZE-10)) THEN IF(ABS(DARFUNC(IINDEX)).LT.DTF) THEN DF1=DZERO ELSE DF1=DARFUNC(IINDEX) ENDIF C IF(ABS(DARFUNC(IINDEX-1)).LT.DTF) THEN DF2=DZERO ELSE DF2=DARFUNC(IINDEX-1) ENDIF DM=DF1*DF2 ELSE DM=DARFUNC(IINDEX)*DARFUNC(IINDEX-1) ENDIF C IF(DM.LT.DZERO) THEN !WE FLIPPED SIGN INODES=INODES+1 ENDIF IINDEX=IINDEX+1 IF (IINDEX.GE.ISIZE) GOTO 103 ENDDO ENDDO 103 CONTINUE C RETURN END C C ******************* C REAL*8 FUNCTION BXDFKK(DZ,DL,DE,DR) C C----------------------------------------------------------------------- C C FN.BXDFKK DETERMINES THE KINETIC-PLUS-NUCLEAR OPERATOR (FOR BOX USE). C C----------------------------------------------------------------------- C IMPLICIT NONE C REAL*8 DZ,DL,DE,DR,DONE,DTWO C PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C BXDFKK=(-(DL*(DL+DONE)/(DR*DR)))+(DTWO*DZ/DR)+DE C RETURN END C C ******************* C SUBROUTINE BXINFL(IN_INT,IANSTEPS,DZ,DL,DE,DR1,DR2,DAR,IRN) C C----------------------------------------------------------------------- C C SR.BXINFL DETERMINES THE INNER POINT OF INFLECTION. C IRN IS USED TO RETURN THE INDEX OF THE R VALUE CLOSEST TO BUT C NOT GREATER THAN THE POSITION OF THE INNER POINT OF INFLECTION C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN,IN_INT,IINDEX,IRN,II,IANSTEPS(*) C REAL*8 DZ,DL,DE,DR1,DR2,DPT_INFL,DAR(*) C REAL*8 DZERO,DONE,DFOUR C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DFOUR=4.0D0) C DR1=(-DZ+SQRT( DZ**2+DE*DL*(DL+DONE)))/DE DR2=(-DZ-SQRT( DZ**2+DE*DL*(DL+DONE)))/DE C IF(DR1.LT.DZERO)THEN DPT_INFL=DR2 ELSE IF(DR2.LT.DZERO)THEN DPT_INFL=DR1 ELSE IF(DR1.LT.DR2)THEN DPT_INFL=DR1 ELSE DPT_INFL=DR2 ENDIF ENDIF IF(DPT_INFL.LT.0)THEN DPT_INFL=0 IN=0 RETURN ENDIF C DPT_INFL=DPT_INFL/DFOUR IINDEX=1 C DO II=1,IN_INT DO IN=1,IANSTEPS(II) IF(DAR(IINDEX).GT.DPT_INFL)THEN IRN=IINDEX-1 GO TO 102 ENDIF C IINDEX=IINDEX+1 ENDDO ENDDO C 102 CONTINUE C C PRINT *,RN,R1,R2,R(RN) C DO WHILE (R(INDEX).LT.PT_INFL) C INDEX=INDEX+1 C ENDDO C RN=INDEX-1 C PRINT *,"RN=",RN C RETURN END C C ******************* C REAL*8 FUNCTION BXINT(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DAF1,DAF2) C C----------------------------------------------------------------------- C C SR.BXINT USES SIMSPONS RULE TO INTEGRATE THE PRODUCT OF TWO FUNCTIONS C ON A RADIAL MESH OF INCREASING STEPSIZE. C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN_INT,IINDEX,IU,II,IN,IR0,IANSTEPS(*) C REAL*8 DASTEPSIZE(*),DAF1(*),DAF2(*),DZERO,DONE,DTWO,DTHREE X ,DFOUR,DSUM,D_TSUM,DT,DFAC !D_TSUM IS TEMPORARY C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D00) PARAMETER (DFOUR=4.0D00) C IINDEX=0 DSUM=DZERO D_TSUM=DZERO DFAC=DONE IU=2 C DO II=1,IN_INT C PRINT *,"INTEGRATING INTERVAL ",II IF(II.NE.1) THEN IU=1 DT=DAF1(IINDEX)*DAF2(IINDEX) D_TSUM= DT ELSE D_TSUM=DZERO IU=1 ENDIF C PRINT *,IINDEX,") DAF1=",DAF1(IINDEX),"DFAC=",DFAC," DT=",DT DFAC=DTWO C DO IN=IU,(IANSTEPS(II)-1) IINDEX=IINDEX+1 IF(DFAC.EQ.DTWO) THEN DFAC=DFOUR ELSE DFAC=DTWO ENDIF C DT=DFAC*DAF1(IINDEX)*DAF2(IINDEX) D_TSUM=D_TSUM+DT C PRINT *,IINDEX,") DAF1=",DAF1(IINDEX),"DFAC=",DFAC,"DT=",DT IF (IINDEX.EQ.(IR0-1))GO TO 104 ENDDO C 104 DFAC=1 IINDEX=IINDEX+1 DT=DAF1(IINDEX)*DAF2(IINDEX) D_TSUM=D_TSUM+DT C PRINT *,IINDEX,") DAF1=",DAF1(IINDEX),"DFAC=",DFAC,"DT=",DT D_TSUM=D_TSUM*DASTEPSIZE(II)/DTHREE DSUM=DSUM+D_TSUM IF (IINDEX.EQ.IR0) GOTO 105 ENDDO C 105 BXINT=DSUM C PRINT *,"INTEGRAL RESULT ",DSUM C RETURN END C C ******************* C SUBROUTINE BXNORM(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DARFUNC) C C----------------------------------------------------------------------- C C SR.BXNORM NORMALIZES BOX FUNCTIONS, TO UNITY. C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN_INT,IINDEX,II,IN,IR0,IANSTEPS(*) C REAL*8 DA,BXINT,DASTEPSIZE(*),DARFUNC(*) C C DA=BXINT(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DARFUNC,DARFUNC) DA=SQRT(DA) C IINDEX=1 DO II=1,IN_INT DO IN=1,IANSTEPS(II) DARFUNC(IINDEX)=DARFUNC(IINDEX)/DA IINDEX=IINDEX+1 ENDDO ENDDO C RETURN END C C ******************* C SUBROUTINE BXNUMV(IN_INT,IANSTEPS,DASTEPSIZE,ISTOP,DZ,DL, X DE,DARFUNC,DAR) C C----------------------------------------------------------------------- C C SR.BXNUMV CARRIES-OUT A NUMEROV INTEGRATION TO DETERMINE BOX ORBITALS C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN_INT,ISTART_INT,ISTART_PT !NO OF INTERVALS, INTERVAL TO C !START ON, POINT WITHIN INTERVAL TO START AT INTEGER II,IN !TEMPORARY VALUE FOR STORING INTERVAL C !NUMBER,N USED AS LOOP COUNTER INTEGER IINDEX,ISTOP !USED TO KEEP TRACK OF POSITION IN THE R C !AND RFUNC ARRAYS,ISTOP IS THE INDEX TO STOP INTEGER IM,IC,IP !AT PREVIOUS INDEX,CURRENT INDEX,NEXT INDEX, C !M=MINUS,C=CURRENT,P=PLUS PT_OF_INFL INTEGER IRN !ALSO RETURNS THE POSITION WITHIN THE RADIAL C !MESH WHERE R IS NEAREST TO, BUT LESS THAN, C !THE R AT WHICH THE FIRST POINT OF C !INFLECTION OCCURS. REAL*8 DE,DZ,DL,DHH !INTEGRATES FROM R=0 R=R0,ENERGY,CHARGE, C !ANGULAR MOMENTUM Q.NUMBER,STEPSIZE SQUARED REAL*8 DKK_C,DKK_P,DKK_M !K (N),K (N+1),K (N-1) NOTE DFKK=K**2 REAL*8 DR1,DR2 !R VALUES OF POINTS OF INFLECTION REAL*8 BXDFKK,BXPWRS !K**2,POWER SERIES FUNCTION C INTEGER IANSTEPS(*) !NO. OF STEPS C REAL*8 DASTEPSIZE(*) !SIZE OF STEPS IN INTERVAL REAL*8 DARFUNC(*),DAR(*) !RADIAL FUNCTION,RADIAL MESH, C REAL*8 DRFUNC_C,DRFUNC_M !CURRENT VALUE OF RFUNC,PREVIOUS C !VALUE OF RFUNC REAL*8 DONE,DTWO,DFIVE,DTWELV !,DZERO C C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFIVE=5.0D00) PARAMETER (DTWELV=12.0D00) C CALL BXINFL(IN_INT,IANSTEPS,DZ,DL,DE,DR1,DR2,DAR,IRN) C C PRINT *,"DR1=",DR1,",DR2=",DR2 C PRINT *,"POWER SERIES TO IINDEX ",IRN C IF((IRN.LE.0).OR.(NINT(DL).EQ.0))IRN=50 !RSET IRN TO SOMETHING C !SENSIBLE C C *************************** C FORCE IRN C PRINT *,IRN C IRN=8 C *************************** C PRINT *,"POSITION OF PT. OF INFL=",IRN C C DARFUNC(0)=DZERO DO IN=1,IRN !FILL OUT DARFUNC USING POWER SERIES DARFUNC(IN)=BXPWRS(DZ,DL,DE,DAR(IN),100) ENDDO C ISTART_INT=1 !INITIALISE STARTING INTERVAL C II=1 !KEEP TRACK OF CURRENT INTERVAL ISTART_PT=IRN !START POINT IS WHERE THE POWER SERIES ENDS C C THIS LOOP FINDS THE INTERVAL AND THE POSITION C WITHIN IT AT WHICH THE PT OF INFLECTION OCCURS - C THIS WILL BE THE STARTING PT OF THE INTEGRATION DO WHILE(ISTART_PT.GT.IANSTEPS(II)) ISTART_PT=ISTART_PT-IANSTEPS(II) II=II+1 ENDDO C ISTART_INT=II !STORE THE STARTING INTERVAL IINDEX=IRN !STORE STARTING IINDEX C C !------------------------------------------------------------- C C PRINT *,"BEGINNING INTEGRATION AT IINDEX=",IINDEX C PRINT *,"START INTERVAL=",II C PRINT *,"ISTART_PT=",ISTART_PT C DO II=ISTART_INT,IN_INT !WE START INTEGRATION FROM WHERE C DHH=DASTEPSIZE(II)**2 !THE POWER SERIES WAS STOPPED C C PRINT *,"CONTINUING INTEGRATION FROM ",IINDEX DO IN=ISTART_PT,(IANSTEPS(II)-1) !CONTINUE THE INTEGRATION C ! FOR THE REST OF THIS INTERVAL C !PRINT *,DHH IF (IN.EQ.0) THEN IM=IINDEX-2 ELSE IM=IINDEX-1 ENDIF IC=IINDEX IP=IINDEX+1 C !PRINT *,"IM,IC,IP ",IM,IC,IP DKK_P=BXDFKK(DZ,DL,DE,DAR(IP)) DKK_C=BXDFKK(DZ,DL,DE,DAR(IC)) DKK_M=BXDFKK(DZ,DL,DE,DAR(IM)) C DARFUNC(IP)=DTWO*(DONE-((DFIVE*DHH)/DTWELV)*DKK_C)*DARFUNC(IC) DARFUNC(IP)=DARFUNC(IP)-DARFUNC(IM)*(DONE+(DHH/DTWELV)*DKK_M) DARFUNC(IP)=DARFUNC(IP)/(DONE+((DHH/DTWELV)*DKK_P)) C C !!PRINT *," ----> ",DKK_C C !!PRINT *,IINDEX," ",DARFUNC(IP) C IINDEX=IINDEX +1 IF (IINDEX.GE.ISTOP) GOTO 108 ENDDO C ISTART_PT=0 !FOR ALL INTERVALS AFTER THE FIRST C !(NOT NESSECARILY INTERVAL 1) C !WE SET I3START_PT=0 SO TWO NEW STARTING C !POINTS ARE TAKING FROM PREV INTERVAL C C !PRINT *,"FINISHED INTERVAL ",II,",LAST IINDEX=",IINDEX C !PRINT *,"." ENDDO C 108 RETURN END C C ******************* C REAL*8 FUNCTION BXPWRS(DZ,DL,DE,DR,II) C C----------------------------------------------------------------------- C C FN.BXPWRS DETERMINES A POWER SERIES OF A FUNCTION OF FORM SUM(CN*R^N) C NOTE: SET BB TO TRUE IF YOU WANT THE INTEGRATION TO ASSUME C THE INTIAL VALUE AT THE ORIGIN IS ZERO C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER II C LOGICAL BB C REAL*8 DZ,DL,DE,DR REAL*8 DC0,DC1,DC,DCM1,DCM2 !COEFFICIENTS C REAL*8 DSUM,DCUR_TERM,DCUR_R,DFIRST_R,DN !,DNTERMS C REAL*8 DT !THRESHOLD,STOP IF THE NEXT TERM IS SMALLER THAN THIS C REAL*8 DZERO,DONE,DTWO,D1M40 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (D1M40=1.D-40) C DT=D1M40 C DC0=DONE DC1=-DZ*DC0/(DL+DONE) C DFIRST_R=DR**(NINT(DL)+1) DSUM=DC0*DFIRST_R+DC1*DFIRST_R*DR C DCUR_R=DFIRST_R*DR C DCM1=DC1 DCM2=DC0 C DN=DTWO BB=.TRUE. C DO WHILE(BB) DC=-(DTWO*DZ*DCM1+DE*DCM2) C !DC=DC/((DN+2.0D00)*(DN+(2.0D00*DL)+3.0D00)) DC=DC/(DN*(DN+DTWO*DL+DONE)) C DCUR_R=DCUR_R*DR DCUR_TERM=DC*DCUR_R C C PRINT *,CUR_TERM DSUM=DSUM+DCUR_TERM C DCM2=DCM1 DCM1=DC C DN=DN+DONE C PRINT *,DCUR_TERM IF(DN.GT.II)THEN C PRINT *,DSUM,DCUR_TERM BB=.FALSE. C DNTERMS=DN ELSE IF(ABS(DCUR_TERM).LT.ABS(DT*DSUM))THEN IF(DC.NE.DZERO) THEN BB=.FALSE. C DNTERMS=DN ENDIF ENDIF ENDIF ENDDO C C PRINT *,"MAX NO.OF TERMS=",I C PRINT *,"TERMS USED=",DNTERMS C BXPWRS=DSUM C RETURN END C C ******************* SUBROUTINE BXSCHN(IN_INT,IANSTEPS,DASTEPSIZE,DZ, X IN,IL,DE,DARFUNC,DR,IR0,IM0) C C----------------------------------------------------------------------- C C SR.BXSCHN IS THE *** MAIN DRIVER FOR BOX ORBITAL GENERATION: *** C SEARCHES FOR THE BOXED STATE WITH Q. NO N,L,Z,E ETC... C ADDED DR0 (29_09_04),CAN BE ANYWHERE IN MESH C REQUIRES THE FOLLOWING SUBROUTINES: C BXSRCH,BXCUNT, BXNUMV,BXNORM, BXDFKK,BXPWRS,BXINFL,BXINT C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN_INT !NO. OF INTERVALS INTEGER IANSTEPS(*),IR0,IM0 !,ISIZE C INTEGER IN,INODES,ICNODES,IL !Q.NO DN,NUMBER OF INODES !REQUIRED,CURRENT NUMBER OF INODES,INTEGER DL INTEGER IDIR !DIRECTION,-1 IF WE MOVED DOWN IN ENERGY, !+1 IF WE ARE MOVING UP C REAL*8 DASTEPSIZE(*) REAL*8 DARFUNC(*),DR(*),DR0 REAL*8 DE,DE0,DDE,DZ,DN,DL,DT,DTF,D_DE_COARSE C REAL*8 DZERO,DTWO,DTEN,DTWELV,D1P2,D99,DPI,D1M6,D1M9 C PARAMETER (DZERO=0.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTEN=10.0D0) PARAMETER (DTWELV=12.0D0) PARAMETER (D1P2=1.0D2) PARAMETER (D99=99.0D0) PARAMETER (DPI=3.14D0) PARAMETER (D1M6=1.0D-6) PARAMETER (D1M9=1.0D-9) C C PRINT *,"CALL BXSCHN()" C PRINT *,"IN=",IN,",IL=",IL,",DE=",DE,",IR0=",IR0 C IF(DE.GT.DZERO)THEN !CHECK MESH DT=SQRT(DE) DT=DPI/DT DT=DT/(DR(IR0)-DR(IR0-1)) IF(DT.LT.DTWELV)THEN WRITE(6,*)'*** BXSCHN: INCREASE MSTEP TO:',IM0+1 WRITE(0,*)'*** BXSCHN: RADIAL MESH TOO COARSE' IL=-999 RETURN ENDIF ENDIF C DT=D1M6 !CONVERGE E-ENERGY TO DT DTF=D1M9 !CONVERGE E-FUNCTION TO DTF DL=IL DN=IN INODES=IN-IL-1 C C***************************************** C DR0=DR(IR0) C !ISIZE=IR0 C IF(DE.GT.-D99*DZ**2)THEN C FIND THE FIRST BOXED STATE NEAR THE INITIAL GUESS C PRINT *,"USING SUPPLIED INITIAL GUESS" DE0=DE ELSE C MAKE AN INITIAL GUESS IF(IN.GT.2) THEN DE0=(DPI*DZ*DN**2)/(2*2*DR0) ELSE DE0=-(DZ**2)/(DN**2) ENDIF C DE0=DE0/2.0D00 C ENDIF C DDE=ABS(DE0)/D1P2 C C PRINT *,"INITIAL GUESS=",DE0,DDE D_DE_COARSE=DE0/DTEN C C IF(DE0.LT.1.0D0)D_DE_COARSE=1.0D0 C ***************************************** C PRINT *,"N=",IN,",L=",IL C PRINT *,"LOOKING FOR ",INODES," INODES" C C ***************************************** C C CALL BXSRCH(IN_INT,IANSTEPS,DASTEPSIZE,DZ,DL,DE0, & DE,DDE,DT,DTF,DARFUNC,DR,IR0) C CALL BXCUNT(IN_INT,IANSTEPS,DTF,DARFUNC,IR0,ICNODES) C C***************************************** C C PRINT *,"E=",DE0," DE=",D_DE_COARSE," ICNODES=",ICNODES C C********************************************* C C DETERMINE WHICH DIRECTION IN ENERGY IT NEEDS TO GO C TO FIND THE CORRECT FUNCTION C IF(ICNODES.LE.INODES)THEN !NEED TO GO UP D_DE_COARSE=ABS(D_DE_COARSE) DDE=ABS(DDE) IDIR=1 ELSE !NEED TO GO DOWN D_DE_COARSE=-ABS(D_DE_COARSE) DDE=-ABS(DDE) IDIR=-1 ENDIF C DO WHILE(ICNODES.NE.INODES) C DE0=DE0+D_DE_COARSE C C OPEN(10,FILE='SRCH.GRF') C CALL WRITE_FILE(10,DR,DARFUNC,10000) C C PRINT *,"E=",DE0," DE=",D_DE_COARSE," ICNODES=",ICNODES C CALL BXSRCH(IN_INT,IANSTEPS,DASTEPSIZE,DZ,DL, & DE0,DE,DDE,DT,DTF,DARFUNC,DR,IR0) C CALL BXCUNT(IN_INT,IANSTEPS,DTF,DARFUNC,IR0,ICNODES) C C FIND WHAT DIRECTION WE NEED TO GO IN NOW C IF(ICNODES.LE.INODES)THEN IF(IDIR.EQ.-1)THEN DE0=DE0+ABS(D_DE_COARSE) D_DE_COARSE=D_DE_COARSE/DTWO ENDIF C ELSE C IF(IDIR.EQ.1)THEN DE0=DE0-ABS(D_DE_COARSE) D_DE_COARSE=D_DE_COARSE/DTWO ENDIF ENDIF ENDDO C C IL=NINT(DL) C PRINT *,"FOUND:" C PRINT *," N=",ICNODES+IL+1," INODES=",ICNODES C PRINT *," L=",IL C PRINT *," Z=",DZ C PRINT *," E=",DE C CALL BXNORM(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DARFUNC) C C CALL WRITE_BOX(DR,DARFUNC,ISIZE) C RETURN END C C ******************* C SUBROUTINE BXSRCH(IN_INT,IANSTEPS,DASTEPSIZE,DZ,DL,DE0, X DE,DDE,DT,DTF,DARFUNC,DR,IR0) C C----------------------------------------------------------------------- C C SR.BXSRCH SEARCHES FOR A FUNCTION WHICH IS 0 AT R0. C C E0 IS INTIAL ENERGY C DE IS THE ENERGY STEPSIZE C T IS THE THRESHOLD VALUE FOR DE C ISIZE IS THE ISIZE OF THE R AND RFUNC ARRAY C C----------------------------------------------------------------------- C IMPLICIT NONE C INTEGER IN_INT !NO. OF INTERVALS INTEGER IANSTEPS(*),IR0 !,ISIZE C REAL*8 DARFUNC(*),DR(*),DASTEPSIZE(*) REAL*8 DE,DE0,DDE,DZ,DL,DT,DTF,DTWO C INTEGER ICNT,ICNT_TOT C C !TEMP STORAGE REAL*8 D_DE REAL*8 DS C PARAMETER (DTWO=2.0D00) C DE=DE0 CALL BXNUMV(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DZ,DL,DE,DARFUNC,DR) C D_DE=DDE DS=1 IF(DARFUNC(IR0).LT.0)DS=-1 C ICNT=0 ICNT_TOT=0 C DO WHILE((ABS(D_DE).GT.DT) !CONVERGE ON E ONLY X .OR.(ABS(DARFUNC(IR0)).GT.DTF) !CONVERGE ON F AS WELL X ) DE=DE+D_DE C ICNT=ICNT +1 ICNT_TOT=ICNT_TOT+1 C IF(ICNT.GE.1000) THEN ICNT=0 C PRINT *,"SEARCHING...",ICNT_TOT," : E=",DE," DE=",D_DE C ENDIF C PRINT *,"(" C PRINT *,D_E C CALL BXNUMV(IN_INT,IANSTEPS,DASTEPSIZE,IR0,DZ,DL,DE,DARFUNC,DR) C C PRINT *,")" C PRINT *," " IF((DARFUNC(IR0)*DS).LT.0) THEN !WE FLIPPED SIGN DE=DE-D_DE D_DE=D_DE/DTWO ENDIF C ENDDO C PRINT *,"ABS(DARFUNC(IR0))=",ABS(DARFUNC(IR0)) C PRINT *,"ABS(D_DE)=",ABS(D_DE) RETURN END C C ******************* C SUBROUTINE CALCFX(N,DX,DF) C C----------------------------------------------------------------------- C C SR.CALCFX HAS BEEN WRITTEN ACCORDING TO THE REQUIREMENTS OF SR.VA04A. C THE ROUTINE RETURNS THE VARIATIONAL FUNCTIONAL DF; DF DEPENDS UPON C N.LE.MXVAR SCALING PARAMETERS DX, SOME OF WHICH MAYBE VARIATIONAL. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (IAXUC=MAXUC) !F77 C PARAMETER (DZERO=0.0D0) C LOGICAL BALAN C CF77 DIMENSION TFWE(MAXUC) !F77 ALLOCATABLE :: TFWE(:) !F95 C DIMENSION DX(*) C COMMON /BASIC/NF,MGAP(11) COMMON /CADJ/ DADJUS(MXVAR),DF0,IEQUAL(MXVAR),ICOUNT COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /CALAN/DALAN(MXVAR),BALAN COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA,MB,KSUBCF !F95 COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV0 COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDEL/TOLB,TOLE,DELELS(MAXTM,2),DELEIC(MAXLV,2),MDELE!F95 X ,MULTS,ISHFTLS,ISHFTIC,NOBS !F95 COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBWGT/EIMXLS,EIMXIC,WLG1,WLG2,IWGHT,IOPTIM,NRSLMX X ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN C C C ASSIGN VALUES DX TO SCALING FACTORS DADJUS(I) C NP0=0 IF(IPOLFN.LT.0)NP0=-IPOLFN NPARM3=(NP0+1)*NPARAM !MXVAR C DO I=1,NPARM3 !=SIZE OF PARAMETER ARRAYS, DEFINED IN SR.MINIM J=IEQUAL(I) IF(J.GT.0)THEN c write(6,*)i,j,dx(j) C IF(J.LE.N)THEN !CONTROLLED BY IEQUAL DADJUS(I)=DX(J) IF(BALAN)DALAN(I)=DX(J) C ENDIF ENDIF ENDDO C IF(ISCALR.GT.0)SCALER=DADJUS(ISCALR) !SLATER SCALING PARAMETER C C UPDATE RADIAL FUNCTIONS & CA ENERGIES C CALL RADIAL(DADJUS) C IF(ICAV0.NE.0)THEN !UNIQUE ICAV=-IABS(ICAV0) CALL CAVE0(ICAV) ENDIF C IF(NF.LE.0)GO TO 20 C C DIAGONALIZE ENERGY MATRIX; DESUM+DECORE=DF+DF0 C DESUM IS THE ENERGY SUM, WITHOUT THE CORE CONTRIBUTION DECORE; C IN THE ALTERNATIVE CASE JPRINT=-2 DIAGON RETURNS DESUM=G, DECORE=0 C IAXDI=1 !F95 NCT=0 !F95 DO M=1,NSL0 !F95 NC=NSL(M) !F95 IAXDI=MAX(IAXDI,NC) !F95 NCT=NCT+NC*NC !F95 ENDDO !F95 C !F95 IF(MOD(NPRNT0,5).EQ.-2.AND.ISHFTLS.LE.0)THEN !F95 IAXUC=IAXDI*IAXDI !F95 IFLAG=-1 !F95 ELSE !F95 IAXUC=NCT !F95 IFLAG=1 !F95 ENDIF !F95 C !F95 ALLOCATE(TFWE(IAXUC),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'CALCFX: ALLOCATION FAILS FOR TFWE' !F95 NF=0 !F95 GO TO 20 !F95 ENDIF !F95 IAXUC=IFLAG*IAXUC !F95 C CALL DIAGON(DECORE,DESUM,TFWE,IAXUC) !H(LS) C IF(NF.LE.0)GO TO 200 C IF(NJO.GT.0)THEN !COMPUTE FINE-STRUCTURE C CALL SOCC !BLUME & WATSON C IF(NF.LE.0)GO TO 200 C CALL DIAGFS(DECORE,DESUM,TFWE) !H(IC) C ENDIF C C 200 CONTINUE C DEALLOCATE(TFWE,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'CALCFX: DE-ALLOCATION FAILS FOR TFWE' !F95 NF=0 !F95 ENDIF !F95 C IF(NF.LE.0)GO TO 20 C IF(IOPTIM.EQ.0)THEN IF(DF0.EQ.DZERO)DF0=DECORE DF=(DECORE-DF0)+DESUM DECORE=-DF0 DESUM=DF-DECORE ELSE DF=DESUM DECORE=DZERO ENDIF C C PRINT THE COMPUTED VALUE OF THE FUNCTIONAL C WRITE(6,799)DF,DESUM,DECORE,ICOUNT C ICOUNT=ICOUNT-1 IF(ICOUNT.NE.0)RETURN C WRITE(6,798) C 20 N=0 C RETURN C 799 FORMAT(/' CALCFX-FUNCTIONAL FX=',E15.8,', =(E-ECORE0)/2RY=', X2E16.9,24X, 'COUNTDOWN INDEX =',I4) 798 FORMAT( ' SR.CALCFX: PARAMETERS IMAXIT AND NEXTRE ALLOW NO MORE XITERATIVE STEPS -- IT MAY NOT BE SENSIBLE TO RESUME ITERATING') C END C C ******************* C SUBROUTINE CAVE(KF,EAV) C C----------------------------------------------------------------------- C C SR.CAVE DETERMINES THE AVERAGE ENERGY OF CONFIGURATION KF C USING ORBITALS (PREVIOUSLY GENERATED) STORED IN COMMON /RADF/. C IT OMITS ANY COMMON CLOSED-SHELL CORE SINCE WE ARE ONLY INTERESTED C IN RELATIVE DIFFERENCES BETWEEN CONFIGURATIONS: RELAXED-UNRELAXED. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MT=60) !~3*max atomic orb 2*l C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (TOLW=1.D-3) !TOLERANCE FOR MATCHING OCCUPATION NOS WK C CHARACTER(LEN=4) CODE C LOGICAL BEQNL,BREL2,BREL,BJUMPR,BMVD,BFOT !BFIX C DIMENSION DFS(MT+1) C C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/POT(MAXB1),TOL,MEND COMMON /COM6/DA(MAXB1) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) c COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM c X ,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /MQVC/MODD,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),R(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBFR/DP(MAXB1) COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit c COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC0 c X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) C DFS(1)=1 DFS(2)=1 DO K=3,MT,2 DFS(K)=-DFS(K-2) DFS(K+1)=(K-1)*DFS(K-1)/32 ENDDO C BREL2=IABS(IREL).EQ.2 AJUST=DONE C C RESTRICT RANGE OF ORBITALS C MXB=0 DO J=1,MXORB IF(IABS(QN(J)).LT.80)MXB=J ENDDO C C INITIALIZE POT(I) C DO I=1,MAXRS POT(I)=DZERO ENDDO C IDIR=0 !INCLUDE DIRECT 2-BODY IXCH=0 !INCLUDE EXCHANGE 2-BODY ct idir=1 ct ixch=1 C C FORM CONFIGURATION AVERAGE POTENTIAL C DO J=1,MXB !LOOP OVER FIRST ELECTRON C IF(NEL(J,KF).NE.0)THEN C IF(IDIR.EQ.0)THEN !PRE-CALC DIRECT YLAMK=0 C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J) ENDDO ELSE DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,J) ENDDO ENDIF C MI=QL(J)+2 C CALL YLAMK(0,MI,DP,DERV,DD1,DD2,MNE,DHNS,MJH,0) !NO RETARD C F0=DBLE((MI-1))/DBLE((2*MI-3)) MJX=MIN(QL(J),8) C ENDIF C K0=MAX(J,MB+1) !EXCLUDE ANY CLOSED CORE C DO K=MXB,K0,-1 !LOOP OVER SECOND ELECTRON C BEQNL=J.EQ.K C C=NEL(K,KF) IF(BEQNL)C=(C-DONE)/DTWO C IF(ABS(C).GT.TOLW)THEN C C=C*ABS(NEL(J,KF)) c IF(IDIR.EQ.1)GO TO 101 C C DIRECT C IF(BEQNL.AND.MJX.GT.0)THEN C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J) ENDDO ELSE DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,J) ENDDO ENDIF C DO MJ=2,MJX,2 C CALL YLAMK(MJ,MI,DP,DA,DD1,DD2,MNE,DHNS,MJH,0)!NO RETARD C DC1=VCC(QL(J),2*MJ,QL(J),0,0,0,DFS,MT) F=-F0*DC1*DC1/(MI-1) c write(6,*)ql(j),2*mj,ql(j),' f=',f C DO I=1,MAXRS DERV(I)=DERV(I)+F*DA(I) ENDDO C ENDDO C ENDIF C IF(BREL2)THEN DO I=1,MAXRS POT(I)=POT(I)-C*DERV(I) X *(DPNL(I,K)*DPNL(I,K)+DQNL(I,K)*DQNL(I,K)) ENDDO ELSE DO I=1,MAXRS POT(I)=POT(I)-C*DERV(I)*DPNL(I,K)*DPNL(I,K) ENDDO ENDIF C C EXCHANGE C 101 IF(.NOT.BEQNL.AND.IXCH.EQ.0)THEN C ME1=IABS(QL(J)-QL(K))/2 ME2=(QL(J)+QL(K))/2 MI=ME2+2 ME2=MIN(ME2,8) C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,K)+DQNL(I,J)*DQNL(I,K) ENDDO ELSE DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,K) ENDDO ENDIF C DO MJ=ME1,ME2,2 C CALL YLAMK(MJ,MI,DP,DA,DD1,DD2,MNE,DHNS,MJH,0)!NO RETARD DC1=VCC(QL(J),2*MJ,QL(K),0,0,0,DFS,MT) G=-DC1*DC1/(2*QL(K)+2) G=G*AJUST !TRY SCALING EXCHANGE c write(6,*)ql(j),2*mj,ql(k),' g=',g C IF(BREL2)THEN DO I=1,MAXRS POT(I)=POT(I)-C*G*DA(I) X *(DPNL(I,J)*DPNL(I,K)+DQNL(I,J)*DQNL(I,K)) ENDDO ELSE DO I=1,MAXRS POT(I)=POT(I)-C*G*DA(I)*DPNL(I,J)*DPNL(I,K) ENDDO ENDIF C ENDDO C ENDIF C ENDIF C ENDDO C ENDIF C ENDDO C C TWO-BODY C CALL WEDDLE(DZERO,POT,E,MNE,DHNS,MJH,MAXRS) C E2BODY=-E !A.U. C C ONE BODY (EXCLUDE ANY CLOSED CORE) C E1BODY=DZERO C DO J=MB+1,MXB IN=NEL(J,KF) IF(IN.GT.0)THEN c write(6,*)'j=',j,' ne=',in E=DEY(J) c write(6,200)dey(j)-duy(j,j),duy(j,j) c 200 format('eps=',1p,d12.5,' V-Z/R=',d12.5) IF(BMVD.OR.NJO.NE.0)E=E+DCD(J,J)+DMASS(J,J) c if(bmvd.or.njo.ne.0)write(6,201)dcd(j,j),dmass(j,j) c 201 format('darwin=',1p,d12.5,' mass=',d12.5) IF(QED.NE.0.AND.QN(J).GT.0)E=E+VPINT(J)+SLFINT(J) c if(qed.ne.0.and.qn(j).gt.0)write(6,202)vpint(j),slfint(j) c 202 format('vac=',1p,d12.5,' self=',d12.5) IF(KUTOO.EQ.98)E=E+DXSI(J,J) c if(kutoo.eq.98)write(6,203)dxsi(j,j) c 203 format('dxsi=',1p,d12.5) E1BODY=E1BODY+IN*E ENDIF ENDDO C c write(6,204)kf,e1body,e2body c 204 format(/'cf=',i3,' e1body=',1p,d12.5,' e2body=',d12.5) c EAV=E1BODY+E2BODY C RETURN C C END C C ******************* C SUBROUTINE CAVE0(ICAV) C C----------------------------------------------------------------------- C C SR.CAVE0 DETERMINES CONFIGURATION AVERAGE ENERGIES BOTH USING AN C INTERNAL RELAXED ORBITALS BASIS (ICAV.GT.0) AND THEN USING THE C EXISTING (UNIQUE) ORBITAL BASIS (ICAV.LT.0). THE TWO ARE STORED C SEPARATELY IN ECAVX AND ECAV TO ENABLE THE LATTER TO BE UPDATED C E.G. DURING MINIMIZATION. THE DIFFERENCE IS THEN APPLIED TO THE C DIAGONAL OF THE HAMILTONIAN IN SR.DIAGON AND SR.DIAGFS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D999=999.0D0) C CHARACTER(LEN=4) CODE C LOGICAL BALAN,BSTO,BSTOH,BFIX C DIMENSION DX(MXVAR) X,MSTOH(MAXGR),DEYH(MAXGR),SCREEH(MAXGR),TELH(MAXGR) C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /CALAN/DALAN(MXVAR),BALAN COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODD,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA,MB,KSUBCF !F95 COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV0 COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC0 X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) C IF(ICAV.GT.0)THEN !NEW SELF-CONSISTENT BASIS C C HOLD USER VALUES C MAUTOH=MAUTO MDENH=MDEN MEXH=MEXPOT MHFH=MHF MRADH=MRAD MCFMXH=MCFMX BSTOH=BSTO NOCCH=NOCC0 DO I=1,MXORB MSTOH(I)=MCFSTO(I) TELH(I)=TEL(I) DEYH(I)=DEY(I) SCREEH(I)=SCREEN(I) ENDDO C C NOW SET-UP FOR A SELF-CONSISTENT CALCULATION C MAUTO=MIN(0,MAUTO) MHF=0 MRAD=0 MCFMX=MXORB BSTO=.TRUE. MDEN=-10 IF(NOCC0.EQ.0)THEN !ELSE STICK WITH USER INPT MEXPOT=0 !FULL EXCHANGE NOCC0=-1000 !NON-UNIQUE, I.E. FAC=NO ELSEIF(NOCC0.LT.0)THEN !USE INDIVIDUAL CF OCC NOS NOCC0=-1000 ELSE !BUT ALLOW FAC='YES' POT NOCC0=1000 ENDIF C NP0=0 IF(IPOLFN.LT.0)NP0=-IPOLFN NPARM3=(NP0+1)*NPARAM !MXVAR C DO I=1,NPARM3 !ASSIGN GLOBAL SCALE VALUE DX(I)=AJUSTX IF(BALAN)DALAN(I)=AJUSTX ENDDO C ELSE C WRITE(6,200) C ENDIF C C LOOP OVER THE KM CONFIGURATIONS C DO K=1,KM C IF(ICAV.GT.0)THEN C DO I=1,MXORB MCFSTO(I)=K IF(NEL(I,K).NE.0)THEN IF(SCREEN(I).GT.-D999)THEN SCREEN(I)=SCREEH(I) DEY(I)=DONE ENDIF ELSEIF(QN(I).LT.70)THEN DEY(I)=DZERO SCREEN(I)=DZERO ENDIF ENDDO C CALL RADIAL(DX) !UPDATE RADIAL FUNCTIONS C IF(NF.LE.0)GO TO 20 C DO I=1,NPARAM !RE-SET IF(SCREEN(I).GT.-D999)THEN DO N=0,NP0 N0=N*NPARAM+I DAJOLD(N0)=DZERO ENDDO ENDIF ENDDO C ENDIF C CALL CAVE(K,EAV) C C IF(ICAV.GT.0)THEN ECAVX(K)=EAV MAXRS=0 !RESET INITIAL RADIAL MESH ELSE ECAV(K)=EAV WRITE(6,202)K,ECAVX(K),ECAV(K),ECAVX(K)-ECAV(K) ENDIF C ENDDO !END LOOP OVER CFS C IF(ICAV.GT.0)THEN !RE-INSTATE MAUTO=MAUTOH MDEN=MDENH MEXPOT=MEXH MHF=MHFH MRAD=MRADH MCFMX=MCFMXH BSTO=BSTOH NOCC0=NOCCH DO I=1,MXORB MCFSTO(I)=MSTOH(I) TEL(I)=TELH(I) IF(SCREEN(I).GT.-D999)THEN DEY(I)=DEYH(I) SCREEN(I)=SCREEH(I) ENDIF ENDDO ENDIF C 20 RETURN C 200 FORMAT(//' CONFIGURATION AVERAGE ENERGIES:' X /45X,'CF',10X,'ECAVX',12X,'ECAV',12X,'DIFFERENCE') 202 FORMAT(42X,I5,2X,1P,2D17.7,3X,D15.5) C END C C ******************* C SUBROUTINE CASC C C----------------------------------------------------------------------- C C SR.CASC CALCULATES CASCADE COEFFICIENTS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD14=100) C PARAMETER (ZERO=0.0D0) C LOGICAL LCOR,BPRINT,HFF C CHARACTER(LEN=2) NY,NO,NB C DIMENSION ATOT(MAXLV),CAS(MAXCA),BUF(MAXLV) X,NPOS(MAXLV),NEX(MAXLV),NS(MAXLV) C COMMON /BASIC/NF,KVAR,HFF,MGAP(9) COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JJ(MAXLV),NGR(MAXLV) COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBCAS/AP(MXNOR),MADD(MXNOR) COMMON /NRBTRN/MENERG,IORIG(MAXLV) COMMON /NRBUNI/IUNIT(MXD14),NUNIT C DATA NY,NO/' ','NO'/ C C OPEN PUNCHFILE C IF(MPNCH.LT.0)THEN MP=2 !FIXED PUNCH TO UNIT2 CASE MPNCH.LT.0 IF(IUNIT(MP).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='CASC'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=2' NF=-1 RETURN ENDIF IUNIT(MP)=1 OPEN(MP,FILE='CASC',STATUS='REPLACE') !OPTIONAL CASCADE COEFFS ENDIF C C FIND NUMBER OF LEVELS IN LOWEST CONFIGURATION C NG=0 LCOR=.FALSE. C DO I=1,MENERG ATOT(I)=ZERO NPOS(I)=0 IOLD=IORIG(I) LCOR=LCOR.OR.IOLD.LT.0 IF(IOLD.GE.0)THEN IOLD=NRR(IOLD) IF(NG.EQ.0)NFK1=NFK(IOLD) IF(NFK(IOLD).EQ.NFK1)NG=NG+1 ENDIF ENDDO C IF(KUTCA.GT.NG)NG=KUTCA IF(KUTCA.GT.(MENERG-1))NG=MENERG-1 C IF(NG.EQ.1)THEN !TRIVIAL RETURN WRITE(6,5) GO TO 100 ENDIF C NCA=NG*(2*MENERG-NG-1)/2 IF(NCA.GT.MAXCA)THEN !DIMENSION EXCEEDED WRITE(6,70)NCA GO TO 100 ENDIF C NB=NO IF(MPNCH.LT.0)NB=NY WRITE(6,60)KUTCA,NG,MPNCH,NB IF(LCOR)WRITE(6,95) WRITE(6,61) C C A GIVEN LEVEL NU AND STORE POINTER NPOS(I) OF LAST TRANS. PROB. C RELATED TO LEVEL I IN ARRAY AP. C NAC=MADD(MXNOR) DO I=1,NAC NU=MADD(I)/MENERG+1 ATOT(NU)=ATOT(NU)+AP(I) NPOS(NU)=I ENDDO DO I=1,NCA CAS(I)=ZERO ENDDO C NS(1)=0 NBEG=0 DO I=2,MENERG IS=NS(I-1)+I-2 IF(I.GT.NG+2)IS=NS(I-1)+NG NS(I)=IS C IF(IORIG(I).GE.0)THEN IM=I-1 IF(IM.GT.NG)IM=NG NFIN=NPOS(I) DO N=1,I BUF(N)=ZERO NEX(N)=0 ENDDO IF(NFIN.NE.0)THEN NBEG=NBEG+1 DO N=NBEG,NFIN NL=MADD(N)-(I-1)*MENERG+1 NEX(NL)=N ENDDO NBEG=NFIN C DO N=1,IM NTRAN=NEX(N) IF(NTRAN.GT.0)THEN !FOR STUPID COMPILERS CAS(IS+N)=AP(NTRAN)/ATOT(I) ENDIF IF(N.NE.IM)THEN NP=N+1 IMT=I-1 DO J=NP,IMT NTRAN=NEX(J) IF(NTRAN.GT.0)THEN IT=NS(J) CAS(IS+N)=CAS(IS+N)+AP(NTRAN)/ATOT(I)*CAS(IT+N) ENDIF ENDDO BUF(N)=CAS(IS+N) ENDIF ENDDO ENDIF C WRITE(6,90)(I,N,BUF(N),N=1,IM) IF(MPNCH.LT.0)WRITE(MP,50)(I,N,BUF(N),N=1,IM) ENDIF C ENDDO C 100 IF(MPNCH.LT.0)THEN CLOSE(MP,STATUS='KEEP') IUNIT(MP)=-1 ENDIF C RETURN C 5 FORMAT(//20X,'CASCADE COEFFS NOT CALCULATED SINCE CONFIG 1 HAS' X,' 1 LEVEL') 50 FORMAT(5(2I3,2X,F8.6)) 60 FORMAT(//35X, 'CASCADE COEFFICIENTS'/' CONTROL PARAMETERS FOR ', X 'CASC: INPUT KUTCA=',I6,8X,'EFFECTIVE KUTCA=',I6,8X,'MPNCH=',I4/ X 3X,A2,' CASCADE COEFFICIENTS WILL BE PUNCHED') 61 FORMAT(//7(4X,'K KP C(KP,K) ')/) 70 FORMAT(' ** SR.CASC **: STORAGE EXCEEDED; INCREASE MAXCA TO',I6) 90 FORMAT(7(2X,2I3,2X,F8.6)) 95 FORMAT(' TRANSITIONS INVOLVING CORRELATION LEVELS HAVE BEEN', X' OMITTED. IF REQUIRED SET IC.JPRINT=1.') C END C C ******************* C CHARACTER(LEN=2) FUNCTION CELMNT(NZION) C C C----------------------------------------------------------------------- C C FN.CELMNT RETURNS 2-CHARACTER ELEMENT SYMBOL FOR NUCLEAR CHRAGE NZION C C----------------------------------------------------------------------- C IMPLICIT NONE C CHARACTER(LEN=2) ELEM2(92) INTEGER NZION C DATA XELEM2/'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE','NA','MG' X,'AL','SI','P ','S ','CL','AR','K ','CA','SC','TI','V ','CR','MN' X,'FE','CO','NI','CU','ZN','GA','GE','AS','SE','BR','KR','RB','SR' X,'Y ','ZR','NB','MO','TC','RU','RH','PD','AG','CD','IN','SN','SB' X,'TE','I ','XE','CS','BA','LA','CE','PR','ND','PM','SM','EU','GD' X,'TB','DY','HO','ER','TM','YB','LU','HF','TA','W ','RE','OS','IR' X,'PT','AU','HG','TL','PB','BI','PO','AT','RN','FR','RA','AC','TH' X,'PA','U '/ C IF(NZION.LE.0.OR.NZION.GT.92)THEN CELMNT=' ' ELSE CELMNT=ELEM2(NZION) ENDIF C RETURN END CGNRC CGNRC ******************* CGNRC CGNR SUBROUTINE CGNR(DEXTRE,NVAR,IMAXIT) CGNRC CGNRC------------------------------------------------------------------- CGNRC CGNRC SR.CGNR INTERFACES WITH THE NUMERICAL RECIPES CONJUGATE GRADIENT CGNRC CODE SUITE CGNRC CGNRC THE SOURCE IS *NOT* PROVIDED HERE DUE TO THEIR LICENSING CGNRC RESTRICTIONS. LINK AT THE COMPILATION STAGE TO YOUR OWN COPY CGNRC OF THE LIBRARY. CGNRC THIS HAS BEEN TESTED TO WORK WITH VANILLA STRAIGHT-OUT-OF-THE-TIN CGNRC UNMODIFIED NUMERICAL RECIPES CODE. IT *MUST* BE THE REAL*8 CGNRC VERSION, FORCING IT VIA A COMPILER SWITCH IS NOT RECOMMENED. CGNRC CGNRC------------------------------------------------------------------- CGNRC CGNR IMPLICIT REAL*8 (A-H,O-P,R-Z) CGNRC CGNR INCLUDE './PARAM' CGNRC CGNRC PARAMETER (DZERO=0.0D0) CGNRc PARAMETER (D1M5=1.0D-5) CGNR PARAMETER (D1M6=1.0D-6) CGNRC CGNR PARAMETER (NMAX=50) !NUM. REC. DEFAULT CGNR REAL*8 pcom(NMAX),xicom(NMAX) !NUM. REC. COMMON CGNR COMMON /f1com/ pcom,xicom,ncom !NUM. REC. COMMON CGNRC CGNR DIMENSION DEXTRE(*) CGNRC CGNRc common /cadj/dadjus(mxvar),df0,iequal(mxvar),icount CGNR COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM CGNR X ,ITOL,INCLUD,JPRINT CGNR COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN CGNRC CGNR NP0=0 CGNR IF(IPOLFN.LT.0)NP0=-IPOLFN CGNR NPARM3=(NP0+1)*NPARAM !MXVAR CGNRC CGNR NVAR=-NVAR CGNRC CGNR IF(NVAR.GT.NMAX)THEN !SHIRELY, SOME MISTAKE CGNR WRITE(6,1081)NVAR,NMAX CGNR WRITE(0,*)' TOO MANY VARIATIONAL PARAMETERS...!!!' CGNR GO TO 999 CGNR ENDIF CGNRC CGNR TOL=D1M6 !SUBJECT TO CHANGE CGNR IF(NP0.GT.0)TOL=D1M6 ! " " " CGNRC CGNRc LIMIT=NVAR*IMAXIT+IMAXIT+2 !200 IS NUM. REC. DEFAULT CGNRc itout=limit !itmax= in modified frprmn CGNRC CGNR ncom=-NPARM3 !PASS THRU TO FUNC CGNR DUMMY=FUNC(DEXTRE) !INITIALIZE DEXTRE STORE CGNRC CGNR ncom=NVAR !PASS THRU TO FUNC, DFUNC CGNRC CGNR CALL FRPRMN(DEXTRE,NVAR,TOL,ITOUT,DF) !REQUIRES REAL*8 VERSION CGNRC CGNR WRITE(6,1082)ITOUT CGNRC CGNR IF(ITOUT.EQ.1)THEN CGNR WRITE(6,1084)TOL,DF CGNR WRITE(0,*) CGNR X 'NR CONJUGATE GRADIENT DOES NOT CHANGE FUNCTIONAL...' CGNR GO TO 999 CGNR ENDIF CGNRC CGNR IF(ITOUT.EQ.200)THEN !LIMIT CGNR WRITE(6,1083)TOL,DF CGNR WRITE(0,*)'NR CONJUGATE GRADIENT HAS FAILED TO CONVERGE...' CGNR GO TO 999 CGNR ENDIF CGNRC CGNRc write(0,*)DF,imaxit,limit,itout,icount CGNRC CGNR RETURN CGNRC CGNR 999 IMAXIT=-1 CGNR RETURN CGNRC CGNR 1084 FORMAT(//' *** NR CONJUGATE GRADIENT DOES NOT CHANGE' CGNR X,' FUNCTIONAL:,2(1PD10.2)) CGNR 1083 FORMAT(//' *** NR CONJUGATE GRADIENT HAS FAILED TO CONVERGE' CGNR X,' TO CONVERGE TO THE REQUESTED ACCURACY:',2(1PD10.2)) CGNR 1082 FORMAT(I5,' ITERATIONS COMPLETED BY NR CONJUGATE GRADIENT' CGNR X,' METHOD') CGNR 1081 FORMAT(//' *** CGNR: NUMBER OF VARIATIONAL PARAMETERS EXCEEDS' CGNR X,' THAT ALLOWED BY NUMERICAL RECIPES - SOME MISTAKE, SURELY?' CGNR X,2I4) CGNRC CGNR END CGNRC CGNRC ******************* CGNRC CGNR REAL*8 FUNCTION FUNC(X) CGNRC CGNRC------------------------------------------------------------------- CGNRC CGNRC FN.FUNC EVALUATES THE COST (C) OF THE FUNCTIONAL AT X(N). CGNRC CGNRC------------------------------------------------------------------- CGNRC CGNR IMPLICIT REAL*8 (A-H,O-Z) CGNRC CGNR INCLUDE './PARAM' CGNRC CGNR PARAMETER (DZERO=0.0D0) CGNRC CGNR PARAMETER (NMAX=50) !NUM. REC. DEFAULT CGNR REAL*8 pcom(NMAX),xicom(NMAX) !NUM. REC. COMMON CGNR COMMON /f1com/ pcom,xicom,ncom !NUM. REC. COMMON CGNRC CGNR DIMENSION XOLD(MXVAR),X(*) CGNRC CGNR DATA NOLD/0/ CGNRC CGNR SAVE NOLD,XOLD CGNRC CGNRC FIRST CALL MUST BE WITH N=-NPARAM TO STORE ALL SCALING PARAMETERS CGNRC IN XOLD. THEN SUBSEQUENT CALLS WITH N=NVAR.GT.0. X(I.GT.NVAR) ARE CGNRC THEN SUPPLEMENTED BY THOSE FROM XOLD. THIS IS BECAUSE (NUM. REC.) CGNRC CG USES DIFFERENT VECTORS FOR ADJUSTED VALUES, RATHER THAN CGNRC OVERWRITING THE ORIGINAL, NECESSARILY. SO THE DORMANT VALUES ARE CGNRC NOT PRESENT. CGNRC CGNR N=ncom CGNRC CGNR IF(N.LT.0)THEN !STORE IN XOLD CGNR NOLD=-N CGNR DO I=1,NOLD CGNR XOLD(I)=X(I) CGNR ENDDO CGNR C=DZERO CGNR GO TO 10 CGNR ELSEIF(N.GT.0)THEN !SUPPLEMENT X CGNR IF(NOLD.EQ.0)THEN CGNR WRITE(6,*)'*** CG: FUNC, NOT INITIALIZED' CGNRC STOP'*** CG: FUNC, NOT INITIALIZED' CGNR C=DZERO CGNR GO TO 10 CGNR ENDIF CGNR DO I=N+1,NOLD CGNR X(I)=XOLD(I) CGNR ENDDO CGNR ELSE CGNR WRITE(6,*)'*** CG: FUNC, ILLEGAL INPUT N=0' CGNRC STOP'*** CG: FUNC, ILLEGAL INPUT N=0' CGNR C=DZERO CGNR GO TO 10 CGNR ENDIF CGNRC CGNR CALL CALCFX(NOLD,X,C) CGNRC CGNR IF(NOLD.EQ.0)THEN CGNR WRITE(6,*)'*** CG: FUNC, CALCFX ABORTED' CGNRC STOP'*** CG: FUNC, CALCFX ABORTED' CGNR C=DZERO CGNR GO TO 10 CGNR ENDIF CGNRC CGNR 10 FUNC=C CGNRC CGNR RETURN CGNR END CGNRC CGNRC ******************* CGNRC CGNR SUBROUTINE DFUNC(X,G) CGNRC CGNRC------------------------------------------------------------------- CGNRC CGNRC SR.DFUNC EVALUATES THE GRADIENT (G(N)) OF THE FUNCTIONAL AT X. CGNRC CGNRC------------------------------------------------------------------- CGNRC CGNR IMPLICIT REAL*8 (A-H,O-Z) CGNRC CGNR PARAMETER (D1M4=1.0D-4) CGNRC CGNR PARAMETER (NMAX=50) !NUM. REC. DEFAULT CGNR REAL*8 pcom(NMAX),xicom(NMAX) !NUM. REC. COMMON CGNR COMMON /f1com/ pcom,xicom,ncom !NUM. REC. COMMON CGNRC CGNR DIMENSION X(*),G(*) CGNRC CGNR N=ncom CGNRC CGNR DX=D1M4 !SUBJECT TO CHANGE CGNR DX2=DX+DX CGNRC CGNR DO I=1,N CGNR X(I)=X(I)+DX CGNR FP=FUNC(X) CGNR X(I)=X(I)-DX2 CGNR FM=FUNC(X) CGNR X(I)=X(I)+DX CGNR G(I)=(FP-FM)/DX2 CGNR ENDDO CGNRC CGNR RETURN CGNR END C C ******************* C SUBROUTINE CGNR(DEXTRE,NVAR,IMAXIT) C C----------------------------------------------------------------------- C C SR.CNGR: THIS IS A DUMMY REPLACEMENT FOR THE INTERFACE ROUTINE TO THE C NUMERICAL RECIPES CONJUGATE GRADIENT BRANCH C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C DIMENSION DEXTRE(*) C C SUPPRESS COMPILER WARNINGS (SIGH...) C DDUM=DEXTRE(1) NDUM=NVAR C WRITE(6,1000) C WRITE(0,*) X'*** CGNR: DUMMY INTERFACE ROUTINE TO NUM REC CONJ GRAD ***' C IMAXIT=-1 C RETURN C 1000 FORMAT(//'*** THIS IS A DUMMY INTERFACE ROUTINE FOR THE NUMERICAL' X,' RECIPES CONJUGATE GRADIENT METHOD. SET NVAR.GT.0 TO USE VA04A.' X/'*** OR UNCOMMENT NON-DUMMY CGNR ROUTINE, RECOMPILE *AND* ' X,'LINK TO YOUR OWN LICENSED NUMERICAL RECIPES LIBRARY!'///) C END C C*********************************************************************** C REAL*8 FUNCTION CNORM(E,Z,L) C C----------------------------------------------------------------------- C C FN.CNORM RETURNS NORMALIZATION COEFFICIENT FOR A COULOMB FUNCTION OF C ENERGY E, ANGULAR MOMENTUM L IN A CHARGE Z (<0) - BASED ON FCF4. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DETY=8.0D1) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M5=1.0D-5) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M15=1.0D-15) PARAMETER (D1M40=1.0D-40) PARAMETER (D1P70=1.0D+70) C PI=ACOS(-DONE) ZZ=Z*Z C IF(E.GT.D1M40)GO TO 6 IF(ABS(Z).GT.D1M15)GO TO 3 C 38 CNORM=DZERO !FAILURE C RETURN C 3 IF(Z.LT.DZERO)GO TO 5 4 CNORM=-DONE GO TO 38 C 5 C=-Z*(PI+PI) GO TO 11 C 6 EK=SQRT(E) T1=PI*Z/EK T2=ABS(T1) IF(T2.GT.D1M2)GO TO 8 C C=DTHREE*EK/(DTHREE+T1*(DTHREE+T1*(DTWO+T1))) GO TO 11 C 8 IF(T2.LT.DETY)GO TO 10 IF(Z.LT.DZERO)GO TO 5 GO TO 4 C 10 C=DONE-EXP(T1+T1) C=-(PI+PI)*Z/C 11 C2=DONE C IF(L.GT.0)THEN DO J=1,L CJ=J CJ2=J+J C2=C2*CJ*(CJ2+DONE) C=C*(ZZ+E*CJ*CJ) 30 IF(C+C2.GE.D1P70)THEN C2=D1M5*C2 C=D1M10*C GO TO 30 ENDIF ENDDO ENDIF C CNORM=SQRT(C)/C2 C RETURN END C C ******************* C SUBROUTINE CONFG0(ICFG0,K2,MXORBR,MXORB,MXCONF,MXCCF,IFILL0) C C----------------------------------------------------------------------- C C SR.CONFG0 GENERATES CONFIGURATION INPUT FOR THE A.S. OPTION C C ICFG=0(DEFAULT)JUST READS I0,MXORB VALENCE OCCUPATION NOS C FOR THE MXCONF CONFIGS. C =1 READS GLOBAL MIN AND MAX ALLOWED OCCUPATION NOS C (MNAL,MXAL)THEN AS ICFG=0, PLUS NUMBER OF EXCITATIONS C IN POSITION MXORB+1. C =2 READS MNAL,MXAL FOR EACH(BASE)MXCONF CONFIG. MXCONF IS C THUS REDEFINED. C C----------------------------------------------------------------------- C IMPLICIT REAL*8(A-H,O-P,R-Z) IMPLICIT INTEGER(Q) C INCLUDE './PARAM' C LOGICAL BTWO,BBUG,BPUNCH,EX C CHARACTER(LEN=6) FORM,FORM2,FORM3 c PARAMETER (MXD14=100) C PARAMETER(FORM2='(60I2)') PARAMETER(FORM3='(40I3)') C COMMON /BASIC/NF,MGAP(11) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODE,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF) COMMON /NRBUNI/IUNIT(MXD14),NUNIT C DIMENSION MNAL(MAXGR,MAXCF),MXAL(MAXGR,MAXCF),MXN(MAXGR,MAXCF) A ,IBASSH(MAXGR,MAXCF),NXCITE(MAXCF),IOCSH(MAXCF) B ,JBASSH(MAXGR,MAXCF),NI(MAXGR),NTOTI(MAXGR),MN(MAXGR) C ,NSPARE(MAXCF),LOCSH(MAXCF) D ,LBASSH(MAXGR,MAXCF) C EQUIVALENCE(JBASSH(1,1),NEL(1,1)) C LBASSH(1,1)=0 !SUPPRESS COMPILER WARNINGS LOCSH(1)=0 !ONLY USED FOR BTWO=.T. NCON1=0 !AND SO INFACT ALWAYS SET NTOTI(1)=0 !BEFORE USE C NOPTN=MXCONF IFILL1=MOD(IFILL0,10) IFILL2=IFILL0/10 C BBUG=.TRUE. BPUNCH=ICFG0.GE.0 BTWO=.FALSE. C IZERO=0 IREAD=5 IWRITE=6 IPUNCH=3 C IF(IUNIT(IPUNCH).LE.0)THEN IF(BPUNCH)THEN C OPEN(IREAD,FILE='dstgc',STATUS='OLD') c OPEN(IWRITE,FILE='routc',STATUS='REPLACE') OPEN(IPUNCH,FILE='CONFIG.DAT',STATUS='REPLACE') ELSE INQUIRE(FILE='CONFIG.DAT',EXIST=EX) IF(EX)THEN OPEN(IPUNCH,FILE='CONFIG.DAT',STATUS='OLD') WRITE(IWRITE,3000)IREAD IREAD=IPUNCH ELSE WRITE(6,*)'USER INPUT FILE "CONFIG.DAT" MISSING, ' X ,'BUT IS REQUIRED BECAUSE OF ICFG SETTING' WRITE(0,*)'USER INPUT FILE "CONFIG.DAT" MISSING, ' X ,'BUT IS REQUIRED BECAUSE OF ICFG SETTING' GO TO 999 ENDIF ENDIF IUNIT(IPUNCH)=1 ELSE REWIND(IPUNCH) ENDIF C C NUMBER OF CONFIGURATION SETS TO BE READ, AND ORBITALS C IF(.NOT.BPUNCH)READ(IREAD,*)K2,MXORB I00=IABS(K2) I0=I00+1 IF(.NOT.BPUNCH)READ(IREAD,*)(QN(L),QL(L),L=I0,MXORB) C ICFG=MOD(ICFG0,10) IF(ICFG0.LT.0)THEN ICFG=1 MXORBR=MXORB ENDIF C IF(IABS(ICFG).GT.2)THEN !ILLEGAL OPTIONAL VALUE WRITE(IWRITE,*)'*SR.CONFIG: ERROR, ICFG HAS ILLEGAL VALUE:',ICFG WRITE(0,*)'*SR.CONFIG: ERROR, ICFG HAS ILLEGAL VALUE:' GO TO 999 ENDIF C 1 IF(.NOT.BPUNCH)READ(IREAD,*)NOPTN IF(BBUG)WRITE(IWRITE,3080)NOPTN,MXORB C c IF(NOPTN.LE.0)STOP'NORMAL END' C IF(NOPTN.GT.MAXCF)THEN WRITE(IWRITE,3010)NOPTN WRITE(0,*)'INCREASE MAXCF' GO TO 999 ENDIF IF(MXORB.GT.MAXGR)THEN WRITE(IWRITE,3020)MXORB WRITE(0,*)'INCREASE MAXGR' GO TO 999 ENDIF C C A CONFIGURATION SET CONSISTS OF MIN OCCUPATION NOS, MAX C OCCUPATION NOS, OCCUPATION NOS OF A BASIC CONFIGURATION C TOGETHER WITH NUMBER OF EXCITATIONS FROM THE BASIC CONFIG. C IFLG3=0 NCON=NOPTN IF(ICFG.EQ.0)THEN DO M=1,NOPTN NXCITE(M)=0 READ(IREAD,*)(JBASSH(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3110)M,(JBASSH(I,M),I=I0,MXORBR) DO I=I0,MXORBR IF(JBASSH(I,M).GT.9)IFLG3=1 ENDDO DO I=MXORBR+1,MXORB !CASE ICFG=10, MXORBR.LT.MXORB JBASSH(I,M)=0 ENDDO ENDDO GO TO 200 !RETURN ENDIF C IFILL=IFILL1 IF(BTWO)IFILL=IFILL2 C IF(ICFG.EQ.1)THEN M=1 READ(IREAD,*)(MNAL(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3090)(MNAL(I,M),I=I0,MXORBR) READ(IREAD,*)(MXAL(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3100)(MXAL(I,M),I=I0,MXORBR) DO M=1,NOPTN READ(IREAD,*,END=10)(IBASSH(I,M),I=I0,MXORBR),NXCITE(M) IF(BBUG)WRITE(IWRITE,3110)M,(IBASSH(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3120)NXCITE(M) DO I=I0,MXORB MNAL(I,M)=MNAL(I,1) MXAL(I,M)=MXAL(I,1) ENDDO DO I=MXORBR+1,MXORB IBASSH(I,M)=0 MNAL(I,M)=0 MXAL(I,M)=IFILL ENDDO ENDDO GO TO 20 10 M=M-1 WRITE(IWRITE,3040)NOPTN,M NOPTN=M NCON=M ENDIF C IF(ICFG.EQ.2)THEN DO M=1,NOPTN READ(IREAD,*)(MNAL(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3090)(MNAL(I,M),I=I0,MXORBR) READ(IREAD,*)(MXAL(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3100)(MXAL(I,M),I=I0,MXORBR) READ(IREAD,*)(IBASSH(I,M),I=I0,MXORBR),NXCITE(M) IF(BBUG)WRITE(IWRITE,3110)M,(IBASSH(I,M),I=I0,MXORBR) IF(BBUG)WRITE(IWRITE,3120)NXCITE(M) DO I=MXORBR+1,MXORB IBASSH(I,M)=0 MNAL(I,M)=0 MXAL(I,M)=IFILL ENDDO ENDDO ENDIF C c perform sanity checks. this is to catch typos etc. c 20 do m=1,noptn if(nxcite(m).lt.0)nxcite(m)=0 do i=i0,mxorbr if(mnal(i,m).lt.0)mnal(i,m)=0 if(mxal(i,m).lt.0)mxal(i,m)=0 if(ibassh(i,m).lt.0)ibassh(i,m)=0 mx=4*ql(i)+2 if(mnal(i,m).gt.mx)mnal(i,m)=mx if(mxal(i,m).gt.mx)mxal(i,m)=mx if(ibassh(i,m).gt.mx)ibassh(i,m)=mx enddo enddo c IF(ICFG0.LT.0)THEN NEX=0 DO M=1,NOPTN NEX=NEX+NXCITE(M) ENDDO IF(NEX.EQ.0)THEN DO M=1,NOPTN DO I=I0,MXORB JBASSH(I,M)=IBASSH(I,M) ENDDO ENDDO GO TO 200 ENDIF ENDIF C C DETERMINE NUMBER OF ELECTRONS C NELC=0 DO I=I0,MXORB NELC=NELC+IBASSH(I,1) ENDDO IF(BBUG)WRITE(IWRITE,3270)NELC C C CHECK OTHER CONFIGS FOR CONSISTENCY C IFAIL=0 DO M=2,NOPTN N=0 DO I=I0,MXORB N=N+IBASSH(I,M) ENDDO IF(N.NE.NELC)THEN IFAIL=1 WRITE(IWRITE,3280)M,N ENDIF ENDDO C IF(IFAIL.NE.0)THEN WRITE(6,*)'SR.CONFG0 ERROR: CONFIGURATION MIS-MATCH' WRITE(0,*)'SR.CONFG0 ERROR: CONFIGURATION MIS-MATCH' GO TO 999 ENDIF C C PERFORM SOME CHECKS ON MNAL AND MXAL FOR CONSISTENCY C IFAIL=0 DO M=1,NOPTN NSPARE(M)=NELC DO I=I0,MXORB NSPARE(M)=NSPARE(M)-MNAL(I,M) ENDDO IF(NSPARE(M).LT.0)THEN WRITE(IWRITE,3290)M IFAIL=1 ENDIF ENDDO C IF(IFAIL.NE.0)THEN WRITE(6,*)'SR.CONFG0 ERROR: MNAL INCONSISTENCY' WRITE(0,*)'SR.CONFG0 ERROR: MNAL INCONSISTENCY' GO TO 999 ENDIF C DO M=1,NOPTN DO I=I0,MXORB NE=MNAL(I,M)+NSPARE(M) IF(NE.LT.MXAL(I,M))THEN MXAL(I,M)=NE WRITE(IWRITE,3300)I,M ENDIF MXN(I,M)=MXAL(I,M)+1 ENDDO ENDDO C C CHECK CONSISTENCY OF BASIC CONFIG WITH MNAL,MXAL AND C STORE LAST OCCUPIED SHELL FOR EACH BASIC CONFIGURATION C IFAIL=0 DO M=1,NOPTN DO I=I0,MXORB J=MXORB-I+I0 IF(IBASSH(J,M).GT.0)THEN IOCSH(M)= J DO L=I0,J IF(IBASSH(L,M).GT.MXAL(L,M))THEN WRITE(IWRITE,3292)M IFAIL=1 ELSEIF(IBASSH(L,M).LT.MNAL(L,M))THEN WRITE(IWRITE,3295)M IFAIL=1 ENDIF ENDDO GO TO 90 ENDIF IF(MNAL(J,M).GT.0)THEN WRITE(IWRITE,3295)M IFAIL=1 ENDIF ENDDO 90 ENDDO C IF(IFAIL.NE.0)THEN WRITE(6,*)'SR.CONFG0 ERROR: BASIC CONFIG INCONSISTENCY' WRITE(0,*)'SR.CONFG0 ERROR: BASIC CONFIG INCONSISTENCY' GO TO 999 ENDIF C C LOOP OVER ALL POSSIBLE ELECTRON DISTRIBUTIONS C NCON=0 DO M=1,NOPTN I=I00 C 110 I=I+1 NI(I)= 0 C 120 NI(I)= NI(I)+ 1 NSTOP=I C MI=MXN(I,M)- NI(I) IF(MI.LT.MNAL(NSTOP,M))GO TO 130 NTOT=MI IF(I.GT.1)NTOT=NTOT+NTOTI(I-1) NTOTI(I)= NTOT MN(I)= MI IF(NTOT.GT.NELC)GO TO 130 IF(NTOT.LT.NELC)GO TO 125 C C TEST FOR EXCITATION ALLOWED FROM THE BASIC CONFIGURATIONS C NEX=0 DO L=I0,IOCSH(M) IF(L.GT.NSTOP)THEN NEX=NEX+IBASSH(L,M) GO TO 30 ENDIF MB=IBASSH(L,M) MA=MN(L) IF(MA.LT.MB)NEX=NEX+MB-MA 30 ENDDO C IF(NEX.LE.NXCITE(M))THEN !ALLOWED C DO N=1,NCON !SEE IF WE ALREADY HAVE IT DO L=I0,NSTOP IF(MN(L).NE.JBASSH(L,N))GO TO 122 ENDDO GO TO 125 !OLD 122 ENDDO C IF(BTWO)THEN !SEE IF N+1 CAN BE FORMED FROM N CONFIG DO L=NSTOP+1,MXORB MN(L)=0 ENDDO DO N=1,NCON1 IDIFF=0 LMAX=MAX(NSTOP,LOCSH(N)) DO L=I0,LMAX IDIFF=IDIFF+IABS(LBASSH(L,N)-MN(L)) ENDDO IF(IDIFF.EQ.0)THEN WRITE(6,*)'SR.CONFG0 ERROR: IDIFF=0!!' WRITE(0,*)'SR.CONFG0 ERROR: IDIFF=0!!' GO TO 999 ENDIF IF(IDIFF.EQ.1)GO TO 124 !O.K. ENDDO GO TO 125 ENDIF C NEW 124 NCON=NCON+1 IF(NCON.GT.MAXCF)GO TO 300 DO L=I0,NSTOP JBASSH(L,NCON)=MN(L) IF(MN(L).GT.9)IFLG3=IFLG3+1 ENDDO DO L=NSTOP+1,MXORB JBASSH(L,NCON)=0 ENDDO C ENDIF C 125 IF(I.LT.MXORB)GO TO 110 IF(I.GT.MXORB)GO TO 140 C 130 IF(NI(I).LT.MXN(I,M))GO TO 120 I=I-1 IF(I.GT.I00)GO TO 130 C 140 ENDDO C C DETERMINE GLOBAL MAX AND MIN OCCUPATIONS C DO M=2,NOPTN DO L=I0,MXORB MNAL(L,1)=MIN(MNAL(L,1),MNAL(L,M)) MXAL(L,1)=MAX(MXAL(L,1),MXAL(L,M)) ENDDO ENDDO C C WRITE CONFIGS TO FILE C 200 IF(BPUNCH)THEN IF(IFLG3.EQ.0)THEN FORM=FORM2 ELSE FORM=FORM3 ENDIF IF(.NOT.BTWO)THEN WRITE(IPUNCH,*)I0-1,MXORB WRITE(IPUNCH,*)(QN(L),QL(L),L=I0,MXORB) ENDIF WRITE(IPUNCH,FORM)NCON WRITE(IPUNCH,FORM)(MNAL(L,1),L=I0,MXORB) WRITE(IPUNCH,FORM)(MXAL(L,1),L=I0,MXORB) DO N=1,NCON WRITE(IPUNCH,FORM)(JBASSH(L,N),L=I0,MXORB),IZERO ENDDO ENDIF C c IF(BTWO)STOP'NORMAL END' IF(BTWO)THEN M=MAXCF+1 DO N=NCON,1,-1 M=M-1 DO I=I0,MXORB JBASSH(I,M)=JBASSH(I,N) ENDDO c write(0,*)m,':',(nel(i,m),i=i0,mxorb) ENDDO DO N=1,NCON1 DO L=I0,MXORB JBASSH(L,N)=LBASSH(L,N) ENDDO ENDDO MXCCF=NCON NCON=NCON+NCON1 GO TO 300 ENDIF C BTWO=MXCCF.NE.0 IF(BTWO)THEN DO N=1,NCON DO I=I0,MXORB IF(JBASSH(I,N).GT.0)LOCSH(N)=I ENDDO DO L=I0,MXORB LBASSH(L,N)=JBASSH(L,N) ENDDO ENDDO NCON1=NCON ICFG=1 IF(ICFG0.LT.0)GO TO 1 IF(MXCCF.LT.0)THEN !FORM N+1 SET NOPTN=1 DO I=I0,MXORB IBASSH(I,1)=JBASSH(I,1) IF(MXAL(I,1).LT.4*QL(I)+2)MXAL(I,1)=MXAL(I,1)+1 ENDDO NXCITE(1)=NXCITE(1)+1 II=LOCSH(1) IF(IBASSH(II,1).LT.4*QL(II)+2)THEN IBASSH(II,1)=IBASSH(II,1)+1 ELSE II=II+1 IBASSH(II,1)=1 IF(MXORBR.LT.II)MXORBR=II ENDIF IF(BBUG)THEN M=1 WRITE(IWRITE,3080)NOPTN,MXORBR WRITE(IWRITE,3090)(MNAL(I,M),I=I0,MXORBR) WRITE(IWRITE,3100)(MXAL(I,M),I=I0,MXORBR) WRITE(IWRITE,3110)M,(IBASSH(I,M),I=I0,MXORBR) WRITE(IWRITE,3120)NXCITE(M) ENDIF GO TO 20 ELSE ICFG=ICFG0/10 NOPTN=MXCCF GO TO 1 ENDIF ENDIF C 300 MXCONF=NCON C c 500 STOP'NO SECOND FILE' IF(IUNIT(IPUNCH).GT.0)THEN CLOSE(IPUNCH) IUNIT(IPUNCH)=-1 ENDIF C RETURN C 999 NF=-1 GO TO 300 C 3000 FORMAT(/' NOTE: READING CONFIGURATIONS FROM FILE CONFIG.DAT:' X,' ANY CONFIGURATION DATA ON UNIT',I3,' WILL BE IGNORED.'/) 3010 FORMAT(' INCREASE MAXCF TO ',I5) 3020 FORMAT(' INCREASE MAXGR TO ',I3) 3040 FORMAT(/'NO. OF CONFIGS REDUCED FROM',I5,' TO',I5,'; ALL THAT' X ,' ARE PRESENT IN CONFIG.DAT FILE'/) 3080 FORMAT(/7X,'OPTION CHOSEN, NOPTN =',I3,' FOR ORBITALS MXORB =' A ,I3) 3090 FORMAT( A ' THE MINIMUM NUMBER OF ELECTRONS ALLOWED IN THIS SHELL IS' B ,2X,(20I3)) 3100 FORMAT( A ' THE MAXIMUM NUMBER OF ELECTRONS ALLOWED IN THIS SHELL IS' B ,2X,(20I3)) 3110 FORMAT(' BASIC CONFIGURATION',I4,35X,(20I3)) 3120 FORMAT(' THE MAXIMUM NUMBER OF ELECTRON EXCITATIONS REQUIRED=', A I3) 3270 FORMAT(' TOTAL NUMBER OF ELECTRONS =',I3) 3280 FORMAT(' ERROR, CONFIGURATION ',I3,' HAS ',I3,' ELECTRONS') 3290 FORMAT(' ERROR, TOO MANY ELECTRONS REQUIRED BY MNAL FOR' A ,' CONFIGURATION',I3) 3292 FORMAT(' ERROR, BASIC OCCUPATION NO GT MXAL FOR CONFIG ',I3) 3295 FORMAT(' ERROR, BASIC OCCUPATION NO LT MNAL FOR CONFIG ',I3) 3300 FORMAT(' WARNING, MXAL TOO LARGE FOR ORBITAL ',I3 A ,' IN CONFIGURATION ',I3) c 3352 FORMAT(60I2) c 3353 FORMAT(40I3) c 3354 FORMAT(I2,I3) c 3355 FORMAT(24(I3,I2)) END C C ******************* C SUBROUTINE CONFG1(QLP) C C----------------------------------------------------------------------- C C SR.CONFG1 DECODES THE KM INPUT CONFIGURATIONS FROM THE INPUT IN C IWRK1+IWRK2, PREVIOUSLY LOADED IN ALGEB0. C OPTIONALLY, SET-UP FOR RELAXED ORBITALS. C C----------------------------------------------------------------------- C USE COMMON_NRBRN2, ONLY: MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXRED=90) PARAMETER (MXLIT=60) PARAMETER (MXLIT0=30) C PARAMETER (MXD01=14) PARAMETER (MXD08=21*(MAXCF+5)) !S.S. NO. CF INPUT LINES*21 PARAMETER (MXD12=100) PARAMETER (MXD14=100) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C LOGICAL LG,LF,LT,BDR,BLOOP CF77 X ,BINDB !F77 C CHARACTER(LEN=1) LIT0,LIT CHARACTER(LEN=4) CODE C DIMENSION QLP(*) DIMENSION LIT(MXLIT),LIT0(MXLIT0) C COMMON /BASIC/NF,KY,KG,JA,JB,MGAP(7) COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,ND,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF), X QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /SSWRK/IWRK1(MXD08),IWRK2(MXD08) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBLOO/BLOOP,LNEW,LCON,LGAP(2) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBUNI/IUNIT(MXD14),NUNIT C NAMELIST/SRADWIN/KEY C DATA LIT0(1),LIT0(2),LIT0(3),LIT0(4),LIT0(5) /'0','1','2','3','4'/ X ,LIT0(6),LIT0(7),LIT0(8),LIT0(9),LIT0(10)/'5','6','7','8','9'/ X,LIT0(11),LIT0(12),LIT0(13),LIT0(14),LIT0(15)/'A','B','C','D','E'/ X,LIT0(16),LIT0(17),LIT0(18),LIT0(19),LIT0(20)/'F','G','H','I','J'/ X,LIT0(21),LIT0(22),LIT0(23),LIT0(24),LIT0(25)/'K','L','M','N','O'/ X,LIT0(26),LIT0(27),LIT0(28),LIT0(29),LIT0(30)/'P','Q','R','S','T'/ C DATA LIT( 1),LIT( 2),LIT( 3),LIT( 4) /'1','2','3','4'/, X LIT( 5),LIT( 6),LIT( 7),LIT( 8) /'5','6','7','8'/, X LIT( 9),LIT(10),LIT(11),LIT(12) /'9','A','B','C'/, X LIT(13),LIT(14),LIT(15),LIT(16) /'D','E','F','G'/, X LIT(17),LIT(18),LIT(19),LIT(20) /'H','I','J','K'/, X LIT(21),LIT(22),LIT(23),LIT(24) /'L','M','N','O'/, X LIT(25),LIT(26),LIT(27),LIT(28) /'P','Q','R','S'/, X LIT(29),LIT(30),LIT(31),LIT(32) /'T','U','V','W'/, X LIT(33),LIT(34),LIT(35),LIT(36) /'X','Y','Z','a'/, X LIT(37),LIT(38),LIT(39),LIT(40) /'b','c','d','e'/, X LIT(41),LIT(42),LIT(43),LIT(44) /'f','g','h','i'/, X LIT(45),LIT(46),LIT(47),LIT(48) /'j','k','l','m'/, X LIT(49),LIT(50),LIT(51),LIT(52) /'n','o','p','q'/, X LIT(53),LIT(54),LIT(55),LIT(56) /'r','s','t','u'/, X LIT(57),LIT(58),LIT(59),LIT(60) /'v','w','x','y'/ C LBLNK=ICHAR(' ') C C BDR=IDR.NE.0 IVAL=0 IC=(LCON-1)/2 IC=-IC-1 C IF(QQCUT.LE.0)THEN IF(QCUT.NE.LBLNK)THEN DO I=10,12 IF(QCUT.EQ.ICHAR(LIT(I)))QQCUT=I-8 ENDDO ELSE QQCUT=1 !DEFAULT AL 2FS ENDIF ENDIF C C IF(MAXGR.GT.MXLIT)GO TO 87 C WRITE(6,88) MAXGR, MXLIT C WRITE(0,*)'***MAXGR EXCEEDS MXLIT' C GO TO 99 C ENDIF C LF=MODD.EQ.-10 C C =.TRUE. DIVERTS CONTROL TO NEAREST GO TO ERROR EXIT (LABEL 9) C C DEFINE GROUP INDICES K=1,2,..MAXGR FOR NL= C 1S,2S,2P...; K MAY HAVE BEEN REDEFINED THROUGH INPUT, SEE LOOP 31 C II=INT(SQRT(DTWO*MAXGR))+1 K=0 DO I=1,II DO L=1,I K=K+1 IF(K.GT.MAXGR)GO TO 32 DEY(K)=DZERO QLP(K)=QL(K) CC IF(CODE.EQ.'S.S.'.OR.K.LE.IABS(JB))THEN IF(JB.GE.0)THEN QN(K)=I QLP(K)=L-1 ENDIF ENDIF CC QL(K)=QLP(K)*2 C ENDDO ENDDO C 32 JB=IABS(JB) c jb1=jb+1 do i=1,jb if(qn(i).eq.qn(jb1).and.ql(i).eq.ql(jb1))then write(0,*)'SR.ALGEB:CLOSED SHELLS OVERLAP VALENCE!' go to 99 endif enddo C IF(CODE.EQ.'S.S.')THEN LT=.FALSE. NT=MIN0(MXRED,MAXGR) MNT=NT M15=15 KGG=KG+18 55 IF(IWRK1(KGG).NE.LBLNK)THEN KGG=KGG+21 M15=M15+15 GO TO 55 ENDIF MNT=MIN0(MNT,M15) ELSE LT=.TRUE. MNT=MXORB ENDIF C LCO=-1 C DO K=1,MNT C IF(CODE.EQ.'S.S.')THEN I=KG+K+2 KX=(K-1)/15 I=I+6*KX IF(IWRK2(I).EQ.0)GO TO 31 QN(K)=IWRK2(I) DO M=1,30 IF(IWRK1(I).EQ.ICHAR(LIT0(M)))THEN L=M-1 GO TO 27 ENDIF ENDDO GO TO 24 ENDIF C 27 IF(.NOT.BDR)GO TO 61 IF(.NOT.BLOOP)GO TO 61 IF(QN(K).LT.80)GO TO 61 IF(QN(K).EQ.99)GO TO 61 IF(QN(K).LT.90)THEN !RYDBERG IVAL=IVAL+1 IF(IVAL.GT.1)WRITE(6,101) C L=LNEW IF(NMIN.LT.L+1)NMIN=L+1 GO TO 60 ENDIF C IF(L.NE.LCO)IC=IC+1 !CONTINUUM LCO=L L=LNEW+IC IF(L.LT.0)THEN IP=LCON/2 IP=IP+L IP=(-1)**IP IP=IP*(-1)**LNEW IM=1-(-1)**LCON IM=IM/2 IP=IP*IM L=L+LCON+IP ENDIF GO TO 60 C 61 IF(CODE.EQ.'A.S.')GO TO 31 !BOUND ALREADY DEFINED C 60 QL(K)=2*L QLP(K)=L LT=.TRUE. IF(QN(K).GT.L)GO TO 31 C 24 WRITE(6,93)K,QN(K),IWRK1(I) LF=.TRUE. C 31 ENDDO C C DECODE INPUT ARRAYS IWRK1 AND IWRK2 (ACCORDING TO GROUP DEFINITION) C OF KM CONFIGURATIONS, EACH CONFIGURATION KF DEFINED BY THE NUMBER C NEL(K,KF) OF EQUIVALENT ELECTRONS N,L=QN(K),QL(K)/2; C DECODE CLOSED SHELL CONFIGURATION C0 (OF NW ELECTRONS) COMMON TO C ALL KM CONFIGURATIONS (THIS FACILITY REDUCES STORAGE REQUIREMENTS) C C MXBORB=0 MXVORB=0 LG=.FALSE. C IF(CODE.EQ.'S.S.')THEN C KM=0 MXORB=0 DO I=1,KG IF(IWRK1(I).EQ.LBLNK)GO TO 36 M=IWRK2(I) C DO K=1,MAXGR IF(IWRK1(I).NE.ICHAR(LIT(K)))GO TO 39 DEY(K)=DONE MXORB=MAX0(K,MXORB) IF(QN(K).LT.80)MXBORB=MAX0(K,MXBORB) IF(QN(K).LT.90)MXVORB=MAX0(K,MXVORB) C IF(M.GT.50)THEN M=M-50 IF(KM.GT.0)GO TO 35 ENDIF C KM=KM+1 IF(KM.GT.MAXCF)THEN !TOO MANY CFS WRITE(6,92)MAXCF LF=.TRUE. KM=KM-1 ENDIF QCP(KM)=0 DO J=1,MAXGR NEL(J,KM)=0 ENDDO C 35 IF(K.LT.JA.OR.K.GT.JB)THEN L=NEL(K,KM)+M NEL(K,KM)=L QCP(KM)=QCP(KM)+M !QCP IS NOT PARITY HERE IF(L.GT.(QL(K)+1)*2)THEN WRITE(6,97)L,QN(K),QLP(K),KM LF=.TRUE. ENDIF ENDIF GO TO 36 C 39 ENDDO C J=(I-1)/21+1 L=(I-(J-1)*21)*3+9 WRITE(6,89)IWRK1(I),I,J,L,MAXGR LF=.TRUE. 36 ENDDO C C DUPLICATE CONFGS WILL BE DROPPED QUIETLY, OR FLAGGED, SEE IF(LG) BELOW C KM0=KM DO K0=2,KM0 K=K0-KM0+KM DO L=1,K-1 DO J=1,MAXGR IF(NEL(J,L).NE.NEL(J,K))GO TO 42 ENDDO LG=.TRUE. WRITE(6,*)'*** DUPLICATE CONFIGURATIONS',L,' AND',K DO I=K+1,KM !DROP, MAY STOP LATER DO J=1,MAXGR NEL(J,I-1)=NEL(J,I) ENDDO ENDDO IF(K.LE.KCUT)KCUT=KCUT-1 KM=KM-1 GO TO 43 42 ENDDO 43 ENDDO C IF(LF)GO TO 9 C ELSE !'A.S.' C DO K=1,KM !SET IN ALGEB QCP(K)=0 DO J=JB+1,MXORB IF(NEL(J,K).NE.0)THEN QCP(K)=QCP(K)+NEL(J,K) !QCP IS NOT PARITY HERE DEY(J)=DONE IF(QN(J).LT.80)MXBORB=MAX0(J,MXBORB) IF(QN(J).LT.90)MXVORB=MAX0(J,MXVORB) ENDIF ENDDO ENDDO C ENDIF C MXORB=MAX(MXORB,ISCALR) !FOR SLATER SCALING DUMMY ORB C C IF(MENGB.GE.0)THEN !I.E. BBORN K=MXORB-(JB-JA+1) IF(K.GT.MXGRB)THEN !TOO MANY ORBS FOR BORN WRITE(6,*)'***SR.ALGEB1: INCREASE MXGRB TO AT LEAST ',K WRITE(0,*)'***SR.ALGEB1: INCREASE MXGRB' GO TO 99 ENDIF ENDIF C DO K=1,MXORB !INITIALIZE MAP IEQ(K)=K ENDDO C C SET-UP COMMON CORE OF CONFIGS C NW=0 MB=JB IF(JB.GT.0)THEN IF(JA.EQ.0)JA=1 MA=JA DO J=JA,JB DEY(J)=DONE L=QL(J) C 82 I=NW+1 NW=I+1 IF(NW.GT.MAXCL)THEN !DIMENSION EXCEEDED, BAIL OUT WRITE(6,95) MAXCL GO TO 9 ENDIF DO K=I,NW NNL(K,1)=J NNL(K,2)=L NNL(K,3)=(NW-K)*2-1 ENDDO L=L-2 IF(L.GE.-QL(J) )GO TO 82 C DO I=1,MAXCF NEL(J,I)=-2*(QL(J)+1) ENDDO ENDDO C WRITE(6,40)NW,NF,KM,(QN(J),QLP(J),J=JA,JB) ELSE WRITE(6,100)NF,KM ENDIF C DO K=1,KM !CHECK CONFIG CONSISTENT IF(QCP(K).NE.NF)THEN WRITE(6,94)K,QCP(K) WRITE(0,*)'***SR.ALGEB1: INCONSISTENT INPUT FOR CONFIGURATION' X ,K LF=.TRUE. ENDIF ENDDO C C WRITE ORBITAL RE-DEFINITION INFO C IF(LT)THEN C KPP=MNT K1=1 K2=15 IF(KPP.GT.K2)KPP=K2 WRITE(6,50)(K,K=K1,K2),(QN(K),QLP(K),K=K1,KPP) C 52 K1=K1+15 IF(K1.LE.MNT)THEN K2=K2+15 KPP=MNT IF(KPP.GT.K2)KPP=K2 WRITE(6,51)(K,K=K1,K2),(QN(K),QLP(K),K=K1,KPP) GO TO 52 ENDIF C C CHECK ORBITALS, REMAP FOR NON-UNIQUE ORBITAL BASIS C DO K=1,MXORB IF(DEY(K).NE.DZERO)THEN DO I=1,K-1 IF(QN(K).EQ.QN(I).AND.QL(K).EQ.QL(I))THEN WRITE(6,91)I,K, QN(I),QLP(I) IF(IEQ(0).NE.0)IEQ(K)=IEQ(I) !REMAP EQUIVALENT ORBITALS COLD TEST LF=.TRUE. ENDIF ENDDO ENDIF ENDDO C C CHECK FOR CLEMENTI "EXTERNAL" ORBITALS AND FLAG, C THEN WE CANNOT EXTEND USAGE OF 60-69. C IF(IUNIT(12).EQ.0)THEN DO K=1,MXORB IF(QN(K).GE.70.AND.QN(K).LE.79)THEN !WE HAVE "EXTERNAL" KEY=0 READ(5,SRADWIN,END=53) 53 IF(KEY.EQ.-10)THEN !WE HAVE CLEMENTI IUNIT(12)=-1 !FLAG ENDIF REWIND(5) !REPOSITION FOR SMINIM GO TO 56 ENDIF ENDDO ENDIF C ENDIF C 56 IF(LF)GO TO 9 C C UN/COMMENT-OUT FOR QUIETLY DROPPING DUPLICATE CONFIGS C IF(LG)THEN WRITE(6,*)'***CHECK CONFIG INPUT, DUPLICATE CONFIGS EXIST' WRITE(0,*)'***CHECK CONFIG INPUT, DUPLICATE CONFIGS EXIST' GO TO 99 ENDIF C IF(LG)WRITE(0,*) 'NOTE: DUPLICATE CONFIGS EXIST...' C C CHECK COLLISION CASE FOR MISTAKEN USER SETTING OF RYDBERG/CONTINUUM C IF(IDW.NE.0)THEN DO I=1,MXORB IF(QN(I).GE.90)THEN WRITE(6,*)"***ALGEB1 ERROR: USER MUST NOT SET CONTINUUM", X " ORBITALS FOR RUN='DE','DI', LET THE CODE DO IT" WRITE(0,*)"***ALGEB1 ERROR: USER MUST NOT SET CONTINUUM", X " ORBITALS FOR RUN='DE','DI', LET THE CODE DO IT" GO TO 99 ENDIF IF(QN(I).GE.80)THEN WRITE(6,*)"***ALGEB1 ERROR: CANNOT USE RYDBERG", X " ORBITALS FOR RUN='DE','DI' - WHY WOULD YOU!" WRITE(0,*)"***ALGEB1 ERROR: CANNOT USE RYDBERG", X " ORBITALS FOR RUN='DE','DI' - WHY WOULD YOU!" GO TO 99 ENDIF ENDDO ENDIF C IF(IEQ(0).EQ.0)GO TO 109 !RETURN C C SET-UP DISTINCT ORBITAL BASIS FOR EACH CONFIG. C (IF SPECIFIED BACK IN SALGEB NAMELIST) BUT, USE C COMMON ORBITALS FOR CLOSED-SHELLS SPECIFIED VIA JA,JB, C IF REQUIRE DISTINCT THEN SPECIFY AS VALENCE. C IF(JA.GT.1)THEN !USER MUST RE-ORDER SO START WITH CLOSED WRITE(6,*) WRITE(6,*)'***SR.ALGEB1: MUST START CLOSED SHELL ORBITALS' X ,' AT KCOR1=1' WRITE(6,*)'***USE ORBITAL RE-DEFINITION LINE' WRITE(0,*)'***SR.ALGEB1: MUST START CLOSED SHELL ORBITALS' X ,' AT KCOR1=1' GO TO 99 ENDIF C MXFORB=MXORB-MXVORB MXVORB=MXVORB-MXBORB MXBORB=MXBORB-JB C IF(MXBORB.LE.0)THEN WRITE(6,*)'***SR.ALGEB1: RELAXED ORBITAL OPTION REQUIRES AT' X,' LEAST ONE NON-CLOSED-SHELL NON-VALENCE/CONTINUUM ORBITAL' WRITE(0,*)'***NEED AN OPEN-SHELL NON-VALENCE/CONTINUUM ORBITAL' GO TO 99 ENDIF C IEQ(0)=-MXBORB MXORB=KM*MXBORB+JB IF(MXFORB.GT.0)MXORB=MXORB+KM IF(MXVORB.GT.0)MXORB=MXORB+KM C IF(MXORB.GT.MAXGR)THEN WRITE(6,*) WRITE(6,*)'***SR.ALGEB1: INCREASE MAXGR TO',MXORB, X ' OR USE UNIQUE ORBITAL BASIS' WRITE(0,*)'***SR.ALGEB1: INCREASE MAXGR' GO TO 99 ELSE DO I=MXORB+1,MAXGR DEY(I)=DZERO ENDDO ENDIF C IF(MXVORB.GT.0.AND..NOT.BDR)THEN WRITE(6,*) WRITE(6,*)"***SR.ALGEB1: YOU HAVE SPECIFIED VALENCE ORBITALS" X," FOR DR BUT RUN=' ', SET RUN='DR' OR SWITCH-OFF VALENCE ORBS" WRITE(0,*)'***SR.ALGEB1: VALENCE ORBITALS SET FOR NON-DR RUN!' GO TO 99 ENDIF C C DUPLICATE ORBITAL LIST FOR EACH CF. PUT ALL CONT AFTER ALL BOUND C IF(MXFORB.GT.0)THEN K0=KM*MXBORB JBB=JB+MXBORB IF(MXVORB.GT.0)THEN K0=K0+KM JBB=JBB+MXVORB ENDIF DO K=1,KM !CONTINUUM II=K0+K+JB DEY(II)=DZERO IEQ(II)=II DO I0=1,MXFORB I=I0+JBB IT=NEL(I,K) IF(IT.GT.0)THEN NEL(I,K)=0 NEL(II,K)=IT QN(II)=QN(I) QL(II)=QL(I) QLP(II)=QLP(I) DEY(II)=DONE IGRCF(II)=K DO J=1,K-1 JJ=K0+J+JB IF(DEY(JJ).NE.DZERO)THEN IF(QN(II).EQ.QN(JJ).AND.QL(II).EQ.QL(JJ))THEN IEQ(II)=IEQ(JJ) GO TO 1 ENDIF ENDIF ENDDO GO TO 1 ENDIF ENDDO 1 ENDDO ENDIF C IF(MXVORB.GT.0)THEN K0=KM*MXBORB JBB=JB+MXBORB DO K=1,KM !VALENCE II=K0+K+JB DEY(II)=DZERO IEQ(II)=II DO I0=1,MXVORB I=I0+JBB IT=NEL(I,K) IF(IT.GT.0)THEN NEL(I,K)=0 NEL(II,K)=IT QN(II)=QN(I) QL(II)=QL(I) QLP(II)=QLP(I) DEY(II)=DONE IGRCF(II)=K DO J=1,K-1 JJ=K0+J+JB IF(DEY(JJ).NE.DZERO)THEN IF(QN(II).EQ.QN(JJ).AND.QL(II).EQ.QL(JJ))THEN IEQ(II)=IEQ(JJ) GO TO 2 ENDIF ENDIF ENDDO GO TO 2 ENDIF ENDDO 2 ENDDO ENDIF C DO K=1,KM !BOUND KK=MXBORB*(K-1) DO I0=1,MXBORB I=I0+JB II=I+KK IT=NEL(I,K) NEL(I,K)=0 NEL(II,K)=IT QN(II)=QN(I) QL(II)=QL(I) QLP(II)=QLP(I) IEQ(II)=IEQ(I) IGRCF(II)=K IF(NEL(II,K).EQ.0)THEN DEY(II)=DZERO ELSE DEY(II)=DONE ENDIF ENDDO ENDDO C C 109 RETURN C C FLAG ABORT C 9 NF=0 GO TO 109 C 99 NF=-1 GO TO 109 C C 40 FORMAT(///' ATOM WITH',I4,'+', I3,' ELECTRONS IN',I4 X,' CONFIGURATIONS',', CLOSED (N L)-SHELLS: ', 6(I5,I3) ) 50 FORMAT( //' ATTENTION: SOME OF THE INTERNAL ORBITALS MAY HAVE ',' XBEEN REDEFINED, AND MAY NOT BE THE STANDARD CODE (K=1,2,3... FOR X1S,2S,2P...)'/' K ',15I6/' N L ',15(I4,I2)) 51 FORMAT(//' K ',15I6/' N L ',15(I4,I2)) c 88 FORMAT(//' SR.ALGEB1: MAXGR=',I3,' EXCEEDS MXLIT=',I2, c X '; EXTEND ARRAY LIT(MXLIT) AND ADJUST DATA:MXLIT IN SR.ALGEB1') 89 FORMAT( " SR.ALGEB1: ORBITAL '",A1, "' IN POSITION",I4, " OF C-IN XPUT (CARD",I3," COLUMN",I3,") IS OUTSIDE RANGE, MAXGR=",I3) 91 FORMAT( ' SR.ALGEB1: WARNING ON REDEFINING GROUP INDICES K,',I3, X' AND',I3, ' BOTH REPRESENT ELECTRONS NL=',2I2) 92 FORMAT(' SR.ALGEB1: C-INPUT REQUIRES STORAGE FOR MORE THAN MAXCF=' X,I3,' CONFIGURATIONS') 93 FORMAT(" SR.ALGEB1: YOU'VE REDEFINED K=",I3," AS NL=",I2,1X,A1) 94 FORMAT(" SR.ALGEB1: CONFIGURATION INPUT INCONSISTENT-YOUR",I3, X"'TH CONFIGURATION CONTAINS",I3," VALENCE ELECTRONS") 95 FORMAT(' SR.ALGEB1: SPACE FOR ONLY MAXCL=',I2,' CORE ELECTRONS') 97 FORMAT(' SR.ALGEB1:',I3,' ELECTRONS NL=',2I2,' IN CF=',I2) 100 FORMAT(///' ATOM WITH',I4,' ELECTRONS IN',I4,' CONFIGURATIONS') 101 FORMAT(//' ***WARNING IN SR.ALGEB1, YOU HAVE SPECIFIED MORE THAN O XNE VALENCE ORBITAL FOR THE DR L-LOOP...') C END C C ********************* C SUBROUTINE CORTFD(X,POT,IEND,ADJUS2,ADJUS3,CRRCT1,CRRCT2) C C----------------------------------------------------------------------- C C SR.CORTFD COMPUTES DIPOLE AND QUADRUPOLE PERTURBATIONS TO THE STATIC C THOMAS-FERMI POTENTIAL - AS DESCRIBED BY: C M. A. BAUTISTA J.PHYS.B 41, 065701 (8pp) (2008). C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C c INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D15O16=15.0D0/16.0D0) C PARAMETER (TOLC=0.1D0) C DIMENSION POT(*),X(*) DIMENSION CORRCT(IEND) C C SQ2=SQRT(DTWO) PI=ACOS(-DONE) C PIP=DONE/(PI*SQ2) PIP2=PIP*PIP COEFFA=DFOUR*SQ2/(DTHREE*PI) COEFFB=COEFFA*(ADJUS3-DONE) COEFFA=COEFFA*(ADJUS2-DONE) C V0=PIP2-POT(IEND)-D15O16*PIP2 C DO J=1,IEND C XP=X(1) V2=V0+POT(1) R2=((PIP+SQRT(V2))*XP)**3 DELP1=R2*XP DELP3=DELP1*XP C DO I=2,J XM=XP XP=X(I) DX=XP-XM C V1=V2 V2=V0+POT(I) R1=R2 R2=((PIP+SQRT(V2))*XP)**3 DELP1=DELP1+(R1+R2)*DX DELP3=DELP3+(R1*XM+R2*XP)*DX c write(90,702)j,i,delp1,delp3 ENDDO C C XP=X(J) V2=V0+POT(J) R2=(PIP+SQRT(V2))**3 DELP2=DZERO DELP4=DZERO C DO K=J+1,IEND XM=XP XP=X(K) DX=XP-XM C V1=V2 V2=V0+POT(K) R1=R2 R2=(PIP+SQRT(V2))**3 DELP2=DELP2+(R1+R2)*DX DELP4=DELP4+(R1/XM+R2/XP)*DX c write(90,702)j,k,delp2,delp4 ENDDO C C XP=X(J) T=XP*XP DELPA=DELP1/T+DELP2*XP DELPB=DELP3/(T*XP)+DELP4*T CORRCT(J)=DELPA*COEFFA+DELPB*COEFFB C c write(90,*)x(i),pot(i),delpa,delpb,(delpa+delpb)/pot(i) c write(90,700)x(j),pot(j),delpa*COEFFA,delpb*COEFFB C ENDDO C T=CORRCT(IEND)/POT(IEND) IF(ABS(T).GT.TOLC)WRITE(6,710)T*100 CRRCT1=DELPA*COEFFA/POT(IEND) CRRCT2=DELPB*COEFFB/POT(IEND) C c write(92,*)'****** ',iend DO I=1,IEND-1 c write(92,700)x(i), pot(i),corrct(i) POT(I)=POT(I)+CORRCT(I) ENDDO c write(0,*)iend,x(iend),pot(iend),x(iend)*pot(iend) !i=1,iend then C RETURN C c 700 format(4(2x,1pe10.3)) c 702 format(2i5,4(2x,1pe10.3)) 710 FORMAT(//'***WARNING SR.CORTFD: PERTURBATION CORRECTION ' X ,'POTENTIAL EXCEEDS COULOMB AT X(IEND) BY',F5.1,'%'//) C END C C ******************* C SUBROUTINE DEIE(TIME,TTIME) C C----------------------------------------------------------------------- C C SR.DEIE IS THE CONTROLING ROUTINE FOR: C DIRECT ELECTRON-IMPACT EXCITATION COLLISION STRENGTH DETERMINATION. C C IT CALLS: C SR.ALGX: C SR.ALGXLS C SR.ALGXFS C SR.DWX C SR.DWXLS C SR.DWXJK C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C UNIX-F77 CF77 REAL*4 TARRY,TIME,TTIME !F77 CF77 DIMENSION TARRY(2) !F77 C COMMON /BASIC/NF,MGAP(11) C C----------------------------------------------------------------------- C C SR.ALGX CALCULATES COLLISION ALGEBRA C CALL ALGX C C----------------------------------------------------------------------- C C UNIX-F77 CF77 DUM=DTIME(TARRY) !F77 CF77 TIME=TARRY(1) !F77 CF77 TIME=TIME/60.0 !F77 CF77 TTIME=TTIME+TIME !F77 C C UNIX-F95 CALL CPU_TIME(TTIME) !F95 TTIME=TTIME/60.0D0 !F95 TIME=TTIME-TIME !F95 C WRITE(6,999) TIME, TTIME C TIME=TTIME !F95 C C----------------------------------------------------------------------- C C SR.DWX CALCULATES COLLISION STRENGTHS C if(nf.gt.0)CALL DWX C C----------------------------------------------------------------------- C C UNIX-F77 CF77 DUM=DTIME(TARRY) !F77 CF77 TIME=TARRY(1) !F77 CF77 TIME=TIME/60.0 !F77 CF77 TTIME=TTIME+TIME !F77 C C UNIX-F95 CALL CPU_TIME(TTIME) !F95 TTIME=TTIME/60.0D0 !F95 TIME=TTIME-TIME !F95 C WRITE(6,999) TIME, TTIME C TIME=TTIME !F95 C RETURN C 999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN',5X,'TOTAL CPU TIME=',F9.3 X,' MIN') C END C C ******************* C SUBROUTINE DIAG(NN,IUP,Z,D,E,IRMX,IORD,MXMAT) C C----------------------------------------------------------------------- C C BADNELL & BURGESS D.A.M.T.P. CAMBRIDGE C C SR.DIAG DIAGONALIZES A REAL SYMMETRIC N-BY-N MATRIX Z. C C METHOD: HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM AND IMPLICIT C SHIFTED QL ALGORITHM TO DETERMINE THE E-VALUES AND E-VECTORS. C C BASED ON MARTIN, REINSCH & WILKINSON: NUM. MATH. 11, 181-95(1968). C C INPUT REQUIRED: NN, IUP AND Z, WHERE N=ABS(NN). C ONLY LOWER TRIANGLE OF Z NEED BE SUPPLIED. C (ON OUTPUT, THE MATRIX Z IS OVERWRITTEN BY EIGENVECTORS OF Z.) C IUP=1/-1 ASC/DESCENDING E-VALUE SORT. C =0 RE-ORDERS ACCORDING TO DOMINANT E-VECTOR COMPONENT. C MXMAT, IS THE ROW DIMENSION OF Z IN THE CALLING ROUTINE. C IF NN.LT.0 THEN JUST RE-ORDER E-VECTORS INPUT FROM LAPACK. C C OUTPUT. Z AND D, WHERE Z CONSISTS OF COLUMN EIGENVECTORS C AND D CONSISTS OF CORRESPONDING EIGENVALUES. C C NOTE: E IS A WORKING ARRAY, OF LENGTH N. C IRMX, IORD ARE WORKING ARRAYS OF LENGTH N, ONLY USED WHEN IUP=0. C C----------------------------------------------------------------------- C IMPLICIT REAL*8(A-H,O-Z) C PARAMETER(TOL=1.0D-40) PARAMETER(EPS=1.0D-12) PARAMETER(ZERO=0.0D0) PARAMETER(ONE=1.0D0) PARAMETER(JMAX=30) C DIMENSION D(*),E(*),Z(MXMAT,*),IRMX(*),IORD(*) c DATA IFLAGE/0/ C C IF(NN.EQ.0)GO TO 999 C N=IABS(NN) IF(NN.LT.0)GO TO 100 DO I=1,N D(I)=Z(N,I) ENDDO IF(N.EQ.1)GO TO 20 C C HOUSEHOLDER REDUCTION TO TRI-DIAGONAL FORM C DO I=N,2,-1 C L=I-1 F=D(I-1) G=ZERO DO K=1,I-2 G=G+D(K)*D(K) ENDDO H=G+F*F IF(G.LE.TOL)THEN E(I)=F H=ZERO DO J=1,L D(J)=Z(L,J) Z(I,J)=ZERO Z(J,I)=ZERO ENDDO GO TO 18 ENDIF C G=SQRT(H) IF(F.GE.ZERO)G=-G E(I)=G H=H-F*G D(L)=F-G DO J=1,L E(J)=ZERO ENDDO DO J=1,L Z(J,I)=D(J) G=E(J)+Z(J,J)*D(J) DO K=J+1,L G=G+Z(K,J)*D(K) E(K)=E(K)+Z(K,J)*D(J) ENDDO E(J)=G ENDDO C F=ZERO DO J=1,L E(J)=E(J)/H F=F+E(J)*D(J) ENDDO HH=F/(H+H) DO J=1,L E(J)=E(J)-HH*D(J) ENDDO DO J=1,L F=D(J) G=E(J) DO K=J,L Z(K,J)=Z(K,J)-F*E(K)-G*D(K) ENDDO D(J)=Z(L,J) Z(I,J)=ZERO ENDDO C 18 D(I)=H C ENDDO C C C ACCUMULATE TRANSFORMATION MATRICES C DO I=2,N L=I-1 Z(N,L)=Z(L,L) Z(L,L)=ONE H=D(I) IF(H.NE.ZERO)THEN DO K=1,L D(K)=Z(K,I)/H ENDDO DO J=1,L G=ZERO DO K=1,L G=G+Z(K,I)*Z(K,J) ENDDO DO K=1,L Z(K,J)=Z(K,J)-G*D(K) ENDDO ENDDO ENDIF DO J=1,L Z(J,I)=ZERO ENDDO ENDDO DO I=1,N D(I)=Z(N,I) Z(N,I)=ZERO ENDDO C 20 E(1)=ZERO Z(N,N)=ONE C C C IMPLICIT SHIFTED QL ALGORITHM TO DETERMINE E-VALUES & E-VECTORS C DO I=2,N E(I-1)=E(I) ENDDO E(N)=ZERO B=ZERO F=ZERO C DO L=1,N C J=0 C H=EPS*(ABS(D(L))+ABS(E(L))) IF(B.LT.H)B=H DO M=L,N IF(ABS(E(M)).LE.B)GO TO 37 ENDDO 37 IF(M.EQ.L)GO TO 53 38 IF(J.EQ.JMAX)THEN WRITE(6,1000) GO TO 999 ENDIF C J=J+1 C P=E(L)+E(L) G=D(L) H=D(L+1)-G IF(ABS(H).LT.ABS(E(L)))THEN P=H/P R=SQRT(P*P+ONE) H=P+R IF(P.LT.ZERO)H=P-R D(L)=E(L)/H ELSE P=P/H R=SQRT(P*P+ONE) D(L)=E(L)*P/(R+ONE) ENDIF C H=G-D(L) DO I=L+1,N D(I)=D(I)-H ENDDO F=F+H P=D(M) C=ONE S=ZERO DO I=M-1,L,-1 G=C*E(I) H=C*P IF(ABS(P).GE.ABS(E(I)))THEN C=E(I)/P R=SQRT(C*C+ONE) E(I+1)=S*P*R S=C/R C=ONE/R ELSE C=P/E(I) R=SQRT(C*C+ONE) E(I+1)=S*E(I)*R S=ONE/R C=C/R ENDIF P=C*D(I)-S*G D(I+1)=H+S*(C*G+S*D(I)) DO K=1,N H=Z(K,I+1) Z(K,I+1)=S*Z(K,I)+C*H Z(K,I)=C*Z(K,I)-S*H ENDDO ENDDO C E(L)=S*P D(L)=C*P IF(ABS(E(L)).GT.B)GO TO 38 53 D(L)=D(L)+F C ENDDO C C PUT BACK IN ORIGINAL ORDER C 100 IF(IUP.EQ.0)THEN c c rewind(99) !debug info if assignment fails c write(99)n c write(99)(d(i),i=1,n) c write(99)((z(j,i),j=1,n),i=1,n) c IFOUND=0 C DO I=1,N !FIND(ROW)MAX CMPNT OF EACH E-VECTOR C CALL HPSRTI(N,Z(1,I),IORD) !FIND ORDER OF COMPONENTS C J=IORD(1) IRMX(I)=J ZAM=Z(J,I) IF(Z(J,I).LT.ZERO)THEN !MAKE LARGEST CPT >0 ZAM=-ZAM DO J=1,N Z(J,I)=-Z(J,I) ENDDO ENDIF E(I)=ZAM ISAME=0 C DO K=2,N J=IORD(K) ZABS=ABS(Z(J,I)) IF(ZABS.EQ.ZAM)THEN !MAKE NON-EQUAL ISAME=ISAME+1 ZABS=ZABS-ISAME*EPS*ZABS Z(J,I)=SIGN(ZABS,Z(J,I)) c if(j.gt.0)then c stop 'degenerate case' c endif ELSE IF(ZABS.EQ.ZERO)GO TO 55 !WE ARE DONE FOR THIS I ZAM=ZABS ISAME=0 ENDIF ENDDO C 55 CONTINUE C ENDDO C DO I=1,N IORD(I)=0 ENDDO C 56 P=ZERO DO I=1,N !FIND LARGEST MAX CMPNT IF(E(I).GT.P)THEN P=E(I) K=I ENDIF ENDDO IF(IORD(IRMX(K)).EQ.0)THEN !ASSIGN IF NOT ALREADY DONE SO IFOUND=IFOUND+1 IORD(IRMX(K))=K E(K)=ZERO IF(IFOUND.EQ.N)GO TO 57 !WE ARE DONE ELSE !ELSE LOOK FOR NEXT LARGEST CMPNT P=-ONE IRMX(K)=0 DO J=1,N ZABS=ABS(Z(J,K)) IF(ZABS.GT.P.AND.ZABS.Lt.E(K))THEN !ALL CPTS NON-EQUAL NOW IRMX(K)=J P=ZABS ENDIF ENDDO IF(IRMX(K).EQ.0)THEN !JUST FILL-IN DO J=1,N IF(IORD(J).EQ.0)THEN IFOUND=IFOUND+1 IRMX(K)=J IORD(J)=-K P=ZERO ENDIF ENDDO c c write(6,*)'k=',k,zabs,e(k),n,ifound,isame c do j=1,n c write(6,1001)iord(irmx(j)),irmx(j),(z(j,k),k=1,n) c enddo c 1001 format(2i5,1p,10e10.2/(10x,10e10.2)) c IF(IFLAGE.EQ.0)THEN WRITE(6,1002) c c alternatively, force the issue (for "safety"). c go to 999 !bailout and use jacord ENDIF IFLAGE=IFLAGE+1 IF(IFOUND.EQ.N)GO TO 57 !WE ARE DONE ENDIF E(K)=P !TRY AGAIN ENDIF GO TO 56 !GO FOR NEXT ONE C 57 CONTINUE C C THE NEW ORDER HAS BEEN DETERMINED SWAP E-VECTORS AND E-VALUES TO MATCH C DO I=1,N IORD(I)=IABS(IORD(I)) IRMX(I)=I !CURRENT POSITION OF ORIG E-VECTOR I E(I)=I !WHAT'S CURRENTLY IN POSITION I ENDDO DO I=1,N K=IRMX(IORD(I)) IF(K.NE.I)THEN IRMX(IORD(I))=I L=NINT(E(I)) IRMX(L)=K E(K)=L E(I)=IORD(I) P=D(K) D(K)=D(I) D(I)=P DO J=1,N P=Z(J,I) Z(J,I)=Z(J,K) Z(J,K)=P ENDDO ENDIF ENDDO C ELSE C C BEGIN SORTING INTO ASC/DESCENDING E-VALUES C DO I=1,N K=I P=D(I) DO J=I+1,N IF(IUP.GT.0.AND.D(J).GT.P)GO TO 58 IF(IUP.LT.0.AND.D(J).LT.P)GO TO 58 K=J P=D(J) 58 ENDDO IF(K.NE.I)THEN D(K)=D(I) D(I)=P DO J=1,N P=Z(J,I) Z(J,I)=Z(J,K) Z(J,K)=P ENDDO ENDIF ENDDO C ENDIF C RETURN C C 999 NN=0 RETURN C 1000 FORMAT(' FAILED IN DIAG, TOO MANY ITERATIONS') 1002 FORMAT('*** UNABLE TO ASSIGN ALL E-VECTORS BY COMPONENT'/ X ' YOU MIGHT WANT TO RUN-CHECK BY SETTING ', X 'IDIAG=1 IN SMINIM... (NO MORE WARNINGS)') C END C C ******************* C SUBROUTINE DIAGFS(DECORE,DFFS,TFWE) C C----------------------------------------------------------------------- C C N.R. BADNELL D.A.M.T.P. CAMBRIDGE C C SR.DIAGFS CALCULATES LEVEL ENERGIES INCLUDING RELATIVISTIC C CORRECTIONS, AND PERMITTED AND FORBIDDEN RADIATIVE DATA. C ALSO CALCULATES INTERMEDIATE COUPLING AUTOIONIZATION RATES C AND PHOTOIONIZATION CROSS SECTIONS C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_COEFF, ONLY: DRKP,QRLP,IRLP,NRKP,NADP !F95 USE COMMON_DMQSS3, ONLY: DSS,MSS,NADR !F95 USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_NRBEKP, ONLY: NED !F95 USE COMMON_NRBMKP, ONLY: NMD1,NMD2 !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 USE COMMON_NRBRN2, ONLY: BINDB,MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXLIT=62) PARAMETER (MXSTRG=32) !MAX STRING WRITE PARAMETER (MSTRGH=16) !SHORT STRING WRITE PARAMETER (MXLABL=19) !0:MXLABL C CF77 PARAMETER (MXD1=MAXDI/MAXDK, !F77 CF77 X MXD2=MAXDK/MAXDI, !F77 CF77 X MXD3=MXD1+MXD2, !F77 CF77 X MXD4=MAXDI*MXD1/MXD3+MAXDK*MXD2/MXD3+1, !F77 CF77 X MXBUF=MXD4*MXD4) !F77 C CF77 PARAMETER (MXXDQ=2*MXST0+MXEST) !F77 CF77 PARAMETER (MXD0=MXD4*MXD4, !F77 CF77 X MXD9=MXXDQ/MXD0, !F77 CF77 X MXD10=MXD0/MXXDQ, !F77 CF77 X MXD11=MXD9+MXD10, !F77 CF77 X MXQBUF=MXXDQ*MXD9/MXD11+MXD0*MXD10/MXD11+1) !F77 C CF77 PARAMETER (ISXDK=MAXDK) !F77 CF77 PARAMETER (IAXDK=MAXDK) !F77 CF77 PARAMETER (IAXJU=MAXJU) !F77 CF77 PARAMETER (IXAAK=MXAAK) !F77 C PARAMETER (MXD01=14) PARAMETER (MXD09=MXBLM+2) !+2 CASE BREL PARAMETER (MXD12=100) PARAMETER (MXD14=100) PARAMETER (MXD24=2*MAXGR) PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) CF77 PARAMETER (MXD30=MAXDK*MAXDK) !MAX FOR !F77 PARAMETER (MXD33=(MXGRB*(MXGRB+1))/2) PARAMETER (MXD34=((MXD33+1)*MXD33)/2) CF77 PARAMETER (MXD35=MXENG*(MXAAK/2)) !F77 CF77 PARAMETER (MXD36=1+MXAAK/2) !F77 PARAMETER (MXD37=MXBLM/2) PARAMETER (MXD39=MXGRB/MAXGR) !=0 (FINITE E) OR 1 (INF. E ONLY) CF77 PARAMETER (MXD40=(MAXDK*(MAXDK+1))/2) !F77 CF77 PARAMETER (MXD41=1) !=MXD35 FOR .NOT.BSCO !F77 C !BORN MOM. TRANSFER (K) INFO PARAMETER (NLAGB=4) !PT LAG, EVEN, CORRELATE WITH NPDEC PARAMETER (NPDEC=4) !NO. OF K-STEPS PER DECADE PARAMETER (IVV0=3) !STARTING AT 10**-IVV0 PARAMETER (NDEC=IVV0+2) !NO. OF DECADES (ALLOW K-SHELL) C PARAMETER (MXNXV=NDEC*NPDEC+3) !NO. OF K_MAX (INC ZERO & INF) PARAMETER (MXD21=IVV0*NPDEC-NPDEC/4+3) !NO. OF K_MIN: UP TO 1.0 PARAMETER (MXD38=(1-MXD39)*((MXNXV*(MXNXV-1))/2 X -((MXNXV-MXD21)*(MXNXV-1-MXD21))/2)+MXD39) C PARAMETER (MXNXB=10) !NO. OF BPW X-VALUES (THRESH. UNITS) PARAMETER (MXNXB1=MXNXB+1) C CF77 PARAMETER (NOMWRX=MXD35) !F77 CF77 PARAMETER (NOMWRY=MXD41) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (DTEN=1.0D1) PARAMETER (D2P1=2.0D1) PARAMETER (D1P8=1.0D8) PARAMETER (D1P20=1.0D20) PARAMETER (D1P30=1.0D30) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M4=1.0D-4) PARAMETER (D1M5=1.0D-5) PARAMETER (D1M7=1.0D-7) PARAMETER (D1M9=1.0D-9) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M20=1.0D-20) PARAMETER (D1M30=1.0D-30) PARAMETER (D1M99=1.0D-99) PARAMETER (DKON=1.653656D17) PARAMETER (DKCM=109737.31D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (HBAR=4.8377687D-17) PARAMETER (C1=DFSC**3/HBAR) PARAMETER (C2=2.567895D-18) !4*pi*a_0**2*alpha PARAMETER (C3=C2/DTHREE) PARAMETER (C4=DFSC**2/DFOUR) PARAMETER (MZERO=0) PARAMETER (EINF=1.0D6) PARAMETER (DEPS=1.0D-15) C PARAMETER (MW=8) !INITIALIZE UNIT NOS PARAMETER (MWW=MW+10) PARAMETER (MWU=MW+20) PARAMETER (MWWU=MWU+2) C REAL*4 OMEGA c integer*8 n8 CF77 integer*8 nrk,nrkp,mss !F77 C CHARACTER(LEN=1) BIGL,NUMB,STRING,DATE,CLIT,CMBLK1 COLD X,SMAL CHAR X,LIT,MBLK1 !USE OF CHAR REQUIRES CHANGES TO PP'S FOR UNFORM I/O CHARACTER(LEN=2) CELMNT,ELEM,LABW CHARACTER(LEN=3) IEXP CHARACTER(LEN=4) MB,MCOR,MBLK,CODE,MYRGE,LAB4,CARD4,MBP CHARACTER(LEN=5) XMANT CHARACTER(LEN=8) DATE8 !F95 CHARACTER(LEN=8) MOBS character(len=9) orbfmt CHARACTER(LEN=10) MTEC,NTEC character(len=31) ceiss,cstan CHARACTER(LEN=17) F762 CHARACTER(LEN=29) F761 character(len=51) f542,f543 CHARACTER(LEN=200) CARD C LOGICAL BPRINT,BAUX,BINT,LMOD,CPRINT,BLAG,BPRNT0,BBC1,BBC2,BECOR X ,BRESAT,BMULT,BJSEL,BSTO,BMODE,BJUMP,BJUMP2,BRAD,BDR,BFOT X ,BDEL,BFOTJ,BTEC,BREL,BJUMPR,BMVD,BREL2,BM1BP,BFANO,BKUTOO X ,BBORN,BEKVEL,BRADAT,BM1NBP,BMPRNT,BING,BFAST,BEQGRP,BPOS X ,BCONT,BPRNTO,BEXP,BSCRO,brtard,b2fs,btime,btimex,badas X ,BALLH,BALLA,BTFU,BOMRC !F95 CF77 X ,BFALL,BINDB !F77 C X,BPRNT5,bcorr C CF77 DIMENSION DU(MAXDK,MAXDK),DE(MAXDK),IDY(MAXDK) !F77 CF77 X ,DVU(MAXDK),NVEC(MAXDK),DVI(MXENG,MAXDK),DVP(MXD40) !F77 CF77 X ,DUI(MXENG,MXAAK),NPOS(4,MXD30),OMR(MXD35),OMC(MXD35)!F77 CF77 X ,OMEGA(0:MXNXB1,MXD41),TFU(MAXJU),DVECF(MXENG,MAXLV) !F77 C ALLOCATABLE :: DU(:,:),NPOS(:,:),DUI(:,:),DVI(:,:) !F95 X ,DVP(:),OMR(:),OMC(:),OMEGA(:,:),TFU(:) !F95 X ,DE(:),IDY(:),DVU(:),NVEC(:) !F95 X ,DVECF(:,:) !F95 C DIMENSION TFWE(*) C DIMENSION X LMX(MAXCF),QSB(10,MAXCF),QLB(10,MAXCF) X ,IHARRY(MAXCF),E1BCF(MAXCF) X ,ITMP(MXD24) X ,DENERG(MAXLV),IWRK2(MAXLV),ID(0:MAXLV),NADRU(MAXLV) X ,DVECL(MAXLV),DVECV(MAXLV),DVECA(MAXLV),NAJ(MAXLV) X ,DDY(MXENG) X ,ETM(MAXTM),WGT(MAXTM) X ,DT(MAXTR),MMIKE(MAXTR),NMIKE(MAXTR) X ,NGRPJ(MAXJG),DFS(MXDFS) cn x ,nrb(maxtm,maxjg) ! *** to be removed *** DIMENSION BIGL(0:MXLABL),NUMB(0:MXLABL) X ,STRING(MXSTRG),DATE(8),CLIT(MXLIT),LIT(MXLIT) COLD X ,SMAL(0:MXLABL) C COMMON /BASIC/NF,MGAP(11) COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /EX/DRLP1(MXSOI),DNL(MAXMI) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCL0,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /MQVC/MODPH,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /NXRL/IRK,IRK0,IOS,IOS0 COMMON /NXRNL/NL000,NL COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR),D2LL(MAXGR,MAXGR) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /TRANS/DRL(MAXRL),DOSC(0:MXD09,MAXGR,MAXGR) X ,NADWE(MAXTM),NAI(MAXTM),NCO,IORIG(MAXTM) COMMON /WEIGHT/WGHT(MAXTM),INDEXW(MAXTM) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA0,MB0,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTSS,NTJ(MAXCF),NFJ(MAXLV) X ,KUTSO COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM CF77 COMMON /NRBALQ/QBUFF(MXQBUF) !F77 CF77 COMMON /NRBBUF/DBUF1(MXBUF),DBUF2(MXBUF) !F77 COMMON /NRBCAS/AP(MXNOR),MADD(MXNOR) COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ESKPL,ESKPH,BECOR COMMON /NRBDEL/TOLB,TOLE,DELELS(MAXTM,2),DELEIC(MAXLV,2),MDELE X ,MULTS,ISHFTLS,ISHFTIC,NOBS COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) CF77 COMMON /NRBEKP/NED(2,MAXSL,MAXTM) !F77 COMMON /NRBFAN/BFANO COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBFSI/DNLI(MXENG,MXFSS),NLI(MAXMI) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR),NRLI(MAXRL) X ,MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBMIX/CMXLSA,CMXLSR,CMXICA,CMXICR CF77 COMMON /NRBMKP/NMD1(2,MAXJG,MAXLV),NMD2(2,MAXJG,MAXLV) !F77 COMMON /NRBNFI/DZLI(MXENG,MXFOO),DXTWOI(MXENG,MXFOO) X ,DETAI(MXENG,MXFOO),FRI(MAXB1),GRI(MAXB1) COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBORN/BL(MXD38,MXD34,0:MXD37),OBO(MXD38),TM2(MXD34) C COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED COMMON /NRBRN1/SBL(MXD33),DBL(MXD33,MXBIF),DG(0:MXBLM) X ,MB3(0:MXD33),MB4(0:MXD33),INDX(MXD28) X ,INDK(MXD34),INDL(MXD34) c x,iflagb(mxd34) CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBRN3/V0(MXNXV),V1(MXNXV),XB(MXNXB),XS(0:MXNXB1) X ,DB0(MXNXV),DB1(MXNXV),OMEGAB(0:MXNXB1) X ,MV0,MV1,XMANT(0:MXNXB1),IEXP(0:MXNXB1),MINFB COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBTCC/KTCC,MTCC,NTCC,NNRGLS COMMON /NRBTRN/NENERG,JORIG(MAXLV) COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD COMMON /NRBWGT/EIMXLS,EIMXIC,WLG1,WLG2,IWGHT,IOPTIM,NRSLMX X ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN COMMON /WORKJ/DWRK(MAXLV),IWRK3(MAXLV) !,IWKR4(MAXDK) common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) common /hps/badas CF77 EQUIVALENCE (DUI(1,1),OMR(1)),(DUI(1,MXD36),OMC(1)) !F77 CF77 X,(DU(1,1),DBUF1(1)),(DVP(1),DBUF2(1)) !F77 CF77 X,(NPOS(1,1),DBUF1(1)) !F77 COLD X,(DP(1),DT(1),ETM(1)), (DPA(1),WGT(1),NMIKE(1),DFS(1)) C EQUIVALENCE (DATE(1),DATE8) !F95 C DATA CMBLK1/' '/,MBLK/' '/,MCOR/' COR'/ C DATA CLIT( 1),CLIT( 2),CLIT( 3),CLIT( 4) /'1','2','3','4'/, X CLIT( 5),CLIT( 6),CLIT( 7),CLIT( 8) /'5','6','7','8'/, X CLIT( 9),CLIT(10),CLIT(11),CLIT(12) /'9','A','B','C'/, X CLIT(13),CLIT(14),CLIT(15),CLIT(16) /'D','E','F','G'/, X CLIT(17),CLIT(18),CLIT(19),CLIT(20) /'H','I','J','K'/, X CLIT(21),CLIT(22),CLIT(23),CLIT(24) /'L','M','N','O'/, X CLIT(25),CLIT(26),CLIT(27),CLIT(28) /'P','Q','R','S'/, X CLIT(29),CLIT(30),CLIT(31),CLIT(32) /'T','U','V','W'/, X CLIT(33),CLIT(34),CLIT(35),CLIT(36) /'X','Y','Z','a'/, X CLIT(37),CLIT(38),CLIT(39),CLIT(40) /'b','c','d','e'/, X CLIT(41),CLIT(42),CLIT(43),CLIT(44) /'f','g','h','i'/, X CLIT(45),CLIT(46),CLIT(47),CLIT(48) /'j','k','l','m'/, X CLIT(49),CLIT(50),CLIT(51),CLIT(52) /'n','o','p','q'/, X CLIT(53),CLIT(54),CLIT(55),CLIT(56) /'r','s','t','u'/, X CLIT(57),CLIT(58),CLIT(59),CLIT(60) /'v','w','x','y'/, X CLIT(61),CLIT(62) /'z','*'/ COLD DATA (SMAL(I),I=0,MXLABL)/'s','p','d','f','g','h','i','k','l' COLD X ,'m','n','o','p','q','r','s','t','u','v','*'/ DATA (BIGL(I),I=0,MXLABL)/'S','P','D','F','G','H','I','K','L','M' X ,'N','O','P','Q','R','S','T','U','V','*'/ DATA (NUMB(I),I=0,MXLABL)/'0','1','2','3','4','5','6','7','8','9' X ,'A','B','C','D','E','F','G','H','I','*'/ C IROW(ILI,ILF,IONE,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE))/2 ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C C C FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS C TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY C OPEN(80,STATUS='SCRATCH',FORM='FORMATTED') WRITE(80,1111)CMBLK1,(CLIT(I),I=1,MXLIT) 1111 FORMAT(80A1) BACKSPACE(80) READ(80,1111)MBLK1,(LIT(I),I=1,MXLIT) CLOSE(80) c if(btime)then timeh=dzero timea=dzero c timea1=dzero c timea2=dzero endif C BCONT=MODE.EQ.2.OR.MODE.EQ.3 !FOR BOUND-CONTINUUM IF(BCONT.AND.ISHFTLS.GT.0)THEN write(6,*)'**** SR.DIAGFS: TECs CURRENTLY NOT INDEXED', X 'FOR USE IN PRESENCE OF CONTINUUM' WRITE(0,*)'*** TECs NOT INDEXED FOR CONTINUUM USAGE...' NF=-1 btfu=.false. !F95 GO TO 750 ENDIF C C INITIALIZE LOGICALS ETC C b2fs=nl000.gt.0 !2-fs exists brtard=irtard.ne.0 !only for brel=.true. BREL2=IABS(IREL).EQ.2 BDR=IDR.NE.0 BBORN=MENGB.GE.0 BFOTJ=.NOT.BLAG.OR..NOT.BFOT LMOD=MODPH.EQ.0.OR.MODPH.EQ.-1 BKUTOO=KUTOO.NE.0 BMODE=MODE.LT.1.OR.IABS(MORT).GT.20 M=NPRNT0 NPRINT=MOD(M,5) BPRNT0=BPRINT IF(BPRINT)BPRNT0=JPRINT.NE.-3 !.AND.JPRINT.NE.3 C BPRNT5=BPRNT0.AND..NOT.BREL !NPRNT0.GT.-5 BRESAT=MODE.GT.1 !.OR.BREL !NPRNT0.LE.-5 C nmetj0=nmetaj NL0=NL !HOLD C MBP='+BP2' IF(MBP2MX.LT.0)MBP='+BP1' C !F95 C DETERMINE DIMENSIONS REQUIRED TO ALLOCATE !F95 C (SEE ALGEB3 SET-UP, NOTE IAXJU IS REDUCED IF NO RAD OR DW) !F95 C !F95 ISXDK=1 !F95 IAXDK=1 !F95 IXAAK=0 !F95 IAXJU=0 !F95 NCI=0 !F95 NCTOT=0 !F95 C !F95 IF(IDW.EQ.0.AND.NPRINT.EQ.-2)THEN !F95 IFLAG=-1 !F95 ELSE !F95 IFLAG=1 !F95 ENDIF !F95 C !F95 DO NN=1,NJO !F95 C !F95 NCJ=NT(NN) !F95 IAXDK=MAX(IAXDK,NCJ) !F95 C !F95 N0=0 !F95 NCC=0 !F95 NCI0=0 !F95 C !F95 do i=1,mxorb !F95 ncc0(i)=0 !F95 enddo !F95 mx0=mxorb+1 !F95 lu=0 !F95 C !F95 DO NGJ=1,NGSLJ(NN) !F95 IS=NSLJ(NGJ,NN) !F95 NP=NSL(IS) !F95 C !F95 nc0=ncc !F95 N00=0 !F95 DO NJ=1,NP !F95 J=NJ+NCI0 !F95 I=NRR(J+NCI) !F95 K=IABS(NFK(I)) !F95 II=QCG(NF,K) !F95 ii=ieq(ii) !F95 IF(IYY(II).GT.0)then !F95 NCC=NCC+1 !F95 ncc0(ii)=ncc0(ii)+1 !F95 mx0=min(mx0,ii) !F95 else !F95 N00=N00+1 !F95 endif !F95 ENDDO !F95 N0=N0+N00 !F95 lu=lu+n00*(ncc-nc0) !if no 2-fs !F95 NCI0=NCI0+NP !F95 ENDDO !F95 C !F95 if(mode.eq.2)then !F95 isxdk=max(isxdk,n0) !F95 iorb(mx0-1)=n0*n0 !F95 do i=mx0,mxorb !F95 n=ncc0(i) !F95 iorb(i)=iorb(i-1)+n*n !F95 isxdk=max(isxdk,n) !F95 enddo !F95 c !F95 c if(btime.and.n0*ncc.gt.0)then !F95 c write(0,*)'njo=',nn,' nb=',n0,' ncc=',(ncc0(i),i=mx0,mxorb) !F95 c t=n0*ncc !F95 c write(0,*)'bmix*c/cmix*b=',t/(iorb(mxorb)-n0*n0) !F95 c write(0,*)'bmix*c=',n0*n0*ncc !F95 c x ,'cmix*b=',n0*(iorb(mxorb)-n0*n0) !F95 c endif !F95 c !F95 if(bfot)then !need c-c e-vectors !F95 nctot=nctot+iorb(mxorb) !F95 else !only need b-b !F95 iaxju=max(iaxju,nctot+iorb(mxorb)) !but need c-c buffer!F95 nctot=nctot+n0*n0 !so can overwite c-c!F95 endif !F95 c write(0,*)nn,nctot !F95 else !need full block !F95 if(mode.eq.4)then !bound only !F95 ncc=0 !F95 lu=0 !F95 endif !F95 isxdk=iaxdk !F95 NCTOT=NCTOT+NCJ*NCJ !F95 endif !F95 C !F95 if(b2fs)LU=NCC*(NCJ-NCC) !WE HAVE 2-FS, NEED ND.NE.NC !F95 IXAAK=MAX(IXAAK,LU) !F95 C !F95 NCI=NCI+NCJ !F95 ENDDO !F95 c write(0,*)ixaak,iaxju !F95 c write(0,*)isxdk,iaxdk !F95 C !F95 IF(IFLAG.LT.0)THEN !F95 if(mode.ne.2)IAXJU=IAXDK*IAXDK !F95 ELSE !F95 if(mode.ne.2.or.bfot)IAXJU=NCTOT !F95 ENDIF !F95 c write(0,*)nctot,iaxju !F95 C !F95 BALLH=.FALSE. !F95 BTFU=.FALSE. !F95 BALLA=.FALSE. !F95 C !F95 ALLOCATE(DU(ISXDK,ISXDK) !F95 X ,DVU(IAXDK),DE(IAXDK),IDY(IAXDK),NVEC(IAXDK) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR DU,DVU,DE,IDY,NVEC' !F95 NF=0 !F95 GO TO 750 !F95 ENDIF !F95 BALLH=.TRUE. !F95 IF(BPRNT0)THEN !F95 IM=(IAXDK*(IAXDK+1))/2 !F95 ALLOCATE(DVP(IM),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR DVP' !F95 NF=0 !F95 GO TO 7600 !F95 ENDIF !F95 ENDIF !F95 C !F95 ALLOCATE(TFU(IAXJU),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR TFU' !F95 NF=0 !F95 GO TO 7600 !F95 ENDIF !F95 BTFU=.TRUE. !F95 IAXJU=IFLAG*IAXJU !F95 C !F95 IF(MENG*IXAAK.GT.0)THEN !F95 ALLOCATE(DUI(MENG,IXAAK),DVI(MENG,IAXDK),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR DUI,DVI' !F95 NF=0 !F95 GO TO 7600 !F95 ENDIF !F95 BALLA=.TRUE. !F95 ENDIF !F95 C C SET-UP TECS BASED-ON CONFIGURATION AVERAGE CORRECTIONS C IF(ISHFTLS.EQ.1.AND.ICAV.NE.0)THEN NCI=0 DO K=1,NSL0 NC=NSL(K) DO ND1=1,NC ND=ND1+NCI KF=NFK(ND) DELELS(ND,1)=ECAVX(KF)-ECAV(KF) ENDDO NCI=NCI+NC ENDDO ENDIF C C TEC/LEC SET-UP C MOBS=' ' MTEC=' ' NTEC=' ' LABW=' ' IF(ISHFTLS.GT.1)THEN !SET NUMBER OF TEC ITERATIONS ITEC=ISHFTLS MTEC=' OBS-CALC' ELSE ITEC=0 IF(IOPTIM.LT.0)THEN MTEC='DIFFERENCE' MOBS='OBSERVED' ENDIF ENDIF C IF(ISHFTIC.GT.1)THEN !SET NUMBER OF LEC ITERATIONS JTEC=ISHFTIC NTEC=' OBS-CALC' ELSE JTEC=0 IF(IOPTIM.GT.0)THEN NTEC='DIFFERENCE' MOBS='OBSERVED' LABW='WT' ENDIF ENDIF C C RESET INCLUD C INCLUD=MOD(INCL0,1000000) C C SET CHARGES ETC. C NZA=NZION-MION+1 DZA2=NZA*NZA DZ2=NZION-MION IF(NZION.EQ.MION)DZ2=DONE DZ2=DZ2*DZ2 TSHFT=MSHFT+MSHFT C C INITIALIZE FOR NLAG-POINT LAGRANGE INTERPOLATION FORMULA FOR C BOUND-CONTINUUM INTEGRALS. C NLAG MUST BE AN EVEN NUMBER .GE. 4 . READ IN SRADCON. C DEFAULT: NLAG=6. C IF MENG.EQ.1 THEN NO INTERPOLATION (& NLAG NOT IUSED) C NLAG2=NLAG-2 NP1=1 NP2=MAX(1,NLAG) NPH=NP2/2 BBC1=MENG.LE.NP2 IF(BBC1)NP2=MENG DDY(1)=DONE !FOR .NOT.BLAG C C DETAIL ONE-BODY MAGNETIC INTEGRALS C IF(BJUMP2)THEN !JUST RE-SCALE IF(BPRNT0)WRITE(6,180) DO L=1,IRLP DD=DONE c K=(QRLP(2,L)-1)/MAXGR DO I=1,2 N=QRLP(I,L) c IF(K.NE.0)N=N-K*MAXGR DD=DD*FACT(N) ENDDO DRLP1(L)=DRLP1(L)*DD IF(BPRNT0)WRITE(6,181)L,QRLP(1,L),QRLP(2,L),DRLP1(L) ENDDO ENDIF C IF(BPRNT0)WRITE(6,900)JPRINT C DO K=1,MXORB IF(DEY(K).EQ.DZERO)GO TO 612 K17=K IF(BJUMP2.AND..NOT.BMVD)THEN !JUST RE-SCALE DO J=1,K IF(DEY(J).NE.DZERO)THEN DD=FACT(J)*FACT(K) DMASS(K,J)=DMASS(K,J)*DD DCD(K,J)=DCD(K,J)*DD D2LL(K,J)=D2LL(K,J)*DD IF(KUTOO.EQ.98)DXSI(K,J)=DXSI(K,J)*DD ENDIF ENDDO ENDIF DD1=DMASS(K,K) DD2=DCD(K,K) DD=DD1+DD2 L=QL(K)/2 IF(BPRNT0)WRITE(6,899)K,QN(K),L,DEY(K),DD1,DD2,DD,D2LL(K,K) 612 ENDDO C IF(BPRNT0)THEN C WRITE(6,200) DO L=1,IRL IF(QRL(5,L).EQ.-1)THEN L1=QRL(1,L) L2=QRL(3,L) WRITE(6,201)L,L1,L2,DMASS(L1,L2),DCD(L1,L2),D2LL(L1,L2) ENDIF ENDDO C C DETAILED PRINTOUT OF ONE-BODY RELATIVISTIC CORRECTIONS C IF(NL.LT.-1)THEN !SUPPRESS DO L=1,3 IF(L.EQ.1)THEN WRITE(6,891) ELSEIF(L.EQ.2)THEN WRITE(6,892) ELSEIF(L.EQ.3)THEN WRITE(6,893) ENDIF C DO K=1,K17 I=K IF(DEY(K).EQ.DZERO)I=10000 IF(L.EQ.1)THEN WRITE(6,895)I,(DMASS(K,J),J=1,K) ELSEIF(L.EQ.2)THEN WRITE(6,895)I,(DCD(K,J),J=1,K) ELSEIF(L.EQ.3)THEN WRITE(6,895)I,(D2LL(K,J),J=1,K) ENDIF ENDDO ENDDO ENDIF C ENDIF C C DETAILED PRINTOUT OF ANY QED CONTRIBUTIONS C IF(QED.NE.0)THEN IF(BPRNT0)WRITE(6,3005) DO K=1,MXORB IF(DEY(K).NE.DZERO)THEN IF(QN(K).LT.0)GO TO 614 !WE ARE DONE IF(BJUMP2.AND.QED.GT.0)THEN !JUST RE-SCALE DD=FACT(K)*FACT(K) VPINT(K)=DD*VPINT(K) SLFINT(K)=DD*SLFINT(K) ENDIF DD=VPINT(K)+SLFINT(K) IF(BPRNT0)WRITE(6,3010)K,QN(K),QL(K)/2,VPINT(K),SLFINT(K),DD ENDIF ENDDO ENDIF C 614 CONTINUE C----------------------------------------------------- C *** CALCULATE TWO-BODY FINE-STRUCTURE INTEGRALS C----------------------------------------------------- C if(btime)call cpu_time(timei) c C HAMILTONIAN C IF(NL000.GT.0)THEN C CALL FSINT(BPRNT0) C IF(NF.LT.0)GO TO 2000 ENDIF C C M1+BP INTEGRALS C IF(NL.GT.NL000)THEN C CALL RADBP2(BPRNT0) C IF(NF.LT.0)GO TO 2000 ENDIF C if(btime)then call cpu_time(timef) times=timef-timei if(nint(times).ne.0)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for diagfs:' !par cpar write(iwp,*)' integral time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'integral time=',nint(times),'sec' cpar endif !par endif endif C ML=2*MAXLAM IF(MAXLAM.NE.1000.AND.BPRNT0)WRITE(6,301)ML C C C*********************************************************************** C C CONSTRUCT AND DIAGONALIZE ENERGY (SUB-)MATRICES. C C*********************************************************************** C C C CALCULATE ENERGY CONTRIBUTION DECORE OF THE NW CORE ELECTRONS C DSC=DZERO ! 1-BODY DD2=DZERO ! 2-BODY C C 1-BODY C DD8=DZERO !REL CONTRIB DO L=1,NW KX=NNL(L,1) DSC=DSC+DEY(KX) DD8=DD8+DCD(KX,KX)+DMASS(KX,KX) IF(QED.NE.0)DD8=DD8+VPINT(KX)+SLFINT(KX) IF(KUTOO.EQ.98)DD8=DD8+DXSI(KX,KX) ENDDO DSC=DSC+DD8 !NON-REL + REL C C 2-BODY C DD=DD8 !HOLD 1-BODY REL DD8=DZERO !REL CONTRIB DO I=1,NAD(0) M=INT(NRK(I)) DD2=DD2+DRL(M)*DRK(I) IF(BKUTOO)THEN IF(BFALL(I))THEN DD8=DD8-DRK(I)*DZL(M) ELSE DD8=DD8+DRK(I)*DZL(M) ENDIF DD8=DD8+DRK(I)*DXTWO(M)+DEK(I)*DETA(M) C - JONES ENDIF ENDDO DD2=DD2+DD8 !NON-REL + REL DD8=DD8+DD !REL 1+2 BODY C DECORE=DSC+DD2 ! 1-BODY + 2-BODY C IF(BPRNT0)THEN WRITE(6,400)DD2,DSC IF(BCONT)THEN WRITE(6,504) IF(ISHFTLS.NE.0.OR.ISHFTIC.NE.0)WRITE(6,509) ENDIF ENDIF C C CALCULATE 1-BODY CF ENERGY CONTRIBUTION OF THE NF VALENCE ELECTRONS C DD=DZERO M2=0 DO M1=1,KMAX E1BCF(M1)=DZERO DO L=1,NF IF(QCG(L,M1).NE.M2)THEN M2=QCG(L,M1) DD=DEY(M2) DD=DD+DCD(M2,M2)+DMASS(M2,M2) IF(QED.LT.0.AND.QN(M2).GT.0.and.qed.ne.99) X DD=DD+VPINT(M2)+SLFINT(M2) ENDIF E1BCF(M1)=E1BCF(M1)+DD ENDDO IF(ICAV.NE.0.AND.ISHFTLS.NE.1) X E1BCF(M1)=E1BCF(M1)+ECAVX(M1)-ECAV(M1) !CA CORRECTN ENDDO C C COLLAPSE BACK RELAXED ORBITAL LIST C IF(IEQ(0).LT.0)THEN MXBORB=-IEQ(0) KF=MB0+MXBORB DO K=1,KF K2=2*K ITMP(K2-1)=QN(K) ITMP(K2)=QL(K)/2 IORB(K)=K2 ENDDO KP=2*KF KF=MB0+MXBORB*KMAX IF(BDR)THEN DO K=1,KMAX KF=KF+1 IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN !FIRST OCC. KP=KP+1 ITMP(KP)=QN(KF) KP=KP+1 ITMP(KP)=QL(KF)/2 IORB(KF)=KP ENDIF ENDDO ENDIF DO K=1,KMAX KF=KF+1 IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN !FIRST OCC. KP=KP+1 ITMP(KP)=QN(KF) KP=KP+1 ITMP(KP)=QL(KF)/2 IORB(KF)=KP ENDIF ENDDO ENDIF C IF(.NOT.BMODE)THEN EIONMN=DZERO IF(IEQ(0).EQ.0)THEN KF=MIN0(MXLIT,MXORB) IF(BPRNT0)WRITE(MW,507)KMAX,NZION,MION,(IABS(QN(K)),QL(K)/2 X ,K=1,KF) IF(.NOT.BPRNT0)WRITE(MWU)KMAX,NZION,MION,(IABS(QN(K)),QL(K)/2 X ,K=1,KF) ELSE KF=MIN0(KP,MXLIT) IF(BPRNT0)WRITE(MW,507)KMAX,NZION,MION,(IABS(ITMP(K)) X ,ITMP(K+1),K=1,KF,2) IF(.NOT.BPRNT0)WRITE(MWU)KMAX,NZION,MION,(IABS(ITMP(K)) X ,ITMP(K+1),K=1,KF,2) ENDIF ENDIF C DO K=1,KMAX LM=0 C DO J=1,MXORB IF(NEL(J,K).GT.0)THEN LM=LM+1 QSB(LM,K)=NEL(J,K) IF(LM.GT.1)QSB(LM,K)=QSB(LM,K)+50 IF(IEQ(0).LT.0)THEN JM=MIN(IORB(IEQ(J))/2,MXLIT) ELSE JM=MIN(J,MXLIT) ENDIF QLB(LM,K)=LIT(JM) CHAR QLB(LM,K)=ICHAR(CLIT(JM)) NCC0(LM)=J ENDIF ENDDO LMX(K)=LM C IF(LM.LT.10)THEN LP=LM+1 DO J=LP,10 QSB(J,K)=0 QLB(J,K)=MBLK1 CHAR QLB(J,K)=ICHAR(CMBLK1) ENDDO ENDIF M2=QCG(NF,K) KW=K MST=MSTAT(K) IF(IYY(M2).GE.0)THEN M1=QL(M2)+1 KW=-K MST=MSTAT(K)/(M1+M1) ENDIF IF(.NOT.BMODE)THEN IF(BPRNT0)WRITE(MW,517)KW,MST,MA0,MB0,(QSB(L,K) X ,QLB(L,K),L=1,LM) CHAR X ,CHAR(QLB(L,K)),L=1,LM) IF(.NOT.BPRNT0)WRITE(MWU)KW,MST,MA0,MB0,(QSB(L,K),QLB(L,K) X ,L=1,10) ENDIF DO L=1,LM QLB(L,K)=NCC0(L) ENDDO ENDDO C IF(.NOT.BMODE)THEN IF(BPRNT0)WRITE(MW,505)NZION,MION IF(.NOT.BPRNT0)WRITE(MWU)NZION,MION ENDIF C CPRINT=(MOD(MPNCH,2).NE.0) !PRINT TCC'S IF(CPRINT)THEN IF(NTCC.NE.MTCC)WRITE(6,755)MTCC,NTCC-MTCC !FLAG MIXED SPEC/CORR IF(KTCC.GT.0)MTCC=NNRGLS !FOR TCCDW ENDIF C C C********************************************************************* C THE FOLLOWING DO 528 RUNS THROUGH ALL THE NJO GROUPS, WHILST DO C 522 RUNS THROUGH ALL THE NCJ LEVELS OF THE K'TH GROUP (J,P). C********************************************************************* C NCUT=KCUT IF(KCUT.LE.0)NCUT=10000 BMULT=MULTS .GT. 0 MULTSM=MULTS-1 BAUX=.FALSE. c TOLA=CMXICA*D1M4 !MAX B-F MATRIX ELEMENT IF(NNEW.GT.1)THEN T=DBLE(NNEW)/DTWO TOLA=TOLA/(T*SQRT(T)) ENDIF tola1=tola tola2=tola1/100 C C 5000 BTEC=ITEC.GT.1.OR.JTEC.GT.1 !SKIP L/TEC ITERATIONS C NCI=0 NGROUP=0 !LS GROUP COUNTER MC=0 NTRAN=0 ID(0)=0 MJX=0 K2=0 N2=0 LUMAX=0 NCTOT=0 BINT=IAXJU.GT.0 !F95 DMIN=DKCM JTMIN=0 NSKP=0 C DO 528 KGROUP=1,NJO !BEGIN JP LOOP C NCJ=NT(KGROUP) MM=NCJ*NCJ MJX=MAX0(MJX,MM+NTRAN) C CF77 IF(MM.GT.IAXJU)GO TO 190 !F77 CF77 IF(NCJ.GT.MAXDK)GO TO 190 !F77 CF77 BINT=MM+NCTOT.LE.IAXJU !F77 IF(.NOT.BINT)NCTOT=0 C NGRPJ(KGROUP)=NCI C IF(BCONT)THEN !SET-UP B-C INDEXING c n0=0 do i=1,mxorb ncc0(i)=0 enddo mx0=mxorb+1 C DO I=1,NCJ II=I+NCI IT=NRR(II) M1=NFK(IT) M1=IABS(M1) M2=QCG(NF,M1) M2=IEQ(M2) IDY(I)=M2 IF(IYY(M2).LT.0)then IDY(I)=-IDY(I) n0=n0+1 NAJ(II)=n0 !REL POSITION OF ABS LEVEL IN GROUP else ncc0(m2)=ncc0(m2)+1 NAJ(II)=ncc0(m2) !REL POSITION OF ABS LEVEL IN GROUP mx0=min(mx0,m2) endif ENDDO C LU=0 ip=0 ipp=0 DO L=1,NCJ IF(IDY(L).GT.0)THEN if(.not.b2fs)then j=l+nci it=nrr(j) ip=nfq(it) endif DO M=1,L IF(IDY(M).LT.0)THEN if(.not.b2fs)then k=m+nci itp=nrr(k) ipp=nfq(itp) endif IF(ip.eq.ipp)LU=LU+1 ENDIF ENDDO nvec(l)=lu DO M=L+1,NCJ IF(IDY(M).LT.0)THEN if(.not.b2fs)then k=m+nci itp=nrr(k) ipp=nfq(itp) endif IF(ip.eq.ipp)LU=LU+1 ENDIF ENDDO ENDIF ENDDO C IF(LU.GT.LUMAX)LUMAX=LU IF(LU.GT.IXAAK)THEN WRITE(6,896)LU WRITE(0,*)'***INCREASE MXAAK' GO TO 2000 ENDIF LUX=LU C ENDIF C !INDEX E-VECTORS if(mode.eq.2)then c iorb(mx0-1)=n0*n0 do i=mx0,mxorb nn=ncc0(i) iorb(i)=iorb(i-1)+nn*nn enddo c DO I=1,NCJ II=I+NCI IF(IDY(I).GT.0)THEN m2=idy(i) nadru(ii)=nctot+iorb(m2-1)+ncc0(m2)*(naj(ii)-1) else nadru(ii)=nctot+n0*(naj(ii)-1) ENDIF ENDDO c if(bfot)then !need c-c e-vectors nctot=nctot+iorb(mxorb) else !only b-b nctot=nctot+n0*n0 !so can overwrite c-c endif C ELSE C DO I=1,NCJ II=I+NCI NAJ(II)=I IT=NRR(II) cn nrb(it,kgroup)=ii M1=NFK(IT) M1=IABS(M1) M2=QCG(NF,M1) M2=IEQ(M2) IDY(I)=M2 IF(IYY(M2).LT.0)IDY(I)=-IDY(I) NADRU(II)=NCTOT !END POSITION OF E-VECTOR II-1 NCTOT=NCTOT+NCJ ENDDO C ENDIF C C FORM H-MATRIX FOR THIS SYMMETRY C ICB=0 ICC=0 C NCI0=0 DO 5220 NGJ1=1,NGSLJ(KGROUP) !BEGIN SL LOOP IS=NSLJ(NGJ1,KGROUP) NP=NSL(IS) C IB=NADG(IS) !FOR H(LS) POS IF(ISHFTLS.GT.0)THEN !TEC ONLY IAB=ngrpi(is) IA=0 DO L=1,IS-1 IN=NSL(L) IA=IN*IN+IA ENDDO INN=NSL(IS) ENDIF C NCIP0=0 DO 5240 NGJP1=1,NGJ1 !BEGIN SL LOOP ISP=NSLJ(NGJP1,KGROUP) NPP=NSL(ISP) C DO 522 NJ11=1,NP !BEGIN SLJ LOOP C I=NJ11+NCI0 II=I+NCI NN=NADRU(II) C IF(IS.EQ.ISP)THEN C NPP=NJ11 C IT=NRR(II) M1=NFK(IT) M1=IABS(M1) C DE(I)=E1BCF(M1) IF(ISHFTIC.GE.1)DE(I)=DE(I)+DELEIC(II,1) !PRE-DIAG SHIFT C M2=QCG(NF,M1) IF(IYY(M2).LT.0)THEN ICB=ICB+1 ELSE DE(I)=DE(I)+ECOR2 M2=IEQ(M2) DO M=1,ICC IF(M2.EQ.IORB(M))GO TO 317 ENDDO ICC=ICC+1 IORB(ICC)=M2 ENDIF ENDIF C 317 CONTINUE C DO 524 NJP11=1,NPP !BEGIN SLJ LOOP C DD=DZERO J=NJP11+NCIP0 JJ=J+NCI ITP=NRR(JJ) c if(bcont)then if(idy(i).gt.0.and.idy(j).gt.0.and.idy(i).ne.idy(j))go to 520 if(.not.b2fs.and.idy(i)*idy(j).lt.0)then !b-c but no 2-fs if(is.ne.isp)go to 520 !no ls k1=k2+1 n1=n2+1 if(mode.eq.3)nj=naj(jj) go to 500 endif nj=naj(jj) else nj=j endif C K1=K2+1 N1=N2+1 NGROUP=NGROUP+1 IF(NL000.GT.0)K2=NADR(NGROUP) N2=NADP(NGROUP) C C 1-BODY FS C DO L=N1,N2 KX=INT(NRKP(L)) DD=DRLP1(KX)*DRKP(L)+DD ENDDO C C 2-BODY FS C DO L=K1,K2 KX=INT(MSS(L)) DD=DNL(KX)*DSS(L)+DD ENDDO C C BOUND-CONTINUUM C 500 LU=0 IF(BCONT.AND.(NL000.GT.0.OR.IS.EQ.ISP))THEN !2-FS OR LS EXIST C C INDEX & INITIALIZE C IF(IDY(I)*IDY(J).LE.0)THEN C if(idy(i).gt.0)then lui=nvec(i) do l=i,j+1,-1 if(idy(l).lt.0)lui=lui-1 enddo lu=lui else luj=nvec(j) do l=j+1,i if(idy(l).lt.0)luj=luj+1 enddo lu=luj endif c DO M=1,MENG DUI(M,LU)=DZERO ENDDO C C 2-BODY FS INTERPOLATABLE C DO L=K1,K2 KX=INT(MSS(L)) KK=NLI(KX) IF(KK.GT.0)THEN DO M=1,MENG DUI(M,LU)=DUI(M,LU)+DNLI(M,KK)*DSS(L) ENDDO ENDIF ENDDO C ENDIF C ENDIF C C ADD-IN LS TERM CONTRIBUTIONS C IF(IS.NE.ISP)then if(mode.eq.3)lu=0 GO TO 519 !LS SYMMS DIFFERENT, SO SKIP AS ZERO endif C C FIND INDEX IN TERM ARRAY (ALSO FOR TEC'S IF REQUIRED) C IF(BCONT)THEN C if(idy(i).lt.0)then ib=ib+1 else if(idy(j).lt.0.or.idy(i).eq.idy(j))IB=IB+1 endif C ELSE C IB=IB+1 C C APPLY TERM ENERGY CORRECTION DELELS TO TERMS WITH INDICES T C IN THE TERM TABLES (NOT ENERGY ORDER) C IF(ISHFTLS.GT.0)THEN L1=IT-IAB L2=ITP-IAB DO L=1,INN IF(ABS(TFWE(IA+L1)).GT.D1M4)THEN IF(ABS(TFWE(IA+L2)).GT.D1M4)THEN DD=DELELS(L+IAB,1)*TFWE(IA+L1)*TFWE(IA+L2)+DD ENDIF ENDIF L1=INN+L1 L2=INN+L2 ENDDO ENDIF C ENDIF C C WE NOW HAVE INDEX (IB) C M1=NAD(IB-1)+1 M2=NAD(IB) C DO L=M1,M2 KX=INT(NRK(L)) C C 2-BODY NON-REL (SLATER) C DD=DD+DRL(KX)*DRK(L) C C 1-BODY NFS C IF(QRL(5,KX).LT.0)THEN !DZL(KX)=DXTWO(KX)=DETA(KX)=0 HERE L1=QRL(1,KX) !FALLING ORDER L1.GE.L2 L2=QRL(3,KX) DS=DCD(L1,L2)+DMASS(L1,L2) IF(KUTOO.EQ.98)DS=DS+DXSI(L1,L2) DS=DS*DRK(L) DD=DD+DS ENDIF C C 2-BODY NFS C IF(BKUTOO)THEN DS=DZL(KX)*DRK(L) IF(BFALL(L))DS=-DS DS=DS+DXTWO(KX)*DRK(L)+DEK(L)*DETA(KX) !- JONES DD=DD+DS ENDIF ENDDO C C BOUND-CONTINUUM (SLATER & NFS) C IF(LU.NE.0)THEN !SO BCONT DO L=M1,M2 KX=INT(NRK(L)) KK=NRLI(KX) IF(KK.GT.0)THEN C SLATER DO M=1,MENG DUI(M,LU)=DUI(M,LU)+DRLI(M,KK)*DRK(L) ENDDO C NFS IF(BKUTOO)THEN DO M=1,MENG DS=DZLI(M,KK)*DRK(L) IF(BFALL(L))DS=-DS DS=DS+DXTWOI(M,KK)*DRK(L)+DETAI(M,KK)*DEK(L) !- J DUI(M,LU)=DUI(M,LU)+DS ENDDO ENDIF C ENDIF ENDDO if(mode.eq.3)lu=0 ENDIF C C STORE H-MATRIX C 519 IF(LU.EQ.0)TFU(NJ+NN)=DD !STORE H FOR DIAG C 520 CONTINUE C IF(BPRNT0)THEN IP=ICOL(J,I,0) DVP(IP)=DD !STORE H FOR PRINTING ENDIF C 524 CONTINUE !END SLJ LOOP C IF(IS.EQ.ISP)TFU(NJ+NN)=TFU(NJ+NN)+DE(I) !ADD DIAG E EHERE C 522 CONTINUE !END SLJ LOOP C NCIP0=NCIP0+NPP 5240 ENDDO !END SL LOOP C NCI0=NCI0+NP 5220 ENDDO !END SL LOOP C C LL=NCI !FOR AUTOIONIZATION AS NCI GETS UPDATED C C***************************************************************** C C DIAGONALIZE HAMILTONIAN C C***************************************************************** C if(btime)call cpu_time(timei) c INFO=0 C !DU IS LOWER, TFU UPPER (SIGH) IF(MODE.NE.2.OR.ICC.LE.0)THEN C NN=NADRU(LL+1) DO I=1,NCJ DO J=1,I DU(I,J)=TFU(NN+J) !NAJ(J+LL)=J HERE (ALL B-B) ENDDO CD DU(I,I)=DU(I,I)+DE(I) NN=NN+NCJ ENDDO C !BOTH UPPER HERE IF(IDIAG.GT.0)THEN NN=NADRU(LL+1) DO I=1,NCJ DO J=1,I-1 DU(J,I)=TFU(NN+J) ENDDO NN=NN+NCJ ENDDO ENDIF C CALL HDIAG(NCJ,DU,ISXDK,DVU,DVECV,NF,INFO) C IF(NCJ*NF.LE.0.OR.INFO.GT.0)GO TO 2000 C IF(MODE.GE.4)THEN icc=0 DO I=1,NCJ DO L=1,NCJ IF(IDY(L)*IDY(I).LE.0)DU(L,I)=DZERO ENDDO ENDDO ENDIF C NN=NADRU(LL+1) DO J=1,NCJ DO I=1,NCJ TFU(NN+I)=DU(I,J) !NAJ(I+LL)=I HERE (ALL B-B) ENDDO NN=NN+NCJ ENDDO C ELSE C C DIAGONALIZE SEPARATELY THE ICC C-C BLOCKS PLUS THE B-B BLOCK C IF(BTEC)GO TO 428 C IF(ICB.GT.0)THEN M0=0 IORB(0)=-1000 ELSE M0=1 ENDIF C DO M=M0,ICC C NSUB=0 DO M7=1,NCJ IF(IORB(M).LT.0.AND.IDY(M7).LT.0)GO TO 676 IF(IORB(M).NE.IDY(M7))GO TO 675 676 NSUB=NSUB+1 NVEC(NSUB)=M7 675 ENDDO C HOLD NSUB0=NSUB IDIAG0=IDIAG C 700 CONTINUE C M1=NVEC(1)+LL NN=NADRU(M1) DO IS=1,NSUB DO JS=1,IS !LOWER DU(IS,JS)=TFU(NN+JS) c if(abs(du(js,is)).lt.d1m10)du(js,is)=dzero ENDDO CD MI=NVEC(IS) CD DU(IS,IS)=DU(IS,IS)+DE(MI) NN=NN+NSUB ENDDO C IF(IDIAG.GT.0)THEN DO IS=1,NSUB DO JS=IS+1,NSUB DU(IS,JS)=DU(JS,IS) ENDDO ENDDO ENDIF C CALL HDIAG(NSUB,DU,ISXDK,DVECL,DVECV,NF,INFO) C IF(NF.LE.0)GO TO 2000 C CL IF(INFO.GT.0)THEN !LAPACK FAILURE, SO TRY DIAG !LAPACK CL WRITE(6,*) !LAPACK CL X ' RE-RUNNING THIS MATRIX ONLY WITH SR.DIAG'!LAPACK CL GO TO 700 !LAPACK CL ENDIF !LAPACK C IF(NSUB.EQ.0)THEN !DIAG FAILURE, SO RELOAD AND USE JACORD WRITE(6,*)' RE-RUNNING THIS MATRIX ONLY WITH SR.JACORD' NSUB=NSUB0 IDIAG=1 GO TO 700 ENDIF C IDIAG=IDIAG0 C C STORE E-VECTORS AND E-ENERGIES IN TFU C M1=NVEC(1)+LL NN=NADRU(M1) DO IS=1,NSUB MI=NVEC(IS) DVU(MI)=DVECL(IS) DO JS=1,NSUB TFU(NN+JS)=DU(JS,IS) ENDDO NN=NN+NSUB ENDDO C ENDDO C ENDIF C 428 CONTINUE c if(btime)then call cpu_time(timef) timeh=timeh+timef-timei endif C C***************************************************************** C C PRINT LEVEL ENERGIES, TRANSFORMATION MATRICES AND H-SUBMATRICES. C C***************************************************************** C M2=0 C DO 525 I=1,NCJ C C J IS THE ARRAY INDEX OF THE WHOLE H-MATRIX, WHEREAS I IS THE C POSITION IN THE APPROPRIATE SUBMATRIX C J=I+LL !+NCI IT=NRR(J) IWRK3(J)=0 c if(qed.eq.99)then !post-process as grasp0 nn=nadru(j) coeff=dzero do l=1,ncj nj=naj(l+ll) coeff=coeff+tfu(nn+nj)**2 enddo mm1=iabs(nfk(it)) dd=dzero mm2=0 do k=nf,1,-1 if(qcg(k,mm1).ne.mm2)then mm2=qcg(k,mm1) if(qn(mm2).gt.0)dd=coeff*(vpint(mm2)+slfint(mm2)) endif dvu(i)=dvu(i)+dd enddo endif C DD=DVU(I) IF(IDY(I).GE.0)THEN M=NFK(IT) NFK(IT)=-IABS(M) IF(MODE.LT.3)DD=DD-DYY(NREL) DD=MOD(DD,TSHFT) ENDIF C COLD IF(ISHFTIC.LT.0)DD=DD+DELEIC(J,1) !POST-DIAG SHIFT IF(DD.LT.DMIN)THEN DMIN=DD JTMIN=J ENDIF C DENERG(J)=DD C IF(BTEC)GO TO 525 C IF(BPRNT0)THEN NN=NADRU(J) IF(MODE.NE.2.OR.ICC.LE.0)THEN DO L=1,NCJ DVECL(L)=TFU(NN+L) ENDDO ELSE DO L=1,NCJ DVECL(L)=DZERO if(idy(i)*idy(l).gt.0.and. x (idy(i).lt.0.or.idy(i).eq.idy(l)))then nj=naj(l+ll) dvecl(l)=tfu(nn+nj) endif ENDDO ENDIF M1=M2+1 M2=M1+I-1 IP=NFQ(IT) WRITE(6,182)J,IT,JN(J),QSI(IP)+1,QLI(IP)/2,QPI(IP)/2 X ,DE(I),DVU(I),NFK(IT),I,(DVECL(L),L=1,NCJ) X ,(DVP(L),L=M1,M2) ENDIF C C CALCULATE 'TERM-COUPLING COEFFICIENTS' FOR TRANSFORMING LS- C COUPLING CONFIGURATION-MIXING K-MATRICES TO INTERMEDIATE- C COUPLING K-MATRICES: IN THIS SECTION CARDS F1 AND F2, REQUIRED C AS INPUT TO SARAPH'S PROGRAM 'JAJOM', ARE PUNCHED -- SEE MPNCH C (REF. H.E.SARAPH, COMPUTER PHYS. COMMUN. 3(1972)256-68). C BEWARE PHASE CONVENTIONS! HERE CONDON & SHORTLEY. C IF(.NOT.BRESAT.AND.LMOD.AND.CPRINT)THEN C C NOTE: IF LMOD=.FALSE. PHASES OF TERM-COUPLING COEFFICIENTS MAY NOT C BE CONSISTENT WITH K-MATRIX DATA PRODUCED BY DISTORTED WAVE PROGRAM C OF W. EISSNER. C II=NADRU(J) NTRAN0=NTRAN+1 M=IORIG(IT) DO IB=1,NCJ IP=NRR(IB+NCI) IF(IP.NE.1.AND.NADWE(IP).EQ.0)BAUX=.TRUE. IF(.NOT.BAUX)THEN MP=IORIG(IP) IF(MP.LE.MTCC.AND.M.LE.MTCC)THEN DS=DZERO DO L=1,NCJ ITP=NRR(L+NCI) IF(NFQ(ITP).EQ.NFQ(IP))THEN NN=NADWE(IP)+NAI(ITP) DS=DS+TFU(II+L)*TFWE(NN) ENDIF ENDDO IF(ABS(DS).GT.D1M9)THEN NTRAN=NTRAN+1 IF(NTRAN.LE.MAXTR)THEN DT(NTRAN)=DS MMIKE(NTRAN)=MP IF(KTCC.LT.0)NMIKE(NTRAN)=M !JAJOM ENDIF ENDIF ENDIF ENDIF ENDDO IF(KTCC.GT.0.AND.MPNCH.LT.0)THEN !STGICF ID(J)=NTRAN c NTRR=MIN(NTRAN,MAXTR) c N1=NTRR-NTRAN0+1 c WRITE(4,756)J,N1,(MMIKE(L),DT(L),L=NTRAN0,NTRR) ENDIF ENDIF C 525 CONTINUE C NCI=NCI+NCJ C IF(.NOT.BRESAT.AND..NOT.BAUX.AND..NOT.BTEC.AND. X (KGROUP.EQ.NJO.OR.JN(J+1).NE.JN(J)))THEN IF(CPRINT.AND.LMOD.AND.KTCC.LT.0)THEN !JAJOM NTRR=MIN(NTRAN,MAXTR) WRITE(6,742)JN(J),NTRAN,(MMIKE(L),NMIKE(L),DT(L),L=1,NTRR) IF(MPNCH.LT.0)THEN IF(BFANO)THEN WRITE(1,743)JN(J),NTRAN,NZION,MION ELSE WRITE(1,744)JN(J),NTRAN,NZION,MION ENDIF IF(MTCC.LT.100.AND.MPNCH.GT.-4)THEN WRITE(1,753)(MMIKE(L),NMIKE(L),DT(L),L=1,NTRR) ELSE WRITE(1,754)(MMIKE(L),NMIKE(L),DT(L),L=1,NTRR) ENDIF ENDIF NTRAN=0 ENDIF ENDIF C C C******************************************** C C ***COMPUTE AUTOIONIZATION RATES*** C C EVALUATE C __ C I.E. DV(I,J)*H(J,K)*DV(K,L) C C******************************************** C C IF(ICC.EQ.0.OR.BTEC)GO TO 528 !BAIL OUT TO NEXT SYM GROUP C IF(EIMXIC.LT.DZERO)THEN !INDEX CONTINUUM ENERGY ORDER C I1=LL+1 CALL HPSRTI(NCJ,DENERG(I1),IWRK2) C M=0 DECMIN=-D1P20 C DO J=1,NCJ NVEC(J)=0 I=IWRK2(J) II=I+LL IT=NRR(II) IF(IDY(I).GT.0)THEN DRY=DENERG(II)+DECORE DRY=DRY+DRY IF(DRY.LE.EIMXIC)THEN !RESOLVED IF(DENERG(II).GT.(DECMIN+TOLB))THEN M=M+1 DE(M)=DENERG(II) IF(IDIAG.GE.0.AND.NFK(IT).LE.NCUT)THEN !ONLY CORR FOR AA NVEC(M)=II IWRK3(II)=M ELSE NSKP=NSKP+1 IWRK3(II)=-M ENDIF ELSE IF(NVEC(M).GT.0)THEN NSKP=NSKP+1 IWRK3(II)=-M ELSEIF(IDIAG.GE.0.AND.NFK(IT).LE.NCUT)THEN!IF LCON SPLIT NVEC(M)=II IWRK3(II)=M ELSE NSKP=NSKP+1 IWRK3(II)=-M ENDIF ENDIF DECMIN=DENERG(II) !ALLOW FOR ANY DRIFT A.U. ETM(IT)=D1P20 L=QLI(II)/2 MB=MBLK MWJ=IABS(NFK(IT)) IF(MWJ.GT.NCUT)MB=MCOR C C ADD TO ENERGY FUNCTIONAL C DD=DZERO IF(LL.EQ.0)GO TO 30 IF(LL.GT.0)THEN DO K=1,LL IF(INDEXW(K).EQ.IT)THEN DD=WGHT(K) GO TO 65 ENDIF ENDDO IF(IOPTIM.EQ.0)GO TO 30 ENDIF IF(I.GT.INCLUD.AND.IOPTIM.EQ.0)GO TO 30 C IF(MWJ.GT.NCUT)GO TO 30 !OMIT CORR. FROM DF FOR INCLUD>0 C IF(IWGHT.EQ.1)DD=DONE IF(IWGHT.NE.1)DD=WGT(IT) C 65 IF(IOPTIM.EQ.0)THEN !STANDARD DFFS=DAU*DD+DFFS DS0=DS0+DD ELSE !DIFF WITH OBS IF(IOPTIM.EQ.-2)THEN !TERMS IF(DELELS(IT,2).GT.DZERO)THEN DF0=(ABS(DELELS(IT,2)-DAU+DMIN)+DFC)/DELELS(IT,2) DFFS=DFFS+DF0*DD !*DF0 ELSEIF(DELELS(IT,2).EQ.DZERO)THEN DD=DZERO ENDIF ELSE DD=DZERO ENDIF ENDIF C 30 DEM=(DAU-DMIN)*DKCM*DTWO IF(ITEC.GT.0.OR.IOPTIM.LT.0)THEN IF(DELELS(IT,2).NE.DZERO)THEN TC=DELELS(IT,2)-DAU IF(IOPTIM.EQ.0)THEN DELELS(IT,1)=DELELS(IT,1)+TC IF(BPRNT0)WRITE(6,995)I,IT,DEM,IP,L,NFK(IT),MB,DD,DRY X ,2*TC ELSE IF(I.EQ.1)TC=TC-DG0 IF(BPRNT0)WRITE(6,995)I,IT,DEM,IP,L,NFK(IT),MB,DD,DRY X ,2*TC,2*DELELS(IT,2) ENDIF ELSE IF(BPRNT0)WRITE(6,995)I,IT,DEM,IP,L,NFK(IT),MB,DD,DRY ENDIF ELSE IF(BPRNT0)THEN IF(ISHFTLS.GT.1)THEN WRITE(6,995)I,IT,DEM,IP,L,NFK(IT),MB,DD,DRY, X DELELS(IT,1)*2 ELSE WRITE(6,995)I,IT,DEM,IP,L,NFK(IT),MB,DD,DRY ENDIF ENDIF ENDIF C ENDDO C ENDIF C 32 IF(ITEC.GT.0.OR.JTEC.GT.0)GO TO 5000 !NEXT ITERATION C IF(DS0.NE.DZERO)THEN !FINALIZE FUNCTIONAL DFFS=DAU0+DFFS/DS0 ELSE DECORE=DZERO ENDIF C IF(CPRINT.AND.MPNCH.LT.0)THEN !CLOSE TCC FILES IF(KTCC.LT.0)THEN WRITE(1,"(9X,'0 0',5X,'TCC END')") CLOSE(1,STATUS='KEEP') ELSEIF(KTCC.GT.0)THEN CLOSE(4,STATUS='KEEP') ENDIF ENDIF C C DE-ALLOCATE C 7600 CONTINUE C IF(BALLH)THEN !F95 DEALLOCATE (DU,DVU,DE,IDY,NVEC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*) !F95 X 'DIAGFS: DE-ALLOCATION FAILS FOR DU,DVU,DE,IDY,NVEC' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 IF(BPRNT0.AND.ALLOCATED(DVP))THEN !F95 DEALLOCATE (DVP,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DVP' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 BALLH=.FALSE. !F95 ENDIF !F95 C !F95 IF(BALLA)THEN !F95 DEALLOCATE (DUI,DVI,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DUI,DVI' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BALLA=.FALSE. !F95 ENDIF !F95 C IF(NF.LE.0)GO TO 750 !RETURN C C C******************************************** C C ***COMPUTE MULTIPOLE RADIATIVE DATA*** C C******************************************** CNRB: RE-WRITTEN FOR N^3 MULT. AND TO USE THE C LOOP OVER ALG STORAGE AS ONE OF THESE LOOPS. C******************************************** C C BRADAT=BPRINT.OR.JPRINT.EQ.3.AND.INCLUD.EQ.0 C IF(.NOT.BPRINT)BRADAT=JPRINT.LT.0.AND.NPRINT.GT.-2 !EVAL G FUNCTL C MLAM=0 IF(.NOT.BRADAT.OR.NPRINT.EQ.-2)GO TO 745 IF(.NOT.BINT)GO TO 106 C NPOSX=(IOS-IRK) if(nposx.le.0)go to 745 CF77 BPOS=NPOSX.LE.MXD30 !F77 BPOS=.TRUE. !FORCE FOR !F95 BOMRC=.FALSE. !F95 C MXORB2=MXORB*MXORB MXPOL=MAX(1,MPOLX/2+1) C IF(BPOS)THEN !PRE-DECODE ADDRESS C ALLOCATE (NPOS(4,NPOSX),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR NPOS' !F95 NF=0 !F95 GO TO 750 !RETURN !F95 ENDIF !F95 C NPOS0=IRK MCI=0 DO NC=1,NSL0 MC=NSL(NC) DO ND=1,NC N1=NED(1,ND,MCI+1) IF(N1.GT.0)THEN DO MD1=1,MC ND1=MD1+MCI N1=NED(1,ND,ND1) N2=NED(2,ND,ND1) DO M=N1,N2 NS=M-NPOS0 n8=MXORB2*MXPOL M1=INT(NRK(M)/n8) M2=M1+1 NPOS(1,NS)=M2 !TERM n8=M1*n8 MK=INT((NRK(M)-n8)/MXORB2) NPOS(2,NS)=MK !MULTIPOLE n8=n8+MK*MXORB2 n8=NRK(M)-n8 M1=INT(n8/MXORB+1) MM=INT(n8-(M1-1)*MXORB+1) M2=MIN0(M1,MM) NPOS(3,NS)=M2 !ORBITAL M1=M1+MM-M2 IF(MM.NE.M1)M1=-M1 NPOS(4,NS)=M1 !ORBITAL ENDDO ENDDO ENDIF ENDDO MCI=MCI+MC ENDDO ELSE NPOS0=0 WRITE(6,1605)NPOSX WRITE(0,1605)NPOSX ENDIF C !F95 IF(.NOT.BFOTJ)THEN !F95 ALLOCATE (DVECF(MENG,NENERG),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR DVECF' !F95 NF=0 !F95 GO TO 7450 !F95 ENDIF !F95 ENDIF !F95 C !F95 ALLOCATE (IDY(IAXDK),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR IDY' !F95 NF=0 !F95 GO TO 7450 !F95 ENDIF !F95 C BAUX=JPRINT.EQ.1.OR.JPRINT.GT.4 !.NOT.BAUX IGNORE CORRELATION C BDEL=MDEL.GT.0 IF(IDIAG.LT.0)WLG0=DTEN**MDEL C BJSEL=MULTS.EQ.0 C IF(IDIAG.LT.0)BJSEL=.TRUE. C DFS(1)=1 DFS(2)=1 DO I=3,MXDFS,2 DFS(I)=-DFS(I-2) DFS(I+1)=(I-1)*DFS(I-1)/32 ENDDO C BMPRNT=.NOT.BBORN.OR.(BBORN.AND.IABS(MBP2MX).GT.0) C CPRINT=JPRINT.EQ.2.OR.JPRINT.GT.4 NTRAN=0 IORT=IABS(MORT) DEM=2*DG00 !GROUND ENERGY (RYD) IF(EIONMN.EQ.DZERO)EIONMN=EIMXIC !ENABLE B-C SPLIT C IF(.NOT.BMODE.AND.BPRNT0)WRITE(MW,508)NZION,MION IF(.NOT.BMODE.AND..NOT.BPRNT0)WRITE(MWU)NZION,MION C IF(MENGB.GE.-1)THEN !INITIALIZE OMEGA BORN C WRITE(6,989) TOLO=D1M10 c if(nmetaj.gt.0)then nmin=min(NMETAJ,NSPECE) ixr=irow(nmin,nspece,ione,nspece) ixc=0 if(idw.eq.0.and.IABS(MENGB).EQ.1)ixc=icol(nmin,nspece,ione) nomwrt=max(ixr,ixc) else NOMWRT=(NSPECE*(NSPECE+1-2*ione))/2 endif C IF(IABS(MENGB).EQ.1)THEN !INFINITE ENERGY ONLY C BSCRO=.TRUE. !(REMOVE "ELSE" TO USE INTERNAL - WASTEFUL) C ALLOCATE (OMR(NOMWRT),OMC(NOMWRT),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: ALLOCATION FAILS FOR OMR,OMC' !F95 NF=0 !F95 GO TO 7450 !F95 ENDIF !F95 BOMRC=.TRUE. !F95 NOMWRX=NOMWRT !F95 C IF(NOMWRT.GT.NOMWRX)THEN NNN=2*NOMWRT/MXENG+1 WRITE(6,993)NNN WRITE(0,*)'*** WORKING ARRAYS TOO SMALL IN SR.DIAGFS' GO TO 3000 ENDIF DO I=1,NOMWRX OMR(I)=DZERO OMC(I)=DZERO ENDDO C ELSE !FINITE ENERGY C BSCRO=.TRUE. !.T. USE SCRATCH FILE, .F. STORE INTERNALLY C IF(.NOT.BSCRO)THEN !F95 ALLOCATE (OMEGA(0:MXNXB1,NOMWRT),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 BSCRO=.TRUE. !F95 ELSE !F95 BSCRO=.FALSE. !F95 ENDIF !F95 ENDIF !F95 NOMWRY=NOMWRT !F95 C CF77 BSCRO=BSCRO.OR.(NOMWRT.GT.NOMWRY) !F77 C IF(BSCRO)THEN C WRITE(0,*)'DIAGFS: USING SCRATCH FOR BORN MULTIPOLE SUM' C WRITE(6,*)'DIAGFS: USING SCRATCH FOR BORN MULTIPOLE SUM' ELSE DO N=1,NOMWRT DO NX=0,MXNXB1 OMEGA(NX,N)=0 ENDDO ENDDO ENDIF C DO NX=1,MXNXB XS(NX)=SQRT(DONE-DONE/XB(NX)) !CASE ICR NOT DONE IN DIAGON ENDDO C ENDIF C MSC0=80 MSC=MSC0-1 IBOMX=0 C ENDIF C IF(MENGB.EQ.1)THEN WLGO=D1M7/DZA2 STOL=D1M9 ELSE WLGO=D1M5/DZA2 STOL=D1M7 ENDIF c if(btime)call cpu_time(timei) C MLAM=MPOL0-2 737 MLAM=MLAM+2 NGROUP=MLAM/2 C BM1BP=NGROUP.EQ.2.AND.IABS(MBP2MX).GT.0 ! 1/2-BODY M1+BP EXISTS BM1NBP=NGROUP.EQ.2.AND.MBP2MX.EQ.0.AND.MBP1MX.LT.0 !M1 NON-REL c x .and.mpole.lt.6 BEKVEL=NGROUP.EQ.1.OR..NOT.BMPRNT ISB=1+ione C IF(NGROUP.EQ.1)THEN MP=0 IF(IORT.GT.20)ISB=IORT IF(BPRNT0)THEN WRITE(6,600)NGROUP IF(ISB.GT.2)WRITE(6,640)ISB,JORIG(ISB) ENDIF IF(WLG1.LT.DZERO)THEN WLG=D1M2 IF(IDIAG.LT.0.AND.BDEL)WLG=WLG0 ELSE WLG=DZERO ENDIF WLG=MAX(WLG,WLG1) WLGS=DKON IF(NPRINT.GE.0)WLGS=D1M20 ELSE IF(WLG2.LT.DZERO)THEN WLG=D1M7 ELSE WLG=DZERO ENDIF WLG=MAX(WLG,WLG2) WLGS=DKON IF(NGROUP.gt.1.AND.BMPRNT)THEN MP=5 MB=MBLK IF(BM1BP)MB=MBP IF(BPRNT0)WRITE(6,650)NGROUP,NGROUP-1,MB ELSE MP=5 IF(BPRNT0)WRITE(6,660)NGROUP,MP ENDIF ENDIF C BBORN=MENGB.GT.1.OR.(MENGB.EQ.1.AND.NGROUP.NE.1) BFOTJ=.NOT.BFOT.OR..NOT.BLAG BFOTJ=BFOTJ.OR.NGROUP.NE.1 !UNCOMMENT TO WRITE E1 ONLY BFAST=.NOT.BBORN.AND..NOT.BPRNT0.AND.BJSEL C IF(BSCRO)THEN !MENGB.GE.-1 MSC=MSC0+NGROUP OPEN(MSC,STATUS='SCRATCH',FORM='UNFORMATTED') ENDIF c c if(bborn)then !initialize flag to count Born usage c do i=1,mb4(0) c iflagb(i)=-1 c enddo c endif C IF(.NOT.BJSEL)WRITE(6,936) !PRINT WARNING IF LS SELECTION RULES C JOS=0 KTRAN=0 ILF=ione JJMN=1+ione JJMN=max(JJMN,ISB) JJMX=NENERG IF(JRAD.GT.0)THEN IF(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5)JJMN=MAX(JJMN,IAUTO) IF(JRAD.EQ.1)JJMX=MIN(IAUTO-1,NENERG) ENDIF JJMX=MIN(JJMX,JUPMX) JJMN=MAX(JJMN,JUPMN-1+ione) C C************************************ C START LOOP OVER UPPER ENERGY LEVELS C************************************ C DO 732 IAB=JJMN,JJMX C IF(.NOT.BAUX.AND.JORIG(IAB).LT.0)GO TO 732 KTRAN=IABS(KTRAN) IF(JORIG(IAB).GT.0)THEN ILF=ILF+1 ELSE KTRAN=-KTRAN ENDIF I=IABS(JORIG(IAB)) IT=NRR(I) C IF(.NOT.BFOT.AND.NFK(IT).LT.0)GO TO 732 C ND=NFQ(IT) MNS=QSI(ND) IF(BMULT.AND.MNS.NE.MULTSM)GO TO 732 MNL=QLI(ND) MQJ=JN(I) DZ9=DBLE(MQJ+1) NDJ=NGR(I) NCJ=NGRPJ(NDJ) !=I-NAJ(I) c c flag if mixing coefficient exists c if(mode.ne.2)then !b-b only do n=1,nt(ndj) idy(n)=-1 enddo elseif(nfk(it).gt.0)then !i is bound do n=1,nt(ndj) j=ncj+n jt=nrr(j) if(nfk(jt).gt.0)then !b-b idy(n)=-1 else !b-c idy(n)=0 endif enddo else !j is continuum m=-nfk(it) m=qcg(nf,m) ij=ieq(m) do n=1,nt(ndj) j=ncj+n jt=nrr(j) if(nfk(jt).gt.0)then !c-b idy(n)=0 else m=-nfk(jt) m=qcg(nf,m) if(ieq(m).eq.ij)then !c-c idy(n)=1 else !c-c' idy(n)=0 endif endif enddo endif C IIMN=1 IIMX=IAB-ione if(nmetaj.gt.0)iimx=min(iimx,nmetaj) IF(JRAD.GT.0)THEN IF(JRAD.EQ.3)IIMN=MAX(1,IAUTO) IF(JRAD.EQ.1.OR.JRAD.EQ.2.OR.JRAD.EQ.4)IIMX=MIN(IAUTO-1,IIMX) ENDIF IF(EIMXIC.GE.DZERO)THEN !OUTWITH DROPPED, NOT BUNDLED IIMN=MAX(IIMN,JLOWMN-1+ione) IIMX=MIN(IIMX,JLOWMX) ENDIF C C INITIALIZE/ZEROIZE C DO J=1,NENERG IWRK3(J)=IABS(IWRK3(J)) DVECL(J)=DZERO DVECV(J)=DZERO DVECA(J)=DZERO ENDDO IF(BBORN)THEN !BORN IBO=0 DO J=1,NENERG ID(J)=0 ENDDO ENDIF IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN DO J=1,NENERG DO M8=1,MENG DVECF(M8,J)=DZERO ENDDO ENDDO ENDIF C C********************************************************************** C PRE-MULTIPLY UPPER MIXING MATRIX BY MULTIPOLE MATRIX FOR ALL "LOWER" C STATES (ALL, BECAUSE THE "LOWER" STATES ARE TO BE MIXED SUBSEQUENTLY) C********************************************************************** C C ***** ELECTRIC ***** C C********************************************************************** C DVECL(J)= !EK LENGTH C IF(NGROUP.NE.2.OR.BBORN)DVECV(J)= !EK VELOCITY C********************************************************************** C C NCJP=0 DO KK=1,NJO !BEGIN LOOP OVER "LOWER" JP GROUPS C C FOR SPEED PRE-SELECT ACCORDING TO PARITY, TOTAL J: C NC=NSLJ(1,KK) M=QPI(NC)+QPI(ND) IF(MOD(M+MLAM,4).NE.0)GO TO 7334 MQJP=JN(NCJP+1) M=IABS(MQJ-MQJP) IF(M.GT.MLAM)GO TO 7334 M=MQJ+MQJP IF(M.LT.MLAM)GO TO 7334 DZ8=MQJP+1 DSJ=SQRT(DZ8*DZ9) C NCJP0=0 DO NGJP=1,NGSLJ(KK) !BEGIN LOOP OVER "LOWER" SLP GROUPS C NC=NSLJ(NGJP,KK) IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 7333 C MQSP=QSI(NC) !=MNSP MQLP=QLI(NC) !=MNLP C IF(.NOT.BJSEL)THEN !LS SELECTION RULES APPLIED IF(MNS.NE.MQSP)GO TO 7333 IF(IABS(MNL-MQLP).GT.MLAM)GO TO 7333 IF(MNL+MQLP.LT.MLAM)GO TO 7333 ENDIF C DO NJP1=1,NSL(NC) J=NCJP+NCJP0+NJP1 !=NCJ+POSITION IN JP GROUP LSL=NRR(J) IF(IWRK3(J).Le.IAB-ione.AND.IWRK3(J).LE.IIMX.AND. X NFK(LSL).GT.0)THEN C .AND.IWRK4(J).GT.IIMN !IWRK4 NOT SET-UP YET IWRK3(J)=-IABS(IWRK3(J)) !FLAG EXISTS ENDIF ENDDO C NCJ0=0 DO NGJ=1,NGSLJ(NDJ) !BEGIN LOOP OVER UPPER CI SLP GROUPS C ND=NSLJ(NGJ,NDJ) MQS=QSI(ND) MQL=QLI(ND) C IF(.NOT.BJSEL)THEN !LS SELECTION RULES IMPOSED ON CI IF(MQS.NE.MNS)GO TO 7340 IF(MQL.NE.MNL)GO TO 7340 ENDIF C C IC REDUCED MATRIX ELEMENT IS ZERO IF LS SELECTION RULES NOT SATISFIED C IT IS JUST A TRANSFORMATION OF LS REDUCED MATRIX ELEMENT (EJN EQU 116) C IF(MQSP.NE.MQS)GO TO 7340 IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 7340 IF(IABS(MQL-MQLP).GT.MLAM)GO TO 7340 IF(MQL+MQLP.LT.MLAM)GO TO 7340 C MMM=(MQL-MQLP)/2 DS=(-1)**MMM IF(BFANO)DS=DS*(-1)**NGROUP C DRACL=SJS(MQL,MQJ,MQS,MQJP,MQLP,MLAM,DFS,MXDFS)*DSJ* X (1-MOD(MQS+MQL+MQJP+MLAM,4)) IF(ABS(DRACL).LT.D1M7)GO TO 7340 C BEQGRP=ND.EQ.NC BING=ND.LE.NC IF(BING)THEN NU=NC NL=ND cn ngl=ndj NNNU=NCJP+NCJP0 NNNL=NCJ+NCJ0 ELSE NU=ND NL=NC cn ngl=kk NNNU=NCJ+NCJ0 NNNL=NCJP+NCJP0 ENDIF C J0=NNNU+1 I0=NRR(J0) IF(NED(1,NL,I0).EQ.0)GO TO 7340 C DO 7330 N=1,NSL(NU) !BEGIN LOOP OVER UPPER SYM. LEVELS C J0=NNNU+N !UPPER LEVEL INDEX I0=NRR(J0) !UPPER TERM INDEX C 332 IF(BING)THEN LSL=I0 J=J0 IF(IWRK3(J).GT.0)GO TO 7320 ELSE KSL=I0 K=J0 if(idy(k-ncj).eq.0)go to 7320 NI=NADRU(I)+NAJ(K) DD1=TFU(NI) IF(ABS(DD1).LT.CMXICR)GO TO 7320 ENDIF C N1=NED(1,NL,I0)-NPOS0 N2=NED(2,NL,I0)-NPOS0 C DO 736 M=N1,N2 !BEGIN LOOP OVER LOWER SYM. LEVELS C IF(BPOS)THEN !M2=LOWER TERM INDEX MK=NPOS(2,M) IF(MK.NE.NGROUP)GO TO 736 M2=NPOS(1,M) ELSE n8=MXORB2*MXPOL M1=INT(NRK(M)/n8) n8=M1*n8 MK=INT((NRK(M)-n8)/MXORB2) IF(MK.NE.NGROUP)GO TO 736 M2=M1+1 ENDIF C K0=NNNL+M2-NRR(NNNL+1)+1 !LOWER LEVEL INDEX cnc write(6,*)nrb(m2,ngl),k0,nnnl,nrr(nnnl+1),m2 cn if(nrb(m2,ngl).ne.k0)stop 'diagfs nnnl 1' C IF(BING)THEN KSL=M2 K=K0 if(idy(k-ncj).eq.0)go to 736 NI=NADRU(I)+NAJ(K) DD1=TFU(NI) IF(ABS(DD1).LT.CMXICR)GO TO 736 ELSE IF(I0.EQ.M2)GO TO 736 !AVOID DOUBLE COUNTING LSL=M2 J=K0 IF(IWRK3(J).GT.0)GO TO 736 ENDIF C IF(BPOS)THEN M2=NPOS(3,M) MM=NPOS(4,M) M1=IABS(MM) ELSE n8=n8+MK*MXORB2 n8=NRK(M)-n8 M1=INT(n8/MXORB+1) MM=INT(n8-(M1-1)*MXORB+1) M2=MIN0(M1,MM) M1=M1+MM-M2 ENDIF C DRY=DD1*DRK(M+NPOS0)*DRACL BINT=LSL.LE.KSL IF(.NOT.BINT)DRY=DRY*DS DSC=DOSC(NGROUP,M1,M2) DVECL(J)=DVECL(J)+DRY*DSC !LENGTH C IF(BREL.AND.NFK(IT).GT.0.and.irtard.gt.0)THEN!RETARD ALREADY ON PI DDD=DENERG(J)-DENERG(K) DDD=4*DDD*DDD*DRY DVECL(J)=DVECL(J)-C4*DDD*DOSC(NGROUP+2,M1,M2)/(2*(2*NGROUP+3)) ENDIF c c write(6,899)i,k,j,m+npos0,dd1,drk(m+npos0),dracl,dry,dsc,dvecl(j) c 899 format(4i5,6(1pe12.3)) C IF(.NOT.BFOTJ.AND.NFK(IT).LT.0)THEN !PHOTO M7=NFOSS(M1,M2) IF(M7.GT.0)THEN ISYGN=1 IF(MM.NE.M1) ISYGN=-ISYGN IF(.NOT.BINT) ISYGN=-ISYGN IF(ISYGN.LT.0)THEN DO M8=1,MENG DSC=DRY !LENGTH/ACCELERATION IF(IGAG(M8).EQ.0)DSC=-DSC !VELOCITY DVECF(M8,J)=DVECF(M8,J)+DFOSS(M7,M8,1)*DSC ENDDO ELSE DO M8=1,MENG DVECF(M8,J)=DVECF(M8,J)+DFOSS(M7,M8,1)*DRY ENDDO endif ENDIF ENDIF C IF(BFAST)GO TO 736 C IF(BEKVEL)THEN DSC=DZERO !CHANGE OF ORBITAL TO TERM ORDER (VEL) IF(M1.NE.M2)THEN DSC=DOSC(NGROUP,M2,M1) ELSE IF(NGROUP.GT.0)DSC=DOSC(NGROUP-1,M2,M1) ENDIF IF(MM.NE.M1) DSC=-DSC IF(.NOT.BINT) DSC=-DSC DVECV(J)=DVECV(J)+DRY*DSC !VELOCITY ENDIF C IF(BBORN)THEN !BORN IF(ID(J).EQ.0)THEN IBO=IBO+1 IF(IBO.LE.MXBIF)THEN ID(J)=IBO DO IX=1,MB3(0) DBL(IX,IBO)=DZERO ENDDO ELSE ID(J)=-IBO ENDIF ENDIF IF(ID(J).GT.0)THEN IB=ID(J) IN=ICOL(M2,M1,0) IF(BINDB(IN,NGROUP/2))THEN IX=INDX(IN) DBL(IX,IB)=DBL(IX,IB)+DRY ELSE JAB=IABS(IORIG(J)) WRITE(6,*)IAB,JAB,K,M,NGROUP,M2,M1 WRITE(0,*)'DIAGFS: BORN M1 M2 NOT FOUND' GO TO 3000 ENDIF ENDIF ENDIF C 736 CONTINUE !END LOOP OVER LOWER SYM. LEVELS C 7320 IF(BEQGRP)THEN !PICK-UP OTHER HALF IF(BING)THEN BING=.FALSE. J0=NNNL-NRR(NNNL+1)+I0+1 cnc write(6,*)nrb(i0,ngl),j0,nnnl,nrr(nnnl+1),i0 cn if(j0.ne.nrb(i0,ngl))stop 'diagfs nnnl 2' cn ngl=kk NNNL=NCJP+NCJP0 GO TO 332 ELSE BING=.TRUE. cn ngl=ndj NNNL=NCJ+NCJ0 ENDIF ENDIF C 7330 CONTINUE !END LOOP OVER UPPER SYM. LEVELS C 7340 NCJ0=NCJ0+NSL(ND) ENDDO !END LOOP OVER UPPER CI SLP GROUPS C1 7333 NCJP0=NCJP0+NSL(NC) ENDDO !END LOOP OVER "LOWER" SLP GROUPS C 7334 NCJP=NCJP+NT(KK) ENDDO !END LOOP OVER "LOWER" JP GROUPS C IF(BBORN)THEN IBOMX=MAX(IBOMX,IBO) IF(IBO.GT.MXBIF)THEN WRITE(6,*)'SR.DIAGFS: DIMENSION ERROR, INCREASE MXBIF TO ' X ,IBO WRITE(0,*)'SR.DIAGFS: DIMENSION ERROR, INCREASE MXBIF' GO TO 3000 ENDIF ENDIF C C C********************************************************************** C C ***** MAGNETIC ***** C C********************************************************************** C C M1 (NON-REL) C DVECA(J)= !M1 C********************************************************************** C IF(BM1NBP)THEN C MLAMM=MLAM-2 !MLAMM=2 FOR M1 C NCJP=0 DO KK=1,NJO !BEGIN LOOP OVER "LOWER" JP GROUPS C IF(NMETGJ(KK)+NMETGJ(NDJ).GT.1)GO TO 6334 C C FOR SPEED PRE-SELECT ACCORDING TO PARITY, TOTAL J: C NC=NSLJ(1,KK) M=QPI(NC)+QPI(ND) IF(MOD(M+MLAM,4).NE.0)GO TO 6334 MQJP=JN(NCJP+1) M=IABS(MQJ-MQJP) IF(M.GT.MLAMM)GO TO 6334 M=MQJ+MQJP IF(M.LT.MLAMM)GO TO 6334 C NCJP0=0 DO NGJP=1,NGSLJ(KK) !BEGIN LOOP OVER "LOWER" SLP GROUPS NC=NSLJ(NGJP,KK) C IF(.NOT.BJSEL)THEN !LS SELECTION RULES APPLIED MNSP=QSI(NC) MNLP=QLI(NC) IF(MNS.NE.MNSP)GO TO 6333 IF(IABS(MNL-MNLP).GT.MLAMM)GO TO 6333 IF(MNL+MNLP.LT.MLAMM)GO TO 6333 ENDIF C NPP=NSL(NC) DO 6330 NJP1=1,NPP !BEGIN LOOP OVER "LOWER" SLJP LEVELS C J=NCJP+NCJP0+NJP1 !=NCJ+POSITION IN JP GROUP IF(IWRK3(J).Gt.IAB-ione)GO TO 6330 IF(IWRK3(J).GT.IIMX)GO TO 6330 C IF(IWRK4(J).LT.IIMN)GO TO 6330 !IWRK4 NOT SET-UP YET LSL=NRR(J) IF(NFK(LSL).LT.0)GO TO 6330 IWRK3(J)=-IABS(IWRK3(J)) !FLAG EXISTS C NCJ0=0 DO NGJ=1,NGSLJ(NDJ) !LOOP OVER UPPER CI SLP GROUPS C ND=NSLJ(NGJ,NDJ) IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 6340 IF(NC.NE.ND)GO TO 6340 !NC=ND FOR NON-REL M1 MQS=QSI(ND) MQL=QLI(ND) C IF(.NOT.BJSEL)THEN !LS SELECTION IMPOSED ON CI IF(MQS.NE.MNS)GO TO 6340 IF(MQL.NE.MNL)GO TO 6340 ENDIF C NP=NSL(ND) DO NJP=1,NP !LOOP OVER UPPER CI SLJP LEVELS C K=NCJ+NCJ0+NJP if(idy(k-ncj).eq.0)go to 634 M=NADRU(I)+NAJ(K) DD1=TFU(M) C IF(ABS(DD1).LT.CMXICR)GO TO 634 C KSL=NRR(K) c write(0,*)njp1,lsl,nc,njp,ksl,nd IF(KSL.EQ.LSL.AND.IABS(MQJ-MQJP).LE.2)THEN IF(MQJ.EQ.MQJP)THEN MJ=(MQJ+2)*MQJ DSC=(MQS+2)*MQS-(MQL+2)*MQL+3*MJ DD8=(MQJ+1)*MJ ELSE MJ=MAX0(MQJ,MQJP) DD8=DBLE(((MJ-MQS+MQL)*(MJ+MQS-MQL)*MJ*(MJ+MQS+MQL+2) X *(MQS+MQL+2-MJ))/2) DSC=1 IF(K.GT.J)THEN DSC=-DSC !OVERALL PHASE - EJN (123) IF(BFANO)DSC=-DSC ENDIF c write(0,*)k,j,mqj,mqjp !k.gt.j iff mqj.lt.mqjp (mqj.ne.mqjp) ENDIF DVECA(J)=DVECA(J)+DD1*DSC* SQRT(DD8)/(DFOUR*MJ)!NON-REL M1 ENDIF C 634 ENDDO !END LOOP OVER UPPER CI SLJP LEVELS C 6340 NCJ0=NCJ0+NSL(ND) ENDDO !END LOOP OVER UPPER CI SLP GROUPS C 6330 CONTINUE !END LOOP OVER "LOWER" SLJP LEVELS C 6333 NCJP0=NCJP0+NPP ENDDO !END LOOP OVER "LOWER" SLP GROUPS C 6334 NCJP=NCJP+NT(KK) ENDDO !END LOOP OVER "LOWER" JP GROUPS C GO TO 450 C ENDIF !END NON-REL M1 C C********************************************************************** C C M1BP AND MK>1 C C IF(NGROUP.EQ.2.AND..NOT.BBORN)DVECV(J)= !MK0/E1 REL VEL C DVECA(J)= !MK1 C********************************************************************** C C IF(NGROUP.EQ.0)GO TO 450 !ALLOW MK (K=NGROUP-1) IF(NGROUP.EQ.1.AND.MEKVMX.LT.2)GO TO 450 !NO E1 REL VEL IF(NMD1(1,1,1).LT.0.AND.NMD2(1,1,1).LT.0)GO TO 450!NO MK IF(NGROUP.GT.2.AND.NMD1(1,1,1).LT.0)GO TO 450 !NO MK MLAMM=MLAM-2 !TEST MLAM-2 FOR MK IF(NGROUP.EQ.1)MLAMM=MLAM C NCJP=0 DO KK=1,NJO !BEGIN LOOP OVER "LOWER" JP GROUPS C IF(NMETGJ(KK)+NMETGJ(NDJ).GT.1)GO TO 8334 C C FOR SPEED PRE-SELECT ACCORDING TO PARITY, TOTAL J: C NC=NSLJ(1,KK) M=QPI(NC)+QPI(ND) IF(MOD(M+MLAM,4).NE.0)GO TO 8334 MQJP=JN(NCJP+1) M=IABS(MQJ-MQJP) IF(M.GT.MLAMM)GO TO 8334 M=MQJ+MQJP IF(M.LT.MLAMM)GO TO 8334 C NPP=NT(KK) DO NJP1=1,NPP C J=NCJP+NJP1 IF(IWRK3(J).Gt.IAB-ione)GO TO 833 IF(IWRK3(J).GT.IIMX)GO TO 833 C IF(IWRK4(J).LT.IIMN)GO TO 833 !IWRK4 NOT SET-UP YET LSL=NRR(J) IF(NFK(LSL).LT.0)GO TO 833 IWRK3(J)=-IABS(IWRK3(J)) !FLAG EXISTS C 833 ENDDO C BEQGRP=KK.EQ.NDJ BING=NDJ.LE.KK IF(BING)THEN NU=KK NL=NDJ NNN=NCJP DS=1-MOD(IABS(MQJ-MQJP),4) IF(BFANO)DS=DS*(1-MOD(MLAMM,4)) ELSE NU=NDJ NL=KK NNN=NCJ DS=1 ENDIF C NP=NT(NU) DO 8340 NJP=1,NP !LOOP OVER UPPER CI JP LEVELS C J0=NNN+NJP C 430 IF(BING)THEN J=J0 IF(IWRK3(J).GT.0)GO TO 834 ELSE K=J0 IF(.NOT.BJSEL)THEN !LS SELECTION IMPOSED ON CI KSL=NRR(K) ND=NFQ(KSL) MQS=QSI(ND) MQL=QLI(ND) IF(MQS.NE.MNS)GO TO 834 IF(MQL.NE.MNL)GO TO 834 ENDIF if(idy(k-ncj).eq.0)go to 834 M=NADRU(I)+NAJ(K) DD1=TFU(M) IF(ABS(DD1).LT.CMXICR)GO TO 834 DD8=DD1*DS ENDIF C C 2-BODY C IF(NGROUP.EQ.2.and.NMD2(1,1,1).GE.0)THEN N1=NMD2(1,NL,J0) N2=NMD2(2,NL,J0) c write(6,*)n1,n2,j,nl,j0 DO N=N1,N2 !BEGIN 2-BODY LOOP OVER LOWER JP LEVELS N8=(MSS(N)-1)/MAXMI MJ=INT(MSS(N)-N8*MAXMI) K0=INT(N8)+1 C IF(BING)THEN K=K0 IF(.NOT.BJSEL)THEN !LS SELECTION RULES APPLIED LSL=NRR(K) NC=NFQ(LSL) MNSP=QSI(NC) MNLP=QLI(NC) IF(MNS.NE.MNSP)GO TO 435 IF(IABS(MNL-MNLP).GT.MLAMM)GO TO 435 IF(MNL+MNLP.LT.MLAMM)GO TO 435 ENDIF if(idy(k-ncj).eq.0)go to 435 M=NADRU(I)+NAJ(K) DD1=TFU(M) IF(ABS(DD1).LT.CMXICR)GO TO 435 DD8=DD1*DS ELSE IF(J0.EQ.K0)GO TO 435 !AVOID DOUBLE COUNTING J=K0 IF(IWRK3(J).GT.0)GO TO 435 ENDIF C DVECA(J)=DVECA(J)+DNL(MJ)*DSS(N)*DD8 !REL M1 c write(6,*)n,j,dveca(j) 435 ENDDO !END 2-BODY LOOP OVER LOWER JP LEVELS ENDIF C C 1-BODY (REL) C IF(NMD1(1,1,1).LT.0)GO TO 834 N1=NMD1(1,NL,J0) N2=NMD1(2,NL,J0) c c write(6,*)nl,j0,n1,n2 c if(n1.eq.0)go to 834 C DO N=N1,N2 !BEGIN 1-BODY LOOP OVER LOWER JP LEVELS N8=(NRKP(N)-1)/MXSOI MJ=INT(NRKP(N)-N8*MXSOI) KX=QRLP(4,MJ) K0=INT(N8)+1 C IF(BING)THEN K=K0 IF(.NOT.BJSEL)THEN !LS SELECTION RULES APPLIED LSL=NRR(K) NC=NFQ(LSL) MNSP=QSI(NC) MNLP=QLI(NC) IF(MNS.NE.MNSP)GO TO 436 IF(IABS(MNL-MNLP).GT.MLAMM)GO TO 436 IF(MNL+MNLP.LT.MLAMM)GO TO 436 ENDIF if(idy(k-ncj).eq.0)go to 436 M=NADRU(I)+NAJ(K) DD1=TFU(M) IF(ABS(DD1).LT.CMXICR)GO TO 436 DD8=DD1*DS ELSE IF(J0.EQ.K0)GO TO 436 !AVOID DOUBLE COUNTING J=K0 IF(IWRK3(J).GT.0)GO TO 436 ENDIF C DRY=(DENERG(K)-DENERG(J))*2 !TEST K->I c write(6,*)n,kx,k,j,dry M1=QRLP(1,MJ) M2=QRLP(2,MJ) C dry0=dey(m1)-duy(m1,m1)-(dey(m2)-duy(m2,m2)) ! a.u. dry0=abs(dry0+dry0) !abs <- falling order c dry=dry0 !test use of orb ener IF(KX.GT.8) THEN !1-BODY MK IF(QRLP(3,MJ).NE.MLAMM)GO TO 436 !WRONG MULTIPOLE DSC=DRLP1(MJ) IF(KX.EQ.9.AND.BREL)THEN c write(6,*)dsc DVECV(J)=DVECV(J)+DRKP(N)*DD8*DSC !MK0 if(brtard)then IF(.NOT.BREL2)THEN DRY=DRY*DRY c 2* for spin DSC=DSC-2*C4*DRY*DOSC(NGROUP,M1,M2)/(2*(2*NGROUP-1)) c write(6,*)m1,m2,ngroup,dsc,dry,dosc(ngroup,m1,m2) ELSE IF(NGROUP.GT.2)THEN DSC0=DOSC(NGROUP-2,M1,M2) ELSE IF(M1.EQ.M2)THEN DSC0=DONE ELSE DSC0=DZERO ENDIF ENDIF DVECV(J)=DVECV(J)+DRKP(N)*DD8*(DSC0-DSC) !MK0 ENDIF endif ENDIF DSC=DRKP(N)*DD8*DSC !DD1->DD8 IF(KX.EQ.10)DSC=DSC*DRY*DRY c write(6,*) c x ngroup,i,j,k,kx,qrlp(1,mj),qrlp(2,mj),dsc,drkp(n),drlp1(mj) DVECA(J)=DVECA(J)+DSC !MK1 c write(6,*)j,dveca(j) GO TO 436 ENDIF C IF(NGROUP.GT.2)GO TO 436 !REL DIPOLE ONLY C DSC=DRLP1(MJ) c write(6,*)'kx=',kx,m1,m2,dsc c dry0=dry !test use of level ener if(igagr.gt.0.and.(kx.eq.4.or.kx.eq.6.or.kx.eq.7.or.kx.eq.8) !then x .and.ql(m1).eq.ql(m2))then !check rad/radial if(qn(m1).ne.qn(m2))then mx=max(m1,m2) mn=min(m1,m2) tt=dry0*dry0*dosc(ngroup,mx,mn)/4 c write(6,*)'kx=',kx,mx,mn,dry0,dosc(ngroup,mx,mn) c case l1=n1-1, l2.lt.l1 only if(ql(m1).ne.ql(m2)) !check rad/radial x tt=-tt*dble(min(ql(m1),ql(m2))/2+1)/dble(max(ql(m1),ql(m2))+1) else tt=2*(dey(m1)-duy(m1,m1))+2*(dey(m2)-duy(m2,m2)) c case l1=n1-1, l2.lt.l1 only if(ql(m1).ne.ql(m2))tt=tt/ !check rad/radial x sqrt(dble(min(ql(m1),ql(m2))/2+2)*dble(max(ql(m1),ql(m2))+1)) endif else tt=dzero endif IF(KX.EQ.8)THEN DSC=(tt-D2LL(M1,M2)-DSC*DRY*DRY/D2P1)*C4*DTWO IF(M2.EQ.M1)THEN DSC=DSC+1 IF(BMPRNT)DVECV(J)=DVECV(J)+DD8*DRKP(N) !REL M0 ENDIF ELSEIF(KX.EQ.7)THEN if(igagr.gt.0.and.ql(m1).eq.ql(m2))then !check rad/radial dsc=tt*c4*nzion/nza else DSC=-NZION*DSC endif ELSEIF(KX.EQ.5)THEN DSC=DRY*DRY*DSC/D2P1 ELSEIF(KX.EQ.6)THEN DSC=DRY*DSC+(tt-D2LL(M1,M2))*C4 elseif(kx.eq.4)then dsc=dsc-tt*c4 ENDIF C DRAC=DD8*DRKP(N)*DSC c write(6,*)'kx=',kx,m1,m2,tt,dsc,drkp(n),drac,dveca(j),j C IF(QPI(NC).NE.QPI(ND))THEN c write(6,*)dvecv(j),drac DVECV(J)=DVECV(J)+2*NZION*DRAC/DRY !REL E1(VEL) ELSE DVECA(J)=DVECA(J)+DRAC !REL M1 c write(6,*)j,kx,dveca(j)-drac,dveca(j),dvecv(j) ENDIF c write(6,*)qrlp(1,mj),qrlp(2,mj),kx,drkp(m),dsc C 436 ENDDO !END 1-BODY LOOP OVER LOWER JP LEVELS C 834 IF(BEQGRP)THEN !PICK-UP OTHER HALF IF(BING)THEN BING=.FALSE. GO TO 430 ELSE BING=.TRUE. ENDIF ENDIF C 8340 CONTINUE !END LOOP OVER UPPER CI JP LEVELS C 8334 NCJP=NCJP+NT(KK) ENDDO !END LOOP OVER "LOWER" JP GROUPS C C END M1BP AND MK>1 C C********************************************************************** C C END LOOPS OVER EK, MK CONNECTION TO UPPER ENERGY LEVELS C C********************************************************************** C C ********************************************* C C START LOOP OVER LOWER ENERGY LEVELS (EK & MK) C C********************************************** C 450 ILI=0 SUMRN=DZERO SUMRD=DZERO C DO 733 JAB=IIMN,IIMX C IF(.NOT.BAUX.AND.JORIG(JAB).LT.0)GO TO 733 IF(JORIG(JAB).GT.0)THEN ILI=ILI+1 IF(KTRAN.GE.0)KTRAN=KTRAN+1 ENDIF J=IABS(JORIG(JAB)) IF(IWRK3(J).GT.0)GO TO 733 IF(IABS(MENGB).EQ.1.AND.MOD(NGROUP,2).EQ.1)THEN IX=IROW(ILI,ILF,ione,NSPECE) IF(OMR(IX).LT.-TOLO)GO TO 733 !DIPOLE ALREADY COMPUTED ENDIF ITP=NRR(J) C IF(IDIAG.GE.0.AND.BDEL)THEN MRD=0 I5=0 M3=NFK(IT) M3=IABS(M3) M4=NFK(ITP) DO I3=1,MXORB I4=NEL(I3,M3)-NEL(I3,M4) IF(I4.NE.0)THEN I5=I5+1 MRDP=MRD MRD=QN(I3) IF((-1)**I5.GT.0.AND.IABS(MRD-MRDP).GE.MDEL)GO TO 693 ENDIF ENDDO GO TO 733 693 CONTINUE ENDIF C II=NFQ(ITP) MNSP=QSI(II) MNLP=QLI(II) NN=NGR(J) L1=NGRPJ(NN)+1 !=J-NAJ(J)+1 L2=L1+NT(NN)-1 DZ8=JN(J)+1 C DD=DZERO DMIN=DZERO DDM=DZERO C IF(BFAST)THEN IF(BFOTJ.OR.NFK(IT).GT.0)THEN DO L=L1,L2 lt=nrr(l) if(nfk(lt).gt.0)then M=NADRU(J)+NAJ(L) DD=DD+TFU(M)*DVECL(L) endif ENDDO ELSE DO M8=1,MENG DFOT(M8)=DZERO ENDDO DO L=L1,L2 lt=nrr(l) if(nfk(lt).gt.0)then M=NADRU(J)+NAJ(L) DD2=TFU(M) IF(ABS(DD2).GT.CMXICR)THEN DD=DD+DD2*DVECL(L) DO M8=1,MENG DFOT(M8)=DFOT(M8)+DD2*DVECF(M8,L) ENDDO ENDIF endif ENDDO ENDIF ELSE IF(BBORN)THEN !BORN DO K=1,MB3(0) SBL(K)=DZERO ENDDO ENDIF IF(BFOTJ.OR.NFK(IT).GT.0)GO TO 7350 DO M8=1,MENG DFOT(M8)=DZERO ENDDO 7350 DO L=L1,L2 lt=nrr(l) if(nfk(lt).lt.0)go to 735 M=NADRU(J)+NAJ(L) DD2=TFU(M) IF(ABS(DD2).LT.CMXICR)GO TO 735 IF(.NOT.BJSEL)THEN !LS SELECTION RULES IMPOSED ON CI LSL=NRR(L) IB=NFQ(LSL) MQSP=QSI(IB) MQLP=QLI(IB) IF(MQLP.NE.MNLP)GO TO 735 IF(MQSP.NE.MNSP)GO TO 735 ENDIF DD=DD+DD2*DVECL(L) DMIN=DMIN+DD2*DVECV(L) DDM=DDM+DD2*DVECA(L) IF(BBORN)THEN !BORN IBO=ID(L) IF(IBO.GT.0)THEN DO M=1,MB3(0) SBL(M)=SBL(M)+DD2*DBL(M,IBO) ENDDO ENDIF ENDIF IF(BFOTJ.OR.NFK(IT).GT.0)GO TO 735 DO M8=1,MENG DFOT(M8)=DFOT(M8)+DD2*DVECF(M8,L) ENDDO 735 ENDDO ENDIF C OBO(MINFB)=DZERO IF(MENGB.EQ.-1.AND.ABS(DD).GT.WLGO)OBO(MINFB)=D1P30 IF(NGROUP.EQ.0)DD=DZERO IF(NGROUP.GT.0.AND.ABS(DD).LT.DEPS.AND.ABS(DDM).LT.DEPS)GO TO 733 C C BORN MULTIPOLES C IF(BBORN)THEN !BORN DO IE=1,MENGB OBO(IE)=DZERO ENDDO OMG1=DZERO DLAM=2*NGROUP+1 NH=NGROUP/2 DO N=1,MB4(0) L=INDL(N) K=INDK(N) SSB=SBL(K)*SBL(L) IF(ABS(SSB).GT.STOL)THEN DO IE=1,MENGB DB=SSB*BL(IE,N,NH) c if(db.ne.dzero)iflagb(n)=iabs(iflagb(n)) !flag used OBO(IE)=OBO(IE)+DB+DB IF(L.EQ.K)OBO(IE)=OBO(IE)-DB ENDDO IF(NGROUP.EQ.1)THEN DB=SSB*TM2(N) OMG1=OMG1+DB+DB IF(L.EQ.K)OMG1=OMG1-DB ENDIF ENDIF ENDDO DB=DEIGHT*DLAM DO IE=1,MENGB OBO(IE)=DB*OBO(IE) ENDDO OMG1=DB*OMG1 ENDIF C C ELECTRIC AND MAGNETIC MULTIPOLES C JOS=JOS+1 DRY=DENERG(I)-DENERG(J) IF(DRY.EQ.DZERO)then if(mengb.lt.-1)GO TO 733 !CASE M1/E2 DEGENERATE dry=d1m10 endif c IF(NFK(IT).LT.0)DRY=DRY+DYY(NREL) DRY=DRY+DRY MI=IAB MJ=JAB IF(NFK(IT).LT.0)MI=-MI C IF(NFK(ITP).LT.0)MJ=-MJ MWJ=JN(J)+1 MWI=JN(I)+1 MB=MBLK IF(JORIG(IAB).LT.0.OR.JORIG(JAB).LT.0)MB=MCOR WLG=ABS(WLG) IF(NFK(IT).LT.0)WLG=-WLG C !DOWNWARD SIGNS ON EVERYTHING DB=DRY**(MLAM-1)*DFSC**(MLAM-2) DD=ABS(DD)*DD !SEK DSC=DG(NGROUP)*DB*DD !GF IF(NFK(IT).GT.0)DAS=C1*DSC*DRY*DRY/DZ9 !AEK IF(NFK(IT).LT.0)DAS=C2*DSC/DZ8 DZ=D1P8/(DRY*DKCM) C IF(NGROUP.GT.1.AND.BMPRNT)THEN !MAGNETIC DS=ABS(DMIN)*DMIN !SMK0 DMIN=ABS(DDM)*DDM !SMK1 DDM1=DG(NGROUP-1)*ABS(DMIN)*C1*DB/(4*DZ9) !AMK1 ELSE IF(NGROUP.GT.1.AND..NOT.BMPRNT)THEN DS=ABS(DDM)*DDM !SMK DDM1=DG(NGROUP-1)*ABS(DS)*C1*DB/(4*DZ9) !AMK ELSE DDM1=DZERO ENDIF !omit dry if orb de DS=DG(NGROUP)*DB*ABS(DMIN)*DMIN/(DRY*DRY) !GF(VEL) DD1=DTEN**MP*DSC/DZ8 !FABS DD2=DTEN**MP*DSC/DZ9 !FEMI DDM=OBO(MINFB) IF(NGROUP.EQ.1)DDM=DFOUR*ABS(DD1)/(DRY*DRY) !ALF(POL) ENDIF C IF(ABS(DAS).LT.WLG.AND.ABS(OBO(MINFB)).LT.WLGO.AND.DSC*DSC.LT. X WLGS.AND.ABS(DDM1).LT.WLG)GO TO 733 C IF(NGROUP.EQ.1)THEN NTRAN=NTRAN+1 OMG=DFOUR*DSC/DRY IF(IABS(MENGB).EQ.1)THEN OMGINF=-ABS(OMG) OMG=OMG*LOG(EINF*DZ2) OMG=-ABS(OMG) !TAG DIPOLE NEGATIVE IF(OMG.GE.-TOLO)OMG=DZERO !ZERO VANISHINGLY SMALL CPT ELSEIF(MENGB.GT.1)THEN OMG=-ABS(OMG) !4S/3 if(nmetaj.eq.0)nmetaj=iimx !pwb ENDIF if(idw.eq.0)then if(nmetaj.eq.0)nmetaj=nenerg !for RM else if(nmetaj.eq.0)nmetaj=iimx endif ELSE OMG=OBO(MINFB) OMGINF=OMG ENDIF C C DETERMINE BORN OMEGAS C BPRNTO=.FALSE. IF(MPOL0.EQ.0.AND.MB.EQ.MBLK)THEN IF(IABS(MENGB).EQ.1)THEN !INFINITE ENERGY BORN ONLY BPRNTO=.TRUE. IXC=ICOL(ILI,ILF,ione) IF(IXC.LE.NOMWRX)OMC(IXC)=OMC(IXC)+OMG IXR=IROW(ILI,ILF,ione,NSPECE) IF(IXR.LE.NOMWRX)OMR(IXR)=OMR(IXR)+OMG OMEGAB(MXNXB1)=OMGINF ELSEIF(MENGB.GT.1.AND.ABS(OBO(MINFB)).GT.WLGO)THEN !FINITE BORN BPRNTO=.TRUE. CALL BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS X ,DB0,DB1,OMG1,OBO,OMEGAB) OMEGAB(MXNXB1)=OMG !INFINITE ENERGY c if(nlagb.lt.0)go to 3000 !brnint failure ELSEIF(ABS(DDM1).GT.WLG)THEN !ONLY M_K HERE BPRNTO=.TRUE. DO K=1,MXNXB1 OMEGAB(K)=DZERO ENDDO ENDIF ENDIF C C OUTPUT ELECTRIC AND MAGNETIC MULTIPOLE DATA. C IF(BPRNT0)THEN IF(NGROUP.GT.1.AND.BMPRNT) X WRITE(6,710)JOS,MB,MI,MJ,DAS,DDM1,DD,DMIN,DS,DSC,DZ,OBO(MINFB) IF(NGROUP.LT.2.OR..NOT.BMPRNT) X WRITE(6,709)JOS,MB,MI,MJ,DAS,DD,DSC,DD1,DD2,DZ,DS,DDM ENDIF IF(BPRNTO)THEN T=ABS(DAS)+ABS(DDM1) IF(BSCRO)THEN WRITE(MSC)MI,MJ,T,(OMEGAB(K),K=1,MXNXB1) ELSE OMEGA(0,KTRAN)=OMEGA(0,KTRAN)+sngl(T) T=dble(OMEGA(MXNXB1,KTRAN)) KMX=MXNXB1 IF(MOD(NGROUP,2).EQ.1.AND.T.LT.-TOLO)KMX=MXNXB !OLD DIPOLE DO K=1,KMX OMEGA(K,KTRAN)=OMEGA(K,KTRAN)+sngl(OMEGAB(K)) ENDDO ENDIF ENDIF C IF(MODE.LT.1)GO TO 429 DB=DENERG(J)+DENERG(J)+DEM IF(NFK(IT)*NFK(ITP).LT.0)GO TO 335 C IF(JAB.LE.JLOWMX.AND.DB.LE.EIMXIC.AND. X IHARRY(NFK(ITP)).LE.NRSLMX)THEN !RESOLVED IF(ABS(DAS).LT.D1M7.AND.ABS(DDM1).LT.D1M7)GO TO 733 IF(NGROUP.GT.1)DAS=ABS(DAS)+ABS(DDM1) IF(BPRNT0)WRITE(MW,501)NFK(IT),I,MWI,NFK(ITP),J,MWJ,DAS,DRY,DB IF(.NOT.BPRNT0)WRITE(MWU)NFK(IT),I,MWI,NFK(ITP),J,MWJ,DAS,DRY,DB ELSE !BUNDLED IF(DB.LT.EIONMN)THEN SUMRN=SUMRN+ABS(DAS)+ABS(DDM1) ELSE SUMRD=SUMRD+ABS(DAS)+ABS(DDM1) ENDIF ENDIF GO TO 429 C 335 IF(BFOTJ)GO TO 733 C DO M8=1,MENG DRY=DENERG(I)-DENERG(J)+DYY(M8) DRY=DRY+DRY C C N.B. SIGN OF REDUCED MATRIX ELEMENT IS FOR DOWNWARD TRANSITION. C TO GET SIGN FOR UPWARD TRANSITION, REMOVE 'C' FROM NEXT TWO LINES. C DFOT(M8)=DFOT(M8)*(-1)**((JN(I)-JN(J))/2) C IF(BFANO)DFOT(M8)=DFOT(M8)*(-1)**NGROUP C DFOT(M8)=C3*DRY*DFOT(M8)*ABS(DFOT(M8))/DZ8 ENDDO C DRY=DENERG(I)+DENERG(I)+DEM C C PI DAS IS ALWAYS LENGTH, EVEN WHEN VEL/ACC SET. C IF(JAB.LE.JLOWMX.AND.DB.LE.EIMXIC.AND.IWRK2(I).LE.JIMXIC.AND. X IHARRY(NFK(ITP)).LE.NRSLMX)THEN !RESOLVED IF(BPRNT0)THEN WRITE(MWW,501)NFK(ITP),J,MWJ,NFK(IT),I,IWRK2(I),DAS,DB,DRY WRITE(MWW,515)(DFOT(M8),M8=1,MENG) ELSE WRITE(MWWU)NFK(ITP),J,MWJ,NFK(IT),I,IWRK2(I),DAS,DB,DRY WRITE(MWWU)(DFOT(M8),M8=1,MENG) ENDIF ENDIF GO TO 733 C C SET UP ARRAY CONTAINING DIPOLE TRANSITION RATES FOR USE BY CASC C 429 IF(NTRAN.LT.MXNOR.AND..NOT.BDR.AND.NGROUP.EQ.1)THEN AP(NTRAN)=ABS(DAS) MADD(NTRAN)=(IAB-1)*NENERG+JAB-1 ENDIF C C 733 CONTINUE !END LOOP OVER LOWER LEVELS C C WLG=ABS(WLG) IF(SUMRN.GT.WLG)THEN IF(BPRNT0)WRITE(MW,501)NFK(IT),I,MWI,MZERO,MZERO,MZERO,SUMRN X ,DZERO,DEM IF(.NOT.BPRNT0)WRITE(MWU)NFK(IT),I,MWI,MZERO,MZERO,MZERO,SUMRN X ,DZERO,DEM ENDIF IF(SUMRD.GT.WLG)THEN IF(BPRNT0)WRITE(MW,501)NFK(IT),I,MWI,MZERO,MZERO,MZERO,SUMRD X ,DZERO,DZERO IF(.NOT.BPRNT0)WRITE(MWU)NFK(IT),I,MWI,MZERO,MZERO,MZERO,SUMRD X ,DZERO,DZERO ENDIF C C 732 CONTINUE !END LOOP OVER UPPER LEVELS C C c determine usage of Born integrals c c if(bborn)then c nh=ngroup/2 c icount=0 c icountb=0 c do i=1,mb4(0) c if(bl(i,nh).ne.dzero)then c nc=indl(i) c j=mb4(nc) c k=mb3(nc) c if(mod(ngroup,2).eq.mod((ql(j)+ql(k))/2,2))then c icount=icount+1 c if(iflagb(i).gt.0)icountb=icountb+1 cc write(777,6999)i,indl(i),iflagb(i),icountb cc 6999 format(i7,i5,i3,i6) c endif c endif c enddo c p=icountb c if(icount.gt.0)p=100*p/icount c npp=nint(p) c write(0,*)'BORN INTEGRALS: CALC=',icount,'USED=',icountb,npp,'%' c write(6,777)icount,icountb,npp c 777 FORMAT(/'BORN INTEGRALS: CALC=',I7,' USED=',I7,I5,'%'/) c endif C C END MULTIPOLE LOOP OVER RADIATIVE TRANSITIONS C IF(MLAM.LT.MPOLE)GO TO 737 C if(btime)then call cpu_time(timef) times=timef-timei cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for diagfs:' !par cpar write(iwp,*)' radiative time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'radiative time=',nint(times),'sec' cpar endif !par endif C C WRITE AN INFINITE ENERGY OMEGA FILE C IF(MENGB.GE.-1)THEN !BBORN C WRITE(6,*)' ' WRITE(6,*)'IBOMX=',IBOMX c do j=nenerg,1,-1 if(jorig(j).gt.0)go to 645 enddo 645 jupe=j C IF(IABS(MENGB).EQ.1)THEN !INF ENG BORN, ROW *AND* COL C IF(MENGB.EQ.-1)THEN DO I=1,NOMWRT OMR(I)=MIN(OMR(I),D1P30) OMC(I)=MIN(OMC(I),D1P30) ENDDO ENDIF C K=0 DO J=1,jupe !NENERG I=JORIG(J) IF(I.GT.0)THEN K=K+1 II=NFQ(NRR(I)) IWRK3(K)=(JN(I)+1)*(1-QPI(II)) DWRK(K)=DENERG(I)*DTWO/DZ2 ENDIF ENDDO C IF(K.NE.NSPECE)THEN WRITE(6,*)'DIAGFS: ENERGY MISMATCH',K,NSPECE WRITE(0,*)'DIAGFS: ENERGY MISMATCH' GO TO 3000 ENDIF c if(nmetaj.eq.0)nmetaj=nspece !case no E1 if(nmetaj.lt.nspece)then ixr=irow(nmetaj,nspece,ione,nspece) if(ixr.lt.nomwrt)nomwrt=ixr ixc=icol(nmetaj,nspece,ione) else ixc=nomwrt endif if(nmetj0.eq.0)nmetaj=-nmetaj C WRITE(24,*)NZION,MION WRITE(24,*)NSPECE,IABS(MENGB),NOMWRT WRITE(24,*)(' 0',IWRK3(I),I=1,NSPECE) WRITE(24,711)(DWRK(I),I=1,NSPECE) WRITE(24,713)EINF,(OMR(I),I=1,NOMWRT) C IF(IDW.EQ.0)THEN !COLUMNWISE AS WELL NOMWRT=(NSPECE*(NSPECE+1-2*ione))/2 if(ixc.lt.nomwrt)nomwrt=ixc C WRITE(24,*)NZION,MION WRITE(24,*)NSPECE,IABS(MENGB),-NOMWRT WRITE(24,*)(' 0',IWRK3(I),I=1,NSPECE) WRITE(24,711)(DWRK(I),I=1,NSPECE) WRITE(24,713)EINF,(OMC(I),I=1,NOMWRT) ENDIF C ENDIF !SUM BORN MULTIPOLES C C WRITE DATA TO ADF04 FILE C BEXP=.FALSE. !TRUE=1.0E+0, FALSE=1.0+0 IF(NSPECE.LT.1000)THEN i1=0 IF(BEXP)THEN F761='(F5.2,4X,"1", 8X,20(1PE10.2))' F762='(2I4,22(1PE10.2))' ELSE F761='(F5.2,4X,"1", 6X, 20(A5, A3))' F762='(2I4, 22(A5, A3))' ENDIF ELSE i1=1 IF(BEXP)THEN F761='(F5.2,4X,"1",10X,20(1PE10.2))' F762='(2I5,22(1PE10.2))' ELSE F761='(F5.2,4X,"1", 8X, 20(A5, A3))' F762='(2I5, 22(A5, A3))' ENDIF ENDIF C C WRITE(26,542)-1 card=' ' card(4:5)='-1' orbfmt='(1x,f7.?)' is=9+2*i1 ie=is+mxorb*7 if(ie.gt.200)then write(6,*)'***sr.diagfs: card too short, need len=',ie write(0,*)'***sr.diagfs: card too short' nf=-1 go to 3000 endif do i=1,mxorb ie=is+7 if(dey(i).ne.dzero)then t=dey(i)-duy(i,i) if(bmvd)t=t+dmass(i,i)+dcd(i,i) t=-2*t endif write(orbfmt(8:8),'(i1)') x max(2,5-max(0,int(log10(max(t,d1m30))))) write(card(is:ie),orbfmt)t is=ie+1 enddo orbfmt=' ' orbfmt(1:6)='(a )' write(orbfmt(3:5),'(i3)')ie write(26,orbfmt)card(1:ie) C IF(BEXP)THEN WRITE(26,F761)DBLE(NZA),(XB(K),K=1,MXNXB) ELSE MSCP=MSC+1 OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED') WRITE(MSCP,764)(XB(K),K=1,MXNXB) BACKSPACE(MSCP) READ(MSCP,765)(XMANT(K),IEXP(K),K=1,MXNXB) WRITE(26,F761)DBLE(NZA),(XMANT(K),IEXP(K),K=1,MXNXB) ENDIF C DO M=MSC0,MSC !RE-POINT BORN MULTIPOLE FILES REWIND(M) ENDDO c if(nenerg.eq.1)go to 373 C IOLD=JJMN !1+ione JOLD=IIMN !1 if(jorig(iold).lt.0.or.jorig(jold).lt.0)then write(6,*)'Lowest two levels cannot be correlation!' write(0,*)'Lowest two levels cannot be correlation!' go to 3000 endif INEW=IOLD !FIRST 2 LEVELS CANNOT BE CORR JNEW=JOLD KTRAN=0 C 371 IF(BSCRO)THEN C BBORN=.FALSE. DO K=0,MXNXB1 OMEGAB(K)=DZERO ENDDO C IP=JORIG(IOLD) IP=NFQ(NRR(IP)) IP=QPI(IP) JP=JORIG(JOLD) JP=NFQ(NRR(JP)) JP=QPI(JP) IF(IP.NE.JP)THEN MMN=MSC0+1 !ODD MULTIPOLES MMX=MSC+MOD(MSC,2)-1 ELSE MMN=MSC0 MMX=MSC-MOD(MSC,2) ENDIF C IFLAGO=999 DO M=MMN,MMX,2 READ(M,END=370,ERR=370)I,J,(XS(K),K=0,MXNXB1) IF(I.GT.IOLD.OR.J.GT.JOLD)THEN BACKSPACE(M) GO TO 370 ELSE if(jold.gt.iimx)then if(nmetj0.eq.0)then go to 370 !unfortunate interchange of i,j use else stop '370' endif endif BBORN=.TRUE. KMX=MXNXB1 IF(IP.NE.JP)THEN LAM=MOD(M,80) IF(LAM.EQ.1.AND.ABS(XS(MXNXB1)).GT.TOLO)IFLAGO=1 !E1 LIM IF(LAM.GT.IFLAGO)KMX=MXNXB !DON'T OVERWRITE E1 LIMIT ENDIF DO K=0,KMX OMEGAB(K)=OMEGAB(K)+XS(K) ENDDO ENDIF 370 ENDDO C ELSE KTRAN=KTRAN+1 DO K=0,MXNXB1 OMEGAB(K)=dble(OMEGA(K,KTRAN)) ENDDO ENDIF C IF(BBORN)THEN DO K=0,MXNXB OMEGAB(K)=ABS(OMEGAB(K)) IF(OMEGAB(K).LT.D1M99)OMEGAB(K)=DZERO ENDDO IF(OMEGAB(0).LT.D1M30)OMEGAB(0)=D1M30 IF(OMEGAB(MXNXB1).GT.D1P30)OMEGAB(MXNXB1)=D1P30 IF(BEXP)THEN WRITE(26,F762)INEW,JNEW,(OMEGAB(K),K=0,MXNXB1) !IOLD,JOLD ELSE BACKSPACE(MSCP) WRITE(MSCP,764)(OMEGAB(K),K=0,MXNXB1) BACKSPACE(MSCP) READ(MSCP,765)(XMANT(K),IEXP(K),K=0,MXNXB1) WRITE(26,F762)INEW,JNEW !IOLD,JOLD X ,(XMANT(K),IEXP(K),K=0,MXNXB1) ENDIF ENDIF C 373 JOLD=JOLD+1 IF(JOLD.Gt.IOLD-ione.or.JOLD.GT.IIMX.and.nmetj0.ne.0)THEN 372 IOLD=IOLD+1 IF(IOLD.GT.jupe)THEN !NENERG !TERMINATE WRITE(26,F762)-1 WRITE(26,F762)-1,-1 if(.not.badas)then !adas skip comments WRITE(26,758) NREC=1 121 NREC=NREC+1 BACKSPACE(5) BACKSPACE(5) READ(5,766)CARD4 IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 121 REWIND(5) DO N=1,NREC READ(5,760)CARD WRITE(26,759)CARD ENDDO DO I=1,8 DATE(I)=' ' ENDDO CALL DATE_AND_TIME(DATE8) !F95 WRITE(26,763)DATE(7),DATE(8),DATE(5),DATE(6),DATE(3) X ,DATE(4) endif DO M=MSC0,MSC CLOSE(M) ENDDO IF(.NOT.BEXP)CLOSE(MSCP) ELSE IF(JORIG(IOLD).LT.0)GO TO 372 JOLD=IIMN !1 JNEW=IIMN !1 INEW=INEW+1 GO TO 371 ENDIF ELSE IF(JORIG(JOLD).LT.0)GO TO 373 JNEW=JNEW+1 GO TO 371 ENDIF ENDIF C C CHECK TO SEE IF SIZE OF ARRAYS MADD AND AP HAS BEEN EXCEEDED C IF(NTRAN.NE.0.AND..NOT.BDR.AND.MOD(IABS(MPNCH),4)/2.EQ.1)THEN IF(NTRAN.LT.MXNOR)THEN MADD(MXNOR)=NTRAN ELSE WRITE(6,3449)NTRAN WRITE(0,*)'***SR.DIAGFS: CASCADE DIMENSION MXNOR EXCEEDED' GO TO 3000 ENDIF ENDIF C C DE-ALLOCATE C 7450 CONTINUE C !F95 IF(BOMRC)THEN !F95 DEALLOCATE (OMR,OMC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR OMR,OMC' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BOMRC=.FALSE. !F95 ENDIF !F95 C !F95 IF(ALLOCATED(IDY))THEN !F95 DEALLOCATE (IDY,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR IDY' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(ALLOCATED(OMEGA))THEN !F95 DEALLOCATE (OMEGA,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR OMEGA' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(.NOT.BFOTJ.AND.ALLOCATED(DVECF))THEN !F95 DEALLOCATE (DVECF,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR DVECF' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BPOS)THEN !F95 DEALLOCATE (NPOS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR NPOS' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BPOS=.FALSE. !F95 ENDIF !F95 C IF(NF.LE.0)GO TO 750 !RETURN C C UPDATE FUNCTIONAL (RE-ENTRY POINT IF NO RADIATION) C 745 DRY=DFFS IF(IOPTIM.EQ.0)DRY=DRY+DECORE DRY=DRY*DTWO IF(BPRNT0)WRITE(6,999)INCLUD,DRY,JPRINT !.AND.INCLUD.NE.0 C C FINISH-UP C 750 NL=NL0 !RESTORE C IF(BTFU)THEN !F95 DEALLOCATE (TFU,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGFS: DE-ALLOCATION FAILS FOR TFU' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BTFU=.FALSE. !F95 ENDIF !F95 C C WRITE TERMINATORS C IF(.NOT.BMODE)THEN IF(BPRNT0)WRITE(MW,513)MBLK IF(.NOT.BPRNT0)WRITE(MWU)MZERO,MZERO,MZERO,MZERO X ,MZERO,MZERO,DZERO,DZERO,DZERO ENDIF IF(.NOT.BFOTJ)THEN IF(BPRNT0)WRITE(MWW,513)MBLK IF(.NOT.BPRNT0)WRITE(MWWU)MZERO,MZERO,MZERO,MZERO,MZERO,MZERO X ,DZERO,DZERO,DZERO ENDIF C C CLOSE SOME FILES C IF(IUNIT(22).GT.0)THEN CLOSE(22) IUNIT(22)=-1 ENDIF IF(IUNIT(24).GT.0)THEN CLOSE(24) IUNIT(24)=-1 ENDIF IF(IUNIT(26).GT.0)THEN CLOSE(26) IUNIT(26)=-1 ENDIF C C RETURN C C 2000 IF(NF.GT.0)NF=-1 GO TO 7600 !DE-ALLOCATE C 3000 IF(NF.GT.0)NF=-1 GO TO 7450 !DE-ALLOCATE C C DIMENSION EXCEEDED, ABORT. C 106 WRITE(6,108)MC,MAXJU WRITE(0,*)'SR.DIAGFS: DIMENSION EXCEEDED' GO TO 2000 190 WRITE(6,980)MAXDK,NCJ,MAXJU,MLAM WRITE(0,*)'SR.DIAGFS: DIMENSION EXCEEDED' GO TO 2000 C C*********************************************************************** C 108 FORMAT(/' SR.DIAGFS WILL NOT COMPUTE RADIATIVE TRANSITION' X,' PROBABILITIES BECAUSE IT REQUIRES',I9,'.GT.MAXJU=',I9 X,' FOR ARRAY TFU') 110 FORMAT(// ' *****WARNING*****--- IF SR. DIAGFS HAS PUNCHED TERM' X,' COUPLING COEFFICIENTS, THE SET WILL BE INCOMPLETE'/ ' BECAUSE' X,' NOT ENOUGH STORAGE WAS ALLOWED FOR STORING TRANSFORMATION' X,' COEFFICIENTS IN DIAGON : INCREASE MAXUC') 180 FORMAT(//5X,'ZETA( A B ) = SPIN-ORBIT PARAMETERS') 181 FORMAT(I5,4X,2I5,8X,E14.7) 182 FORMAT(I4,I4,4I3,1X,F14.5,F14.6,2I3,1X, 9F8.4/(56X, 9F8.4)) 183 FORMAT('2J P',2X,' S L',3X,'CF',3X,'NI',7X,'ENERGY(RYD)') 200 FORMAT(/ ' ONE-BODY RELATIVISTIC INTEGRALS'/ ' I(R) I( A, C )' X,' = ',6X,'MASS',9X,'DARWIN',24X,'') 201 FORMAT(I5,3X,2I4,3X,2F14.7,16X,F14.7) 301 FORMAT(22X,'2MXLBD=',I3) 3449 FORMAT(/5X,10('*'), ' IF YOU REQUIRE CASCADE COEFFICIENTS AUGMENT' X,' MXNOR TO A VALUE GREATER THAN',I6) 400 FORMAT(// ' LV T 2J 2S+1L P',6X, 'H(ZZ)/2RY EIGEN-HBP/2RY CF XNO',9X,'TF-MATRIX AND HZ/2RY-TRIANGLE E(CORE)/2RY=',F10.5 X,F11.4) 501 FORMAT( 6I5,1PE15.5 ,2(0PF15.6)) 502 FORMAT(1X,12X,I4,2I4,1PE15.3, 2(0PF15.4)) 503 FORMAT(60X,F15.6) 504 FORMAT(4X,'NA',10X,'W',2X,'LV',1X,'LVP',8X,'AA*SEC',6X, X'ECONT(A.U)',7X,'E-I(A.U)') 505 FORMAT(8X,'I-S',12X,'C-S',11X,'AUTO-IONIZATION DATA',7X,'Z=',I2, X3X,'N=',I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',4X,'W',6X, X'AA*SEC',9X,'E-C(RYD)',6X,'E-I(RYD)') 506 FORMAT(5I5,4X,'X',1PE15.5,2(0PF15.6)) 507 FORMAT(I3,'CFIC',2X,'G',3X,'Z=',I2,4X,'N=',I2,2X,'NL',62(I3,I2)) 508 FORMAT(8X,'I-S',12X,'G-S',15X,'RADIATIVE DATA',9X,'Z=',I2,3X,'N=' X,I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',4X,'W',6X,'AR*SEC', 9X, X'DEL(RYD)',6X,'E-G(RYD)') 509 FORMAT('+',67X, '(AA DATA INCLUDES TERM/LEVEL ENERGY CORRECTION)') 510 FORMAT(3X,'NLEVEL=',I5,39X,'E1/RY=',F15.6/4X,'K',3X,'LV',4X,'T', X' 2S+1',4X,'L',3X,'2J',3X,'CF',5X,'(EK-E1)/RY') 511 FORMAT(7I5,F15.6) 513 FORMAT(A2) 514 FORMAT(I3,' E(RYD) ',2X,'Z=',I2,4X,'N=',I2,5X, 'Intermediate-' X,'Coupling',1X,'EIONMIN=',F15.6) 515 FORMAT(5(1PE15.5)) 516 FORMAT(8X,'I-S',12X,'C-S',10X,'PHOTO-IONIZATION DATA',7X,'Z=',I2, X3X,'N=',I2/3X,'CF',3X,'LV',4X,'W',3X,'CF',3X,'LV',3X,'EO',6X, X' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)') 517 FORMAT(2I5,4X,I1,I2,1X,10(I2,A1)) 536 FORMAT('*** SR.DIAGFS: INCREASE INTERNAL DIMENSION MXSTRG TO',I3) 537 FORMAT(' &ADASEX NLEVS= XXX',' &END') !,I4 540 FORMAT('NAME:'/'DATE:'/'.') 541 FORMAT(A2,'+',I2,2I10,F15.4,A4) 600 FORMAT(/7X,'E',I1,'-DATA',3X,'K KP',11X,'A(EK)*SEC' X,11X,'S',15X,'G*F',10X,'F(ABS) -F(EMI)',4X,'WAVEL/AE', X 6X,'GF(VEL)',6X,'ALPHA(POL)') 640 FORMAT(' RESTARTED FROM K=',I5,3X,'LV=',I5) 650 FORMAT(/4X,'E',I1,'/M',I1,'-DATA',3X,'K KP',11X,'A(EK)*SEC' X,6X,'A(MK)*SEC',A4,7X,'SE',11X,'SM',11X,'SM0' X,12X,'G*F',6X,'WAVEL/AE',4X,'OMG(BORN)') 660 FORMAT(/7X,'E',I1,'-DATA',3X,'K KP',11X,'A(EK)*SEC',11X,'S' X,15X,'G*F',3X,'10**',I1,'* ','F(ABS) -F(EMI)',4X,'WAVEL/AE', X 6X,'GF(VEL)',7X,'OMG(BORN)') 709 FORMAT(I9,A4,I5,I4,5X,1PE15.3,5X,0PF10.6,3X,1PE15.3,3X X,2(0PF10.5),2X,F11.4,3X,1PE10.2,3X,E12.3) 710 FORMAT(I9,A4,I5,I4,5X,2(1PE15.3),4X,3E13.3,E15.3,0PF11.2,1PE13.3) 711 FORMAT(1P,5E16.6) 713 FORMAT(1PE14.8,6E11.3/(14X,6E11.3)) 7393 FORMAT(/ ' *****WARNING***** IF SR.DIAGFS HAS PUNCHED TERM ' X,'COUPLING COEFFICIENTS THE SET WILL BE INCOMPLETE,'/20X, X 'BECAUSE MAXTR.GE.',I9,' IS REQUIRED') 7395 FORMAT( ' NO TERM-COUPLING COEFFICIENTS CALCULATED BECAUSE OF ' X,'INCORRECT CHOICE OF MOD : CHOOSE MOD =0 OR -1') 742 FORMAT(43X,'....',9X,I3,I5,12X, 'HEADING CARD FOR TERM COUPLING ' X,'COEFFICIENTS'/(43X,'...',5(2I3,F9.6))) 743 FORMAT(5X,2I5,5X,"TCC'S BASED ON FANO-AS"," Z =",I3,", N =",I3) 744 FORMAT(5X,2I5,5X,"TCC'S BASED ON C&S -AS"," Z =",I3,", N =",I3) 751 FORMAT(3I7,F16.7,I15,I7) 752 FORMAT(/' RECOUPLING MATRIX: ROWS ARE J LEVELS, COLUMNS ARE', X' LS TERMS'//' LEVEL # LS TERM #S/COEFFICIENTS') 753 FORMAT(5(I3,I2,F9.6)) 754 FORMAT(1P,(4(2I4,E12.4E1))) 755 FORMAT(/'*** TCC WARNING: HIGHEST SPECTROSCOPIC TERM BELOW' X,' ALL CORRELATION IS AT ',I5,' BUT THERE ARE',I5,' OTHERS HIGHER' X) 756 FORMAT(2I5,4(I5,F18.14),(5X,4(I5,F18.14))) 757 FORMAT(/I5,' J LEVELS',I5//' LEVEL 2J PI ENERGY(RYD)' X,' ORIG. LEVEL # TERM #') 758 FORMAT('C',79('-')/'C'/'C') 759 FORMAT('C ',A200) 760 FORMAT(A200) 763 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X X ,'AUTOSTRUCTURE PLANE-WAVE BORN'/ X 'C'/'C NAME:'/'C DATE: ',2(A1),'/',2(A1),'/',2(A1)/ X 'C'/'C',79('-')) 764 FORMAT(22(1PE9.2)) 765 FORMAT(22(A5,1X,A3)) 766 FORMAT(A4) 891 FORMAT(/' GAM ONE-BODY MASS-VELOCITY INTEGRALS') 892 FORMAT(/' GAM ONE-BODY DARWIN INTEGRALS') 893 FORMAT(/' GAM ONE-BODY INTEGRALS') 895 FORMAT(1X,I3,9F14.7/(4X,9F14.7)) 896 FORMAT('*****STORAGE EXCEEDED IN SR.DIAGFS, INCREASE MXAAK TO',I9) 897 FORMAT(1X,I5) 898 FORMAT(' ',I9,' USED, MXAAK=',I9) 899 FORMAT(7X,3I5,F14.6,3X,2F12.6,F13.7,20X,F12.6) 900 FORMAT(//9X, 'ONE-BODY RELATIVISTIC CORRECTIONS TO INDIVIDUAL ORB XITALS IN UNITS OF 2*RY',35X,'IC.JPRINT =',I4/9X, 'GAM N L X E(NON.REL)',8X,'E(MASS)',6X,'E(DAR)',7X,'E(TOT)',23X,'') 901 FORMAT( ' PLUS CORE CONTRIBUTION',F13.4,2X,F12.5,9X,'RELATIVISTIC' X,' CORE CONTRIBUTION ALONE' ,F13.4) 936 FORMAT(' ******WARNING LS SELECTION RULES APPLIED TO TRANSITION' X,' LEVELS IN SR.DIAGFS'/) 980 FORMAT(/' SR.DIAGFS: IF MAXDK=',I5,'.LT.',I5,' INCREASE' X,' MAXDK'/' ********* IF MAXJU=',I9,'.LT.',I9 X,' INCREASE MAXJU') 989 FORMAT(//'*** ATTN: BECAUSE BORN MULTIPOLES ARE BEING COMPUTED' X,' FOR NON-E1 TRANSITIONS, RADIATIVE DATA IS NOT COMPUTED FOR', X' THOSE E3/M2 ETC TRANSITIONS'/10X,'FOR WHICH E1 DATA ALREADY' X,' EXISTS (SO AS NOT TO OVERWRITE THE E1-LIMIT)'/) 990 FORMAT(I11,2I10,F13.0,I7,3I5,A4,I2,F13.8,27X,F15.8,2X,F15.8) 991 FORMAT( /' LIST OF TERMS WITH A WEIGHTED MEAN OVER THE FINE ', X'STRUCTURE' /9X,'I',8X,' T',8X,'K*CM',2X, '2S+1 L CF',5X, X'WEIGHTS',8X, '(EI-E1)/RY E1/RY =',F13.6,3X,A10,I5,1X,A8) 992 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4) 993 FORMAT(/' *** WORKING ARRAYS TOO SMALL IN SR.DIAGFS, INCREASE', X' MXAAK TO:',I9/' *** OR REDUCE NUMBER OF SPECTROSCOPIC TERMS') 994 FORMAT(96X,I5,F10.0,F11.6) 995 FORMAT(2I10,F13.0,I5,I2,I5,A4,F8.3,F18.6,24X,2F14.6) 996 FORMAT(//9X,' K',8X,'LV',8X,' T',8X,'K*CM',5X,'2*S+1 L 2J CF' X,4X,A2,3X,'(EK-E1)/RY E1/RY =',F15.8,5X,A10,I5,4X,A8) 997 FORMAT(I11,2I10,F13.0,I7,3I5,A4,F15.8,27X,F15.8,2X,F15.8) 998 FORMAT(' ',98X,'LEVEL ENERGY CORRECTION') 999 FORMAT(//9X,'INCLUD =',I5,9X, 'FUNCTIONAL F =',1PE14.7 X ,9X, 'IC.JPRINT=',I2//) 1605 FORMAT('*** SR.DIAGFS: COULD ACCESS MEMORY FASTER IF MXD30=',I7) 3005 FORMAT (/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,' GAM N L', +3X,'VACUUM POLARIZ.',6X,'SELF ENERGY',9X,'TOTAL') 3010 FORMAT (8X,3I5,3(2X,F15.7),2F10.5) C END C C ******************* C SUBROUTINE DIAGON(DECORE,DF,TFU,IAXUC) C C----------------------------------------------------------------------- C C N.R. BADNELL D.A.M.T.P. CAMBRIDGE C C SR.DIAGON CALCULATES TERM ENERGIES AND DATA FOR ELECTRIC RADIATIVE C TRANSITIONS. C ALSO CALCULATES AUTOIONIZATION RATES AND PHOTOIONIZATION CROSS C SECTIONS - SEE ALSO NOTES IN SR.RADCON. C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_NRBEKP, ONLY: NED !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 USE COMMON_NRBRN2, ONLY: BINDB,MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXLIT=62) PARAMETER (MXSTRG=32) !MAX STRING WRITE PARAMETER (MSTRGH=16) !SHORT STRING WRITE PARAMETER (MXLABL=19) !0:MXLABL C CF77 PARAMETER (MXD1=MAXDI/MAXDK, !F77 CF77 X MXD2=MAXDK/MAXDI, !F77 CF77 X MXD3=MXD1+MXD2, !F77 CF77 X MXD4=MAXDI*MXD1/MXD3+MAXDK*MXD2/MXD3+1, !F77 CF77 X MXBUF=MXD4*MXD4) !F77 C CF77 PARAMETER (MXXDQ=2*MXST0+MXEST) !F77 CF77 PARAMETER (MXD0=MXD4*MXD4, !F77 CF77 X MXD9=MXXDQ/MXD0, !F77 CF77 X MXD10=MXD0/MXXDQ, !F77 CF77 X MXD11=MXD9+MXD10, !F77 CF77 X MXQBUF=MXXDQ*MXD9/MXD11+MXD0*MXD10/MXD11+1) !F77 C CF77 PARAMETER (ISXDI=MAXDI) !F77 CF77 PARAMETER (IAXDI=MAXDI) !F77 CF77 PARAMETER (IXAAI=MXAAI) !F77 C PARAMETER (MXD01=14) PARAMETER (MXD09=MXBLM+2) !+2 CASE BREL PARAMETER (MXD12=100) PARAMETER (MXD14=100) PARAMETER (MXD24=2*MAXGR) PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) CF77 PARAMETER (MXD30=MAXDI*MAXDI) !MAX FOR !F77 PARAMETER (MXD33=(MXGRB*(MXGRB+1))/2) PARAMETER (MXD34=((MXD33+1)*MXD33)/2) CF77 PARAMETER (MXD35=MXENG*(MXAAI/2)) !F77 CF77 PARAMETER (MXD36=1+MXAAI/2) !F77 PARAMETER (MXD37=MXBLM/2) PARAMETER (MXD39=MXGRB/MAXGR) !=0 (FINITE E) OR 1 (INF. E ONLY) CF77 PARAMETER (MXD40=(MAXDI*(MAXDI+1))/2) !F77 CF77 PARAMETER (MXD41=1) !=MXD35 FOR .NOT.BSCO !F77 C !BORN MOM. TRANSFER (K) INFO PARAMETER (NLAGB=4) !PT LAG, EVEN, CORRELATE WITH NPDEC PARAMETER (NPDEC=4) !NO. OF K-STEPS PER DECADE PARAMETER (IVV0=3) !STARTING AT 10**-IVV0 PARAMETER (NDEC=IVV0+2) !NO. OF DECADES (ALLOW K-SHELL) C PARAMETER (MXNXV=NDEC*NPDEC+3) !NO. OF K_MAX (INC ZERO & INF) PARAMETER (MXD21=IVV0*NPDEC-NPDEC/4+3) !NO. OF K_MIN: UP TO 1.0 PARAMETER (MXD38=(1-MXD39)*((MXNXV*(MXNXV-1))/2 X -((MXNXV-MXD21)*(MXNXV-1-MXD21))/2)+MXD39) C PARAMETER (MXNXB=10) !NO. OF BPW X-VALUES (THRESH. UNITS) PARAMETER (MXNXB1=MXNXB+1) C CF77 PARAMETER (NOMWRX=MXD35) !F77 CF77 PARAMETER (NOMWRY=MXD41) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D0PT9=0.9D0) PARAMETER (D1PT1=1.1D0) COLD PARAMETER (D1PT5=1.5D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (DTEN=1.0D1) PARAMETER (D1P8=1.0D8) PARAMETER (D1P20=1.0D20) PARAMETER (D1P30=1.0D30) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M4=1.0D-4) PARAMETER (D1M5=1.0D-5) PARAMETER (D1M7=1.0D-7) PARAMETER (D1M9=1.0D-9) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M20=1.0D-20) PARAMETER (D1M30=1.0D-30) PARAMETER (D1M99=1.0D-99) PARAMETER (DKON=1.653656D17) PARAMETER (DKCM=109737.31D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (HBAR=4.8377687D-17) PARAMETER (C1=DFSC**3/HBAR) PARAMETER (C2=2.567895D-18) !4*pi*a_0**2*alpha PARAMETER (C3=C2/DTHREE) PARAMETER (C4=DFSC**2/DFOUR) PARAMETER (MZERO=0) PARAMETER (EINF=1.0D6) C PARAMETER (MW=7) !INITIALIZE UNIT NOS PARAMETER (MWW=MW+10) PARAMETER (MWU=MW+20) PARAMETER (MWWU=MWU+2) c integer*8 n8 CF77 integer*8 nrk !F77 C CHARACTER(LEN=1) BIGL,NUMB,STRING,DATE,CLIT,CMBLK1 COLD X,SMAL CHAR X,LIT,MBLK1 !USE OF CHAR REQUIRES CHANGES TO PP'S FOR UNFORM I/O CHARACTER(LEN=2) CELMNT,ELEM CHARACTER(LEN=3) IEXP CHARACTER(LEN=4) MB,MCOR,MBLK,CODE,MYRGE,LAB4,CARD4,MOUT CHARACTER(LEN=5) XMANT CHARACTER(LEN=8) DATE8 !F95 character(len=9) orbfmt CHARACTER(LEN=24) MOBS character(len=31) ceiss,cstan CHARACTER(LEN=17) F762 CHARACTER(LEN=29) F761 character(len=51) f542,f543 CHARACTER(LEN=200) CARD C LOGICAL BPRINT,BINT,BAUX,BRADAT,BLAG,BSTO,BORT,BFOT,BPRNT0,BPRNTO X ,BJUMP,BJUMP2,BDR,BRAD,BBC1,BBC2,BREL,BJUMPR,BDEL,BFOTJ X ,BFANO,BMVD,BBORN,BING,BFAST,BEQGRP,BPOS,BKUTOO,BREL2,BECOR X ,BCONT,BTFU,BANAL,CPRINT,BEXP,BSCRO,btime,btimex,badas X ,BALLH,BALLA,BOMRC !F95 CF77 X ,BFALL,BINDB !F77 COLD X,BNJO,bcorr C CF77 DIMENSION DU(MAXDI,MAXDI),DE(MAXDI),IDY(MAXDI) !F77 CF77 X ,DVU(MAXDI),NVEC(MAXDI),DVI(MXENG,MAXDI),DVP(MXD40) !F77 CF77 X ,DUI(MXENG,MXAAI),NPOS(4,MXD30),OMR(MXD35),OMC(MXD35)!F77 CF77 X ,OMEGA(0:MXNXB1,MXD41),DVECF(MXENG,MAXTM) !F77 C ALLOCATABLE :: DU(:,:),NPOS(:,:),DUI(:,:),DVI(:,:) !F95 X ,DVP(:),OMR(:),OMC(:),OMEGA(:,:) !F95 X ,DE(:),IDY(:),DVU(:),NVEC(:) !F95 X ,DVECF(:,:) !F95 C CF77 DIMENSION TFU(IAXUC) !F77 DIMENSION TFU(iabs(iaxuc)) !F95 C DIMENSION X LMX(MAXCF),QSB(10,MAXCF),QLB(10,MAXCF) X ,IHARRY(MAXCF),NCFBIG(MAXCF,2),E1BCF(MAXCF) X ,ITMP(MXD24) X ,DENERG(MAXTM),IWRK2(MAXTM),ID(MAXTM),IORIG(MAXTM) X ,DVECL(MAXTM),DVECV(MAXTM),DVECA(MAXTM) X ,DDY(MXENG) X ,NX1(MXEL0),LX1(MXEL0) X ,XB0(MXNXB) DIMENSION BIGL(0:MXLABL),NUMB(0:MXLABL) X ,STRING(MXSTRG),DATE(8),CLIT(MXLIT),LIT(MXLIT) COLD X ,SMAL(0:MXLABL) C COMMON /BASIC/NF,MGAP(11) COMMON /CACC/ACC(MAXGR,MAXGR) COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,IEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCL0,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /MQVC/MDUM,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /NXRL/IRK,IRK0,IOS,IOS0 COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /TRANS/DRL(MAXRL),DOSC(0:MXD09,MAXGR,MAXGR) X ,NADRU(MAXTM),NAI(MAXTM),NC0,JORIG(MAXTM) COMMON /WEIGHT/WGHT(MAXTM),INDEXW(MAXTM) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA0,MB0,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE CF77 COMMON /NRBALQ/QBUFF(MXQBUF) !F77 CF77 COMMON /NRBBUF/DBUF1(MXBUF),DBUF2(MXBUF) !F77 COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ESKPL,ESKPH,BECOR COMMON /NRBDEL/TOLB,TOLE,DELELS(MAXTM,2),DELEIC(MAXLV,2),MDELE X ,MULTS,ISHFTLS,ISHFTIC,NOBS COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) CF77 COMMON /NRBEKP/NED(2,MAXSL,MAXTM) !F77 COMMON /NRBFAN/BFANO COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLIM/ECNTRA,JTANAL,BANAL(MAXCF) !ALGEBRAIC COMMON /NRBMIX/CMXLSA,CMXLSR,CMXICA,CMXICR COMMON /NRBNFI/DZLI(MXENG,MXFOO),DXTWOI(MXENG,MXFOO) X ,DETAI(MXENG,MXFOO),FRI(MAXB1),GRI(MAXB1) CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBORN/BL(MXD38,MXD34,0:MXD37),OBO(MXD38),TM2(MXD34) COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED COMMON /NRBRN1/SBL(MXD33),DBL(MXD33,MXBIF),DG(0:MXBLM) X ,MB3(0:MXD33),MB4(0:MXD33),INDX(MXD28) X ,INDK(MXD34),INDL(MXD34) c x,iflagb(mxd34) CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBRN3/V0(MXNXV),V1(MXNXV),XB(MXNXB),XS(0:MXNXB1) X ,DB0(MXNXV),DB1(MXNXV),OMEGAB(0:MXNXB1) X ,MV0,MV1,XMANT(0:MXNXB1),IEXP(0:MXNXB1),MINFB c COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBRNG/DSTRNG(6,MAXGR) COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBTAR/ETAR(MAXTM),ISTAR(MAXTM),LTAR(MAXTM),JTAR(MAXTM) X ,NTAR,IGAPE COMMON /NRBTCC/KTCC,MTCC,NTCC,NENERG COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD COMMON /NRBWGT/EIMXLS,EIMXIC,WLG1,WLG2,IWGHT,IOPTIM,NRSLMX X ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN COMMON /PJSLIM/ECNTRB,ITANAL COMMON /WORKLS/DWRK(MAXTM),IWRK3(MAXTM),IWRK4(MAXTM) common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) common /hps/badas C CF77 EQUIVALENCE (DUI(1,1),OMR(1)),(DUI(1,MXD36),OMC(1)) !F77 CF77 X,(DU(1,1),DBUF1(1)),(DVP(1),DBUF2(1)) !F77 CF77 X,(NPOS(1,1),DBUF1(1)) !F77 COLD X,(IDY(1),DP(1)),(DE(1),DPA(1),IORIG(1)),(IHARRY(1),IHAR(1)) C EQUIVALENCE (DATE(1),DATE8) !F95 C DATA CMBLK1/' '/,MBLK/' '/,MCOR/' COR'/,MOUT/' X '/ C DATA CLIT( 1),CLIT( 2),CLIT( 3),CLIT( 4) /'1','2','3','4'/, X CLIT( 5),CLIT( 6),CLIT( 7),CLIT( 8) /'5','6','7','8'/, X CLIT( 9),CLIT(10),CLIT(11),CLIT(12) /'9','A','B','C'/, X CLIT(13),CLIT(14),CLIT(15),CLIT(16) /'D','E','F','G'/, X CLIT(17),CLIT(18),CLIT(19),CLIT(20) /'H','I','J','K'/, X CLIT(21),CLIT(22),CLIT(23),CLIT(24) /'L','M','N','O'/, X CLIT(25),CLIT(26),CLIT(27),CLIT(28) /'P','Q','R','S'/, X CLIT(29),CLIT(30),CLIT(31),CLIT(32) /'T','U','V','W'/, X CLIT(33),CLIT(34),CLIT(35),CLIT(36) /'X','Y','Z','a'/, X CLIT(37),CLIT(38),CLIT(39),CLIT(40) /'b','c','d','e'/, X CLIT(41),CLIT(42),CLIT(43),CLIT(44) /'f','g','h','i'/, X CLIT(45),CLIT(46),CLIT(47),CLIT(48) /'j','k','l','m'/, X CLIT(49),CLIT(50),CLIT(51),CLIT(52) /'n','o','p','q'/, X CLIT(53),CLIT(54),CLIT(55),CLIT(56) /'r','s','t','u'/, X CLIT(57),CLIT(58),CLIT(59),CLIT(60) /'v','w','x','y'/, X CLIT(61),CLIT(62) /'z','*'/ COLD DATA (SMAL(I),I=0,MXLABL)/'s','p','d','f','g','h','i','k','l' COLD X ,'m','n','o','p','q','r','s','t','u','v','*'/ DATA (BIGL(I),I=0,MXLABL)/'S','P','D','F','G','H','I','K','L','M' X ,'N','O','P','Q','R','S','T','U','V','*'/ DATA (NUMB(I),I=0,MXLABL)/'0','1','2','3','4','5','6','7','8','9' X ,'A','B','C','D','E','F','G','H','I','*'/ C DATA (XB0(I),I=1,MXNXB)/1.001D0,1.1D0,1.2D0,1.3D0,1.55D0,2.D0 C X ,3.D0,5.5D0,1.D1,2.D1,3.D1,5.5D1,1.D2,2.D2,3.D2,5.5D2,1.D3/ C !17-vals DATA (XB0(I),I=1,MXNXB)/1.1D0,1.2D0,1.55D0,2.D0,3.D0,5.5D0,1.D1 X ,2.D1,5.5D1,1.D2/ C !10-vals C IROW(ILI,ILF,IONE,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE))/2 ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C C C FIX FOR FORTRAN 90 COMPILERS THAT DON'T ALLOW ASSIGNMENT OF CHARACTERS C TO INTEGER VARIABLES, REQUIRED FOR HISTORIC BACKWARDS COMPATIBILITY C OPEN(80,STATUS='SCRATCH',FORM='FORMATTED') WRITE(80,1111)CMBLK1,(CLIT(I),I=1,MXLIT) 1111 FORMAT(80A1) BACKSPACE(80) READ(80,1111)MBLK1,(LIT(I),I=1,MXLIT) CLOSE(80) c if(btime)then timeh=dzero timea=dzero endif C C INITIALIZE LOGICALS ETC C BCONT=MODE.EQ.2.OR.MODE.EQ.3 !FOR BOUND-CONTINUUM BPRNT0=BPRINT IF(BPRINT)BPRNT0=JPRINT.NE.-3 BREL2=IABS(IREL).EQ.2 BDR=IDR.NE.0 BBORN=MENGB.GE.0 IF(BBORN)THEN DO I=1,MXNXB XB(I)=XB0(I) ENDDO ENDIF COLD BNJO=NJO.LE.0.AND.ISHFTLS.EQ.1 !ALLOWED PRIOR SHIFT IF TECS BFOTJ=.NOT.BFOT.OR..NOT.BLAG IF(.NOT.BFOTJ.AND.PMIN.GT.DZERO)IPIG=1 BORT=MORT.LT.0 BKUTOO=KUTOO.NE.0 M=NPRNT0 NPRINT=MOD(M,5) nmeta0=nmeta COLD MRP=MR+1 !UNIT NO OF TFU FILE C C DETERMINE DIMENSIONS REQUIRED TO ALLOCATE !F95 C (SEE ALGEB2 SET-UP.) !F95 C !F95 ISXDI=1 !F95 IAXDI=1 !F95 IXAAI=0 !F95 NCI=0 !F95 C !F95 DO NN=1,NSL0 !F95 C !F95 NC=NSL(NN) !F95 IAXDI=MAX(IAXDI,NC) !F95 C !F95 N0=0 !F95 NCC=0 !F95 C !F95 do i=1,mxorb !F95 ncc0(i)=0 !F95 enddo !F95 mx0=mxorb+1 !F95 C !F95 DO J=1,NC !F95 I=NCI+J !F95 K=IABS(NFK(I)) !F95 II=QCG(NF,K) !F95 ii=ieq(ii) !F95 IF(IYY(II).GT.0)then !F95 NCC=NCC+1 !F95 ncc0(ii)=ncc0(ii)+1 !F95 mx0=min(mx0,ii) !F95 else !F95 N0=N0+1 !F95 endif !F95 ENDDO !F95 C !F95 if(mode.eq.2)then !F95 isxdi=max(isxdi,n0) !F95 do i=mxorb,mx0,-1 !F95 n=ncc0(i) !F95 isxdi=max(isxdi,n) !F95 enddo !F95 c !F95 else !need full block !F95 if(mode.eq.4)then !bound only !F95 ncc=0 !F95 endif !F95 isxdi=iaxdi !F95 endif !F95 C !F95 IXAAI=MAX(IXAAI,NCC*(NC-NCC)) !F95 NCI=NCI+NC !F95 ENDDO !F95 c write(0,*)ixaai !F95 c write(0,*)isxdi,iaxdi !F95 C !F95 BALLH=.FALSE. !F95 BALLA=.FALSE. !F95 C !F95 ALLOCATE(DU(ISXDI,ISXDI) !F95 X ,DVU(IAXDI),DE(IAXDI),IDY(IAXDI),NVEC(IAXDI) !F95 X ,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR DU,DVU,DE,IDY,NVEC' !F95 NF=0 !F95 GO TO 750 !F95 ENDIF !F95 BALLH=.TRUE. !F95 IF(BPRNT0)THEN !F95 IM=(IAXDI*(IAXDI+1))/2 !F95 ALLOCATE(DVP(IM),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR DVP' !F95 NF=0 !F95 GO TO 7600 !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(MENG*IXAAI.GT.0)THEN !F95 ALLOCATE(DUI(MENG,IXAAI),DVI(MENG,IAXDI),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR DUI,DVI' !F95 NF=0 !F95 GO TO 7600 !F95 ENDIF !F95 BALLA=.TRUE. !F95 ENDIF !F95 C C INITIALIZE GEOMETRIC COEFFICIENTS FOR MULTIPOLE RADIATION C DG(0)=DZERO IP=1 DO I=2,MPOLE,2 IP=IP*(I+1)*2 IM=I/2 DG(IM)=2*(I+1)*(IM+1) DG(IM)=DG(IM)/(IM*DBLE(IP)*DBLE(IP)) ENDDO C C SET-UP TCC'S C MTCC=0 NTCC=0 CPRINT=(MOD(MPNCH,2).NE.0.AND.MPNCH.LT.0) !PRINT TCC'S IF(CPRINT)THEN IF(KTCC.LT.0)THEN IF(IUNIT(1).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='TCC.DAT'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=1' GO TO 2000 ENDIF IUNIT(1)=1 OPEN(1,FILE='TCC.DAT',STATUS='REPLACE') !JAJOM ELSE IF(IUNIT(4).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='TCCDW.DAT'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=4' GO TO 2000 ENDIF IUNIT(4)=1 OPEN(4,FILE='TCCDW.DAT',STATUS='REPLACE') !STGICF ENDIF ENDIF C C RESET INCLUD IF IC OPTIMIZATION C INCLUD=MOD(INCL0,1000000) IF(NJO.GT.0)INCLUD=0 C C SET CHARGES ETC. C NZA=NZION-MION+1 DZA2=NZA*NZA DZA=-NZA c DZM=-NZION DZ2=NZION-MION IF(NZION.EQ.MION)DZ2=DONE DZ2=DZ2*DZ2 TSHFT=MSHFT+MSHFT C C INITIALIZE FOR NLAG-POINT LAGRANGE INTERPOLATION FORMULA FOR C BOUND-CONTINUUM INTEGRALS. C NLAG MUST BE AN EVEN NUMBER .GE. 4 . READ IN SRADCON. C DEFAULT: NLAG=6. C IF MENG.EQ.1 THEN NO INTERPOLATION (& NLAG NOT IUSED) C NLAG2=NLAG-2 NP1=1 NP2=MAX(1,NLAG) NPH=NP2/2 BBC1=MENG.LE.NP2 IF(BBC1)NP2=MENG DDY(1)=DONE !FOR .NOT.BLAG C C RE-SCALE ONE-BODY TERMS INVOLVING RYDBERG ORBITAL IN DR OPERATION C IF(BJUMP2)THEN DO K=1,MXORB !1/N**3 SCALING IF(DEY(K).EQ.DZERO)GO TO 115 C IF(K.LE.IABS(MPSEUD))GO TO 115 IF(IVAL(K).NE.0)THEN TM=NNEW TM=TM-SCREEN(K) TN=DZA/TM TN=TN*TN !COULOMB IF(BREL)THEN T=DTWO*TM/(QL(K)+1)-DTHREE/DFOUR TMV=T*TN*TN !M-V IF(QL(K).EQ.0)THEN !DARWIN TT=dza/TM !DZM->dza since large n TT=TT*TT TD=-TT*TT*TM ELSE TD=DZERO ENDIF T=(TMV+TD)*DFSC*DFSC if(tn+t.lt.dzero)t=dzero !use non.rel. TN=TN+T ENDIF DSHIFT(K)=TN/DTWO TN=NNOLD TN=TN-SCREEN(K) TN=TN/TM FACT(K)=TN**3 DUY(K,K)=DUY(K,K)*FACT(K) DEY(K)=DUY(K,K)-DSHIFT(K) IF(QED.LT.0.AND.QN(K).GT.0)THEN VPINT(K)=FACT(K)*VPINT(K) SLFINT(K)=FACT(K)*SLFINT(K) ENDIF FACT(K)=SQRT(FACT(K)) ENDIF IF(K.EQ.1)GO TO 115 I=K-1 DO J=1,I DUY(K,J)=DUY(K,J)*FACT(K)*FACT(J) ENDDO IF(BMVD)THEN DO J=1,K IF(DEY(J).NE.DZERO)THEN DD=FACT(J)*FACT(K) DMASS(K,J)=DMASS(K,J)*DD DCD(K,J)=DCD(K,J)*DD D2LL(K,J)=D2LL(K,J)*DD IF(KUTOO.EQ.98)DXSI(K,J)=DXSI(K,J)*DD ENDIF ENDDO ENDIF 115 ENDDO GO TO 114 ENDIF C C DETERMINE CONFIGURATION OVERLAP MATRIX C (FOR USE WITH RELAXED ORBITALS, IRLX=2 ONLY.) C IF(IRLX.EQ.2)THEN !DETERMINE OVERLAPS BETWEEN CF'S IF(NF.GT.MAXTM)THEN !UNLIKELY!! WRITE(0,*)'DIAGON: INCREASE MAXTM' GO TO 2000 ENDIF KK=0 DO KF=2,KMAX DO KG=1,KF-1 KK=KK+1 DO I=1,NF IWRK3(I)=QCG(I,KG) ENDDO K=0 OVL=DONE DO I=1,NF DO L=1,NF IF(IEQ(IWRK3(L)).EQ.IEQ(QCG(I,KF)))THEN IWRK3(L)=0 I1=MIN(QCG(I,KF),QCG(L,KG)) I2=MAX(QCG(I,KF),QCG(L,KG)) II=((I2-1)*(I2-2))/2+I1 OVL=OVL*OVLPGR(II) GO TO 51 ENDIF ENDDO K=K+1 IPAIR(KK)=K IF(K.GT.2)GO TO 52 51 ENDDO OVLPCF(KK)=OVL 52 ENDDO ENDDO IF(BPRINT)THEN WRITE(6,768)(K,K=1,KMAX-1) K2=0 DO KF=2,KMAX K1=K2+1 K2=K2+KF-1 WRITE(6,767)KF,(OVLPCF(K),K=K1,K2) ENDDO ENDIF C C MULTIPLY ONE-BODY INTEGRALS BY OVERLAPS C DO J=2,MXORB KF=IGRCF(J) IF(DEY(J).EQ.DZERO.OR.KF.EQ.0)GO TO 78 DO I=1,J-1 KG=IGRCF(I) IF(DEY(I).EQ.DZERO.OR.KG.EQ.0)GO TO 77 IF(BJUMP.AND.IVAL(I)+IVAL(J).EQ.0)GO TO 77 IF(KF.NE.KG)THEN K1=MIN(KF,KG) K2=MAX(KF,KG) KK=((K2-1)*(K2-2))/2+K1 IF(IPAIR(KK).EQ.1)THEN OVL=OVLPCF(KK) DUY(I,J)=DUY(I,J)*OVL DUY(J,I)=DUY(J,I)*OVL !NEEDED? IF(BMVD.OR.NJO.GT.0)THEN DMASS(I,J)=DMASS(I,J)*OVL DCD(I,J)=DCD(I,J)*OVL D2LL(I,J)=D2LL(I,J)*OVL DMASS(J,I)=DMASS(J,I)*OVL !DITTO DCD(J,I)=DCD(J,I)*OVL D2LL(J,I)=D2LL(J,I)*OVL ENDIF ENDIF ENDIF 77 ENDDO 78 ENDDO ENDIF C C GENERATE AND PRINT SOME EXPECTATION VALUES C (NOT USED SUBSEQUENTLY, SO CAN SKIP IF PRINTING SUPPRESSED.) C 114 IF(.NOT.BPRNT0)GO TO 805 C IF(MGRP.GE.0)WRITE(6,200)MAXRS IF(MGRP.LT.0)WRITE(6,201)MAXRS L=MAXRS-2 C DO K=1,MXORB C IF(DEY(K).EQ.DZERO)GO TO 816 C IF(K.LE.IABS(MPSEUD))GO TO 816 K17=K N1=QL(K)/2 N3=N1 IF(BORT)N3=K-1 IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 613 DO J=1,6 DSTRNG(J,K)=DZERO ENDDO DSTRNG(3,K)=-DUY(K,K) DSTRNG(1,K)=(DEY(K)+DSTRNG(3,K))*DTWO IF(.NOT.BDR)DSTRNG(1,K)=DSTRNG(1,K)+DTWO*DSHIFT(K) IF(MODE.LT.6.AND.QN(K).LT.0)GO TO 613 !MODE=1-4, CURRENTLY... C DO J=2,6 M=J-3 IF(M.NE.0)THEN IF(BREL2)THEN DO I=1,MAXRS DD=DPNL(I,K)*DPNL(I,K)+DQNL(I,K)*DQNL(I,K) DPA(I)=DD*DX(I)**M ENDDO ELSE DO I=1,MAXRS DPA(I)=DPNL(I,K)*DPNL(I,K)*DX(I)**M ENDDO ENDIF CALL WEDDLE(DZERO,DPA,DC,MNH,DHNS,MJH,MAXRS) DSTRNG(J,K)=DC ENDIF ENDDO C 613 N2=IEND(N3+1) IF(N2.EQ.0)N2=MAXRS C WRITE(6,250)K,QN(K),N1,MION,NZION,SCREEN(K),(DSTRNG(J,K),J=1,6), X DADJUS(N3+1),DX(N2),(DPNL(I,K)*FACT(K),I=L,MAXRS) C 816 ENDDO C WRITE(6,100)(DX(I),I=L,MAXRS) C C DETAILED PRINTOUT OF MASS-VELOCITY PLUS DARWIN INTEGRALS C (SKIPPED IF PRINTING SUPPRESSED.) C IF(BMVD.AND.BPRNT0)THEN WRITE(6,901)JPRINT DO K=1,MXORB IF(DEY(K).NE.DZERO)THEN DD1=DMASS(K,K) DD2=DCD(K,K) DD=DD1+DD2 L=QL(K)/2 WRITE(6,902)K,QN(K),L,DEY(K),DD1,DD2,DD,D2LL(K,K) ENDIF ENDDO C WRITE(6,903) DO L=1,IRL IF(QRL(5,L).EQ.-1)THEN L1=QRL(1,L) L2=QRL(3,L) WRITE(6,904)L,L1,L2,DMASS(L1,L2),DCD(L1,L2),D2LL(L1,L2) ENDIF ENDDO ENDIF C C DETAILED PRINTOUT OF ONE-BODY INTEGRALS I(A,C) C IF(IRL.LT.0)THEN !.LT.0 SUPRESSES PRINTOUT WRITE(6,701) DO K=1,K17 I=K IF(DEY(K).EQ.DZERO)I=10000 WRITE(6,702)I,(DUY(K,J),J=1,K) ENDDO ENDIF C C DETAILED PRINTOUT OF ANY QED CONTRIBUTIONS C IF(QED.LT.0.AND.BPRNT0)THEN WRITE(6,3005) DO K=1,MXORB IF(DEY(K).NE.DZERO)THEN IF(QN(K).LT.0)GO TO 805 !WE ARE DONE DD=VPINT(K)+SLFINT(K) WRITE(6,3010)K,QN(K),QL(K)/2,VPINT(K),SLFINT(K),DD ENDIF ENDDO ENDIF C 805 CONTINUE C---------------------------------------------------------- C *** CALCULATE SLATER INTEGRALS: DRL(L) (AND 2-NFS) *** C---------------------------------------------------------- C if(btime)call cpu_time(timei) c IF(IRL.GT.0)THEN C CALL SLATR(BPRNT0) C IF(NF.LE.0)GO TO 2000 ENDIF C C IF(BPRNT0.AND.MAXLAM.NE.1000)WRITE(6,301)2*MAXLAM C BRADAT=BPRINT.OR.JPRINT.EQ.3.AND.INCL0.EQ.0 !ORIGINAL INCLUD IF(.NOT.BPRINT)BRADAT=JPRINT.LT.0.AND.NPRINT.GT.-2 !EVAL G FUNCTNL C BTFU=BRADAT.OR.ISHFTLS.GT.0.OR.ITANAL.NE.0 C IF(.NOT.BRADAT)GO TO 830 IF(BJUMP.AND..NOT.BRAD)GO TO 830 C C----------------------------------------------------- C *** CALCULATE R^K MULTIPOLE INTERGALS (INC BORN) *** C----------------------------------------------------- C CALL RKINT(BPRNT0) C IF(NF.LE.0)GO TO 2000 C 830 CONTINUE C if(btime)then call cpu_time(timef) times=timef-timei cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for diagon:' !par cpar write(iwp,*)' integral time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'integral time=',nint(times),'sec' cpar endif !par endif C C*********************************************************************** C C CONSTRUCT AND DIAGONALIZE ENERGY (SUB-)MATRICES. C C*********************************************************************** C C IF(.NOT.BREL)GO TO 831 !NPRNT0.GT.-5 C if(brel)go to 831 !allow LSR c IF(BPRNT0)WRITE(6,1000)NPRNT0 DF=DZERO DECORE=DZERO NC0=0 DO K=1,NSL0 NC=NSL(K) NC0=NC0+(NC*(NC+1))/2 ENDDO N=NC0 C C N.B. MDEL.GE.0 FIXED NOW BACK IN SR.MINIM. C IF(MDELE.EQ.0)GO TO 7500 IF(MDELE.LT.0)THEN IF(BDR)THEN WRITE(6,1001) C C IF REQUIRE THIS THEN NEED TO SET UP DISTINCT FILES FOR TFU AND THE C INTERPOLATION ORBITALS OF SR.RADCON. C NF=-1 GO TO 7500 ENDIF COLD READ(MRP)TFU GO TO 7500 ENDIF ISHFTLS=0 GO TO 7500 C 831 DO I=1,MAXCF IHARRY(I)=0 ENDDO C C CALCULATE ENERGY CONTRIBUTION DECORE OF THE NW CORE ELECTRONS C DC=DZERO ! 1-BODY DD2=DZERO ! 2-BODY C C 1-BODY (INC. NFS IF LSM/ICM) C DO L=1,NW J=NNL(L,1) DC=DC+DEY(J) IF(BMVD)THEN DC=DC+DCD(J,J)+DMASS(J,J) IF(QED.LT.0)DC=DC+VPINT(J)+SLFINT(J) IF(KUTOO.EQ.98)DC=DC+DXSI(J,J) ENDIF ENDDO C C 2-BODY (INC. NFS IF LSM/ICM) C DO I=1,NAD(0) J=INT(NRK(I)) DD2=DD2+DRL(J)*DRK(I) IF(BKUTOO.AND.BMVD)THEN IF(BFALL(I))THEN DD2=DD2-DRK(I)*DZL(J) ELSE DD2=DD2+DRK(I)*DZL(J) ENDIF DD2=DD2+DRK(I)*DXTWO(J)+DEK(I)*DETA(J) C - JONES ENDIF ENDDO C DECORE=DC+DD2 ! 1-BODY + 2-BODY C IF(BPRNT0)THEN WRITE(6,400)DD2,DC IF(BCONT)THEN WRITE(6,504) IF(ISHFTLS.NE.0)WRITE(6,509) ENDIF ENDIF C C CALCULATE 1-BODY CF ENERGY CONTRIBUTION OF THE NF VALENCE ELECTRONS C M2=0 DO M1=1,KMAX E1BCF(M1)=DZERO DO L=1,NF IF(QCG(L,M1).NE.M2)THEN M2=QCG(L,M1) DD=DEY(M2) IF(BMVD)DD=DD+DCD(M2,M2)+DMASS(M2,M2) IF(QED.LT.0.AND.QN(M2).GT.0)DD=DD+VPINT(M2)+SLFINT(M2) ENDIF E1BCF(M1)=E1BCF(M1)+DD ENDDO IF(ICAV.NE.0)E1BCF(M1)=E1BCF(M1)+ECAVX(M1)-ECAV(M1) !CA CORRECTN ENDDO C C COLLAPSE BACK RELAXED ORBITAL LIST C IF(IEQ(0).LT.0)THEN MXBORB=-IEQ(0) KF=MB0+MXBORB DO K=1,KF K2=2*K ITMP(K2-1)=QN(K) ITMP(K2)=QL(K)/2 IORB(K)=K2 ENDDO KP=2*KF KF=MB0+MXBORB*KMAX IF(BDR)THEN DO K=1,KMAX KF=KF+1 IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN !FIRST OCC. KP=KP+1 ITMP(KP)=QN(KF) KP=KP+1 ITMP(KP)=QL(KF)/2 IORB(KF)=KP ENDIF ENDDO ENDIF DO K=1,KMAX KF=KF+1 IF(IGRCF(KF).GT.0.AND.KF.EQ.IEQ(KF))THEN !FIRST OCC. KP=KP+1 ITMP(KP)=QN(KF) KP=KP+1 ITMP(KP)=QL(KF)/2 IORB(KF)=KP ENDIF ENDDO ENDIF C IF(MODE.GT.0)THEN EIONMN=DZERO IF(IEQ(0).EQ.0)THEN KF=MIN0(MXLIT,MXORB) IF(BPRNT0)WRITE(MW,507)KMAX,NZION,MION,(IABS(QN(K)),QL(K)/2 X ,K=1,KF) IF(.NOT.BPRNT0)WRITE(MWU)KMAX,NZION,MION,(IABS(QN(K)),QL(K)/2 X ,K=1,KF) ELSE KF=MIN0(KP,MXLIT) IF(BPRNT0)WRITE(MW,507)KMAX,NZION,MION,(IABS(ITMP(K)) X ,ITMP(K+1),K=1,KF,2) IF(.NOT.BPRNT0)WRITE(MWU)KMAX,NZION,MION,(IABS(ITMP(K)) X ,ITMP(K+1),K=1,KF,2) ENDIF ENDIF C DO K=1,KMAX LM=0 C DO J=1,MXORB IF(NEL(J,K).GT.0)THEN LM=LM+1 QSB(LM,K)=NEL(J,K) IF(LM.GT.1)QSB(LM,K)=QSB(LM,K)+50 IF(IEQ(0).LT.0)THEN JM=MIN(IORB(IEQ(J))/2,MXLIT) ELSE JM=MIN(J,MXLIT) ENDIF QLB(LM,K)=LIT(JM) CHAR QLB(LM,K)=ICHAR(CLIT(JM)) NCC0(LM)=J ENDIF ENDDO LMX(K)=LM C IF(LM.LT.10)THEN LP=LM+1 DO J=LP,10 QSB(J,K)=0 QLB(J,K)=MBLK1 CHAR QLB(J,K)=ICHAR(CMBLK1) ENDDO ENDIF M2=QCG(NF,K) KW=K MST=MSTAT(K) IF(IYY(M2).GE.0)THEN M1=QL(M2)+1 KW=-K MST=MSTAT(K)/(M1+M1) ENDIF IF(MODE.GT.0)THEN IF(BPRNT0)WRITE(MW,517)KW,MST,MA0,MB0,(QSB(L,K) X ,QLB(L,K),L=1,LM) CHAR X ,CHAR(QLB(L,K)),L=1,LM) IF(.NOT.BPRNT0)WRITE(MWU)KW,MST,MA0,MB0,(QSB(L,K),QLB(L,K) X ,L=1,10) ENDIF DO L=1,LM QLB(L,K)=NCC0(L) ENDDO ENDDO C IF(MODE.GT.0)THEN IF(BPRNT0)WRITE(MW,505)NZION,MION IF(.NOT.BPRNT0)WRITE(MWU)NZION,MION ENDIF C C*********************************************************************** C SUBMATRICES 2S,2L=QSI,QLI(K) (NF=NUMBER OF VALENCE ELECTRONS) C LOOP 728 (WITH 723) CORRESPONDS TO LOOP 61 (WITH N=0) IN SR ALGEB2 C*********************************************************************** C NENERG=0 N=0 MC=0 NCI=0 LUMAX=0 NCUT=KCUT IF(KCUT.LE.0)NCUT=10000 NCTOT=0 BINT=IAXUC.GT.0 !F95 DMIN=DKCM ITMIN=0 NSKP=0 c TOLA=CMXLSA*D1M4 !MAX B-F MATRIX ELEMENT IF(NNEW.GT.1)THEN T=DBLE(NNEW)/DTWO TOLA=TOLA/(T*SQRT(T)) ENDIF tola1=tola tola2=tola1/100 C DO 728 K=1,NSL0 C NC=NSL(K) MM=NC*NC C CF77 IF(MM.GT.IAXUC)GO TO 990 !F77 CF77 IF(NC.GT.MAXDI)GO TO 990 !F77 CF77 BINT=MM+NCTOT.LE.IAXUC !F77 IF(.NOT.BINT)NCTOT=0 C NGRPI(K)=NCI NCI=NCI+NC C IF(BCONT)THEN c n0=0 do i=1,mxorb ncc0(i)=0 enddo mx0=mxorb+1 C DO I=1,NC II=I+NENERG M1=NFK(II) M1=IABS(M1) M2=QCG(NF,M1) M2=IEQ(M2) IDY(I)=M2 IF(IYY(M2).LT.0)then IDY(I)=-IDY(I) n0=n0+1 NAI(II)=n0 !REL POSITION OF ABS TERM IN GROUP else ncc0(m2)=ncc0(m2)+1 NAI(II)=ncc0(m2) !REL POSITION OF ABS TERM IN GROUP mx0=min(mx0,m2) endif ENDDO C !SET-UP B-C INDEXING LU=0 DO L=1,NC IF(IDY(L).GT.0)THEN DO M=1,NC IF(IDY(M).LT.0)LU=LU+1 ENDDO ENDIF ENDDO C IF(LU.GT.LUMAX)LUMAX=LU IF(LU.GT.IXAAI)THEN WRITE(6,899)LU WRITE(0,*)'***INCREASE MXAAI' write(0,*)k,lu,ixaai GO TO 2000 ENDIF LUX=LU C ENDIF C !INDEX E-VECTORS if(mode.eq.2)then c iorb(mx0-1)=n0*n0 do i=mx0,mxorb nn=ncc0(i) iorb(i)=iorb(i-1)+nn*nn enddo C DO I=1,NC II=I+NENERG IF(IDY(I).GT.0)THEN m2=idy(i) nadru(ii)=nctot+iorb(m2-1)+ncc0(m2)*(nai(ii)-1) else nadru(ii)=nctot+n0*(nai(ii)-1) ENDIF ENDDO c if(bfot)then !need c-c e-vectors nctot=nctot+iorb(mxorb) else !only b-b nctot=nctot+n0*n0 !so can overwrite c-c endif C ELSE C DO I=1,NC II=I+NENERG NAI(II)=I M1=NFK(II) M1=IABS(M1) M2=QCG(NF,M1) M2=IEQ(M2) IDY(I)=M2 IF(IYY(M2).LT.0)IDY(I)=-IDY(I) NADRU(II)=NCTOT !END POSITION OF E-VECTOR II-1 NCTOT=NCTOT+NC ENDDO C ENDIF C C FORM H-MATRIX FOR THIS SYMMETRY C lui=0 ICB=0 ICC=0 IP=0 C DO I=1,NC !START SL LOOP C II=I+NENERG NN=NADRU(II) C M1=NFK(II) M1=IABS(M1) DE(I)=E1BCF(M1) C COLD IF(BNJO)DE(I)=DELELS(II,1) !NO SHIFT PRIOR TO DIAG NOW CADD DE(I)=DE(I)+DC C M2=QCG(NF,M1) IF(IYY(M2).LT.0)THEN ICB=ICB+1 ELSE DE(I)=DE(I)+ECOR1 M2=IEQ(M2) DO M=1,ICC IF(M2.EQ.IORB(M))GO TO 316 ENDDO ICC=ICC+1 IORB(ICC)=M2 ENDIF C C LOOP OVER SECOND INDEX OF H-MATRIX C 316 DO J=1,I !START SL LOOP C DD=DZERO c if(bcont)then if(idy(i).gt.0.and.idy(j).gt.0.and.idy(i).ne.idy(j))go to 317 ni=nai(j+nenerg) else ni=j endif C N=N+1 N1=NAD(N-1)+1 N2=NAD(N) C C 2-BODY NON-REL (SLATER) C DO L=N1,N2 M1=INT(NRK(L)) DD=DD+DRL(M1)*DRK(L) ENDDO CADD DD=DE(I) C C CASE LSM/ICM; ADD-IN 1- AND 2-BODY NFS C IF(BMVD)THEN DO L=N1,N2 M1=INT(NRK(L)) C 1-BODY IF(QRL(5,M1).LT.0)THEN !DZL(KX)=DXTWO(KX)=DETA(KX)=0 HERE L1=QRL(1,M1) !FALLING ORDER L1.GE.L2 L2=QRL(3,M1) DS=DCD(L1,L2)+DMASS(L1,L2) IF(KUTOO.EQ.98)DS=DS+DXSI(L1,L2) DS=DS*DRK(L) DD=DD+DS ENDIF C 2-BODY IF(BKUTOO)THEN DS=DZL(M1)*DRK(L) IF(BFALL(L))DS=-DS DS=DS+DXTWO(M1)*DRK(L)+DETA(M1)*DEK(L) !- JONES DD=DD+DS ENDIF ENDDO ENDIF C C BOUND-CONTINUUM (SLATER & NFS) C LU=0 IF(BCONT)THEN IF(IDY(I)*IDY(J).LE.0)THEN if(idy(i).gt.0)then lui=lui+1 lu=lui else luj=nvec(j) do l=j+1,i if(idy(l).lt.0)luj=luj+1 enddo lu=luj endif DO M=1,MENG DUI(M,LU)=DZERO ENDDO DO L=N1,N2 M1=INT(NRK(L)) KK=NRLI(M1) IF(KK.GT.0)THEN C SLATER DO M=1,MENG DUI(M,LU)=DUI(M,LU)+DRLI(M,KK)*DRK(L) ENDDO C NFS IF(BKUTOO.AND.BMVD)THEN DO M=1,MENG DS=DZLI(M,KK)*DRK(L) IF(BFALL(L))DS=-DS DS=DS+DXTWOI(M,KK)*DRK(L)+DETAI(M,KK)*DEK(L) !- J DUI(M,LU)=DUI(M,LU)+DS ENDDO ENDIF C ENDIF ENDDO if(mode.eq.3)lu=0 ENDIF ENDIF C C STORE H-MATRIX C IF(LU.EQ.0)TFU(NI+NN)=DD !STORE H FOR DIAG C 317 CONTINUE C IF(BPRNT0)THEN IP=IP+1 DVP(IP)=DD !STORE H FOR PRINTING ENDIF C ENDDO !END SL LOOP C TFU(NI+NN)=TFU(NI+NN)+DE(I) !ADD DIAG E EHERE c if(bcont)then if(idy(i).gt.0)then nvec(i)=lui do j=i+1,nc if(idy(j).lt.0)lui=lui+1 enddo endif endif C ENDDO !END SL LOOP C LL=NENERG C C***************************************************************** C C DIAGONALIZE HAMILTONIAN C C***************************************************************** C if(btime)call cpu_time(timei) c INFO=0 C IF(MODE.NE.2.OR.ICC.LE.0)THEN C !DU IS LOWER, TFU UPPER (SIGH) NN=NADRU(LL+1) DO I=1,NC DO J=1,I DU(I,J)=TFU(NN+J) !NAI(I+LL)=I HERE (ALL B-B) ENDDO CD DU(I,I)=DU(I,I)+DE(I) NN=NN+NC ENDDO C !BOTH UPPER HERE IF(IDIAG.GT.0)THEN NN=NADRU(LL+1) DO I=1,NC DO J=1,I-1 DU(J,I)=TFU(NN+J) ENDDO NN=NN+NC ENDDO ENDIF C CALL HDIAG(NC,DU,ISXDI,DVU,DVECV,NF,INFO) C IF(NC*NF.LE.0.OR.INFO.GT.0)GO TO 2000 C IF(MODE.GE.4)THEN icc=0 DO I=1,NC DO L=1,NC IF(IDY(L)*IDY(I).LE.0)DU(L,I)=DZERO ENDDO ENDDO ENDIF C NN=NADRU(LL+1) DO J=1,NC DO I=1,NC TFU(NN+I)=DU(I,J) !NAI(I+LL)=I HERE (ALL B-B) ENDDO NN=NN+NC ENDDO C ELSE C C DIAGONALIZE SEPARATELY THE ICC C-C BLOCKS PLUS THE B-B BLOCK C IF(ICB.GT.0)THEN M0=0 IORB(0)=-1000 ELSE M0=1 ENDIF C DO M=M0,ICC C NSUB=0 DO M7=1,NC IF(IORB(M).LT.0.AND.IDY(M7).LT.0)GO TO 676 IF(IORB(M).NE.IDY(M7))GO TO 675 676 NSUB=NSUB+1 NVEC(NSUB)=M7 675 ENDDO C HOLD NSUB0=NSUB IDIAG0=IDIAG C 700 CONTINUE C M1=NVEC(1)+LL NN=NADRU(M1) DO IS=1,NSUB DO JS=1,IS !LOWER DU(IS,JS)=TFU(NN+JS) c if(abs(du(js,is)).lt.d1m10)du(js,is)=dzero ENDDO CD MI=NVEC(IS) CD DU(IS,IS)=DU(IS,IS)+DE(MI) NN=NN+NSUB ENDDO C IF(IDIAG.GT.0)THEN DO IS=1,NSUB DO JS=IS+1,NSUB DU(IS,JS)=DU(JS,IS) ENDDO ENDDO ENDIF C CALL HDIAG(NSUB,DU,ISXDI,DVECL,DVECV,NF,INFO) C IF(NF.LE.0)GO TO 2000 C CL IF(INFO.GT.0)THEN !LAPACK FAILURE, SO TRY DIAG !LAPACK CL WRITE(6,*) !LAPACK CL X ' RE-RUNNING THIS MATRIX ONLY WITH SR.DIAG'!LAPACK CL GO TO 700 !LAPACK CL ENDIF !LAPACK C IF(NSUB.EQ.0)THEN !DIAG FAILURE, SO RELOAD AND USE JACORD WRITE(6,*)' RE-RUNNING THIS MATRIX ONLY WITH SR.JACORD' NSUB=NSUB0 IDIAG=1 GO TO 700 ENDIF C IDIAG=IDIAG0 C C STORE E-VECTORS AND E-ENERGIES IN TFU C M1=NVEC(1)+LL NN=NADRU(M1) DO IS=1,NSUB MI=NVEC(IS) DVU(MI)=DVECL(IS) DO JS=1,NSUB TFU(NN+JS)=DU(JS,IS) ENDDO NN=NN+NSUB ENDDO C ENDDO C ENDIF c if(btime)then call cpu_time(timef) timeh=timeh+timef-timei endif C C***************************************************************** C C PRINT TERM ENERGIES, TRANSFORMATION MATRICES AND H-SUBMATRICES. C C***************************************************************** C c test set corr-corr mixing to zero. c No real time saving, better not to generate it in the first place. c c do i=1,nc c j=i+ll c dry=2*dvu(i) c jj=iabs(nfk(j)) c if(idiag.ge.0.and.jj.gt.ncut c x .or.dry.gt.ecorr.or.dry.gt.eskpl.and.dry.lt.eskph)then c iwrk3(i)=-1 c else c iwrk3(i)=1 c endif c enddo c do i=1,nc c if(iwrk3(i).lt.0)then c j=i+ll c do l=1,nc c if(iwrk3(l).lt.0.and.idy(i)*idy(l).gt.0)then c if(idy(i).lt.0.or.idy(i).eq.idy(l))then c nn=nadru(j) c ni=nai(l+ll) c tfu(nn+ni)=dzero c endif c endif c enddo c endif c enddo c M2=0 C DO I=1,NC C C J IS THE ARRAY INDEX OF THE WHOLE H-MATRIX, WHEREAS I IS THE C POSITION IN THE APPROPRIATE SUBMATRIX C J=I+LL !+NENERG IWRK3(J)=0 C DD=DVU(I) COLD IF(BNJO)DD=DD-DELELS(J,1) !AS NO PRIOR SHIFT NOW M=NFK(J) JJ=IABS(M) IF(IDY(I).GE.0)THEN C REMOVE ENERGY OF CONTINUUM ELECTRON FROM ENERGY TERM LIST NFK(J)=-JJ IF(MODE.LT.3)DD=DD-DYY(NREL) DD=MOD(DD,TSHFT) ENDIF C IF(ISHFTLS.EQ.1)DD=DD+DELELS(J,1) !POST SHIFT FOR AUGERS IF(DD.LT.DMIN)THEN DMIN=DD ITMIN=J ENDIF C DENERG(J)=DD C IF(BTFU)THEN IHARRY(JJ)=IHARRY(JJ)+1 C IF(BPRNT0)THEN IF(MODE.NE.2.OR.ICC.LE.0)THEN DO L=1,NC NN=NADRU(J) DVECL(L)=TFU(NN+L) ENDDO ELSE DO L=1,NC DVECL(L)=DZERO if(idy(i)*idy(l).gt.0.and. x (idy(i).lt.0.or.idy(i).eq.idy(l)))then nn=nadru(j) ni=nai(l+ll) dvecl(l)=tfu(nn+ni) endif ENDDO ENDIF M1=M2+1 M2=M1+I-1 WRITE(6,180)J,QSI(K)+1,QLI(K)/2,QPI(K)/2,DE(I) X ,DVU(I),NFK(J),IHARRY(JJ),I,(DVECL(L),L=1,NC) X ,(DVP(L),L=M1,M2) ENDIF C ENDIF C ENDDO C NENERG=NENERG+NC C C C******************************************** C C ***COMPUTE AUTOIONIZATION RATES*** C C EVALUATE C __ C I.E. DV(I,J)*H(J,K)*DV(K,L) C C******************************************** C C IF(ICC.EQ.0)GO TO 728 !BAIL OUT TO NEXT SYMMETRY GROUP C IF(EIMXLS.LT.DZERO)THEN !INDEX CONTINUUM ENERGY ORDER C I1=LL+1 CALL HPSRTI(NC,DENERG(I1),IWRK2) C M=0 DECMIN=-D1P20 C DO J=1,NC NVEC(J)=0 I=IWRK2(J) II=I+LL IF(IDY(I).GT.0)THEN DRY=DENERG(II)+DECORE DRY=DRY+DRY IF(DRY.LE.EIMXLS)THEN !RESOLVED IF(DENERG(II).GT.(DECMIN+TOLB))THEN M=M+1 DE(M)=DENERG(II) IF(IDIAG.GE.0.AND.NFK(II).LE.NCUT)THEN !ONLY CORR FOR AA NVEC(M)=II IWRK3(II)=M ELSE NSKP=NSKP+1 IWRK3(II)=-M ENDIF ELSE IF(NVEC(M).GT.0)THEN NSKP=NSKP+1 IWRK3(II)=-M ELSEIF(IDIAG.GE.0.AND.NFK(II).LE.NCUT)THEN!IF LCON SPLIT NVEC(M)=II IWRK3(II)=M ELSE NSKP=NSKP+1 IWRK3(II)=-M ENDIF ENDIF DECMIN=DENERG(II) !ALLOW FOR ANY DRIFT0 C C STATISTICAL WEIGHTED AVERAGE C IF(IWGHT.NE.1)DD=(QLI(JJ)+1)*ISS C C EQUAL WEIGHTED AVERAGE C IF(IWGHT.EQ.1)DD=DONE C C ADD TO ENERGY FUNCTIONAL C 65 IF(IOPTIM.EQ.0)THEN !STANDARD DF=DAU*DD+DF DS=DS+DD ELSE !DIFF WITH OBS IF(IOPTIM.EQ.1)THEN !TERMS IF(DELELS(I,2).GT.DZERO)THEN DF0=(ABS(DELELS(I,2)-DENERG(I))+DFC)/DELELS(I,2) DF=DF+DF0*DD !*DF0 ELSEIF(DELELS(I,2).EQ.DZERO)THEN DD=DZERO ENDIF ENDIF ENDIF C 30 IF(ISHFTLS.LT.0)THEN !DETERMINE TEC IF(DELELS(I,1).NE.DZERO)THEN T=DELELS(I,1)-DENERG(I) DENERG(I)=DELELS(I,1) DELELS(I,1)=T ENDIF ENDIF C C ENR(I)=DRY DEM=DRY*DKCM DWRK(I)=DEM C MYRGE=MBLK IF(NFK(I).LT.0)THEN IF(DRY.GT.(DECMIN+TOLB))IE0=IE0+1 IF(DRY.LE.TIMXLS)JIMXLS=IE0 IWRK2(I)=IE0 ELSE IF(DRY.LT.DECMIN+TOLB.and.idw.eq.0)THEN IF(LSP.EQ.QLI(JJ)/2.AND.IPP.EQ.IP2)THEN MYRGE='****' IF(IUNIT(14).GT.0)BACKSPACE(14) ISP=(ISP+ISS)/2 ENDIF ENDIF ENDIF IF(MYRGE.EQ.MBLK)ISP=ISS IPP=IP2 LSP=QLI(JJ)/2 DECMIN=DRY C IF(IAUTO.GT.0.AND.DENERG(I)-EMIN.LE.TOLE)IAUTO=J+1 IF(NFK(I).LT.0.AND.IAUTO.LT.0)THEN IAUTO=J EMIN=DENERG(I) ENDIF C IF(CPRINT.AND.IORIG(J).GT.0)THEN !CHECK SPEC/CORR DISTRIB NTCC=NTCC+1 !NO OF SPEC TERMS IF(J-1.EQ.MTCC)MTCC=J !HIGHEST SPEC BELOW ALL CORR ENDIF C IF(.NOT.BAUX)GO TO 80 C II=(1-QPI(JJ))*ISS W=ISS*(QLI(JJ)+1)-1 W=W/2 C IF(MODE.GT.0.AND.MWR.GT.0)THEN IF(BPRNT0)THEN WRITE(MW,511)J,IORIG(J),II,LSP,NFK(I),DRY ELSE WRITE(MWU)IORIG(J),MZERO,II,LSP,MZERO,NFK(I),DRY ENDIF ENDIF C IF(BPRNT0)THEN WRITE(6,995)J,I,DEM,II,LSP,NFK(I),MB,DD,DRY IF(MODE.EQ.1.AND.IORIG(J).GT.0.AND.IUNIT(14).GT.0) !NO CORR X WRITE(14,992)ISP,LSP,IPP,NFK(I),NFI(I)-NTG(NFK(I)-1),DRY,MYRGE ENDIF C IF(MENGB.GE.-1.AND.IORIG(J).GT.0.and.j.le.lupe)THEN !NO CORR LSP=MIN(LSP,MXLABL) ISS=MIN(ISS,MXLABL) IS=0 K=IABS(NFK(I)) DO L=1,LMX(K) IS=IS+1 JJK=IABS(QN(QLB(L,K))) IF(JJK.GT.9)THEN STRING(IS)=NUMB(JJK/10) ELSE STRING(IS)=' ' ENDIF IS=IS+1 STRING(IS)=NUMB(MOD(JJK,10)) IS=IS+1 JJK=MIN(QL(QLB(L,K))/2,MXLABL) STRING(IS)=BIGL(JJK) IS=IS+1 N=MOD(QSB(L,K),50) STRING(IS)=NUMB(N) ENDDO DO L=IS+1,MXSTRG STRING(L)=' ' ENDDO if(badas)then !adf04 only if(iunit(25).gt.0)then cstan=' ' ceiss=' ' if(ismx.le.mstrgh)then f542="(i5,1x,1a15,2x,' (',i1,')',i1,'(',f4.1,')',f21.4)" write(cstan(1:15),'(15a1)')(string(l),l=2,mstrgh) call xxcftr(2,cstan,ceiss) write(25,f542)nspece,ceiss(1:15),iss,lsp,w,dem else f543="(i5,1x,1a31,2x,' (',i1,')',i1,'(',f4.1,')',f21.4)" write(cstan(1:31),'(31a1)')(string(l),l=2,mxstrg) call xxcftr(2,cstan,ceiss) write(25,f543)nspece,ceiss(1:31),iss,lsp,w,dem endif endif else !adf04 or adsex.in.form IF(ISMX.LE.MSTRGH)THEN F542="(I5,1X,15(A1),2X,' (',A1,')',A1,'(',F4.1,')',F21.4)" IF(IUNIT(21).GT.0)WRITE(21,F542)NSPECE X ,(STRING(L),L=2,MSTRGH),NUMB(ISS),NUMB(LSP),W,DEM IF(IUNIT(25).GT.0)WRITE(25,F542)NSPECE X ,(STRING(L),L=2,MSTRGH),NUMB(ISS),NUMB(LSP),W,DEM ELSE F543="(I5,1X,31(A1),2X,' (',A1,')',A1,'(',F4.1,')',F21.4)" IF(IUNIT(21).GT.0)WRITE(21,F543)NSPECE X ,(STRING(L),L=2,MXSTRG),NUMB(ISS),NUMB(LSP),W,DEM IF(IUNIT(25).GT.0)WRITE(25,F543)NSPECE X ,(STRING(L),L=2,MXSTRG),NUMB(ISS),NUMB(LSP),W,DEM ENDIF endif ENDIF C IF(JTCC.NE.0.AND.BPRNT0)THEN IF(DELELS(I,JTCC).NE.DZERO)THEN IF(IOPTIM.EQ.0)THEN DD=2*DELELS(I,1)*DKCM WRITE(6,994)I,DD,(2*DELELS(I,L),L=1,JTCC) ELSEIF(IOPTIM.EQ.1)THEN DD=DENERG(I)-DELELS(I,2) IF(J.EQ.1)DD=DD+DG0 DD=-DD*2 DDD=DD*DKCM WRITE(6,994)I,DDD,DD,2*DELELS(I,2) ENDIF ENDIF ENDIF C 80 ENDDO C C *** END ENERGY WRITE LOOP C IF(MODE.EQ.1.AND.BPRNT0.AND.IUNIT(14).GT.0) X WRITE(14,992)0,0,0,0,0,2*DG0 IF(IUNIT(21).GT.0)WRITE(21,540) IF(IDW.NE.0)THEN WRITE(MR)NMETA WRITE(MR)(NMETAG(I),I=1,NSL0) NNN=NENERG IF(BECOR)NNN=-NNN !FLAG ENERGY CORR WRITE(MR)NNN,KCUT WRITE(MR)(IORIG(I),I=1,NENERG) WRITE(MR)(DENERG(iabs(IORIG(I)))*DTWO,I=1,NENERG) WRITE(MR)NCTOT WRITE(MR)(TFU(I),I=1,NCTOT) ENDIF IF(IAUTO.LT.0)IAUTO=NENERG+1 C C PRINT OUT DETAILED INFORMATION ABOUT CI FOR LOWEST ITANAL TERMS C IF(ITANAL.NE.0)THEN IF(ITANAL.LT.0)WRITE(6,1749)ITANAL,ECNTRB NBIGC=0 NCFBIG(1,1)=0 DO J=1,NENERG L=NFI(J) ID(L)=-J DVECA(J)=DZERO ENDDO ITAN=IABS(ITANAL) ITAN=MIN(ITAN,NENERG) DO II=1,ITAN I=IORIG(II) IF(I.LT.0)GO TO 530 !CASE CORRELATION L=NFI(I) ID(L)=IABS(ID(L)) LSG=NFQ(I) IJ=(QSI(LSG)+1)*(1-QPI(LSG)) JJ=QLI(LSG)/2 IF(ITANAL.GT.0)WRITE(6,1751)II,IJ,JJ,DWRK(I) K1=NGRPI(LSG)+1 !=I-NAI(I)+1 K2=K1+NSL(LSG)-1 C DO K=K1,K2 N1=NADRU(I)+NAI(K) DD1=TFU(N1) DRY=DWRK(K)-DWRK(I) DD=DRY*DD1*DD1 KK=NFK(K) KK=IABS(KK) !CASE CONTINUUM L=NFI(K) C Add this CF to list of those that contribute more than C ECNTRB wavenumbers to the energy of this state DDA=ABS(DD) IF(DDA.GT.ECNTRB)THEN ID(L)=IABS(ID(L)) IF(ITANAL.GT.0)THEN DO IJ=1,NBIGC IF(NCFBIG(IJ,1).EQ.KK) GO TO 1699 ENDDO NBIGC=NBIGC+1 NCFBIG(NBIGC,1)=KK NCFBIG(NBIGC,2)=QPI(LSG) ENDIF ELSE DVECA(L)=MAX(DDA,DVECA(L)) ENDIF 1699 IF(ITANAL.GT.0)THEN DO IJ=1,NF NN=QCG(IJ,KK) NX1(IJ)=QN(NN) LX1(IJ)=QL(NN)/2 ENDDO WRITE(6,1750)K,KK,DD1,DRY,DD X ,(NX1(IJ),LX1(IJ),IJ=1,NF) ENDIF ENDDO 530 ENDDO C IF(NBIGC.GT.0)WRITE(6,1604)ECNTRB DO K1=1,NBIGC KK=NCFBIG(K1,1) DO IJ=1,NF NN=QCG(IJ,KK) NX1(IJ)=QN(NN) LX1(IJ)=QL(NN)/2 ENDDO WRITE(6,1603)K1,KK,NCFBIG(K1,2),(NX1(IJ),LX1(IJ),IJ=1,NF) ENDDO C DO K=1,KMAX IF(BANAL(K))GO TO 534 !WAS RESTRICXTED IN ALGEB ID0=0 N1=NTG(K-1)+1 N2=NTG(K) DO I=N1,N2 IF(ID(I).LT.0)ID0=ID0+1 ENDDO IF(ID0.GT.0)THEN DO IJ=1,NF NN=QCG(IJ,K) NX1(IJ)=QN(NN) LX1(IJ)=QL(NN)/2 ENDDO KK=K IF(K.GT.KCUT)KK=-KK NTT=NTG(K)-NTG(K-1) WRITE(31,531)ID0,NTT,KK,NF,(NX1(IJ),LX1(IJ),IJ=1,NF) I0=0 DO I=N1,N2 I0=I0+1 IF(ID(I).LT.0)WRITE(31,532)I0,-ID(I),DVECA(I) ENDDO ENDIF 534 ENDDO ENDIF C C WRITE LS PROLOGUE TO TCC FILES C IF(CPRINT.AND.KTCC.LT.0)THEN C C TCC.DAT JAJOM FORMAT C MTCC SPECTROSCOPIC TERMS LYING BELOW ALL CORRELATION C WRITE(1,519)MTCC,NENERG,KCUT DO J=1,MTCC I=IORIG(J) JJ=NFQ(I) WRITE(1,518)J,QSI(JJ)+1,QLI(JJ)/2,QPI(JJ)/2,DENERG(I)*DTWO ENDDO C ELSEIF(CPRINT.AND.KTCC.GT.0)THEN C C TCCDW.DAT STGICF FORMAT C NTCC SPECTROSCOPIC TERMS WHICH MAYBE INTERSPERSED WITH CORRELATION C WRITE FULL TERM LIST AND FLAG CORRELATION FOR STGICF TO ELIMINATE C SAID COMPONENTS AND RE-ORTHOINORMALIZE THE TCCS. C N0=NENERG IF(NTCC.NE.NENERG)N0=-N0 LAB4=' C&S' IF(BFANO)LAB4='FANO' WRITE(4,520)NTCC,N0,LAB4 DO J=1,NENERG I0=IORIG(J) I=IABS(I0) JJ=NFQ(I) J0=J IF(I0.LT.0)J0=-J WRITE(4,521)J0,QSI(JJ)+1,QLI(JJ)/2,QPI(JJ)/2,DENERG(I)*DTWO,I ENDDO ENDIF C C ALTERNATE FORM OF ENERGY FUNCTIONAL C IF(DS.EQ.DZERO)THEN DS=DONE DECORE=DZERO DO I=1,LL II=-INDEXW(I) IF(II.EQ.0)II=IORIG(I) DO J=1,I JJ=-INDEXW(J) IF(JJ.EQ.0)JJ=IORIG(J) DF=(DWRK(II)-DWRK(JJ)-WGHT(I)+WGHT(J) )**2+DF ENDDO IF(BAUX)WRITE(6,70)I,DWRK(II),WGHT(I),DF ENDDO ENDIF C C FINALIZE ENERGY FUNCTIONAL DF C DF=DF/DS C C DE-ALLOCATE C 7600 CONTINUE C IF(BALLH)THEN !F95 DEALLOCATE (DU,DVU,DE,IDY,NVEC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*) !F95 X 'DIAGON: DE-ALLOCATION FAILS FOR DU,DVU,DE,IDY,NVEC' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 IF(BPRNT0.AND.ALLOCATED(DVP))THEN !F95 DEALLOCATE (DVP,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR DVP' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 BALLH=.FALSE. !F95 ENDIF !F95 C !F95 IF(BALLA)THEN !F95 DEALLOCATE (DUI,DVI,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR DUI,DVI' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BALLA=.FALSE. !F95 ENDIF !F95 C IF(NF.LE.0)GO TO 750 !RETURN C c IF(BREL)GO TO 750 !Comment-out for LSR !NPRNT0.LE.-5 C C C******************************************** C C ***COMPUTE MULTIPOLE RADIATIVE DATA*** C C******************************************** CNRB: RE-WRITTEN FOR N^3 MULT. AND TO USE THE C LOOP OVER ALG STORAGE AS ONE OF THESE LOOPS. C******************************************** C C NGF=0 SGF=DZERO IF(.NOT.BRADAT.OR.NPRINT.EQ.-2)GO TO 745 IF(.NOT.BINT)GO TO 710 C NPOSX=(IOS-IRK) if(nposx.le.0)go to 745 CF77 BPOS=NPOSX.LE.MXD30 !F77 BPOS=.TRUE. !FORCE FOR !F95 BOMRC=.FALSE. !F95 C MXORB2=MXORB*MXORB MXPOL=MAX(1,MPOLX/2+1) IF(BPOS)THEN !PRE-DECODE ADDRESS C ALLOCATE (NPOS(4,NPOSX),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR NPOS' !F95 NF=0 !F95 GO TO 750 !RETURN !F95 ENDIF !F95 C c write(0,*)nposx,mxorb,mxpol NPOS0=IRK MCI=0 DO NC=1,NSL0 MC=NSL(NC) DO ND=1,NC N1=NED(1,ND,MCI+1) IF(N1.GT.0)THEN DO MD1=1,MC ND1=MD1+MCI N1=NED(1,ND,ND1) N2=NED(2,ND,ND1) DO M=N1,N2 NS=M-NPOS0 n8=MXORB2*MXPOL M1=INT(NRK(M)/n8) M2=M1+1 NPOS(1,NS)=M2 !TERM c if(m2.lt.1.or.m2.gt.maxtm)write(0,*)1,m,ns,m2,nrk(m) n8=M1*n8 MK=INT((NRK(M)-n8)/MXORB2) NPOS(2,NS)=MK !MULTIPOLE c if(mk.lt.1.or.mk.gt.mxpol)write(0,*)2,m,ns,mk,nrk(m) n8=n8+MK*MXORB2 n8=NRK(M)-n8 M1=INT(n8/MXORB+1) MM=INT(n8-(M1-1)*MXORB+1) M2=MIN0(M1,MM) NPOS(3,NS)=M2 !ORBITAL c if(m2.lt.1.or.m2.gt.mxorb)write(0,*)3,m,ns,m2,nrk(m) M1=M1+MM-M2 c if(m1.lt.1.or.m1.gt.mxorb)write(0,*)4,m,ns,m1,nrk(m) IF(MM.NE.M1)M1=-M1 NPOS(4,NS)=M1 !ORBITAL ENDDO ENDDO ENDIF ENDDO MCI=MCI+MC ENDDO ELSE NPOS0=0 WRITE(6,1605)NPOSX WRITE(0,1605)NPOSX ENDIF C !F95 IF(.NOT.BFOTJ)THEN !F95 ALLOCATE (DVECF(MENG,NENERG),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR DVECF' !F95 NF=0 !F95 GO TO 7450 !F95 ENDIF !F95 ENDIF !F95 C !F95 ALLOCATE (IDY(IAXDI),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR IDY' !F95 NF=0 !F95 GO TO 7450 !F95 ENDIF !F95 C BAUX=JPRINT.EQ.1.OR.JPRINT.GT.4 !.NOT.BAUX IGNORE CORRELATION C BDEL=MDEL.GT.0 IF(IDIAG.LT.0.AND.BDEL)WLG0=DTEN**MDEL DEM=2*DG0 !GROUND ENERGY (RYD) IF(EIONMN.EQ.DZERO)EIONMN=EIMXLS !ENABLE B-C SPLIT C IF(BPRNT0.AND.MODE.GT.0)WRITE(MW,508)NZION,MION IF(.NOT.BPRNT0.AND.MODE.GT.0)WRITE(MWU)NZION,MION C IF(MENGB.GE.-1)THEN !INITIALIZE OMEGA BORN C WRITE(6,989) TOLO=D1M10 c if(nmeta.gt.0)then nmin=min(NMETA,NSPECE) ixr=irow(nmin,nspece,ione,nspece) ixc=0 if(idw.eq.0.and.IABS(MENGB).EQ.1)ixc=icol(nmin,nspece,ione) nomwrt=max(ixr,ixc) else NOMWRT=(NSPECE*(NSPECE+1-2*ione))/2 endif C IF(IABS(MENGB).EQ.1)THEN !INFINITE ENERGY ONLY C BSCRO=.TRUE. !(REMOVE "ELSE" TO USE INTERNAL - WASTEFUL) C ALLOCATE (OMR(NOMWRT),OMC(NOMWRT),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: ALLOCATION FAILS FOR OMR,OMC' !F95 NF=0 !F95 GO TO 7450 !F95 ENDIF !F95 BOMRC=.TRUE. !F95 NOMWRX=NOMWRT !F95 C IF(NOMWRT.GT.NOMWRX)THEN NNN=2*NOMWRT/MXENG+1 WRITE(6,991)NNN WRITE(0,*)'*** WORKING ARRAYS TOO SMALL IN SR.DIAGON' GO TO 3000 ENDIF DO I=1,NOMWRX OMR(I)=DZERO OMC(I)=DZERO ENDDO C ELSE !FINITE ENERGY C BSCRO=.TRUE. !.T. USE SCRATCH FILE, .F. STORE INTERNALLY C IF(.NOT.BSCRO)THEN !F95 ALLOCATE (OMEGA(0:MXNXB1,NOMWRT),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 BSCRO=.TRUE. !F95 ELSE !F95 BSCRO=.FALSE. !F95 ENDIF !F95 ENDIF !F95 NOMWRY=NOMWRT !F95 C CF77 BSCRO=BSCRO.OR.(NOMWRT.GT.NOMWRY) !F77 C IF(BSCRO)THEN C WRITE(0,*)'DIAGON: USING SCRATCH FOR BORN MULTIPOLE SUM' C WRITE(6,*)'DIAGON: USING SCRATCH FOR BORN MULTIPOLE SUM' ELSE DO N=1,NOMWRT DO NX=0,MXNXB1 OMEGA(NX,N)=0 ENDDO ENDDO ENDIF C DO NX=1,MXNXB XS(NX)=SQRT(DONE-DONE/XB(NX)) ENDDO C ENDIF C MSC0=80 MSC=MSC0-1 IBOMX=0 C ENDIF C IF(MENGB.EQ.1)THEN WLGO=D1M7/DZA2 STOL=D1M9 ELSE WLGO=D1M5/DZA2 STOL=D1M7 ENDIF c if(btime)call cpu_time(timei) C MLAM=MPOL0-2 740 MLAM=MLAM+2 NGROUP=MLAM/2 C IF(NGROUP.EQ.1)THEN MP=0 IF(BPRNT0)WRITE(6,600)NGROUP IF(WLG1.LT.DZERO)THEN WLG=D1M2 IF(IDIAG.LT.0.AND.BDEL)WLG=WLG0 ELSE WLG=DZERO ENDIF WLG=MAX(WLG,WLG1) WLGS=DKON IF(NPRINT.GE.0)WLGS=D1M20 MPR=5 ELSE MP=5 IF(BPRNT0)WRITE(6,800)NGROUP,MP IF(WLG2.LT.DZERO)THEN WLG=D1M7 ELSE WLG=DZERO ENDIF WLG=MAX(WLG,WLG2) WLGS=DKON MPR=5 ENDIF C BBORN=MENGB.GT.1.OR.(MENGB.EQ.1.AND.NGROUP.NE.1) BFOTJ=.NOT.BFOT.OR..NOT.BLAG BFOTJ=BFOTJ.OR.NGROUP.NE.1 !UNCOMMENT TO WRITE E1 ONLY BFAST=.NOT.BBORN.AND..NOT.BPRNT0.and.includ.eq.0 C IF(BSCRO)THEN !MENGB.GE.-1 MSC=MSC0+NGROUP OPEN(MSC,STATUS='SCRATCH',FORM='UNFORMATTED') ENDIF c c if(bborn)then !initialize flag to count Born usage c do i=1,mb4(0) c iflagb(i)=-1 c enddo c endif C JOS=0 KTRAN=0 ILF=ione JJMN=1+ione JJMX=NENERG IF(JRAD.GT.0)THEN IF(JRAD.EQ.2.OR.JRAD.EQ.3.OR.JRAD.EQ.5)JJMN=MAX(JJMN,IAUTO) IF(JRAD.EQ.1)JJMX=MIN(IAUTO-1,NENERG) ENDIF JJMX=MIN(JJMX,LUPMX) JJMN=MAX(JJMN,LUPMN-1+ione) C C*********************************** C START LOOP OVER UPPER ENERGY TERMS C*********************************** C DO 732 JJ=JJMN,JJMX C IF(.NOT.BAUX.AND.IORIG(JJ).LT.0)GO TO 732 IF(IORIG(JJ).GT.0)THEN ILF=ILF+1 ELSE KTRAN=-KTRAN ENDIF J=IABS(IORIG(JJ)) C IF(.NOT.BFOT.AND.NFK(J).LT.0)GO TO 732 C ND=NFQ(J) NCD=NGRPI(ND) !=J-NAI(J) c c flag if mixing coefficient exists c if(mode.ne.2)then !b-b only do n=1,nsl(nd) idy(n)=-1 enddo elseif(nfk(j).gt.0)then !j is bound do n=1,nsl(nd) i=ncd+n if(nfk(i).gt.0)then !b-b idy(n)=-1 else !b-c idy(n)=0 endif enddo else !j is continuum m=-nfk(j) m=qcg(nf,m) ij=ieq(m) do n=1,nsl(nd) i=ncd+n if(nfk(i).gt.0)then !c-b idy(n)=0 else m=-nfk(i) m=qcg(nf,m) if(ieq(m).eq.ij)then !c-c idy(n)=1 else !c-c' idy(n)=0 endif endif enddo endif C IIMN=1 IIMX=JJ-ione if(nmeta.gt.0)iimx=min(iimx,nmeta) IF(JRAD.GT.0)THEN IF(JRAD.EQ.3)IIMN=MAX(1,IAUTO) IF(JRAD.EQ.1.OR.JRAD.EQ.2.OR.JRAD.EQ.4)IIMX=MIN(IAUTO-1,IIMX) ENDIF IF(EIMXLS.GE.DZERO)THEN !OUTWITH DROPPED, NOT BUNDLED IIMN=MAX(IIMN,LLOWMN-1+ione) IIMX=MIN(IIMX,LLOWMX) ENDIF C C INITIALIZE/ZEROIZE C DO I=1,NENERG IWRK3(I)=IABS(IWRK3(I)) DVECL(I)=DZERO DVECV(I)=DZERO DVECA(I)=DZERO ENDDO IF(BBORN)THEN !BORN IBO=0 DO I=1,NENERG ID(I)=0 ENDDO ENDIF IF(.NOT.BFOTJ.AND.NFK(J).LT.0)THEN DO I=1,NENERG DO M8=1,MENG DVECF(M8,I)=DZERO ENDDO ENDDO ENDIF C C PRE-MULTIPLY UPPER MIXING MATRIX BY MULTIPOLE MATRIX FOR ALL "LOWER" C STATES (ALL, BECAUSE THE "LOWER" STATES ARE TO BE MIXED SUBSEQUENTLY) C NCC=0 DO NC=1,NSL0 !BEGIN LOOP OVER "LOWER" GROUPS C C FOR SPEED PRE-SELECT ACCORDING TO MULTIPLICITY, PARITY, TOTAL L: C IF(QSI(ND).NE.QSI(NC))GO TO 7333 IF(NMETAG(NC)+NMETAG(ND).GT.1)GO TO 7333 ML=QPI(ND)+QPI(NC) IF(MOD(ML+MLAM,4).NE.0)GO TO 7333 ML=QLI(ND)+QLI(NC) IF(ML.LT.MLAM)GO TO 7333 ML=IABS(QLI(ND)-QLI(NC)) IF(ML.GT.MLAM)GO TO 7333 DS=1-MOD(ML,4) IF(BFANO)DS=DS*(-1)**NGROUP C DO N=1,NSL(NC) I=NCC+N IF(IWRK3(I).Le.JJ-ione.AND.IWRK3(I).LE.IIMX.AND.NFK(I).GT.0)THEN C .AND.IWRK4(I).GE.IIMN !IWRK4 NOT SET-UP YET IWRK3(I)=-IABS(IWRK3(I)) !FLAG EXISTS ENDIF ENDDO BEQGRP=ND.EQ.NC BING=ND.LE.NC IF(BING)THEN NU=NC NL=ND NNN=NCC ELSE NU=ND NL=NC NNN=NCD ENDIF C IF(NED(1,NL,NNN+1).EQ.0)GO TO 7333 C DO 7330 N=1,NSL(NU) !BEGIN LOOP OVER UPPER C !SYMMETRY ORDER TERMS I0=NNN+N C 332 IF(BING)THEN I=I0 IF(IWRK3(I).GT.0)GO TO 7320 ELSE L=I0 if(idy(l-ncd).eq.0)go to 7320 NI=NADRU(J)+NAI(L) DD2=TFU(NI) IF(ABS(DD2).LT.CMXLSR)GO TO 7320 ENDIF C N1=NED(1,NL,I0)-NPOS0 N2=NED(2,NL,I0)-NPOS0 C DO 736 M=N1,N2 C IF(BPOS)THEN M2=NPOS(1,M) ELSE n8=MXORB2*MXPOL M1=INT(NRK(M)/n8) M2=M1+1 ENDIF C IF(BING)THEN L=M2 if(idy(l-ncd).eq.0)go to 736 NI=NADRU(J)+NAI(L) DD2=TFU(NI) IF(ABS(DD2).LT.CMXLSR)GO TO 736 ELSE IF(I0.EQ.M2)GO TO 736 !AVOID DOUBLE COUNTING I=M2 IF(IWRK3(I).GT.0)GO TO 736 ENDIF C IF(BPOS)THEN MK=NPOS(2,M) IF(MK.NE.NGROUP)GO TO 736 M2=NPOS(3,M) MM=NPOS(4,M) M1=IABS(MM) ELSE n8=M1*n8 MK=INT((NRK(M)-n8)/MXORB2) IF(MK.NE.NGROUP)GO TO 736 n8=n8+MK*MXORB2 n8=NRK(M)-n8 M1=INT(n8/MXORB+1) MM=INT(n8-(M1-1)*MXORB+1) M2=MIN0(M1,MM) M1=M1+MM-M2 ENDIF C DRY=DD2*DRK(M+NPOS0) BINT=I.LE.L !DOWN TRUE IF(.NOT.BINT)DRY=DRY*DS !UP->DOWN DB=DOSC(NGROUP,M1,M2) DVECL(I)=DVECL(I)+DB*DRY !LENGTH C IF(BREL.AND.NFK(J).GT.0.and.irtard.gt.0)THEN !RETARD ALREADY ON PI DDD=DENERG(I)-DENERG(L) DDD=4*DDD*DDD*DRY DVECL(I)=DVECL(I)-C4*DDD*DOSC(NGROUP+2,M1,M2)/(2*(2*NGROUP+3)) ENDIF C IF(.NOT.BFOTJ.AND.NFK(J).LT.0)THEN !PHOTO M7=NFOSS(M1,M2) IF(M7.GT.0)THEN ISYGN=1 IF(MM.NE.M1)ISYGN=-ISYGN IF(.NOT.BINT)ISYGN=-ISYGN IF(ISYGN.LT.0)THEN DO M8=1,MENG DB=DRY !LENGTH/ACCELERATION IF(IGAG(M8).EQ.0)DB=-DB !VELOCITY DVECF(M8,I)=DVECF(M8,I)+DFOSS(M7,M8,1)*DB ENDDO ELSE DO M8=1,MENG DVECF(M8,I)=DVECF(M8,I)+DFOSS(M7,M8,1)*DRY ENDDO ENDIF ENDIF ENDIF C IF(BFAST)GO TO 736 C DB=DZERO !CHANGE OF ORBITAL TO TERM ORDER (VEL) IF(M2.NE.M1)THEN DB=DOSC(NGROUP,M2,M1) ELSE IF(NGROUP.GT.0)DB=DOSC(NGROUP-1,M2,M1) ENDIF IF(MM.NE.M1)DB=-DB IF(.NOT.BINT)DB=-DB DVECV(I)=DVECV(I)+DB*DRY !VELOCITY DVECA(I)=DVECA(I)+DRY*ACC(M1,M2) !ACCELERATION C IF(BBORN)THEN !BORN IF(ID(I).EQ.0)THEN IBO=IBO+1 IF(IBO.LE.MXBIF)THEN ID(I)=IBO DO IX=1,MB3(0) DBL(IX,IBO)=DZERO ENDDO ELSE ID(I)=-IBO ENDIF ENDIF IF(ID(I).GT.0)THEN IB=ID(I) IN=ICOL(M2,M1,0) IF(BINDB(IN,NGROUP/2))THEN IX=INDX(IN) DBL(IX,IB)=DBL(IX,IB)+DRY ELSE II=JORIG(I) WRITE(6,*)JJ,II,L,I,M,NGROUP,M2,M1 WRITE(0,*)'DIAGON: BORN M1 M2 NOT FOUND' GO TO 3000 ENDIF ENDIF ENDIF C 736 CONTINUE C 7320 IF(BEQGRP)THEN !PICK-UP OTHER HALF IF(BING)THEN BING=.FALSE. GO TO 332 ELSE BING=.TRUE. ENDIF ENDIF C 7330 CONTINUE !END LOOP OVER TERMS C 7333 NCC=NCC+NSL(NC) ENDDO !END LOOP OVER GROUPS C IF(BBORN)THEN IBOMX=MAX(IBOMX,IBO) IF(IBO.GT.MXBIF)THEN WRITE(6,*)'SR.DIAGON: DIMENSION ERROR, INCREASE MXBIF TO ' X ,IBO WRITE(0,*)'SR.DIAGON: DIMENSION ERROR, INCREASE MXBIF' GO TO 3000 ENDIF ENDIF C C*********************************** C START LOOP OVER LOWER ENERGY TERMS C*********************************** C ILI=0 SUMRN=DZERO SUMRD=DZERO C DO 733 II=IIMN,IIMX C IF(.NOT.BAUX.AND.IORIG(II).LT.0)GO TO 733 IF(IORIG(II).GT.0)THEN ILI=ILI+1 IF(KTRAN.GE.0)KTRAN=KTRAN+1 ENDIF I=IABS(IORIG(II)) IF(IWRK3(I).GT.0)GO TO 733 IF(IABS(MENGB).EQ.1.AND.MOD(NGROUP,2).EQ.1)THEN IX=IROW(ILI,ILF,ione,NSPECE) IF(OMR(IX).LT.-TOLO)GO TO 733 !DIPOLE ALREADY COMPUTED ENDIF C IF(IDIAG.GE.0.AND.BDEL)THEN MRD=0 I5=0 M3=NFK(J) M3=IABS(M3) M4=NFK(I) DO I3=1,MXORB I4=NEL(I3,M3)-NEL(I3,M4) IF(I4.NE.0)THEN I5=I5+1 MRDP=MRD MRD=QN(I3) IF((-1)**I5.GT.0.AND.IABS(MRD-MRDP).GE.MDEL)GO TO 437 ENDIF ENDDO GO TO 733 437 CONTINUE ENDIF C NC=NFQ(I) ML=QLI(ND)-QLI(NC) K1=NGRPI(NC)+1 !=I-NAI(I)+1 K2=K1+NSL(NC)-1 C DD=DZERO DC=DZERO DAS=DZERO C IF(BFAST)THEN IF(BFOTJ.OR.NFK(J).GT.0)THEN DO K=K1,K2 if(nfk(k).gt.0)then N1=NADRU(I)+NAI(K) DD=DD+TFU(N1)*DVECL(K) endif ENDDO ELSE DO M8=1,MENG DFOT(M8)=DZERO ENDDO DO K=K1,K2 if(nfk(k).gt.0)then N1=NADRU(I)+NAI(K) DD1=TFU(N1) IF(ABS(DD1).GT.CMXLSR)THEN DD=DD+DD1*DVECL(K) DO M8=1,MENG DFOT(M8)=DFOT(M8)+DD1*DVECF(M8,K) ENDDO ENDIF endif ENDDO ENDIF ELSE IF(BBORN)THEN !BORN DO K=1,MB3(0) SBL(K)=DZERO ENDDO ENDIF IF(BFOTJ.OR.NFK(J).GT.0)GO TO 3330 DO M8=1,MENG DFOT(M8)=DZERO ENDDO 3330 DO K=K1,K2 if(nfk(k).lt.0)go to 734 N1=NADRU(I)+NAI(K) DD1=TFU(N1) IF(ABS(DD1).LT.CMXLSR)GO TO 734 DD=DD+DD1*DVECL(K) DC=DC+DD1*DVECV(K) DAS=DAS+DD1*DVECA(K) IF(BBORN)THEN !BORN IBO=ID(K) IF(IBO.GT.0)THEN DO M=1,MB3(0) SBL(M)=SBL(M)+DD1*DBL(M,IBO) ENDDO ENDIF ENDIF IF(BFOTJ.OR.NFK(J).GT.0)GO TO 734 DO M8=1,MENG DFOT(M8)=DFOT(M8)+DD1*DVECF(M8,K) ENDDO 734 ENDDO ENDIF C OBO(MINFB)=DZERO IF(MENGB.EQ.-1.AND.ABS(DD).GT.WLGO)OBO(MINFB)=D1P30 IF(NGROUP.EQ.0)DD=DZERO IF(NGROUP.GT.0.AND.DD.EQ.DZERO)GO TO 733 C C EXCLUDE TRANSITIONS INVOLVING ZERO-WEIGHT TERMS FROM FUNCTIONAL G C MB=MBLK IF(LL.GT.0)THEN !-INCLUDE NN=-1 DO K=1,LL IF(INDEXW(K).EQ.I.OR.INDEXW(K).EQ.J)THEN NN=NN+1 IF(NN.GT.0)GO TO 746 ENDIF ENDDO MB=MOUT ENDIF 746 IF(IORIG(II).LT.0.OR.IORIG(JJ).LT.0)MB=MCOR C C BORN MULTIPOLES C IF(BBORN)THEN !BORN DO IE=1,MENGB OBO(IE)=DZERO ENDDO OMG1=DZERO DLAM=2*NGROUP+1 NH=NGROUP/2 DO N=1,MB4(0) L=INDL(N) K=INDK(N) SSB=SBL(K)*SBL(L) IF(ABS(SSB).GT.STOL)THEN DO IE=1,MENGB DB=SSB*BL(IE,N,NH) c if(db.ne.dzero)iflagb(n)=iabs(iflagb(n)) !flag used OBO(IE)=OBO(IE)+DB+DB IF(L.EQ.K)OBO(IE)=OBO(IE)-DB ENDDO IF(NGROUP.EQ.1)THEN DB=SSB*TM2(N) OMG1=OMG1+DB+DB IF(L.EQ.K)OMG1=OMG1-DB ENDIF ENDIF ENDDO DB=DEIGHT*DLAM*(QSI(ND)+1) DO IE=1,MENGB OBO(IE)=DB*OBO(IE) ENDDO OMG1=DB*OMG1 ENDIF C C ELECTRIC MULTIPOLE C JOS=JOS+1 DRY=DENERG(J)-DENERG(I) IF(DRY.EQ.DZERO)then if(mengb.lt.-1)GO TO 733 !CASE E2 DEGENERATE dry=d1m10 endif c IF(NFK(J).LT.0)DRY=DRY+DYY(NREL) DRY=DRY+DRY DP(4)=4*DAS/(DRY*DRY) c dp(4)=das !if orb ener. used MI=II MJ=JJ C IF(NFK(I).LT.0)MI=-MI IF(NFK(J).LT.0)MJ=-MJ MWJ=(QSI(ND)+1)*(QLI(ND)+1) MWI=(QSI(NC)+1)*(QLI(NC)+1) WLG=ABS(WLG) IF(NFK(J).LT.0)WLG=-WLG C DB=DG(NGROUP)*DRY**(MLAM-1)*DFSC**(MLAM-2) DD=ABS(DD)*DD*(QSI(ND)+1) DS=DB*DD IF(NFK(J).GT.0)DAS=C1*DS*DRY*DRY/MWJ IF(NFK(J).LT.0)DAS=C2*DS/MWI IF(ABS(DAS).LT.WLG.AND.OBO(MINFB).LT.WLGO.AND.DS*DS.LT.WLGS) X GO TO 733 C BINT=(BAUX.OR.MB.NE.MCOR).AND.BPRNT0 C ISGN=(-1)**(ML/2) !SWITCH DOWN TO UP ON F C IF(BFANO)ISGN=ISGN*(-1)**NGROUP ISGN=1 !ALL DOWN DB=ISGN*DB*(QSI(ND)+1)*DTEN**MP DC=DC/DRY !skip if orb ener. used DP(2)=DB*DC*ABS(DC) DP(3)=DB*DC*SQRT(ABS(DD)/(QSI(ND)+1)) DP(4)=DB*DP(4)*ABS(DP(4)) DP(1)=D1P8/(DRY*DKCM) DS=ISGN*DS*DTEN**MP DD1=DS/MWI DD2=DS/MWJ C IF(NGROUP.EQ.1)THEN DP(5)=DFOUR*ABS(DD1)/(DRY*DRY) OMG=DFOUR*DS/DRY IF(IABS(MENGB).EQ.1)THEN OMGINF=-ABS(OMG) OMG=OMG*LOG(EINF*DZ2) OMG=-ABS(OMG) !TAG DIPOLE NEGATIVE IF(OMG.GE.-TOLO)OMG=DZERO !ZERO VANISHINGLY SMALL CPT ELSEIF(MENGB.GT.1)THEN OMG=-ABS(OMG) !4S/3 if(nmeta.eq.0)nmeta=iimx !pwb ENDIF if(idw.eq.0)then if(nmeta.eq.0)nmeta=nenerg !for RM else if(nmeta.eq.0)nmeta=iimx endif ELSE DP(5)=OBO(MINFB) OMG=OBO(MINFB) OMGINF=OMG ENDIF C C DETERMINE BORN OMEGAS C BPRNTO=.FALSE. IF(MPOL0.EQ.0.AND.MB.EQ.MBLK)THEN !MPOL0 CATCHES E1 IF(IABS(MENGB).EQ.1)THEN !INFINITE ENERGY BORN ONLY BPRNTO=.TRUE. IXC=ICOL(ILI,ILF,ione) IF(IXC.LE.NOMWRX)OMC(IXC)=OMC(IXC)+OMG IXR=IROW(ILI,ILF,ione,NSPECE) IF(IXR.LE.NOMWRX)OMR(IXR)=OMR(IXR)+OMG OMEGAB(MXNXB1)=OMGINF ELSEIF(MENGB.GT.1.AND.abs(OBO(MINFB)).GT.WLGO)THEN !FINITE BORN BPRNTO=.TRUE. CALL BRNINT(BPRNT0,NLAGB,MXNXB,MV0,MV1,DRY,V0,V1,XB,XS X ,DB0,DB1,OMG1,OBO,OMEGAB) OMEGAB(MXNXB1)=OMG !INFINITE ENERGY c if(nlagb.lt.0)go to 3000 !brnint failure ENDIF ENDIF C C OUTPUT ELECTRIC MULTIPOLE DATA. C IF(BINT)WRITE(6,500)JOS,MB,MJ,MI,DAS,DD,DS,DD1,DD2,(DP(K),K=1,MPR) IF(BPRNTO)THEN T=ABS(DAS) IF(BSCRO)THEN WRITE(MSC)MJ,MI,T,(OMEGAB(K),K=1,MXNXB1) ELSE OMEGA(0,KTRAN)=OMEGA(0,KTRAN)+sngl(T) T=dble(OMEGA(MXNXB1,KTRAN)) KMX=MXNXB1 IF(MOD(NGROUP,2).EQ.1.AND.T.LT.-TOLO)KMX=MXNXB !OLD DIPOLE DO K=1,KMX OMEGA(K,KTRAN)=OMEGA(K,KTRAN)+sngl(OMEGAB(K)) ENDDO ENDIF ENDIF C IF(MODE.LT.1)GO TO 615 DB=DENERG(I)+DENERG(I)+DEM IF(NFK(I)*NFK(J).LT.0)GO TO 335 C IF(II.LE.LLOWMX.AND.DB.LE.EIMXLS.AND. X IHARRY(NFK(I)).LE.NRSLMX)THEN !RESOLVED IF(BPRNT0)WRITE(MW,501)NFK(J),J,MWJ,NFK(I),I,MWI,DAS,DRY,DB IF(.NOT.BPRNT0)WRITE(MWU)NFK(J),J,MWJ,NFK(I),I,MWI,DAS,DRY,DB ELSE !BUNDLED IF(DB.LT.EIONMN)THEN SUMRN=SUMRN+ABS(DAS) ELSE SUMRD=SUMRD+ABS(DAS) ENDIF ENDIF GO TO 615 C 335 IF(BFOTJ)GO TO 733 C DO M8=1,MENG DRY=DENERG(J)-DENERG(I)+DYY(M8) DRY=DRY+DRY C C N.B. SIGN OF REDUCED MATRIX ELEMENT IS STILL FOR DOWNWARD TRANSITION. C TO GET SIGN FOR UPWARD TRANSITION, UNCOMMENT THE NEXT TWO LINES. C DFOT(M8)=DFOT(M8)*(-1)**(ML/2) C IF(BFANO)DFOT(M8)=DFOT(M8)*(-1)**NGROUP C DFOT(M8)=C3*DRY*DFOT(M8)*ABS(DFOT(M8))/DBLE(QLI(NC)+1) ENDDO C DRY=DENERG(J)+DENERG(J)+DEM C C PI DAS IS ALWAYS LENGTH, EVEN WHEN VEL/ACC SET. C IF(II.LE.LLOWMX.AND.DB.LE.EIMXLS.AND.IWRK2(J).LE.JIMXLS.AND. X IHARRY(NFK(I)).LE.NRSLMX)THEN !RESOLVED IF(BPRNT0)THEN WRITE(MWW,501)NFK(I),I,MWI,NFK(J),J,IWRK2(J),DAS,DB,DRY WRITE(MWW,515)(DFOT(M8),M8=1,MENG) ELSE WRITE(MWWU)NFK(I),I,MWI,NFK(J),J,IWRK2(J),DAS,DB,DRY WRITE(MWWU)(DFOT(M8),M8=1,MENG) ENDIF ENDIF GO TO 733 C C IN ELECTRIC DIPOLE CASE ADD CONTRIBUTION TO FUNCTIONAL G C 615 IF(NGROUP.EQ.1.AND. X INCLUD.NE.0.AND. X MB.EQ.MBLK)THEN NGF=NGF+1 DS=ABS(DS) DP(2)=ABS(DP(2)) DP(3)=ABS(DP(3)) SGF=(DS+DP(2)-2*DP(3))/(DS+DP(2)+2*DP(3))+SGF ENDIF C C 733 CONTINUE !END LOOP OVER LOWER LEVELS C C WLG=ABS(WLG) IF(SUMRN.GT.WLG)THEN IF(BPRNT0)WRITE(MW,501)NFK(J),J,MWJ,MZERO,MZERO,MZERO,SUMRN X ,DZERO,DEM IF(.NOT.BPRNT0)WRITE(MWU)NFK(J),J,MWJ,MZERO,MZERO,MZERO,SUMRN X ,DZERO,DEM ENDIF IF(SUMRD.GT.WLG)THEN IF(BPRNT0)WRITE(MW,501)NFK(J),J,MWJ,MZERO,MZERO,MZERO,SUMRD X ,DZERO,DZERO IF(.NOT.BPRNT0)WRITE(MWU)NFK(J),J,MWJ,MZERO,MZERO,MZERO,SUMRD X ,DZERO,DZERO ENDIF C C 732 CONTINUE !END LOOP OVER UPPER LEVELS C C c determine usage of Born integrals c note: practically all are used for normal targets. c e.g. of where usage is low is large pseudostate expansions, c especially ls coupling. Also, perhaps, use of relaxed orbitals; c but the bindb variable helps greatly. c c if(bborn)then c nh=ngroup/2 c icount=0 c icountb=0 c do i=1,mb4(0) c if(bl(1,i,nh).ne.dzero)then c nc=indl(i) c j=mb4(nc) c k=mb3(nc) c if(mod(ngroup,2).eq.mod((ql(j)+ql(k))/2,2))then c icount=icount+1 c if(iflagb(i).gt.0)icountb=icountb+1 c if(bprnt0)write(777,6999)i,indl(i),iflagb(i),icountb c 6999 format(i7,i5,i3,i6) c endif c endif c enddo c p=icountb c if(icount.gt.0)p=100*p/icount c npp=nint(p) c write(0,*)'BORN INTEGRALS: CALC=',icount,'USED=',icountb,npp c x ,'%' c write(6,777)icount,icountb,npp c 777 FORMAT(/'BORN INTEGRALS: CALC=',I7,' USED=',I7,I5,'%'/) c endif C C END MULTIPOLE LOOP OVER RADIATIVE TRANSITIONS C IF(MLAM.LT.MPOLE)GO TO 740 C if(btime)then call cpu_time(timef) times=timef-timei cpar if(iam.ge.0)then !par cpar write(iwp,*)'proc',iam,' for diagon:' !par cpar write(iwp,*)' radiative time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'radiative time=',nint(times),'sec' cpar endif !par endif C C WRITE AN INFINITE ENERGY OMEGA FILE C IF(MENGB.GE.-1)THEN !BBORN C WRITE(6,*)' ' WRITE(6,*)'IBOMX=',IBOMX c do j=nenerg,1,-1 if(iorig(j).gt.0)go to 645 enddo 645 lupe=j C IF(IABS(MENGB).EQ.1)THEN !INF ENG BORN, ROW *AND* COL C IF(MENGB.EQ.-1)THEN DO I=1,NOMWRT OMR(I)=MIN(OMR(I),D1P30) OMC(I)=MIN(OMC(I),D1P30) ENDDO ENDIF C K=0 DO J=1,lupe !NENERG I=IORIG(J) IF(I.GT.0)THEN K=K+1 N=NFQ(I) IWRK3(K)=(1-QPI(N))*(QSI(N)+1) IWRK4(K)=QLI(N)/2 DWRK(K)=DENERG(I)*DTWO/DZ2 ENDIF ENDDO C IF(K.NE.NSPECE)THEN WRITE(6,*)'DIAGON: ENERGY MISMATCH',K,NSPECE WRITE(0,*)'DIAGON: ENERGY MISMATCH' GO TO 3000 ENDIF c if(nmeta.eq.0)nmeta=nspece !case no E1 if(nmeta.lt.nspece)then ixr=irow(nmeta,nspece,ione,nspece) if(ixr.lt.nomwrt)nomwrt=ixr ixc=icol(nmeta,nspece,ione) else ixc=nomwrt endif if(nmeta0.eq.0)nmeta=-nmeta C WRITE(23,*)NZION,MION WRITE(23,*)NSPECE,IABS(MENGB),NOMWRT WRITE(23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE) WRITE(23,711)(DWRK(I),I=1,NSPECE) WRITE(23,713)EINF,(OMR(I),I=1,NOMWRT) C IF(IDW.EQ.0)THEN !COLUMNWISE AS WELL NOMWRT=(NSPECE*(NSPECE+1-2*ione))/2 if(ixc.lt.nomwrt)nomwrt=ixc C WRITE(23,*)NZION,MION WRITE(23,*)NSPECE,IABS(MENGB),-NOMWRT WRITE(23,*)(IWRK3(I),IWRK4(I),I=1,NSPECE) WRITE(23,711)(DWRK(I),I=1,NSPECE) WRITE(23,713)EINF,(OMC(I),I=1,NOMWRT) ENDIF C ENDIF !SUM BORN MULTIPOLES C C WRITE DATA TO ADF04 FILE C BEXP=.FALSE. !TRUE=1.0E+0, FALSE=1.0+0 IF(NSPECE.LT.1000)THEN i1=0 IF(BEXP)THEN F761='(F5.2,4X,"1", 8X,20(1PE10.2))' F762='(2I4,22(1PE10.2))' ELSE F761='(F5.2,4X,"1", 6X, 20(A5, A3))' F762='(2I4, 22(A5, A3))' ENDIF ELSE i1=1 IF(BEXP)THEN F761='(F5.2,4X,"1",10X,20(1PE10.2))' F762='(2I5,22(1PE10.2))' ELSE F761='(F5.2,4X,"1", 8X, 20(A5, A3))' F762='(2I5, 22(A5, A3))' ENDIF ENDIF C C WRITE(25,542)-1 card=' ' card(4:5)='-1' orbfmt='(1x,f7.?)' is=9+2*i1 ie=is+mxorb*7 if(ie.gt.200)then write(6,*)'***sr.diagon: card too short, need len=',ie write(0,*)'***sr.diagon: card too short' nf=-1 go to 3000 endif do i=1,mxorb ie=is+7 if(dey(i).ne.dzero)then t=dey(i)-duy(i,i) if(bmvd)t=t+dmass(i,i)+dcd(i,i) t=-2*t endif write(orbfmt(8:8),'(i1)') x max(2,5-max(0,int(log10(max(t,d1m30))))) write(card(is:ie),orbfmt)t is=ie+1 enddo orbfmt=' ' orbfmt(1:6)='(a )' write(orbfmt(3:5),'(i3)')ie write(25,orbfmt)card(1:ie) C IF(BEXP)THEN WRITE(25,F761)DBLE(NZA),(XB(K),K=1,MXNXB) ELSE MSCP=MSC+1 OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED') WRITE(MSCP,764)(XB(K),K=1,MXNXB) BACKSPACE(MSCP) READ(MSCP,765)(XMANT(K),IEXP(K),K=1,MXNXB) WRITE(25,F761)DBLE(NZA),(XMANT(K),IEXP(K),K=1,MXNXB) ENDIF C DO M=MSC0,MSC !RE-POINT BORN MULTIPOLE FILES REWIND(M) ENDDO c if(nenerg.eq.1)go to 373 C IOLD=JJMN !1+ione JOLD=IIMN !1 if(iorig(iold).lt.0.or.iorig(jold).lt.0)then write(6,*)'Lowest two terms cannot be correlation!' write(0,*)'Lowest two terms cannot be correlation!' go to 3000 endif INEW=IOLD JNEW=JOLD C 371 IF(BSCRO)THEN C BBORN=.FALSE. C DAS=DZERO DO K=0,MXNXB1 OMEGAB(K)=DZERO ENDDO C IP=IORIG(IOLD) IP=NFQ(IP) IP=QPI(IP) JP=IORIG(JOLD) JP=NFQ(JP) JP=QPI(JP) IF(IP.NE.JP)THEN MMN=MSC0+1 !ODD MULTIPOLES MMX=MSC+MOD(MSC,2)-1 ELSE MMN=MSC0 MMX=MSC-MOD(MSC,2) ENDIF C IFLAGO=999 DO M=MMN,MMX,2 READ(M,END=370,ERR=370)I,J,(XS(K),K=0,MXNXB1) IF(I.GT.IOLD.OR.J.GT.JOLD)THEN BACKSPACE(M) GO TO 370 ELSE if(jold.gt.iimx)then if(nmeta0.eq.0)then go to 370 !unfortunate interchange of i,j use else stop '370' endif endif BBORN=.TRUE. KMX=MXNXB1 IF(IP.NE.JP)THEN LAM=MOD(M,80) IF(LAM.EQ.1.AND.ABS(XS(MXNXB1)).GT.TOLO)IFLAGO=1 !E1 LIM IF(LAM.GT.IFLAGO)KMX=MXNXB !DON'T OVEFRWRITE E1 LIMIT ENDIF DO K=0,KMX OMEGAB(K)=OMEGAB(K)+XS(K) ENDDO ENDIF 370 ENDDO C ELSE KTRAN=KTRAN+1 DO K=0,MXNXB1 OMEGAB(K)=dble(OMEGA(K,KTRAN)) ENDDO ENDIF C IF(BBORN)THEN DO K=0,MXNXB OMEGAB(K)=ABS(OMEGAB(K)) IF(OMEGAB(K).LT.D1M99)OMEGAB(K)=DZERO ENDDO IF(OMEGAB(0).LT.D1M30)OMEGAB(0)=D1M30 IF(OMEGAB(MXNXB1).GT.D1P30)OMEGAB(MXNXB1)=D1P30 IF(BEXP)THEN WRITE(25,F762)INEW,JNEW,(OMEGAB(K),K=0,MXNXB1) !IOLD,JOLD ELSE BACKSPACE(MSCP) WRITE(MSCP,764)(OMEGAB(K),K=0,MXNXB1) BACKSPACE(MSCP) READ(MSCP,765)(XMANT(K),IEXP(K),K=0,MXNXB1) WRITE(25,F762)INEW,JNEW !IOLD,JOLD X ,(XMANT(K),IEXP(K),K=0,MXNXB1) ENDIF ENDIF C 373 JOLD=JOLD+1 IF(JOLD.Gt.IOLD-ione.or.JOLD.GT.IIMX.and.nmeta0.ne.0)THEN 372 IOLD=IOLD+1 IF(IOLD.GT.lupe)THEN !NENERG !TERMINATE WRITE(25,F762)-1 WRITE(25,F762)-1,-1 if(.not.badas)then !adas skip comments WRITE(25,758) NREC=1 121 NREC=NREC+1 BACKSPACE(5) BACKSPACE(5) READ(5,766)CARD4 IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 121 REWIND(5) DO N=1,NREC READ(5,760)CARD WRITE(25,759)CARD ENDDO DO I=1,8 DATE(I)=' ' ENDDO CALL DATE_AND_TIME(DATE8) !F95 WRITE(25,763)DATE(7),DATE(8),DATE(5),DATE(6),DATE(3) X ,DATE(4) endif DO M=MSC0,MSC CLOSE(M) ENDDO IF(.NOT.BEXP)CLOSE(MSCP) ELSE IF(IORIG(IOLD).LT.0)GO TO 372 JOLD=IIMN !1 JNEW=IIMN !1 INEW=INEW+1 GO TO 371 ENDIF ELSE IF(IORIG(JOLD).LT.0)GO TO 373 JNEW=JNEW+1 GO TO 371 ENDIF ENDIF C C DE-ALLOCATE C 7450 CONTINUE C !F95 IF(BOMRC)THEN !F95 DEALLOCATE (OMR,OMC,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR OMR,OMC' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BOMRC=.FALSE. !F95 ENDIF !F95 C !F95 IF(ALLOCATED(IDY))THEN !F95 DEALLOCATE (IDY,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR IDY' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(ALLOCATED(OMEGA))THEN !F95 DEALLOCATE (OMEGA,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR OMEGA' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(.NOT.BFOTJ.AND.ALLOCATED(DVECF))THEN !F95 DEALLOCATE (DVECF,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR DVECF' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 ENDIF !F95 C !F95 IF(BPOS)THEN !F95 DEALLOCATE (NPOS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DIAGON: DE-ALLOCATION FAILS FOR NPOS' !F95 NF=MIN(NF,0) !F95 ENDIF !F95 BPOS=.FALSE. !F95 ENDIF !F95 C IF(NF.LE.0)GO TO 750 !RETURN C C UPDATE FUNCTIONAL (RE-ENTRY POINT IF NO RADIATION) C IF(NGF.NE.0)SGF=DTWO*SGF/NGF 745 DRY=DF IF(IOPTIM.EQ.0)DRY=DRY+DECORE DRY=DRY*DTWO IF(BPRNT0)WRITE(6,999)INCLUD,DRY,SGF,NGF,JPRINT !.AND.INCLUD.NE.0 IF(JPRINT.EQ.-2)THEN DF=SGF if(includ.ne.0)WRITE(6,998) DECORE=DZERO ENDIF C C WRITE TERMINATORS C 750 IF(MODE.GT.0)THEN IF(BPRNT0)WRITE(MW,512)MBLK IF(.NOT.BPRNT0)WRITE(MWU)MZERO,MZERO,MZERO,MZERO,MZERO X ,MZERO,DZERO,DZERO,DZERO ENDIF IF(.NOT.BFOTJ)THEN IF(BPRNT0)WRITE(MWW,512)MBLK IF(.NOT.BPRNT0)WRITE(MWWU)MZERO,MZERO,MZERO,MZERO,MZERO,MZERO X ,DZERO,DZERO,DZERO ENDIF C C CLOSE SOME FILES C IF(IUNIT(1).GT.0)THEN CLOSE(1) IUNIT(1)=-1 ENDIF IF(IUNIT(4).GT.0)THEN CLOSE(4) IUNIT(4)=-1 ENDIF IF(IUNIT(21).GT.0)THEN CLOSE(21) IUNIT(21)=-1 ENDIF IF(IUNIT(23).GT.0)THEN CLOSE(23) IUNIT(23)=-1 ENDIF IF(IUNIT(25).GT.0)THEN CLOSE(25) IUNIT(25)=-1 ENDIF C C RETURN C C 2000 IF(NF.GT.0)NF=-1 GO TO 7600 !DE-ALLOCATE C 3000 IF(NF.GT.0)NF=-1 GO TO 7450 !DE-ALLOCATE C C DIMENSION EXCEEDED, ABORT C 710 WRITE(6,984)MC,MAXUC WRITE(0,*)'INSUFFICIENT TF COEFFICIENTS OR REDUCED MATRX ELEMENTS' GO TO 2000 990 WRITE(6,980)MAXDI,NC,MAXUC,MM C NF=-2 C DF=DZERO WRITE(0,*)'SR.DIAGON: DIMENSION EXCEEDED - MAXDI OR MAXUC' GO TO 2000 C C*********************************************************************** C 70 FORMAT(I6,' CALC ',F10.1,' OBS ',F10.1, ' SQ-DIF.SUM',E16.5) 100 FORMAT(88X, 'R OF 3 LAST P(R):',3F9.4) 180 FORMAT(' ',4I3,F14.5,F14.6,2I3,I4,1X,10F8.4/(52X,10F8.4)) 200 FORMAT(// ' GAM ( N, L,NION, Z,SIG/D/P) EPSILON/RY <1/R> X (ADJUST, REND, 3 LAST P), IN X',I7,' STEPS') 201 FORMAT(// ' GAM ( N, L,NION, Z,Q.D/D/P) EPSILON/RY <1/R> X (ADJUST, REND, 3 LAST P), IN X',I7,' STEPS') 250 FORMAT(5I4,F9.5,F13.5,1X, 3F9.5,2F9.4, 2X,F8.4,F6.2,1X,3(1PE9.2)) 301 FORMAT(22X,'2MXLBD=',I3) 400 FORMAT (// ' T,2S+1L (P) H(ZZ)/2RY EIGEN-H/2RY CF NI NO X MATRIX AND H(Z)/2RY-TRIANGLE. E(CORE)/2RY =',F10.5, XF11.4) 500 FORMAT(1X,I4,A4,2I4,1PE15.3,0PF14.7,F16.6,3X,2F10.5,F12.4,4F12.4) 501 FORMAT( 6I5,1PE15.5 ,2(0PF15.6)) 502 FORMAT(1X,4X,I4,2I4,1PE15.3, 2(0PF15.4)) 503 FORMAT(60X,F15.6) 504 FORMAT(4X,'NA',2X,'W',3X,'T TP',8X,'AA*SEC',6X,'ECONT(A.U)', X7X,'E-I(A.U)') 505 FORMAT(8X,'I-S',12X,'C-S',11X,'AUTO-IONIZATION DATA',7X,'Z=',I2, X3X,'N=',I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',4X,'W',6X,'AA*SEC' X,9X,'E-C(RYD)',6X,'E-I(RYD)') 506 FORMAT(5I5,4X,'X',1PE15.5,2(0PF15.6)) 507 FORMAT(I3,'CFLS',2X,'G',3X,'Z=',I2,4X,'N=',I2,2X,'NL',62(I3,I2)) 508 FORMAT(8X,'I-S',12X,'G-S',15X,'RADIATIVE DATA',9X,'Z=',I2,3X,'N=' X,I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',4X,'W',6X,'AR*SEC', 9X, X'DEL(RYD)',6X,'E-G(RYD)') 509 FORMAT('+',67X, '(AA DATA INCLUDES TERM ENERGY CORRECTION)' ) 510 FORMAT(4X,'NTERM=',I5,39X,'E1/RY=',F15.6/4X,'I',4X,'T',6X,'2S+1' X,4X,'L',8X,'CF',5X,'(EI-E1)/RY') 511 FORMAT(2I5,5X,2I5,5X,I5,F15.6) 512 FORMAT(A4) 514 FORMAT(I3,' E(RYD) ' ,2X,'Z=',I2,4X,'N=',I2,5X,'LS-Coupling' X,11X,'EIONMIN=',F15.6) 515 FORMAT(5(1PE15.5)) 516 FORMAT(8X,'I-S',12X,'C-S',10X,'PHOTO-IONIZATION DATA',7X,'Z=',I2 X,3X,'N=',I2/3X,'CF',4X,'T',4X,'W',3X,'CF',4X,'T',3X,'EO',6X X,' P/CM2',9X,'E-I(RYD)',6X,'E-C(RYD)') 517 FORMAT(2I5,4X,I1,I2,1X,10(I2,A1)) 518 FORMAT(I4,3I3,1PE14.6) 519 FORMAT(I4,' TERMS AMONG',I4,' (KCUT=',I2,')') 520 FORMAT(I5,' LS TERMS',I5,36X,A4// X' TERM 2S+1 L PI ENERGY(RYD) ORIG. TERM #') 521 FORMAT(4I7,F16.7,I15) 531 FORMAT(3I6,I3,100(I3,I2)) 532 FORMAT(2I6,F13.3) 536 FORMAT('*** SR.DIAGON: INCREASE INTERNAL DIMENSION MXSTRG TO',I3) 537 FORMAT(' &ADASEX NTERM= XXX',' &END') !,I3 540 FORMAT('NAME:'/'DATE:'/'.') 541 FORMAT(A2,'+',I2,2I10,F15.4,A4) 600 FORMAT(/' E',I1, '-DATA I IP', 6X, 'A(EK)*SEC S ', X 12X,'G*F',8X,'F(ABS) -F(EMI) WAVEL/AE', X 5X,'GF(VEL) V(GFL*GFV)',5X,'GF(ACC)',2X,'ALPHA(POL)') 701 FORMAT(/ ' GAM I(A,C) = ONE-BODY INTEGRALS') 702 FORMAT(1X,I3,9F14.7/(4X,9F14.7)) 711 FORMAT(1P,5E16.6) 713 FORMAT(1PE14.8,6E11.3/(14X,6E11.3)) 758 FORMAT('C',79('-')/'C'/'C') 759 FORMAT('C ',A200) 760 FORMAT(A200) 763 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X X ,'AUTOSTRUCTURE PLANE-WAVE BORN'/ X 'C'/'C NAME:'/'C DATE: ',2(A1),'/',2(A1),'/',2(A1)/ X 'C'/'C',79('-')) 764 FORMAT(22(1PE9.2)) 765 FORMAT(22(A5,1X,A3)) 766 FORMAT(A4) 767 FORMAT(I6,40(F6.3)) 768 FORMAT(/"CONFIGURATION OVERLAP MATRIX (SET TO ZERO IF CF'S DIFFER" X," BY MORE THAN 2 PAIRS) CASE IRLX=2:"/6X,40(I6)) 800 FORMAT(/' E',I1, '-DATA I IP', 6X, 'A(EK)*SEC S ', X 4X,'10**',I1,'*',' G*F',7X,'*F(ABS) -F(EMI) WAVEL/AE', X 4X,'*GF(VEL) *V(GFL*GFV)',4X,'*GF(ACC)',3X,'OMG(BORN)') 897 FORMAT(1X,I5) 898 FORMAT(' ',I8, ' USED, MXAAI=',I8) 899 FORMAT('*****STORAGE EXCEEDED IN SR.DIAGON, INCREASE MXAAI TO',I8) 900 FORMAT( ' CORE CONTRIB. ',F12.4,F12.5) 901 FORMAT(//9X, 'ONE-BODY RELATIVISTIC CORRECTIONS TO INDIVIDUAL ORB XITALS IN UNITS OF 2*RY',35X,'LS.JPRINT =',I4/9X, 'GAM N L X E(NON.REL)',8X,'E(MASS)',6X,'E(DAR)',7X,'E(TOT)',23X,'') 902 FORMAT(7X,3I5,F14.6,3X,2F12.6,F13.7,20X,F12.6) 903 FORMAT(/ ' ONE-BODY RELATIVISTIC INTEGRALS'/ ' I(R) I( A, C ) X= ',6X,'MASS',9X,'DARWIN',24X,'') 904 FORMAT(I5,3X,2I4,3X,2F14.7,16X,F14.7) 980 FORMAT(/ ' SR.DIAGON: IF MAXDI =',I5,'.LT.',I5, ' INCREASE M XAXDI'/ ' ********* IF MAXUC=',I7,'.LT.',I7, ' INCREASE *MAXUC') 981 FORMAT(' S L P',3X,'CF',3X,'NI',7X,'ENERGY(RYD)') 984 FORMAT(/ ' SR.DIAGON MAXUC=',I7, ' REQUIRED FOR ARRAY TFU'/20X X,I6, ' INSUFFICIENT TO COMPUTE RADIATIVE TRANSITION DATA') 989 FORMAT(//'*** ATTN: BECAUSE BORN MULTIPOLES ARE BEING COMPUTED' X,' FOR NON-E1 TRANSITIONS, RADIATIVE DATA IS NOT COMPUTED FOR', X' THOSE E3 TRANSITIONS'/10X,'FOR WHICH E1 DATA ALREADY' X,' EXISTS (SO AS NOT TO OVERWRITE THE E1-LIMIT)'/) 991 FORMAT(/' *** WORKING ARRAYS TOO SMALL IN SR.DIAGON, INCREASE', X' MXAAI TO:',I6/' *** OR REDUCE NUMBER OF SPECTROSCOPIC TERMS') 992 FORMAT(3I2,I5,I5,F18.6,3X,A4) 993 FORMAT(90X, 'TERM ENERGY ',A24) 994 FORMAT(' ',85X,I5,F10.0,F11.6,F14.6) 995 FORMAT(2I10,F13.0,I5,I2,I5,A4,F8.3,F18.6) 996 FORMAT(9X,'I',8X,' T',8X,'K*CM',2X, '2S+1 L CF',5X,'WEIGHTS',8X, X '(EI-E1)/RY E1/RY =',F14.6) 997 FORMAT(//I6, ' (IF .GT. 0: LOWEST STAT-WEIGHTED) TERMS ARE X MINIMIZED; SCALING PARAMETERS ',5F9.5,/((84X,5F9.5))) 998 FORMAT(68X, '*WARNING* G WILL BE MINIMIZED, AS JPRINT=-2') 999 FORMAT(//9X,'INCLUD =',I5,9X, 'FUNCTIONAL F =',1PE14.7,9X, 'FUNCT XIONAL G =',E10.3,' (',I4, ' TRANSITIONS)',9X, 'LS.JPRINT=',I2//) 1000 FORMAT( ' SR.DIAGON DOES NOT CALCULATE E-ENERGIES (OR RATES) SINC XE MPRINT= ',I2/' ************************************************' X'****************** ') 1001 FORMAT( ' *****ERROR IN SR.DIAGON, IT IS NOT POSSIBLE TO RUN MDEL X .LT. 0 AND BDR .TRUE. AS PROGRAMMED ') 1002 FORMAT(33X,I1,'-POLE PERTURBED TFDA POTENTIAL SCALING PARAMETERS ' X,5F9.5,/((84X,5F9.5))) 1603 FORMAT(2X,2I5,I4,10X,9(I2,I1)) 1604 FORMAT(//1X,'LIST OF CFS THAT CONTRIBUTE AN ENERGY GREATER THAN ' X,F7.0,' /CM'//) 1605 FORMAT('*** SR.DIAGON: COULD ACCESS MEMORY FASTER IF MXD30=',I7) 1749 FORMAT(//'*** FILE "ITANAL" WRITTEN FOR: ITANAL=',I6,5X,'ECNTRB=' X,F12.2,' /CM'/) 1750 FORMAT(1X,2I5,F10.5,F15.2,F12.2,5X,9(I2,I1)) 1751 FORMAT(//1X,'TERM NUMBER',I4,' SLP = ',2I3, X ' ENERGY =',F15.2,' /CM'/ X 1X,'***************'// X 1X,' T CF COEFF ENERGY-DIFF', X ' ENERGY-CNTRB ELECTRON CF'/) 3005 FORMAT (/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,' GAM N L', +3X,'VACUUM POLARIZ.',6X,'SELF ENERGY',9X,'TOTAL') 3010 FORMAT (8X,3I5,3(2X,F15.7),2F10.5) C END C C ******************* C SUBROUTINE DIFF (A,B,NH,HN,JH) C C----------------------------------------------------------------------- C C SR.DIFF COMPUTES THE FIRST DERIVATIVE OF ARRAY A INTO ARRAY B, USING C A 7 POINT LAGRANGE FORMULA. C REFERENCE: W.G. BICKLEY, MATH.GAZ.25, 19-27 (1941). C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C DIMENSION A(*),B(*),HN(JH),NH(JH) C C** REGULAR RADIAL WAVE FUNCTION TO ORBITAL L ASSUMED IF L.GE.0 C** IF(L.LT.0) GO TO 5 --- PB0,QB0,Z,D ALSO DOUBLE PRECISION C** J=L+1 // F=Z*PB0/J // DO 4 K=1,2 // D=K*HN(1) C**4 B(K)=((((J+2)*(Z*F-QB0/2))/(2*J+1)*D-(J+1)*F)*D+J*PB0)*D**L C**5 CONTINUE C N=0 C DO J=1,JH F=1/(60*HN(J)) NA=N+1 C** IF(L.GE.0 .AND. N.EQ.0) GO TO 6 K=NA B(NA)=(-147*A(K)+360*A(K+1)-450*A(K+2)+400*A(K+3)-225*A(K+4) X +72*A(K+5)-10*A(K+6))*F B(NA+1)=(-10*A(K)-77*A(K+1)+150*A(K+2)-100*A(K+3)+50*A(K+4) X -15*A(K+5)+2*A(K+6))*F C**6 CONTINUE B(NA+2)=(2*A(K)-24*A(K+1)-35*A(K+2)+80*A(K+3)-30*A(K+4)+ X 8*A(K+5)-A(K+6))*F N=NH(J)+N NB=N-6 C DO K=NA,NB B(K+3)=(((A(K+4)-A(K+2))*5+A(K+1)-A(K+5))*9+A(K+6)-A(K))*F ENDDO C K=NB NB=N B(NB-2)=(A(K)-8*A(K+1)+30*A(K+2)-80*A(K+3)+35*A(K+4)+24* X A(K+5)-2*A(K+6))*F B(NB-1)=(-2*A(K)+15*A(K+1)-50*A(K+2)+100*A(K+3)-150*A(K+4) X +77*A(K+5)+10*A(K+6))*F B(NB)=(10*A(K)-72*A(K+1)+225*A(K+2)-400*A(K+3)+450*A(K+4) X -360*A(K+5)+147*A(K+6))*F ENDDO C RETURN END C C ******************* C SUBROUTINE DIMUSE(NAME,NDIMEN) C IMPLICIT REAL*8 (A-H,O-Z) C C----------------------------------------------------------------------- C C SR.DIMUSE C NDIMEN.GT.0 STORES THE MAX VALUE OF THE PRIMARY DIMENSION NAME. C NDIMEN.LE.0 RETURNS THE MAX VALUE OF THE PRIMARY DIMENSION NAME. C C----------------------------------------------------------------------- C INCLUDE './PARAM' C CHARACTER KNAM*5,NAME*5 C COMMON /NRBDIM/MXUSED(MXDIM),KNAM(MXDIM) C DO K=1,MXDIM IF(NAME.EQ.KNAM(K))THEN IF(NDIMEN.GT.0)THEN MXUSED(K)=MAX(MXUSED(K),NDIMEN) ELSE NDIMEN=MXUSED(K) ENDIF RETURN ENDIF ENDDO C SHOULD NEVER GET HERE! WRITE(6,*)'SR.DIMUSE: DIMENSION NAME NOT FOUND ',NAME STOP 'SR.DIMUSE: DIMENSION NAME NOT FOUND' C END C C ******************* C SUBROUTINE DIPOL(JSW,N1,N2,E2,LMAX,CP,CM,JC) C C----------------------------------------------------------------------- C C ALAN BURGESS DAMTP CAMBRIDGE, MODS BY NRB. C C SR.DIPOL CALCULATES SQUARES OF HYDROGENIC DIPOLE LENGTH RADIAL MATRIX C ELEMENTS FOR BOUND-BOUND OR BOUND-FREE TRANSITIONS. C C BOUND STATES ARE NORMALISED TO UNITY. C FREE STATES ARE NORMALISED TO ASYMPTOTIC AMPLITUDE K**(-0.5). C C N.B. DIPOLE ACCELERATION MATRIX ELEMENT = (E12**2/4Z) * DIPOLE LENGTH C WHERE E12 = - N1**(-2) + N2**(-2) FOR BOUND-BOUND C = - N1**(-2) + E2 FOR BOUND-FREE C Z = REDUCED CHARGE C INPUT: C FOR BOUND-BOUND,SET JSW=NEGATIVE C N1,N2=PRINCIPAL QUANTUM NUMBERS OF STATES C LMAX=RANGE OF ANGULAR MOMENTUM QUANTUM NUMBERS C FOR BOUND-FREE, SET JSW=POSITIVE C N1=BOUND STATE PRINCIPAL QUANTUM NUMBER C E2=FREE STATE ENERGY IN RYDBERGS (=K**2) C C OUTPUT: C VECTOR CP(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR C MOMENTUM TRANSITIONS FROM L-1 TO L, C VECTOR CM(L),L=1,LMAX,CONTAINS SQUARED MATRIX ELEMENTS FOR ANGULAR C MOMENTUM TRANSITIONS FROM L TO L-1, C IN BOTH CASES THE TRANSITION IS FROM LOWER TO HIGHER C ENERGY, INDEPENDANT OF THE SIGN OF N1-N2 FOR BOUND-BOUND C CASES. IF N1=N2 THEN CP(L)=CM(L). C VECTOR JC(L),L=1,LMAX WILL USUALLY BE ZERO AND MAY THEN BE IGNORED, C BUT FOR EXTREME INPUT VALUES THERE IS POSSIBILITY OF C OVER OR UNDERFLOW OF CP(L) OR CM(L),IN WHICH CASE THE C OUTPUT VALUES OF CP(L) AND CM(L) SHOULD BE MULTIPLIED C BY (1.0D10)**JC(L) TO OBTAIN TRUE VALUES. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) C PARAMETER (PI=3.14159265359D0) PARAMETER (S1=1.0D10) PARAMETER (S2=1.0D-10) PARAMETER (TEST1=1.0D-20) PARAMETER (TEST2=1.0D20) PARAMETER (TEST3=0.044D0) PARAMETER (TEST4=0.1D0) PARAMETER (TEST5=300.0D0) PARAMETER (TEST6=1.0D-30) PARAMETER (TEST7=1.0D30) C DIMENSION CP(LMAX),CM(LMAX),JC(LMAX) C PI=ACOS(-DONE) C N=N1 E=E2 IF(JSW.LE.0)THEN EN2=N2 N3=N2 IF(N1.EQ.N2)GO TO 59 IF(N2.LT.N1)THEN N=N2 EN2=N1 N3=N1 ENDIF E=-DONE/(EN2*EN2) ENDIF C EN=N ENN=EN*EN E1=-DONE/ENN JMAX=LMAX C1=DONE C2=DZERO JS=0 L=N+1 IF(N.LE.LMAX)THEN CP(N)=DONE CM(N)=DZERO JC(N)=0 JMAX=N-1 DO I=L,LMAX CP(I)=DZERO CM(I)=DZERO JC(I)=0 ENDDO ENDIF C 9 L=L-1 IF(L.GT.1)THEN EL=L ELL=EL*EL T1=DONE+ELL*E1 T2=DONE+ELL*E T3=L+L-1 T4=DONE/(T3+DONE) T5=(T3*T1*C2+T2*C1)*T4 C1=(T1*C2+T3*T2*C1)*T4 C2=T5 11 IF(C1*C1.GT.TEST2)THEN C1=S2*C1 C2=S2*C2 JS=JS+1 GO TO 11 ENDIF IF(L.LE.LMAX+1)THEN CP(L-1)=C1 CM(L-1)=C2 JC(L-1)=JS ENDIF GO TO 9 ENDIF C JS=0 T=4 T=DONE/(T*EN*ENN) IF(JSW.LE.0)THEN !JSW.LT.0 ENN2=EN2*EN2 T1=4 T1=T1*ENN*ENN2/(ENN2-ENN) T1=T1*T1 T=T*T1*T1/(EN2*ENN2) IF(N3.LE.30)THEN T=T*((EN2-EN)/(EN2+EN))**(N3+N3) GO TO 34 ENDIF E21=E/E1 IF(E21.LE.TEST4)THEN T2=DZERO DO J=1,11 T3=2*(11-J)+1 T2=DONE/T3+T2*E21 ENDDO T2=T2+T2 ELSE T3=EN/EN2 T2=LOG((DONE+T3)/(DONE-T3))/T3 ENDIF T2=T2+T2 T1=T1*EXP(-T2) C ELSE !JSW.GT.0 C T1=4 T1=T1*ENN/(DONE+ENN*E) T1=T1*T1 T=T*T1*T1 IF(E.LT.TEST3)THEN T3=2 T=T*(PI/T3) ELSE T4=SQRT(E) IF(T4.LE.TEST5)THEN T3=(PI+PI)/T4 T3=DONE-EXP(-T3) T3=DONE/T3 ELSE T4=PI/T4 T3=3 T3=(DONE+T4+T4*T4/T3)/(T4+T4) ENDIF T2=2 T=T*(PI*T3/T2) ENDIF C T4=ENN*E IF(T4.LE.TEST4)THEN T2=DZERO DO J=1,11 T3=2*(11-J)+1 T2=DONE/T3-T2*T4 ENDDO ELSE T3=SQRT(T4) T2=ATAN(T3)/T3 ENDIF T2=T2+T2 T2=T2+T2 T1=T1*EXP(-T2) ENDIF C !ALL JSW 34 DO J=1,N TJ=J+J T2=TJ*(TJ-DONE) T2=T2*T2 T=T*T1/T2 35 IF(T.LE.TEST1)THEN T=T*S1 JS=JS-1 GO TO 35 ENDIF 37 IF(T.GE.TEST2)THEN T=T*S2 JS=JS+1 GO TO 37 ENDIF ENDDO J=0 C 40 J=J+1 IF(J.LE.JMAX)THEN TJ=J TJ=TJ*TJ T1=DONE+TJ*E1 T2=DONE+TJ*E T3=CP(J) T3=T2*T*T3*T3 T4=CM(J) T4=T1*T*T4*T4 L1=JC(J)+JC(J)+JS C 42 IF(L1.LT.0)THEN IF(T4.GT.TEST6)THEN L1=L1+1 T3=T3*S2 T4=T4*S2 GO TO 42 ENDIF ELSEIF(L1.GT.0)THEN IF(T3.LT.TEST7)THEN L1=L1-1 T3=T3*S1 T4=T4*S1 GO TO 42 ENDIF ENDIF C CP(J)=T3 CM(J)=T4 JC(J)=L1 T=T*T1*T2 48 IF(T.GT.TEST2)THEN T=T*S2 JS=JS+1 GO TO 48 ENDIF GO TO 40 ENDIF C IF(N.LE.LMAX)THEN T2=DONE+ENN*E T3=CP(N) T3=T2*T*T3*T3 L1=JC(N)+JC(N)+JS C 52 IF(L1.LT.0)THEN IF(T3.GT.TEST6)THEN L1=L1+1 T3=T3*S2 GO TO 52 ENDIF ELSEIF(L1.GT.0)THEN IF(T3.LT.TEST7)THEN L1=L1-1 T3=T3*S1 GO TO 52 ENDIF ENDIF C CP(N)=T3 JC(N)=L1 ENDIF C RETURN C 59 JMAX=LMAX IF(N.LE.LMAX)THEN DO L=N,LMAX CP(L)=DZERO CM(L)=DZERO JC(L)=0 ENDDO JMAX=N-1 ENDIF T1=9 T2=4 T3=(T1/T2) T1=EN2*EN2 T2=T1*T3 DO J=1,JMAX TJ=J JC(J)=0 T=T2*(T1-TJ*TJ) CP(J)=T CM(J)=T ENDDO C RETURN END C C ******************* C SUBROUTINE DISKDC(IU,DC,IDC,ISTRT,IFIN,KF,NGSYM,IRW,MSTRT0) C C----------------------------------------------------------------------- C C SR.DISKDC READS/WRITES TO AN UNFORMATTED UNIT=IU FILE. C ALL WRITES TAKE PLACE BEFORE ALL READS, SO IS SEQUENTIAL C AND, UNLESS SINGLE STAGE RESTART (MSTRT0.GT.IRL5=6), 'SCRATCH'. C C IRW.EQ.0 ALLOWS OPEN/CLOSE/REWIND OF FILE ETC - SEE BELOW C .GT.0 READ A SLICE OF THE DC (& IDC) ARRAYS C .LT.0 WRITE " " " C FROM C ISTRT TO IFIN (IN THE CASE OF READ, IFIN IS OUTPUT ONLY) C FOR C KF CONFIG C NGSYM SLP SYMMETRY GROUP INDEX WITHIN THE CONFIG C C MSTART IS USED TO FLAG FILE STATUS AT C OPEN: REPLACE/OLD C CLOSE: KEEP/DELETE C (MOST OBVIOUSLY FOR THE USUAL RESTART, BUT MORE GENERALLY AS WELL.) C C RELEVANT COMMON VARIABLES: C MDCF8 CONTAINS THE TOTAL NUMBER OF VCC'S (DC ARRAY) FOR KF C MDCFT8 CONTAINS THE SUM OF MDCF8 OVER ALL CONFIGS. C MDCBUF CONTAINS THE CURRENT DC SLICE LENGTH: C DURING WRITE IT LOGS THE MAX LENGTH OF SLICE OF ARRAY DC USED C AND DURING READ IT CHECKS IFIN DOES NOT EXCEED IT (=MAXDC FOR F77) C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD14=100) C REAL*8 DC DIMENSION DC(0:*),IDC(*) C INTEGER*8 MDCF8,MDCFT8 C PARAMETER (DZERO=0.0D0) C PARAMETER (LREC=2**15) C LOGICAL BFAST,BDSKLP,BSEQ C CHARACTER(LEN=2) NAME0 CHARACTER(LEN=8) FILNAM CHARACTER(LEN=9) STATLB cparc !par cpar character(len=1) :: num(0:9) !par C DIMENSION NPTS0(MAXSL*MAXCF) !ALLOCATE TBD along with /NRBGCF/ DIMENSION IREC(MAXSL*MAXCF) !FOR DIRECT ACCESS ONLY C COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBUNI/IUNIT(MXD14),NUNIT cparc !par cpar data num/'0','1','2','3','4','5','6','7','8','9'/ !par C DATA BDSKLP/.FALSE./,BSEQ/.FALSE./ C SAVE KF0,NPOS0,npos1,npos2,istrt1,ifin1,istrt2,ifin2,NPTS0 X ,IREC,IRECW C C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C IF(.NOT.BSEQ)THEN !DIRECT ACCESS IRECL=8*LREC !*8 DC IF(.NOT.BFAST)IRECL=IRECL+4*LREC !*4 IDC ENDIF C IF(IRW.EQ.0)THEN !INITIALIZE I/O C KF0=9999 NPOS0=0 npos1=-1 npos2=-1 C IRL5=6 !5+1 NOW ALG3/4 SEPARATE MSTRT=IABS(MSTRT0) MSTART=MOD(MSTRT,IRL5) MS1=1 IF(MSTRT.NE.0)MS1=MSTART/MSTRT C IF(IUNIT(IU).EQ.0)THEN !OPEN C IF(IU.EQ.32)THEN C IF(MSTART.EQ.0.OR.MSTART*MS1.EQ.1)THEN STATLB='SCRATCH' !AS NO RE-RESTART IF(BSEQ)THEN OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB) ELSE OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB X ,ACCESS='DIRECT',RECL=IRECL) IRECW=1 ENDIF ELSE NAME0='' cparc !par cpar i1=iam/10 !par cpar i2=iam-(10*(iam/10)) !par cpar name0=num(i1)//num(i2) !par cparc !par FILNAM='DISKDC'//NAME0 IF(MSTART.LE.1)THEN !.EQ.0 TEST KEEP STATLB='REPLACE' ELSE STATLB='OLD' ENDIF IF(BSEQ)THEN OPEN(IU,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB) ELSE OPEN(IU,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB X ,ACCESS='DIRECT',RECL=IRECL) IRECW=1 !ONLY FOR MSTART.LE.1 ENDIF ENDIF C ELSEIF(IU.EQ.33)THEN C CDSK FILNAM='DSKDMP' CDSK STATLB='REPLACE' CDSK OPEN(IU,FILE=FILNAM,FORM='UNFORMATTED',STATUS=STATLB) c if(mstart.ne.0)stop 'diskdc: illegal mstart (non-zero)' C STATLB='SCRATCH' !AS NO RESTARTX, MSTART=0 IF(BSEQ)THEN OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB) ELSE OPEN(IU,FORM='UNFORMATTED',STATUS=STATLB X ,ACCESS='DIRECT',RECL=IRECL) IRECW=1 ENDIF C ELSE ! should not be here write(6,*)'sr.diskdc: illegal unit number',iu stop'sr.diskdc: illegal unit number' ENDIF C IUNIT(IU)=1 C ELSEIF(IUNIT(IU).GT.0)THEN C IF(ISTRT.EQ.0)THEN !CLOSE IF(MSTART.GT.0.AND.MSTART.LT.4*(1-MS1))THEN !FOR 2/3/4 IUNIT(IU)=-1 ELSE !WE ARE DONE IUNIT(IU)=0 ENDIF IF(IUNIT(IU).LT.0)THEN CLOSE(IU,STATUS='KEEP') ELSEIF(IUNIT(IU).EQ.0)THEN CLOSE(IU,STATUS='DELETE') ENDIF ELSE !RE-INITIAL IF(NGSYM.GT.0)THEN KSL0=KGCF(KF-1)-KGCF(KUTDSK)+NGSYM NPTS=NPTS0(KSL0) IFIN=ISTRT+NPTS-1 ENDIF ENDIF C else !-1 write(6,*)'sr.diskdc: should not be here' stop'sr.diskdc: should not be here' ENDIF C ELSEIF(IRW.LT.0)THEN !SEQUENTIAL WRITE C NPTS=IFIN-ISTRT+1 MDCBUF=MAX(MDCBUF,NPTS) !CAN'T USE IFIN BECAUSE OF VCG BUFFER IF(KF.GT.KF0)THEN MDCFT8=MDCFT8+MDCF8 MDCF8=0 ENDIF KF0=KF MDCF8=MDCF8+INT(NPTS) c c write(0,*)kf,ngsym,istrt,ifin,npts,mdcbuf C KSL0=KGCF(KF-1)-KGCF(KUTDSK)+NGSYM !=KSL0+1 NPTS0(KSL0)=NPTS C IF(BDSKLP)THEN C write(6,*)kf,ngsym,npts IF(.NOT.BFAST)WRITE(6,101)(IDC(I),I=ISTRT,IFIN) WRITE(6,100)(DC(I),I=ISTRT,IFIN) ENDIF C IF(BSEQ)THEN WRITE(IU)(DC(I),I=ISTRT,IFIN) IF(.NOT.BFAST)WRITE(IU)(IDC(I),I=ISTRT,IFIN) ELSE IREC(KSL0)=IRECW I2=ISTRT-1 50 CONTINUE I1=I2+1 I2=MIN(I2+LREC,IFIN) IF(BFAST)THEN WRITE(IU,REC=IRECW)(DC(I),I=I1,I2) ELSE WRITE(IU,REC=IRECW)(DC(I),I=I1,I2),(IDC(I),I=I1,I2) ENDIF IRECW=IRECW+1 !POINTS TO NEXT AVAILABLE RECORD IF(I2.LT.IFIN)GO TO 50 ENDIF C ELSEIF(IRW.GT.0)THEN !READ C NREC0=1 !ONLY NEEDED FOR BSEQ, IF(.NOT.BFAST)NREC0=NREC0+1 !ELSE A VIRTUAL INDEX C KSL0=KGCF(KF-1)-KGCF(KUTDSK)+NGSYM NPOS=NREC0*(KSL0-1) !WHERE WE WANT TO BE c c test to see which buffer in use c npos0=0 !test c if(kutdsk.lt.kfbuff)then !whole group npos1=-1 npos2=-1 ibuff=0 !for variable length else !by cf c c then see if we already have it for quick return c if(npos.eq.npos1)then istrt=istrt1 ifin=ifin1 c write(77,*)npos,-kf,ngsym,istrt,ifin,npts c call flush(77) return elseif(npos.eq.npos2)then if(istrt.eq.mtgd1)then ifin=mtgd1-1 do i=istrt2,ifin2 ifin=ifin+1 dc(ifin)=dc(i) if(.not.bfast)idc(ifin)=idc(i) enddo istrt1=mtgd1 !trivially ifin1=ifin istrt=istrt1 ifin=ifin1 npos1=npos2 npos2=-1 !not necess. c write(79,*)npos,-kf,-ngsym,istrt,ifin,npts c call flush(79) return else istrt=istrt2 ifin=ifin2 c write(78,*)npos,kf,-ngsym,istrt,ifin,npts c call flush(78) return endif endif c c no we don't, so read c c ibuff=0 !for variable length (and see end of this if block) ibuff=(mdcbuf-mtgd1+1)/2 !for fixed length if(istrt.gt.mtgd1)istrt=mtgd1+ibuff !for fixed length endif C NPTS=NPTS0(KSL0) C IFIN=ISTRT+NPTS-1 IF(IFIN.GT.MDCBUF)THEN WRITE(6,102)IFIN,MDCBUF WRITE(0,*)' *** DISKDC ERROR: RECORD TO LONG FOR DC ARRAY' IFIN=-IFIN RETURN ENDIF c c write(76,*)npos,kf,ngsym,istrt,ifin,npts c call flush(76) C IF(BSEQ)THEN C IF(NPOS0.EQ.0)REWIND(IU) !FIRST READ C IF(NPOS.GT.NPOS0)THEN !PROGRESS THRU FINAL GROUPS DO N=NPOS0+1,NPOS READ(IU) ENDDO ELSEIF(NPOS.LT.NPOS0)THEN !+NREC0 !START A NEW INITIAL GROUP IF(NPOS0-NPOS.GT.NPOS)THEN REWIND(IU) DO N=1,NPOS READ(IU) ENDDO ELSE DO N=NPOS+1,NPOS0 BACKSPACE(IU) ENDDO ENDIF ENDIF C READ(IU)(DC(I),I=ISTRT,IFIN) IF(.NOT.BFAST)READ(IU)(IDC(I),I=ISTRT,IFIN) C NPOS0=NPOS+NREC0 C ELSE C IRECR=IREC(KSL0) I2=ISTRT-1 10 CONTINUE I1=I2+1 I2=MIN(I2+LREC,IFIN) IF(BFAST)THEN READ(IU,REC=IRECR)(DC(I),I=I1,I2) ELSE READ(IU,REC=IRECR)(DC(I),I=I1,I2),(IDC(I),I=I1,I2) ENDIF IRECR=IRECR+1 IF(I2.LT.IFIN)GO TO 10 c c if(.not.bfast)write(6,101)(idc(i),i=istrt,ifin) c write(6,100)(dc(i),i=istrt,ifin) C ENDIF c c - not currently used if(kutdsk.lt.kfbuff)... c if(istrt.eq.mtgd1)then npos1=npos istrt1=istrt !trivially ifin1=ifin if(ibuff.eq.0)npos2=-1 !reset unless fixed length else npos2=npos istrt2=istrt ifin2=ifin endif C ENDIF C RETURN C 100 FORMAT(10F8.4) 101 FORMAT(10I8) 102 FORMAT(/' *** DISKDC ERROR: ATTEMPT TO READ DC ARRAY TO',I9 X ,' WHICH EXCEEDS DIMENSION:',I9) C END C C +++++++++++++++++++ C SUBROUTINE DNAMP(A0,A,E,C,Q,U,Z,X,NMAX,JMAX) C C----------------------------------------------------------------------- C C N.R.BADNELL D.A.M.T.P. CAMBRIDGE C ALAN BURGESS D.A.M.T.P. CAMBRIDGE C C SR.DNAMP CALCS THE ASYMP. AMP. & ITS DERIVS. FOR A COULOMB FUNCTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D1M50=1.0D-50) C DIMENSION A(*),B(100),W(100),V(100) C ONEM=-DONE ONEQ=-DONE/DFOUR C X1=DONE/X X2=X1*X1 C F=-DTWO*Z*X1 G=-C*X2 D=-Q*X2*X1 H=-U*X2*X2 W0=E+F+G+D+H S=DONE C IF(W0.LT.D1M50)THEN W0=-W0 F=-F G=-G S=-S D=-D H=-H ENDIF C NMAX2=NMAX+2 C DO N=1,NMAX2 EN=N F=-EN*F*X1 G=-(EN+DONE)*G*X1 D=-(EN+DTWO)*D*X1 H=-(EN+DTHREE)*H*X1 W(N)=F+G+D+H ENDDO C CALL DNAQ(W0,W,A0,A,ONEQ,NMAX2,5) C DO J=1,JMAX C CALL DNAQ(A0,A,B0,B,ONEM,NMAX,3) C A0=A(2) DO N=1,NMAX A(N)=A(N+2) ENDDO C CALL DNPROD(A0,A,B0,B,V0,V,NMAX) C B0=W0+V0*S DO N=1,NMAX B(N)=W(N)+V(N)*S ENDDO C CALL DNAQ(B0,B,A0,A,ONEQ,NMAX,5) C ENDDO C RETURN END C C +++++++++++++++++++ C SUBROUTINE DNAQ(A0,A,B0,B,Q,NMAX,JSWICH) C C----------------------------------------------------------------------- C C ALAN BURGESS D.A.M.T.P. CAMBRIDGE C C SR.DNAQ: C GIVEN A0 AND ITS FIRST NMAX DERIVATIVES IN ARRAY A, AND GIVEN Q C AND NMAX, CALCULATES B0 AND ARRAY B, BEING THE VALUE AND FIRST C NMAX DERIVATIVES OF (A0)**Q C C FOR PERHAPS GREATER SPEED, YOU MAY SET JSWICH TO 2 IF Q IS -2.0 C JSWICH TO 3 IF Q IS -DONE C JSWICH TO 4 IF Q IS -0.5 C JSWICH TO 5 IF Q IS -0.25 C JSWICH TO 6 IF Q IS 0.25 C JSWICH TO 7 IF Q IS 0.5 C JSWICH TO 8 IF Q IS 2.0 C OTHERWISE SET JSWICH TO 1 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DONE=1.0D0) C DIMENSION A(*),B(*),W(100) C IF(JSWICH.LE.1)THEN B0=A0**Q ELSEIF(JSWICH.EQ.2)THEN B0=DONE/(A0*A0) ELSEIF(JSWICH.EQ.3)THEN B0=DONE/A0 ELSEIF(JSWICH.EQ.4)THEN B0=DONE/SQRT(A0) ELSEIF(JSWICH.EQ.5)THEN B0=DONE/SQRT(A0) B0=SQRT(B0) ELSEIF(JSWICH.EQ.6)THEN B0=SQRT(A0) B0=SQRT(B0) ELSEIF(JSWICH.EQ.7)THEN B0=SQRT(A0) ELSE B0=A0*A0 ENDIF C W(1)=Q C=DONE/A0 B(1)=Q*A(1)*B0*C C DO N=2,NMAX B(N)=Q*B0*A(N) W(N)=Q U=-DONE J1=N-1 DO J=1,J1 V=W(J) W(J)=U+W(J) U=V J2=N-J B(N)=B(N)+W(J)*A(J)*B(J2) ENDDO B(N)=C*B(N) ENDDO C RETURN END C C ******************* C SUBROUTINE DNPROD(A0,A,B0,B,C0,C,NMAX) C C----------------------------------------------------------------------- C C ALAN BURGESS D.A.M.T.P. CAMBRIDGE C C SR.DNPROD EVALUATES THE ASYMPTOTIC COULOMB AMPLITUDE. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DONE=1.0D0) C DIMENSION A(20),B(20),C(20),W(20) C C0=A0*B0 C DO N=1,NMAX C(N)=A0*B(N)+B0*A(N) ENDDO C W(1)=DONE U=DONE C DO N=2,NMAX W(N)=DONE JMAX=N-1 DO J=1,JMAX V=W(J) W(J)=U+W(J) U=V J1=N-J C(N)=C(N)+W(J)*A(J1)*B(J) ENDDO ENDDO C RETURN END C C ******************* C SUBROUTINE DWX C C----------------------------------------------------------------------- C C SR.DWX CALCULATES EIE COLLISION STENGTHS. C C IT CALLS: C SR.RADCX0 C SR.DWXLS C SR.DWXBP C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam,nproc, !par cpar A comm_barrier,comm_finalize !par C USE COMMON_DMQSS3, ONLY: BDMQSS3,DSS,MSS,QSS,NADR !F95 USE COMMON_DXRL, ONLY: BDXRL,DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_NRBNF1, ONLY: BNRBNF1,DEK,BFALL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD06=MXENG*MXENG) C CF77 PARAMETER (MDIM0=MXD06) !F77 CF77 PARAMETER (MDIM1=1*MAXB1) !1*MAXB1 IF .NOT. BREL2 !F77 CF77C PARAMETER (MDIM1=2*MAXB1) !2*MAXB1 IF BREL2... !F77 CF77 PARAMETER (MDIM2=MXENG) !F77 CF77 PARAMETER (MDIM3=MXLFR) !F77 CF77 PARAMETER (MDIM4=MAXRL) !F77 CF77 PARAMETER (MDIM5=MXLRL) !F77 CF77C UNCOMMENT IF BKUTOO=.FALSE. !F77 CF77 PARAMETER (MDIM6=1) !F77 CF77 PARAMETER (MDIM7=1) !F77 CF77 PARAMETER (MDIM8=0) !F77 CF77C UNCOMMENT IF BKUTOO=.TRUE. !F77 CF77C PARAMETER (MDIM6=MDIM0) !F77 CF77C PARAMETER (MDIM7=MDIM4) !F77 CF77C PARAMETER (MDIM8=MDIM5) !F77 CF77C UNCOMMENT IF BKUTSS=.FALSE. !F77 CF77 PARAMETER (MDIM9=1) !F77 CF77 PARAMETER (MDIM10=1) !F77 CF77C UNCOMMENT IF BKUTSS=.TRUE. !F77 CF77C PARAMETER (MDIM9=MDIM0) !F77 CF77C PARAMETER (MDIM10=MAXMI) !F77 c CF77 integer*8 nrk !F77 C LOGICAL BREL,BJUMPR,BMVD,BREL2,BKUTOO,BKUTSS C CF77 DIMENSION FRX(MDIM1,MDIM2,MDIM3) !F77 CF77 X ,PSHFTX(MDIM2,MDIM3) !F77 CF77 X ,DRLX(MDIM4,MDIM0,0:MDIM5) !F77 CF77 X ,DZLX(MDIM7,MDIM6,0:MDIM8) !F77 CF77 X ,DXTWOX(MDIM7,MDIM6,0:MDIM8) !F77 CF77 X ,DETAX(MDIM7,MDIM6,0:MDIM8) !F77 CF77 X ,DNLX(MDIM10,MDIM9) !F77 C ALLOCATABLE :: FRX(:,:,:),PSHFTX(:,:),DRLX(:,:,:) !F95 ALLOCATABLE :: DZLX(:,:,:),DXTWOX(:,:,:),DETAX(:,:,:) !F95 ALLOCATABLE :: DNLX(:,:) !F95 C COMMON /BASIC/NF,MGAP(11) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRNL/NL000,NL COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW7/MNDEX(MXD06,2),MRNDX(MXD06),MTRAN,mlim(mxeng,2) COMMON /NRBDW8/DYY0(MXENG),IYY0(MXENG),MENG0 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit c logical buse !,busi,btmp common /nrbuse/buse(mxeng) !,busi(mxeng,mxeng),btmp(mxeng,mxeng) C IF(NZION.EQ.0)RETURN !QUICK EXIT C BKUTOO=KUTOOX.NE.0 BKUTSS=KUTSSX.NE.-1.AND.MAXJFS.GE.0 BREL2=IABS(IREL).EQ.2 C CF77 IF(BREL2.AND.MDIM1.NE.2*MAXB1)THEN !F77 CF77 WRITE(0,*)' *** SR.DWX: SET MDIM1=2*MAXB1 FOR IREL=2,' !F77 CF77 X ,' OR USE THE F95 CODE' !F77 CF77 WRITE(6,*)' *** SR.DWX: SET MDIM1=2*MAXB1 FOR IREL=2,' !F77 CF77 X ,' OR USE THE F95 CODE' !F77 CF77 NF=-1 !F77 CF77 GO TO 900 !F77 CF77 ENDIF !F77 CF77 IF(BKUTOO.AND. !F77 CF77 X (MDIM6.NE.MDIM0.OR.MDIM7.NE.MDIM4.OR.MDIM8.NE.MDIM5))THEN!F77 CF77 WRITE(0,*)' *** SR.DWX: SET MDIM6,7,8=MDIM0,4,5 FOR NFS'!F77 CF77 X ,' OR USE THE F95 CODE' !F77 CF77 WRITE(6,*)' *** SR.DWX: SET MDIM6,7,8=MDIM0,4,5 FOR NFS'!F77 CF77 X ,' OR USE THE F95 CODE' !F77 CF77 NF=-1 !F77 CF77 GO TO 900 !F77 CF77 ENDIF !F77 CF77 IF(BKUTSS.AND. !F77 CF77 X (MDIM9.NE.MDIM0.OR.MDIM10.NE.MAXMI))THEN !F77 CF77 WRITE(0,*)' *** SR.DWX: SET MDIM9=MDIM0,' !F77 CF77 X ,' MDIM10.NE.MAXMI FOR FS' !F77 CF77 X ,' OR USE THE F95 CODE' !F77 CF77 WRITE(6,*)' *** SR.DWX: SET MDIM9=MDIM0,' !F77 CF77 X ,' MDIM10.NE.MAXMI FOR FS' !F77 CF77 X ,' OR USE THE F95 CODE' !F77 CF77 NF=-1 !F77 CF77 GO TO 900 !F77 CF77 ENDIF !F77 CF77 M=MAX(LCONDW,LCONDWJ) !F77 CF77 IF(M.GT.MXLFR)THEN !F77 CF77 WRITE(0,*)' *** SR.DWX: INCREASE MXLFR TO:',M !F77 CF77 WRITE(6,*)' *** SR.DWX: INCREASE MXLFR TO:',M !F77 CF77 NF=-1 !F77 CF77 GO TO 900 !F77 CF77 ENDIF !F77 CF77 IF(IABS(MODD).LE.1)THEN !F77 CF77 M=QMCS+1 !F77 CF77 IF(M.GT.MXLRL)THEN !F77 CF77 WRITE(0,*)' *** SR.DWX: INCREASE MXLRL TO:',M !F77 CF77 WRITE(6,*)' *** SR.DWX: INCREASE MXLRL TO:',M !F77 CF77 NF=-1 !F77 CF77 GO TO 900 !F77 CF77 ENDIF !F77 CF77 ENDIF !F77 C C----------------------------------------------------------------------- C if(iabs(modd).gt.1)WRITE(6,1000) if(iabs(modd).le.1)WRITE(6,2000) C C----------------------------------------------------------------------- c TBD recover orbital info: DPNL, DQNL, DORIG, DEY, DUY & RADIAL MESH c to implement RESTARTX - currently left from (single pass) target run. c viz. some/all of COMMON /RADF/, /NRBDQE/, /CRAD/, /NRBHF/, /NRBNUK/ C----------------------------------------------------------------------- C C----------------------------------------------------------------------- C C READ SCATTERING ENERGIES AND INDEX INTERACTING ENERGY PAIRS. C GENERATE THE UNIQUE CONTINUUM DW POTENTIAL AND CHECK THE RADIAL GRID. C CALL RADCX0 C IF(NF.LE.0)GO TO 900 IF(IRL.EQ.0)THEN WRITE(6,1001) GO TO 900 ENDIF c initialize flag of use of interpolation energies do m2=1,meng buse(m2)=.false. c do m1=1,meng c busi(m1,m2)=.false. c enddo enddo do m0=1,meng0 m=iyy0(m0) buse(m)=.true. c busi(m,m)=.true. enddo C C----------------------------------------------------------------------- C C NOW ALLOCATE BASED ON KNOWN NO OF POINTS (MAXRS), ENERGIES (MENG), C ENERGY PAIRS (MTRAN) AND INTEGRALS (IRL), FOR LSTORE+1 TOTAL L-VALUES. C LS COUPLING ONLY REQUIRES LSTORE=0. C !F95 if(iabs(modd).gt.1)then !F95 LSTORE=0 !F95 else !F95 LSTORE=QMCS+1 !F95 endif !F95 C !F95 MDIM0=MTRAN !F95 MDIM1=MAXRS !F95 IF(BREL2)MDIM1=2*MDIM1 !F95 MDIM2=MENG !F95 MDIM3=MAX(LCONDW,LCONDWJ) !F95 MDIM4=IRL !F95 MDIM5=LSTORE !F95 C !F95 ALLOCATE (FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3) !F95 X,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: ALLOCATION FAILS FOR DFRX,PSHFTX' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C !F95 ALLOCATE (DRLX(MDIM4,MDIM0,0:MDIM5),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: ALLOCATION FAILS FOR DRLX' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C !F95 IF(BKUTOO)THEN !F95 MDIM6=MDIM0 !F95 MDIM7=MDIM4 !F95 MDIM8=MDIM5 !F95 ELSE !F95 MDIM6=1 !F95 MDIM7=1 !F95 MDIM8=0 !F95 ENDIF !F95 C !F95 ALLOCATE (DZLX(MDIM7,MDIM6,0:MDIM8) !F95 X ,DXTWOX(MDIM7,MDIM6,0:MDIM8) !F95 X ,DETAX(MDIM7,MDIM6,0:MDIM8) !F95 X ,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: ALLOCATION FAILS FOR DZLX,DXTWOX,DETAX' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C !F95 IF(BKUTSS)THEN !F95 MDIM9=MDIM0 !F95 MDIM10=NL000 !F95 ELSE !F95 MDIM9=1 !F95 MDIM10=1 !F95 ENDIF !F95 C !F95 ALLOCATE (DNLX(MDIM10,MDIM9) ,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: ALLOCATION FAILS FOR DNLX' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C if(iabs(modd).gt.1)then c C----------------------------------------------------------------------- C C SR.DWXLS CALCULATES EIE NR (+2NFS) COLLISION STRENGTHS IN LS-COUPLING C CALL DWXLS(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,MDIM5 X ,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8) C IF(NF.LT.0)GO TO 999 C C----------------------------------------------------------------------- C else C C----------------------------------------------------------------------- C C SR.DWXBP CALCULATES EIE BP (+2FS) COLLISION STRENGTHS IN JK-COUPLING C CALL DWXBP(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4,MDIM5 X ,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8,DNLX,MDIM9,MDIM10) C IF(NF.LT.0)GO TO 999 C C----------------------------------------------------------------------- c endif C 999 CONTINUE c write use of interpolation energies c nskp=0 do m2=1,meng if(.not.buse(m2))then write(0,2001)m2,dyy(m2) write(6,2001)m2,dyy(m2) c else c do m1=1,meng c if(buse(m1).and.btmp(m1,m2).and..not.busi(m1,m2).and..not. c x busi(m2,m1))then c x write(6,*)'INTEGRAL PAIR NOT USED',m1,m2 c nskp=nskp+1 c endif c enddo endif enddo c if(nskp.gt.0)write(6,2002)nskp,mtran C !F95 C DE-ALLOCATE !F95 C !F95 DEALLOCATE (FRX,PSHFTX,DRLX,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: DE-ALLOCATION FAILS FOR FRX,PSHFTX,DRLX' !F95 NF=0 !F95 ENDIF !F95 C !F95 DEALLOCATE (DZLX,DXTWOX,DETAX,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: DE-ALLOCATION FAILS FOR DZLX,DXTWOX,DETAX' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C !F95 DEALLOCATE (DNLX,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: DE-ALLOCATION FAILS FOR DNLX' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C !F95 C EX-COMMON/DXRL/ !F95 if(.not.bdxrl)stop 'error DXRL not allocated' !F95 DEALLOCATE (DRK,QRL,NRK,NAD,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: DE-ALLOCATION FAILS FOR DRK,QRL,NRK,NAD' !F95 NF=0 !F95 ENDIF !F95 C !F95 C EX-COMMON/NRBNF1/ !F95 if(.not.bnrbnf1)stop 'error NRBNF1 not allocated' !F95 DEALLOCATE (DEK,BFALL,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWX: DE-ALLOCATION FAILS FOR DEK, BFALL' !F95 NF=0 !F95 ENDIF !F95 C !F95 IF(BKUTSS)THEN !F95 C !F95 C EX-COMMON/DMQSS3/ !F95 if(.not.bdmqss3)stop 'error DMQSS3 not allocated' !F95 DEALLOCATE (DSS,MSS,QSS,NADR,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*) !F95 X 'DWX: DE-ALLOCATION FAILS FOR DSS,MSS,QSS,NADR' !F95 NF=0 !F95 ENDIF !F95 ENDIF !F95 C C----------------------------------------------------------------------- C 900 RETURN C 1000 FORMAT(///1X,136('-')//50X,'*** COLLISION HAMILTONIAN (LS) ***' X //1X,136('-')//) 1001 FORMAT(//'*** NO INTERACTIONS/CHANNELS - BAILING-OUT ***') 2000 FORMAT(///1X,136('-')//50X,'*** COLLISION HAMILTONIAN (BP) ***' X //1X,136('-')//) 2001 FORMAT('*** INTERPOLATION ENERGY',I3,' NOT USED E=',F9.3) c 2002 format(/' NOTE:',I3,' OUT OF',I4, c X ' ENERGY INTEGRAL PAIRS WERE NOT USED') C END C C ******************* C SUBROUTINE DWXBP(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4 X ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8 X ,DNLX,MDIM9,MDIM10) C C----------------------------------------------------------------------- C C SR.DWXBP CALCULATES EIE BP (+2FS) COLLISION STRENGTHS IN JK-COUPLING C C IT CALLS: C SR.FSINTX C FN:NCHAJK C FN.QPTLS C FN.QPTLSJ C SR.RADCNX C FN.SJS C SR.SLATRX C SR.TOP1 C SR.TOP2 C FN.XINT C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam,comm_barrier !par cpar use mpi !par C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS,NADR !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD06=MXENG*MXENG) PARAMETER (MXD13=500) PARAMETER (MXD14=100) C PARAMETER (MXD1=MXENG/10, X MXD2=10/MXENG, X MXD3=MXD1+MXD2, X MXD4=MXENG*MXD1/MXD3+10*MXD2/MXD3+3) C PARAMETER (MXNXB=10) !NO. OF BPW X-VALUES PRE-EXISTING IN ADF04 c real*4 e1m10 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (D3O4=3.0D0/4.0D0) PARAMETER (E1M10=1.E-10) PARAMETER (D1M20=1.D-20) PARAMETER (D1M30=1.D-30) c c parameter (dfour=4.0d0) !x c parameter (dfsc=7.2973525333d-03) !x c parameter (dalf=dfsc*dfsc) !x c parameter (c4=dalf/dfour) !x C PARAMETER (XMIX=1.D-4) !not speed-sensitive C C THESE ARE ACTUAL MAX REQUIREMENTS BUT LARGE STRUCTURE RUNS WILL C OVERINFLATE. SINCE F95 TAKES CARE OF THIS BY ALLOCATE, NOT WORTH C ADDING NEW VARIABLES TO PARAM. JUST HARD-WIRE SAFE SMALL VALUES. C CF77C PARAMETER (NDIM0=MXD06) !F77 CF77C PARAMETER (NDIM1=MAXDK*MAXDK) !F77 CF77C PARAMETER (NDIM2=(MAXLV*(MAXLV+1))/2) !F77 CF77 PARAMETER (NDIM0=300) !F77 CF77 PARAMETER (NDIM1=3000) !F77 CF77 PARAMETER (NDIM2=20000) !F77 C INTEGER SA,SAP c CF77 integer*8 nrk,mss !F77 c real*4 omega,tolo cpar real*4 omsend,omrecv !par C LOGICAL BPRNT0,BPRNT2,BPRNT3,BKUTOO,BLS,BKUTSS,BTHRSH x ,btime,btimex,btimep x ,eqgrp,eqgrpl,eqgrpl0,b2fs,bnx,bcorr,becor,bcor !,eqgrpj x ,bunit,bht,brmx,bmix,bswap,bswapj,bntest,badas !,bswapt X ,BREL,BJUMPR,BMVD,BEXP CF77 X ,BFALL !F77 c logical brel,bjumpr,bmvd !x C CHARACTER(LEN=1) DATE CHARACTER(LEN=3) IEXP,IEXP0,IEXP1 CHARACTER(LEN=4) CARD4 CHARACTER(LEN=5) XMANT,XMANT0,XMANT1 CHARACTER(LEN=8) DATE8 !F95 character(len=9) orbfmt CHARACTER(LEN=15) F767 CHARACTER(LEN=35) F762 CHARACTER(LEN=44) F761 CHARACTER(LEN=200) CARD C DIMENSION DATE(8) DIMENSION IEXP(0:MXD4),XMANT(0:MXD4) C CF77 DIMENSION RHO1(NDIM0,NDIM1),RHO2(NDIM0,NDIM1) !F77 CF77 DIMENSION OMEGA(MXENG,NDIM2),TFU(MAXJU),TMPX(MAXDK) !F77 CF77 DIMENSION TEMP(NDIM0,MAXDK),OMGINF(NDIM2) !F77 C ALLOCATABLE :: RHO1(:,:),RHO2(:,:),OMEGA(:,:),TFU(:),TMPX(:) !F95 X ,TEMP(:,:),OMGINF(:) !F95 cpar allocatable :: omsend(:),omrecv(:) !par C DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3),PSHFT0(0:20) X ,DRLX(MDIM4,MDIM0,0:MDIM5) X ,DZLX(MDIM7,MDIM6,0:MDIM8) X ,DXTWOX(MDIM7,MDIM6,0:MDIM8) X ,DETAX(MDIM7,MDIM6,0:MDIM8) X ,DNLX(MDIM10,MDIM9) C DIMENSION QPX(0:MDIM5),QPX0(0:MDIM5),QPOSJ(MAXGR),DFS(MXDFS) DIMENSION NADRUG(MAXJG),NTGJ(MAXJG),TMP(MXENG,MXENG),OMP(MXENG) c dimension bswap(mxd13),bswapj(mxd13) dimension ntest(1,1) !check channel set-up C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NXRNL/NL000,NL c COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT c COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MGP1(2),KSUBCF COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW3/KACT(MAXCF,MAXCF) COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW6/QPOS(MAXGR),QPOS0(MAXGR) COMMON /NRBDW7/MNDEX(MXD06,2),MRNDX(MXD06),MTRAN,mlim(mxeng,2) COMMON /NRBDW8/DYY0(MXENG),IYY0(MXENG),MENG0 COMMON /NRBDW9/DSPECJ(MAXLV),INDXJ(MAXLV),JNDXJ(MAXLV),NSPECJ X ,NENERJ COMMON /NRBDWJ/JSYMM(MXSYJ,MAXJG),NCHGJ(MAXJG),NADGJ(MAXJG) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) !target COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /WORKJ/DWRK(MAXLV),IWRK3(MAXLV) !,IWKR4(MAXDK) common /nrbiad/iadd,iadj,iadjt c common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex c common /nrbrel/brel,bjumpr,bmvd,irel,kappa,igagr,irtard,ibreit !x common /hps/badas C EQUIVALENCE (DATE(1),DATE8) !F95 C DATA JOLD/-2/,LOLD/-1/,IU/24/,IUU/26/,IULS/23/ c omginfic adf04ic C IROW(ILI,ILF,IONE,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE))/2 ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C C----------------------------------------------------------------------- C c some test set-up switches that user joe should not need to touch. c bht=.false. !.true. for bht(1970) test comparison c !x c some cross section units options: need to uncomment code above and !x c below labeled "!x" !x c !x c xconv=done !pi*a_0^2 !x c xconv=xconv*acos(-done) !a_0^2 !x c xconv=xconv*28.003d0 !Mbarns !x c xconv=xconv*1.d6 !barns !x c c elastic switch (normally ione=1, no elastic. ione=0 inc elastic) c now set by user in algeb, and passed thru /nrbdwm/ as needed. c cold ione=1 c c test: DO NOT CHANGE! cold ione0=0 !algxls/fs ione, elastic needed for mixing c if(ione.eq.0.and.kutssx.eq.-1)write(6,1120) 1120 format(//'Note: Elastic collision strengths maybe somewhat' x,' inaccurate as not all phases are present...'/'In-elastic' x,' collision strengths are unaffected'//'Set kutssx.ne.-1 and' x,' maxjfs=-1 to correct this - if memory allows') c c set (approx) unitarity switch c bunit=.true. if(bht)bunit=.false. c c set mixing switch, can test switching-off mixing. c bmix=.true. c c set print of r(tau=0)-matrix as opposed to rho(tau)-matrix c *MUST* use full T=-2iR/(1-iR) if converting via R-matrix. (not done) c can only use weak coupling T=-2i*rho for rho-matrix. (always) c brmx=.false. if(jprint.eq.4)brmx=.true. if(brmx.and.kutssx.eq.-1)write(6,1121) 1121 format(//'Note: R-matrix elements maybe somewhat inaccurate' x,' as not all phases are present...'/'rho-matrix and partial' x,' collision strengths are unaffected'//'Set kutssx.ne.-1 and' x,' maxjfs=-1 to correct this - if memory allows') c c checks channel set-up (needs ntest dimensioned) c bntest=.false. !ione.eq.0.and.jprint.ge.2 c bntest=bntest.and.nmetaj.ge.nspecj c c if bcor then we have algebraic correlation, and we know how ordered c bcor=km*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD/J(NCOR/J) c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- c btimep=btimex !for iam.ne.0 if(btimex)then c if(iabs(modd).le.1)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for dwxbp' !par cpar else !par write(iw,*)'Starting dwxbp' cpar endif !par c endif call cpu_time(timei) time0=timei endif C C INITIALIZATIONS C PI=ACOS(-DONE) TPI=DTWO*PI C DFS(1)=1 DFS(2)=1 DO I=3,MXDFS,2 DFS(I)=-DFS(I-2) DFS(I+1)=(I-1)*DFS(I-1)/32 ENDDO C NZA2=MAX(NZION-MION,1) NZA2=NZA2*NZA2 TOLO=E1M10/NZA2 C BPRNT2=JPRINT.GE.2 !FOR DETAILED OMEGA PRINTOUT BPRNT3=JPRINT.GE.3 !FOR DETAILED RHO PRINTOUT BPRNT0=JPRINT.NE.-3 C KOLDOO=KUTOOX BKUTOO=KUTOOX.NE.0 C BKUTSS=KUTSSX.NE.-1 C IF(NZION.EQ.MION)THEN NZA=0 DZ2=DONE ELSE NZA=NZION-MION DZ2=NZA*NZA ENDIF C IF(MAXJT.GE.0)THEN IF(LRGLAM.GT.MAXJT)THEN WRITE(0,*)'*** SR.DWXBP: LRGLAM.GT.MAXJT, SO NO TOP-UP' LRGLAM=-1 ELSE IF(LRGLAM.EQ.-999)LRGLAM=MAXJT ENDIF IF(LRGLAM.EQ.0)LRGLAM=-1 ENDIF C IF(LRGLAM.GT.1)THEN !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS LRGLMN=LRGLAM-2*(QMCL+QMCS) ELSE LRGLMN=1000 ENDIF c jktest=2*maxlx+qmcs+1 !max J for K.ne.K' C MPOSC=MXORB+(LCONDWJ-1)/2-(LCONDW-1)/2 !BUFFER SPACE C C SET POINTER TO START OF GROUP IN MIXING COEFFICIENT ARRAY TFU, C AND FOR MAPPING TERMS OF A J-GROUP TO ABSOLUTE LEVEL INDEX. C MC=0 NCMX=0 NSUM=0 DO N=1,NJO NADRUG(N)=MC NTGJ(N)=NSUM NC=NT(N) NCMX=MAX(NCMX,NC) MC=MC+NC*NC NSUM=NSUM+NC ENDDO C C RECOVER TARGET MIXING COEFFICIENTS C READ(MR)NCTOT C if(nctot.ne.mc)stop 'dwxbp:nctot index error' !shouldn't happen C ALLOCATE(TFU(NCTOT),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXBP: ALLOCATION FAILS FOR TFU' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C READ(MR)(TFU(I),I=1,NCTOT) C C LOOK FOR LAST SPECTROSCOPIC ENERGY C c NSPECL=0 c DO N=1,NENERJ c NSPECL=MAX(NSPECL,JNDXJ(N)) c ENDDO C C USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETA.LT.NSPECE C NOMTG=NCMX*NCMX !NEED ALL FOR MIXING nmin=min(NMETAJ,NSPECJ) NOMWRT=IROW(nmin,NSPECJ,ione,NSPECJ) !ROWWISE NOMWR0=NOMWRT c ctest if(ione.eq.1)nomwr0=nomwr0+nmin !incase ione=0 in diagfs C CF77 IF(MTRAN.GT.NDIM0.OR.NOMTG.GT.NDIM1.OR. !F77 CF77 X NOMWRT.GT.NDIM2)THEN !F77 CF77 WRITE(6,*)'SR.DWXBP: NDIM0,1,2=',NDIM0,NDIM1,NDIM2 !F77 CF77 X ,' BUT REQUIRE',MTRAN,NOMTG,NOMWRT !F77 CF77 WRITE(6,*)'TO AVOID INFLATION, USE F95 CODE/COMPILER' !F77 CF77 WRITE(0,*)'*** TIME TO USE F95 CODE/COMPILER!' !F77 CF77 NF=-1 !F77 CF77 GO TO 999 !F77 CF77 ENDIF !F77 C BTHRSH=LVMAX.GE.0 IF(BTHRSH)THEN MOGGY=LVMAX+1-LVMIN CF77 IF(MOGGY.GT.MXENG)THEN !F77 CF77 WRITE(6,*)'SR.DWXLS: USE OF LVMAX=',LVMAX, !F77 CF77 X ' REQUIRES MXENG=',LVMAX+1,' (=LVMAX+1)' !F77 CF77 WRITE(0,*)'*** TIME TO USE F95 CODE/COMPILER!' !F77 CF77 NF=-1 !F77 CF77 GO TO 999 !F77 CF77 ENDIF !F77 ELSE MOGGY=MENG0 ENDIF C ALLOCATE(RHO1(MTRAN,NOMTG),RHO2(MTRAN,NOMTG),TEMP(MTRAN,NCMX) !F95 X ,TMPX(NCMX),OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR) !F95 cparc !par cpar allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr) !par C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXBP: ALLOCATION FAILS FOR RHO,OMEGA,TEMP' !F95 NF=0 !F95 GO TO 900 !F95 ENDIF !F95 C DO N=1,NOMWRT OMGINF(N)=DZERO DO M=1,MOGGY OMEGA(M,N)=0 ENDDO ENDDO C C RECOVER INFINITE ENERGY INFO (ROWWISE) C IF(IUNIT(IU).EQ.0)THEN !ADF04 WILL BE INCOMPLETE WRITE(6,*)'NO INFINITE ENERGY FILE="OMGINFIC"...' WRITE(0,*)'NO INFINITE ENERGY FILE ON UNIT=',IU IF(LRGLAM.GE.0)THEN WRITE(6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP' WRITE(0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP' NF=-1 GO TO 800 ELSE GO TO 110 ENDIF ELSEIF(IUNIT(IU).LT.0)THEN OPEN(IU,FILE='OMGINFIC',STATUS='OLD',ERR=110) IUNIT(IU)=1 ELSE !SHOULD NOT BE HERE REWIND(IU) !ALREADY OPEN... stop 'dwxbp: omginfbp confusion' ENDIF C READ(IU,*)NZDUM,MDUM READ(IU,*)NSPEC0,MENGB,NOMWR0 C IF(NSPEC0.NE.NSPECJ)THEN !SHOULD NOT HAPPEN, NOW WRITE(6,*)'DWXBP: INFINITE ENERGY TARGET MISMATCH',NSPEC0,NSPECJ WRITE(0,*)'DWXBP: INFINITE ENERGY TARGET MISMATCH' NF=-1 GO TO 800 ENDIF C READ(IU,*)(IDUM0,IWRK3(I),I=1,NSPEC0) READ(IU,711)(DWRK(I),I=1,NSPEC0) C c optionally recover spec energy subset from omginf, c and retain full-set in denerg back above. c c do i=1,nspec0 c dwrk0(i)=dwrk0(i)*dz2 c enddo c iflag=0 if(nomwrt.ne.nomwr0)then !should not happen in non-test mode if(ione.eq.0)then !elastic in dwxjk if(nomwrt-nmin.ne.nomwr0)then write(6,*)'dwxbp: infinite energy omega mismatch' x ,nomwrt,nomwr0 write(0,*)'dwxbp: infinite energy omega mismatch' nf=-1 go to 800 else !case ione=1 in diagfs iflag=1 endif else !inelastic in dwxjk if(nomwrt+nmin.ne.nomwr0)then write(6,*)'dwxbp: infinite energy omega mismatch' x ,nomwrt,nomwr0 write(0,*)'dwxbp: infinite energy omega mismatch' nf=-1 go to 800 else !case ione=0 in diagfs iflag=2 endif endif endif C READ(IU,713)EINF,(OMGINF(I),I=1,NOMWR0) cparc cpar if(iam.ne.0)then cpar IUNIT(IULS)=-1 cpar CLOSE(IULS) cpar IUNIT(IU)=-1 cpar CLOSE(IU) cpar endif c if(iflag.eq.1)then !make room for elastic n=nomwrt+1 nshft=nmin do i=nmin,1,-1 do j=nspec0,i+1,-1 n=n-1 omginf(n)=omginf(n-nshft) enddo n=n-1 omginf(n)=done !flag poss. allowed nshft=nshft-1 enddo if(n.ne.1)stop 'iflag=1 nshft error' elseif(iflag.eq.2)then !drop elastic n=0 nshft=1 do i=1,nmin do j=i+1,nspec0 n=n+1 omginf(n)=omginf(n+nshft) enddo nshft=nshft+1 enddo if(n.ne.nomwrt)stop 'iflag=2 nshft error' endif c C 110 CONTINUE C C WRITE-OUT SPEC. TARGET ENERGIES C im=-1 if(nmetag(0).ne.0)im=1 c WRITE(6,1110) WRITE(6,996)NMETAJ*im C DO J=1,NSPECJ I=INDXJ(J) M1=NRR(I) II=NFQ(M1) IP=(1-QPI(II))*(QSI(II)+1) WRITE(6,995)J,I,M1,IP,QLI(II)/2,JN(I),NFK(M1),DSPECJ(J) ENDDO C WRITE(6,1111) C C----------------------------------------------------------------------- C C BEGIN LOOP OVER Jp SCATTERING SYMMETRIES C C----------------------------------------------------------------------- c iwait=0 wait=done C DO KX=1,INASTJ C MTJ=JPI(KX)/10 MTP=JPI(KX)-MTJ*10 MTP=MTP+MTP C C SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS C JNEW=MTJ C IF(JNEW.NE.JOLD)THEN C C----------------------------------------------------------------------- C if(btimex)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'Starting proc',iam !par cpar x ,'updating continuum for 2j=',mtj !par cpar call flush(iwp) !par cpar else !par write(iw,*) x 'Begin update of continuum basis & integrals for 2J=',MTJ cpar endif !par c call cpu_time(timei) times=timei endif C C----------------------------------------------------------------------- C jstep=jnew-jold if(jstep.gt.2.and.jfact.gt.200.and.jold.gt.0)then if(iwait.eq.2)then iwait=1 else iwait=2 endif wait=iwait*jstep wait=wait/dthree endif C C UPDATE CONTINUUM BASIS C C NOTE: IF THE USER HAS RESTRICTED LCONDWJ THEN ANY FINE-STRUCTURE HAS C A TRUNCATED PARTIAL WAVE EXPANSION. C IF(BKUTSS)THEN C IF(BTHRSH)LCONDWJ=-LCONDWJ !FLAG C CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3 X ,JNEW/2,JOLD/2,LCONDWJ,-MXORB) C IF(NF.LT.0)GO TO 800 C DO L=1,LCONDWJ QPOSJ(L)=QPOS(L) ENDDO C ENDIF C C UPDATE FINE-STRUCTURE C IF(JNEW.LE.MAXJFS)THEN C C UPDATE EXCHANGE MULTIPOLE C JDIFF=JNEW IF(JOLD.GE.0)JDIFF=JDIFF-JOLD jdiff=2*(jdiff/2) C DO L=1,NL000 IF(QSS(1,L).GT.MXORB.AND.QSS(3,L).GT.MXORB X .OR.QSS(2,L).GT.MXORB.AND.QSS(4,L).GT.MXORB)THEN ELSE QSS(5,L)=QSS(5,L)+JDIFF !EXCHANGE ENDIF ENDDO C C UPDATE FINE-STRUCTURE INTEGRALS C IF(BPRNT0)WRITE(6,1997)JNEW C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) CALL FSINTX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DNLX(1,M) X ,M1,M2,JNEW,MXORB) ENDDO ENDIF C C PREPARE TO UPDATE NON-FINE-STRUCTURE INTEGRALS: C SET POINTERS FOR INTEGRAL STORAGE FOR MULTIPLE LTOT C IF(JOLD.LT.0)THEN !FIRST TIME DO L=0,QMCS+1 QPX(L)=L+1 ENDDO ELSE DO L=0,QMCS+1 QPX0(L)=QPX(L) QPX(L)=0 ENDDO L00=(JOLD-QMCS-1)/2 K0=(JNEW-JOLD)/2 DO L=0,QMCS+1 L0=L00+L IF(2*L0.GE.(JNEW-QMCS-1).AND. X 2*L0.LE.(JNEW+QMCS+1))THEN !RE-USE K=L-K0 QPX(K)=-QPX0(L) !FLAG OLD ELSE QPX0(L)=-QPX0(L) !NOT WANTED ENDIF ENDDO ENDIF C DO L=0,QMCS+1 IF(QPX(L).EQ.0)THEN !NEW DO K=0,QMCS+1 !LOOK FOR SPACE IF(QPX0(K).LT.0)THEN QPX(L)=-QPX0(K) QPX0(K)=0 GO TO 150 ENDIF ENDDO WRITE(6,*)' SR.DWXBP: QPX INDEX ERROR...' WRITE(0,*)' SR.DWXBP: QPX INDEX ERROR...' NF=-1 GO TO 800 ENDIF 150 CONTINUE c write(0,*)l,qpx(l),qpx0(l) !debug print ENDDO C LPOS=(JNEW-QMCS-1)/2 C DO LQ=0,QMCS+1 !do lq=qmcs+1,0,-1 C LNEW=LPOS+LQ C C IF(LNEW.GE.0.AND.QPX(LQ).GT.0)THEN C C UPDATE/RE-LABEL CONTINUUM BASIS FOR THIS LTOT C IF(BKUTSS)THEN C C NOTE: CURRENTLY, NO NEW CONTINUUM ORBITALS ARE GENERATED HERE. C SO, IF THE USER HAS RESTRICTED LCONDWJ (*NOT A GOOD IDEA*) C THEN FLAG & DISCARD PWS. C J=MPOSC-MXORB J=J+LNEW-JNEW/2 MYL2=2*(LNEW-(LCONDW+1)/2) C DO L=1,LCONDW J=J+1 MYL2=MYL2+2 if(j.le.0.or.j.gt.lcondwj)then !user restricts lcondwj QPOS(L)=0 !flag not to calculate QL(MPOSC+L)=-99 !flag non-existence else QPOS(L)=IABS(QPOSJ(J)) QL(MPOSC+L)=MYL2 endif ENDDO C ELSE C C UPDATE CONTINUUM BASIS C IF(BTHRSH)LCONDW=-LCONDW !FLAG C CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3 X ,LNEW,LOLD,LCONDW,MPOSC) C IF(NF.LT.0)GO TO 800 C ENDIF C C UPDATE EXCHANGE MULTIPOLE C LDIFF=LNEW IF(LOLD.GE.0)LDIFF=LDIFF-LOLD LDIFF=LDIFF+LDIFF C DO I=1,IRL IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+LDIFF !EXCHANGE ENDDO C C UPDATE SLATER INTEGRALS (INC. 2NFS IF BKUTOO=.TRUE.) C IF(BKUTOO.AND.LNEW.GT.MAXLOO)THEN KUTOOX=0 BKUTOO=.FALSE. ENDIF C IF(BPRNT0)WRITE(6,1996)LNEW LSTORE=QPX(LQ)-1 C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) IF(BKUTOO)THEN CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DRLX(1,M,LSTORE) X ,DZLX(1,M,LSTORE) X ,DXTWOX(1,M,LSTORE) X ,DETAX(1,M,LSTORE) X ,M1,M2,LNEW,MAXLX,MPOSC) ELSE CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DRLX(1,M,LSTORE) X ,DZLX(1,1,0) X ,DXTWOX(1,1,0) X ,DETAX(1,1,0) X ,M1,M2,LNEW,MAXLX,MPOSC) ENDIF ENDDO C LOLD=LNEW KUTOOX=KOLDOO BKUTOO=KUTOOX.NE.0 C ENDIF C QPX(LQ)=IABS(QPX(LQ)) C ENDDO C C RE-SET C JOLD=JNEW C C (NOTE: MAKE SURE QL IS SYNCHRONIZED WITH LDIFF USAGE BELOW WHEN C TESTING WHETHER "INITIAL" & "FINAL" STATES HAVE BEEN SWAPPED C BY FALLING ORDER) C IF(BKUTSS)THEN DO J=1,LCONDWJ QPOS(J)=QPOSJ(J) ENDDO JPOS=JNEW ELSE JPOS=LNEW+LNEW ENDIF C MYL2=2*(JPOS/2-(LCONDWJ+1)/2) DO L=1,LCONDWJ MYL2=MYL2+2 QL(MXORB+L)=MYL2 ENDDO c if(btimex)then call cpu_time(timef) times=timef-times c cpar if(iam.ge.0)then !par cpar write(iwp,*)'Ending proc',iam !par cpar x ,'updating continuum' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'End update of continuum basis & integrals' x ,', time=',nint(times),'sec' cpar endif !par endif C ENDIF C C INITIALIZE FOR J-LOOP C IF(BPRNT0)WRITE(6,1114)KX,MTJ,MTP/2 C NWTJ=MTJ+1 C NCHJT=NCHAJK(KX,-1,-1,-1,-1,NTGJ,DFS) !WRITE CHANNEL LIST C IF(.NOT.BPRNT0)WRITE(6,1112)KX,MTJ,MTP/2,NCHJT c if(bntest)then do i=1,nchjt do j=1,nchjt ntest(j,i)=0 enddo enddo endif C INASTX=NCHGJ(KX) !NO. OF LS-SYMMS FOR THIS JP c c detailed print if(jprint.ge.5)then write(6,1150) if(maxjfs.ge.0)write(6,3050) endif C IF(BPRNT2)WRITE(6,1116) c if(btimex)then cpar if(iam.ge.0)then !par cpar write(6,*)'Starting proc',iam !par cpar x ,'symmetry',kx,':',mtj,mtp/2 !par cpar call flush(6) !par cpar else !par write(iw,*)'Starting dwxbp symmetry',kx,' :',mtj,mtp/2 cpar endif !par cparc !par call cpu_time(timei) timej=timei endif C C BEGIN K-LOOPS C KAY2=MTJ+1 IF(MTJ.GT.0)THEN KAY1=MTJ-1 ELSE KAY1=KAY2 ENDIF c if(mtj.le.jktest)then !exchange present so K.ne.K' allowed kay1p=kay1 kay2p=kay2 endif C DO KAYI=KAY1,KAY2,2 !LOOP OVER INTIAL CHANNEL K c if(mtj.gt.jktest)then !no-exchange so K=K' only kay1p=kayi kay2p=kayi endif C DO KAYF=KAY1p,KAY2p,2 !LOOP OVER FINAL CHANNEL K C C BEGIN TARGET JP LOOPS (CURRENTLY, WE HAVE NOT YET SELECTED SUBSET C THAT CONTRIBUTE TO THE TOTAL JP SYMMETRY, C SO LOOP OVER ALL AND DISCARD ON-THE-FLY.) C DO JIG=1,NJO !LOOP OVER INITIAL TARGET JP GROUPS C NC=NSLJ(1,JIG) JIP=QPI(NC) JI=NTGJ(JIG)+1 JI=JN(JI) SJKI=SQRT(DBLE((JI+1)*(KAYI+1))) L1=IABS(KAYI-JI) IF(MOD(JIP+L1,4).NE.MTP)L1=L1+2 L2=KAYI+JI IF(MOD(JIP+L2,4).NE.MTP)L2=L2-2 C NCJ0=NT(JIG) NCN0=NGSLJ(JIG) c jf2=jig if(kayf.gt.kayi)jf2=jig-1 C DO JFG=1,jf2 !LOOP OVER FINAL TARGET JP GROUPS C ND=NSLJ(1,JFG) JFP=QPI(ND) JF=NTGJ(JFG)+1 JF=JN(JF) SJKF=SQRT(DBLE((JF+1)*(KAYF+1))) L1P=IABS(KAYF-JF) IF(MOD(JFP+L1P,4).NE.MTP)L1P=L1P+2 L2P=KAYF+JF IF(MOD(JFP+L2P,4).NE.MTP)L2P=L2P-2 C NCJP0=NT(JFG) NCNP0=NGSLJ(JFG) C c get lambda for non-dipole infnite energy top-up c if(jnew.ge.lrglam)then if(ji+jf.ne.0)then litlam=iabs(ji-jf)/2 if(jip.ne.jfp)then if(litlam.le.1)then !for case of octupole litlam=3 elseif((-1)**litlam.gt.0)then litlam=litlam+1 endif else if(litlam.eq.0)then litlam=2 elseif((-1)**litlam.lt.0)then litlam=litlam+1 endif endif if(litlam.gt.(ji+jf)/2)litlam=0 else litlam=0 endif endif c c eqgrpj=jig.eq.jfg !not currently used C DO LI=L1,L2,4 !LOOP OVER INITIAL CHANNEL L C c set position of phase shift for this li c only required by elastic case for diagonal rho c or if printing usual reactance matrix c if(ione.eq.0.or.brmx)then L=(LCONDWJ+1)/2 -JPOS/2+LI/2 c if(l.gt.lcondwj.or.l.lt.1)stop'phase error' l=min(l,lcondwj) !case user has restricted lcondwj l=max(l,1) !then we don't have all the phases L0=IABS(QPOS(L)) endif C DO LF=L1P,L2P,4 !LOOP OVER FINAL CHANNEL L C c set position of phase shift for this lf c only need if printing usual reactance matrix, not needed by rho matrix C if(brmx)then L=(LCONDWJ+1)/2 -JPOS/2+LF/2 c if(l.gt.lcondwj.or.l.lt.1)stop'phase error' l=min(l,lcondwj) !case user has restricted lcondwj l=max(l,1) !then we don't have all the phases L00=IABS(QPOS(L)) endif C C NOW FORM JK INTERACTION (BY TARGET SYMMETRY GROUP) C************************* C C THIS IS IN THE RHO-I REPRESENTATION, WHERE C |T^R(V,V')|=|T^RHO(V,V')| FOR CHANNELS V.NE.V'. C WE USE T^RHO(V,V')=-2I*RHO(V,V'), WITH A 2X2 UNITARITY CONDITION. C FOR V.EQ.V' T^R(V,V)~-2*TAN(TAU(V)), FOR RHO(V,V) SMALL. C (IN GENERAL, WE ARE NOT INTERESTED IN ELASTIC TRANSITIONS.) C C NOMTG=NCJ0*NCJP0 DO N=1,NOMTG DO M=1,MTRAN RHO1(M,N)=DZERO ENDDO ENDDO C NCI0=0 DO NC00=1,NCN0 !BEGIN LOOP OVER INITIAL SL GROUPS NC=NSLJ(NC00,JIG) MC=NSL(NC) SA=QSI(NC) LA=QLI(NC) MCI=NGRPI(NC) C NCIP0=0 DO ND00=1,NCNP0 !BEGIN LOOP OVER FINAL SL GROUPS ND=NSLJ(ND00,JFG) MCP=NSL(ND) SAP=QSI(ND) c IF(ABS(SA-SAP).GT.2)GO TO 68 !unnecessary... IF(NMETAG(NC)+NMETAG(ND).EQ.2)GO TO 68 LAP=QLI(ND) MCIP=NGRPI(ND) C DO IXX=1,INASTX !LOOP OVER INITIAL LS SYMMS C IX=JSYMM(IXX,KX) NCN=NCHG(IX) C nchi=0 DO NC0=1,NCN !FIND INITIAL GROUP LL1=LLCH(1,NC0,IX) LL2=LLCH(2,NC0,IX) nchi=nchi+((ll2-ll1)/4+1)*mc IF(NC.EQ.ITARG(NC0,IX))THEN !MATCHED IF(LI.LT.LL1.OR.LI.GT.LL2)GO TO 715 nchi=nchi-((ll2-li)/4+1)*mc GO TO 720 ENDIF ENDDO C 715 CONTINUE c write(6,*)'NO CONTRIB. FROM LS SYM',IXX,' IX=',IX GO TO 750 !SLP DOES NOT CONTRIBUTE C 720 IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 C IF(MTP.NE.IP+IP)STOP 'IXX ERROR' !REMOVE MTS=IS-1 MTL=IL+IL C IF(KAYI.LT.IABS(MTL-SA) X .OR.KAYI.GT.MTL+SA)GO TO 750 !LAST TRIANGLE C IF(BKUTOO.AND.IL.GT.MAXLOO)THEN KUTOOX=0 BKUTOO=.FALSE. ENDIF C bnx=il.gt.maxlx c if(jprint.ge.5)then if(bnx)then nwt=-2*is+2 else nwt=is endif write(6,1113)ix,nwt,il,ip endif c c must be synchronized with current values of l placed in ql(i) for c orbital and integral evaluations. c ldiff=2*(jpos/2)-mtl !for adjust of ql(i) C C DETERMINE INITIAL STATE RECOUPLING COEFFICIENT C W=SJS(LA,LI,MTL,KAYI,SA,JI,DFS,MXDFS) ISIGN=(LI+MTL+SA+JI)/2 W=W*(-1)**ISIGN W2=SJS(MTS,MTL,MTJ,KAYI,1,SA,DFS,MXDFS) ISIGN=(MTL+MTJ+1+SA)/2 W2=W*W2*(-1)**ISIGN W2=W2*SQRT(DBLE((MTL+1)*(MTS+1)))*SJKI c if(bnx)then mts=mts-2 if(mts.ge.iabs(mtj-mtl))then x2=sjs(mts,mtl,mtj,kayi,1,sa,dfs,mxdfs) c isign=(mtl+mtj+1+sa)/2 x2=w*x2*(-1)**isign x2=x2*sqrt(dble((mtl+1)*(mts+1)))*sjki endif else x2=dzero endif c if(abs(w2)+abs(x2).lt.1.d-70)go to 750 C JX1=1 !FS IF(MTJ.GT.MAXJFS)JX1=IXX !NO-FS C DO JXX=JX1,IXX !LOOP OVER FINAL LS SYMMS C JX=JSYMM(JXX,KX) NCNP=NCHG(JX) C nchip=0 DO ND0=1,NCNP !FIND FINAL GROUP LL1P=LLCH(1,ND0,JX) LL2P=LLCH(2,ND0,JX) nchip=nchip+((ll2p-ll1p)/4+1)*mcp IF(ND.EQ.ITARG(ND0,JX))THEN !MATCHED IF(LF.LT.LL1P.OR.LF.GT.LL2P)GO TO 725 nchip=nchip-((ll2p-lf)/4+1)*mcp GO TO 730 ENDIF ENDDO C 725 CONTINUE c write(6,*)'NO CONTRIB. FROM LS SYM',JXX,' JX=',JX GO TO 740 !SLP DOES NOT CONTRIB C 730 ISP=LSPI(JX)/10000 IPP=LSPI(JX)-ISP*10000 ILP=IPP/10 IPP=IPP-ILP*10 C IF(MTP.NE.IPP+IPP)STOP 'JXX ERROR' !REMOVE MTSP=ISP-1 MTLP=ILP+ILP C IF(KAYF.LT.IABS(MTLP-SAP) X .OR.KAYF.GT.MTLP+SAP)GO TO 740 !LAST TRIANGLE C BLS=IX.EQ.JX b2fs=mtj.le.maxjfs X .and. (IS+ISP-2)*(IL+ILP).GT.0 x .and. iabs(NMETAG(NC))+iabs(NMETAG(ND)).lt.2 C if(jprint.ge.5)then if(bnx)then nwtp=-2*isp+2 else nwtp=isp endif write(6,1115)jx,nwtp,ilp,ipp endif C C DETERMINE FINAL STATE RECOUPLING COEFFICIENT C W=SJS(LAP,LF,MTLP,KAYF,SAP,JF,DFS,MXDFS) ISIGN=(LF+MTLP+SAP+JF)/2 W=W*(-1)**ISIGN W2P=SJS(MTSP,MTLP,MTJ,KAYF,1,SAP,DFS,MXDFS) ISIGN=(MTLP+MTJ+1+SAP)/2 W2P=W*W2P*(-1)**ISIGN W2P=W2P*SQRT(DBLE((MTLP+1)*(MTSP+1)))*SJKF C W4=W2*W2P c if(bnx)then mtsp=mtsp-2 if(mtsp.ge.iabs(mtj-mtlp))then x2p= x sjs(mtsp,mtlp,mtj,kayf,1,sap,dfs,mxdfs) c isign=(mtlp+mtj+1+sap)/2 x2p=w*x2p*(-1)**isign x2p=x2p*sqrt(dble((mtlp+1)*(mtsp+1))) x *sjkf w4=w4+x2*x2p endif endif C if(abs(w4).lt.1.d-70)go to 740 c c set pointers to ls and fs interactions c c eqgrp=bls.and.nc0.eq.nd0 !ls equal grps c !to fill rho1 eqgrpl=eqgrpl0.and.eqgrp.and.li.eq.lf c if(bls)then ncor=qptls(ix,nc0,nd0,li,lf) if(ncor.ge.0)then nun=0 else !reverse nun=mc-1 c write(6,*)ix,nc0,nd0,li,lf,ncor+1 endif ncor0=ncor LSTORE=IL-LPOS LSTORE=QPX(LSTORE)-1 else ncor0=0 endif c if(b2fs)then ncorj=qptlsj(kx,ixx,jxx,nc0,nd0,li,lf) if(ncorj.ge.0)then nunj=0 else !reverse nunj=mc-1 c write(6,*)kx,ixx,jxx,nc0,nd0,li,lf,ncorj+1 endif ncorj0=ncorj else ncorj0=0 endif c icl0=0 if(bcorr.and.(ncor0.lt.0.or.ncorj0.lt.0)) x then do md1=1,mc j1=md1+mci j=jndex(j1) if(j.lt.0)icl0=icl0+1 enddo endif C C POPULATE UNMIXED RHO1 INTERACTION MATRIX C icl=0 DO MD1=1,MC !LOOP OVER INITIAL LEVELS J1=MD1+MCI c j=jndex(j1) if(bcorr.and.j.lt.0)icl=icl+1 KF=NFK(J1) NCJ=NCI0+MD1 C if(ncor0.lt.0)ncor=-ncor0-1+md1-1 if(ncorj0.lt.0)ncorj=-ncorj0-1+md1-1 c iclp=0 DO MDP1=1,MCP !LOOP OVER FINAL LEVELS J1P=MDP1+MCIP c jp=jndex(j1p) if(bcorr.and.jp.lt.0)iclp=iclp+1 if(j.lt.0.and.jp.lt.0)then !cor-cor if(becor)then if(bls)ncor=ncor+1 if(b2fs)ncorj=ncorj+1 go to 710 endif go to 712 endif C KG=NFK(J1P) NCJP=NCIP0+MDP1 C NOMTG=(NCJP-1)*NCJ0+NCJ C C LS ALGEBRA C IF(BLS)THEN c since ls only stores half... if(eqgrpl.and.j1p.gt.j1-ione0)then ncor=ncor0+icol(md1,mdp1,ione0)-1 if(bcorr)ncor=ncor x -icol(iclp-1,iclp-1,ione0) endif C N1=NAD(NCOR)+1 NCOR=NCOR+1 N2=NAD(NCOR) c debug write if(jprint.ge.5.and.n1.le.n2)then nch=nchi+md1 nchp=nchip+mdp1 if(n2-n1.eq.5)then write(6,9119)ncor,ix,nch,nchp,0,0, x (nrk(n),drk(n),n=n1,n2) else write(6,9120)ncor,ix,nch,nchp,0,0, x (nrk(n),drk(n),n=n1,n2) endif if(bkutoo)write(6,9121) x (nrk(n),dek(n),n=n1,n2) write(6,9120) endif c c need to find if Slater integral initial and final states are swapped c because of falling order. this also picks-up any case that needs c swapping because initial and final algebraic states are swapped. c it doesn't pick-up all cases of ncor0.lt.0 but the symmetry of the c Slater integrals means that such cases are unchanged by a swap. c if(n2-n1+1.gt.mxd13)then write(6,*)'***sr.dwxbp: increase', x ' internal buffer mxd13 to', n2-n1+1 nf=-1 go to 800 endif c ks=0 do n=n1,n2 ks=ks+1 bswap(ks)=.false. n0=int(nrk(n)) m0=qrl(1,n0) if(li.eq.ql(m0)-ldiff)then if(li.eq.lf.and.kf.ne.kg)then m0=qrl(3,n0) if(qn(m0).gt.0)then !exchange if(m0.ne.kact(kg,kf))then !f bswap(ks)=.true. !swap endif c else !direct - doesn't matter endif c else !distinct/kf=kg so can't endif else !trivially, they were bswap(ks)=.true. endif enddo c ELSE N1=1 N2=0 ENDIF C C FS ALGEBRA C if(b2fs)then c since ls only stores half... if(eqgrpl.and.j1p.gt.j1-ione0)then ncorj=ncorj0+icol(md1,mdp1,ione0)-1 if(bcorr)ncorj=ncorj x -icol(iclp-1,iclp-1,ione0) endif c k1=nadr(ncorj)+1 ncorj=ncorj+1 k2=nadr(ncorj) c debug write if(jprint.ge.5.and.k1.le.k2)then nch=nchi+md1 nchp=nchip+mdp1 if(k2-k1.eq.5)then write(6,1201)ncorj,kx,ix,jx,nch, x nchp,0,0,(mss(n),dss(n),n=k1,k2) else write(6,1202)ncorj,kx,ix,jx,nch, x nchp,0,0,(mss(n),dss(n),n=k1,k2) endif write(6,1201) endif c c need to find if n & v integral initial and final states are swapped c because of falling order. c c this does *not* pick-up all cases that need swapping because initial c and final algebraic states are swapped (ncorj0.lt.0) hence additional c test on ncorj0. c if(k2-k1+1.gt.mxd13)then write(0,*)ncorj,iadj write(6,*)'***sr.dwxbp: increase ', x 'internal buffer mxd13 to', k2-k1+1 nf=-1 go to 800 endif c c ********************************************************************** c currently, swapping of indexes due to falling order has been c suppressed in sr.resx1 (see also sr.fsintx) because of the lesser c symmetry compared to Slater integrals which means that an additional c flag is needed. c ********************************************************************** c c so, we simply have: ksj=0 do k=k1,k2 ksj=ksj+1 bswapj(ksj)=ncorj0.lt.0 enddo cc instead of: c ksj=0 c do k=k1,k2 c ksj=ksj+1 c bswapj(ksj)=.false. c k0=int(mss(k)) cc c i1=qss(1,k0) c i3=qss(3,k0) c i2=qss(2,k0) c i4=qss(4,k0) c if(qn(i1).lt.0)then c ic=i1 c if(qn(i3).lt.0)then !direct c ib=i4 c else !exchange c ib=i3 c endif c else c ic=i2 c if(qn(i4).lt.0)then !direct c ib=i3 c else !exchange c ib=i4 c endif c endif c if(li.eq.ql(ic))then c if(li.eq.lf)then c if(kf.ne.kg)then c if(ib.ne.kact(kg,kf))then !f c bswapj(ksj)=.true. c endif c else cc tbd for exchange falling order (see also sr.resx1 and sr.fsintx): cc the case of N(C'C;BB)=N(BC;C'B) for Bound and Continuum needs a cc further flag so as to distinguish it from N(C'C;BB)=N(C'B;BC), cc since in the former we need C'=M2 while in the latter C'=M1, so cc if (former) then cc bswapj(ksj)=.true. cc since unlike slater we cannot interchange 1 & 3 with 2 & 4 cc - this also means that we need c if(ncorj0.lt.0) c x bswapj(ksj)=.not.bswapj(ksj) c endif c else !distinct so can't c endif c else !trivially, they were c bswapj(ksj)=.true. c endif cc cc nj=ntgj(jig) cc njp=ntgj(jfg) cc n1=ncj+nj cc n=jndxj(n1) cc n1p=ncjp+njp cc np=jndxj(n1p) cc write(6,*)ixx,jxx,nc0,nd0,n,np,li,lf,ncorj0,k0,bswapj(ksj) cc bswapt=ncorj0.lt.0 cc if(bswapt.neqv.bswapj(ksj)) cc x write(0,*)ixx,jxx,nc0,nd0,n,np,li,lf,ncorj0,k0,bswapj(ksj) cc cc enddo c else k1=1 k2=0 endif C C LOOP OVER ENERGIES C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) C C LS CONTRIBUTION: C DD=DZERO ks=0 DO N=N1,N2 ks=ks+1 c if(bswap(ks))then !swap mm=mrndx(m) else mm=m endif c N0=INT(NRK(N)) C DD=DD+DRLX(N0,mm,LSTORE)*DRK(N) C IF(BKUTOO)THEN DS=DZLX(N0,mm,LSTORE) IF(BFALL(N))DS=-DS DS=DS+DXTWOX(N0,mm,LSTORE)*DRK(N) X +DETAX(N0,mm,LSTORE)*DEK(N) DD=DD+DS ENDIF ENDDO C C FS CONTRIBUTION: C c dd=dzero !test fs, switch-off coulomb c DDJ=DZERO ksj=0 DO K=K1,K2 ksj=ksj+1 c if(bswapj(ksj))then !swap mm=mrndx(m) else mm=m endif c K0=INT(MSS(K)) C DDJ=DDJ+DNLX(K0,mm)*DSS(K) ENDDO C DEE=DD+DDJ C !UNMIXED RHO1(M,NOMTG)=RHO1(M,NOMTG)+DEE*W4 ENDDO c c start test print c nj=ntgj(jig) c njp=ntgj(jfg) c n1=ncj+nj c n=jndxj(n1) c n1p=ncjp+njp c np=jndxj(n1p) c write(6,777)n,np,(rho1(m,nomtg),m=1,mtran) c 777 format(2i5,1p,10d12.3/(10x,10d12.3)) c call flush(6) c end test print C 710 if(ncor0.lt.0)then ncor=ncor+nun if(jp.lt.0)ncor=ncor-icl0 endif if(ncorj0.lt.0)then ncorj=ncorj+nunj if(jp.lt.0)ncorj=ncorj-icl0 endif c ENDDO !END LOOP OVER FINAL LEVELS c 712 if(eqgrpl)then if(bls)then ncor=ncor0+icol(md1,md1,ione0) if(bcorr)ncor=ncor-icol(icl,icl,ione0) endif if(b2fs)then ncorj=ncorj0+icol(md1,md1,ione0) if(bcorr)ncorj=ncorj x -icol(icl,icl,ione0) endif endif C ENDDO !END LOOP OVER INITIAL LEVELS C 740 ENDDO !END LOOP OVER FINAL LS SYMMS C KUTOOX=KOLDOO BKUTOO=KUTOOX.NE.0 C 750 ENDDO !END LOOP OVER INITIAL LS SYMMS C 68 CONTINUE C NCIP0=NCIP0+MCP ENDDO !END LOOP OVER FINAL SL GROUPS if(ncip0.ne.ncjp0) !temp test x stop 'ncip0.ne.nt(jfg)' C NCI0=NCI0+MC ENDDO !END LOOP OVER INITIAL SL GROUPS if(nci0.ne.ncj0)stop 'nci0.ne.nt(jig)' !temp test C C----------------------------------------------------------------------- c c test skip mixing c if(.not.bmix)then nj=ntgj(jig) njp=ntgj(jfg) do ncj=1,ncj0 j1=ncj+nj j=jndxj(j1) if(j.lt.0)go to 31 ng0=(ncj-1)*ncjp0 do ncjp=1,ncjp0 j1p=ncjp+njp if(j1.eq.j1p.and.ione.ne.0)go to 21 if(kayi.eq.kayf)then IF(J1P.GT.J1)GO TO 31 if(j1.eq.j1p.and.lf.gt.li)go to 21 endif jp=jndxj(j1p) if(jp.lt.0)go to 21 if(min(j,jp).gt.nmetaj)go to 21 ng1=(ncjp-1)*ncj0+ncj ng2=ng0+ncjp do m=1,mtran rho2(m,ng2)=rho1(m,ng1) enddo c write(6,777)j,jp,(rho1(m,ng1),m=1,mtran) c 777 format(2i5,1p,10d12.3/(10x,10d12.3)) c call flush(6) 21 enddo 31 enddo go to 130 endif C C NOW MIX (INITIAL) C N0=NADRUG(JIG) N0P=NADRUG(JFG) NJ=NTGJ(JIG) NJP=NTGJ(JFG) C NCJ0=NT(JIG) C NCJP0=NT(JFG) C DO NCJ=1,NCJ0 !BEGIN LOOP OVER INITIAL LEVELS C J1=NCJ+NJ j=jndxj(j1) if(j.lt.0)go to 11 !omit corr. if(j.gt.nmetaj)go to 11 !omit non-metastable c if(bcorr.or.kayi.eq.kayf)then DO NCJP=1,NCJP0 !SEE IF WE HAVE A FINAL LEVEL J1P=NCJP+NJP IF(J1P.GT.J1.and.kayi.eq.kayf)GO TO 11 jp=jndxj(j1p) if(jp.gt.0)go to 5 !we do ENDDO GO TO 11 !WE DON'T endif C 5 N1=N0+(NCJ-1)*NCJ0 DO LD1=1,NCJ0 N2=N1+LD1 TMPX(LD1)=TFU(N2) c write(6,777)n1,n2,tfu(n2) ENDDO C DO NCJP=1,NCJP0 !FOR EACH FINAL LEVEL C DO M=1,MTRAN TEMP(M,NCJP)=DZERO ENDDO C NG0=(NCJP-1)*NCJ0 DO LD1=1,NCJ0 !BEGIN INITIAL MIXING C NG=NG0+LD1 !rho1 nomtg TF=TMPX(LD1) C IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN TEMP(M,NCJP)=TEMP(M,NCJP)+RHO1(M,NG)*TF ENDDO ENDIF c ENDDO !END INITIAL MIXING C c j1p=ncjp+njp c write(6,777)j1,j1p,(temp(m,ncjp),m=1,mtran) c ENDDO !FOR EACH FINAL LEVEL C C NOW MIX (FINAL) C NOMTG0=(NCJ-1)*NCJP0 DO NCJP=1,NCJP0 !BEGIN LOOP OVER FINAL LEVELS C J1P=NCJP+NJP if(j1.eq.j1p.and.ione.ne.0)go to 10 if(kayi.eq.kayf)then IF(J1P.GT.J1)GO TO 11 if(j1.eq.j1p.and.lf.gt.li)go to 10 endif c jp=jndxj(j1p) if(jp.lt.0)go to 10 !omit corr. c if(min(j,jp).gt.nmetaj)go to 10 !non-metastable c N1P=N0P+(NCJP-1)*NCJP0 C NOMTG=NOMTG0+NCJP !rho2 nomtg (new) DO M=1,MTRAN RHO2(M,NOMTG)=DZERO ENDDO C DO LDP1=1,NCJP0 !BEGIN FINAL MIXING c N2P=N1P+LDP1 TF=TFU(N2P) c IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN RHO2(M,NOMTG)=RHO2(M,NOMTG) X +TEMP(M,LDP1)*TF ENDDO ENDIF c ENDDO !END FINAL MIXING c c write(6,777)j1,j1p,(rho2(m,nomtg),m=1,mtran) 10 ENDDO !END LOOP OVER FINAL LEVELS C 11 ENDDO !END LOOP OVER INITIAL LEVELS C C FIRST SEE IF WE NEED REVERSE CASE: C C INITIAL & FINAL ARE ALGEBRAIC AND SO NMETA CAN BE IN EITHER/BOTH/NONE C BUT WE WANT THE FIRST MIXING MATRIX MULT TO BE FOR NMETAJ SO WE DON'T C NEED TO MULTIPLY BY THE ZERO BLOCK. THUS, WE MAKE A DOUBLE PASS. OF C COURSE, IF NMETAJ=NSPECJ THEN THE SECOND PASS IS "SKIPPED". C DO NCJP=1,NT(JIG) !CHECK INITIAL LEVELS J1P=NCJP+NTGJ(JIG) jp=jndxj(j1p) if(jp.gt.nmetaj)go to 8 !needed ENDDO GO TO 130 !ALL DONE C C NOW MIX (FINAL) - REVERSE CASE C 8 N0=NADRUG(JFG) N0P=NADRUG(JIG) NJ=NTGJ(JFG) NJP=NTGJ(JIG) NCJ0=NT(JFG) NCJP0=NT(JIG) C DO NCJ=1,NCJ0 !BEGIN LOOP OVER FINAL LEVELS C J1=NCJ+NJ j=jndxj(j1) if(j.lt.0)go to 13 !omit corr. if(j.gt.nmetaj)go to 13 !omit non-metastable c DO NCJP=1,NCJP0 !SEE IF WE HAVE INITIAL LEVEL J1P=NCJP+NJP IF(J1P.LT.J1.and.kayi.eq.kayf)GO TO 6 jp=jndxj(j1p) if(jp.gt.nmetaj)go to 7 !we do 6 ENDDO GO TO 13 !WE DON'T C 7 N1=N0+(NCJ-1)*NCJ0 DO LD1=1,NCJ0 N2=N1+LD1 TMPX(LD1)=TFU(N2) c write(6,777)n1,n2,tfu(n2) ENDDO C DO NCJP=1,NCJP0 !FOR EACH INITIAL LEVEL C DO M=1,MTRAN TEMP(M,NCJP)=DZERO ENDDO C DO LD1=1,NCJ0 !BEGIN FINAL MIXING C NG=NCJP+(LD1-1)*NCJP0 !rho1 nomtg TF=TMPX(LD1) C IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN TEMP(M,NCJP)=TEMP(M,NCJP)+RHO1(M,NG)*TF ENDDO ENDIF c ENDDO !END FINAL MIXING C c j1p=ncjp+njp c write(6,777)j1,j1p,(temp(m,ncjp),m=1,mtran) c ENDDO !FOR EACH INITIAL LEVEL C C NOW MIX (INITIAL) - REVERSE CASE C DO NCJP=1,NCJP0 !BEGIN LOOP OVER INITIAL LEVELS C J1P=NCJP+NJP if(j1.eq.j1p.and.ione.ne.0)go to 12 if(kayi.eq.kayf)then IF(J1P.LT.J1)GO TO 12 if(j1.eq.j1p.and.lf.gt.li)go to 12 endif c jp=jndxj(j1p) c if(jp.lt.0)go to 12 !omit corr. if(jp.le.nmetaj)go to 12 !already gotten c N1P=N0P+(NCJP-1)*NCJP0 C NOMTG=NCJ+(NCJP-1)*NCJ0 !rho2 nomtg (new) DO M=1,MTRAN RHO2(M,NOMTG)=DZERO ENDDO C DO LDP1=1,NCJP0 !BEGIN INITIAL MIXING c N2P=N1P+LDP1 TF=TFU(N2P) c IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN RHO2(M,NOMTG)=RHO2(M,NOMTG) X +TEMP(M,LDP1)*TF ENDDO ENDIF c ENDDO !END INITIAL MIXING c c write(6,777)j1,j1p,(rho2(m,nomtg),m=1,mtran) 12 ENDDO !END LOOP OVER INITIAL LEVELS C 13 ENDDO !END LOOP OVER FINAL LEVELS C C RE-SET NJ=NTGJ(JIG) NJP=NTGJ(JFG) NCJ0=NT(JIG) NCJP0=NT(JFG) c 130 continue !re-entry point for no-mixing test C C----------------------------------------------------------------------- C C NOW INTERPOLATE MIXED RHO2, CONVERT TO TMX AND ADD TO OMEGA C NOTE, RHO2 IS IN "A.U" C ALLOW FOR ANY INITIAL ALGEBRAIC LEVELS NOT BEING LOWEST IN ENERGY. C DO NCJ=1,NCJ0 !BEGIN LOOP OVER INITIAL LEVELS C C IF(BPRNT2)NCHJ=NCHAJK(KX,KAYI,JIG,LI,NCJ X ,NTGJ,DFS) J1=NCJ+NJ j=jndxj(j1) if(j.lt.0)go to 14 !omit cor. C NOMTG0=(NCJ-1)*NCJP0 DO NCJP=1,NCJP0 !BEGIN LOOP OVER FINAL LEVELS C J1P=NCJP+NJP if(j1.eq.j1p.and.ione.ne.0)go to 15 if(kayi.eq.kayf)then IF(J1P.GT.J1)GO TO 14 if(j1.eq.j1p.and.lf.gt.li)go to 15 endif C jp=jndxj(j1p) if(jp.lt.0)go to 15 !omit corr. if(min(j,jp).gt.nmetaj)go to 15 !non-metastable C IF(BPRNT2)NCHJP=NCHAJK(KX,KAYF,JFG,LF,NCJP X ,NTGJ,DFS) c c write(6,*)nchj,nchjp,j1,j1p,j,jp c if(bntest)ntest(nchj,nchjp)=ntest(nchj,nchjp)+1 c c "undefined" should not be accessed by xint... c do m2=1,meng c do m1=1,meng c tmp(m1,m2)=1.d70 !dzero !test c enddo c enddo C NOMTG=NOMTG0+NCJP !rho2 nomtg (new) C IF(J.LE.JP)THEN !INITIAL ALGEBRAIC IS LOWER ENRG C JL=J JH=JP NCHL=NCHJ NCHH=NCHJP LUP=LF C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) TMP(M1,M2)=RHO2(M,NOMTG) ENDDO C ELSE !FINAL ALGEBRAIC IS LOWER ENERGY C JL=JP JH=J NCHL=NCHJP NCHH=NCHJ LUP=LI C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) TMP(M2,M1)=RHO2(M,NOMTG) ENDDO C ENDIF C NOMT=IROW(JL,JH,ione,NSPECJ) !ROWWISE DE=DSPECJ(JH)-DSPECJ(JL) c if(nomt.gt.nomwrt)then !shouldn't happen, now write(0,*)jl,jh,nmetaj,nspecj,nomt,nomwrt stop 'omega prob.' endif C C LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES C DO M0=1,MENG0 C M=IYY0(M0) ml=mlim(m,1) mu=mlim(m,2) c c if(omginf(nomt).lt.dzero)mu=-mu !flag dipole C RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu)!A.U. RHOSQ=RHO*RHO C c IF(NCHJ.eq.NCHJP)THEN !DIAGONAL MX c if(j1.eq.j1p.and.li.eq.lf.and.kayi.eq.kayf)then C IF(BRMX)THEN !USUAL REACTANCE T=PI*PSHFTX(M,L0) CT=COS(T) ST=SIN(T) RMX=(ST+RHO*CT)/(CT+RHO*ST) ENDIF C T=TPI*PSHFTX(M,L0) C2T=COS(T) S2T=SIN(T) C if(bunit)then !UNITARY TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO) X /(RHOSQ+DONE) else !non-unitary tsq=done+(c2t*(dtwo*rhosq-done) x +dtwo*s2t*rho) endif c TSQ=TSQ+TSQ ! T^R=1+EXP(2I*TAU)(T^RHO-1) C ELSE !OFF DIAGONAL C IF(BRMX)THEN !USUAL REACTANCE T1=TPI*PSHFTX(M,L0) T2=TPI*PSHFTX(M,L00) DET=COS(T1)*COS(T2)-RHOSQ*SIN(T1)*SIN(T2) RMX=RHO/DET ENDIF C TSQ=4*RHOSQ ! |T^R(V,V')|=|T^RHO(V,V')| C if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !~UNITARITY C C !FOR ELASTIC LI.NE.LF .OR. KI.NE.KF IF(J1.EQ.J1P)TSQ=TSQ+TSQ C ENDIF c if(tsq.lt.d1m20)tsq=dzero C IF(BPRNT3)THEN IF(BRMX)THEN WRITE(6,202)NCHL,NCHH,JL,JH,RMX,M0, X 'R-MATRIX ' ELSE WRITE(6,202)NCHL,NCHH,JL,JH,RHO,M0, X 'RHO-MATRIX' ENDIF ENDIF C OMPW=wait*TSQ*NWTJ/DTWO C if(bht)ompw=ompw/2 !for BHT(1970) comparison C C LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH) C IF(JNEW.GE.LRGLMN)THEN C !NON-DIPOLE IF(OMGINF(NOMT).GT.DZERO.and. X litlam.gt.0)THEN C IF(JNEW.EQ.LRGLAM)THEN !APPLY TOP-UP EJ=DYY0(M0) EI=EJ+DE c ompw0=ompw ompw=ompw/wait IF(BPRNT3)OMPW=-OMPW !FLAG PRINT C CALL TOP2(LITLAM,LRGLAM/2,EI,EJ,OMPW) C ompw=ompw+ompw0*(wait-done)/wait !adjust c ELSEIF(JNEW.GT.LRGLAM)THEN OMPW=DZERO ENDIF C !DIPOLE:LITLAM=LRGLAM ELSEIF(OMGINF(NOMT).LT.DZERO)THEN !POSS C !ZERO-OUT ASINC. IN TOP-UP IF(MAX(LI,LF).GT.LRGLAM)OMPW=DZERO C ENDIF C ENDIF C C ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS C IF(BTHRSH)THEN M00=LUP/2+1-LVMIN IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 15 ELSE !CASE NOT XCLUDED BY ALGXLS M00=M0 ENDIF C OMP(M0)=OMPW C !UPDATE TOTAL OMEGA OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+sngl(OMPW) C ENDDO C IF(BPRNT2)WRITE(6,201) !PARTIAL OMEGA X NCHL,NCHH,JL,JH,(OMP(M0),M0=1,MENG0) C 15 ENDDO !END LOOP OVER FINAL LEVELS C 14 ENDDO !END LOOP OVER INITIAL LEVELS C ENDDO !END LOOP OVER FINAL L C ENDDO !END LOOP OVER INITIAL L C ENDDO !END LOOP OVER FINAL JP GROUPS C ENDDO !END LOOP OVER INITIAL JP GROUPS C ENDDO !END LOOP OVER FINAL K C ENDDO !END LOOP OVER INITIAL K C if(bntest)then do i=1,nchjt if(ntest(i,i).ne.1)then write(0,*)'checksum wrong for nchj,nchj ' x ,i,' :',ntest(i,i) endif do j=i+1,nchjt if(ntest(i,j)+ntest(j,i).ne.1)then write(0,*)'checksum wrong for nchj,nchjp' x ,i,j,' :',ntest(i,j),ntest(j,i) endif enddo enddo endif C C----------------------------------------------------------------------- C if(btimex)then call cpu_time(timef) times=timef-timej c cpar if(iam.ge.0)then !par cpar write(iwp,*)'Ending proc',iam !par cpar x ,'dwxbp symmetry',kx,':',' nchan=',nchjt !par cpar x ,'time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'Ending dwxbp symmetry ',kx,':',' nchan=',nchjt x ,'time=',nint(times),'sec' cpar endif !par endif C C----------------------------------------------------------------------- C C ----------------------------- ENDDO !END LOOP OVER TOTAL JP SYMMS C ----------------------------- C cparc !par cpar if(iam.ne.0)then !par cpar if(btimex)then !par cpar btimep=.false. !par cpar call cpu_time(timef) !par cpar times=timef-time0 !par cparc !par cpar write(iw,*)'Ending proc',iam,' for dwxbp:' !par cpar x ,' time=',nint(times),'sec' !par cpar endif !par cpar endif !par cparc !par cpar ns=0 !par cpar nr=0 !par cparc !par cpar do m0=1,moggy !par cparc !par cpar call pomsend(ns,omega(1,1),nomwrt,omsend) !par cparc !par cpar call comm_barrier() !par cparc !par cpar call mpi_reduce(omsend,omrecv,nomwrt,mpi_real4,mpi_sum, !par cpar x 0,mpi_comm_world,ier) !par cpar if(ier.ne.0)write(0,*)'mpi_reduce: iam, ier=',iam,ier !par cparc !par cpar call comm_barrier() !par cparc !par cpar if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1)) !par cparc !par cpar enddo !par cparc !par cpar if(iam.ne.0)go to 800 !par cparc !par C C APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH) C IF(LRGLAM.GT.1)THEN C WRITE(6,1002)LRGLAM if(btimex)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Proc',iam, !par cpar x 'Top-up has been applied: lrglam=',lrglam !par cpar else !par write(iw,*)'Top-up has been applied: lrglam=',lrglam cpar endif !par endif IF(BPRNT2)WRITE(6,716) C LITLAM=LRGLAM/2 !USE GLOBAL VALUE JA=0 CO2S=D3O4/LOG(EINF*DZ2) C NOMT=0 DO I=1,NMETAJ !,NSPECL c IF(INDXJ(I).GT.0)THEN !NON-CORR C DO J=I+ione,NSPECJ !,NSPECL c IF(INDXJ(J).GT.0)THEN !NON-CORR C NOMT=NOMT+1 SS=OMGINF(NOMT) C IF(SS.LT.DZERO)THEN !DIPOLE SS=SS*CO2S !CONVERT TO LINE STRENGTH DE=DSPECJ(J)-DSPECJ(I) DE=DE/DZ2 DO M0=1,MENG0 EJ=DYY0(M0)/DZ2 EI=EJ+DE C CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT) C if(bht)omt=omt/2 !for BHT(1970) comparison c OM=dble(OMEGA(M0,NOMT)) OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+sngl(OMT) C IF(BPRNT2)WRITE(6,717)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT ENDDO ENDIF C c IF(NOMT.EQ.NOMWRT)GO TO 113 !WE ARE DONE c ENDIF ENDDO C c ENDIF ENDDO C ELSE C WRITE(6,1003) if(btimex)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par cpar else !par write(iw,*)'Top-up has *NOT* been applied!' cpar endif !par endif C ENDIF C c 113 CONTINUE c !x c test convert to cross section !x c !x c nomt=0 !x c do i=1,nmetaj !x c j=indxj(i) !x c wi=jn(j)+1 !x c do j=i+ione,nspecj !x c nomt=nomt+1 !x c de=dspecj(j)-dspecj(i) !x c do m0=1,moggy !x c ej=dyy0(m0) !x c ei=ej+de !x c if(brel)ei=ei+c4*ei*ei !wavenumber !x c om=dble(omega(m0,nomt)) !x c om=xconv*om/(ei*wi) !x c omega(m0,nomt)=sngl(om) !x c enddo !x c enddo !x c enddo !x C C----------------------------------------------------------------------- C C WRITE TOTALS C IF(BTHRSH)THEN WRITE(6,1001) IF(BPRNT0)THEN WRITE(6,1118)((I,J,J=I+ione,NSPECJ),I=1,NMETAJ) !ROWWISE DO M0=1,MOGGY WRITE(6,200)DBLE(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT) ENDDO ENDIF ELSE WRITE(6,1000) IF(BPRNT0)THEN WRITE(6,1117)((I,J,J=I+ione,NSPECJ),I=1,NMETAJ) !ROWWISE DO M0=1,MENG0 !=MOGGY WRITE(6,200)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT) ENDDO ENDIF ENDIF C IF(IUNIT(IU).GT.0)THEN c if(iunit(iuls).lt.0)then !same status as IU OPEN(IULS,FILE='OMGINFLS',STATUS='OLD') CLOSE(IULS,STATUS='DELETE') !tidy-up IUNIT(IULS)=-1 c endif CLOSE(IU,STATUS='DELETE') IF(BTHRSH)THEN IUNIT(IU)=-1 ELSE OPEN(IU,FILE='OMEGAIC',STATUS='REPLACE') !OPEN UNDER NEW NAME CTBD OPEN(IU,FILE='OMEGAUIC',STATUS='REPLACE',FORM='UNFORMATTED') WRITE(IU,*)NZION,MION WRITE(IU,*)NSPECJ,-(MENG0+1),NOMWRT !FLAG NO E'S .LT.0 WRITE(IU,*)(' 0',IWRK3(I),I=1,NSPECJ) WRITE(IU,711)(DWRK(I),I=1,NSPECJ) DO M0=1,MENG0 !=MOGGY WRITE(IU,713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT) ENDDO WRITE(IU,713)EINF,(OMGINF(N),N=1,NOMWRT) IUNIT(IU)=-1 CLOSE(IU) ENDIF ENDIF C C OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB C DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS C IF(IUNIT(IUU).GE.0)THEN !NO ADF04, LIKELY SINCE RAD='NO' WRITE(6,*)'NO ADF04 FILE="adf04ic"...' WRITE(0,*)'NO ADF04 FILE ON UNIT=',IUU C NF=-1 GO TO 800 ELSEIF(IUNIT(IUU).LT.0)THEN IUNIT(IUU)=1 OPEN(IUU,FILE='adf04ic',STATUS='OLD',ERR=800) ENDIF C BEXP=.FALSE. !*MUST* SYNC WITH DIAGFS IF(NSPECJ.LT.1000)THEN i1=0 IF(MOGGY.LE.20)THEN IF(BEXP)THEN F761='(F5.2, I5, 8X,20(1PE10.2))' F762='(2I4,22(1PE10.2))' F767='(18X,21(F10.5))' ELSE F761='(A5,A3,I2, 6X, 20(A5, A3))' F762='(2I4, 22(A5, A3))' F767='(16X,21(F8.5))' ENDIF ELSE IF(BEXP)THEN F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))' F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))' ELSE F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))' F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))' !WRAP LAST POINT ENDIF ENDIF ELSE i1=1 IF(MOGGY.LE.20)THEN IF(BEXP)THEN F761='(F5.2, I5,10X,20(1PE10.2))' F762='(2I5,22(1PE10.2))' F767='(20X,21(F10.5))' ELSE F761='(A5,A3,I2, 8X, 20(A5, A3))' F762='(2I5, 22(A5, A3))' F767='(18X,21(F8.5))' ENDIF ELSE IF(BEXP)THEN F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))' F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))' ELSE F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))' F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))' !WRAP LAST POINT ENDIF ENDIF ENDIF C MSC0=80 OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED') IF(.NOT.BEXP)THEN MSCP=81 OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED') ENDIF C DO N=1,NSPECJ+2 READ(IUU,760)CARD WRITE(MSC0,760)CARD ENDDO C NNN=max(NOMWRT,nomwr0) C DO N=1,NNN+2 READ(IUU,760,END=115)CARD WRITE(MSC0,760)CARD ENDDO C 115 REWIND(IUU) REWIND(MSC0) C DO N=1,NSPECJ+2 READ(MSC0,760)CARD WRITE(IUU,760)CARD ENDDO C backspace(iuu) card=' ' card(4:5)='-1' orbfmt='(1x,f7.?)' is=9+2*i1 ie=is+mxorb*7 if(ie.gt.200)then write(6,*)'***sr.dwxbp: card too short, need len=',ie write(0,*)'***sr.dwxbp: card too short' nf=-1 go to 800 endif do i=1,mxorb ie=is+7 if(dey(i).ne.dzero)then t=dey(i)-duy(i,i) if(bmvd)t=t+dmass(i,i)+dcd(i,i) t=-2*t endif write(orbfmt(8:8),'(i1)') x max(2,5-max(0,int(log10(max(t,d1m30))))) write(card(is:ie),orbfmt)t is=ie+1 enddo orbfmt=' ' orbfmt(1:6)='(a )' write(orbfmt(3:5),'(i3)')ie write(iuu,orbfmt)card(1:ie) c IF(BTHRSH)THEN ITYPE=6 WRITE(IUU,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY) IF(BEXP)THEN WRITE(IUU,F761)DBLE(NZA+1),ITYPE,(DBLE(M-1+LVMIN),M=1,MOGGY) ELSE WRITE(MSCP,764)(DBLE(M-1+LVMIN),M=1,MOGGY) ENDIF ELSE ITYPE=5 IF(BEXP)THEN WRITE(IUU,F761)DBLE(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY ELSE WRITE(MSCP,764)(DYY0(M),M=1,MENG0) !=MOGGY ENDIF ENDIF C IF(BEXP)THEN READ(MSC0,F761) ELSE BACKSPACE(MSCP) READ(MSCP,765)(XMANT(M),IEXP(M),M=1,MOGGY) iexp(0)=' ' READ(MSC0,F761)XMANT(0) !,IEXP(0) WRITE(IUU,F761)XMANT(0),IEXP(0),ITYPE X ,(XMANT(M),IEXP(M),M=1,MOGGY) ENDIF C MENG1=MOGGY+1 IB0=1 JB0=IB0+IONE c ntr=0 C DO N=1,NNN+1 C IF(BEXP)THEN READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1 ELSE READ(MSC0,F762)JB,IB,XMANT0,IEXP0, X (XMANT(I),IEXP(I),I=1,MXNXB),XMANT1,IEXP1 ENDIF C JB1=JB IF(JB.LT.0)THEN JB1=NSPECJ IB=MIN(JB1-IONE,NMETAJ) IF(BEXP)THEN XB0=D1M30 XB1=DZERO ELSE XMANT0=' 1.00' IEXP0='-30' XMANT1=' 0.00' IEXP1='+00' ENDIF ENDIF C IF(BEXP)THEN X0=D1M30 X1=DZERO ELSE XMANT(0)=' 1.00' IEXP(0)='-30' XMANT(MENG1)=' 0.00' IEXP(MENG1)='+00' ENDIF C DO JT=JB0,JB1 IF(JT.EQ.JB1)THEN IB1=IB ELSE IB1=MIN(JT-IONE,NMETAJ) ENDIF DO IT=IB0,IB1 C ctest if(ione.eq.0.or.it.ne.jt)then !catch ione=0 diagfs only ntr=ntr+1 c NOMT=IROW(IT,JT,IONE,NSPECJ) C !TEST MENG0 STILL IF BTHRSH IF(OMEGA(MENG0,NOMT).GT.TOLO)THEN !SKIP SA-SAP.GT.1 c c if(omginf(nomt).lt.dzero)then !test write reduced dipole c do m=1,moggy c de=log(dyy0(m)+2.7183) c omega(m,nomt)=omega(m,nomt)/de c enddo c endif C IF(BEXP)THEN IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN !NOW ALLOWED X0=XB0 X1=XB1 ENDIF WRITE(IUU,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1 ELSE BACKSPACE(MSCP) WRITE(MSCP,764)(OMEGA(M,NOMT),M=1,MOGGY) BACKSPACE(MSCP) READ(MSCP,765)(XMANT(M),IEXP(M),M=1,MOGGY) IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN !NOW ALLOWED XMANT(0)=XMANT0 IEXP(0)=IEXP0 XMANT(MENG1)=XMANT1 IEXP(MENG1)=IEXP1 ENDIF WRITE(IUU,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1) ENDIF C ENDIF ctest endif ENDDO IB0=1 ENDDO C IF(JB.LT.0)then if(ntr.ne.nomwrt)then !checksum write(6,*)'adf04 no. of transitions mis-match: ntr,nomwrt=' x ,ntr,nomwrt write(0,*)'adf04 no. of transitions mis-match' nf=-1 go to 800 endif GO TO 120 endif C JB0=JB IB0=IB+1 C ENDDO C WRITE(0,*)'SR.DWXBP: HAVE NOT REACHED END OF adf04ic...' WRITE(6,*)'SR.DWXBP: HAVE NOT REACHED END OF adf04ic...' NF=-1 GO TO 800 C 120 WRITE(IUU,F762)-1 WRITE(IUU,F762)-1,-1 c if(.not.badas)then !adas skip comments WRITE(IUU,758) C NREC=1 121 NREC=NREC+1 BACKSPACE(5) BACKSPACE(5) READ(5,766)CARD4 IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 121 REWIND(5) C DO N=1,NREC READ(5,760)CARD WRITE(IUU,759)CARD ENDDO DO I=1,8 DATE(I)=' ' ENDDO CALL DATE_AND_TIME(DATE8) !F95 WRITE(IUU,763)DATE(7),DATE(8),DATE(5),DATE(6),DATE(3) X ,DATE(4) endif C IUNIT(IUU)=-1 CLOSE(IUU) C CLOSE(MSC0) IF(.NOT.BEXP)CLOSE(MSCP) C C----------------------------------------------------------------------- C 800 CONTINUE C DEALLOCATE(RHO1,RHO2,TEMP,TMPX,OMGINF,OMEGA,STAT=IERR) !F95 cparc !par cpar deallocate(omsend,omrecv,stat=ierr) !par C IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXBP: DEALLOCATION FAILS FOR RHO,OMEGA,TEMP' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C 900 DEALLOCATE(TFU,STAT=IERR) !F95 C IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXBP: DEALLOCATION FAILS FOR TFU' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C 999 CONTINUE C C----------------------------------------------------------------------- C if(btimep)then call cpu_time(timef) times=timef-time0 c C if(iabs(modd).le.1)then c cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for dwxbp:' !par cpar x ,' time=',nint(times),'sec' !par cpar else !par write(iw,*)'Ending dwxbp: time=',nint(times),'sec' cpar endif !par C endif endif C C----------------------------------------------------------------------- C RETURN C C 200 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3))) 201 FORMAT(2I6,3X,2I5,2X,1P,10(E11.3)/(27X,10(E11.3))) 202 FORMAT(2I6,3X,2I5,2X,1PE11.3,10X,'E(',I2,') ',A10) 711 FORMAT(1P,5E16.6) 713 FORMAT(1PE14.8,6E11.3/(14X,6E11.3)) 716 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE', X9X,'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)') 717 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4) 758 FORMAT('C',79('-')/'C'/'C') 759 FORMAT('C ',A200) 760 FORMAT(A200) 763 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X X ,'AUTOSTRUCTURE DISTORTED-WAVE'/ X 'C'/'C NAME:'/'C DATE: ',2(A1),'/',2(A1),'/',2(A1)/ X 'C'/'C',79('-')) 764 FORMAT(22(1PE9.2)) 765 FORMAT(22(A5,1X,A3)) 766 FORMAT(A4) 995 FORMAT(1X,3I10,13X,I7,3I5,F19.8) 996 FORMAT(10X,'K',8X,'LV',8X,' T',17X,'2*S+1 L 2J CF',9X, X '(EK-E1)/RY',15X,'NMETAJ=',I5) 1000 FORMAT(///1X,136('-')//51X, X '*** TOTAL COLLISION STRENGTHS (BP) ***'//1X,136('-')//) 1001 FORMAT(///1X,136('-')//45X, X '*** THRESHOLD PARTIAL COLLISION STRENGTHS (BP) ***'// X 1X,136('-')//) 1002 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//) 1003 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//) 1110 FORMAT(//1X,136('-')/// X 49X,'*** TARGET ENERGIES (IC) ***'/) 1111 FORMAT(//1X,136('-')/) 1112 FORMAT(' SYJ=',I3,5X,'2J P =',I4,I3,5X,'NCHJT=',I6) 1113 FORMAT(//' SY1=',I3,5X,'(2S+1) L P =',I3,I4,I3) !/1X,34('-')) 1114 FORMAT(//' SYJ=',I3,5X,'2J P =',I4,I3/1X,25('-')) 1115 FORMAT(//' SY2=',I3,5X,'(2S+1) L P =',I3,I4,I3) !/1X,34('-')) 1116 FORMAT(/4X,'CH',3X,'CHP',7X,'K',3X,'KP',4X,'OMEGA(IE=1,MENG):') 1117 FORMAT(74X,'OMEGA(K-KP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)' X ,2X,10(I5,'-',I5)/(23X,10(I5,'-',I5))) 1118 FORMAT(74X,'OMEGA(K-KP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.' X ,2X,10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4))) 1150 FORMAT(/' NCYC SY CH CHP MNF MNR',6(3X,'I(R) F(A,...)' X)) 1201 format(i9,i5,2i4,2i5,i9,i6,6(i6,f9.4)) 1202 format(i9,i5,2i4,2i5,i9,i6,6(i6,f9.4)/(47x,6(i6,f9.4))) 1996 FORMAT(/' *** UPDATING SLATER INTEGRALS FOR LTOT=', X I3/1X,42('-')/) 1997 FORMAT(/' *** UPDATING MAGNETIC INTEGRALS FOR 2*JTOT=', X I3/1X,46('-')/) 3050 FORMAT(7X,'NP',2X,'SYJ',2X,'SY',1X,'SYP',3X,'CH',2X,'CHP',7X, X'CN',3X,'IND',6(3X,'I(Y) X(A-D)')) 9119 format(i8,i3, 2i5, i8,i5, 6(i6,f11.6)) 9120 format(i8,i3, 2i5, i8,i5, 6(i6,f11.6)/(34x,6(i6,f11.6))) 9121 format((34x,6(i6,f11.6))) C END C C ******************* C SUBROUTINE DWXLS(FRX,PSHFTX,DRLX,MDIM0,MDIM1,MDIM2,MDIM3,MDIM4 X ,MDIM5,DZLX,DXTWOX,DETAX,MDIM6,MDIM7,MDIM8) C C----------------------------------------------------------------------- C C SR.DWXLS CALCULATES EIE 2-BODY NFS COLLISION STRENGTHS IN LS-COUPLING C C IT CALLS: C FN.QPTLS C SR.RADCNX C SR.SLATRX C SR.TOP1 C SR.TOP2 C FN.XINT C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam,comm_barrier !par cpar use mpi !par C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL,NAD !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD06=MXENG*MXENG) PARAMETER (MXD13=500) PARAMETER (MXD14=100) C PARAMETER (MXD1=MXENG/10, X MXD2=10/MXENG, X MXD3=MXD1+MXD2, X MXD4=MXENG*MXD1/MXD3+10*MXD2/MXD3+3) C PARAMETER (MXNXB=10) !NO. OF BPW X-VALUES PRE-EXISTING IN ADF04 c real*4 e1m30 C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (D3O4=3.0D0/4.0D0) PARAMETER (E1M30=1.E-30) PARAMETER (D1M30=1.D-30) c c parameter (dfour=4.0d0) !x c parameter (dfsc=7.2973525333d-03) !x c parameter (dalf=dfsc*dfsc) !x c parameter (c4=dalf/dfour) !x C PARAMETER (XMIX=1.D-4) !not speed-sensitive C C THESE ARE ACTUAL MAX REQUIREMENTS BUT LARGE STRUCTURE RUNS WILL C OVERINFLATE. SINCE F95 TAKES CARE OF THIS BY ALLOCATE, NOT WORTH C ADDED NEW VARIABLES TO PARAM. JUST HARD-WIRE SAFE SMALL VALUES. C CF77C PARAMETER (NDIM0=MXD06) !F77 CF77C PARAMETER (NDIM1=MAXDI*MAXDI) !F77 CF77C PARAMETER (NDIM2=(MAXTM*(MAXTM+1))/2) !F77 CF77 PARAMETER (NDIM0=300) !F77 CF77 PARAMETER (NDIM1=3000) !F77 CF77 PARAMETER (NDIM2=20000) !F77 C INTEGER SA,SAP c CF77 integer*8 nrk !F77 c real*4 omega cpar real*4 omsend,omrecv !par C LOGICAL BPRNT0,BPRNT2,BPRNT3,BKUTOO,BTHRSH x ,eqgrp,eqgrpl,eqgrpl0,bcorr,becor,bcor,badas x ,bunit,bht,brmx,bmix,btime,btimex,btimep,bswap,bntest X ,BREL,BJUMPR,BMVD,BEXP CF77 X ,BFALL !F77 c logical brel,bjumpr,bmvd !x C CHARACTER(LEN=1) DATE CHARACTER(LEN=3) IEXP,IEXP0,IEXP1 CHARACTER(LEN=4) CARD4 CHARACTER(LEN=5) XMANT,XMANT0,XMANT1 CHARACTER(LEN=8) DATE8 !F95 character(len=9) orbfmt CHARACTER(LEN=15) F767 CHARACTER(LEN=35) F762 CHARACTER(LEN=44) F761 CHARACTER(LEN=200) CARD C DIMENSION DATE(8) DIMENSION IEXP(0:MXD4),XMANT(0:MXD4) C CF77 DIMENSION RHO1(NDIM0,NDIM1),RHO2(NDIM0,NDIM1) !F77 CF77 DIMENSION OMEGA(MXENG,NDIM2),TFU(MAXUC),TMPX(MAXDI) !F77 CF77 DIMENSION TEMP(NDIM0,MAXDI),OMGINF(NDIM2) !F77 C ALLOCATABLE :: RHO1(:,:),RHO2(:,:),OMEGA(:,:),TFU(:),TMPX(:) !F95 X ,TEMP(:,:),OMGINF(:) !F95 cpar allocatable :: omsend(:),omrecv(:) !par C DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3),PSHFT0(0:20) X ,DRLX(MDIM4,MDIM0,0:MDIM5) X ,DZLX(MDIM7,MDIM6,0:MDIM8) X ,DXTWOX(MDIM7,MDIM6,0:MDIM8) X ,DETAX(MDIM7,MDIM6,0:MDIM8) DIMENSION NADRUG(MAXSL),TMP(MXENG,MXENG),OMP(MXENG) c dimension bswap(mxd13) dimension ntest(1,1) !check channel set-up C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) c COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT c COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MGP1(2),KSUBCF COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW3/KACT(MAXCF,MAXCF) COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW6/QPOS(MAXGR),QPOS0(MAXGR) COMMON /NRBDW7/MNDEX(MXD06,2),MRNDX(MXD06),MTRAN,mlim(mxeng,2) COMMON /NRBDW8/DYY0(MXENG),IYY0(MXENG),MENG0 COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /WORKLS/DWRK(MAXTM),IWRK3(MAXTM),IWRK4(MAXTM) c common /nrbone/ione,ione0 common /nrbtim/iw,iwp,btime,btimex c common /nrbrel/brel,bjumpr,bmvd,irel,kappa,igagr,irtard,ibreit !x c common /hps/badas C EQUIVALENCE (DATE(1),DATE8) !F95 C DATA LOLD/-1/,IU/23/,IUU/25/ c omginfls adf04ls C IROW(ILI,ILF,IONE,NENG)=ILF+NENG*(ILI-1)-(ILI*(ILI-1+2*IONE))/2 C C----------------------------------------------------------------------- C c some test set-up switches that user joe should not need to touch. c bht=.false. !.true. for bht(1970) test comparison c !x c some cross section units options: need to uncomment code above and !x c below labeled "!x" !x c !x c xconv=done !pi*a_0^2 !x c xconv=xconv*acos(-done) !a_0^2 !x c xconv=xconv*28.003d0 !Mbarns !x c xconv=xconv*1.d6 !barns !x c c elastic switch (normally ione=1, no elastic. ione=0 inc elastic) c now set by user in algeb, and passed thru /nrbdwm/ as needed. c cold ione=1 c c test: DO NOT CHANGE! cold ione0=0 !algxls ione, elastic needed for mixing c c set (approx) unitarity switch c bunit=.true. if(bht)bunit=.false. c c set mixing switch, can test switching-off mixing. c bmix=.true. c c set print of r(tau=0)-matrix as opposed to rho(tau)-matrix c *MUST* use full T=-2iR/(1-iR) if converting via R-matrix. (not done) c can only use weak coupling T=-2i*rho for rho-matrix. (always) c brmx=.false. if(jprint.eq.4)brmx=.true. c c checks channel set-up (needs ntest dimensioned) c bntest=.false. !ione.eq.0.and.nmeta.ge.nspece.and.jprint.ge.2 ncht=1 c c if bcor then we have algebraic correlation, and we know how ordered c bcor=km*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD(NCOR) c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- c btimep=btimex !for iam.ne.0 if(btimex)then c if(iabs(modd).le.1)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for dwxls' !par cpar else !par write(iw,*)'Starting dwxls' cpar endif !par c endif call cpu_time(timei) time0=timei endif C C INITIALIZATIONS C PI=ACOS(-DONE) TPI=DTWO*PI C BPRNT2=JPRINT.GE.2 !FOR DETAILED OMEGA PRINTOUT BPRNT3=JPRINT.GE.3 !FOR DETAILED RHO PRINTOUT BPRNT0=JPRINT.NE.-3 C KOLDOO=KUTOOX BKUTOO=KUTOOX.NE.0 c IF(NZION.EQ.MION)THEN NZA=0 DZ2=DONE ELSE NZA=NZION-MION DZ2=NZA*NZA ENDIF C LSTORE=0 !TRIVIAL INTEGRAL STORAGE C IF(MAXLT.GE.0)THEN IF(LRGLAM.GT.MAXLT)THEN WRITE(0,*)'*** SR.DWXLS: LRGLAM.GT.MAXLT, SO NO TOP-UP' LRGLAM=-1 ELSE IF(LRGLAM.EQ.-999)LRGLAM=MAXLT ENDIF IF(LRGLAM.EQ.0)LRGLAM=-1 ENDIF C IF(LRGLAM.GE.0)THEN !SET L WHERE DIPOLE TOP-UP NEEDS CHECKS LRGLMN=LRGLAM-QMCL ELSE LRGLMN=1000 ENDIF C C SET POINTER TO START OF GROUP IN MIXING COEFFICIENT ARRAY TFU C MC=0 NCMX=0 DO N0=1,NSL0 NADRUG(N0)=MC NC=NSL(N0) NCMX=MAX(NCMX,NC) !MAX NO TERMS IN GROUP MC=MC+NC*NC ENDDO C C RECOVER TARGET MIXING COEFFICIENTS C READ(MR)NCTOT C if(nctot.ne.mc)stop 'dwxls:nctot index error' !shouldn't happen C ALLOCATE(TFU(NCTOT),STAT=IERR) !F95 C IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXLS: ALLOCATION FAILS FOR TFU' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C READ(MR)(TFU(I),I=1,NCTOT) C C LOOK FOR LAST SPECTROSCOPIC ENERGY C c NSPECL=0 c DO N=1,NENERG c NSPECL=MAX(NSPECL,JNDEX(N)) c ENDDO C C USE ROWWISE TO SIMPLY REDUCE NDIM2 IF NMETA.LT.NSPECE C NOMTG=NCMX*NCMX !NEED ALL FOR MIXING nmin=min(NMETA,NSPECE) NOMWRT=IROW(nmin,NSPECE,ione,NSPECE) !ROWWISE NOMWR0=NOMWRT ctest if(ione.eq.1)nomwr0=nomwr0+nmin !incase ione=0 in diagon C CF77 IF(MTRAN.GT.NDIM0.OR.NOMTG.GT.NDIM1.OR. !F77 CF77 X NOMWRT.GT.NDIM2)THEN !F77 CF77 WRITE(6,*)'SR.DWXLS: NDIM0,1,2=',NDIM0,NDIM1,NDIM2 !F77 CF77 X ,' BUT REQUIRE',MTRAN,NOMTG,NOMWRT !F77 CF77 WRITE(6,*)'TO AVOID INFLATION, USE F95 CODE/COMPILER' !F77 CF77 WRITE(0,*)'*** TIME TO USE F95 CODE/COMPILER!' !F77 CF77 NF=-1 !F77 CF77 GO TO 999 !F77 CF77 ENDIF !F77 C BTHRSH=LVMAX.GE.0 IF(BTHRSH)THEN MOGGY=LVMAX+1-LVMIN CF77 IF(MOGGY.GT.MXENG)THEN !F77 CF77 WRITE(6,*)'SR.DWXLS: USE OF LVMAX=',LVMAX, !F77 CF77 X ' REQUIRES MXENG=',LVMAX+1,' (=LVMAX+1)' !F77 CF77 WRITE(0,*)'*** TIME TO USE F95 CODE/COMPILER!' !F77 CF77 NF=-1 !F77 CF77 GO TO 999 !F77 CF77 ENDIF !F77 ELSE MOGGY=MENG0 ENDIF C ALLOCATE(RHO1(MTRAN,NOMTG),RHO2(MTRAN,NOMTG),TEMP(MTRAN,NCMX) !F95 X ,TMPX(NCMX),OMGINF(NOMWR0),OMEGA(MOGGY,NOMWRT),STAT=IERR) !F95 cparc !par cpar allocate(omsend(nomwrt),omrecv(nomwrt),stat=ierr) !par C IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXLS: ALLOCATION FAILS FOR RHO,OMEGA,TEMP' !F95 NF=0 !F95 GO TO 900 !F95 ENDIF !F95 C DO N=1,NOMWRT OMGINF(N)=DZERO DO M=1,MOGGY OMEGA(M,N)=0 ENDDO ENDDO C C RECOVER INFINITE ENERGY INFO (ROWWISE) C IF(IUNIT(IU).EQ.0)THEN !ADF04 WILL BE INCOMPLETE WRITE(6,*)'NO INFINITE ENERGY FILE="OMGINFLS"...' WRITE(0,*)'NO INFINITE ENERGY FILE ON UNIT=',IU IF(LRGLAM.GE.0)THEN WRITE(6,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP' WRITE(0,*)'NO INFINITE ENERGY FILE INFO, CANNOT TOP-UP' NF=-1 GO TO 800 ELSE GO TO 110 ENDIF ELSEIF(IUNIT(IU).LT.0)THEN OPEN(IU,FILE='OMGINFLS',STATUS='OLD',ERR=110) IUNIT(IU)=1 ELSE !SHOULD NOT BE HERE REWIND(IU) !ALREADY OPEN... stop 'dwxls: omginfls confusion' ENDIF C READ(IU,*)NZDUM,MDUM READ(IU,*)NSPEC0,MENGB,NOMWR0 C IF(NSPEC0.NE.NSPECE)THEN !SHOULD NOT HAPPEN, NOW WRITE(6,*)'DWXLS: INFINITE ENERGY TARGET MISMATCH',NSPEC0,NSPECE WRITE(0,*)'DWXLS: INFINITE ENERGY TARGET MISMATCH' NF=-1 GO TO 800 ENDIF C READ(IU,*)(IWRK3(I),IWRK4(I),I=1,NSPEC0) READ(IU,711)(DWRK(I),I=1,NSPEC0) C c optionally recover spec energy subset from omginf, c and retain full-set in denerg back in algx. c c do i=1,nspec0 c dwrk(i)=dwrk(i)*dz2 c enddo c iflag=0 if(nomwrt.ne.nomwr0)then !should not happen in non-test mode if(ione.eq.0)then !elastic in dwxls if(nomwrt-nmin.ne.nomwr0)then write(6,*)'dwxls: infinite energy omega mismatch' x ,nomwrt,nomwr0 write(0,*)'dwxls: infinite energy omega mismatch' nf=-1 go to 800 else !case ione=1 in diagon iflag=1 endif else !inelastic in dwxls if(nomwrt+nmin.ne.nomwr0)then write(6,*)'dwxls: infinite energy omega mismatch' x ,nomwrt,nomwr0 write(0,*)'dwxls: infinite energy omega mismatch' nf=-1 go to 800 else !case ione=0 in diagon iflag=2 endif endif endif C READ(IU,713)EINF,(OMGINF(I),I=1,NOMWR0) cparc cpar if(iam.ne.0)then cpar IUNIT(IU)=-1 cpar CLOSE(IU) cpar endif c if(iflag.eq.1)then !make room for elastic n=nomwrt+1 nshft=nmin do i=nmin,1,-1 do j=nspec0,i+1,-1 n=n-1 omginf(n)=omginf(n-nshft) enddo n=n-1 omginf(n)=done !flag poss. allowed nshft=nshft-1 enddo if(n.ne.1)stop 'iflag=1 nshft error' elseif(iflag.eq.2)then !drop elastic n=0 nshft=1 do i=1,nmin do j=i+1,nspec0 n=n+1 omginf(n)=omginf(n+nshft) enddo nshft=nshft+1 enddo if(n.ne.nomwrt)stop 'iflag=2 nshft error' endif C 110 CONTINUE C C WRITE-OUT SPEC. TARGET ENERGIES C WRITE(6,1110) WRITE(6,996)NMETA C DO J=1,NSPECE I=INDEX(J) JJ=NFQ(I) II=(1-QPI(JJ))*(QSI(JJ)+1) WRITE(6,995)J,I,II,QLI(JJ)/2,NFK(I),DSPECE(J) ENDDO C WRITE(6,1111) C C----------------------------------------------------------------------- C C BEGIN LOOP OVER SCATTERING SYMMETRIES C C----------------------------------------------------------------------- C NCOR=0 c iwait=0 wait=done C DO IX=1,INAST C IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 C LNEW=IL C IF(BKUTOO.AND.LNEW.GT.MAXLOO)THEN KUTOOX=0 BKUTOO=.FALSE. ENDIF C C SEE IF WE NEED TO UPDATE INTEGRALS & CONTINUUM BASIS C IF(LNEW.NE.LOLD)THEN C C----------------------------------------------------------------------- C if(btimex)then cc if(iabs(modd).gt.1)then ADD IC FLAG cpar if(iam.ge.0)then !par cpar write(iwp,*)'Starting proc',iam !par cpar x ,'updating continuum for l=',il !par cpar call flush(iwp) !par cpar else !par write(iw,*) x 'Begin update of continuum basis & integrals for L=',lnew cpar endif !par cc endif c call cpu_time(timei) times=timei endif C C----------------------------------------------------------------------- C lstep=lnew-lold if(lstep.gt.1.and.lfact.gt.100.and.lold.gt.0)then if(iwait.eq.4)then iwait=2 else iwait=4 endif wait=iwait*lstep wait=wait/dthree endif C C UPDATE CONTINUUM BASIS C IF(BTHRSH)LCONDW=-LCONDW !FLAG C CALL RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,LOLD X ,LCONDW,MXORB) C IF(NF.LT.0)GO TO 800 C C UPDATE EXCHANGE MULTIPOLE C LDIFF=LNEW IF(LOLD.GE.0)LDIFF=LDIFF-LOLD LDIFF=LDIFF+LDIFF C DO I=1,IRL IF(QRL(2,I).GT.MXORB)QRL(5,I)=QRL(5,I)+LDIFF !EXCHANGE ENDDO C C UPDATE SLATER INTEGRALS (INC. 2NFS IF BKUTOO=.TRUE.) C IF(BPRNT0)WRITE(6,1996)LNEW C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) IF(BKUTOO)THEN CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DRLX(1,M,LSTORE) X ,DZLX(1,M,LSTORE) X ,DXTWOX(1,M,LSTORE) X ,DETAX(1,M,LSTORE) X ,M1,M2,LNEW,MAXLX,MXORB) ELSE CALL SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DRLX(1,M,LSTORE) X ,DZLX(1,1,0) X ,DXTWOX(1,1,0) X ,DETAX(1,1,0) X ,M1,M2,LNEW,MAXLX,MXORB) ENDIF ENDDO C LOLD=LNEW C C----------------------------------------------------------------------- C if(btimex)then call cpu_time(timef) times=timef-times c cc if(iabs(modd).gt.1)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'Ending proc',iam !par cpar x ,'updating continuum' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iwp) !par cpar else !par write(iw,*)'End update of continuum basis & integrals' x ,', time=',nint(times),'sec' cpar endif !par cc endif endif C C----------------------------------------------------------------------- C ENDIF C C C INITIALIZE FOR LS-LOOP C nwt=is if(il.gt.maxlx)nwt=-2*is+2 c if(bntest)then do i=1,ncht do j=1,ncht ntest(j,i)=0 enddo enddo endif c IF(BPRNT0)WRITE(6,1115)IX,nwt,IL,IP IF(.NOT.BPRNT0)WRITE(6,1114)IX,nwt,IL,IP IF(BPRNT2)WRITE(6,1116) C C----------------------------------------------------------------------- C if(btimex)then cc if(iabs(modd).gt.1)then cpar if(iam.ge.0)then !par cpar write(iwp,*)'Starting proc',iam !par cpar x ,'dwxls symmetry',ix,':',nwt,il,ip !par cpar call flush(iwp) !par cpar else !par write(iw,*)'Starting dwxls symmetry',ix,':',nwt,il,ip cpar endif !par cc endif c call cpu_time(timei) times=timei endif C C----------------------------------------------------------------------- C nwt=iabs(nwt)*(2*il+1) C C NOW FORM LS INTERACTION (BY TARGET SYMMETRY GROUP) C************************* C C THIS IS IN THE RHO-I REPRESENTATION, WHERE C |T^R(V,V')|=|T^RHO(V,V')| FOR CHANNELS V.NE.V'. C WE USE T^RHO(V,V')=-2I*RHO(V,V'), WITH A 2X2 UNITARITY CONDITION. C FOR V.EQ.V' T^R(V,V)~-2*TAN(TAU(V)), FOR RHO(V,V) SMALL. C (IN GENERAL, WE ARE NOT INTERESTED IN ELASTIC TRANSITIONS.) C C NCN=NCHG(IX) C NCHI=0 NCHI0=0 C DO NC0=1,NCN !BEGIN LOOP OVER INITIAL GROUPS L1=LLCH(1,NC0,IX) L2=LLCH(2,NC0,IX) NC=ITARG(NC0,IX) MC=NSL(NC) SA=QSI(NC) LA=QLI(NC) MCI=NGRPI(NC) C NCHIP=0 NCHIP0=0 C DO ND0=1,NC0 !BEGIN LOOP OVER FINAL GROUPS L1P=LLCH(1,ND0,IX) L2P=LLCH(2,ND0,IX) ND=ITARG(ND0,IX) MCP=NSL(ND) SAP=QSI(ND) C IF(ABS(SA-SAP).GT.2)GO TO 68 !unnecessary... IF(NMETAG(NC)+NMETAG(ND).EQ.2)THEN NCHI=NCHI0+((L2-L1)/4+1)*MC NCHIP=NCHIP0+((L2P-L1P)/4+1)*MCP GO TO 68 ENDIF LAP=QLI(ND) MCIP=NGRPI(ND) C eqgrp=nc.eq.nd !flag equal groups for filling rho1 c c get lambda for non-dipole infnite energy top-up c if(lnew.ge.lrglam)then if(sa.eq.sap)then litlam=0 if(qpi(nc).ne.qpi(nd))then litlam=3 !for case of octupole else if(la-lap.eq.0)then if(la+lap.ge.4)litlam=2 else litlam=iabs(la-lap)/2 endif endif else litlam=-1 endif endif C NCHI=NCHI0 DO LI=L1,L2,4 !LOOP OVER INITIAL CHANNEL L C c set position of phase shift for this li c only required by elastic case for diagonal rho c or if printing usual reactance matrix c if(ione.eq.0.or.brmx)then L=LCONDW/2+1-LNEW+LI/2 L0=IABS(QPOS(L)) endif C lf2=l2p if(eqgrp)lf2=li c NCHIP=NCHIP0 DO LF=L1P,lf2,4 !LOOP OVER FINAL CHANNEL L c eqgrpl=eqgrpl0.and.eqgrp.and.li.eq.lf c qcor=qptls(ix,nc0,nd0,li,lf) if(qcor.ne.ncor)then write(0,*)ix,nc0,nd0,li,lf,ncor,qcor stop 'ncor mis-match' endif C c set position of phase shift for this lf c only need if printing usual reactance matrix, not needed by rho matrix C if(brmx)then L=LCONDW/2+1-LNEW+LF/2 L00=IABS(QPOS(L)) endif C NOMTG=MC*MCP DO N=1,NOMTG DO M=1,MTRAN RHO1(M,N)=DZERO ENDDO ENDDO C DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS J1=MD1+MCI j=jndex(j1) KF=NFK(J1) C DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS J1P=MDP1+MCIP IF(eqgrpl.and.J1P.GT.J1-ione0)GO TO 2 !sync algxls c jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then !omit cor-cor, as algxls if(becor)then ncor=ncor+1 go to 1 endif go to 2 endif C N1=NAD(NCOR)+1 NCOR=NCOR+1 N2=NAD(NCOR) c write(73,*)ix,md1,mdp1,j,jp,ncor,n2 IF(N1.GT.N2)GO TO 1 KG=NFK(J1P) c c need to find if Slater integral initial and final states are swapped c because of falling order. (algebraic are not swapped in LS.) c if(n2-n1+1.gt.mxd13)then write(6,*)'***sr.dwxls: increase internal buffer', x ' mxd13 to', n2-n1+1 nf=-1 go to 800 endif c ks=0 do n=n1,n2 ks=ks+1 bswap(ks)=.false. n0=int(nrk(n)) m0=qrl(1,n0) if(li.eq.ql(m0))then if(li.eq.lf.and.kf.ne.kg)then m0=qrl(3,n0) if(qn(m0).gt.0)then !exchange if(m0.ne.kact(kg,kf))then !swap bswap(ks)=.true. endif c else !direct and it doesn't matter endif c else !distinct or kf=kg so they can't endif else !trivially, they were bswap(ks)=.true. endif enddo C NOMTG=(MDP1-1)*MC+MD1 if(eqgrpl)nmteq=(md1-1)*mcp+mdp1 C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) C DD=DZERO ks=0 DO N=N1,N2 ks=ks+1 c if(bswap(ks))then !swap because of falling order mm=mrndx(m) else mm=m endif c N0=INT(NRK(N)) C DD=DD+DRLX(N0,mm,LSTORE)*DRK(N) IF(BKUTOO)THEN DS=DZLX(N0,mm,LSTORE) IF(BFALL(N))DS=-DS DS=DS+DXTWOX(N0,mm,LSTORE)*DRK(N) X +DETAX(N0,mm,LSTORE)*DEK(N) DD=DD+DS ENDIF ENDDO c RHO1(M,NOMTG)=RHO1(M,NOMTG)+DD !UNMIXED c if(eqgrpl.and.nomtg.ne.nmteq)then !pop lower tri mm=mrndx(m) !need reverse rho1(mm,nmteq)=rho1(mm,nmteq)+dd endif C ENDDO c c write(6,777)j1,j1p,(rho1(m,nomtg),m=1,mtran) c 777 format(2i5,1p,10d12.3/(10x,10d12.3)) C 1 ENDDO !END LOOP OVER FINAL TERMS C 2 ENDDO !END LOOP OVER INITIAL TERMS C C----------------------------------------------------------------------- c c test skip mixing c if(.not.bmix)then do md1=1,mc j1=md1+mci j=jndex(j1) if(j.lt.0)go to 31 ng0=(md1-1)*mcp do mdp1=1,mcp j1p=mdp1+mcip if(j1p.gt.j1.and.li.eq.lf)go to 31 if(j1.eq.j1p.and.ione.ne.0)go to 21 jp=jndex(j1p) if(jp.lt.0)go to 21 if(min(j,jp).gt.nmeta)go to 21 ng1=(mdp1-1)*mc+md1 ng2=ng0+mdp1 do m=1,mtran rho2(m,ng2)=rho1(m,ng1) enddo 21 enddo 31 enddo go to 130 endif C C NOW MIX (INITIAL) C N0=NADRUG(NC) N0P=NADRUG(ND) C MCI=NGRPI(NC) C MCIP=NGRPI(ND) C MC=NSL(NC) C MCP=NSL(ND) C DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS C J1=MD1+MCI j=jndex(j1) if(j.lt.0)go to 11 !omit corr. if(j.gt.nmeta)go to 11 !omit non-metastable c if(bcorr.or.li.eq.lf)then DO MDP1=1,MCP !SEE IF WE HAVE A FINAL TERM J1P=MDP1+MCIP IF(J1P.GT.J1.and.li.eq.lf)GO TO 11 jp=jndex(j1p) if(jp.gt.0)go to 5 !we do ENDDO GO TO 11 !WE DON'T endif C 5 N1=N0+(MD1-1)*MC DO LD1=1,MC N2=N1+LD1 TMPX(LD1)=TFU(N2) c write(6,777)n1,n2,tfu(n2) ENDDO C DO MDP1=1,MCP !FOR EACH FINAL TERM C DO M=1,MTRAN TEMP(M,MDP1)=DZERO ENDDO C NG0=(MDP1-1)*MC DO LD1=1,MC !BEGIN INITIAL MIXING C NG=NG0+LD1 !rho1 nomtg TF=TMPX(LD1) C IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN TEMP(M,MDP1)=TEMP(M,MDP1)+RHO1(M,NG)*TF ENDDO ENDIF c ENDDO !END INITIAL MIXING C c j1p=mdp1+mcip c write(6,777)j1,j1p,(temp(m,mdp1),m=1,mtran) c ENDDO !FOR EACH FINAL TERM C C NOW MIX (FINAL) C NOMTG0=(MD1-1)*MCP DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS C J1P=MDP1+MCIP IF(J1P.GT.J1.and.li.eq.lf)GO TO 11 if(j1.eq.j1p.and.ione.ne.0)go to 10 c jp=jndex(j1p) if(jp.lt.0)go to 10 !omit corr. c if(min(j,jp).gt.nmeta)go to 10 !non-metastable c N1P=N0P+(MDP1-1)*MCP C NOMTG=NOMTG0+MDP1 !rho2 nomtg (new) DO M=1,MTRAN RHO2(M,NOMTG)=DZERO ENDDO C DO LDP1=1,MCP !BEGIN FINAL MIXING c N2P=N1P+LDP1 TF=TFU(N2P) c IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN RHO2(M,NOMTG)=RHO2(M,NOMTG)+TEMP(M,LDP1)*TF ENDDO ENDIF c ENDDO !END FINAL MIXING c c write(6,777)j1,j1p,(rho2(m,nomtg),m=1,mtran) 10 ENDDO !END LOOP OVER FINAL TERMS C 11 ENDDO !END LOOP OVER INITIAL TERMS C C FIRST SEE IF WE NEED REVERSE CASE: C C INITIAL & FINAL ARE ALGEBRAIC AND SO NMETA CAN BE IN EITHER/BOTH/NONE C BUT WE WANT THE FIRST MIXING MATRIX MULT TO BE FOR NMETA SO WE DON'T C NEED TO MULTIPLY BY THE ZERO BLOCK. THUS, WE MAKE A DOUBLE PASS. OF C COURSE, IF NMETA=NSPECE THEN THE SECOND PASS IS "SKIPPED". C DO MDP1=1,NSL(NC) !CHECK INITIAL TERMS J1P=MDP1+NGRPI(NC) jp=jndex(j1p) if(jp.gt.nmeta)go to 8 !needed ENDDO GO TO 130 !ALL DONE C C NOW MIX (FINAL) - REVERSE CASE C 8 N0=NADRUG(ND) N0P=NADRUG(NC) MCI=NGRPI(ND) MCIP=NGRPI(NC) MC=NSL(ND) MCP=NSL(NC) C DO MD1=1,MC !BEGIN LOOP OVER FINAL TERMS C J1=MD1+MCI j=jndex(j1) if(j.lt.0)go to 13 !omit corr. if(j.gt.nmeta)go to 13 !omit non-metastable c DO MDP1=1,MCP !SEE IF WE HAVE INITIAL TERM J1P=MDP1+MCIP IF(J1P.LT.J1.and.li.eq.lf)GO TO 6 jp=jndex(j1p) if(jp.gt.nmeta)go to 7 !we do 6 ENDDO GO TO 13 !WE DON'T C 7 N1=N0+(MD1-1)*MC DO LD1=1,MC N2=N1+LD1 TMPX(LD1)=TFU(N2) c write(6,777)n1,n2,tfu(n2) ENDDO C DO MDP1=1,MCP !FOR EACH INITIAL TERM C DO M=1,MTRAN TEMP(M,MDP1)=DZERO ENDDO C DO LD1=1,MC !BEGIN FINAL MIXING C NG=MDP1+(LD1-1)*MCP !rho1 nomtg TF=TMPX(LD1) C IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN TEMP(M,MDP1)=TEMP(M,MDP1)+RHO1(M,NG)*TF ENDDO ENDIF c ENDDO !END FINAL MIXING C c j1p=mdp1+mcip c write(6,777)j1,j1p,(temp(m,mdp1),m=1,mtran) c ENDDO !FOR EACH INITIAL TERM C C NOW MIX (INITIAL) - REVERSE CASE C DO MDP1=1,MCP !BEGIN LOOP OVER INITIAL TERMS C J1P=MDP1+MCIP IF(J1P.LT.J1.and.li.eq.lf)GO TO 12 if(j1.eq.j1p.and.ione.ne.0)go to 12 c jp=jndex(j1p) c if(jp.lt.0)go to 12 !omit corr. if(jp.le.nmeta)go to 12 !already gotten c N1P=N0P+(MDP1-1)*MCP C NOMTG=MD1+(MDP1-1)*MC !rho2 nomtg (new) DO M=1,MTRAN RHO2(M,NOMTG)=DZERO ENDDO C DO LDP1=1,MCP !BEGIN INITIAL MIXING c N2P=N1P+LDP1 TF=TFU(N2P) c IF(ABS(TF).GT.XMIX)THEN DO M=1,MTRAN RHO2(M,NOMTG)=RHO2(M,NOMTG)+TEMP(M,LDP1)*TF ENDDO ENDIF c ENDDO !END INITIAL MIXING c c write(6,777)j1,j1p,(rho2(m,nomtg),m=1,mtran) 12 ENDDO !END LOOP OVER INITIAL TERMS C 13 ENDDO !END LOOP OVER FINAL TERMS C C RE-SET MCI=NGRPI(NC) MCIP=NGRPI(ND) MC=NSL(NC) MCP=NSL(ND) c 130 continue !re-entry point for no-mixing test C C----------------------------------------------------------------------- C C NOW INTERPOLATE MIXED RHO2, CONVERT TO TMX AND ADD TO OMEGA C NOTE, RHO2 IS IN "A.U" C ALLOW FOR ANY INITIAL ALGEBRAIC TERMS NOT BEING LOWEST IN ENERGY. C DO MD1=1,MC !BEGIN LOOP OVER INITIAL TERMS C NCH=NCHI+MD1 J1=MD1+MCI J=JNDEX(J1) if(j.lt.0)go to 14 !omit cor. C NOMTG0=(MD1-1)*MCP DO MDP1=1,MCP !BEGIN LOOP OVER FINAL TERMS C J1P=MDP1+MCIP IF(J1P.GT.J1.and.li.eq.lf)GO TO 14 if(j1.eq.j1p.and.ione.ne.0)go to 15 C JP=JNDEX(J1P) if(jp.lt.0)go to 15 !omit cor. if(min(j,jp).gt.nmeta)go to 15 !non-metastable C NCHP=NCHIP+MDP1 c c write(6,*)nch,nchp,j1,j1p,j,jp c if(bntest)ntest(nch,nchp)=ntest(nch,nchp)+1 c c "undefined" should not be accessed by xint... c do m2=1,meng c do m1=1,meng c tmp(m1,m2)=1.d70 !dzero !test c enddo c enddo C NOMTG=NOMTG0+MDP1 !rho2 nomtg (new) C IF(J.LE.JP)THEN !INITIAL ALGEBRAIC IS LOWER ENERGY C JL=J JH=JP NCHL=NCH NCHH=NCHP LUP=LF C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) TMP(M1,M2)=RHO2(M,NOMTG) ENDDO C ELSE !FINAL ALGEBRAIC IS LOWER ENERGY C JL=JP JH=J NCHL=NCHP NCHH=NCH LUP=LI C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) TMP(M2,M1)=RHO2(M,NOMTG) ENDDO C ENDIF C NOMT=IROW(JL,JH,ione,NSPECE) !ROWWISE DE=DSPECE(JH)-DSPECE(JL) c if(nomt.gt.nomwrt)then !shouldn't happen, now write(0,*)jl,jh,nmeta,nspece,nomt,nomwrt stop 'omega prob.' endif C C LOOP-OVER MENG0 UPPER STATE SCATTERING ENERGIES C DO M0=1,MENG0 C M=IYY0(M0) ml=mlim(m,1) mu=mlim(m,2) c c if(omginf(nomt).lt.dzero)mu=-mu !flag dipole C RHO=-2*XINT(DE,DYY,NLAG,TMP(1,M),M,ml,mu) !AS A.U. RHOSQ=RHO*RHO C IF(NCH.eq.NCHP)THEN !DIAGONAL MX c if(j1.ne.j1p.or.li.ne.lf)stop 'not diag' C IF(BRMX)THEN !USUAL REACTANCE T=PI*PSHFTX(M,L0) CT=COS(T) ST=SIN(T) RMX=(ST+RHO*CT)/(CT+RHO*ST) ENDIF C T=TPI*PSHFTX(M,L0) C2T=COS(T) S2T=SIN(T) C if(bunit)then !UNITARY TSQ=DONE+(C2T*(RHOSQ-DONE)+DTWO*S2T*RHO) X /(RHOSQ+DONE) else !non-unitary tsq=done+(c2t*(dtwo*rhosq-done)+dtwo*s2t*rho) endif c TSQ=TSQ+TSQ ! T^R=1+EXP(2I*TAU)(T^RHO-1) C ELSE !OFF DIAGONAL C IF(BRMX)THEN !USUAL REACTANCE T1=TPI*PSHFTX(M,L0) T2=TPI*PSHFTX(M,L00) DET=COS(T1)*COS(T2)-RHOSQ*SIN(T1)*SIN(T2) RMX=RHO/DET ENDIF C TSQ=4*RHOSQ ! |T^R(V,V')|=|T^RHO(V,V')| C if(bunit)TSQ=TSQ/(DONE+RHOSQ)**2 !APPROX UNITRTY C IF(J1.EQ.J1P)TSQ=TSQ+TSQ !FOR ELASTIC LI.NE.LF C ENDIF C IF(BPRNT3)THEN IF(BRMX)THEN WRITE(6,202)NCHL,NCHH,JL,JH,RMX,M0, X 'R-MATRIX ' ELSE WRITE(6,202)NCHL,NCHH,JL,JH,RHO,M0, X 'RHO-MATRIX' ENDIF ENDIF C OMPW=wait*TSQ*NWT/DTWO C if(bht)ompw=ompw/2 !for BHT(1970) comparison C C LOOK AT TOP-UP ISSUES, IF L LARGE ENOUGH TO WARRANT IT (OFF IF BTHRSH) C IF(LNEW.GE.LRGLMN)THEN C !NON-DIPOLE IF(OMGINF(NOMT).GT.DZERO.and.litlam.gt.0)THEN C IF(LNEW.EQ.LRGLAM)THEN !APPLY TOP-UP EJ=DYY0(M0) EI=EJ+DE c ompw0=ompw ompw=ompw/wait IF(BPRNT3)OMPW=-OMPW !FLAG PRINT C CALL TOP2(LITLAM,LRGLAM,EI,EJ,OMPW) C ompw=ompw+ompw0*(wait-done)/wait !adjust c ELSEIF(LNEW.GT.LRGLAM)THEN OMPW=DZERO ENDIF C !DIPOLE:LITLAM=LRGLAM ELSEIF(OMGINF(NOMT).LT.DZERO)THEN !POSS ZERO-OUT C !INC. IN TOP-UP IF(MAX(LI,LF)/2.GT.LRGLAM)OMPW=DZERO C ENDIF C ENDIF C C ARCHIVE PARTIAL/TOTAL COLLISION STRENGTHS C IF(BTHRSH)THEN M00=LUP/2+1-LVMIN IF(M00.LT.1.OR.M00.GT.MOGGY)GO TO 15 ELSE !CASE NOT XCLUDED BY ALGXLS M00=M0 ENDIF C OMP(M0)=OMPW C !UPDATE TOTAL OMEGA OMEGA(M00,NOMT)=OMEGA(M00,NOMT)+sngl(OMPW) C ENDDO C IF(BPRNT2) !PARTIAL OMEGA X WRITE(6,201)NCHL,NCHH,JL,JH,(OMP(M0),M0=1,MENG0) C 15 ENDDO !END LOOP OVER FINAL TERMS C 14 ENDDO !END LOOP OVER INITIAL TERMS C NCHIP=NCHIP+MCP ENDDO !END LOOP OVER FINAL L C NCHI=NCHI+MC ENDDO !END LOOP OVER INITIAL L C 68 NCHIP0=NCHIP0+((L2P-L1P)/4+1)*MCP!=NCHIP if(nchip0.ne.nchip)stop 'nchip0.ne.nchip' c write(0,*)nchip0,nchip ENDDO !END LOOP OVER FINAL GROUPS C NCHI0=NCHI0+((L2-L1)/4+1)*MC !=NCHI if(nchi0.ne.nchi)stop 'nchi0.ne.nchi' c write(0,*)nchi0,nchi ENDDO !END LOOP OVER INITIAL GROUPS C if(bntest)then if(nch.ne.nchp)stop 'channel index error' do i=1,nch if(ntest(i,i).ne.1)then write(0,*)'checksum wrong for nch,nch ' x ,i,' :',ntest(i,i) endif do j=i+1,nch if(ntest(i,j)+ntest(j,i).ne.1)then write(0,*)'checksum wrong for nch,nchp' x ,i,j,' :',ntest(i,j),ntest(j,i) endif enddo enddo endif c if(btimex)then call cpu_time(timef) times=timef-times c cpar if(iam.ge.0)then !par cpar write(6,*)'Ending proc',iam !par cpar x ,'dwxls symmetry',ix,':',' nchan=',nch !par cpar x ,'time=',nint(times),'sec' !par cpar call flush(6) !par cpar else !par write(iw,*)'Ending dwxls symmetry ',ix,':',' nchan=',nch x ,'time=',nint(times),'sec' cpar endif !par endif C KUTOOX=KOLDOO BKUTOO=KUTOOX.NE.0 C -------------------------- ENDDO !END LOOP OVER TOTAL SYMMS C -------------------------- C IF(IADD.NE.NCOR)THEN WRITE(6,*)'SR.DWXLS: GLOBAL INDEX ERROR:',IADD,NCOR !test GO TO 999 ENDIF C cparc !par cpar if(iam.ne.0)then !par cpar if(btimex)then !par cpar btimep=.false. !par cpar call cpu_time(timef) !par cpar times=timef-time0 !par cparc !par cpar write(iw,*)'Ending proc',iam,' for dwxls:' !par cpar x ,' time=',nint(times),'sec' !par cpar endif !par cpar endif !par cparc !par cpar ns=0 !par cpar nr=0 !par cparc !par cpar do m0=1,moggy !par cparc !par cpar call pomsend(ns,omega(1,1),nomwrt,omsend) !par cparc !par cpar call comm_barrier() !par cparc !par cpar call mpi_reduce(omsend,omrecv,nomwrt,mpi_real4,mpi_sum, !par cpar x 0,mpi_comm_world,ier) !par cpar if(ier.ne.0)write(0,*)'mpi_reduce: iam, ier=',iam,ier !par cparc !par cpar call comm_barrier() !par cparc !par cpar if(iam.eq.0)call pomrecv(nomwrt,omrecv,nr,omega(1,1)) !par cparc !par cpar enddo !par cparc !par cpar if(iam.ne.0)go to 800 !par cparc !par C C APPLY (DIPOLE) TOP-UP (OFF IF BTHRSH) C IF(LRGLAM.GT.0)THEN C WRITE(6,1002)LRGLAM if(btimex)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Proc',iam, !par cpar x 'Top-up has been applied: lrglam=',lrglam !par cpar else !par write(iw,*)'Top-up has been applied: lrglam=',lrglam cpar endif !par endif IF(BPRNT2)WRITE(6,716) C LITLAM=LRGLAM !USE GLOBAL VALUE LA=0 CO2S=D3O4/LOG(EINF*DZ2) C NOMT=0 DO I=1,NMETA !,NSPECL c IF(INDEX(I).GT.0)THEN !NON-CORR C DO J=I+ione,NSPECE !,NSPECL c IF(INDEX(J).GT.0)THEN !NON-CORR C NOMT=NOMT+1 SS=OMGINF(NOMT) C IF(SS.LT.DZERO)THEN !DIPOLE SS=SS*CO2S !CONVERT TO LINE STRENGTH DE=DSPECE(J)-DSPECE(I) DE=DE/DZ2 DO M0=1,MENG0 EJ=DYY0(M0)/DZ2 EI=EJ+DE C CALL TOP1(NZA,LITLAM,EI,EJ,SS,OMT) C if(bht)omt=omt/2 !for BHT(1970) comparison c OM=dble(OMEGA(M0,NOMT)) OMEGA(M0,NOMT)=OMEGA(M0,NOMT)+sngl(OMT) C IF(BPRNT2)WRITE(6,717)I,J,SS,EI,EJ,DE,OM,OMT,OM+OMT ENDDO ENDIF C c IF(NOMT.EQ.NOMWRT)GO TO 113 !WE ARE DONE c ENDIF ENDDO C c ENDIF ENDDO C ELSE C WRITE(6,1003) if(btimex)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Proc',iam,'Top-up has *NOT* been applied!'!par cpar else !par write(iw,*)'Top-up has *NOT* been applied!' cpar endif !par endif C ENDIF C c 113 CONTINUE c !x c test convert to cross section !x c !x c nomt=0 !x c do i=1,nmeta !x c j=index(i) !x c jj=nfq(j) !x c wi=(qsi(jj)+1)*(qli(jj)+1) !x c do j=i+ione,nspece !x c nomt=nomt+1 !x c de=dspece(j)-dspece(i) !x c do m0=1,moggy !x c ej=dyy0(m0) !x c ei=ej+de !x c if(brel)ei=ei+c4*ei*ei !wavenumber !x c om=dble(omega(m0,nomt)) !x c om=xconv*om/(ei*wi) !x c omega(m0,nomt)=sngl(om) !x c enddo !x c enddo !x c enddo !x C C----------------------------------------------------------------------- C C WRITE TOTALS C IF(BTHRSH)THEN WRITE(6,1001) IF(BPRNT0)THEN WRITE(6,1118)((I,J,J=I+ione,NSPECE),I=1,NMETA) !ROWWISE DO M0=1,MOGGY WRITE(6,200)DBLE(M0-1+LVMIN),(OMEGA(M0,N),N=1,NOMWRT) ENDDO ENDIF ELSE WRITE(6,1000) IF(BPRNT0)THEN WRITE(6,1117)((I,J,J=I+ione,NSPECE),I=1,NMETA) !ROWWISE DO M0=1,MENG0 !=MOGGY WRITE(6,200)DYY0(M0),(OMEGA(M0,N),N=1,NOMWRT) ENDDO ENDIF ENDIF C IF(IUNIT(IU).GT.0)THEN CLOSE(IU,STATUS='DELETE') IF(BTHRSH)THEN IUNIT(IU)=-1 ELSE OPEN(IU,FILE='OMEGALS',STATUS='REPLACE') !OPEN UNDER NEW NAME CTBD OPEN(IU,FILE='OMEGAULS',STATUS='REPLACE',FORM='UNFORMATTED') WRITE(IU,*)NZION,MION WRITE(IU,*)NSPECE,-(MENG0+1),NOMWRT !FLAG NO E'S .LT.0 WRITE(IU,*)(IWRK3(I),IWRK4(I),I=1,NSPECE) WRITE(IU,711)(DWRK(I),I=1,NSPECE) DO M0=1,MENG0 !=MOGGY WRITE(IU,713)DYY0(M0)/DZ2,(OMEGA(M0,N),N=1,NOMWRT) ENDDO WRITE(IU,713)EINF,(OMGINF(N),N=1,NOMWRT) IUNIT(IU)=-1 CLOSE(IU) ENDIF ENDIF C C OVERWRITE PWB ADF04 WITH DW, TAKING ACCOUNT OF THE FACT THAT THE PWB C DOES NOT CONTAIN (SPIN) FORBIDDEN TRANSITIONS C IF(IUNIT(IUU).GE.0)THEN !NO ADF04, LIKELY SINCE RAD='NO' WRITE(6,*)'NO ADF04 FILE="adf04ls"...' WRITE(0,*)'NO ADF04 FILE ON UNIT=',IUU C NF=-1 GO TO 800 ELSEIF(IUNIT(IUU).LT.0)THEN IUNIT(IUU)=1 OPEN(IUU,FILE='adf04ls',STATUS='OLD',ERR=800) ENDIF C BEXP=.FALSE. !*MUST* SYNC WITH DIAGON IF(NSPECE.LT.1000)THEN i1=0 IF(MOGGY.LE.20)THEN IF(BEXP)THEN F761='(F5.2, I5, 8X,20(1PE10.2))' F762='(2I4,22(1PE10.2))' F767='(18X,21(F10.5))' ELSE F761='(A5,A3,I2, 6X, 20(A5, A3))' F762='(2I4, 22(A5, A3))' F767='(16X,21(F8.5))' ENDIF ELSE IF(BEXP)THEN F761='(F5.2, I5, 8X,20(1PE10.2)/(18X,20(1PE10.2)))' F762='(2I4,21(1PE10.2)/(18X,20(1PE10.2)))' ELSE F761='(A5,A3,I2, 6X, 20(A5, A3)/(16X, 20(A5, A3)))' F762='(2I4, 21(A5, A3)/(16X, 20(A5, A3)))' !WRAP LAST POINT ENDIF ENDIF ELSE i1=1 IF(MOGGY.LE.20)THEN IF(BEXP)THEN F761='(F5.2, I5,10X,20(1PE10.2))' F762='(2I5,22(1PE10.2))' F767='(20X,21(F10.5))' ELSE F761='(A5,A3,I2, 8X, 20(A5, A3))' F762='(2I5, 22(A5, A3))' F767='(18X,21(F8.5))' ENDIF ELSE IF(BEXP)THEN F761='(F5.2, I5,10X,20(1PE10.2)/(20X,20(1PE10.2)))' F762='(2I5,21(1PE10.2)/(20X,20(1PE10.2)))' ELSE F761='(A5,A3,I2, 8X, 20(A5, A3)/(18X, 20(A5, A3)))' F762='(2I5, 21(A5, A3)/(18X, 20(A5, A3)))' !WRAP LAST POINT ENDIF ENDIF ENDIF C MSC0=80 OPEN(MSC0,STATUS='SCRATCH',FORM='FORMATTED') IF(.NOT.BEXP)THEN MSCP=81 OPEN(MSCP,STATUS='SCRATCH',FORM='FORMATTED') ENDIF C DO N=1,NSPECE+2 READ(IUU,760)CARD WRITE(MSC0,760)CARD ENDDO C NNN=max(NOMWRT,nomwr0) C DO N=1,NNN+2 READ(IUU,760,END=115)CARD WRITE(MSC0,760)CARD ENDDO C 115 REWIND(IUU) REWIND(MSC0) C DO N=1,NSPECE+2 READ(MSC0,760)CARD WRITE(IUU,760)CARD ENDDO C backspace(iuu) card=' ' card(4:5)='-1' orbfmt='(1x,f7.?)' is=9+2*i1 ie=is+mxorb*7 if(ie.gt.200)then write(6,*)'***sr.dwxls: card too short, need len=',ie write(0,*)'***sr.dwxls: card too short' nf=-1 go to 800 endif do i=1,mxorb ie=is+7 if(dey(i).ne.dzero)then t=dey(i)-duy(i,i) if(bmvd)t=t+dmass(i,i)+dcd(i,i) t=-2*t endif write(orbfmt(8:8),'(i1)') x max(2,5-max(0,int(log10(max(t,d1m30))))) write(card(is:ie),orbfmt)t is=ie+1 enddo orbfmt=' ' orbfmt(1:6)='(a )' write(orbfmt(3:5),'(i3)')ie write(iuu,orbfmt)card(1:ie) c IF(BTHRSH)THEN ITYPE=6 WRITE(IUU,F767)(PSHFT0(M-1+LVMIN),M=1,MOGGY) IF(BEXP)THEN WRITE(IUU,F761)DBLE(NZA+1),ITYPE,(DBLE(M-1+LVMIN),M=1,MOGGY) ELSE WRITE(MSCP,764)(DBLE(M-1+LVMIN),M=1,MOGGY) ENDIF ELSE ITYPE=5 IF(BEXP)THEN WRITE(IUU,F761)DBLE(NZA+1),ITYPE,(DYY0(M),M=1,MENG0) !=MOGGY ELSE WRITE(MSCP,764)(DYY0(M),M=1,MENG0) !=MOGGY ENDIF ENDIF C IF(BEXP)THEN READ(MSC0,F761) ELSE BACKSPACE(MSCP) READ(MSCP,765)(XMANT(M),IEXP(M),M=1,MOGGY) iexp(0)=' ' READ(MSC0,F761)XMANT(0) !,IEXP(0) WRITE(IUU,F761)XMANT(0),IEXP(0),ITYPE X ,(XMANT(M),IEXP(M),M=1,MOGGY) ENDIF C MENG1=MOGGY+1 IB0=1 JB0=IB0+IONE c nt=0 C DO N=1,NNN+1 C IF(BEXP)THEN READ(MSC0,F762)JB,IB,XB0,(DUM,I=1,MXNXB),XB1 ELSE READ(MSC0,F762)JB,IB,XMANT0,IEXP0, X (XMANT(I),IEXP(I),I=1,MXNXB),XMANT1,IEXP1 ENDIF C JB1=JB IF(JB.LT.0)THEN JB1=NSPECE IB=MIN(JB1-IONE,NMETA) IF(BEXP)THEN XB0=D1M30 XB1=DZERO ELSE XMANT0=' 1.00' IEXP0='-30' XMANT1=' 0.00' IEXP1='+00' ENDIF ENDIF C IF(BEXP)THEN X0=D1M30 X1=DZERO ELSE XMANT(0)=' 1.00' IEXP(0)='-30' XMANT(MENG1)=' 0.00' IEXP(MENG1)='+00' ENDIF C DO JT=JB0,JB1 IF(JT.EQ.JB1)THEN IB1=IB ELSE IB1=MIN(JT-IONE,NMETA) ENDIF DO IT=IB0,IB1 C ctest if(ione.eq.0.or.it.ne.jt)then !catch ione=0 diagon only nt=nt+1 c NOMT=IROW(IT,JT,IONE,NSPECE) C !TEST MENG0 STILL IF BTHRSH IF(OMEGA(MENG0,NOMT).GT.E1M30)THEN !SKIP SA-SAP.GT.1 c c if(omginf(nomt).lt.dzero)then !test write reduced dipole c do m=1,moggy c de=log(dyy0(m)+2.7183) c omega(m,nomt)=omega(m,nomt)/de c enddo c endif C IF(BEXP)THEN IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN !NOW ALLOWED X0=XB0 X1=XB1 ENDIF WRITE(IUU,F762)JT,IT,X0,(OMEGA(M,NOMT),M=1,MOGGY),X1 ELSE BACKSPACE(MSCP) WRITE(MSCP,764)(OMEGA(M,NOMT),M=1,MOGGY) BACKSPACE(MSCP) READ(MSCP,765)(XMANT(M),IEXP(M),M=1,MOGGY) IF(JT.EQ.JB1.AND.IT.EQ.IB1)THEN !NOW ALLOWED XMANT(0)=XMANT0 IEXP(0)=IEXP0 XMANT(MENG1)=XMANT1 IEXP(MENG1)=IEXP1 ENDIF WRITE(IUU,F762)JT,IT,(XMANT(M),IEXP(M),M=0,MENG1) ENDIF C ENDIF ctest endif ENDDO IB0=1 ENDDO C IF(JB.LT.0)then if(nt.ne.nomwrt)then !checksum write(6,*)'adf04 no. of transitions mis-match: nt,nomwrt=' x ,nt,nomwrt write(0,*)'adf04 no. of transitions mis-match' nf=-1 go to 800 endif GO TO 120 endif C JB0=JB IB0=IB+1 C ENDDO C WRITE(0,*)'SR.DWXLS: HAVE NOT REACHED END OF adf04ls...' WRITE(6,*)'SR.DWXLS: HAVE NOT REACHED END OF adf04ls...' NF=-1 GO TO 800 C 120 WRITE(IUU,F762)-1 WRITE(IUU,F762)-1,-1 c if(.not.badas)then !adas skip comments WRITE(IUU,758) C NREC=1 121 NREC=NREC+1 BACKSPACE(5) BACKSPACE(5) READ(5,766)CARD4 IF(CARD4.NE.'A.S.'.AND.CARD4.NE.'S.S.')GO TO 121 REWIND(5) C DO N=1,NREC READ(5,760)CARD WRITE(IUU,759)CARD ENDDO DO I=1,8 DATE(I)=' ' ENDDO CALL DATE_AND_TIME(DATE8) !F95 WRITE(IUU,763)DATE(7),DATE(8),DATE(5),DATE(6),DATE(3) X ,DATE(4) endif C IUNIT(IUU)=-1 CLOSE(IUU) C CLOSE(MSC0) IF(.NOT.BEXP)CLOSE(MSCP) C C----------------------------------------------------------------------- C 800 CONTINUE C DEALLOCATE(RHO1,RHO2,TEMP,TMPX,OMGINF,OMEGA,STAT=IERR) !F95 cparc !par cpar deallocate(omsend,omrecv,stat=ierr) !par C IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXLS: DEALLOCATION FAILS FOR RHO,OMEGA,TEMP' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C 900 DEALLOCATE(TFU,STAT=IERR) !F95 C IF(IERR.NE.0)THEN !F95 WRITE(0,*)'DWXLS: DEALLOCATION FAILS FOR TFU' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 C 999 CONTINUE C C----------------------------------------------------------------------- C if(btimep)then call cpu_time(timef) times=timef-time0 c C if(iabs(modd).le.1)then c cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for dwxls:' !par cpar x ,' time=',nint(times),'sec' !par cpar else !par write(iw,*)'Ending dwxls: time=',nint(times),'sec' cpar endif !par C endif endif C C----------------------------------------------------------------------- C RETURN C C 200 FORMAT(F21.3,2X,1P,10(E11.3)/(23X,10(E11.3))) 201 FORMAT(2I5,3X,2I4,2X,1P,10(E11.3)/(23X,10(E11.3))) 202 FORMAT(2I5,3X,2I4,2X,1PE11.3,10X,'E(',I2,') ',A10) 711 FORMAT(1P,5E16.6) 713 FORMAT(1PE14.8,6E11.3/(14X,6E11.3)) 716 FORMAT(3X,'CH',2X,'CHP',9X,'S',14X,'EI',10X,'EJ',10X,'DE', X9X,'OMEGA(PAR)',2X,'OMEGA(TOP)',4X,'OMEGA(TOT)') 717 FORMAT(2I5,3X,1PE11.3,2X,0P,3F12.4,5X,2F12.4,2X,F12.4) 758 FORMAT('C',79('-')/'C'/'C') 759 FORMAT('C ',A200) 760 FORMAT(A200) 763 FORMAT('C'/'C'/'C',79('-')/'C'/'C',1X X ,'AUTOSTRUCTURE DISTORTED-WAVE'/ X 'C'/'C NAME:'/'C DATE: ',2(A1),'/',2(A1),'/',2(A1)/ X 'C'/'C',79('-')) 764 FORMAT(22(1PE9.2)) 765 FORMAT(22(A5,1X,A3)) 766 FORMAT(A4) 995 FORMAT(2I10,13X,I5,I2,I5,12X,F18.6) 996 FORMAT(9X,'I',8X,' T',14X,'2S+1 L CF',20X,'(EI-E1)/RY' X ,15X,'NMETA=',I5) 1000 FORMAT(///1X,136('-')//51X, X '*** TOTAL COLLISION STRENGTHS (LS) ***'//1X,136('-')//) 1001 FORMAT(///1X,136('-')//45X, X '*** THRESHOLD PARTIAL COLLISION STRENGTHS (LS) ***'// X 1X,136('-')//) 1002 FORMAT(//' *** TOP-UP HAS BEEN APPLIED: LRGLAM=',I5//) 1003 FORMAT(//' *** TOP-UP HAS *NOT* BEEN APPLIED ***'//) 1110 FORMAT(//1X,136('-')/// X 49X,'*** TARGET ENERGIES (LS) ***'/) 1111 FORMAT(//1X,136('-')/) 1114 FORMAT(' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3) 1115 FORMAT(//' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3/1X,33('-')) 1116 FORMAT(/3X,'CH',2X,'CHP',6X,'I',2X,'IP',4X,'OMEGA(IE=1,MENG):') 1117 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/2X,'*FINAL* ENERGY(RYD)' X ,2X,10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4))) 1118 FORMAT(74X,'OMEGA(I-IP)'/74X,11('-')/1X,'*FINAL* RYDBERG A.M.' X ,2X,10(2X,I4,'-',I4)/(23X,10(2X,I4,'-',I4))) 1996 FORMAT(//' *** UPDATING SLATER INTEGRALS FOR LTOT=', X I3/1X,42('-')/) C END C C ******************* C SUBROUTINE EKALG1(KM,NF,MMIN,MMAX,AM,BM,QLML,JYI,JYF,DFS,MAXEL) C C----------------------------------------------------------------------- C C SR.EKALG1 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N: C IT CALCULATES THE PURELY ALGEBRAIC COEFFICIENTS FOR EACH REDUCED C ELECTRIC MULTIPOLE MATRIX ELEMENT, IN TERMS OF SLATER STATES. NRB C C----------------------------------------------------------------------- C USE COMMON_DXRLS, ONLY: DRKS,QRLS,NRKS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C PARAMETER (DONE=1.0D0) PARAMETER (TYNY=1.0D-8) C LOGICAL BVC,SKP,AM,BM,BFANO,BDLBD,BFOT,BSKP CF77 X ,BFALLS !F77 C CHARACTER(LEN=4) CODE C DIMENSION JYI(*),JYF(*),QLML(MAXEL,*),AM(*),BM(*),DFS(*) C COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 c common /mqvc/modd,kcut,qmcl,qmcs,nel(maxgr,maxcf) CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBFAN/BFANO COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX C MVC(M,MA)=( (M+2)*M/2+MA )/2+1 SKP=MXLL.EQ.-1 MXORB2=MXORB*MXORB C C INITIALIZATIONS C IFOTMX=0 IF(BFOT)IFOTMX=1 C IOSS=0 LOSS=0 NCF=0 NADS(0)=0 KGG=KM DD=DONE C C LOOP OVER ALL CONFIG PAIRS C c iflagc=0 DO 99 KF=1,KM C II=QCG(NF,KF) IFOT1=0 IF(QN(II).GE.90)IFOT1=1 C JA=JYI(KF) JB=JYF(KF) C IF(BM(1))KGG=KF !WITHIN A GROUP C DO 90 KG=1,KGG C NCF=NCF+1 BSKP=NADS(NCF).LT.0 !KF AND/OR KG NOT CONTRIB NADS(NCF)=NADS(NCF-1) IF(BSKP)GO TO 90 IF(MOD(QCP(KF)+QCP(KG)+MMIN,4).NE.0)GO TO 90 !WRONG PARITY C II=QCG(NF,KG) IFOT2=0 IF(QN(II).GE.90)IFOT2=1 IF((IFOT1+IFOT2).GT.IFOTMX)GO TO 90 !OMIT CONTINUUM-CONTINUUM c c iflagc=max(iflagc,ifot2) c omit corr-corr' c if(ifot1+ifot2+iflagc.gt.0.and.kf.gt.kcut.and.kg.gt.kcut)go to 90 C C SKIP, IF CONFIG KF AND KG DIFFER IN MORE THAN ONE ELECTRONS C DO I=1,NF QLML(I,1)=QCG(I,KG) ENDDO C K=0 DO I=1,NF DO L=1,NF IF(IEQ(QLML(L,1)).EQ.IEQ(QCG(I,KF)))THEN QLML(L,1)=0 GO TO 51 ENDIF ENDDO K=K+1 IF(K.GT.1)GO TO 90 51 ENDDO C IOSS00=IOSS+1 LOSS00=LOSS LOSS1=LOSS00+1 JAP=JYI(KG) JBP=JYF(KG) AM(1)=KF.EQ.KG C C LOOP OVER SLATER STATES OF ALL CONFIG PAIRS C DO 15 J=JA,JB IF(AM(J))GO TO 15 C IF(AM(1))JBP=J !KF=KG C DO 16 JD=JAP,JBP IF(BM(JD))GO TO 16 C CTHIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE, NOT TERM COLD IOSS0=IOSS+1 C DO I=LOSS1,LOSS IORIG(I)=0 ENDDO C MK=MMIN QCL=0 C IF(JD.NE.J)THEN QCS=0 DO I=1,NF QCS=QCS+I DO K=1,NF IF(IEQ(QCG(K,KG)).NE.IEQ(QCG(I,KF)))GO TO 19 IF(QLML(I,J).NE.QLML(K,JD))GO TO 19 QCS=QCS-K GO TO 18 19 ENDDO IF(QCL.NE.0)GO TO 16 QCL=I 18 ENDDO QCS0=QCS QCL0=QCL GO TO 20 ENDIF C 27 QCL=QCL+1 QCS=QCL C 20 NG=QCG(QCL,KF) NT=QCG(QCS,KG) C C M1=QN(NG) C M2=QN(NT) C IF(IABS(M1-M2).LT.MDEL)GO TO 28 C M1=QL(NG) M2=QL(NT) IF(M1+M2.LT.MK)GO TO 28 IF(IABS(M1-M2).GT.MK)GO TO 28 C IF(.NOT.SKP)THEN ML1=((QLML(QCL,J)+100)/2)*2-100 ML2=((QLML(QCS,JD)+100)/2)*2-100 ML2=-ML2 IF(BVC.OR.(M1.LE.MXLL .AND. M2.LE.MXLL))THEN I=MVC(M1,ML1) K=MVC(M2,ML2) MM=MK/4+1 DD=VCA(I,K,MM) ELSE MLK=ML1+ML2 DD=VCC(M1,M2,MK,0,0,0,DFS,MXDFS) X *VCC(M1,M2,MK,ML1,ML2,MLK,DFS,MXDFS)/(MK+1) ENDIF C MMM=(MK-ML2)/2 DD=(-1)**(MMM+QCL+QCS)*SQRT(DBLE((M1+1)*(M2+1)))*DD C IF(ABS(DD).LT.TYNY)GO TO 28 C IF(BFANO)THEN IFANO=MK+M2-M1 IFANO=IFANO/4 FANO=(-1)**IFANO DD=DD*FANO ENDIF ENDIF C C STORE COEFFICIENT C IPLANT=(MK/2)*MXORB2+(NG-1)*MXORB+NT-1 DO L=LOSS1,LOSS IF(IPLANT.EQ.JORIG(L))THEN IF(J.EQ.JD)THEN I=IORIG(L) IF(I.GT.0)THEN DRKS(I)=DRKS(I)+DD GO TO 28 ENDIF ENDIF LP=L GO TO 30 ENDIF ENDDO C C CANNOT FIND OLD ARGUMENT C LP=LOSS+1 LOSS=LP IF(LOSS.GT.MXRLS)GO TO 999 C QRLS(1,LP)=NT QRLS(2,LP)=NG QRLS(3,LP)=MK QRLS(4,LP)=IPLANT JORIG(LP)=IPLANT C 30 IOSS=IOSS+1 IF(IOSS.GT.MXRKS)GO TO 999 C IORIG(LP)=IOSS NRKS(IOSS)=LP DRKS(IOSS)=DD NSTJ(IOSS)=J NSTJD(IOSS)=JD C 28 IF(JD.EQ.J.AND.QCS.LT.NF)GO TO 27 C MK=MK+4 IF(MK.LE.MMAX)THEN !MULTIPOLE LOOP... IF(J.EQ.JD)THEN QCL=0 GO TO 27 ELSE QCL=QCL0 QCS=QCS0 GO TO 20 ENDIF ENDIF C C 16 CONTINUE !END SLATER STATE LOOP C 15 CONTINUE !END SLATER STATE LOOP C C C ELIMINATE ZEROES C IF(IOSS.LT.IOSS00)GO TO 90 C K=IOSS00-1 KP=0 DO I=LOSS1,LOSS IORIG(I)=0 ENDDO C DO I=IOSS00,IOSS JD0=NRKS(I) JD=IABS(JD0) IF(ABS(DRKS(I)).LT.TYNY)THEN IF(IORIG(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QRLS AS MAY OCCUR LATER GO TO 94 ENDIF C K=K+1 DRKS(K)=DRKS(I) NSTJ(K)=NSTJ(I) NSTJD(K)=NSTJD(I) C 94 IF(JD.LE.LOSS00)THEN IF(LOSS.LE.MXRLS)THEN !SHOULD NOT GET HERE WRITE(6,*)'EKALG1: INFORM NRB OF STOP HERE' WRITE(0,*)'EKALG1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 ELSE !GRACEFUL EXIT TO DIMENSION STOP LP=JD GO TO 92 ENDIF ENDIF C IF(IORIG(JD).EQ.0)THEN LP=JD-KP DO L=1,LOSS00 DO J=1,3 IF(QRLS(J,JD).NE.QRLS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG(JD) GO TO 92 ENDIF C IORIG(JD)=LP DO J=1,4 QRLS(J,LP)=QRLS(J,JD) ENDDO C 92 IF(JD0.NE.0)THEN NRKS(K)=LP C IF(JD0.LT.0)NRKS(K)=-NRKS(K) ENDIF 91 ENDDO C LOSS=LOSS-KP IOSS=K NADS(NCF)=IOSS C C 90 CONTINUE !END LOOP OVER CFS C 99 CONTINUE !END LOOP OVER CFS C C 999 IRLS=LOSS IRKS=IOSS RETURN C END C C ******************* C SUBROUTINE EKALG2(DC,mam,nam,KK,DVC,JOS,IXY) C C----------------------------------------------------------------------- C C SR.EKALG2 DEALS WITH THE PROBLEMS DESCRIBED IN SECTION 3.2 OF E&N: C IT CALCULATES THE PURELY ALGEBRAIC COEFFICIENTS FOR EACH REDUCED C ELECTRIC MULTIPOLE MATRIX ELEMENT, IN TERMS OF LEVELS. NRB C C----------------------------------------------------------------------- C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL !F95 USE COMMON_DXRLS, ONLY: DRKS,QRLS,NRKS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 USE COMMON_NRBRN2, ONLY: BINDB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-5) PARAMETER (TTYNY=TYNY/1.D3) C INTEGER*8 N8 CF77 INTEGER*8 NRK !F77 C LOGICAL BREL,BJUMPR,BMVD,EQCFS,BFAST !,BBORN CF77 X ,BFALLS,BINDB !F77 C CHARACTER(LEN=4) CODE C REAL*8 DC C DIMENSION DC(0:*),mam(*),nam(*),DVC(*) C COMMON /BASIC/NF,KF,KG,JGAP(2),MB1,MB2,ND1,NDP1,ND2,NDP2,NGAP CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 COMMON /NXRL/IRK,IRK0,IOS,IOS0 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT c COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) c X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 C ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C MXPOL=MAX(1,MPOLE/2+1) MXORB2=MXORB*MXORB C CB BBORN=MENGB.GE.0 !BORN CODING USED MORE GENERALLY NOW C IOS0=IOS+1 LOS=IRL C DO J=1,IRLS JORIG(J)=0 ENDDO C EQCFS=KG.EQ.KF C c write(6,*)'kf=',kf,' kg=',kg C C LOOP OVER SLATER STATES C K0=NADS(KK-1)+1 C m0=0 t0=dzero DO KS=K0,NADS(KK) C J=NSTJ(KS) JD=NSTJD(KS) C IF(BFAST)THEN DD=DC(J+ND2)*DC(JD+NDP2)*DRKS(KS) IF(EQCFS.AND.J.NE.JD)DD=DD+DC(J+NDP2)*DC(JD+ND2)*DRKS(KS) ELSE m=mam(j) md=nam(jd) c write(6,*)m,md if(m.gt.0.and.md.gt.0)then !m*md can over flow I*4 if(m.ne.m0)then t0=dc(m) m0=m endif DD=t0*DC(md)*DRKS(KS) else dd=dzero endif IF(EQCFS.AND.J.NE.JD)then md=mam(jd) m=nam(j) if(m.gt.0.and.md.gt.0)then !m*md can over flow I*4 DD=DD+DC(md)*DC(m)*DRKS(KS) endif endif ENDIF C IF(ABS(DD).GT.TTYNY)THEN N=NRKS(KS) L=JORIG(N) IF(L.GT.0)THEN I=IORIG(L) DRK(I)=DRK(I)+DD ELSE !CANNOT FIND OLD ARGUMENT LOS=LOS+1 IF(LOS.GT.MAXRL)GO TO 93 !HARDLY LIKELY IOS=IOS+1 IF(IOS.GT.MAXRK)GO TO 92 DRK(IOS)=DD NRK(IOS)=LOS IORIG(LOS)=IOS JORIG(N)=LOS DO I=1,4 QRL(I,LOS)=QRLS(I,N) ENDDO ENDIF ENDIF C ENDDO C C CLEAR ARRAY OF ZEROES C IXY=0 K=IOS0-1 C DO I=IOS0,IOS C DD=DRK(I) IF(ABS(DD).GT.TYNY)THEN K=K+1 LL=INT(NRK(I)) NT=QRL(1,LL) NG=QRL(2,LL) MM=QRL(3,LL)/2 CB IF(BBORN)THEN MN=MIN(NT,NG) MX=MAX(NT,NG) IN=ICOL(MN,MX,0) BINDB(IN,MM/2)=.TRUE. IF(BREL)BINDB(IN,MM/2+1)=.TRUE. CB ENDIF N8=MXORB2*MXPOL NRK(K)=N8*(NDP1-1)+QRL(4,LL) !MM*MXORB2+(NG-1)*MXORB+NT-1 DD0=SQRT(DBLE(2*MM+1)) DRK(K)=DD0*DD/DVC(MM/2+1) C IF(MPRINT.GT.0)WRITE(6,700) X JOS,ND1,NDP1,NG,NT,K,DRK(K),DD,DVC(MM/2+1),MB1,MB2,MM ENDIF C ENDDO C IOS=K IF(IOS.GE.IOS0)JOS=JOS+1 C RETURN C 92 IXY=1 RETURN C 93 IXY=-1 RETURN C 700 FORMAT( I5, 2X,2(I5,I4),I7, F13.5,2F19.5, 6X,2I4, 5X,'E',I1) END C C ******************* C REAL*8 FUNCTION ELAM(LAM,K1,K2,K3,K4) C C----------------------------------------------------------------------- C C FN.ELAM EVALUATES THE ETA-LAMDA INTEGRALS OF ORBIT-ORBIT INTERACTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C c PARAMETER (DZERO=0.0D0) C COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) C C c IF(LAM.EQ.0)THEN !test c ELAM=DZERO c RETURN c ENDIF c L1=QL(K1)/2 L2=QL(K2)/2 L3=QL(K3)/2 L4=QL(K4)/2 LP1=LAM+1 LP2=LAM+2 LT=(L1+L3+LP2)*(L3-L1+LP1)*(L1-L3+LP1)*(L1+L3-LAM)*(L2+L4+LP2) X *(L4-L2+LP1)*(L2-L4+LP1)*(L2+L4-LAM) T=SQRT(DBLE(LT)) TP=LP1*LP2*(2*LP1-1)*(LP1+LP2) C JONES TP=LP1*LP2 IF(LT.NE.0)V=VLAM(LAM,K1,K2,K3,K4) V=T*V/TP C ELAM=-V !V->-V C C WRITE(6,100) K1, K2, K3, K4, 2*LAM, ELAM C100 FORMAT(8X,2(I5,I4),I6,F14.7,' =ELAM') C RETURN END C C*********************************************************************** C REAL*8 FUNCTION F21(A,B,C,D,EPS,IFAIL) C C----------------------------------------------------------------------- C C FN.F21 DETERMINES TRHE 2_F_1 HYPERGEOMETRIC FUNCTION FROM SERIES C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) C IPRINT=IFAIL IFAIL=0 T=(A*B*D)/C DD=DONE/(DONE-D) SUM=DONE+T TN1=DZERO C I=1 3 AI=I T=T*(A+AI)*(B+AI)*D/((C+AI)*(DONE+AI)) TN2=T*DD F21=SUM+TN2 SUM=SUM+T C AT=ABS(T+TN2-TN1) AS=ABS(F21)*EPS C IF(AS.GE.AT)RETURN C TN1=TN2 I=I+1 IF(I.LT.301)GO TO 3 C IF(IPRINT.GT.0)WRITE(6,100) IFAIL=3 RETURN C 100 FORMAT(' FAILED TO CONVERGE IN F21') END C C ******************* C SUBROUTINE FCF4(F,C,E,Z,L,MFH0,MFE,DNS,DX) C C----------------------------------------------------------------------- C C BADNELL AND BURGESS, D.A.M.T.P., CAMBRIDGE. C C SR.FCF4 DETERMINES A CONTINUUM COULOMB FUNCTION BY SERIES EXPANSION. C C INPUT. E,Z,L, PLUS GRID INFO FROM SR.RADIAL MFH0,MFE,DNS,DX. C OUTPUT. F,C. C PUTS FREE REGULAR COULOMB REAL-FUNCTION IN F(J), AT X=DX(J). C F SATISFIES ((D/DX)(D/DX)-L(L+1)/X**2-2Z/X+E)F=0 C F=C*X**(L+1.0)*(1.0+...) FOR SMALL X C F=K**(-0.5)*DSIN(KX-0.5*EL*PI-(Z/K)LOG(2KX)+ARGGAMMA(EL+1+I*Z/K)) C FOR LARGE X C WHERE K=SQRT(E) C N.B. Z IS POSITIVE FOR REPULSIVE FIELD C X0 IS (APPROX.) THE FIRST POINT OF INFLEXION IN F. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DETY=8.0D1) PARAMETER (DTWE=DONE/12.0D0) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M5=1.0D-5) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M15=1.0D-15) PARAMETER (D1M40=1.0D-40) PARAMETER (D1P70=1.0D+70) C DIMENSION F(*),A(100) DIMENSION MFE(*),DNS(*),DX(*) C WILF(X)=E+W1/X+W2/(X*X) C PI=ACOS(-DONE) EL=L W1=-(Z+Z) W2=-EL*(EL+DONE) W3=(EL+DONE)*(EL+DTWO) ZZ=Z*Z C IF(E.GT.D1M40)GO TO 6 IF(ABS(Z).GT.D1M15)GO TO 3 WRITE(6,100) C 38 K=0 C DO M=1,MFH0 I1=MFE(M) DO I=1,I1 K=K+1 F(K)=DZERO ENDDO ENDDO C RETURN C 3 IF(Z.LT.DZERO)GO TO 5 4 WRITE(6,101) GO TO 38 C 5 C=-Z*(PI+PI) GO TO 11 C 6 EK=SQRT(E) T1=PI*Z/EK T2=ABS(T1) IF(T2.GT.D1M2)GO TO 8 C C=DTHREE*EK/(DTHREE+T1*(DTHREE+T1*(DTWO+T1))) GO TO 11 C 8 IF(T2.LT.DETY)GO TO 10 IF(Z.LT.DZERO)GO TO 5 GO TO 4 C 10 C=DONE-EXP(T1+T1) C=-(PI+PI)*Z/C 11 C2=DONE C IF(L.GT.0)THEN DO J=1,L CJ=J CJ2=J+J C2=C2*CJ*(CJ2+DONE) C=C*(ZZ+E*CJ*CJ) 30 IF(C+C2.GE.D1P70)THEN C2=D1M5*C2 C=D1M10*C GO TO 30 ENDIF ENDDO ENDIF C C=SQRT(C)/C2 X0=W3/(SQRT(ZZ+W3*E)-Z) I1=0 I=0 C DO M=1,MFH0 MFH=M K=MFE(M) I1=I1+K DO J=1,K I=I+1 IF(X0.LT.DX(I))GO TO 16 ENDDO ENDDO J=K C 16 IF(I.LT.2)I=2 IF(J.EQ.K)I=I-1 I0=I X0=DX(I) L1=L+1 A(1)=DONE T1=L1 A(2)=X0*Z/T1 J=2 Z2=Z+Z C 17 J=J+1 C2=J-1 C3=J+L+L A(J)=X0*(Z2*A(J-1)-X0*E*A(J-2))/(C2*C3) IF(J.LE.6)GO TO 17 C2=ABS(A(J))+ABS(A(J-1)) IF(C2.GT.D1M10)GO TO 17 J0=J C DO I=1,I0 X=DX(I) X=X/X0 J=J0 T1=A(J) 22 J=J-1 T1=A(J)+X*T1 IF(J.GT.1)GO TO 22 F(I)=C*T1*(X*X0)**L1 ENDDO C IM=1 I=I0 X=DX(I) H=DNS(MFH) C 24 H0=H*H H1=DTWE*H0 C0=F(I)*(DONE+(H1-H0)*WILF(X))-F(I-IM)*(DONE+H1*WILF(X-H)) C1=F(I)*(DONE+H1*WILF(X)) C 25 I=I+1 X=DX(I) C1=C1+C0 C2=WILF(X) F(I)=C1/(DONE+H1*C2) C0=C0-H0*C2*F(I) IF(I.LT.I1)GO TO 25 MFH=MFH+1 C IF(MFH.GT.MFH0)RETURN C H=DNS(MFH) IM=2 I1=I1+MFE(MFH) GO TO 24 C C 100 FORMAT('***FAILED IN FCF4 BECAUSE E AND Z ARE BOTH ZERO, OUTPUT', X ' SET TO ZERO') 101 FORMAT('***FCF4 OUTPUT SET TO ZERO BECAUSE E IS LESS THAN 1.0D-40' X ,' AND Z EXCEEDS 1.0D-15') C END C C ******************* C SUBROUTINE FCF6(FR,C,DEL,L,EI,ZI0,ZIA,Q,U,Z3,ZS,JZNM,ZL,MEND X,DNUK,MFH0,MFE,DNS,DX,GR,MAXPS) C C----------------------------------------------------------------------- C C N.R.BADNELL D.A.M.T.P. CAMBRIDGE C C SR.FCF6 EVALUATES A DW CONTINUUM RADIAL FUNCTION ON THE INPUT GRID C BY SOLVING THE SCHRODINGER EQUATION WITH THE SUMMED COWELL-NUMEROV C METHOD, USES SMALLER STEPS IF NECESSARY I.E. IT IS NOT CONSTRAINED C BY THE USER INPUT GRID. C C IT CALLS: C FN.CNORM C FN.DNAMP C FN.PHASEX C C INPUT: L,E,Z0,ZA,Q,U,Z3,ZS,JZNM,ZL,MEND,MFH0,MFE,DNS,DX C WHERE C F(I)"=L(L+1)/R**2-ZL(I)-E AND FOR LARGE R C F"=2*ZA/R+L(L+1)/R**2+Q/R**3+U/R**4+Z3/R**5-E C N.B. Z0,ZA .LT. 0, E .GT. 0 C ZS(I) I=1,JZNM IS POWER SERIES EXPANSION ABOUT ORIGIN. C MEND,MFH0,MFE,DNS,DX INFORMATION ON GRID DEFINED IN SR.RADIAL C OUTPUT: FUNCTION FR, C AND NON-COULOMB PHASE SHIFT / PI=DEL C WHERE FOR SMALL R F=C*R**(L+1) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DTWELV=12.0D0) PARAMETER (DSIXTY=60.0D0) PARAMETER (D1P4=1.0D4) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M2=1.0D-2) PARAMETER (D5M2=5.0D-2) PARAMETER (DHALF=0.5D0) PARAMETER (D64=64.0D0) PARAMETER (D3QRT=DTHREE/DFOUR) PARAMETER (DQUART=DONE/DFOUR) PARAMETER (DFIFTH=0.2D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DEPS0=1.D-10) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C DIMENSION FR(*),GR(*),A(100),ZS(JZNM),AMP2(20),AMP3(20) DIMENSION MFE(*),DNS(*),DX(*),ZL(*),DNUK(*) C COMMON /COM3/EE,ZP,ELLP !,EQ,ZQ,CQ COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C C Q,U,Z3=ZERO IN AUTOSTRUCTURE C WILT(T,E,ZZ,CI)=E-(ZZ+(CI+(Q+(U+Z3*T)*T)*T)*T)*T C WILT(T,E,ZZ,CI)=E-(ZZ+CI*T)*T C C LOOK AT COULOMB NORMALIZATION TO SEE IF FUNCTION IS NUMERICALLY C DETERMINABLE, BASICALLY A FUNCTION OF L/E. ZERO-OUT IF NOT, C THIS SHOULD ONLY OCCUR IN EXTREME CASES. (FCF4 DOESN'T EVEN WARN.) C EC=MAX(EI,D1M2) C=CNORM(EC,ZIA,L) c write(70,700)l,ei,c C IF(C.LE.DZERO)THEN C WRITE(6,1004)L,EI C C=DZERO DO I=1,MAXPS FR(I)=DZERO ENDDO C IF(BREL.AND.IABS(IREL).EQ.2)THEN DO I=1,MAXPS GR(I)=DZERO ENDDO ENDIF C RETURN !<----------------- RETURN C ENDIF C C INITIALIZE C KAPPA=0 !PMVDAR IGNORES KAPPA AND USES ITS OWN, DEFAULT -1 c c if(l.gt.0)kappa=-l-1 !l or -l-1 c PI=ACOS(-DONE) PIH=PI/DTWO EL=L CI=EL*(EL+DONE) ELLP=CI ZA=ZIA Z0=ZI0 ZP=-ZI0 EE=EI E=EI CI0=CI CI1=CI C IF(BREL)THEN DO I=1,INUK !TRANSFER NUCLEUS T=ZL(I) ZL(I)=DNUK(I) DNUK(I)=T ENDDO EQ=DQUART*DALF*EI*EI E=EI+EQ Z0=ZI0+DHALF*DALF*ZI0*EI ZQ=DHALF*DALF*ZIA*EI ZA=ZIA+ZQ ZQ=ZQ+ZQ CI0=CI-DALF*ZI0*ZI0 CQ=-DALF*ZIA*ZIA CI1=CI+CQ BREL2=IABS(IREL).EQ.2 ENDIF C Z2=ZA+ZA ZA2=ZA*ZA Z1=ZI0+ZI0 VS=ZS(1) ZS(1)=VS+E !TEMP HOLD E NNMAX=10 JMAX=5 TMAX=DONE/D64 C C FIND MAX STEP LENGTH ALLOWABLE FOR ACCURATE EVALUATION OF PHASE C W3=DQUART+CI1-D3QRT/Z0 HMAX=ABS(E) IF(L.GT.0)HMAX=HMAX+ZA2/CI1 IF(HMAX.LT.D1M10)HMAX=D1M10 HMAX=SQRT(TMAX/HMAX) C C ESTIMATE INNER TURNING POINT C C X0=-DONE/Z0 X0=DX(2) W3=W3-CI1+CI0 IF(L.GT.0)X0=W3/(SQRT(Z0*Z0+W3*E)-Z0) C i10=0 I=0 DO M=1,MFH0 JM=MFE(M) DO J=1,JM I=I+1 IF(X0.LE.DX(I))THEN I0=I GO TO 70 ENDIF ENDDO ENDDO I0=I C 70 CONTINUE C C EVALUATE POWER SERIES SOLUTION FOR FIRST TWO POINTS WITH FR .GT. DEPS C A1=DONE A1=C A(1)=A1 C DEPS=DEPS0/SQRT(-Z0) DEPS=DEPS*A1/C C IF(BREL)THEN C TL=L !=L HERE IF(RNUK.LT.DZERO)THEN !POINT J0=2 B=DONE+(EI+DFOUR/DALF)*DX(1)/ZP B=DONE/B B=B*B T=L*(L+1)-DALF*ZP*ZP+D3QRT*B TLAM=DQUART+T TLAM=SQRT(TLAM)-DHALF A(2)=(TLAM+DONE)*(TLAM+DTWO)-T A(2)=-A(1)*DTWO*ZP*(DONE+EI*DALF/DTWO)/A(2) A(3)=A(1)*TLAM/DTWO !FOR Q NORM - NOT USED ELSE J0=3 A(2)=DZERO T=(L+2)*(L+3)-L*(L+1) IF(INUKE.EQ.0)THEN T1=DONE T3=DTHREE ELSE !U6 POTENTIAL T1=21 T1=T1/8 T3=63 T3=T3/16 ENDIF TNUK=T3*ZP/RNUK TT=DONE+DQUART*DALF*(EI+TNUK) TT=T1*D3QRT*DALF*ZP/(TT*RNUK**3) TT=TT-(TNUK+EI)*(DONE+DQUART*DALF) A(3)=A(1)*TT/T ENDIF ELSE A(2)=A(1)*Z0/(EL+DONE) T=DZERO JM=JZNM+1 jam=10 !jm !old ks=2 C TL=EL !=L HERE DO J=2,jam if(j.gt.jm)ks=j+1-jznm DO K=ks,J K2=K-1 K1=J-K2 T=T-A(K2)*ZS(K1) ENDDO T=T+Z1*A(J) TJ=J A(J+1)=T/((EL+EL+TJ+DONE)*TJ) ENDDO J0=jam+1 ENDIF C ZS(1)=VS !RE-INSTATE PURE POT c TLAM=TL !=L HERE c i10=i0 I00=2 m00=1 i1=mfe(m00) i11=1 i2=i0-2 c c write(0,*)'Hello World 1' C 80 DO I=i11,I00 c write(0,*)'Hello World 2' FR(I)=DZERO DO J=1,J0 C T=dble(J) C T=T+TL !=J+L HERE FR(I)=FR(I)+A(J)*DX(I)**(J+L) ENDDO ENDDO C IF(ABS(FR(I00)).LT.DEPS.AND.ABS(FR(I00-1)).LT.DEPS)THEN if(i00.lt.i2)then i11=i11+2 i00=i00+2 if(i00.ge.i1)then if(i00.eq.i1)i00=i00+1 m00=m00+1 if(m00.gt.mfh0)then !zero across entire mesh if(i0.eq.i10)then !not reached inner turning-point m00=m00-1 i00=i1-1 fr(i00)=deps go to 81 else !maybe need to be renormalized write(6,1003)E,L,DX(I0) stop 'fcf6: starting f-values must be non-zero' c go to 999 !SUN f95 -O4 does not like this... endif endif i1=i1+mfe(m00) endif go to 80 elseif(i0.eq.i10)then !not reached inner turning-point i00=i0-1 fr(i00)=deps go to 81 else !beyond inner turning point WRITE(6,1003)E,L,DX(I0) STOP 'FCF6: STARTING F-VALUES MUST BE NON-ZERO' C GO TO 999 !SUN f95 -O4 does not like this... endif ENDIF c write(0,*)i00,dx(i00),i0,dx(i0) c 81 IF(ABS(C-A1).GT.DEPS0)THEN !SKIP IF A(1)=C (&A(2)=A(1)*... c write(0,*)c DO I=1,I00 FR(I)=FR(I)*C c write(6,*)i,fr(i) ENDDO ENDIF C C SUMMED COWELL NUMEROV OVER INPUT GRID C M=0 !NODES C MFH=m00 H=DNS(mfh) IM=1 C I=I00 X=DX(I) T=DONE/X C V2=ZL(I)+DTWO*VSC(I)+WILT(T,EI,Z1,CI) IF(BREL)V2=V2+PMVDAR(I,X) C 101 TT=X-H T=DONE/TT II=I-IM C V1=ZL(II)+DTWO*VSC(II)+WILT(T,EI,Z1,CI) IF(BREL)V1=V1+PMVDAR(II,TT) C HH=H*H H1=HH/DTWELV C0=FR(I)*(DONE+(H1-HH)*V2)-FR(I-IM)*(DONE+H1*V1) C1=FR(I)*(DONE+H1*V2) C 41 I=I+1 X=DX(I) C1=C1+C0 T=DONE/X C V2=ZL(I)+DTWO*VSC(I)+WILT(T,EI,Z1,CI) IF(BREL)V2=V2+PMVDAR(I,X) C FR(I)=C1/(DONE+H1*V2) C0=C0-HH*V2*FR(I) C IF(I.GT.I0.AND.FR(I-1)*FR(I).LT.DZERO)M=M+1 !NODES IF(I.LT.I1)GO TO 41 C C START NEW INTERVAL C MFH=MFH+1 H2=H C IF(MFH.LE.MFH0)THEN H=DNS(MFH) I1=MFE(MFH)+I1 IM=2 C IF(H.LE.HMAX)GO TO 101 !CHECK IF STEP CAN BE INCREASED C H0=DNS(MFH-1) JH=2 C 53 J=0 54 J=J+1 C X=X+H0 C1=C1+C0 T=DONE/X C IF(I.LT.MEND)THEN ZT=Z1-X*ZEFXL(X,ZL,DX,I) V2=WILT(T,EI,ZT,CI) ELSE V2=WILT(T,E,Z2,CI1) ENDIF C F2=C1/(DONE+H1*V2) C0=C0-HH*V2*F2 IF(J.LT.JH)GO TO 54 C I=I+1 X=DX(I) FR(I)=F2 C IF(I.GT.I0.AND.FR(I)*FR(I-1).LT.DZERO)M=M+1 !NODES IF(I.LT.I1)GO TO 53 C MFH=MFH+1 H2=H0 IF(MFH.LE.MFH0)THEN I1=MFE(MFH)+I1 JH=JH+JH GO TO 53 ENDIF C ENDIF C C END OF REQUESTED TABULATION C F2=FR(I1) X1=X ZT=ZA-VSC(I1)*X1 Z2=ZT+ZT C C TEST IF SHORT RANGE POTENTIALS CAN BE NEGLECTED C T=DONE/X1 TH=V2-WILT(T,E,Z2,CI1) V2=V2+D1M10 IF(ABS(TH)*D1P4.GT.ABS(V2))WRITE(6,1000)E,L,X1,ABS(TH/V2) C T=DTHREE*CI1+DSIXTY X2=T/(SQRT(ZA2+E*T)-ZA) XZ=(D1P4*ABS(Z3/V2))**DFIFTH X2=MAX(X2,XZ,RZERO) C C DETERMINE WHERE TO NORMALISE WHEN PLASMA SCREENING POTENTIAL PRESENT C ALWAYS GO OUT TO AT LEAST TO DX(MAXPS). C ZT=ZA-VSC(I1)*DX(I1) Z2=ZT+ZT IF(DENE.LE.DZERO)GO TO 299 C 304 IF(X2.LT.XC1)THEN C IF(DX(MAXPS).LT.XC1)THEN IF(X1.LT.XC1)GO TO 299 C IF(X2.GT.DX(MAXPS))THEN DO I=1,I1 IF(DX(I).GT.X2)GO TO 301 ENDDO I=I1 ELSE I=MAXPS ENDIF C GO TO 301 ELSE ZX=ZA-VSC(MAXPS)*DX(MAXPS) XT=T/(SQRT(ZX*ZX+E*T)-ZX) X2=DX(MAXPS) C IF(X2.LT.XT)THEN X2=XT IF(X2.GT.X1)GO TO 304 ENDIF C IF(X1.GT.XC2)GO TO 102 C IF(ABS(X2-XC1).GT.ABS(XC2-X1))THEN XT=T/(SQRT(ZT*ZT+E*T)-ZT) IF(XT.LT.X1)GO TO 300 ENDIF C DO I=1,I1 IF(DX(I).GT.X2)GO TO 308 ENDDO 300 I=I1 308 ZT=ZA-VSC(I)*DX(I) TT=-ZT/DX(I) IF(TT.GT.D1M2*E)WRITE(6,1002) IF(TT.LT.D5M2*E)GO TO 301 WRITE(6,1001) WRITE(0,*)'FCF6: UNABLE TO DETERMINE AMP-PHASE' GO TO 999 ENDIF C ELSE C IF(X1.GT.XC2)GO TO 299 IF(X2.LE.X1)THEN DO I=1,I1 IF(DX(I).GT.X2)GO TO 310 ENDDO ENDIF I=I1 310 ZX=ZA-VSC(I)*DX(I) X2=T/(SQRT(ZX*ZX+E*T)-ZX) XT=DX(MAXPS) IF(XT.LT.X2)XT=X2 C IF(X1.LT.X2.OR.ABS(X1-XC2).LT.ABS(XT-XC1))THEN C USE APPROX ZT (X=X1) IN C-N AND AMP-PHASE TT=-ZT/X1 IF(TT.GT.D1M2*E)WRITE(6,1002) IF(TT.LT.D5M2*E)GO TO 299 WRITE(6,1001) WRITE(0,*)'FCF6: UNABLE TO DETERMINE AMP-PHASE' GO TO 999 ELSE DO I=1,I1 IF(DX(I).GT.XT)GO TO 312 ENDDO I=I1 312 ZT=ZA-VSC(I)*DX(I) C C CHECK AMP-PHASE ACC C TT=-ZT/DX(I) IF(TT.GT.D1M2*E)WRITE(6,1002) IF(TT.LT.D5M2*E)GO TO 301 WRITE(6,1001) WRITE(0,*)'FCF6: UNABLE TO DETERMINE AMP-PHASE' GO TO 999 ENDIF C ENDIF C C STOP 44 301 Z2=ZT+ZT X=DX(I) F2=FR(I) C C RE-INITIALISE FOR F3, ALTERNATIVELY COULD SEARCH FOR F3 LATER C H2=DX(I)-DX(I-1) NH=1 303 IF(H2.GT.HMAX)THEN H2=DHALF*H2 NH=NH+1 GO TO 303 ENDIF C IF(NH.GT.1)THEN TH=NH F1=-DHALF*(TH-DONE)*FR(I-2)+(TH+TH-DONE)*FR(I-1)+ X DHALF*(TH+TH-DONE)*(TH-DONE)*FR(I) F1=F1/(TH*TH) ELSE F1=FR(I-1) ENDIF C HH=H2*H2 H1=HH/DTWELV T=DONE/X V2=WILT(T,E,Z2,CI1) TT=X-H2 T=DONE/TT V1=WILT(T,E,Z2,CI1) C0=F2*(DONE+(H1-HH)*V2)-F1*(DONE+H1*V1) C1=F2*(DONE+H1*V2) IP=I+1 DO J=IP,I1 IF(FR(J)*FR(J-1).LT.DZERO)M=M-1 !NODES ENDDO GO TO 102 C END PLASMA MOD C C CONTINUE INTEGRATION UNTIL CAN USE AMP PHASE C (COULD INCREASE STEP NOW SINCE NOT RESTRICTED BY TABULATION GRID, C BUT STILL NEEDS TO BE FINE ENOUGH FOR NUMEROV.) C 299 IF(X2.GT.X1)THEN C T=HMAX/DNS(MFH0) IH=-INT(T) !SUPPRESS IF(IH.GT.1.AND.IH.LE.MFE(MFH0))THEN IH=MIN(IH,4) !DON'T GO MAD H2=DX(I1)-DX(I1-IH) HH=H2*H2 H1=HH/DTWELV T=DONE/DX(I1-IH) V1=WILT(T,E,Z2,CI1) F1=FR(I1-IH) V2=V2-D1M10 C0=F2*(DONE+(H1-HH)*V2)-F1*(DONE+H1*V1) ENDIF C 118 F1=F2 X=X+H2 C1=C1+C0 T=DONE/X C2=WILT(T,E,Z2,CI1) F2=C1/(DONE+H1*C2) C0=C0-HH*C2*F2 IF(F1*F2.LT.DZERO)M=M+1 !NODES c write(6,*)x,f2 IF(X.LT.X2)GO TO 118 C ELSE C DO I=MEND,-I1,2 !SUPPRESS IF(X2.LT.DX(I))THEN IP=I+1 DO J=IP,I1 IF(FR(J)*FR(J-1).LT.DZERO)M=M-1 !NODES ENDDO H2=DX(I)-DX(I-1) HH=H2*H2 H1=HH/DTWELV T=DONE/DX(I-1) V1=WILT(T,E,Z2,CI1) F1=FR(I-1) T=DONE/DX(I) V2=WILT(T,E,Z2,CI1) F2=FR(I) C0=F2*(DONE+(H1-HH)*V2)-F1*(DONE+H1*V1) C1=F2*(DONE+H1*V2) X=DX(I) GO TO 102 ENDIF ENDDO C ENDIF C C EVALUATE ASYMPTOTIC AMP AND PHASE AT X2 AND X3=X2+0.5*WAVELENGTH C 102 X2=X C CALL DNAMP(A2,AMP2,E,CI1,Q,U,ZT,X2,NNMAX,JMAX) C LM=L IF(BREL)LM=-L-1 PHI2=PHASEX(E,CI1,Q,U,LM,ZT,X2) X23=PIH*A2*A2 X3=X2+X23 C 103 X=X+H2 C1=C1+C0 T=DONE/X C2=WILT(T,E,Z2,CI1) F3=C1/(DONE+H1*C2) C0=C0-HH*C2*F3 IF(X.LT.X3)GO TO 103 X3=X C CALL DNAMP(A3,AMP3,E,CI1,Q,U,ZT,X3,NNMAX,JMAX) C PHI3=PHASEX(E,CI1,Q,U,LM,ZT,X3) C F2=F2/A2 F3=F3/A3 S2=SIN(PHI2) S3=SIN(PHI3) C2=COS(PHI2) C3=COS(PHI3) S23=SIN(PHI3-PHI2) C23=COS(PHI3-PHI2) CT=SQRT(S23*S23/(F2*F2+F3*F3-DTWO*F2*F3*C23)) T=CT/S23 SD=(F2*S3-F3*S2)*T CD=(F3*C2-F2*C3)*T C C NON-COULOMB PHASE SHIFT C DEL=ATAN2(SD,CD) T=(PHI2+DEL)/PI M1=INT(T) EM1=M-M1 DEL=EM1+DEL/PI c f2norm=sin(phi2+del*pi)*a2 c f2=f2*a2*ct C C NORMALISE FR C IF(FR(I0).LT.DZERO)CT=-CT C=C*CT IF(.NOT.BREL)THEN C TLAM=L DO I=1,I1 FR(I)=CT*FR(I) ENDDO c write(0,*)l,c,fr(1)/dx(1)**(l+1) ELSE C TLAM=L T=DONE IF(RNUK.GT.DZERO)T=T+DQUART*DALF*(EI-DTHREE*ZI0/RNUK) T=DONE/SQRT(T) C=C*T C C THE FOLLOWING BOTH TRANSFORMS SOLUTION AND CORRECTS NORMALIZATION C C (RENORMALIZING FOR OMITTED SMALL CPT IS MINOR IMPROVEMENT AT BEST C AT MEDIUM Z, BUT VERY POOR AT HIGH Z.) C C IF(BREL2)THEN TQ=DQUART DE=DONE C ELSE !TRY AND COMPENSATE FOR MISSING SMALL CPT C TQ=DQUART !FORMAL RENORMALIZATION C DE=SQRT((DONE+DHALF*DALF*EI)/(DONE+DQUART*DALF*EI)) C TQ=DHALF !SAMPSON E->E-V C DE=DONE C ENDIF C c w=done !standard Darwin c if(l.gt.0)w=-2. !see also radwav DO I=1,I1 T=DONE+TQ*DALF*(EI+ZL(I)+DTWO*VSC(I)-Z1/DX(I)) T=SQRT(T) c t=t**(w/dtwo) FR(I)=CT*DE*T*FR(I) ENDDO c c call dnamp(a2,amp2,e,ci1,q,u,zt,x1,nnmax,jmax) c phi2=phasex(e,ci1,q,u,lm,zt,x1) c fnorm=sin(phi2+del*pi)*a2*t !sqrt(done+tq*dalf*(ei-z2/x1)) c write(6,*)l,ei,x1,x2,f2/f2norm,fr(i1)/fnorm C C SMALL COMPONENT C IF(BREL2)THEN tkap=-1 if(kappa.ne.0)tkap=kappa c if(l.gt.0)tkap=l !-l-1 or l c CALL DIFF(FR,GR,MFE,DNS,MFH0) C DO I=1,I1 T=DONE+DQUART*DALF*(EI+ZL(I)+DTWO*VSC(I)-Z1/DX(I)) GR(I)=DHALF*DFSC*(GR(I)+tkap*FR(I)/DX(I))/T c if(e.gt.0.)write(6,*)i,t!fr(i)**2+gr(i)**2*4*e/(dalf*ei**2) ENDDO ENDIF C C REPLACE NUCLEUS C DO I=1,INUK T=ZL(I) ZL(I)=DNUK(I) DNUK(I)=T ENDDO ENDIF C c write(70,700)l,e,c,a1,i0,dx(i0),fr(i0),i1,dx(i1),fr(i1) c 700 format(i5,1p,3e15.8,i5,2e15.8,i5,2e15.8) c write(6,700)l,e,c,a1,i0,dx(i0),fr(i0),i1,dx(i1),fr(i1) c do i=1,i1 c write(6,700)i,dx(i),fr(i) c enddo C RETURN !NORMAL RETURN C 999 L=-999 !FLAG ABORT C RETURN C 1000 FORMAT('E=',F10.4,' RYD',5X,'L=',I3,5X,'X1=',F10.6,5X,'RAT=',F8.5, X5X,'X1 TOO SMALL, SHORT-RANGE POTENTIALS STILL TOO LARGE IN FCF6') 1001 FORMAT(//' UNABLE TO DETERMINE AMP-PHASE, INCREASE MAXB1 OR' X,' INCREASE STEP-LENGTH') 1002 FORMAT(' WARNING, PLASMA SCREENING POTENTIAL MAY CAUSE INACCURACY' X,' IN EVALUATION OF AMP-PHASE') 1003 FORMAT(//'SR.FCF6: BOTH STARTING VALUES OF F ARE ZERO, NUMERICAL ' X,'INTEGRATION JUST RETURNS A NULL FUNCTION FOR'/'E=',F10.4,' RYD' X,5X,'L=',I3,5X,'AT INNER TURNING POINT X0=',F10.4) 1004 FORMAT('*** SR.FCF6: CONTINUUM FUNCTION NOT DETERMINABLE FOR L,' X,' E :',I6,F10.4) C END C C*********************************************************************** C REAL*8 FUNCTION FDIP(EK1,L1,EK2,L2,IFAIL) C C----------------------------------------------------------------------- C C FN.FDIP: C CALCULATES THE FUNCTION I(KAPPA1,L1,KAPPA2,L2,1) C DEFINED IN PHIL. TRANS. ROY. SOC. A226, 255, (1970), C WHERE EK1=KAPPA1**2 AND EK2=KAPPA2**2. C IT IS SUITABLE FOR USE IN EQUATIONS (8),(9),(10) OR (11) OF C J. PHYS. B. 7, L364, (1974). C ALAN BURGESS DEPT. OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE C C NRB: ADDED FDIPA ASYMPTOTIC OPTION FOR EXTREME CASES C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTEN=10.0D0) PARAMETER (D1O6=0.16667D0) !1/6 PARAMETER (D1O34=0.02944D0) !1/34 PARAMETER (D1M40=1.0D-40) PARAMETER (EPS=1.D-4) C IPRINT=IFAIL C IF(EK1+EK2.LT.D1M40)THEN FDIP=DZERO IFAIL=1 IF(IPRINT.EQ.-2)WRITE(6,100)IFAIL RETURN ENDIF C IF(EK1.LE.EK2)THEN EMIN=EK1 EMAX=EK2 ELSE EMIN=EK2 EMAX=EK1 ENDIF C T=EMIN/EMAX C IF(T.LT.D1O6)THEN FDIP=FDIP1(EK1,L1,EK2,L2) IF(FDIP*FDIP.LT.D1M40.AND.T.GT.D1O34)FDIP=FDIP2(EK1,L1,EK2,L2) ELSE FDIP=FDIP2(EK1,L1,EK2,L2) ENDIF C IF(FDIP*FDIP.LT.D1M40)THEN IFAIL=2 IF(IPRINT.EQ.-2)WRITE(6,100)IFAIL RETURN ENDIF C IF(FDIP.LT.DZERO.OR.FDIP.GT.DONE)THEN IFAIL=3 IF(IPRINT.EQ.-2)WRITE(6,100)IFAIL FDIP=DZERO RETURN ENDIF C IFAIL=0 FA=FDIPA(EK1,L1,EK2,L2) C IF(FA.EQ.DZERO)THEN FA=FDIP0(EK1,L1,EK2,L2,EPS,IFAIL) IFAIL=-IFAIL IF(FA.EQ.DZERO)RETURN ENDIF C RAT=FDIP/FA IF(RAT.GT.DTEN)THEN IFAIL=4 IF(IPRINT.EQ.-2)WRITE(6,100)IFAIL FDIP=DZERO ENDIF C RETURN C 100 FORMAT('***FDIP FAILURE: IFAIL=',I2) C END C C*********************************************************************** C REAL*8 FUNCTION FDIP0(EK1,L1,EK2,L2,EPS,IFAIL) C C----------------------------------------------------------------------- C C FN.FDIP0: C CALCULATES THE FUNCTION I0(K1,L1,K2,L2,1) C DEFINED IN PHIL. TRANS. ROY. SOC. A266,255,1970, C WHERE EK1=K1*K1, EK2=K2*K2, C AND THE RELATIVE ACCURACY IS APPROXIMATELY EPS. C IT IS SUITABLE FOR USE IN EQUATIONS (13) ETC. OF C J. PHYS. B. 7,L364, (1974) C ALAN BURGESS, DEPT OF APPLIED MATHS. AND THEORETICAL PHYSICS,CAMBRIDGE C C NRB - IFAIL C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DQUART=0.25D0) PARAMETER (DHALF=0.5D0) PARAMETER (DONE=1.0D0) PARAMETER (D1PT5=1.5D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D300=300.0D0) C IPRINT=IFAIL IFAIL=0 C IF(L1.LT.L2)THEN L=L1 ELSEIF(L1.GT.L2)THEN L=L2 ELSE IF(IPRINT.EQ.-2)WRITE(6,100)L1 IFAIL=1 FDIP0=DZERO RETURN ENDIF C EL=L FDIP0=DHALF/(EL+DONE) C IF(EK1.LT.EK2)THEN E=EK1/EK2 P=L1-L ELSEIF(EK1.GT.EK2)THEN E=EK2/EK1 P=L2-L ELSE RETURN ENDIF C FDIP0=FDIP0*E**((EL+P+DHALF)*DHALF) C C TO OBTAIN THE FUNCTION EK1 OF M.J. SEATON, PROC. PHYS. SOC. A68,457, C 1955, REMOVE THE 'C' ON THE NEXT LINE. C FDIP0=DONE C IF(E.GE.DHALF)THEN C P1=P-DHALF T=P1*(EL+DONE)*(E-DONE) I0=L+1 H0=DZERO C DO I=1,I0 TI=I H0=H0+DONE/TI ENDDO C X=DONE-E H=DONE-(P+P+H0+LOG(DQUART*X)) S=DONE+T*H A=EL+DONE B=P1 C=DONE D=DZERO C 10 A=A+DONE B=B+DONE C=C+DONE D=D+DONE T=T*A*B*X/(C*D) H=H+P1/(D*B)+EL/(C*A) T1=T*H S=S+T1 C IF(ABS(T1).GE.EPS*ABS(S))THEN IF(C.LT.D300)GO TO 10 IF(IPRINT.EQ.-2)WRITE(6,101) IFAIL=2 ENDIF C FDIP0=FDIP0*S C ELSE C A=EL+DONE B=P-DHALF C=EL+P+D1PT5 C F=F21(A,B,C,E,EPS,IFAIL) C L=L+1 EL=L C IF(P.LE.DHALF)THEN C1=EL+EL+DONE ELSE C1=DONE ENDIF C DO I=1,L AI=I AII=AI+AI C1=C1*AI*AI*DFOUR/(AII*(AII+DONE)) ENDDO C FDIP0=FDIP0*F*C1 C ENDIF C RETURN C 100 FORMAT(' FAILED IN FDIP0, L1=L2=',I5) 101 FORMAT(' FAILED TO CONVERGE IN FDIP0') C END C C ******************************************************************* C REAL*8 FUNCTION FDIP1(EK1,L1,EK2,L2) C C----------------------------------------------------------------------- C C FN.FDIP1 EVALUATES DIPOLE INTERGALS IN TERMS OF MONOPOLE INTEGRALS - C SEE EQU (A3) OF BHT(1970) - CASE EMAX/EMIN.GT.6. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D1M40=1.0D-40) C IF(L1.LT.L2)THEN L=L1 A1=EK1 A2=EK2 ELSEIF(L1.GT.L2)THEN L=L2 A1=EK2 A2=EK1 ELSE FDIP1=DZERO RETURN ENDIF C LP=L+1 ELP=LP C B1=SQRT(DONE+ELP*ELP*A2)*FMON1(EK1,EK2,L) B2=SQRT(DONE+ELP*ELP*A1)*FMON1(EK1,EK2,LP) C IF(B1*B2.LT.D1M40)THEN FDIP1=DZERO ELSE FDIP1=(B1-B2)/ELP ENDIF C RETURN END C C ****************************************************************** C REAL*8 FUNCTION FDIP2(EK1,L1,EK2,L2) C IMPLICIT REAL*8 (A-H,O-Z) C C EVALUATE DIPOLE INTERGALS IN TERMS OF MONOPOLE INTEGRALS - C SEE EQU (A3) OF BHT(1970) - CASE EMAX/EMIN.LT.6. C NRB: BASED ON ALAN'S ORIGINAL. C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D4TEEN=14.0D0) PARAMETER (D200=200.D0) PARAMETER (D1P24=1.0D+24) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M40=1.0D-40) C PI=ACOS(-DONE) WMAX=D200 C ETA1=DONE/SQRT(EK1) ETA2=DONE/SQRT(EK2) W1=ETA2-ETA1 A=ABS(W1) B=PI*A C IF(B.LE.D1M2)THEN C=DTHREE/(DTHREE-B*(DTHREE-B*(DTWO-B))) C=SQRT(C) ELSEIF(B.GE.D4TEEN)THEN C=SQRT(B+B) ELSE B=B+B C1=DONE-EXP(-B) C=SQRT(B/C1) ENDIF C C=C/(SQRT(ETA1*ETA2)*DTWO) C2=ETA1+ETA2 C1=DFOUR*ETA1*ETA2/(C2*C2) C IF(L2.LE.L1)THEN L=L2 T1=ETA1 ETA1=ETA2 ETA2=T1 W1=-W1 ELSE L=L1 ENDIF C C=C*C1**(L+1) U0=L+1 U1=ETA1 V0=U0 V1=-ETA2 W0=DONE X0=W1/(C2*C2) Y2=-ETA2-ETA2 Y0=-U0*W1+Y2 Y1=ETA2*W1 T1=X0/(DONE+W1*W1) Z0=U0*T1 Z1=U1*T1 T=Z0-Z1*W1 Z1=Z0*W1+Z1 Z0=T Q0=-DONE+Z0*Y0-Z1*Y1 Q1=Z0*Y1+Z1*Y0 X=W1*X0 C 8 U0=U0+DONE V0=V0+DONE W0=W0+DONE C IF(W0.GT.WMAX)THEN FDIP2=DZERO RETURN ENDIF C Y0=Y0+Y2 T=Z0*U0-Z1*U1 Z1=Z0*U1+Z1*U0 Z0=T T=Z0*V0-Z1*V1 Z1=Z0*V1+Z1*V0 Z0=T T=Z0*W0-Z1*W1 Z1=Z0*W1+Z1*W0 Z0=T X0=X/(W0*(W0*W0+W1*W1)) Z0=Z0*X0 Z1=Z1*X0 T0=Z0*Y0-Z1*Y1 T1=Z0*Y1+Z1*Y0 Q0=Q0+T0 Q1=Q1+T1 T1=T0*T0+T1*T1 T0=Q0*Q0+Q1*Q1 C IF(T0.LT.D1P24*T1)GO TO 8 C J1=0 J2=L+1 P=ARGAM(DBLE(J1),W1)+ARGAM(DBLE(L),ETA1)-ARGAM(DBLE(J2),ETA2) C IW0=W0 IF(A.GT.D1M40)P=P+W1*LOG(C2/A) C P0=COS(P) P1=SIN(P) T=P0*Q0-P1*Q1 Q1=P0*Q1+P1*Q0 Q0=T FDIP2=C*Q1 C RETURN C END C C*********************************************************************** C REAL*8 FUNCTION FDIPA(EK1,L1,EK2,L2) C C----------------------------------------------------------------------- C C FN.FDIPA EVALUATES ASYMPTOTIC EXPRESSIONS FOR I(KAPPA1,L1,KAPPA2,L2,1) C BASED ON A40,1 OF BHT. NRB C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (D100=100.D0) PARAMETER (D1M50=1.0D-50) C IF(EK1*EK2.LT.D1M50)THEN FDIPA=DZERO RETURN ENDIF C X1=DONE/SQRT(EK1) X2=DONE/SQRT(EK2) XP=ABS(X1-X2) IF(XP.GT.D100)THEN FDIPA=DZERO RETURN ENDIF C PI=ACOS(-DONE) XP=EXP(PI*XP/DTWO) C IF(EK1.LE.EK2)THEN C E=EK1/EK2 IF(L1.LE.L2)THEN L=L1 GO TO 7 ELSE L=L2 GO TO 8 ENDIF C ELSE C E=EK2/EK1 IF(L1.LE.L2)THEN L=L1 GO TO 8 ELSE L=L2 GO TO 7 ENDIF C ENDIF C C A40 C 7 TL=L T0=DONE-E IF(TL*T0.LT.E)THEN FDIPA=DZERO RETURN ENDIF C T=PI*TL EE=SQRT(E) F0=SQRT(T*T0*EE)*EE**L TL=L+L+1 FDIPA=F0*XP/TL RETURN C C A41 C 8 T0=DONE-E TL=L IF(TL*T0.LT.E)THEN FDIPA=DZERO RETURN ENDIF C T0=DONE/T0 T=TL*PI EE=SQRT(E) F0=SQRT(T*T0*EE)*EE**(L+1) TL=L+L+1 TL2=L+L+3 FDIPA=F0*XP/(TL*TL2) C RETURN END C C ******************* C SUBROUTINE FILON(L,V,RMAX,IMAX,F,FB,FO) C C----------------------------------------------------------------------- C C SR.FILON EVALUATES BORN INETGRALS USING FILON'S RULE. C A. BURGESS, DAMTP, CAMBRIDGE. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (DQUART=0.25D0) PARAMETER (D2THRD=DTWO/DTHREE) PARAMETER (D4THRD=DFOUR/DTHREE) PARAMETER (DPT1=0.1D0) PARAMETER (DPT3=0.3D0) PARAMETER (D8P6=8.0D6) C DIMENSION F(0:*) C H=RMAX/IMAX B0=DONE C IF(L.GT.0)THEN DO I=1,L B0=(I+I+1)*B0 ENDDO B0=DONE/B0 B1=DONE/(L*4+6) B2=B1/(L*8+20) TT=L*DQUART ELSE S2=DZERO S3=DZERO T1=DONE/5040 TT=DPT1 ENDIF C R=DZERO S0=DZERO S1=DZERO V2=V*V C DO I=1,IMAX C R=R+H T=V*R IF(T.LT.TT)THEN T2=T*T IF(L.GT.0)THEN T1=((B2*T2-B1)*T2+DONE)*B0 DO K=1,L T1=R*T1 ENDDO ELSE T0=((42-T2)*T2-840)*T1*R*R T2=V2*T0+DONE ENDIF ELSE IF(T.LT.D8P6)THEN S=SIN(T) C=COS(T) ELSE S=DZERO C=DZERO ENDIF IF(L.EQ.0)THEN T2=S/T T0=(T2-DONE)/V2 ELSE U=DONE/T T1=(S*U-C)*U IF(L.GT.1)THEN T0=S*U DO K=1,L-1 T2=(2*K+1)*T1*U-T0 T0=T1 T1=T2 ENDDO ENDIF U=DONE/V DO K=1,L T1=T1*U ENDDO ENDIF ENDIF C T=F(I) IF(MOD(I,2).EQ.0)THEN IF(L.EQ.0)THEN S0=T*T0+S0 S2=T*T2+S2 ELSE S0=T*T1+S0 ENDIF ELSE IF(L.EQ.0)THEN S1=T*T0+S1 S3=T*T2+S3 ELSE S1=T*T1+S1 ENDIF ENDIF C ENDDO C T=V*H IF(T.LE.DPT3)THEN T2=T*T B0=(T2*10-108)*T2+378 C0=(54-T2)*T2-1512 IF(L.GT.0)THEN B=(B0*T2+1890)/2835 C=(C0*T2+15120)/11340 ELSE B0=B0*H*H/2835 B=B0*V2+D2THRD C0=C0*H*H/11340 C=C0*V2+D4THRD ENDIF ELSE IF(T.LT.D8P6)THEN S=SIN(T) C=COS(T) T0=C*C ELSE S=DZERO C=DZERO T0=DHALF ENDIF T1=DONE/T T2=T1*T1 B=(DONE+T0-DTWO*S*C*T1)*T2*DTWO C=(S*T1-C)*T2*DFOUR IF(L.EQ.0)THEN C0=(C-D4THRD)/V2 B0=(B-D2THRD)/V2 ENDIF ENDIF C IF(L.GT.0)THEN FB=(B*S0+C*S1)*H FO=DZERO ELSE FO=(B*S2+C*S3)*H FB=((S0*DTWO+S1*DFOUR)/DTHREE+B0*S2+C0*S3)*H ENDIF C RETURN END C C ******************* C SUBROUTINE FIT(A0,M,H,A,C) C C----------------------------------------------------------------------- C C N.R.BADNELL D.A.M.T.P. CAMBRIDGE C C SR.FIT FITS A RADIL FUNCTION NEAR THE ORIGIN BY A POWER SERIES. C INPUT TABULATED FUNCTION A(I) WITH I .GE. 5, STEP H AND BEHAVIOUR C A0*X**M FOR X SMALL. C OUTPUT C(I) (I.GT.5 UNDEFINED) A POWER SERIES EXPANSION OF FORM C (A0+C(1)*X+..............C(5)*X**5)*X**M C NOTE THAT A0 IS CORRECT LEADING ORDER TERM AND IS NOT REDEFINED. C THIS FIT IS DERIVED FROM ALAN BURGESS'S SR.YLAM. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DONE=1.0D0) C DIMENSION A(5),C(5) C X1=H C1=A(1)/X1**M-A0 X2=X1+H C2=A(2)/X2**M-A0 X3=X2+H C3=A(3)/X3**M-A0 X4=X3+H C4=A(4)/X4**M-A0 X5=X4+H C5=A(5)/X5**M-A0 C H1=DONE/H Z=H1/120 C(1)=(600*(C1-C2)+400*C3-150*C4+24*C5)*Z Z=H1*Z C(2)=(-770*C1+1070*C2-780*C3+305*C4-50*C5)*Z Z=H1*Z C(3)=(355*C1-590*C2+490*C3-205*C4+35*C5)*Z Z=H1*Z C(4)=(-70*C1+130*C2-120*C3+55*C4-10*C5)*Z Z=H1*Z C(5)=(5*C1+10*(C3-C2)-5*C4+C5)*Z C RETURN END C C ******************* C SUBROUTINE FLGL1(KC,KM,NF,JYI,JYF,QLMC,AM,DFS,MAXEL) C C----------------------------------------------------------------------- C C SR.FLGL1: EXPANDS THE ENERGY MATRIX ELEMENT C IN TERMS OF TWO SORTS OF RADIAL INTEGRALS, EQ.1.6,7,8 IN E&N, C AND CALCULATES THE COEFFICIENTS AS DESCRIBED IN SECT.3.2 OF E&N C C**THIS VERSION DETERMINES THE SLATER STATE INTERACTIONS ONLY, C FOR A GIVEN SLP - NRB. C C INPUT: KM CONFIGURATIONS C. C AM(J)=TRUE FOR ALL SLST J WITH TOTAL MS,ML OTHER THAN CONSIDERED. C NF VALENCE ELECTRONS, NW CORE ELECTRONS. C 2*ML , 2*MS OF I'TH ELECTRON IN J'TH SLATER STATE C =QLMC(I,J) +-1, IF QLMC EVEN C =QLMC(I,J)-1++1, IF QLMC ODD C QCG(I,K)=G OF I'TH ELECTRON IN K'TH CONF; G=1,2,3.. FOR 1S,2S, C 2P.. IF NOT REDEFINED, GENERALLY NK=QN(K),LK=QL(K)/2. C FOR THE CORE NNL(I)=G, NNL(I+MAXCL)=QLMC AS ABOVE, (I=1,NW) C KC IS CONFIG OF FIRST SYMMETRY, USED FOR CORE. C C OUTPUT: COEFFICIENTS DRKS(J) AND ARGUMENT-ADRESSES L=NRKS(J) STORED C SEQUENTIALLY FROM IRKS0 ONWARDS; ARGUMENTS QRLS(1...5,L)=A,B,C,D,LD C TEMPORARILY LISTED IN NEW SECTION OF REF.-LIST FROM IRLS00 ONWARDS C AT THE END ALL QRLS THAT HAD PREVIOUSLY BEEN LISTED ARE CANCELLED. C QLMC(K,1) IS USED AS BUFFER (K=1,2,..NF.LE.ME), AM(1) IS I/O. C C----------------------------------------------------------------------- C USE COMMON_DXRLS, ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD14=100) PARAMETER (MXD27=MAXCF*MAXCF) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (TYNY=1.D-6) C LOGICAL AM,BVC,EQCFS,EQTMS,SKP,BFANO,BKUTOO,BDLBD X ,BSKP,BFALL,BPLANT CF77 X ,BFALLS !F77 C CHARACTER(LEN=4) CODE C DIMENSION AM(*),QLMC(MAXEL,*),DFS(*),JYI(*),JYF(*) X ,Q1(2,2),MM(2,2),Q3(2,2),Q4(2,2) X ,NEN(2,2),NEJ(2),MRL(5),NEK(2) C COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 c common /mqvc/modd,kcut,qmcl,qmcs,nel(maxgr,maxcf) CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBFAN/BFANO COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBUNI/IUNIT(MXD14),NUNIT C EQUIVALENCE (KF,NEK(1)),(KG,NEK(2)),(NEN(1,1),N1),(NEN(2,1),N2) X ,(MM(1,1),MJ11),(MM(1,2),MJ12),(MRL(5),ML) C MVC(M,MA)=((M+2)*M/2+MA)/2+1 C C BPLANT=MXORB.LT.67 JPLANT(1)=0 SKP=MXLL.EQ.-1 BKUTOO=KUTOO.NE.0 C IRLS=0 IRKS=0 NCF=0 NADS(0)=0 MXLAM=IABS(MAXLAM) C IDIR=0 !ALLOW DIRECT IXCH=0 !ALLOW ECHANGE ct idir=1 ct ixch=1 C IF(NADS(-1).EQ.-1)THEN NE=NF NF=0 EQCFS=.TRUE. KF1=KC KG1=KC ELSE KF1=1 KG1=1 ENDIF C if(iunit(12).ne.0)then !for radwin i69=69 else i69=79 endif C C LOOP OVER ALL CONFIG PAIRS C c iflagc=0 100 DO 99 KF=KF1,KM C IF(NF.GT.0)THEN II=IEQ(QCG(NF,KF)) KCF=0 IF(QN(II).GE.90)KCF=II !CONTINUUM if(qn(ii).ge.60.and.qn(ii).le.i69)kcf=-ii !omit ryd ci c iflagc=max(iflagc,kcf) ENDIF C JA=JYI(KF) JB=JYF(KF) C DO 90 KG=KG1,KF C IF(NF.EQ.0)GO TO 56 NCF=NCF+1 BSKP=NADS(NCF).LT.0 !KF AND/OR KG NOT CONTRIB NADS(NCF)=NADS(NCF-1) IF(BSKP)GO TO 90 C C OMIT CONTINUUM-CONTINUUM C II=IEQ(QCG(NF,KG)) KCG=0 IF(QN(II).GE.90)KCG=II if(qn(ii).ge.60.and.qn(ii).le.i69)kcg=-ii !omit ryd ci IF(KCF.NE.KCG.AND.KCF*KCG.NE.0)GO TO 90 !DOES NOT CONTRIB if(kcf.ne.kcg.and.(kcf+kcg).lt.0)go to 90 c omit corr-corr' c if(kf.ne.kg.and.kcf+kcg+iflagc.gt.0.and.kg.gt.kcut)go to 90 C EQCFS=KG.EQ.KF IF(EQCFS)GO TO 56 IF(MAXLAM.LT.0)GO TO 90 !SINGLE CONFIG C C SKIP, IF CONFIG KF AND KG DIFFER IN MORE THAN TWO ELECTRONS C DO I=1,NF QLMC(I,1)=QCG(I,KG) ENDDO C DO I=1,MAXGR IGRGR(I)=I ENDDO C K=0 DO I=1,NF DO L=1,NF IF(IEQ(QLMC(L,1)).EQ.IEQ(QCG(I,KF)))THEN QLMC(L,1)=0 IGRGR(QCG(I,KF))=QCG(L,KG) GO TO 51 ENDIF ENDDO K=K+1 IF(K.GT.2)GO TO 90 51 ENDDO C C COMPUTE COEFFICIENTS A AND B (SEE E+N SECTION 3.2, DO55 AND DO57 C ARE THE TWO SUMMATIONS OVER SLATER STATES IN EQ.3.17). C 56 IRLS00=IRLS IRLS1=IRLS00+1 IRKS00=IRKS+1 C EVTL IF(AM(1)) IRLS00=0 DDA=DONE DDB=DZERO C JAP=JYI(KG) JBP=JYF(KG) C C BEGIN MAIN SLATER-STATE LOOPS OVER 55 AND 57 C DO 55 J=JA,JB C IF(AM(J))GO TO 55 NEJ(1)=J IF(EQCFS)JBP=J IF(NF.EQ.0)JAP=J C DO 57 JD=JAP,JBP C IF(AM(JD))GO TO 57 DDH=DONE C C THIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE, NOT TERM COLD IRKS0=IRKS+1 C DO I=IRLS1,IRLS IORIG(I)=0 JORIG(I)=0 ENDDO C EQTMS=NF.EQ.0 !NEED EQUI AND NON-EQUI CASES C NEJ(2)=JD NK=0 NU=-NW IF(JD.EQ.J)GO TO 75 !SO EQCFS=.TRUE. IF(NF.EQ.0)STOP 'FLGL1: NF=0????' !GO TO 57 C C CALCULATE NK-THE NUMBER OF INDIVIDUAL SETS IN WHICH SLATER C STATE JD DIFFERS FROM J; THE PHASE FACTOR THAT RESULTS FROM C THE REMAINING NF-NK SETS WILL BE ABSORBED INTO DDH: C MU=0 DO I=1,NF DO L=1,NF IF(QLMC(L,JD).NE.QLMC(I,J))GO TO 59 IF(IEQ(QCG(L,KG)).NE.IEQ(QCG(I,KF)))GO TO 59 LP=L GO TO 58 59 ENDDO NK=NK+1 IF(NK.GT.2)GO TO 57 NEN(1,NK)=I MU=I+MU LP=0 58 QLMC(I,1)=LP ENDDO C K=0 DO L=1,NF DO I=1,NF IF(QLMC(I,1).EQ.L)GO TO 60 ENDDO K=K+1 NEN(2,K)=L MU=L+MU IF(K.EQ.NK)GO TO 74 60 ENDDO C 74 DDH=(1-2*MOD(MU,2))*DDH C IF(NK.EQ.2)GO TO 72 C C NOW NK=1, WHICH IMPLIES NDP1.NE.ND1 IF(N1.EQ.0.OR.N2.EQ.0)THEN WRITE(6,*) WRITE(6,*)'***SR.FLGL1: DUPLICATE CONFIGURATIONS',KF, X ' AND',KG,' ????' WRITE(0,*)'SR.FLGL1: DUPLICATION CONFIGURATIONS?' NF=-1 GO TO 999 ENDIF C c if(nk.eq.1)go to 75 !assume cancel with 2-bdy ml=0 ML=QCG(N1,KF) MU=QCG(N2,KG) IF(QL(MU).NE.QL(ML))GO TO 75 IF(QN(ML).GE.90.AND.QN(MU).GE.90)GO TO 75 IF(.NOT.SKP)DDA=DDH C DDB=DZERO IF(MU.GE.ML)THEN LP=ML ML=MU MU=LP ENDIF MRL(1)=ML MRL(2)=-0 MRL(3)=MU MRL(4)=-0 ML=-1 BFALL=.FALSE. GO TO 87 C 75 IF(DDH.EQ.DZERO)GO TO 57 C IF(.NOT.EQTMS.AND.EQCFS)NU=0 C 68 NU=NU+1 IF(NU.GT.NF)GO TO 67 NEN(1,2)=NU IF(NK.NE.0)GO TO 71 ND=NU IF(ND*NF.LT.0)ND=0 69 ND=ND+1 IF(ND.GT.NF)GO TO 68 NEN(1,1)=ND 71 IF(NEN(1,1).EQ.NEN(1,2))GO TO 65 C 72 IMT=0 C !test - need to exc kcor as well c nval=0 !test - exclude "core" DO L=1,2 !=1 FOR SLATER STATES J (OF CONFIG KF),=2 FOR JD (OF KG) I=L DO K=1,2 !=1 FOR FOR FIRST PAIR OF ELECTRON STATES,=2 FOR SECOND IF(NK.LT.K)I=1 KP=NEN(I,K) IF(KP.LE.0)THEN KP=KP+NW LP=NNL(KP,1) MU=NNL(KP,2) ELSE LP=NEJ(I) MU=QLMC(KP,LP) LP=NEK(I) LP=QCG(KP,LP) IF(QN(LP).GE.90)IMT=IMT+1 IF(IMT.GT.1)GO TO 65 ENDIF ML=((QL(LP)+MU)/2)*2-QL(LP) Q4(L,K)=(MU-ML)*2-1 Q3(L,K)=ML MM(L,K)=QL(LP) Q1(L,K)=LP c if(qn(lp).ge.80)nval=nval+1 !test - exclude "core" ENDDO ENDDO c if(nval.ne.2)go to 65 !test - exclude "core" IF(NK.EQ.1)Q1(2,2)=IGRGR(Q1(2,2)) C C DIRECT C KP=0 C C EQU MJ11=Q2(1,1) C EQU MJ12=Q2(1,2) MM11=-Q3(1,1) MM12=-Q3(1,2) MV11=MVC(MJ11,MM11) MV12=MVC(MJ12,MM12) C IF(IDIR.EQ.1)GO TO 76 !NO DIRECT C C EXCHANGE RE-ENTRY POINT C 77 IF(.NOT.SKP.AND.Q4(2,1+KP).NE.Q4(1,1))GO TO 76 C MJ21=MM(2,KP+1) MJ22=MM(2,2-KP) C C MU=MAX LAM MU=MIN0(MJ11+MJ21,MJ12+MJ22,2*MXLAM) C C ML=MIN LAM ML=MAX0(IABS(MJ11-MJ21),IABS(MJ12-MJ22)) C C AGAIN (SEE BELOW) ORBIT-ORBIT "LESS RESTRICTIVE" - C HOW I MISSED THIS FOR SO LONG... IF(.not.BKUTOO.and. !add .not.BKUTOO !!!!! X .NOT.EQTMS.AND.KP+NK+ML.EQ.0)ML=4 IF(ML.GT.MU)GO TO 76 c c if(ml.eq.0.and.kp.eq.0.and.nk.eq.1)go to 10 !assume cancel ml=-1 C IF(.NOT.SKP)THEN MM21=Q3(2,KP+1) MMD1=MM21+MM11 MM22=Q3(2,2-KP) MMD2=MM12+MM22 C C INCREASE MIN LAM BECAUSE OF ML1-ML2 K=MAX0(IABS(MMD1),IABS(MMD2)) C C ORBIT-ORBIT LAM+1, SO "LESS RESTRICTIVE" - C THIS WAS IN MY ORIGINAL CODING OF O-O IF(BKUTOO)K=K-2 IF(K.GT.ML)ML=((K+2-ML)/4)*4+ML IF(ML.GT.MU)GO TO 76 DSJ=SQRT( DBLE((MJ11+1)*(MJ12+1)*(MJ21+1)*(MJ22+1)))* X DBLE((1-MOD(IABS(MM22-MM11),4))*(1-2*KP))*DDH MV21=MVC(MJ21,MM21) MV22=MVC(MJ22,MM22) ENDIF C C REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR C L=0 K=0 IF(Q1(2,2-KP).GT.Q1(1,2))K=2 !FO I=0 IF(Q1(2,1+KP).GT.Q1(1,1))I=2 !FO BFALL=BKUTOO.AND.I+K.EQ.2 C 62 MRL(1+I+L)=Q1(1,1) MRL(3-I+L)=Q1(2,1+KP) MRL(2+K-L)=Q1(1,2) MRL(4-K-L)=Q1(2,2-KP) L=1 IF(MRL(2).GT.MRL(1))GO TO 62 !FO C C LAMBDA RE-ENTRY POINT C 78 IF(.NOT.SKP)THEN LP=ML/4+1 IF(BVC.OR.(MJ11.LE.MXLL.AND.MJ21.LE.MXLL))THEN DDA=VCA(MV11,MV21,LP) IF(BKUTOO)DDB=VCB(MV11,MV21,LP) ELSE DVC=VCC(MJ11,MJ21,ML,0,0,0,DFS,MXDFS) DDA=DVC*VCC(MJ11,MJ21,ML,MM11,MM21,MMD1,DFS,MXDFS)/(ML+1) IF(BKUTOO)DDB=DVC*VCC(MJ11,MJ21,ML+2,MM11,MM21,MMD1,DFS,MXDFS) ENDIF IF(BVC.OR.(MJ22.LE.MXLL.AND.MJ12.LE.MXLL))THEN DDA=DDA*VCA(MV22,MV12,LP) IF(BKUTOO)DDB=DDB*VCB(MV22,MV12,LP) ELSE DVC=VCC(MJ22,MJ12,ML,0,0,0,DFS,MXDFS) DDA=DDA*DVC*VCC(MJ22,MJ12,ML,MM22,MM12,MMD2,DFS,MXDFS)/(ML+1) IF(BKUTOO)DDB=DDB*DVC X *VCC(MJ22,MJ12,ML+2,MM22,MM12,MMD2,DFS,MXDFS) ENDIF C IF(ABS(DDA)+ABS(DDB).EQ.DZERO)GO TO 10 C IF(BFANO)THEN IFANO=QL(Q1(2,1+KP))-QL(Q1(1,1)) IF(MRL(5).GE.0)IFANO=IFANO+QL(Q1(2,2-KP))-QL(Q1(1,2)) IFANO=IFANO/4 FANO=(-1)**IFANO DDA=DDA*FANO IF(BKUTOO)DDB=DDB*FANO ENDIF C DDA=DDA*DSJ IF(BKUTOO)DDB=DDB*DSJ ENDIF C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C 87 IF(BPLANT)IPLANT=MRL(5)/2+ X((((MRL(4)*MXORB+MRL(3))*MXORB+MRL(2))*MXORB)+MRL(1))*100 C c if(qn(mrl(1)).lt.80)go to 84 !test - exclude "core" c DO I=IRLS1,IRLS IF(.NOT.BPLANT)THEN DO K=5,1,-1 IF(MRL(K).NE.QRLS(K,I))GO TO 63 ENDDO ELSE IF(IPLANT.NE.JPLANT(I))GO TO 63 ENDIF IF(EQTMS)THEN LP=-I K=JORIG(I) ELSE LP=I K=IORIG(I) ENDIF IF(K.GT.0)THEN DRKS(K)=DDA+DRKS(K) IF(BKUTOO)THEN DEKS(K)=DDB+DEKS(K) IF(BFALLS(K).NEQV.BFALL)THEN WRITE(6,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.' WRITE(0,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.' NF=-1 GO TO 999 ENDIF ENDIF GO TO 84 ENDIF C 83 CONTINUE GO TO 82 63 ENDDO C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C LP=IRLS+1 IRLS=LP IF(LP.GT.MXRLS) GO TO 999 C DO K=1,5 QRLS(K,LP)=MRL(K) ENDDO C IF(BPLANT)JPLANT(LP)=IPLANT IF(EQTMS)LP=-LP C C K=-IRKS 82 IRKS=IRKS+1 IF(IRKS.GT.MXRKS)GO TO 999 C DRKS(IRKS)=DDA IF(BKUTOO)THEN DEKS(IRKS)=DDB BFALLS(IRKS)=BFALL ENDIF C IF(LP.GT.0)THEN IORIG(LP)=IRKS JORIG(LP)=0 ELSE JORIG(-LP)=IRKS ENDIF C NRKS(IRKS)=LP NSTJ(IRKS)=J NSTJD(IRKS)=JD 84 CONTINUE C c write(6,998) j,jd,nk,lp,kp, mrl,dda c 998 format(5i5,4x,5i3,2f12.5) C IF(ML.LT.0)GO TO 68 10 ML=ML+4 IF(ML.LE.MU)GO TO 78 !NEXT LAMBDA C 76 KP=KP+1+IXCH IF(KP.EQ.1)GO TO 77 !EXCHANGE C 65 IF(NK-1.LT.0)GO TO 69 IF(NK-1.EQ.0)GO TO 68 C 67 IF(J.EQ.JD.AND..NOT.EQTMS)THEN !SO EQCFS=.TRUE. EQTMS=.TRUE. NU=-NW GO TO 75 ENDIF C C 57 CONTINUE !END INNER SLATER-STATE LOOP C 55 CONTINUE !END OUTER SLATER-STATE LOOP C C C ELIMINATE COEFFICIENTS /DRKS/.LT.TYNY AND ARGUMENTS QRLS THAT HAVE C BEEN LISTED BEFORE IN THE REFERENCE LIST C C 89 IF(KF.GT.0)GO TO 98 IF(IRKS.LT.IRKS00)GO TO 90 C K=IRKS00-1 KP=0 DO I=IRLS1,IRLS IORIG(I)=0 ENDDO C DO 91 I=IRKS00,IRKS C JD0=NRKS(I) JD=IABS(JD0) DD=ABS(DRKS(I)) IF(BKUTOO)DD=DD+ABS(DEKS(I)) IF(ABS(DD).LT.TYNY)THEN IF(IORIG(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QRLS AS MAY OCCUR LATER GO TO 94 ENDIF C K=K+1 DRKS(K)=DRKS(I) IF(BKUTOO)THEN DEKS(K)=DEKS(I) BFALLS(K)=BFALLS(I) ENDIF NSTJ(K)=NSTJ(I) NSTJD(K)=NSTJD(I) C 94 IF(JD.LE.IRLS00)THEN IF(IRLS.LE.MXRLS)THEN !SHOULD NOT GET HERE WRITE(6,*)'FLGL1: INFORM NRB OF STOP HERE' WRITE(0,*)'FLGL1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 ELSE !GRACEFUL EXIT TO DIMENSION STOP LP=JD GO TO 92 ENDIF ENDIF C IF(IORIG(JD).EQ.0)THEN LP=JD-KP DO L=1,IRLS00 DO J=1,5 IF(QRLS(J,JD).NE.QRLS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG(JD) GO TO 92 ENDIF C IORIG(JD)=LP DO J=1,5 QRLS(J,LP)=QRLS(J,JD) ENDDO C 92 IF(JD0.NE.0)THEN NRKS(K)=LP IF(JD0.LT.0)NRKS(K)=-NRKS(K) ENDIF C 91 CONTINUE C IRLS=IRLS-KP IRKS=K C 98 CONTINUE NADS(NCF)=IRKS C IF(NF.EQ.0)THEN NADS(-1)=0 NF=NE KF1=1 KG1=1 GO TO 100 ENDIF C C 90 CONTINUE !END OF INNER CF LOOP C 99 CONTINUE !END OF OUTER CF LOOP C C 999 RETURN C END C C ******************* C SUBROUTINE FLGL2(DC,mam,nam,KK) C C----------------------------------------------------------------------- C C SR.FLGL2 EXPANDS THE ENERGY MATRIX ELEMENT C IN TERMS OF TWO SORTS OF RADIAL INTEGRALS, EQ.1.6,7,8 IN E&N, C AND CALCULATES THE COEFFICIENTS AS DESCRIBED IN SECT.3.2 OF E&N C C INPUT: KF,KG ARE INDEXES OF CONFIGURATION C,C' C DRKS, NRKS CONTAIN AND INDEX SLATER STATE INTERACTIONS BETWEEN C SLATER STATES J AND JD ASSOCIATED WITH C AND C' - NRB; C DC(J+ND2)=VCC OF J'TH SLATERSTATE TO TERM ND2 C DC(JD+NDP2) JD C C OUTPUT: COEFFICIENTS DRL(J) AND ARGUMENT-ADRESSES L=NRK(J) STORED C SEQUENTIALLY FROM IRK0 ONWARDS; ARGUMENTS QRL(1...5,L)=A,B,C,D,LD C TEMPORARILY LISTED IN NEW SECTION OF REF.-LIST FROM IRL00 ONWARDS C AT THE END ALL QRL THAT HAD PREVIOUSLY BEEN LISTED ARE CANCELLED. C C----------------------------------------------------------------------- C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL !F95 USE COMMON_DXRLS, ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-8) PARAMETER (TTYNY=TYNY/1.D3) C CF77 INTEGER*8 NRK !F77 C LOGICAL EQCFS,EQTMS,BKUTOO,BFAST CF77 X ,BFALLS,BFALL !F77 C REAL*8 DC DIMENSION DC(0:*),mam(*),nam(*) C COMMON /BASIC/NF,KF,KG,JGAP(4),ND1,NDP1,ND2,NDP2,NGAP CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /NXRL/IRK,IRK0,IOS,IOS0 CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO C C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C BKUTOO=KUTOO.NE.0 DDB=DZERO C IRL00=IRL !EVTL IF(AM(1)) IRL00=0 C DO J=1,IRLS JORIG(J)=0 ENDDO C EQCFS=KG.EQ.KF EQTMS=NDP1.EQ.ND1 C c write(6,*)'kf=',kf,' kg=',kg C C BEGIN MAIN LOOP 57 OVER SLATER INTERACTIONS C c m0=0 c t0=dzero c md0=0 c td0=dzero K0=NADS(KK-1)+1 C DO 57 KS=K0,NADS(KK) C J=NSTJ(KS) JD=NSTJD(KS) C II=NRKS(KS) IF(J.EQ.JD)THEN IF(EQTMS.AND.II.GT.0)GO TO 57 IF(.NOT.EQTMS.AND.II.LT.0)GO TO 57 II=IABS(II) ENDIF C IF(BFAST)THEN DDH=DC(J+ND2)*DC(JD+NDP2) IF(EQCFS.AND.JD.NE.J)DDH=DC(J+NDP2)*DC(JD+ND2)+DDH ELSE c write(6,*)m,md m=mam(j) md=nam(jd) if(m.gt.0.and.md.gt.0)then !m*md can over flow I*4 c if(m.ne.m0)then c t0=dc(m) c m0=m c endif c if(md.ne.md0)then c td0=dc(md) c md0=md c endif c DDH=t0*td0 DDH=DC(m)*DC(md) else ddh=dzero endif IF(EQCFS.AND.JD.NE.J)then md=mam(jd) m=nam(j) if(m.gt.0.and.md.gt.0)then !m*md can over flow I*4 DDH=DC(md)*DC(m)+DDH endif endif ENDIF C DDA=DDH*DRKS(KS) IF(BKUTOO)DDB=DDH*DEKS(KS) IF(ABS(DDA)+ABS(DDB).LT.TTYNY)GO TO 57 c write(6,*)ks,j,jd,ddh,drks(ks),dda C LP=JORIG(II) IF(LP.GT.0)THEN K=IORIG(LP) DRK(K)=DRK(K)+DDA c write(6,*)lp,k,drk(k) IF(BKUTOO)THEN DEK(K)=DDB+DEK(K) IF(BFALL(K).NEQV.BFALLS(KS))THEN WRITE(6,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.' WRITE(0,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.' NF=-1 GO TO 90 ENDIF ENDIF ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C LP=IRL+1 IRL=LP IRK=IRK+1 IF(IRK.GT.MAXRK)GO TO 90 IF(LP.GT.MAXRL)GO TO 90 DO K=1,5 QRL(K,LP)=QRLS(K,II) ENDDO DRK(IRK)=DDA IF(BKUTOO)THEN DEK(IRK)=DDB BFALL(IRK)=BFALLS(KS) ENDIF JORIG(II)=LP IORIG(LP)=IRK NRK(IRK)=LP c write(6,*)-lp,irk,drk(irk) ENDIF C 57 CONTINUE C C ELIMINATE COEFFICIENTS /DRK/.LT.TYNY AND ARGUMENTS QRL THAT HAVE C BEEN LISTED BEFORE IN THE REFERENCE LIST C c IF(IRK.LT.IRK0)GO TO 90 K=IRK0-1 KP=0 C DO I=IRK0,IRK C JD=INT(NRK(I)) DD=ABS(DRK(I)) IF(BKUTOO)DD=DD+ABS(DEK(I)) C IF(ABS(DD).LT.TYNY)THEN IF(JD.GT.IRL00)KP=KP+1 GO TO 91 ENDIF C K=K+1 DRK(K)=DRK(I) IF(BKUTOO)THEN DEK(K)=DEK(I) BFALL(K)=BFALL(I) ENDIF C LP=JD IF(JD.GT.IRL00)THEN LP=JD-KP DO L=1,IRL00 DO J=1,5 IF(QRL(J,JD).NE.QRL(J,L))GO TO 95 ENDDO KP=KP+1 LP=L GO TO 92 95 ENDDO DO J=1,5 QRL(J,LP)=QRL(J,JD) ENDDO ENDIF C 92 NRK(K)=LP C 91 ENDDO C IRL=IRL-KP IRK=K C 90 RETURN C END C C ******************* C SUBROUTINE FLGLX0(KK,QLMC,MAXEL) C C----------------------------------------------------------------------- C C SR.FLGLX0 CHECKS WHICH SLATER-STATES OF TWO CFS DIFFER BY ZERO OR ONE C PAIR, AND SETS POINTERS TO THEM FOR LATER USE BY FLGLX1. C C----------------------------------------------------------------------- C USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C LOGICAL EQCFS,BTEMP(MXEL0,MXEL0) C DIMENSION QLMC(MAXEL,*),NEN(2,2) X,JTEMP(MAXGR),KTEMP(MXEL0*MXEL0+1),LTEMP(MXEL0*MXEL0) X,MTEMP(MXEL0),NTEMP(MAXGR) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP(5) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) !F95 COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 C NF1=NF+1 EQCFS=KG.EQ.KF C DO L=1,NF J=QCG(L,KG) JTEMP(L)=IEQ(J) K=QCG(L,KF) NTEMP(L)=IEQ(K) ENDDO C K=0 DO I=NF,1,-1 DO L=NF,1,-1 BTEMP(L,I)=JTEMP(L).EQ.NTEMP(I) IF(BTEMP(L,I))THEN K=K+1 LTEMP(K)=L KTEMP(K)=I ENDIF ENDDO ENDDO KTEMP(K+1)=0 KMAX=K C C INITIALIZE GROUP RANGES C MXD02=QMCL/2 !F95 C MG2=MXD02 MG1=-MXD02 C MG2P=MXD02 MG1P=-MXD02 C C LOOP OVER INITIAL ML GROUPS OF CONFIG KF C DO MG=MG2,MG1,-1 C M1=MPOINT(MG+1,KF)+1 !SLATER-STATE RANGE M2=MPOINT(MG,KF) C C LOOP OVER FINAL MLP GROUPS OF CONFIG KG C IF(EQCFS)MG1P=MG C DO MGP=MG2P,MG1P,-1 C M1P=MPOINT(MGP+1,KG)+1 !SLATER-STATE RANGE M2P=MPOINT(MGP,KG) C C LOOP OVER INITIAL SLATER STATES OF ML C DO M=M1,M2 C J=M C C LOOP OVER FINAL SLATER STATES OF MLP C IF(EQCFS.AND.MG.EQ.MGP)M2P=M C DO MP=M1P,M2P C JD=MP C NEN2=0 IF(JD.EQ.J)GO TO 75 !SO EQCFS=.TRUE. C NK=1 !FOR CONTINUUM PAIR DO K=1,2 !INITIALIZE NK=1 CONT-CONT NEN(K,1)=NF1 ENDDO C C DETERMINE THE SECOND PAIR OF INDIVIDUAL SETS IN WHICH SLATER C STATE JD DIFFERS FROM J, AND THE PHASE FACTOR THAT RESULTS FROM C THE REMAINING NF-2 SETS: C NEN(1,2)=0 MU=0 DO I=1,NF MTEMP(I)=0 ENDDO C C CASES WHERE ORBITAL NL'S MATCH C I0=0 DO K=1,KMAX I=KTEMP(K) L=LTEMP(K) IF(I.NE.I0)THEN !NEED TO CHECK L STILL IF(QLMC(L,JD).EQ.QLMC(I,J))THEN MTEMP(I)=L I0=I ELSEIF(KTEMP(K+1).NE.I)THEN !HAVE MOVED TO A NEW I NK=NK+1 IF(NK.GT.2)GO TO 57 NEN(1,NK)=I !NEN(1,2) MU=I+MU ENDIF ENDIF ENDDO C C CASES WHERE ORBITALS DO NOT MATCH, SEE IF A DIFFERENCE C HAS ALREADY BEEN FLAGGED, IF NOT, DO SO. C DO I=NF,1,-1 IF(MTEMP(I).EQ.0.AND.NEN(1,2).NE.I)THEN DO L=NF,1,-1 IF(.NOT.BTEMP(L,I))THEN NK=NK+1 IF(NK.GT.2)GO TO 57 NEN(1,NK)=I !NEN(1,2) MU=I+MU GO TO 580 ENDIF ENDDO ENDIF 580 ENDDO C K=1 !0->1 SINCE CONT-CONT IS ONE DO L=NF,1,-1 DO I=NF,1,-1 IF(MTEMP(I).EQ.L)GO TO 60 ENDDO K=K+1 NEN(2,K)=L !NEN(2,2) MU=L+MU IF(K.EQ.NK)GO TO 74 60 ENDDO C 74 IPHASE=(1-2*MOD(MU,2)) !*IPHASE C C NK.EQ.2 HERE C IF(NK.NE.2)THEN WRITE(6,*)'FLGLX0: ERROR, SHOULD NOT BE HERE',KF,KG,J,JD STOP'FLGLX0: ERROR, SHOULD NOT BE HERE' ENDIF C NEN2=NF1*NEN(1,2)+NEN(2,2) NEN2=NEN2*IPHASE C C FLAG THIS PAIR AS INTERACTING (TBD DON'T BOTHER TO STORE J=JD CASE?) C 75 KINT=KINT+1 IF(KINT.LE.MXSTX)THEN !COULD PACK FURTHER... KINTI(KINT)=J KINTF(KINT)=JD KEN2(KINT)=NEN2 C WRITE(6,*)KF,J,' ** ',KG,JD ENDIF C 57 CONTINUE C ENDDO !END FINAL ML SLATER STATE LOOP C ENDDO !END INITIAL ML SLATER STATE LOOP C KPTCFM(MGP,MG,KK)=KINT IF(EQCFS)KPTCFM(MG,MGP,KK)=KINT C ENDDO !END FINAL MLP GROUP LOOP FOR KG C ENDDO !END INITIAL ML GROUP LOOP FOR KF C C RETURN C END C C ******************* C SUBROUTINE FLGLX1(QLMC,NAM,DFS,MAXEL) C C----------------------------------------------------------------------- C C SR.FLGLX1 CALCULATES THE SLATER-STATE ELECTROSTATIC AND, OPTIONALLY, C ORBIT-ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE PAIR BEING C CONTINUUM. C C----------------------------------------------------------------------- C USE COMMON_DXRLS, ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C PARAMETER (MXD27=MAXCF*MAXCF) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (TYNY=1.D-6) C LOGICAL BVC,EQCFS,EQTMS,EQGRP,SKP,BFANO,BKUTOO,BDLBD X ,BFALL,BPLANT,LX,EQUALM,brev CF77 X ,BFALLS !F77 C DIMENSION QLMC(MAXEL,*),NAM(*),DFS(*) X ,Q1(2,2),Q2(2,2),Q3(2,2),Q4(2,2) X ,NEN(2,2),NEJ(2),NEK(2),MRL(5) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,ND1,NDP1,LLCH(2),MAXLX COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /CMDVC/DVC12O,LX,ICLRR,EQUALM COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /XSSADR/IRKS0,IRLS0 COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ X ,LVMIN,LVMAX COMMON /NRBFAN/BFANO COMMON /NRBLAM/MAXLAM,MXLAMX c COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 C EQUIVALENCE (KF,NEK(1)),(KG,NEK(2)) !,(NEN(1,1),N1),(NEN(2,1),N2) X ,(Q2(1,1),MJ11),(Q2(1,2),MJ12),(MRL(5),ML) C C MVC(M,MA)=((M+2)*M/2+MA)/2+1 C MPOSC=MXORB+(LCONDWJ-1)/2-(LCONDW-1)/2 !BUFFER SPACE MXORBC=MPOSC+LCONDW BPLANT=MXORBC.LT.67 MPOSC=MPOSC+(LCONDW+1)/2 C SKP=MXLL.EQ.-1 BKUTOO=KUTOOX.NE.0 C IRLS1=IRLS0+1 IF(ICLRR.LT.0)GO TO 400 C brev=kf.lt.kg EQCFS=KG.EQ.KF IF(.NOT.EQCFS.AND.MAXLAM.LT.0)GO TO 999 !SINGLE CONFIG EQGRP=ND1.EQ.NDP1 !WITHIN A GROUP C NF1=NF+1 IDIR=0 IF(QSI(ND1).NE.QSI(NDP1))IDIR=1 !NO DIRECT IXCH=0 IF(MTL.GT.2*MAXLX)IXCH=1 !NO EXCHANGE IF(IDIR+IXCH.EQ.2)GO TO 999 !NULL ct idir=1 ct ixch=1 C DDA=DONE DDB=DZERO DVC12=DVC12O C C BEGIN MAIN SLATER-STATE INTERACTION LOOP (57) C DO 57 J1=JA,JB C kk=nam(j1) if(brev.or.kk.lt.0)then kk=iabs(kk) i1=2 i2=1 else i1=1 i2=2 endif nej(i1)=kinti(kk) nej(i2)=kintf(kk) j=nej(1) jd=nej(2) c c write(6,*)kf,j,' ',kg,jd c IF(EQUALM)THEN IF(JD.GT.J)GO TO 57 IF(JD.LT.J)THEN DVC12=2*DVC12O ELSE DVC12=DVC12O ENDIF ENDIF C DO I=IRLS1,IRLS IORIG(I)=0 JORIG(I)=0 ENDDO C DDH=DONE EQTMS=.FALSE. C NK=1 !0->1 SINCE CONT-CONT IS ONE DO K=1,2 !INITIALIZE NK=1 CONT-CONT NEN(K,1)=NF1 ENDDO C NU=0 IF(JD.EQ.J)GO TO 68 !SO EQCFS=.TRUE. C C NK.EQ.2 HERE C nk=2 nen2=ken2(kk) c if(nen2.eq.0)stop 'nen2 error' if(nen2.lt.0)then ddh=-ddh nen2=-nen2 endif nen(i1,2)=nen2/nf1 c if(nen(i1,2).eq.0)stop 'nen(1,2) error' nen(i2,2)=nen2-nen(i1,2)*nf1 c if(nen(i2,2).eq.0)stop 'nen(2,2) error' c go to 72 C C NOW NK=1 (CASE J.EQ.JD ONLY NOW) C 68 NU=NU+1 IF(NU.GT.NF)GO TO 67 NEN(1,2)=NU C 72 DO L=1,2 !=1 FOR SLATER STATES J (OF CONFIG KF),=2 FOR JD (OF KG) I=L DO K=1,2 !=1 FOR FOR FIRST PAIR OF ELECTRON STATES,=2 FOR SECOND IF(NK.LT.K)I=1 KP=NEN(I,K) IF(KP.LE.0)THEN KP=KP+NW MU=NNL(KP,2) !PACKED LP=NNL(KP,1) Q1(L,K)=LP Q2(L,K)=QL(LP) C Q3(L,K)=NNL(KP,2) !UNPACKED C Q4(L,K)=NNL(KP,3) !UNPACKED ELSE LP=NEJ(I) MU=QLMC(KP,LP) LP=NEK(I) LP=QCG(KP,LP) IF(LP.GT.MXORB)THEN !CONTINUUM Q2(L,K)=LLCH(L) Q1(L,K)=(LLCH(L)-MTL)/2+MPOSC ELSE Q2(L,K)=QL(LP) Q1(L,K)=LP ENDIF ENDIF !PACKED ML=Q2(L,K) ML=((ML+MU)/2)*2-ML Q3(L,K)=ML Q4(L,K)=(MU-ML)*2-1 C ENDIF !UNPACKED ENDDO ENDDO C C DIRECT C KP=0 C C EQU MJ11=Q2(1,1) C EQU MJ12=Q2(1,2) MM11=-Q3(1,1) MM12=-Q3(1,2) MV11=MVC(MJ11,MM11) MV12=MVC(MJ12,MM12) C IF(IDIR.EQ.1)GO TO 76 !NO DIRECT C MXLAM=IABS(MXLAMX) !RESTRICT DIRECT LAMBDA C C EXCHANGE RE-ENTRY POINT C 77 IF(.NOT.SKP.AND.Q4(2,1+KP).NE.Q4(1,1))GO TO 76 C MJ21=Q2(2,KP+1) MJ22=Q2(2,2-KP) C C MU=MAX LAM MU=MIN0(MJ11+MJ21,MJ12+MJ22,2*MXLAM) C C ML=MIN LAM ML=MAX0(IABS(MJ11-MJ21),IABS(MJ12-MJ22)) C IF(ML.GT.MU)GO TO 76 C IF(.NOT.SKP)THEN MM21=Q3(2,KP+1) MMD1=MM21+MM11 MM22=Q3(2,2-KP) MMD2=MM12+MM22 C C INCREASE MIN LAM BECAUSE OF ML1-ML2 K=MAX0(IABS(MMD1),IABS(MMD2)) C C ORBIT-ORBIT LAM+1, SO "LESS RESTRICTIVE" IF(BKUTOO)K=K-2 IF(K.GT.ML)ML=((K+2-ML)/4)*4+ML IF(ML.GT.MU)GO TO 76 DSJ=SQRT( DBLE((MJ11+1)*(MJ12+1)*(MJ21+1)*(MJ22+1)))* X DBLE((1-MOD(IABS(MM22-MM11),4))*(1-2*KP))*DDH*DVC12 MV21=MVC(MJ21,MM21) MV22=MVC(MJ22,MM22) ENDIF C C REORDER A,B,C,D IN AS MUCH FALLING ORDER AS SYMMETRY ALLOWS FOR C L=0 K=0 IF(Q1(2,2-KP).GT.Q1(1,2))K=2 I=0 IF(Q1(2,1+KP).GT.Q1(1,1))I=2 BFALL=BKUTOO.AND.I+K.EQ.2 C 62 MRL(1+I+L)=Q1(1,1) MRL(3-I+L)=Q1(2,1+KP) MRL(2+K-L)=Q1(1,2) MRL(4-K-L)=Q1(2,2-KP) L=1 IF(MRL(2).GT.MRL(1))GO TO 62 if(mrl(2).eq.mrl(1).and.mrl(4).gt.mrl(3))go to 62!cont in pos nk=1 C C LAMBDA RE-ENTRY POINT C 78 IF(.NOT.SKP)THEN LP=ML/4+1 IF(BVC.OR.(MJ11.LE.MXLL.AND.MJ21.LE.MXLL))THEN DDA=VCA(MV11,MV21,LP) IF(BKUTOO)DDB=VCB(MV11,MV21,LP) ELSE DVC=VCC(MJ11,MJ21,ML,0,0,0,DFS,MXDFS) DDA=DVC*VCC(MJ11,MJ21,ML,MM11,MM21,MMD1,DFS,MXDFS)/(ML+1) IF(BKUTOO)DDB=DVC*VCC(MJ11,MJ21,ML+2,MM11,MM21,MMD1,DFS,MXDFS) ENDIF IF(BVC.OR.(MJ22.LE.MXLL.AND.MJ12.LE.MXLL))THEN DDA=DDA*VCA(MV22,MV12,LP) IF(BKUTOO)DDB=DDB*VCB(MV22,MV12,LP) ELSE DVC=VCC(MJ22,MJ12,ML,0,0,0,DFS,MXDFS) DDA=DDA*DVC*VCC(MJ22,MJ12,ML,MM22,MM12,MMD2,DFS,MXDFS)/(ML+1) IF(BKUTOO)DDB=DDB*DVC X *VCC(MJ22,MJ12,ML+2,MM22,MM12,MMD2,DFS,MXDFS) ENDIF C IF(ABS(DDA)+ABS(DDB).EQ.DZERO)GO TO 10 C IF(BFANO)THEN IFANO=QL(Q1(2,1+KP))-QL(Q1(1,1)) IF(MRL(5).GE.0)IFANO=IFANO+QL(Q1(2,2-KP))-QL(Q1(1,2)) IFANO=IFANO/4 FANO=(-1)**IFANO DDA=DDA*FANO IF(BKUTOO)DDB=DDB*FANO ENDIF C DDA=DDA*DSJ IF(BKUTOO)DDB=DDB*DSJ ENDIF C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C IF(BPLANT)IPLANT=MRL(5)/2+ X((((MRL(4)*MXORBC+MRL(3))*MXORBC+MRL(2))*MXORBC)+MRL(1))*100 C DO I=IRLS1,IRLS IF(.NOT.BPLANT)THEN DO K=5,1,-1 IF(MRL(K).NE.QRLS(K,I))GO TO 63 ENDDO ELSE IF(IPLANT.NE.JPLANT(I))GO TO 63 ENDIF IF(EQTMS)THEN LP=-I K=JORIG(I) ELSE LP=I K=IORIG(I) ENDIF IF(K.GT.0)THEN DRKS(K)=DDA+DRKS(K) IF(BKUTOO)THEN DEKS(K)=DDB+DEKS(K) IF(BFALLS(K).NEQV.BFALL)THEN WRITE(6,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.' WRITE(0,*)'FLGL1: PROBLEM WITH ORBIT-ORBIT ALG.' NF=-1 GO TO 999 ENDIF ENDIF GO TO 84 ENDIF GO TO 82 63 ENDDO C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C LP=IRLS+1 IRLS=LP IF(LP.GT.MXRLS) GO TO 999 C DO K=1,5 QRLS(K,LP)=MRL(K) ENDDO C IF(BPLANT)JPLANT(LP)=IPLANT C IF(EQTMS)LP=-LP C 82 IRKS=IRKS+1 IF(IRKS.GT.MXRKS)GO TO 999 C DRKS(IRKS)=DDA IF(BKUTOO)THEN DEKS(IRKS)=DDB BFALLS(IRKS)=BFALL ENDIF C IF(LP.GT.0)THEN IORIG(LP)=IRKS JORIG(LP)=0 ELSE JORIG(-LP)=IRKS ENDIF C NRKS(IRKS)=LP NSTJ(IRKS)=J NSTJD(IRKS)=JD 84 CONTINUE C c write(6,998) j,jd,lp,kp, mrl,dda,irks,kf,kg c 998 format(4i5,4x,5i3,f12.5,i4,2i6) C 10 ML=ML+4 IF(ML.LE.MU)GO TO 78 !NEXT LAMBDA C 76 KP=KP+1+IXCH MXLAM=MXLAMX !RESTRICT EXCHANGE LAMBDA IF(KP.EQ.1)GO TO 77 !EXCHANGE C IF(NK-1.EQ.0)GO TO 68 C 67 IF(J.EQ.JD.AND..NOT.EQTMS)THEN !SO EQCFS=.TRUE. EQTMS=.TRUE. IF(LLCH(1).EQ.LLCH(2).AND.EQGRP)THEN NU=-NW ELSE NU=0 ENDIF GO TO 68 ENDIF C C 57 CONTINUE !END SLATER-STATE INTERACTION LOOP C C C IF THE COEFFICIENTS OF THE MATRIX ELEMENT HAVE NOT BEEN COMPLETELY C CALCULATED, RETURN - WILL CALL AGAIN, FOR DIFFERENT (MS,ML). C IF(LX)RETURN C C C ELIMINATE COEFFICIENTS /DRKS/.LT.TYNY AND ARGUMENTS QRLS THAT HAVE C BEEN LISTED BEFORE IN THE REFERENCE LIST C 400 ICLRR=0 IF(IRKS.LT.IRKS0)GO TO 999 C K=IRKS0-1 KP=0 DO I=IRLS1,IRLS IORIG(I)=0 ENDDO C DO 91 I=IRKS0,IRKS C JD0=NRKS(I) JD=IABS(JD0) DD=ABS(DRKS(I)) IF(BKUTOO)DD=DD+ABS(DEKS(I)) IF(ABS(DD).LT.TYNY)THEN IF(IORIG(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QRLS AS MAY OCCUR LATER GO TO 94 ENDIF C K=K+1 DRKS(K)=DRKS(I) IF(BKUTOO)THEN DEKS(K)=DEKS(I) BFALLS(K)=BFALLS(I) ENDIF NSTJ(K)=NSTJ(I) NSTJD(K)=NSTJD(I) C 94 IF(JD.LE.IRLS0)THEN IF(IRLS.LE.MXRLS)THEN !SHOULD NOT GET HERE WRITE(6,*)'FLGL1: INFORM NRB OF STOP HERE' WRITE(0,*)'FLGL1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 ELSE !GRACEFUL EXIT TO DIMENSION STOP LP=JD GO TO 92 ENDIF ENDIF C IF(IORIG(JD).EQ.0)THEN LP=JD-KP DO L=1,IRLS0 DO J=1,5 IF(QRLS(J,JD).NE.QRLS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG(JD) GO TO 92 ENDIF C IORIG(JD)=LP DO J=1,5 QRLS(J,LP)=QRLS(J,JD) ENDDO C 92 IF(JD0.NE.0)THEN NRKS(K)=LP IF(JD0.LT.0)NRKS(K)=-NRKS(K) ENDIF C 91 CONTINUE C IRLS=IRLS-KP IRKS=K C C 999 RETURN C END C C ******************* C SUBROUTINE FLGLX2(DC,iam,ibm,KK) C C----------------------------------------------------------------------- C C SR.FLGLX2 CALCULATES THE TERM-RESOLVED ELECTROSTATIC AND, OPTIONALLY, C ORBIT-ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE PAIR BEING C CONTINUUM. C C----------------------------------------------------------------------- C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,IRL !F95 USE COMMON_DXRLS, ONLY: DRKS,DEKS,QRLS,NRKS,BFALLS,IRLS,IRKS !F95 USE COMMON_NSTS, ONLY: NADS,NSTJ,NSTJD,IORIG,JORIG,JPLANT !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-8) PARAMETER (TTYNY=TYNY/1.D3) C CF77 INTEGER*8 NRK !F77 C LOGICAL EQTMS,BKUTOO,BFAST CF77 X ,BFALL,BFALLS !F77 C REAL*8 DC DIMENSION DC(0:*),iam(*),ibm(*) C COMMON /BASIC/NF,KF,KG,ND1,ND2,NDP1,NDP2,NGAP(5) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /NXRL/IRK,IRK0,IOS,IOS0 CF77 COMMON /DXRLS/DRKS(MXRKS),DEKS(MXROS),QRLS(5,MXRLS) !F77 CF77 X ,NRKS(MXRKS),BFALLS(MXROS),IRKS,IRLS !F77 CF77 COMMON /NSTS/NADS(-1:MXD27),NSTJ(MXRKS),NSTJD(MXRKS) !F77 CF77 X ,IORIG(MXRLS),JORIG(MXRLS),JPLANT(MXRLS) !F77 CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MTS,MTSP,MTL,MTLP,MTP,LCONDWJ,MTJ X ,LVMIN,LVMAX C C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C BKUTOO=KUTOOX.NE.0 DDB=DZERO C IRK0=IRK+1 IRL00=IRL C DO J=1,IRLS JORIG(J)=0 ENDDO C EQTMS=NDP1.EQ.ND1 C C C BEGIN MAIN LOOP 57 OVER SLATER INTERACTIONS C K0=NADS(KK-1)+1 C DO 57 KS=K0,NADS(KK) C J=NSTJ(KS) m=iam(j) if(m.eq.0)go to 57 c JD=NSTJD(KS) C II=NRKS(KS) IF(J.EQ.JD)THEN IF(EQTMS.AND.II.GT.0)GO TO 57 IF(.NOT.EQTMS.AND.II.LT.0)GO TO 57 II=IABS(II) ENDIF C IF(BFAST)THEN DDH=DC(m)*DC(JD+NDP2) !DC(J+ND2) ELSE md=ibm(jd) if(md.eq.0)go to 57 DDH=DC(m)*DC(md) ENDIF C DDA=DDH*DRKS(KS) c write(6,*)ks,j,jd,ddh,drks(ks),dda IF(BKUTOO)DDB=DDH*DEKS(KS) IF(ABS(DDA)+ABS(DDB).LT.TTYNY)GO TO 57 C LP=JORIG(II) IF(LP.GT.0)THEN K=IORIG(LP) DRK(K)=DRK(K)+DDA c write(6,*)lp,k,drk(k) IF(BKUTOO)THEN DEK(K)=DDB+DEK(K) IF(BFALL(K).NEQV.BFALLS(KS))THEN WRITE(6,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.' WRITE(0,*)'FLGL2: PROBLEM WITH ORBIT-ORBIT ALG.' NF=-1 GO TO 90 ENDIF ENDIF ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C LP=IRL+1 IRL=LP IRK=IRK+1 IF(IRK.GT.MAXRK)GO TO 90 IF(LP.GT.MAXRL)GO TO 90 C DO K=1,5 QRL(K,LP)=QRLS(K,II) ENDDO if(qrl(2,lp).gt.mxorb)qrl(5,lp)=qrl(5,lp)-mtl !exchange C DRK(IRK)=DDA IF(BKUTOO)THEN DEK(IRK)=DDB BFALL(IRK)=BFALLS(KS) ENDIF JORIG(II)=LP IORIG(LP)=IRK NRK(IRK)=LP c write(6,*)-lp,irk,drk(irk) ENDIF C 57 CONTINUE C C ELIMINATE COEFFICIENTS /DRK/.LT.TYNY AND ARGUMENTS QRL THAT HAVE C BEEN LISTED BEFORE IN THE REFERENCE LIST C K=IRK0-1 KP=0 C DO I=IRK0,IRK C JD=INT(NRK(I)) DD=ABS(DRK(I)) IF(BKUTOO)DD=DD+ABS(DEK(I)) C IF(ABS(DD).LT.TYNY)THEN IF(JD.GT.IRL00)KP=KP+1 GO TO 91 ENDIF C K=K+1 DRK(K)=DRK(I) IF(BKUTOO)THEN DEK(K)=DEK(I) BFALL(K)=BFALL(I) ENDIF C LP=JD IF(JD.GT.IRL00)THEN LP=JD-KP DO L=1,IRL00 DO J=1,5 IF(QRL(J,JD).NE.QRL(J,L))GO TO 95 ENDDO KP=KP+1 LP=L GO TO 92 95 ENDDO DO J=1,5 QRL(J,LP)=QRL(J,JD) ENDDO ENDIF C 92 NRK(K)=LP C 91 ENDDO C IRL=IRL-KP IRK=K C 90 RETURN END C C ******************* C SUBROUTINE FLGLX3(IFLAG1,IFLAG2,LA1,LA2,L1,L2,MTL,MTLO,NCORX,DFS) C C----------------------------------------------------------------------- C C SR.FLGLX3 CALCULATES THE TERM-RESOLVED ELECTROSTATIC AND, OPTIONALLY, C ORBIT-ORBIT INTERACTION USING SYMMTERY RELATION FOR A PRECEEDING L. C C----------------------------------------------------------------------- C USE COMMON_DXRL, ONLY: DRK,QRL,NRK,NAD !F95 USE COMMON_NRBNF1, ONLY: DEK,BFALL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD16=MAXRK/10) PARAMETER (MXD17=MXRKO/10+1) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (TYNY=1.D-6) C CF77 INTEGER*8 NRK !F77 C LOGICAL BKUTOO CF77 X ,BFALL !F77 C DIMENSION DFS(MXDFS),DRKO(MXD16),DEKO(MXD17) C CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /NXRL/IRK,IRK0,IOS,IOS0 c COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) c X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) CF77 COMMON /NRBNF1/DEK(MXRKO),BFALL(MXRKO) !F77 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO C DATA K1/0/,K2/0/,K1P/0/,K2P/0/,MTLN/0/ C SAVE K00,DRKO,DEKO C C BKUTOO=KUTOOX.NE.0 C LD=MTL-MTLO if(mod(ld,4).ne.0)stop'sr.flglx3: phase error!' !shouldn't happen C C SET OLD FLGL C IF(IFLAG1.EQ.1.OR.IFLAG2.EQ.1)THEN IF(IFLAG1.EQ.1)THEN K1=MAX(K1,K2P) K0=MAX(K1,K1P) ENDIF IF(IFLAG2.EQ.1)THEN K2=MAX(K2,K1P) K0=MAX(K2,K2P) ENDIF C L1O=L1-LD L2O=L2-LD DDO=SQRT(DBLE((L1O+1)*(L2O+1))) C DO K=NAD(NCORX-1)+1,NAD(NCORX) C K0=K0+1 IF(K0.LE.MXD16)THEN J=INT(NRK(K)) MLAM=QRL(5,J) C c write(66,*)'k=',k c write(66,*)l1o,l2o,mlam D3O=VCC(L1O,L2O,MLAM,0,0,0,DFS,MXDFS) c write(66,*)d3o c call flush(66) C IF(ABS(DRK(K)).GT.TYNY)THEN !FOR CASE BKUTOO=.T. c write(66,*)j,la1,l1o,mtlo,l2o,la2,mlam D6O=SJS(LA1,L1O,MTLO,L2O,LA2,MLAM,DFS,MXDFS) c write(66,*)d6o c call flush(66) if(d3o*d6o.eq.dzero)then if(abs(drk(k)).gt.10*tyny)then write(6,*)'sr.flglx3: 3j-/6j-symbol zero' write(6,*)'3j=',d3o write(6,*)j,la1,l1o,mtlo,l2o,la2,mlam write(6,*)'6j=',d6o write(6,*)'k=',k,'drk(k)=',drk(k) c call flush(6) stop'sr.flglx3: 3j-/6j-symbol zero' else drk(k)=dzero d3o=done d6o=done endif endif DRKO(K0)=DRK(K)/(DDO*D3O*D6O) ELSE DRKO(K0)=DZERO ENDIF C IF(BKUTOO)THEN IF(ABS(DEK(K)).GT.TYNY)THEN c write(66,*)j,la1,l1o,mtlo,l2o,la2,mlam+2 D6O=SJS(LA1,L1O,MTLO,L2O,LA2,MLAM+2,DFS,MXDFS) !LAM+1 c write(66,*)d6o c call flush(66) if(d3o*d6o.eq.dzero)then if(abs(dek(k)).gt.10*tyny)then write(6,*)'sr.flglx3: 3j-/6j-symbol zero' stop'sr.flglx3: 3j-/6j-symbol zero' else dek(k)=dzero d3o=done d6o=done endif endif DEKO(K0)=DEK(K)/(DDO*D3O*D6O) ELSE DEKO(K0)=DZERO ENDIF ENDIF ENDIF C ENDDO C IF(IFLAG1.EQ.1)K1P=K0 IF(IFLAG2.EQ.1)K2P=K0 C IF(K0.GT.MXD16)THEN WRITE(6,*)'*** SR.FLGLX3: MAY NEED TO ADJUST MXD16 SETTING' NCORX=0 RETURN ENDIF C ENDIF C C GET NEW FLGL FROM OLD C IF(MTL.GT.MTLN)THEN MTLN=MTL IF(IFLAG1.GT.0)K00=K1 IF(IFLAG2.GT.0)K00=K2 ENDIF C IRK0=IRK+1 IRK=IRK+NAD(NCORX)-NAD(NCORX-1) IF(IRK.GT.MAXRK)RETURN IRK=IRK0-1 C DD=SQRT(DBLE((L1+1)*(L2+1))) C DO K=NAD(NCORX-1)+1,NAD(NCORX) C IRK=IRK+1 C NRK(IRK)=NRK(K) J=INT(NRK(K)) MLAM=QRL(5,J) IF(MLAM.LT.0)STOP 'SR.FLGLX3: LAMBDA ERROR!' C c write(66,*)'k=',k c write(66,*)j,la1,l1,mtl,l2,la2,mlam D6=SJS(LA1,L1,MTL,L2,LA2,MLAM,DFS,MXDFS) c write(66,*)d6 c write(66,*)l1,l2,mlam D3=VCC(L1,L2,MLAM,0,0,0,DFS,MXDFS) c write(66,*)d3 C K00=K00+1 C IF(ABS(DRKO(K00)).GT.TYNY)THEN DDA=DRKO(K00) !DRK(K)/(DDO*D3O*D6O) DRK(IRK)=DD*DDA*D3*D6 ELSE DRK(IRK)=DZERO ENDIF c c write(66,*)k,irk,j,drk(irk) C IF(BKUTOO)THEN IF(ABS(DEKO(K00)).GT.TYNY)THEN D6=SJS(LA1,L1,MTL,L2,LA2,MLAM+2,DFS,MXDFS) !RANK LAM+1 C write(66,*)d6 DDB=DEKO(K00) !DEK(K)/(DDO*D3O*D6O) DEK(IRK)=DD*DDB*D3*D6 BFALL(IRK)=BFALL(K) ELSE DEK(IRK)=DZERO ENDIF ENDIF C ENDDO C RETURN END C C*********************************************************************** C REAL*8 FUNCTION FMON1(EK1,EK2,L) C IMPLICIT REAL*8 (A-H,O-Z) C C----------------------------------------------------------------------- C C FN.FMON1 EVALUATES MONOPOLE INTEGRALS NEEDED FOR DETERMINATION OF THE C DIPOLE ONE - SEE EQUS (A3) & (A4) OF BHT. C NRB: BASED ON ALAN'S ORIGINAL. C C----------------------------------------------------------------------- C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (D64=64.0D0) PARAMETER (D1O64=DONE/D64) PARAMETER (D300=300.D0) PARAMETER (D1PT5=1.5D0) PARAMETER (DPT2=0.2D0) PARAMETER (D1P24=1.0D+24) PARAMETER (D1P50=1.0D+50) PARAMETER (D1M40=1.0D-40) C IF(EK1+EK2.LT.D1M40)THEN FMON1=D1P50 RETURN ENDIF C VMAX=200 X1=SQRT(EK1) X2=SQRT(EK2) X3=X1+X2 X4=X3*X3 X5=X1*X2 X6=X2-X1 X7=DFOUR/X4 PI=ACOS(-DONE) C IF(EK1.LT.EK2)THEN ETA=DONE/X2 ELSE ETA=DONE/X1 ENDIF C G=PI*EXP(-PI*ETA)/DTWO C IF(G.lt.d1m40)THEN !NRB OVERFLOW ZEROES OUT FMON1=DZERO RETURN ENDIF C A1=DONE A2=DONE MG=0 MA1=0 MA2=0 C M=-1 4 M=M+1 EM=M T=EM+EM+DONE G=G*X7/(T*(T+DONE)) EMM=EM*EM A1=A1*(DONE+EMM*EK1) A2=A2*(DONE+EMM*EK2) C 30 IF(G.LT.D1O64)THEN G=D64*G MG=MG-1 GO TO 30 ENDIF C 32 IF(G.GT.D64)THEN G=G/D64 MG=MG+1 GO TO 32 ENDIF C 34 IF(A1.GT.D64)THEN A1=A1/D64 MA1=MA1+1 GO TO 34 ENDIF C 36 IF(A2.GT.D64)THEN A2=D1O64*A2 MA2=MA2+1 GO TO 36 ENDIF C IF(M.LT.L)GO TO 4 C G=G*(T+DONE) C IF(X1.GE.D300)THEN B=PI/X1 A1=D1PT5*A1/(B*(DTHREE-B*(DTHREE-B*(DTWO-B)))) ELSEIF(X1.GT.DPT2)THEN B=-PI/X1 A1=A1/(DONE-EXP(B+B)) ENDIF C IF(X2.GE.D300)THEN B=PI/X2 A2=D1PT5*A2/(B*(DTHREE-B*(DTHREE-B*(DTWO-B)))) ELSEIF(X2.GT.DPT2)THEN B=-PI/X2 A2=A2/(DONE-EXP(B+B)) ENDIF C G=G*SQRT(A1*A2)*DEIGHT**(MG+MG+MA1+MA2) C S0=DONE S1=DZERO U=L V=DZERO W=U+U+DONE T0=DONE T1=DZERO C 14 U=U+DONE V=V+DONE W=W+DONE C IF(V.GT.VMAX)THEN FMON1=DZERO RETURN ENDIF C U0=U*U*X5+DONE U1=U*X6 T=T0*U0-T1*U1 T1=T0*U1+T1*U0 T0=T T=X7/(V*W) T0=T*T0 T1=T*T1 S0=S0+T0 S1=S1+T1 S=S0*S0+S1*S1 T=T0*T0+T1*T1 SM=DONE/S TM=DONE/T C IF(SM*TM.EQ.DZERO)THEN !NRB OVERFLOW ZEROES OUT FMON1=DZERO RETURN ENDIF C IF(S.LT.D1P24*T)GO TO 14 C FMON1=G*SQRT(S) C IV=V C RETURN END C C ******************* C SUBROUTINE FSINT(BPRNT0) C C----------------------------------------------------------------------- C C SR.FSINT CALCULATES THE TWO-BODY FINE-STRUCTURE INTEGRALS (N & V) C FOR HAMILTONIAN. C C THE FOUR ELECTRON-ARGUMENTS (1,2,3.. FOR 1S,2S,2P..) HAVE BEEN C STORED IN QSS(I,L),I=1,4, AND 2*LAMBDA IN QRSS(5,L). C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: QSS !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (C4=DFSC**2/DFOUR) C CF77 INTEGER*8 MSS !F77 C LOGICAL BINT,BJUMP,BJUMP2,BRAD,BREL,BJUMPR,BMVD,BREL2 X,BPRNT0,BSTO,BLAG,BBC2 C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 COMMON /EX/DRLP1(MXSOI),DNL(MAXMI) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBFSI/DNLI(MXENG,MXFSS),NLI(MAXMI) COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C C IF(NL.LT.NL000)NL=NL+1 NN=NL000 C IF(BPRNT0)WRITE(6,610) C BREL2=IABS(IREL).EQ.2 C IF(BJUMP)THEN !JUST RE-COMPUTE OR RE-SCALE RYDBERG C DO J=1,NN M=0 TM=DONE DO I=1,4 N=QSS(I,J) M=M+IVAL(N) TM=TM*FACT(N) ENDDO KK=NLI(J) IF(M.GT.0)THEN IF(BJUMP2)THEN DNL(J)=DNL(J)*TM !RE-SCALE IF(KK.GT.0)THEN DO I=1,MENG DNLI(I,KK)=DNLI(I,KK)*TM ENDDO ENDIF ELSE DNL(J)=DZERO !ZERO-OUT FOR RE-COMPUTE ENDIF ENDIF C IF(BJUMP2.AND.BPRNT0)THEN IF(KK.GT.0)WRITE(6,140)J,(QSS(I,J),I=1,5) X ,(DNLI(IC,KK),IC=1,MENG) IF(KK.EQ.0)WRITE(6,140)J,(QSS(I,J),I=1,5),DNL(J) ENDIF C ENDDO C IF(BJUMP2)GO TO 500 !RETURN C ELSE !INITIALIZE AND COMPUTE *ALL* C DO J=1,NN DNL(J)=DZERO ENDDO C ENDIF C C OUTER LOOP TO DETERMINE FINE-STRUCTURE INETGRALS C DO J=1,NN !START MAGNETIC TWO-BODY OUTER LOOP C !OVER INNER ORBITAL PAIR (YLAMK) IF(DNL(J).NE.DZERO)GO TO 127 C M=QSS(5,J) MM=(M+2)/100 BINT=MM.EQ.2 !FALSE V; TRUE N IF(.NOT.BINT.AND.MM.NE.1)THEN WRITE(6,*)'FSINT ERROR: ITYPE=',MM WRITE(6,*)'J',J,' QSS(J):',(QSS(M,J),M=1,5) WRITE(0,*)'FSINT ITYPE ERROR' NF=-1 GO TO 500 !RETURN ENDIF C M1=(M-100*MM)/2 IF(M1.GT.MAXLAM)GO TO 127 C MJ=M-197 IF(MJ.GT.0)MJ0=3 !N IF(MJ.LT.0)MJ0=-3 !V K=0 !V IF(BINT)K=1 !N C N1=QSS(K+1,J) N2=QSS(K+3,J) IF(MODE.LT.3)THEN IMT=0 IF(IYY(N1).GT.0)IMT=IMT+1 IF(IYY(N2).GT.0)IMT=IMT+1 IF(IMT.GT.1)GO TO 127 ENDIF C M2=(QL(N1)+QL(N2))/2+2 IF(BINT)THEN DO I=1,MAXRS DPA(I)=DPNL(I,N2)*DPNL(I,N1) ENDDO ELSE IF(QL(N2).GT.0)M2=M2-1 C DO I=1,MAXRS DPA(I)=DPNL(I,N2)/DX(I) ENDDO C CALL DIFF(DPA,DP,MNH,DHNS,MJH) C DO I=1,MAXRS DPA(I)=DPNL(I,N1)*DP(I)*DX(I) ENDDO ENDIF C IF(BREL)THEN DE1=DEY(N1)-DUY(N1,N1) DE2=DEY(N2)-DUY(N2,N2) DEL=DE1-DE2 ! A.U. T=C4*DTWO DZ=NZION IF(BREL2)THEN DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD2=DONE+T*(DE2+POT(I,1)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)/DSQ ENDDO ELSE dnorm=rnorm(n1)*rnorm(n2) DO I=1,MAXRS DD1=DONE+C4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) DD2=DONE+C4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)*dnorm/DSQ ENDDO ENDIF CALL YLAMKR(M1,M2,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0) ELSE CALL YLAMK(M1,M2,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0) ENDIF C IF(.NOT.BINT)THEN DO I=1,MAXRS DP(I)=DP(I)*DX(I) ENDDO ENDIF C DO L=J,NN !START INNER MAGNETIC LOOP C !OVER OUTER ORBITAL PAIR IF(QSS(5,L).NE.M)GO TO 602 IF(QSS(K+1,L).NE.N1)GO TO 602 IF(QSS(K+3,L).NE.N2)GO TO 602 C L1=QSS(2-K,L) L2=QSS(4-K,L) JMT=0 IF(MODE.LT.3)THEN IF(IYY(L1).GT.0)JMT=JMT+1 IF(IYY(L2).GT.0)JMT=JMT+1 IF(IMT+JMT.GT.1)GO TO 602 ENDIF C DO I=1,MAXRS DPA(I)=DPNL(I,L1)*DP(I)*DPNL(I,L2) ENDDO C IF(BREL)THEN DE1=DEY(L1)-DUY(L1,L1) DE2=DEY(L2)-DUY(L2,L2) C DEL=DE1-DE2 ! A.U. T=C4*DTWO DZ=NZION IF(BREL2)THEN DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD2=DONE+T*(DE2+POT(I,1)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)/DSQ ENDDO ELSE dnorm=rnorm(l1)*rnorm(l2) DO I=1,MAXRS DD1=DONE+C4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) DD2=DONE+C4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)*dnorm/DSQ ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS) C OVL=DONE IF(IRLX.EQ.2)THEN !OVERLAPS KF=IGRCF(N1) KG=IGRCF(N2) IF(KG.EQ.0)KG=IGRCF(L1) IF(KF.NE.KG.AND.KG.GT.0)THEN K1=MIN(KF,KG) K2=MAX(KF,KG) KK=((K2-1)*(K2-2))/2+K1 OVL=OVLPCF(KK) IF(IPAIR(KK).EQ.1)THEN!SURELY THIS CAN BE SIMPLIFIED... IF(IEQ(N1).EQ.IEQ(N2))THEN K1=MIN(N1,N2) K2=MAX(N1,N2) ELSEIF(IEQ(L1).EQ.IEQ(L2))THEN IF(IGRCF(L1).EQ.0)GO TO 611 K1=MIN(L1,L2) K2=MAX(L1,L2) ELSEIF(KF.NE.IGRCF(L1))THEN IF(IEQ(N1).EQ.IEQ(L1))THEN K1=MIN(N1,L1) K2=MAX(N1,L1) ELSEIF(IEQ(L2).EQ.IEQ(N2))THEN IF(IGRCF(L2).EQ.0)GO TO 611 K1=MIN(L2,N2) K2=MAX(L2,N2) else write(6,*)'fsint: why are we here?', x kf,kg,n1,l1,n2,l2 write(0,*)'fsint: why are we here?' nf=-1 go to 500 !return ENDIF ELSE IF(IEQ(N1).EQ.IEQ(L2))THEN K1=MIN(N1,L2) K2=MAX(N1,L2) ELSEIF(IEQ(L1).EQ.IEQ(N2))THEN K1=MIN(L1,N2) K2=MAX(L1,N2) else write(6,*)'fsint: why are we here?', x kf,kg,n1,l1,n2,l2 write(0,*)'fsint: why are we here?' nf=-1 go to 500 !return ENDIF ENDIF KK=((K2-1)*(K2-2))/2+K1 OVL=OVL/OVLPGR(KK) ENDIF ENDIF ENDIF C 611 DNL(L)=DD*C4*OVL KK=NLI(L) IF(KK.GT.0)THEN IF(IRLX.EQ.2)THEN DO I=1,MENG DNLI(I,KK)=DNLI(I,KK)*OVL ENDDO ENDIF DNLI(NREL,KK)=DNL(L) ENDIF C 602 ENDDO !END INNER LOOP C 127 KK=NLI(J) IF(BPRNT0.AND.KK.EQ.0)WRITE(6,140)J,(QSS(I,J),I=1,5),DNL(J) IF(BPRNT0.AND.KK.GT.0)WRITE(6,140)J,(QSS(I,J),I=1,5) X ,(DNLI(IC,KK),IC=1,MENG) C ENDDO !END OUTER LOOP C 500 RETURN C 140 FORMAT(I5,3X,2(I5,I4),I6,7F14.8,1X/(32X,7F14.8)) 610 FORMAT(//5X,"N&V( A B C D 2LBD') = MAGNETIC INTEGRALS") C END C C ******************* C SUBROUTINE FSINTI(ICOUNT,N,KK,MAXPS) C C----------------------------------------------------------------------- C C SR.FSINTI CALCULATES THE TWO-BODY FINE-STRUCTURE INTEGRALS (N&V) C INVOLVING CONTINUUM FUNCTIONS (ORBITAL N) AT THE ICOUNT'TH C INTERPOLATION ENERGY, INDEXED BY KK. C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: QSS !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (C4=DFSC**2/DFOUR) C LOGICAL BINT,BREL,BJUMPR,BMVD,BREL2,BSTO,BLAG,BBC2,BCALC C CF77 INTEGER*8 MSS !F77 C COMMON /CHARY/DEY(MAXGR) COMMON /COM3/DRY,DZ,TM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBFR/GR(MAXB1) COMMON /NRBFSI/DNLI(MXENG,MXFSS),NLI(MAXMI) COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/FR(MAXB1),DERV1(MAXB1),DERV2(MAXB1),BP(MAXB1) common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C C IF(NL.LT.NL000)NL=NL+1 NN=NL000 C DDY=DRY/DTWO !A.U. DD=DZERO C BREL2=IABS(IREL).EQ.2 C !ELSE COMPUTE DO J=1,NN !START MAGNETIC TWO-BODY OUTER LOOP C !OVER INNER ORBITAL PAIR (YLAMK) KP=NLI(J) C ****TEST 108 IF(KP.GT.0)then !.AND. for stupid compilers if(DNLI(ICOUNT,KP).NE.DZERO)GO TO 127 endif C M=QSS(5,J) MM=(M+2)/100 BINT=MM.EQ.2 !FALSE V; TRUE N IF(.NOT.BINT.AND.MM.NE.1)THEN WRITE(6,*)'FSINTI ERROR: ITYPE=',MM WRITE(0,*)'FSINTI ITYPE ERROR' KK=-1 GO TO 999 ENDIF C M1=(M-100*MM)/2 IF(M1.GT.MAXLAM)GO TO 127 C DO I=1,4 !NO ASSUMPTION ABOUT POSITION OF CONTINUUM IF(N.EQ.QSS(I,J))GO TO 121 ENDDO GO TO 127 C 121 IN=N !SUPERFLUOUS WHEN ONLY ONE CONTINUUM MJ=M-197 IF(MJ.GT.0)MJ0=3 !N IF(MJ.LT.0)MJ0=-3 !V K=0 !V IF(BINT)K=1 !N C N1=QSS(K+1,J) N2=QSS(K+3,J) IF(MODE.LT.3)THEN IMT=0 IF(IYY(N1).GT.0)IMT=IMT+1 IF(IYY(N2).GT.0)IMT=IMT+1 IF(IMT.GT.1)GO TO 127 ENDIF C BCALC=N1.EQ.IN.OR.N2.EQ.IN C IF(.NOT.BLAG)GO TO 125 C M2=(QL(N1)+QL(N2))/2+2 IF(BINT)THEN IF(N1.EQ.IN)THEN DO I=1,MAXPS DPA(I)=DPNL(I,N2)*FR(I) ENDDO ELSEIF(N2.EQ.IN)THEN DO I=1,MAXPS DPA(I)=FR(I)*DPNL(I,N1) ENDDO ELSE DO I=1,MAXPS DPA(I)=DPNL(I,N2)*DPNL(I,N1) ENDDO ENDIF ELSE IF(QL(N2).GT.0)M2=M2-1 C IF(N2.EQ.IN)THEN DO I=1,MAXPS DPA(I)=FR(I)/DX(I) ENDDO ELSE DO I=1,MAXPS DPA(I)=DPNL(I,N2)/DX(I) ENDDO ENDIF C CALL DIFF(DPA,BP,MNH,DHNS,MJH) C IF(N1.EQ.IN)THEN DO I=1,MAXPS DPA(I)=FR(I)*BP(I)*DX(I) ENDDO ELSE DO I=1,MAXPS DPA(I)=DPNL(I,N1)*BP(I)*DX(I) ENDDO ENDIF ENDIF C IF(BREL)THEN T=C4*DTWO DE1=DEY(N1)-DUY(N1,N1) DE2=DEY(N2)-DUY(N2,N2) IF(BREL2)THEN IF(N1.EQ.IN)DE1=DDY IF(N2.EQ.IN)DE2=DDY DO I=1,MAXPS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD2=DONE+T*(DE2+POT(I,1)) DPA(I)=DPA(I)/SQRT(DD1*DD2) ENDDO ELSE dnorm=rnorm(n1)*rnorm(n2) !use nrel value IF(N1.EQ.IN)THEN DE1=DDY DO I=1,MAXPS DD1=DONE+C4*(GR(I)/FR(I)+DTWO*DZ/DX(I)) DD2=DONE+C4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2) ENDDO ELSEIF(N2.EQ.IN)THEN DE2=DDY DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I)) DD2=DONE+C4*(GR(I)/FR(I)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2) ENDDO ELSE DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I)) DD2=DONE+C4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2) ENDDO ENDIF ENDIF DEL=DE1-DE2 ! A.U. CALL YLAMKR(M1,M2,DEL,DPA,BP,DD1,DD2,MNH,DHNS,MJH,MJ0) ELSE CALL YLAMK(M1,M2,DPA,BP,DD1,DD2,MNH,DHNS,MJH,MJ0) ENDIF C IF(.NOT.BINT)THEN DO I=1,MAXPS BP(I)=BP(I)*DX(I) ENDDO ENDIF C 125 DO L=J,NN !START INNER MAGNETIC LOOP C !OVER OUTER ORBITAL PAIR IF(QSS(5,L).NE.M)GO TO 602 IF(QSS(K+1,L).NE.N1)GO TO 602 IF(QSS(K+3,L).NE.N2)GO TO 602 C L1=QSS(2-K,L) L2=QSS(4-K,L) JMT=0 IF(MODE.LT.3)THEN IF(IYY(L1).GT.0)JMT=JMT+1 IF(IYY(L2).GT.0)JMT=JMT+1 IF(IMT+JMT.ne.1)GO TO 602 !NEED ONE AND ONLY ONE CONTINUUM ENDIF C IF(.NOT.BCALC)THEN !NOT YET MATCHED ORB N IF(L1.NE.IN.AND.L2.NE.IN)GO TO 602 !NOT FOUND ENDIF C IF(.NOT.BLAG)GO TO 126 C IF(L1.EQ.IN)THEN DO I=1,MAXPS DPA(I)=FR(I)*BP(I)*DPNL(I,L2) ENDDO ELSEIF(L2.EQ.IN)THEN DO I=1,MAXPS DPA(I)=DPNL(I,L1)*BP(I)*FR(I) ENDDO ELSE DO I=1,MAXPS DPA(I)=DPNL(I,L1)*BP(I)*DPNL(I,L2) ENDDO ENDIF C IF(BREL)THEN DE1=DEY(L1)-DUY(L1,L1) DE2=DEY(L2)-DUY(L2,L2) T=C4*DTWO IF(BREL2)THEN IF(L1.EQ.IN)DE1=DDY IF(L2.EQ.IN)DE2=DDY DO I=1,MAXPS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD2=DONE+T*(DE2+POT(I,1)) DPA(I)=DPA(I)/SQRT(DD1*DD2) ENDDO ELSE dnorm=rnorm(l1)*rnorm(l2) !use nrel value IF(L1.EQ.IN)THEN c DE1=DDY DO I=1,MAXPS DD1=DONE+C4*(GR(I)/FR(I)+DTWO*DZ/DX(I)) DD2=DONE+C4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2) ENDDO ELSEIF(L2.EQ.IN)THEN c DE2=DDY DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I)) DD2=DONE+C4*(GR(I)/FR(I)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2) ENDDO ELSE DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I)) DD2=DONE+C4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DPA(I)=DPA(I)*dnorm/SQRT(DD1*DD2) ENDDO ENDIF ENDIF ENDIF C CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXPS) C 126 KP=NLI(L) IF(KP.LE.0)THEN KK=KK+1 IF(KK.GT.MXFSS)GO TO 602 KP=KK NLI(L)=KK ENDIF C DNLI(ICOUNT,KP)=DD*C4 C 602 ENDDO !END INNER LOOP C C **TEST PRINT C 108 KP=NLI(J) C WRITE(6,140)ICOUNT,J,(QSS(I,J),I=1,5),DNLI(ICOUNT,KP) C 140 FORMAT(2I5,3X,2(I5,I4),I6,F14.8) C 127 ENDDO !END OUTER LOOP C 999 RETURN C END C C ******************* C SUBROUTINE FSINTX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DNL X ,M1,M2,JNEW,MPOSC) C C----------------------------------------------------------------------- C C SR.FSINTX CALCULATES THE DEIE TWO-BODY FINE-STRUCTURE INTEGRALS (N&V) C C THE FOUR ELECTRON-ARGUMENTS (1,2,3.. FOR 1S,2S,2P..) HAVE BEEN C STORED IN QSS(I,L),I=1,4, AND 2*LAMBDA IN QSS(5,L). C C IT CALLS: C SR.VNRKX C SR.VNYKX C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: QSS !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C CF77 INTEGER*8 MSS !F77 C LOGICAL BPRNT0,BREL,BJUMPR,BMVD,BREL2,BINT C !,BPRINT,BSTO C DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3) X ,DNL(*) C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) C COMMON /COM1/DPOT(MAXB1),TOL,MEND COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /NXRNL/NL000,NL c COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) C COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW6/QPOS(MAXGR),QPOS0(MAXGR) COMMON /NRBLAM/MAXLAM,MXLAMX C COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) C COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/FR(MAXB1),DERV1(MAXB1),DERV2(MAXB1),BP(MAXB1) common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C C SUPPRESS COMPILER WARNINGS (SIGH...) C DUM=PSHFTX(1,1) C NN=NL000 C BPRNT0=JPRINT.GE.4 !FOR DETAILED PRINTOUT c BPRNT0=JPRINT.NE.-3 BREL2=IABS(IREL).EQ.2 C MAXRS1=MAXRS IF(BREL2)MAXRS1=MAXRS1+1 C IF(BPRNT0)WRITE(6,610)M1,DYY(M1),M2,DYY(M2) C C INITIALIZE C DO J=1,NN DNL(J)=DZERO ENDDO C C OUTER LOOP TO DETERMINE FINE-STRUCTURE INETGRALS C DO J=1,NN !START MAGNETIC TWO-BODY OUTER LOOP C !OVER INNER ORBITAL PAIR (YLAMK) IF(DNL(J).NE.DZERO)GO TO 127 C M5=QSS(5,J) IF(M5.LT.100.OR. !NOT NEEDED FOR THIS JTOT X M5.LT.198.AND.M5.GT.160+JNEW)GO TO 127 MM=(M5+2)/100 BINT=MM.EQ.2 !FALSE V; TRUE N IF(.NOT.BINT.AND.MM.NE.1)THEN WRITE(6,*)'FSINTX ERROR: ITYPE=',MM WRITE(6,*)'J',J,' QSS(J):',(QSS(M,J),M=1,5) WRITE(0,*)'FSINTX ITYPE ERROR' NF=-1 GO TO 500 !RETURN ENDIF C MI=(M5-100*MM)/2 IF(MI.GT.MAXLAM)GO TO 127 C K=0 !V IF(BINT)K=1 !N C N1=QSS(K+1,J) N2=QSS(K+3,J) IF(QL(N1).LT.0)GO TO 127 IF(QL(N2).LT.0)GO TO 127 C ML=(QL(N1)+QL(N2))/2+2 IF(.NOT.BINT.AND.QL(N2).GT.0)ML=ML-1 c if(brel)dnorm=rnorm(n1)*rnorm(n2) C C DETERMINE "YLAMK" C IF(QN(N1).LT.0)THEN Q1=QPOS(N1-MPOSC) q1=iabs(q1) DE1=DYY(M1)/DTWO ELSE DE1=DEY(N1)-DUY(N1,N1) ENDIF C IF(QN(N2).LT.0)THEN Q2=QPOS(N2-MPOSC) q2=iabs(q2) DE2=DYY(M2)/DTWO IF(QN(N1).LT.0)THEN C ICASE=1 CALL VNYKX(FRX(1,M1,Q1),FRX(1,M2,Q2),FRX(MAXRS1,M1,Q1) X ,FRX(MAXRS1,M2,Q2),BINT,MI,ML,DE1,DE2,FR,BP,DX,dnorm) ELSE C ICASE=3 M=M1 CALL VNYKX(DPNL(1,N1),FRX(1,M2,Q2),DQNL(1,N1) X ,FRX(MAXRS1,M2,Q2),BINT,MI,ML,DE1,DE2,FR,BP,DX,dnorm) ENDIF ELSE DE2=DEY(N2)-DUY(N2,N2) IF(QN(N1).LT.0)THEN C ICASE=2 c if(bint)then !and falling order c m0=m2 c m=m1 c de1=dyy(m2)/dtwo c else M0=M1 M=M2 c endif CALL VNYKX(FRX(1,M0,Q1),DPNL(1,N2),FRX(MAXRS1,M0,Q1) X ,DQNL(1,N2),BINT,MI,ML,DE1,DE2,FR,BP,DX,dnorm) ELSE C ICASE=4 M=M1 CALL VNYKX(DPNL(1,N1),DPNL(1,N2),DQNL(1,N1) X ,DQNL(1,N2),BINT,MI,ML,DE1,DE2,FR,BP,DX,dnorm) ENDIF ENDIF C DO L=J,NN !START INNER MAGNETIC LOOP C !OVER OUTER ORBITAL PAIR IF(QSS(5,L).NE.M5)GO TO 602 IF(QSS(K+1,L).NE.N1)GO TO 602 IF(QSS(K+3,L).NE.N2)GO TO 602 L1=QSS(2-K,L) L2=QSS(4-K,L) IF(QL(L1).LT.0)GO TO 602 IF(QL(L2).LT.0)GO TO 602 c if(brel)dnorm=rnorm(l1)*rnorm(l2) C C DETERMINE "RK" (A.U.) C IF(QN(L1).LT.0)THEN Q1=QPOS(L1-MPOSC) q1=iabs(q1) DE1=DYY(M)/DTWO ELSE DE1=DEY(L1)-DUY(L1,L1) ENDIF C IF(QN(L2).LT.0)THEN Q2=QPOS(L2-MPOSC) q2=iabs(q2) DE2=DYY(M2)/DTWO IF(QN(L1).LT.0)THEN C JCASE=4 CALL VNRKX(FRX(1,M1,Q1),FRX(1,M2,Q2),FRX(MAXRS1,M1,Q1) X ,FRX(MAXRS1,M2,Q2),DE1,DE2,FR,BP,DX,dnorm,DD) ELSE C JCASE=2 CALL VNRKX(DPNL(1,L1),FRX(1,M,Q2),DQNL(1,L1) X ,FRX(MAXRS1,M,Q2),DE1,DE2,FR,BP,DX,dnorm,DD) ENDIF ELSE DE2=DEY(L2)-DUY(L2,L2) IF(QN(L1).LT.0)THEN C JCASE=3 CALL VNRKX(FRX(1,M,Q1),DPNL(1,L2),FRX(MAXRS1,M,Q1) X ,DQNL(1,L2),DE1,DE2,FR,BP,DX,dnorm,DD) ELSE C JCASE=1 CALL VNRKX(DPNL(1,L1),DPNL(1,L2),DQNL(1,L1) X ,DQNL(1,L2),DE1,DE2,FR,BP,DX,dnorm,DD) ENDIF ENDIF C DNL(L)=DD C 602 ENDDO !END INNER LOOP C 127 IF(BPRNT0)WRITE(6,140)J,(QSS(I,J),I=1,5),DNL(J) C ENDDO !END OUTER LOOP C 500 RETURN C 140 FORMAT(I5,3X,2(I5,I4),I6,F14.8) 610 FORMAT(/5X,"N&V( A B C D 2LBD') = MAGNETIC INTEGRALS" X,3X,'FOR E(',I2,')=',F10.3,5X,'E(',I2,')=',F10.3,' RYD') 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 Based on PHN's GRASP0 routine and freely adapted by NRB. C C----------------------------------------------------------------------- C IMPLICIT NONE C INCLUDE './PARAM' C C Parameter variables C DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) DOUBLE PRECISION THREE PARAMETER (THREE=3.D0) 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) DOUBLE PRECISION SLFE1,SLFE3 INTEGER NUMVAL C C Common variables C INTEGER QCG,QL,QN COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) c Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C 1s data : C DATA VAL1S/4.654D0,3.246D0,2.5519D0,2.1351D0,1.8644D0,1.6838D0 +,1.5675D0,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.0549D0,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 +,90.0D0,100.0D0,110.0D0/ C C Number of data points C DATA NUMVAL/11/ C----------------------------------------------------------------------- IF (QN(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 (QL(I).EQ.0)THEN C CALL INTRPG(ARG,VAL2S,ZEFF,NUMVAL,SLFE) C ELSEIF(QL(I).EQ.2)THEN C C np- case C CALL INTRPG(ARG,VAL2P1,ZEFF,NUMVAL,SLFE1) C C np case C CALL INTRPG(ARG,VAL2P3,ZEFF,NUMVAL,SLFE3) C C FORM KAPPA AVERAGE C SLFE=(SLFE1+TWO*SLFE3)/THREE C ENDIF C END C C ******************* C REAL*8 FUNCTION GAMA7(XX) C C----------------------------------------------------------------------- C C FN.GAMA7 EVALUATES THE GAMMA FUNCTION OF ARGUMENT X, C USING THE 7-POINT APPROXIMATE FORM OF ABRAMOWITZ AND STEGUN. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (ERR=1.D-6) PARAMETER (ARGFCT=57.0D0) C PARAMETER (C1=0.57710166D0) PARAMETER (C2=0.98585399D0) PARAMETER (C3=0.87642182D0) PARAMETER (C4=0.8328212D0) PARAMETER (C5=0.5684729D0) PARAMETER (C6=0.25482049D0) PARAMETER (C7=0.05149930D0) C IER=2 X=XX IF(X.GT.ARGFCT)GO TO 9 C GX=DONE 2 IF(X.GE.DTWO)THEN X=X-DONE GX=GX*X GO TO 2 ENDIF C IF(X.LT.ERR)THEN IER=1 Y=DBLE(INT(X))-X IF(ABS(Y).LT.ERR)GO TO 9 IF(DONE-Y-ERR.LE.DZERO)GO TO 9 ENDIF C 5 IF(X.EQ.DONE)THEN GAMA7=GX RETURN ENDIF IF(X.LT.DONE)THEN GX=GX/X X=X+DONE GO TO 5 ENDIF C Y=X-DONE GX=(((((((-C7*Y+C6)*Y-C5)*Y+C4)*Y-C3)*Y+C2)*Y-C1)*Y+DONE)*GX C GAMA7=GX RETURN C C SHOULD NOT OCCUR AS ALL USES OF GAMA7 CHECK FOR VALID RANGE BEFOREHAND C 9 WRITE(6,100)IER WRITE(0,*)'***ERROR IN FUNCTION GAMA7' C STOP'***ERROR IN FUNCTION GAMA7' 100 FORMAT('***ERROR',I3,' IN FUNCTION GAMA7') C END C C ******************* C SUBROUTINE HDIAG(NMAX,DU,MAXNJ,DEV,WRK,NF,INFO) C C----------------------------------------------------------------------- C C SR.HDIAG DIAGONALIZES A REAL SYMMETRIC (HAMILTONIAN) MATRIX C THERE ARE SEVERAL ROUTINES CODED-FOR. C ON INPUT: DU CONTAINS THE LOWER TRIANGLE MATRIX OF ORDER NMAX C AND ROW DIMENSION MAXNJ C ON OUTPUT: DU CONTAINS THE E-VECTORS AND DEV(NMAX) THE E-VALUES C WRK IS A VECTOR OF LENGTH AT LEAST NMAX. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD1=MAXDI/MAXDK, !F77 CF77 X MXD2=MAXDK/MAXDI, !F77 CF77 X MXD3=MXD1+MXD2, !F77 CF77 X MXD4=MAXDI*MXD1/MXD3+MAXDK*MXD2/MXD3+1) !=NMAX !F77 C PARAMETER (DONE=1.0D0) CL PARAMETER (EPS=1.0D-12) !DSYEVR C CF77 DIMENSION DSV(MAXDK,MAXDK) !F77 ALLOCATABLE :: DSV(:,:),IWRK1(:),IWRK2(:) !F95 CL ALLOCATABLE :: WORK(:),IWORK(:) !LAPACK C DIMENSION DU(MAXNJ,*),DEV(*),WRK(*) CF77 X ,IWRK1(MXD4),IWRK2(MXD4),ISUPP(2*MXD4) !F77 C COMMON /NRBDIJ/IDIAG,JRAD C CF77 EQUIVALENCE (IWRK1(1),ISUPP(1)),(IWRK2(1),ISUPP(MXD4+1)) !F77 CF77 !F77 CF77 NDUM=NF !F77 C IF(NMAX.EQ.1)THEN !QUICK RETURN DEV(1)=DU(1,1) DU(1,1)=DONE RETURN ENDIF C IF(IDIAG.LE.0)THEN C !F95 ALLOCATE(IWRK1(NMAX),IWRK2(NMAX),STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)' HDIAG: ALLOCATION FAILS FOR IWRK1,IWRK2' !F95 GO TO 7600 !F95 ENDIF !F95 C CL IF(INFO.GT.0)GO TO 200 !PREVIOUS LAPACK FAILURE !LAPACK C INFO=1 !FLAG FOR DIAG C CLC ALL LAPACK !LAPACK CLC !LAPACK CLC FOR DSYEVR !DSYEVR CL LIWORK=10*NMAX !DSYEVR CL LWORK=(512+6)*NMAX !DSYEVR CLC !LAPACK CLC FOR DSYEVD !DSYEVD CL LIWORK=3+5*NMAX !DSYEVD CL LWORK=500+6*NMAX+2*NMAX*NMAX !DSYEVD CLC !LAPACK CL ALLOCATE(WORK(LWORK),IWORK(LIWORK) !LAPACK CL X ,DSV(NMAX,NMAX),ISUPP(2*NMAX) !DSYEVR CL X ,STAT=IERR) !LAPACK CLC !LAPACK CL IF(IERR.NE.0)THEN !LAPACK CL WRITE(0,*)' HDIAG: ALLOCATION FAILS FOR WORK,LWORK' !LAPACK CL GO TO 7600 !LAPACK CL ENDIF !LAPACK CLC !DSYEVD CLC DSYEVD - DIVIDE AND CONQUER (MEMORY HOG) !DSYEVD CLC !DSYEVD CL CALL DSYEVD('V','L',NMAX,DU,MAXNJ,DEV !DSYEVD CL X ,WORK,LWORK,IWORK,LIWORK,INFO) !DSYEVD CLC !DSYEVD CL IF(INFO.NE.0)GO TO 100 !DSYEVD CLC !DSYEVD CLC USE DIAG TO RE-ORDER E-VALUES BASED ON DOMINANT E-VECTOR CPTS!DSYEVD CLC !DSYEVD CL CALL DIAG(-NMAX,0,DU,DEV,WRK,IWRK1,IWRK2,MAXNJ) !DSYEVD CLC !DSYEVD CLC END DSYEVD !DSYEVD CLC !LAPACK CLC DSYEVR (REQUIRES MACHINES TO HANDLE NaNs GRACEFULLY) !DSYEVR CLC !DSYEVR CL IEEEOK=ILAENV(10,'DSYEVR','N',1,2,3,4) !DSYEVR CL IF(IEEEOK.NE.1)WRITE(0,*) !DSYEVR CL X 'WARNING: DSTEBZ/DSTEIN USED, BETTER TO CALL DSYEVD!' !DSYEVR CLC !DSYEVR CL CALL DSYEVR('V','A','L',NMAX,DU,MAXNJ,VL,VU,IL,IU,EPS !DSYEVR CL X ,MSUB,DEV,DSV,NMAX,ISUPP,WORK,LWORK !DSYEVR CL X ,IWORK,LIWORK,INFO) !DSYEVR CLC !DSYEVR CL IF(MSUB.NE.NMAX)THEN !DSYEVR CL WRITE(6,*)' SR.HDIAG: ERROR IN LAPACK DSYEVR, NOT' !DSYEVR CL X ,' ALL E-VALUES FOUND:',MSUB,NMAX !DSYEVR CL WRITE(0,*)' SR.HDIAG: FAILURE IN LAPACK DSYEVR' !DSYEVR CL IF(INFO.EQ.0)INFO=1 !DSYEVR CL ENDIF !DSYEVR CLC !DSYEVR CL IF(INFO.NE.0)GO TO 100 !DSYEVR CLC !DSYEVR CLC USE DIAG TO RE-ORDER E-VALUES BASED ON DOMINANT E-VECTOR CPTS!DSYEVR CLC !DSYEVR CL CALL DIAG(-NMAX,0,DSV,DEV,WRK,IWRK1,IWRK2,MSUB) !DSYEVR CLC !DSYEVR CL DO IS=1,NMAX !DSYEVR CL DO JS=1,NMAX !DSYEVR CL DU(JS,IS)=DSV(JS,IS) !DSYEVR CL ENDDO !DSYEVR CL ENDDO !DSYEVR CLC !DSYEVR CLC END DSYEVR !DSYEVR CLC !LAPACK CLC ALL LAPACK !LAPACK CLC !LAPACK CL 100 IF(WORK(1).GT.LWORK)THEN !LAPACK CL LWRK=NINT(WORK(1)) !LAPACK CL WRITE(6,*) !LAPACK CL X '***OPTIMAL USE OF DSYEVD REQUIRES LWORK=',LWRK !DSYEVD CL X '***OPTIMAL USE OF DSYEVR REQUIRES LWORK=',LWRK !DSYEVR CL ENDIF !LAPACK CLC !LAPACK CL DEALLOCATE(WORK,IWORK !LAPACK CL X ,DSV,ISUPP !DSYEVR CL X ,STAT=IERR) !LAPACK CL IF(IERR.NE.0)THEN !LAPACK CL WRITE(0,*) !LAPACK CL X ' HDIAG: DEALLOCATION FAILS FOR WORK, LWORK' !LAPACK CL GO TO 7500 !LAPACK CL ENDIF !LAPACK CLC !LAPACK CL IF(INFO.NE.0)THEN !LAPACK CL WRITE(6,*) !LAPACK CL X ' SR.HDIAG: ERROR IN LAPACK DSYEVD: INFO=',INFO !DSYEVD CL X ' SR.HDIAG: ERROR IN LAPACK DSYEVR: INFO=',INFO !DSYEVR CLC !LAPACK CL IF(INFO.GT.0)THEN !LAPACK CLC !LAPACK CL I1=INFO/(NMAX+1) !DSYEVD CL I2=MOD(INFO,NMAX+1) !DSYEVD CL WRITE(6,1000)I1,I2,NMAX !DSYEVD CL WRITE(6,*)' DSYEVR: INTERNAL ERROR' !DSYEVR CLC !LAPACK CLc do is=1,nmax !LAPACK CLc write(6,1001)is,(du(js,is),js=1,nmax) !LAPACK CLc 1001 format(i5,1p,10d12.4/(5x,10d12.4)) !LAPACK CLc enddo !LAPACK CLC !LAPACK CL RETURN !RELOAD AND TRY DIAG !LAPACK CLC !LAPACK CL ELSE !BAILOUT !LAPACK CL WRITE(0,*) !LAPACK CL X ' SR.HDIAG: FAILURE IN LAPACK ROUTINE DSYEVD' !DSYEVD CL X ' SR.HDIAG: FAILURE IN LAPACK ROUTINE DSYEVR' !DSYEVR CL GO TO 2000 !LAPACK CL ENDIF !LAPACK CL ENDIF !LAPACK CLC !LAPACK CLC END LAPACK !LAPACK CLC !LAPACK CL 200 CONTINUE !LAPACK C C HOUSEHOLDER+QL DIAGONALIZATION C IF(INFO.GT.0)THEN INFO=0 !RESET C CALL DIAG(NMAX,0,DU,DEV,WRK,IWRK1,IWRK2,MAXNJ) C ENDIF C !F95 DEALLOCATE(IWRK1,IWRK2,STAT=IERR) !F95 C !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)' HDIAG: DE-ALLOCATION FAILS FOR IWRK1,IWRK2' !F95 GO TO 7600 !F95 ENDIF !F95 C C DIAG FAILURE, SO RETURN & RELOAD AND USE JACORD C IF(NMAX.EQ.0)RETURN C ENDIF C C SLOW BUT ROBUST JACOBI METHOD C IF(IDIAG.GT.0)THEN C ALLOCATE(DSV(MAXNJ,MAXNJ),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)' HDIAG: ALLOCATION FAILS FOR DSV' !F95 GO TO 7600 !F95 ENDIF !F95 C NMAX=-NMAX C CALL JACORD(NMAX,.TRUE.,DU,DSV,MAXNJ) C DO IS=1,NMAX DEV(IS)=DU(IS,IS) DO JS=1,NMAX DU(JS,IS)=DSV(JS,IS) ENDDO ENDDO C DEALLOCATE(DSV,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)' HDIAG: DEALLOCATION FAILS FOR DSV' !F95 GO TO 7600 !F95 ENDIF !F95 C ENDIF C RETURN C CL 2000 NF=-1 !LAPACK CL RETURN !LAPACK C CL 7500 NF=0 !LAPACK CL RETURN !LAPACK C 7600 NF=0 !F95 RETURN !F95 C CL 1000 FORMAT !DSYEVD CL X(/' DSYEVD: ALGORITHM FAILED TO COMPUTE AN EIGENVALUE ' !DSYEVD CL X,'WHILE WORKING ON THE SUBMATRIX LYING IN ROWS AND ' !DSYEVD CL X,'COLUMNS',I5,' THROUGH',I5,' FOR MATRIX OF RANK',I5/) !DSYEVD C END C C ******************* C SUBROUTINE HPSRTI (N,A,IP) C C----------------------------------------------------------------------- C C IMPLICIT HEAPSORT BY *MAGNITUDE* OF C INPUT: VECTOR A, LENGTH N. C OUTPUT: DOWN-ORDERED POINTER IN IP, A IS UNCHANGED. C (UP-ORDERED CAN BE OBTAINED BY CHANGING .LT. TO .GT. AS BELOW). C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C DIMENSION A(*),IP(*) C DO I=1,N IP(I)=I ENDDO C IF(N.LT.2)RETURN C L=N/2+1 IT=N C 1 IF(L.GT.1)THEN L=L-1 IPT=IP(L) ELSE IPT=IP(IT) IP(IT)=IP(1) IT=IT-1 IF(IT.EQ.1)THEN IP(1)=IPT RETURN ENDIF ENDIF I=L J=L+L C 2 IF(J.LE.IT)THEN IF(J.LT.IT)THEN IF(abs(A(IP(J+1))).lT.abs(A(IP(J))))J=J+1 !.lt. down, .gt .up ENDIF IF(abs(A(IP(J))).lT.abs(A(IPT)))THEN !.lt. down, .gt .up IP(I)=IP(J) I=J J=J+J ELSE J=IT+1 ENDIF GO TO 2 ENDIF IP(I)=IPT GO TO 1 C 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 PHN's GRASP0 routine C C----------------------------------------------------------------------- C 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.NE.J) PL = (X-ARG(J))*PL/(ARG(L)-ARG(J)) ENDDO Y = Y+PL*VAL(L) ENDDO C END C C ******************* C SUBROUTINE JACORD(N,EIVEC,A,V,MXMAT) C C----------------------------------------------------------------------- C C SR.JACORD CALCULATES EIGENVALUES AND EIGENVECTORS OF A REAL-SYMMETRIC C MATRIX A WITH THE METHOD OF JACOBI. RE-WRITTEN JUN96 NRB. C C INPUT: C N=ORDER OF THE MATRIX A TO BE DIAGONALISED. C EIVEC=.TRUE.EIGENVECTORS WANTED,=.FALSE.NO EIGENVECTORS WANTED. C C RESULTS: C V(I,K),I=1,N EIGENVECTORS TO A(K,K)=EIGENVALUE. C THE ORIGINAL A IS DESTROYED. THE EIGENVALUES WILL BE ORDERED- C A(K,K).LT.A(I,I) FOR K.LT.I BUT IF N.LT.0 NO REORDERING TAKES PLACE, C IN THAT CASE N=-N AT THE BEGINNING. C C JACORD AND ROTSYM ARE BASED ON ALGOL PROCEDURES WRITTEN BY C RUTISHAUSER AT THE ETH (ZURICH, SWITZERLAND). FOR AN IMPROVED C VERSION SEE RUTISHAUSER,NUMER.MATH.9(1966)1-10. C C*****IF JACORD FAILS THEN IT IS PROBABLY RETURNING TOO SOON, REDUCE C*****PARAMETER TOL BELOW, UNLESS NMAX SWEEPS OCCURRED - LOOK FOR C*****WARNING WRITTEN BY FORMAT 100 - THIS IS EXTREMELY UNLIKELY DUE C*****TO THE QUADRATIC CONVERGENCE. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (EPS=1.0D-11) PARAMETER (TOL=EPS*EPS) ! *** TOL *** PARAMETER (STOL=1.0D-2*EPS) PARAMETER (BIG=3.16D19) PARAMETER (NMAX=50) C LOGICAL EIVEC,BNOGT C DIMENSION A(MXMAT,MXMAT),V(MXMAT,MXMAT) C BNOGT=N.LT.0 IF(BNOGT) N=-N C IF(EIVEC)THEN DO K=1,N DO L=1,N V(K,L)=DZERO ENDDO V(K,K)=DONE ENDDO ENDIF C I=1 IF(N.EQ.1)GO TO 9 !EXIT FAST C C C NMAX IS THE NUMBER OF SWEEPS C IT IS VIRTUALLY INDEPENDENT OF THE ORDER N. C DO I=1,NMAX C SS=DZERO DO K=1,N-1 DO L=K+1,N SS=A(K,L)*A(K,L)+SS ENDDO ENDDO C IF(SS.LT.TOL)GO TO 9 !EXIT C TRESH=DZERO IF(I.LT.4)TRESH=DONE*SQRT(SS)/(DFIVE*N**2) C DO K=1,N-1 C DO L=K+1,N C AKK=A(K,K) ALL=A(L,L) AKL=A(K,L) T=ABS(AKL)/STOL C IF(I.GT.4.AND.ABS(AKK).GE.T.AND.ABS(ALL).GE.T)A(K,L)=DZERO C IF(ABS(A(K,L)).GT.TRESH)THEN C THETA=(ALL-AKK)/(DTWO*AKL) C IF(ABS(THETA).GT.BIG)THEN T=DONE/(DTWO*THETA) ELSE T=ABS(THETA)+SQRT(THETA*THETA+DONE) IF(THETA.LE.DZERO) T=-T T=DONE/T ENDIF C C=DONE/SQRT(T*T+DONE) S=T*C C CALL ROTSYM(N,N,EIVEC,C,S,K,L,A,V,MXMAT) C A(K,L)=DZERO C ENDIF C ENDDO C ENDDO C ENDDO C WRITE(6,100)I-1,SS C 9 CONTINUE !CONVERGED C C WRITE(6,101)N,I-1 C IF(BNOGT)RETURN C C RE-ORDER INTO ASCENDING E-VALUES (& VECTORS) C DO I=1,N K=I P=A(I,I) DO J=I+1,N IF(A(J,J).LT.P)THEN K=J P=A(J,J) ENDIF ENDDO IF(K.NE.I)THEN A(K,K)=A(I,I) A(I,I)=P DO J=1,N P=V(J,I) V(J,I)=V(J,K) V(J,K)=P ENDDO ENDIF ENDDO C C RETURN C 100 FORMAT(' POSSIBLE INACCURACY IN JACORD, AFTER',I3,' SWEEPS' X,' SUM OF OFF-DIAGONAL ELEMENTS IS:',1PD10.2) C 101 FORMAT(' MATRIX ORDER N=',I5,' REQUIRED',I3,' SWEEPS') C END C C ******************* C SUBROUTINE LDFGX(M,L,DP,DQ,MAXRS,BREL,BREL2) C C----------------------------------------------------------------------- C C SR.LDFGX LOADS THE ORBITAL DP INTO DPNL(I,L) AND, IF BREL2, C DQ INTO DQNL(I,L) FOR ACCESS BY THE NFS- INTEGRAL ROUTINES. C IF BREL BUT .NOT.BREL2 THEN CREATES DQNL FROM DTOT=2(V-Z/X), WILL C NEED MODIFYING FOR DIFFERENT DPOT CONTENTS. FINALLY, SETS DEY. C COULD BE ADAPTED FOR OTHER USES. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DTWO=2.0D0) C LOGICAL BREL,BREL2 C DIMENSION DP(*),DQ(*) C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TOL,MEND COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDW5/DYY(MXENG),MENG,NLAG C IF(BREL)THEN !DUY SHOULD BE ZERO, BUT JUST INCASE... DEY(L)=DYY(M)/DTWO+DUY(L,L) IF(BREL2)THEN DO I=1,MAXRS DPNL(I,L)=DP(I) DQNL(I,L)=DQ(I) ENDDO ELSE DO I=1,MAXRS DPNL(I,L)=DP(I) DQNL(I,L)=DP(I)*(DPOT(I)+DYY(M)) ENDDO ENDIF ELSE DO I=1,MAXRS DPNL(I,L)=DP(I) ENDDO ENDIF C RETURN END C C ******************* C SUBROUTINE MINIM C C----------------------------------------------------------------------- C C SR.MINIM CONTROLS THE SECOND, ANALYTIC BRANCH VIZ. HAMILTONIAN SET-UP C DETERMINATION OF ENERGIES, RADIATIVE & AUTOIONIZATION RATES PLUS C PHOTOIONIZATION CROSS SECTIONS AND FINITE ENERGY BORN EXCITATION. C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C USE COMMON_COEFF, ONLY: BCOEFF,DRKP,QRLP,NRKP,NADP !F95 USE COMMON_DMQSS3, ONLY: BDMQSS3,DSS,MSS,QSS,NADR !F95 USE COMMON_DXRL, ONLY: BDXRL,DRK,QRL,NRK,NAD !F95 USE COMMON_NRBEKP, ONLY: BNRBEKP,NED !F95 USE COMMON_NRBMKP, ONLY: BNRBMKP,NMD1,NMD2 !F95 USE COMMON_NRBNF1, ONLY: BNRBNF1,DEK,BFALL !F95 USE COMMON_NRBRN2, ONLY: BNRBRN2,BINDB,MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (IAXUC=MAXUC) !F77 C PARAMETER (MXD01=14) PARAMETER (MXD12=100) PARAMETER (MXD14=100) PARAMETER (MXD15=100) PARAMETER (MXD24=2*MAXGR) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (MZERO=0) PARAMETER (DZERO=0.0D0) C PARAMETER (DONE=1.0D0) PARAMETER (D1M5=1.0D-5) PARAMETER (D5M6=5.0D-6) PARAMETER (DONE=1.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (DTEN=10.0D0) PARAMETER (DCON2=1.5789D5) PARAMETER (DCON3=5.29177D-9) PARAMETER (DCON4=3.22D0) PARAMETER (DCON5=25.1327D0) PARAMETER (DCON6=0.2387D0) C C ASSIGN UNIT NUMBERS C PARAMETER (MW=7) !ols PARAMETER (MWP=MW+1) !oic PARAMETER (MWW=MW+10) !opls PARAMETER (MWPW=MWP+10) !opic PARAMETER (MWU=MW+20) !olsu PARAMETER (MWPU=MWP+20) !oicu PARAMETER (MWWU=MWU+2) !oplsu PARAMETER (MWPWU=MWPU+2) !opicu C CHARACTER(LEN=2) NAM0 CHARACTER(LEN=4) CODE,MBLK CHARACTER(LEN=7) NAM cparc !par cpar character(len=1) :: num(0:9) !par C LOGICAL BPRINT,HFF,BSTO,BORT,BJUMP,BRAD,BDR,BSTART,BJUMP2,BNAME X,BLOOP,BLAG,BBC2,BREL,BJUMPR,BFOT,BPRNT0,BALAN,BMVD,BECOR,BFIX x,btime,btimex X,CPRINT,BTFWE !F95 CF77 X ,BINDB !F77 C CF77 DIMENSION TFWE(MAXUC) !F77 ALLOCATABLE :: TFWE(:) !F95 C DIMENSION DEXTRE(MXVAR),DACCUR(MXVAR) C COMMON /BASIC/NF,KVAR,HFF,MGAP(9) COMMON /CADJ/DADJUS(MXVAR),DF0,IEQUAL(MXVAR),ICOUNT COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /MQVC/MODPH,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /WEIGHT/WGHT(MAXTM),INDEXW(MAXTM) COMMON /CALAN/DALAN(MXVAR),BALAN COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTSS,NTJ(MAXCF),NFJ(MAXLV) X ,KUTSO COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV0 COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ESKPL,ESKPH,BECOR COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDEL/TOLB,TOLE,DELELS(MAXTM,2),DELEIC(MAXLV,2),MDELE X ,MULTS,ISHFTLS,ISHFTIC,NOBS COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLOO/BLOOP,LGAP(3),LMAX COMMON /NRBMIX/CMXLSA,CMXLSR,CMXICA,CMXICR COMMON /NRBNAM/BNAME,NF0 COMMON /NRBNV/MAXNV COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBPLS/DENS(MXD15),TKAYS(MXD15),NDEN COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBTCC/KTCC,MTCC,NTCC,NNRGLS COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD COMMON /NRBWGT/EIMXLS,EIMXIC,WLG1,WLG2,IWGHT,IOPTIM,NRSLMX X ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN COMMON /NRBZSP/ZESP(MAXLL),IZESP,NWRM common /nrbtim/iw,iwp,btime,btimex common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) COMMON /PJSLIM/ECNTRB,ITANAL C DATA ICON,IPRINT/2,1/, MBLK/' '/ cparc !par cpar data num/'0','1','2','3','4','5','6','7','8','9'/ !par C DO I=1,MXVAR DADJUS(I)=DONE !DEFAULT SCALING PARAMETERS FOR EACH ORBITAL DEXTRE(I)=DONE ! DITTO ENDDO C C----------------------------------------------------------------------- C C READ USER INPUT AND PERFORM CHECKS ON INITIAL SET-UP C CALL MINIM0(MPRINT,NLAM,NVAR,DEXTRE,IMAXIT,TVARY,ICM,ICP) C IF(NZION.EQ.0.OR.NF.LE.0)GO TO 10 !RETURN C C----------------------------------------------------------------------- C BORT=MORT.LT.0 JPRINT=MOD(MPRINT,10) C C----------------------------------------------------------------------- C C DETRMINE (RELAXED) CONFIGURATION AVERAGE ENERGY C IF(ICAV0.NE.0)THEN ICAV=IABS(ICAV0) !>0 RELAXED CALL CAVE0(ICAV) ENDIF C C----------------------------------------------------------------------- C NP0=0 IF(IPOLFN.LT.0)NP0=-IPOLFN NPARM3=(NP0+1)*NPARAM !MXVAR C C----------------------------------------------------------------------- C C MINIMALIZATION OF INCLUD TERMS (IN NVAR VARIABLE PARAMETERS WITH NLAM C SCALING PARAMETERS, DEXTRE=DADJUS) C CALL THE MINIMIZATION SR VA04A-WHICH CALLS FUNCTIONAL-SR CALCFX C (THEY NO LONGER USE NLAM EXPLICITLY, UNLESS ZERO.) C C----------------------------------------------------------------------- C IF(INCLUD.NE.0)THEN C IF(NF.LE.0)GO TO 10 !RETURN BPRINT=JPRINT.GE.5 !FOR DETAILED PRINTOUT NPRINT=MOD(NPRNT0,5) C IF(JPRINT.EQ.-2.AND.NPRINT.EQ.-2)THEN WRITE(6,*)'*** SR.MINIM: ERROR, G FUNCTIONAL SPECIFIED FOR' X ,' MINIMIZATION BUT E1 RADIATION IS OFF!' WRITE(0,*)'*** G FUNCTIONAL REQUIRES E1 RADIATION!' GO TO 11 ENDIF C IF(JPRINT.EQ.-2.AND.NJO.GT.0)THEN WRITE(6,*)'*** SR.MINIM: ERROR, G FUNCTIONAL SPECIFIED FOR ', X 'MINIMIZATION IN IC, BUT G IS ONLY AVAILABLE IN LS MINIMIZATION' WRITE(0,*)'*** G FUNCTIONAL ONLY AVAILABLE IN LS MINIMIZATION' GO TO 11 ENDIF C C SWITCH-OFF QUANTITIES NOT NEEDED DURING OPTIMIZATION, SWITCH-ON AFTER C NPRINT=NPRNT0 !TEMP IF(JPRINT.NE.-2)THEN !SWITCH-OFF RAD NPRNT0=-2 IF(NPRINT.NE.MOD(NPRINT,5))NPRNT0=-7 !REL WAVEFN ENDIF COLD NJO0=NJO !TEMP COLD NJO=0 !SWITCH-OFF IC MRAD0=MRAD !TEMP MRAD=0 !SWITCH-OFF RADOUT MENGB0=MENGB !TEMP MENGB=-2 !SWITCH-OFF BORN MDEN0=MDEN IF(MDEN.LT.0)MDEN=-1 C !DUMP ols/u,oic/u OUTPUT IF(BPRINT)THEN IF(IUNIT(MW).GT.0)THEN !SHOULDN'T BE WRITE(6,*)'UNIT=7 ALREADY OPEN' WRITE(0,*)'UNIT=7 ALREADY OPEN' GO TO 11 ENDIF IUNIT(MW)=1 OPEN(MW,STATUS='SCRATCH',FORM='FORMATTED') !DUMP IF(NJO.GT.0)THEN IF(IUNIT(MWP).GT.0)THEN !SHOULDN'T BE WRITE(6,*)'UNIT=8 ALREADY OPEN' WRITE(0,*)'UNIT=8 ALREADY OPEN' GO TO 11 ENDIF IUNIT(MWP)=1 OPEN(MWP,STATUS='SCRATCH',FORM='FORMATTED') !DUMP ENDIF ELSE IF(IUNIT(MWU).GT.0)THEN !SHOULDN'T BE WRITE(6,*)'UNIT=27 ALREADY OPEN' WRITE(0,*)'UNIT=27 ALREADY OPEN' GO TO 11 ENDIF IUNIT(MWU)=1 OPEN(MWU,STATUS='SCRATCH',FORM='UNFORMATTED') !DUMP IF(NJO.GT.0)THEN IF(IUNIT(MWPU).GT.0)THEN !SHOULDN'T BE WRITE(6,*)'UNIT=28 ALREADY OPEN' WRITE(0,*)'UNIT=28 ALREADY OPEN' GO TO 11 ENDIF IUNIT(MWPU)=1 OPEN(MWPU,STATUS='SCRATCH',FORM='UNFORMATTED') !DUMP ENDIF ENDIF C !DITTO TERMS/LEVELS IF(IUNIT(14).GT.0)THEN !SHOULDN'T BE WRITE(6,*)'UNIT=14 ALREADY OPEN' WRITE(0,*)'UNIT=14 ALREADY OPEN' GO TO 11 ENDIF IUNIT(14)=1 OPEN(14,STATUS='SCRATCH',FORM='FORMATTED') !DUMP IF(NJO.GT.0)THEN IF(IUNIT(15).GT.0)THEN WRITE(0,*)'UNIT=15 ALREADY OPEN' !SHOULDN'T BE GO TO 11 ENDIF IUNIT(15)=1 OPEN(15,STATUS='SCRATCH',FORM='FORMATTED') !DUMP ENDIF C C SET COUNTERS C ICOUNT=-IMAXIT IF(IMAXIT.LE.0)IMAXIT=ABS(NVAR) IF(ICOUNT.LT.0)ICOUNT=4*ABS(NVAR)*IMAXIT+IMAXIT+2 C IF(NVAR.GT.0)THEN C C POWELL'S METHOD ("NAG") C T=TVARY !0.01 DO N=0,NP0 N0=N*NPARAM DO I=1,NPARAM I0=IEQUAL(N0+I) IF(I0.LE.NVAR)DACCUR(I0)=T !VARY SCALE BY UP TO T PER ITER ENDDO IF(N.EQ.1)T=T/DTEN ENDDO C CALL VA04A(DEXTRE,DACCUR,NVAR,NLAM,DF,DTEN,IPRINT,ICON,IMAXIT) C ELSE C C CONJUGATE GRADIENT C C INTERFACE TO NAPACK ROUTINES (CAN BE SUPPLIED) C C CALL CGNA(DEXTRE,NVAR,IMAXIT) C C INTERFACE TO NUMERICAL RECIPES ROUTINES C (*NOT* SUPPLIED AS LICENSE REQUIRED - LINK TO YOUR OWN LIBRARY) C CALL CGNR(DEXTRE,NVAR,IMAXIT) !USE REAL*8 NUM. REC. C ENDIF C IF(IMAXIT.LT.0)GO TO 11 !RETURN C C NO DETAILED PRINTOUT DURING ITERATION, THEREFORE NOW PRINTOUT TO C MINIMIZING SCALE FACTORS, HAVING ROUNDED THEM TO 5 DECIMALS C NOTE: DEXTRE(I.GT.NLAM)=1 DURING OPT, UNLESS "FIXED", SO DO NOT USE C IF(I.GT.NLAM)DEXTRE(I)=DEXTRE(NLAM) !HERE C IF(NF.GT.0)THEN C WRITE(6,996)(DEXTRE(I),I=1,NVAR) DO I=1,NPARM3 MM=INT(100000*(DEXTRE(I)+D5M6)) DEXTRE(I)=D1M5*MM ENDDO DO N=0,NP0 N0=N*NPARAM I0=0 DO I=1,NPARAM J=IEQUAL(N0+I) IF(J.LE.NVAR)THEN I0=I0+1 DACCUR(I0)=DEXTRE(J) ENDIF ENDDO IF(N.EQ.0)WRITE(6,996)(DACCUR(I),I=1,I0) IF(I0*N.GT.0)WRITE(6,997)N,(DACCUR(I)-DONE,I=1,I0)!DACCUR(I) ENDDO ENDIF C C TIDY-UP C NPRNT0=NPRINT !RE-INSTATE COLD NJO=NJO0 MRAD=MRAD0 MENGB=MENGB0 MDEN=MDEN0 C IF(IUNIT(MW).GT.0)THEN !CLOSE-OFF SCRATCH CLOSE(IUNIT(MW)) IUNIT(MW)=0 ENDIF IF(IUNIT(MWP).GT.0)THEN CLOSE(IUNIT(MWP)) IUNIT(MWP)=0 ENDIF IF(IUNIT(14).GT.0)THEN CLOSE(IUNIT(14)) IUNIT(14)=0 ENDIF IF(IUNIT(15).GT.0)THEN CLOSE(IUNIT(15)) IUNIT(15)=0 ENDIF C IF(IUNIT(MWU).GT.0)THEN !CLOSE-OFF SCRATCH CLOSE(IUNIT(MWU)) IUNIT(MWU)=0 ENDIF IF(IUNIT(MWPU).GT.0)THEN CLOSE(IUNIT(MWPU)) IUNIT(MWPU)=0 ENDIF C ENDIF C C C END MINIMIZATION ----------------------------------------------------- C IF(INCLUD.LT.0)THEN INCLUD=-1000000+INCLUD ELSE INCLUD=1000000+INCLUD ENDIF C C C MPRINT=AB GIVES LS.JPRINT=B AND IC.JPRINT=A AND BOTH HAVE C THE SAME SIGN, THAT OF MPRINT. C NOT TO BE CONFUSED WITH ALGEBRAIC MPRINT (& NPRNT0) C BPRINT=.TRUE. LSPRNT=JPRINT ICPRNT=MPRINT/10 ICOUNT=0 ND0=1 C C INTERNAL CONTROLS FOR DR LOOP, NOT DIRECTLY SET BY USER. C BDR=IDR.NE.0 !'DR' LOOPING OVER DUMMY RYDBERG BJUMP=.FALSE. !.T. FOR SUBSEQUENT LOOPS (SKIP) BJUMP2=.FALSE. !.T. FOR SCALING 1/N**3 BRAD=.TRUE. !.T. RECALCULATE RADIATIVE DATA. C C PLASMA RE-ENTRY POINT C 2 IF(MDEN.GT.0)THEN DEN0=DENS(ND0) TKAY=TKAYS(ND0) DENE=DEN0*DCON3**3 IF(TKAY.LT.DZERO)TKAY=-TKAY/DCON2 T=NZION-MION GAMQ=DCON4*T**(DFIVE/DTHREE)*DENE**(DONE/DTHREE) IF(TKAY*DENE.NE.DZERO)THEN GAMQ=GAMQ/TKAY DEBYE=SQRT(DCON5*DENE/TKAY) DEBYE=DONE/DEBYE R0=(DCON6*T/DENE)**(DONE/DTHREE) ENDIF WRITE(6,881)MDEN,DEN0,TKAY,GAMQ,DEBYE,R0 ENDIF C C SET-UP LOOP OVER RYDBERG ORBITAL(S), ASSIGN VALUES TO DUMMY C BSTART=BDR NNEW=MAXNV LNEW=-1 LMX0=-999 C IF(BDR.AND.NF.GT.0)THEN LMX0=LMAX IJUMP2=-1 IRAD=-1 C IF(NMIN.GT.0.AND.NMIN.LE.NMAX)THEN !INITIAL N-VALUE ND=0 N=NMIN ELSEIF(JND.LE.0)THEN !RETURN EVENTUALLY WRITE(6,896) WRITE(0,*)'*** CANNOT ASSIGN N-VALUE TO VALENCE ORBITAL...' GO TO 11 ELSE ND=1 N=NDR(1) ENDIF ENDIF C C NL RE-ENTRY C 96 IF(BDR.AND.NF.GT.0)THEN DO I=1,MAXGR IF(IVAL(I).NE.0)THEN !ASSIGN NL LNEW=QL(I)/2 IF(LNEW.GE.N)THEN !NEED TO INCREMENT NMIN FOR THIS L N=LNEW+1 IF(ND.GT.0.OR.JND.GT.0.AND.N.GE.NDR(1))THEN WRITE(6,*)'*** NEED NMAX OF AT LEAST:',N WRITE(0,*)'*** NEED NMAX OF AT LEAST:',N GO TO 11 ENDIF ENDIF QN(I)=N NSW0=LNEW*LNEW NSW0=NSW0/4 NSW0=NSW0+NS0 IF(NSW0.GT.NSX)NSW0=NSX IF(NSW.LT.NSW0)NSW=NSW0 IF(N.LT.NSW)THEN L=LNEW+1 IF(BORT)L=I DAJOLD(L)=DZERO ELSE IF(IJUMP2.LT.0)SCREEN(I)=6999 IF(IJUMP2.GE.0)QN(I)=-N ENDIF ENDIF ENDDO C NNOLD=NNEW NNEW=N IF(.NOT.BLOOP)LNEW=999 WRITE(6,894)NNEW,LNEW c call flush(6) !useful for debug large UNFORM cases BRAD=N.LE.NRAD IF(.NOT.BRAD)IRAD=IRAD+1 IF(IRAD.EQ.0)WRITE(6,892)NRAD IF(N.GE.NSW)THEN IJUMP2=IJUMP2+1 BJUMP2=IJUMP2.GT.0 IF(.NOT.BJUMP2)WRITE(6,893)NSW C HFF=.TRUE. MAUTO=1 IF(ICM.LT.0)MAUTO=0 ENDIF ENDIF C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C *** COMPUTE NON-RELATIVISTIC CASE C C----------------------------------------------------------------------- C JPRINT=LSPRNT BPRNT0=JPRINT.NE.-3 NPRINT=MOD(NPRNT0,5) CPRINT=(MOD(MPNCH,2).NE.0) !F95 C IF(MODE.GT.0)THEN !WRITE HEADERS TO FILES, OPEN IF NECESSARY C NAM0='' cparc !par cpar if(idw.eq.0)then !par cpar i1=iam/10 !par cpar i2=iam-(10*(iam/10)) !par cpar nam0=num(i1)//num(i2) !par cpar endif !par cparc !par IF(BPRNT0)THEN IF(MODE.EQ.1)THEN IF(IUNIT(14).EQ.0)THEN IUNIT(14)=1 OPEN(14,FILE='TERMS',STATUS='REPLACE') !TERM LIST ENDIF IF(ITANAL.NE.0)THEN IF(IUNIT(31).EQ.0)THEN IUNIT(31)=1 OPEN(31,FILE='ITANAL',STATUS='REPLACE') !SMALL TERMS ELSE IF(IUNIT(31).GT.0)CLOSE(31) IUNIT(31)=1 OPEN(31,FILE='ITANAL',STATUS='OLD' X ,POSITION='APPEND') !F95 CF77 X ,ACCESS='APPEND') !F77 ENDIF ENDIF ENDIF IF(IUNIT(MW).EQ.0)THEN IUNIT(MW)=1 NAM='ols'//NAM0 OPEN(MW,FILE=NAM,STATUS='REPLACE') !RATES & ENERGIES ENDIF WRITE(MW,891)NNEW,LNEW,(I,I=1,20) ENDIF IF(.NOT.BPRNT0)THEN IF(IUNIT(MWU).EQ.0)THEN IUNIT(MWU)=1 NAM='olsu'//NAM0 OPEN(MWU,FILE=NAM,FORM='UNFORMATTED' X ,STATUS='REPLACE') !RATES & ENERGIES ENDIF WRITE(MWU)NNEW,LNEW ENDIF C IF(BFOT)THEN IF(BPRNT0)THEN IF(IUNIT(MWW).EQ.0)THEN IUNIT(MWW)=1 NAM='opls'//NAM0 OPEN(MWW,FILE=NAM,STATUS='REPLACE') !PHOTOIONIZATION ENDIF WRITE(MWW,891)NNEW,LNEW ENDIF IF(.NOT.BPRNT0)THEN IF(IUNIT(MWWU).EQ.0)THEN IUNIT(MWWU)=1 NAM='oplsu'//NAM0 OPEN(MWWU,FILE=NAM X ,FORM='UNFORMATTED',STATUS='REPLACE') !PHOTOIONIZATION ENDIF WRITE(MWWU)NNEW,LNEW ENDIF ENDIF C IF(IABS(MENGB).EQ.1)THEN IF(IUNIT(23).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='OMGINFLS'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=23' GO TO 11 ELSEIF(IUNIT(23).EQ.0)THEN IUNIT(23)=1 OPEN(23,FILE='OMGINFLS',STATUS='REPLACE') !INF E BORN ENDIF IF(IUNIT(21).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='adasex.in.form'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=21' GO TO 11 ELSEIF(IUNIT(21).EQ.0.and.idw.eq.0)THEN IUNIT(21)=1 OPEN(21,FILE='adasex.in.form',STATUS='REPLACE') !TEMP ADAS ENDIF ENDIF C IF(MENGB.GE.-1)THEN IF(IUNIT(25).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='adf04ls'..." WRITE(0,*) 'TRYING TO RE-OPEN UNIT=25' GO TO 11 ELSEIF(IUNIT(25).EQ.0)THEN IUNIT(25)=1 cpar if(iam.eq.0)then !par OPEN(25,FILE='adf04ls',STATUS='REPLACE') !IN/FINITE E BORN cpar else !par cpar OPEN(25,STATUS='SCRATCH') !par cpar endif !par ENDIF ENDIF C ENDIF !END OF HEADERS AND FILE OPENING C C ASSIGN SCALING FACTORS C IF(.NOT.BJUMP2)THEN IF(.NOT.BJUMP)THEN DO I=1,NPARM3 !MXVAR J=IEQUAL(I) IF(J.GT.0)THEN C IF(J.LE.NLAM)THEN !CONTROLLED BY IEQUAL DADJUS(I)=DEXTRE(J) IF(BALAN)DALAN(I)=DEXTRE(J) C ENDIF ENDIF ENDDO ENDIF C IF(ISCALR.GT.0)SCALER=DADJUS(ISCALR)!SLATER SCALING PARAMETER C C----------------------------------------------------------------------- C C BEGIN CALCULATIONS: RADIAL & DIAGON C C----------------------------------------------------------------------- C CALL RADIAL(DADJUS) !UPDATE RADIAL FUNCTIONS C IF(NF.LE.0)GO TO 10 !RETURN EVENTUALLY C IF(ICAV0.NE.0.AND..NOT.BJUMP)THEN !UNIQUE ICAV=-IABS(ICAV0) CALL CAVE0(ICAV) ENDIF C ENDIF C C DETERMINE DIMENSIONS REQUIRED TO ALLOCATE !F95 C (SEE ALGEB2 SET-UP, NOTE IAXUC IS REDUCED IF NO RAD, DW OR TECS) !F95 C !F95 IAXDI=1 !F95 IAXUC=0 !F95 NCI=0 !F95 NCTOT=0 !F95 C !F95 IF(IDW.EQ.0.AND.NPRINT.EQ.-2.AND.ISHFTLS.LE.0.AND. !F95 X ITANAL.EQ.0.AND..NOT.CPRINT)THEN !F95 IFLAG=-1 !F95 ELSE !F95 IFLAG=1 !F95 ENDIF !F95 C !F95 DO NN=1,NSL0 !F95 NC=NSL(NN) !F95 IAXDI=MAX(IAXDI,NC) !F95 C !F95 N0=0 !F95 NCC=0 !F95 C !F95 do i=1,mxorb !F95 ncc0(i)=0 !F95 enddo !F95 mx0=mxorb+1 !F95 C !F95 DO J=1,NC !F95 I=NCI+J !F95 K=IABS(NFK(I)) !F95 II=QCG(NF,K) !F95 ii=ieq(ii) !F95 IF(IYY(II).GT.0)then !F95 NCC=NCC+1 !F95 ncc0(ii)=ncc0(ii)+1 !F95 mx0=min(mx0,ii) !F95 else !F95 N0=N0+1 !F95 endif !F95 ENDDO !F95 C !F95 if(mode.eq.2)then !F95 iorb(mx0-1)=n0*n0 !F95 do i=mx0,mxorb !F95 n00=ncc0(i) !F95 iorb(i)=iorb(i-1)+n00*n00 !F95 enddo !F95 c !F95 if(bfot)then !need c-c e-vectors !F95 nctot=nctot+iorb(mxorb) !F95 else !only need b-b !F95 iaxuc=max(iaxuc,nctot+iorb(mxorb)) !but need c-c buffer!F95 nctot=nctot+n0*n0 !so can overwite c-c!F95 endif !F95 c write(0,*)nn,nctot !F95 else !need full block !F95 NCTOT=NCTOT+NC*NC !F95 endif !F95 C !F95 NCI=NCI+NC !F95 ENDDO !F95 c write(0,*)iaxuc !F95 C !F95 IF(IFLAG.LT.0)THEN !F95 if(mode.ne.2)IAXUC=IAXDI*IAXDI !F95 ELSE !F95 if(mode.ne.2.or.bfot)IAXUC=NCTOT !F95 ENDIF !F95 c write(0,*)nctot,iaxuc !F95 C !F95 ALLOCATE(TFWE(IAXUC),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: ALLOCATION FAILS FOR TFWE' !F95 NF=0 !F95 GO TO 10 !F95 ENDIF !F95 IAXUC=IFLAG*IAXUC !F95 c if(btime)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for diagon' !par cpar else !par write(iw,*)'Starting diagon' cpar endif !par if(bdr)write(iw,*)'n=',nnew,' l=',lnew call cpu_time(timei) endif C CALL DIAGON(DECORE,DF,TFWE,IAXUC) !DIAG H(LS) & COMPUTE RATES c if(btime)then call cpu_time(timef) times=timef-timei c if(bdr)write(iw,*)'n=',nnew,' l=',lnew cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for diagon:' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iw) !par cpar else !par write(iw,*)'Ending diagon: time=',nint(times),'sec' cpar endif !par endif C IF(NF.LE.0)GO TO 100 !RETURN EVENTUALLY C c btfwe=.true. BTFWE=ISHFTLS.GT.0.OR.CPRINT !TECs or TCCs, hold LS CI for IC!F95 IF(.NOT.BTFWE)THEN !LS CI NOT NEEDED !F95 DEALLOCATE(TFWE,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: DE-ALLOCATION FAILS FOR TFWE' !F95 NF=0 !F95 GO TO 10 !F95 ENDIF !F95 ENDIF !F95 C C----------------------------------------------------------------------- C C *** COMPUTE FINESTRUCTURE C C----------------------------------------------------------------------- C IF(NJO.GT.0)THEN C JPRINT=ICPRNT BPRNT0=JPRINT.NE.-3 C IF(MODE.GT.0)THEN !WRITE HEADERS TO FILES, OPEN IF NECESSARY C NAM0='' cparc !par cpar if(idw.eq.0)then !par cpar i1=iam/10 !par cpar i2=iam-(10*(iam/10)) !par cpar nam0=num(i1)//num(i2) !par cpar endif !par cparc !par IF(BPRNT0)THEN IF(MODE.EQ.1.AND.IUNIT(15).EQ.0)THEN IUNIT(15)=1 OPEN(15,FILE='LEVELS',STATUS='REPLACE') !LEVEL LIST ENDIF IF(IUNIT(MWP).EQ.0)THEN IUNIT(MWP)=1 NAM='oic'//NAM0 OPEN(MWP,FILE=NAM,STATUS='REPLACE') !RATES & ENERGIES ENDIF WRITE(MWP,891)NNEW,LNEW,(I,I=1,20) ENDIF IF(.NOT.BPRNT0)THEN IF(IUNIT(MWPU).EQ.0)THEN IUNIT(MWPU)=1 NAM='oicu'//NAM0 OPEN(MWPU,FILE=NAM,FORM='UNFORMATTED' X ,STATUS='REPLACE') !RATES & ENERGIES ENDIF WRITE(MWPU)NNEW,LNEW ENDIF C IF(BFOT)THEN IF(BPRNT0)THEN IF(IUNIT(MWPW).EQ.0)THEN IUNIT(MWPW)=1 NAM='opic'//NAM0 OPEN(MWPW,FILE=NAM,STATUS='REPLACE') !PHOTOIONIZATION ENDIF WRITE(MWPW,891)NNEW,LNEW ENDIF IF(.NOT.BPRNT0)THEN IF(IUNIT(MWPWU).EQ.0)THEN IUNIT(MWPWU)=1 NAM='opicu'//NAM0 OPEN(MWPWU,FILE=NAM X ,FORM='UNFORMATTED',STATUS='REPLACE') !PHOTOIONIZATION ENDIF WRITE(MWPWU)NNEW,LNEW ENDIF ENDIF C IF(IABS(MENGB).EQ.1)THEN IF(IUNIT(24).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='OMGINFIC'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=24' GO TO 11 ELSEIF(IUNIT(24).EQ.0)THEN IUNIT(24)=1 OPEN(24,FILE='OMGINFIC',STATUS='REPLACE') !INF E BORN ENDIF IF(IUNIT(22).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='adasexj.in.form'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=22' GO TO 11 ELSEIF(IUNIT(22).EQ.0.and.idw.eq.0)THEN IUNIT(22)=1 OPEN(22,FILE='adasexj.in.form',STATUS='REPLACE')!TEMP ADAS ENDIF ENDIF C IF(MENGB.GE.-1)THEN IF(IUNIT(26).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='adf04ic'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=26' GO TO 11 ELSEIF(IUNIT(26).EQ.0)THEN IUNIT(26)=1 cpar if(iam.eq.0)then !par OPEN(26,FILE='adf04ic',STATUS='REPLACE') !IN/FINITE E BORN cpar else !par cpar OPEN(26,STATUS='SCRATCH') !par cpar endif !par ENDIF ENDIF C ENDIF !END OF HEADERS AND FILE OPENING C C----------------------------------------------------------------------- C C BEGIN CALCULATIONS: SOCC & DIAGFS C C----------------------------------------------------------------------- C IF(.NOT.BJUMP2)THEN !BLUME & WATSON CONTRIBUTION c c if(btime)call cpu_time(timei) C CALL SOCC c c if(btime)then c call cpu_time(timef) c write(iw,*)'socc time=',nint(timef-timei),'sec' c endif C IF(NF.LE.0)GO TO 100 !RETURN EVENTUALLY C ENDIF c if(btime)then cpar if(iam.ge.0)then !par cpar write(iw,*)'Starting proc',iam,' for diagfs' !par cpar else !par write(iw,*)'Starting diagfs' cpar endif !par if(bdr)write(iw,*)'n=',nnew,' l=',lnew call cpu_time(timei) endif C CALL DIAGFS(DECORE,DFFS,TFWE) !DIAG H(IC) & COMPUTE RATES c if(btime)then call cpu_time(timef) times=timef-timei c if(bdr)write(iw,*)'n=',nnew,' l=',lnew cpar if(iam.ge.0)then !par cpar write(iw,*)'Ending proc',iam,' for diagfs:' !par cpar x ,' time=',nint(times),'sec' !par cpar call flush(iw) !par cpar else !par write(iw,*)'Ending diagfs: time=',nint(times),'sec' cpar endif !par endif C ENDIF C C----------------------------------------------------------------------- C 100 CONTINUE C IF(ALLOCATED(TFWE))THEN !F95 DEALLOCATE(TFWE,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: DE-ALLOCATION FAILS FOR TFWE' !F95 NF=0 !F95 ENDIF !F95 ENDIF !F95 C IF(NF.LE.0)GO TO 10 !RETURN EVENTUALLY C C----------------------------------------------------------------------- C C C DETERMINE NEXT N-VALUE FOR RESONANCE (DR/RR/RE ETC) OPERATION C IF(BDR)THEN ICM=0 HFF=.FALSE. IF(ICP.GT.0)MAUTO=1 BJUMP=.TRUE. N=N+1 IF(N.LE.NMAX.AND.ND.EQ.0)GO TO 96 !LOOP BACK-UP WITH NEW N ND=ND+1 IF(ND.LE.JND)THEN N=NDR(ND) GO TO 96 !LOOP BACK-UP WITH NEW N ENDIF ENDIF C C WRITE TERMINATORS C IF(MODE.GT.0.AND.LNEW.GE.LMX0)THEN IF(BPRNT0)WRITE(MW,512)MBLK IF(.NOT.BPRNT0)WRITE(MWU)MZERO,MZERO IF(BFOT)THEN IF(BPRNT0)WRITE(MWW,512)MBLK IF(.NOT.BPRNT0)WRITE(MWWU)MZERO,MZERO ENDIF C IF(NJO.GT.0)THEN !RELATIVISTIC IF(BPRNT0)WRITE(MWP,512)MBLK IF(.NOT.BPRNT0)WRITE(MWPU)MZERO,MZERO IF(BFOT)THEN IF(BPRNT0)WRITE(MWPW,512)MBLK IF(.NOT.BPRNT0)WRITE(MWPWU)MZERO,MZERO ENDIF ENDIF ENDIF C IF(BSTART.NEQV.BDR)THEN !RETURN EVENTUALLY WRITE(6,897) GO TO 10 ENDIF C C COMPUTE CASCADE COEFFICIENTS C IF(KUTCA.GE.0)THEN C CALL CASC C IF(NF.LE.0)GO TO 10 !RETURN EVENTUALLY C ENDIF C C NEW PLASMA POTENTIAL C IF(NDEN.GT.0)THEN NDEN=NDEN-1 ND0=ND0+1 DEN0=DENS(ND0) TKAY=TKAYS(ND0) ZNP=-999 DO I=1,NPARM3 !MXVAR DAJOLD(I)=DZERO ENDDO GO TO 2 !LOOP BACK-UP WITH NEW TEMP AND DENSITY ELSE GO TO 10 !RETURN EVENTUALLY ENDIF C C 10 CONTINUE C C EX-COMMON/DXRL/ !F95 DEALLOCATE (DRK,QRL,NRK,NAD,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: DE-ALLOCATION FAILS FOR DRK,QRL,NRK,NAD' !F95 NF=0 !F95 ENDIF !F95 BDXRL=.FALSE. !F95 C !F95 C EX-COMMON/NRBEKP/ !F95 DEALLOCATE (NED,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: DE-ALLOCATION FAILS FOR NED' !F95 NF=0 !F95 ENDIF !F95 BNRBEKP=.FALSE. !F95 C !F95 C EX-COMMON/NRBMKP/ !F95 DEALLOCATE (NMD1,NMD2,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: DE-ALLOCATION FAILS FOR NMD1,NMD2' !F95 NF=0 !F95 ENDIF !F95 BNRBMKP=.FALSE. !F95 C !F95 C EX-COMMON/NRBNF1/ !F95 DEALLOCATE (DEK,BFALL,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: ALLOCATION FAILS FOR DEK, BFALL' !F95 NF=0 !F95 ENDIF !F95 BNRBNF1=.FALSE. !F95 C !F95 C EX-COMMON/NRBRN2/ !F95 DEALLOCATE (BINDB,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'MINIM: DE-ALLOCATION FAILS FOR BINDB' !F95 NF=0 !F95 ENDIF !F95 BNRBRN2=.FALSE. !F95 C !F95 IF(NJO.GT.0)THEN !F95 C !F95 C EX-COMMON/COEFF/ !F95 DEALLOCATE (DRKP,QRLP,NRKP,NADP,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*) !F95 X 'MINIM: DE-ALLOCATION FAILS FOR DRKP,QRLP,NRKP,NADP'!F95 NF=0 !F95 ENDIF !F95 BCOEFF=.FALSE. !F95 C !F95 C EX-COMMON/DMQSS3/ !F95 DEALLOCATE (DSS,MSS,QSS,NADR,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*) !F95 X 'MINIM: DE-ALLOCATION FAILS FOR DSS,MSS,QSS,NADR' !F95 NF=0 !F95 ENDIF !F95 BDMQSS3=.FALSE. !F95 C !F95 ENDIF !F95 C NF0=NF RETURN C 11 NF=-1 GO TO 10 C C 997 FORMAT(16X,I1,'-POLE PERTURBATION PARAMETERS:',8F10.5, X/((48X,8F10.5))) 996 FORMAT(//' MINIMIZATION RESULT OF VARIATIONAL PARAMETERS:',8F10.5, X/((48X,8F10.5))) 897 FORMAT( ' WARNING, YOU ARE ATTEMPTING TO RUN DR DATA WHICH REQUI XRES THE RESTEMP FILE, PLEASE RECOMPILE WITH RESTART ON, MEANWHILE' X,' DR HAS BEEN SWITCHED OFF BY SR.MINIM ') 896 FORMAT( ' ***ERROR, SR.MINIM IS UNABLE TO ASSIGN ANY VALUE OF N T XO YOUR VALENCE ORBITALS ') 894 FORMAT(' N=',I4,5X,'L=',I3) 893 FORMAT(25X,'NSW=',I3) 892 FORMAT(35X,'NRAD=',I5) 891 FORMAT(2X,'NV=',I5,2X,'LV=',I5,7X,'K',20I5) 881 FORMAT(/' MDEN=',I2,3X,'ELECTRON DENSITY=',1PE8.2,'CM-3',3X, X'TEMPERATURE*K=',0PF7.2,'RYD',3X,'GAMMA=',0PF5.2,3X,'DEBYE=',F7.2 X,3X,'R0=',F7.2/ X' **** ',5X,'**************** ',15X,'************* ',13X, X'***** ',8X,'***** ',10X,'**') 512 FORMAT(A4) C END C C ******************* C SUBROUTINE MINIM0(MPRNT0,NLAM0,NVAR0,DEXTRE,IMXIT,TVARY0,ICM,ICP) C C----------------------------------------------------------------------- C C SR.MINIM0 READS USER INPUT FOR THE ANAYLTIC BRANCH, C PERFORMS CHECKS ON IT AND INITIALIZES A RUN C C----------------------------------------------------------------------- cparc !par cpar use comm_interface, only : iam !par C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) PARAMETER (MXD12=100) PARAMETER (MXD14=100) PARAMETER (MXD15=100) PARAMETER (MXD24=2*MAXGR) C PARAMETER (MJH0=10) !*MUST* BE SAME AS IN SR.RADIAL C PARAMETER (DKCM=109737.31D0) PARAMETER (DZERO=0.0D0) PARAMETER (D1P2=1.0D2) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M5=1.0D-5) PARAMETER (D1P5M7=1.5D-7) PARAMETER (D1M8=1.0D-8) PARAMETER (D1M9=1.0D-9) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DCON1=1.625D0) PARAMETER (DELW=D1M5) C CHARACTER(LEN=3) RAD,RADOUT,POTOUT,POTL,ORTHOG,STONLZ,FAC CHARACTER(LEN=4) CODE,POTIN,PPOT,MYRGE CHARACTER(LEN=6) PRINT,TCC C LOGICAL BPRINT,BPRNT0,HFF,BSTO,BORT,BCORR,BJUMP,BRAD,BDR,BJUMP2 X,BPASS1,BNAME,BREL,BJUMPR,BFOT,BALAN,BMVD,BECOR,BFIX,EX C DIMENSION DEXTRE(MXVAR),IBUF(MXVAR),BUF(MXVAR) X,IFYX(MXVAR),DUM(MAXGR),IDUM(MAXGR) C COMMON /BASIC/NF,KVAR,HFF,MGAP(9) COMMON /CADJ/DADJUS(MXVAR),DF0,IEQUAL(MXVAR),ICOUNT COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TDUM,MEND COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /MQVC/MDUM,KCUT0,QGAP(2),NEL(MAXGR,MAXCF) COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /WEIGHT/WGHT(MAXTM),INDEXW(MAXTM) COMMON /CALAN/DALAN(MXVAR),BALAN COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE c COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTSS,NTJ(MAXCF),NFJ(MAXLV) c X ,KUTSO COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ESKPL,ESKPH,BECOR COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDEL/TOLB,TOLE,DELELS(MAXTM,2),DELEIC(MAXLV,2),MDELE X ,MULTS,ISHFTLS,ISHFTIC,NOBS COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBHF/MHF,MRAD,MSTEP !,xmax COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBMIX/CMXLSA,CMXLSR,CMXICA,CMXICR COMMON /NRBNAM/BNAME,NF0 c COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) c X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 c COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBPLS/DENS(MXD15),TKAYS(MXD15),NDEN COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC0 X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBTCC/KTCC,MTCC,NTCC,NENERG COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD COMMON /NRBWGT/EIMXLS,EIMXIC,WLG1,WLG2,IWGHT,IOPTIM,NRSLMX X ,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN COMMON /NRBZSP/ZESP(MAXLL),IZESP,NWRM common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) COMMON /PJSLIM/ECNTRB,ITANAL C EQUIVALENCE (RMIN1,WLG1), (RMIN2,WLG2), (RNUKE,RNUK) C C NAMELIST/SMINIM/NZION,INCLUD,MEXTRE,MGRP,MDEN,MPRINT,ITOL,JPRINT X,PRINT,IMAXIT,MPNCH,KUTCA,MRED,IORT,MDELE,MULTS,M,MHF,MCFMX,MAXLAM X,MEXPOT,ORTHOG,NLAM,NVAR,POTL,RADOUT,POTIN,POTOUT,BALAN,ALFD,RCUT X,PPOT,NDEN,MPSEUD,IPOLFN,MSTEP,IDIAG,IWGHT,WLG1,WLG2,RAD,JRAD,TCC X,RMIN1,RMIN2,ISHFTLS,ISHFTIC,CMXLSA,CMXLSR,CMXICA,CMXICR,TOLE,QED X,IFIX,NFIX,TOLB,RZERO,IREL,INUKE,RNUKE,SKIN,ATM,TK0,KCUT,IGAGR X,JUPMX,JUPMN,JLOWMX,JLOWMN,LUPMX,LUPMN,LLOWMX,LLOWMN,IOPTIM,MCFSTO X,NLAMD,NLAMQ,NVARD,NVARQ,ALAV,RCAV,SCALER,STONLZ,TVARY,MAXE,NPE X,ECORR,ESKPL,ESKPH,ECNTRB,ITANAL,NOCC,FAC,MRAD,ICAV,AJUSTX,ZESP X,IZESP,IBWRM,EIMXLS,EIMXIC,NRSLMX,NMETAR,NMETARJ,ibreit,irtard C X !,xmax C PI=ACOS(-DONE) C C SOME INITIALIZATIONS. C BDR=IDR.NE.0 !'DR' LOOPING OVER DUMMY RYDBERG BPASS1=.TRUE. !.T. FOR FIRST NL-LOOP, THEN .F. MAUTO=0 !CONTROLS ACCESS TO RADWIN/RADCON MXBOX=-1 !BOX ORBITAL POINTS (INTERNAL) C IF(IEQ(0).LT.0)MXBORB=-IEQ(0) !FOR NON-UNIQUE BASIS C C SET-UP ORBITAL INFO,SCALING PARAMETERS ETC. C TYPE OF ORBITAL I FLAGGED BY USER VIA QN(I), CONVERT TO INTERNAL C SCREEN(I) FLAG. C IV=0 !INITIALIZE NO. OF RYDBERG ORBS NGROUP=0 !HIGHEST NL-SUBSHELL INDEX OCCUPPIED NOLD=0 !HIGHEST L ORBITAL INDEX MION=NW+NF !TOTAL NUMBER OF ELECTRONS IPIG=1 !IN CASE RADCON NOT CALLED NWRM=NW MAXN=0 ICC=0 iswch=0 C DO I=1,MAXGR !PI INDEX DO J=1,I NFOSS(I,J)=0 ENDDO IVAL(I)=0 !DUMMY RYDBERG ORBITAL FLAG FACT(I)=DONE MCFSTO(I)=0 !STO CF NOS. TEL(I)=DZERO !POTL OCCUPATION NOS DORIG(I)=DONE !TEST rnorm(i)=done C IF(DEY(I).NE.DZERO)THEN !ORBITAL EXISTS IN A CONFIG NGROUP=I IF(QL(I).GT.NOLD)NOLD=QL(I) C IF(QN(I).LT.70)THEN !N=1-69, NORMAL INTERNAL BOUND ORBITAL NE=QN(I) MAXN=MAX(MAXN,NE) NE=(NE-1)*NE*(2*NE-1) NE=NE/3 L=QL(I)/2 NE=NE+QL(I)+1+L*QL(I) IF(NE.GE.MION)NE=MION-1 SCREEN(I)=NE ELSEIF(QN(I).LT.80)THEN !N=70-79: RADWIN EXTERNAL ORBITAL SCREEN(I)=3999 ELSEIF(QN(I).LT.90)THEN !N=80-89: DUMMY RYDBERG ORBITAL iswch=1 IVAL(I)=1 IV=IV+1 SCREEN(I)=MION-1 ELSE !N=90-99: CONTINUUM ORBITAL iswch=1 ICC=ICC+1 C IVAL(I)=0 C IV=IV-1 SCREEN(I)=9999 ENDIF ENDIF ENDDO C IF(ISCALR.GT.0)NGROUP=MAX(NGROUP,ISCALR) !FOR SLATER SCALING C IOPTIM=0 !OPTIMIZATION SWITCH NOLD=NOLD/2+1 !MAX NO L-DEPENDENT SCALING PARAMETERS ITOL0=7 !DEFAULT ACC OF ORBITALS DEL(E)/E.LT.10**(-ITOL0) MORT=1 !ORTHOG SWITCH, RESET BY USER IORT INCLUD=0 !SEE INPUT BELOW MEXTRE=0 !SEE INPUT BELOW C C C 10 OLD ISOELECTRONIC RE-ENTRY POINT C NPARAM=NOLD !RESET NO SCALING PARAMETERS ITOL=0 !SEE ITOL0 ABOVE IMAXIT=0 !NO OF ITERATIONS IN VA04A TVARY=D1M2 !MAX VARY OF SCALE PER ITERATION NLSTOE=-18 !STO NL SCREEN BEYOND AR-LIKE JUPMX=MAXLV !MAX UPPER LEVEL FOR RADIATIVE OUTPUT JUPMN=2 !MIN UPPER " " " JLOWMX=JUPMX-1 !MAX LOWER " " " JLOWMN=1 !MIN LOWER " " " LUPMX=MAXTM !MAX UPPER TERM FOR RADIATIVE OUTPUT LUPMN=2 !MIN UPPER " " " LLOWMX=LUPMX-1 !MAX LOWER " " " LLOWMN=1 !MIN LOWER " " " EIMXLS=1 !MAX LS ION ENERGY FOR AUGER RESOLUTION EIMXIC=1 !MAX IC " " " " NRSLMX=10000 !MAX RESOLVED LOWER N-VALUE IF ABOVE ON NMETAR=0 !MAX NO TERMS FOR AUGER RESOLUTION NMETARJ=0 !MAX NO LEVELS FOR AUGER RESOLUTION ECORR=-9999999 !CORRELATION ABOVE ECORR ESKPL=-1 !CORRELATION BETWEEN ESKPL ESKPH=-2 !AND ESKPH c xmax=-done C C----------------------------------------------------------------------- C C NAMELISTED INPUT (PREFERRED) C C----------------------------------------------------------------------- C IF(BNAME)THEN C IF(INCLUD.EQ.0.AND.MEXTRE.GT.1000)BPASS1=.TRUE. IF(.NOT.BPASS1)GO TO 95 !NO TERMINATOR OR ISO FOR NAME - RETURN BPASS1=.FALSE. C C FREQUENTLY USED INPUTS C NZION=0 !NUCLEAR CHARGE (<0 TF, >0 STO, 0 STOP) INC0=INCLUD !NO. TERMS TO INCLUDE IN ENERGY MINIM INCLUD=0 !>0 LOWEST, <0 TERMS TO BE SPECIFIED NLAM=0 !NO. SCALING PARAMETERS NVAR=0 !NO. VARIATIONAL PARAMETERS MCFMX=0 !NO. STO POTENTIAL CF'S PRINT='FORM' !'UNFORM' UNFORMATTED OUTPUT (SHORT) MAXE=-1 !MAX CONTINUUM ENERGY FOR PI (&DW) ICAV=0 !.NE.0 APPLY CONFIG. AV. ENERGY CORREC AJUSTX=DONE !GLOBAL CONFIG. AV. EXCHANGE SCALING C C OCCASIONALLY NEEDED C MSTEP=0 !STEP LENGTH PROP 1/2**MSTEP MRED=0 !+/- SUBTRACT/ADD ELECTRNS IN MODEL POT ORTHOG=' ' !CHANGE DEFAULT ORTHOG. 'YES'=' ' IORT=-1 !DITTO RADOUT=' ' !OUTPUT RADIAL FILE E.G. FOR R-MATRIX NLAMD=0 !DIPOLE TF PERTBN NLAM NLAMQ=0 !QUAD TF PERTBN NLAM NVARD=0 !DIPOLE TF PERTBN NVAR NVARQ=0 !QUAD TF PERTBN NVAR IPOLFN=9999 !TYPE OF POLARIZATION POTENTIAL DO I=0,3 !1-BODY POLARIZATION SPECIFICATION ALFD(I)=DZERO RCUT(I)=DZERO ENDDO ALAV=DZERO !2-BODY POLARIZATION SPECIFICATION RCAV=DZERO ! DITTO SCALER=DONE !COWAN SLATER INTEGRAL SCALE FACTOR ISHFTLS=0 !TERM ENERGY CORRECTIONS ISHFTIC=0 !PLUS LEVEL ENERGY CORRECTIONS RZERO=-DONE !RADIUS OF BOX STATES INUKE=999 !FINITE NUCLEUS TYPE RNUK=-DONE !FINITE NUCLEUS RADIUS ATM=-DONE !NUCLEAR MASS IZESP=0 !ZETA S-O SCREENING PARAMETER DO I=1,MAXLL ZESP(I)=DONE ENDDO IBWRM=0 !MAX R-MATRIX CLOSED SHELL ORB. NO. C C THE REST ARE HARDLY EVER USED OR NEEDED, EXCEPT FOR TESTING C IREL=999 !SMALL CPT FLAG & TYPE OF S-O SCREENING TK0=-DONE !NON-UNIFORM NUCLEUS SCALING PARAMETER SKIN=DZERO !NUCLEAR SKIN DEPTH IGAGR=0 !NUMERICAL GAUGE FOR RELATIVISTIC ORBS irtard=1 !RETARDATION SWITCH FOR MULTIPOLE RADTN ibreit=0 !GENERALIZED BREIT SWITCH QED=0 !QED CORRECTIONS MEXTRE=0 !HISTORIC MIX OF NLAM AND NVAR M=0 !HISTORIC MSTEP MEXPOT=-999 !LOCAL (STO) EXCHANGE POTENTIAL NOCC=0 !NO. OCCUPATION NOS FOR STO/SCF STONLZ=' ' !YES/NO: STO NL-SUBSHELL SCREENING IWGHT=1 !TERM WEIGHTING FACTOR FOR ENERGY SUM MDEN=0 !TYPE OF PLASMA POTENTIAL NDEN=0 !NO. OF TEMP/DENSITY PAIRS KCUT=-999 !OVERRIDE ALGEB KCUT... NPE=12 !MIN NUMBER STEPS PER PI FOR CONTINUUM ITANAL=0 !DETAIL CI FOR ITANAL TERMS ECNTRB=DZERO !WHICH CONTRIB ECNTRB WAVE NOS TO TERM PPOT=' ' !SELF-CONSISTENT POTENTIAL IFIX=0 !NO OF ORBS TO BE FIXED IN SCF C C CAN'T REMEMBER THE LAST TIME THESE WERE USED C MAXLAM=1000 NFIX=0 MGRP=0 FAC=' ' MPRINT=-11 JPRINT=-11 MPNCH=0 KUTCA=-1 TCC='NO' MDELE=0 MULTS=0 MHF=0 MRAD=0 POTL=' ' POTOUT=' ' POTIN=' ' BALAN=.false. MPSEUD=0 IDIAG=0 WLG1=-DONE WLG2=-DONE RAD=' ' CMXLSA=D1M5 CMXLSR=D1M5 CMXICA=D1M5 CMXICR=-D1M5 TOLE=DZERO TOLB=-DONE C C READ(5,SMINIM,END=999,ERR=999) ! <-------------------- NAMELIST C C IF(ICAV.NE.0)THEN IF(IRLX.NE.0)THEN ICAV=0 WRITE(6,*) WRITE(6,*)'*** RE-SETTING ICAV=0 SINCE RELAXED ORBITAL', X ' BASIS PREVIOUSLY SPECIFIED.' ELSEIF(ICAV.GT.0)THEN !BASIC SET-UP NZION=-IABS(NZION) !MUST HAVE STO IF(PPOT.EQ.' ')PPOT='SCCA' !SELF-CONSISTENT IF(MCFMX.EQ.0)THEN !AV. OCC. NOS OVER SPEC MCFMX=MIN(KCUT,KCUT0,KMAX) IF(MCFMX.LE.0)MCFMX=-KMAX ENDIF ENDIF ENDIF C IF(KCUT.GE.0.AND.KCUT.NE.KCUT0)THEN IF(KCUT.EQ.0)KCUT=999 WRITE(6,*) IF(KCUT*KCUT0.GT.KCUT0*KCUT0)THEN WRITE(6,*)"*** WARNING: CORRELATION FLAG HAS BEEN REMOVED ", X "FROM CF'S",KCUT0+1," THRU",KCUT,", RATES INCOMPLETE!" WRITE(0,*)"*** WARNING: ALGEB CORRELATION SETTING HAS BEEN", X " OVERRIDDEN!" ELSE WRITE(6,*)"NOTE: CF'S FROM",KCUT+1,"UPWARDS HAVE BEEN ", X "FLAGGED AS CORRELATION - MORE EFFICIENT TO DO SO IN ALGEB!" ENDIF KCUT0=KCUT ENDIF C IF(JPRINT.NE.-11)MPRINT=JPRINT IF(PRINT.EQ.'UNFORM')MPRINT=-33 BPRNT0=MOD(MPRINT,10).NE.-3 C KTCC=0 IF(TCC.EQ.'STGICF')KTCC=1 IF(TCC.EQ.'JAJOM')KTCC=-1 IF(KTCC.EQ.0.AND.TCC.NE.'NO')KTCC=1 IF(MPNCH.NE.0)THEN MPNCH0=1 IF(MPNCH.LT.0)MPNCH0=-1 M0=IABS(MOD(MPNCH,4)) IF(KUTCA.GE.0.AND.M0.EQ.1)MPNCH=MPNCH+2*MPNCH0 IF(KUTCA.LT.0.AND.M0.GT.1)KUTCA=0 IF(KTCC.NE.0.AND.MOD(M0,2).EQ.0)MPNCH=MPNCH+MPNCH0 IF(KTCC.EQ.0.AND.MOD(M0,2).NE.0)KTCC=1 ELSE IF(KUTCA.GE.0)MPNCH=-2 IF(KTCC.NE.0)MPNCH=MPNCH-1 ENDIF C M0=MAX(M,MSTEP) C MAXLAM=IABS(MAXLAM) TOLE=TOLE/DTWO !CONVERT TO A.U. C IF(CMXICR.LT.DZERO)THEN IF(MPOLE.GE.4)THEN CMXICA=D1M8 CMXICR=D1M8 ELSE CMXICR=D1M5 ENDIF ENDIF C IF(MPSEUD.GT.0)MPSEUD=MB IF(MPSEUD.LT.0)MPSEUD=-MB C IF(IPOLFN.LT.0)THEN WRITE(0,*)'*** RESETTING IPOLFN=0 (.LT.0 INTERNALLY RESERVED)' WRITE(6,*)'*** RESETTING IPOLFN=0 (.LT.0 INTERNALLY RESERVED)' IPOLFN=0 ENDIF C IF(NLAMD.NE.0.or.nvard.gt.0)IPOLFN=-1 IF(NLAMQ.NE.0.or.nvarq.gt.0)IPOLFN=-2 IF(NZION.LT.0.AND.IPOLFN.LT.0)THEN WRITE(6,*)' *** SR.MINIM: ERROR, CANNOT USE PERTURBED TF', X ' WITH STO! SET NZION.GT.0, OR SWITCH-OFF PERTURBN.' WRITE(0,*)'CANNOT USE PERTURBED TF WITH STO!' GO TO 998 ENDIF C III=INCLUD INCLUD=INC0 IF(NVAR.LT.0)THEN ISVAR=-1 NVAR=-NVAR ELSEIF(NVAR.GT.0)THEN ISVAR=1 ELSE ISVAR=1 IF(NVARD.LT.0.OR.NVARQ.LT.0)ISVAR=-1 ENDIF IF(NVARD.LT.0)NVARD=-NVARD !NVAR OVERRIDES IF(NVARQ.LT.0)NVARQ=-NVARQ ! " " IF(TVARY.LE.D1M5)TVARY=D1M2 C C INITIALIZE FOR POLARIZATION C IF(ALFD(0).NE.DZERO)THEN !USER HAS STARTED AT 0 DO I=3,1,-1 ALFD(I)=ALFD(I-1) RCUT(I)=RCUT(I-1) ENDDO ENDIF IF(ALFD(1).EQ.DZERO)ALFD(1)=ALFD(2) IF(ALFD(2).EQ.DZERO)ALFD(2)=ALFD(1) IF(ALFD(3).EQ.DZERO)ALFD(3)=ALFD(2) IF(RCUT(1).EQ.DZERO)RCUT(1)=RCUT(2) IF(RCUT(2).EQ.DZERO)RCUT(2)=RCUT(1) IF(RCUT(3).EQ.DZERO)RCUT(3)=RCUT(2) IF(ALAV.EQ.DZERO)THEN DO I=1,3 ALAV=ALAV+ALFD(I) ENDDO ALAV=(DONE/DTHREE)*ALAV ENDIF IF(RCAV.EQ.DZERO)THEN DO I=1,3 RCAV=RCAV+RCUT(I) ENDDO RCAV=(DONE/DTHREE)*RCAV ENDIF IF(ALFD(1)*RCUT(1).NE.DZERO)THEN !SWITCH-ON POLARIZATION IF(IPOLFN.LT.0)THEN WRITE(6,*)'***SR.MINIM: CANNOT USE PERTURBED TF WITH', X ' NORCROSS/BAYLISS POLARIZATION POTENTIAL' WRITE(0,*)'***CANNOT MIX NORCROSS/BAYLISS WITH PERTURBED TF' GO TO 998 ENDIF IF(IPOLFN.EQ.9999)IPOLFN=1 !NORCROSS IPOLF1=MOD(IPOLFN,10) IPOLF2=IPOLFN/10 IF(IPOLF1.GT.2)IPOLF1=2 !BAYLISS IF(BPRNT0)THEN IF(IPOLF1.EQ.1)WRITE(6,882)(I-1,ALFD(I),RCUT(I),I=1,3) IF(IPOLF1.EQ.2)WRITE(6,883)(I-1,ALFD(I),RCUT(I),I=1,3) ENDIF IF(IPOLF2.GT.0)THEN IF(IPOLF2.GT.2)IPOLF2=2 IF(BPRNT0)THEN IF(IPOLF2.EQ.1)WRITE(6,880)ALAV,RCAV IF(IPOLF2.EQ.2)WRITE(6,881)ALAV,RCAV ENDIF ENDIF IPOLFN=10*IPOLF2+IPOLF1 ELSE IF(IPOLFN.GT.0)IPOLFN=0 ENDIF DO I=1,3 ALFD(I)=ALFD(I)/DTWO ENDDO C C SET LOW-LEVEL VARIABLES BASED ON USER INPUT C IF(RADOUT.EQ.'YES')THEN IF(BDR)THEN MRAD=0 !SET INTERNAL FLAG WRITE(6,*)'*** RE-SETTING RADOUT="NO" SINCE &DRR IN USE' WRITE(0,*)'*** RE-SETTING RADOUT="NO"' ELSE MRAD=-13 !NO LONGER NEED TO SET UNIT ENDIF ELSEIF(RADOUT.EQ.'NO')THEN MRAD=0 ELSEIF(RADOUT.NE.' ')THEN WRITE(0,*)'*** UNRECOGNIZED OPTION FOR RADOUT...' WRITE(6,878)RADOUT GO TO 998 ENDIF C IF(POTOUT.EQ.'YES')THEN !GIVES RADIAL AS WELL IF(BDR)THEN MRAD=0 !SET INTERNAL FLAG WRITE(6,*)'*** RE-SETTING POTOUT="NO" SINCE &DRR IN USE' WRITE(0,*)'*** RE-SETTING POTOUT="NO"' ELSE MRAD=MRAD-100 ENDIF ELSEIF(POTOUT.EQ.'NO')THEN MRAD=MOD(MRAD,100) ELSEIF(POTOUT.NE.' ')THEN WRITE(0,*)'*** UNRECOGNIZED OPTION FOR POTOUT...' WRITE(6,877)POTOUT GO TO 998 ENDIF C IF(POTIN.EQ.'HFFC')THEN MHF=1 ELSEIF(POTIN.EQ.'YES'.OR.POTIN.EQ.'FAC')THEN MHF=2 ELSEIF(POTIN.EQ.'HFNL')THEN MHF=3 ELSEIF(POTIN.EQ.'NO')THEN MHF=0 ELSEIF(POTIN.NE.' ')THEN WRITE(0,*)'*** UNRECOGNIZED OPTION FOR POTIN...' WRITE(6,879)POTIN GO TO 998 ENDIF C IF(POTL.EQ.'STO')NZION=-IABS(NZION) IF(POTL.EQ.'TF')NZION=IABS(NZION) C IF(ORTHOG.EQ.'L')IORT=1 IF(ORTHOG.EQ.'NO'.OR.(ORTHOG.EQ.' '.AND.NZION.LT.0))IORT=-3 IF(ORTHOG.EQ.'LPS')IORT=-4 IF(IEQ(0).LT.0)IORT=-3 !NON-UNIQUE BASIS='RLX' IN SALGEB IF(ORTHOG.EQ.'BOX')IORT=-5 IF(IORT.EQ.-5)THEN IF(RZERO.LE.DZERO)THEN WRITE(6,*)'*** ERROR: USER MUST INPUT RZERO.GT.0 FOR BOX' WRITE(0,*)'*** ERROR: USER MUST INPUT RZERO.GT.0 FOR BOX' GO TO 998 ENDIF MXBOX=0 ENDIF C IF(STONLZ.EQ.'YES')NLSTOE=0 IF(STONLZ.EQ.'NO')NLSTOE=999 C C INITIALIZE FOR RELATIVISTIC ORBITALS C IF(BREL)THEN IF(IORT.EQ.-4)THEN WRITE(6,*)'*** RELATIVISTIC LPS NOT CODED...' WRITE(0,*)'*** RELATIVISTIC LPS NOT CODED...' GO TO 998 ENDIF IF(IORT.EQ.-5)THEN WRITE(6,*)'*** RELATIVISTIC BOX STATES NOT CODED...' WRITE(0,*)'*** RELATIVISTIC STATES NOT CODED...' GO TO 998 ENDIF IF(ORTHOG.EQ.' ')IORT=-3 ENDIF C ELSE C C----------------------------------------------------------------------- C HISTORIC NON-NAMELIST FIXED FORMAT INPUT: CAN LOOP OVER MULTIPLE NZION C N.B. ISOELECTRONIC LOOP HAS BEEN DISABLED. C C NOTE: FOR THE NEXT ISOEL STRUCTURE RUN ONE CAN START WITH THE OLD C SCALING (PUT MEXTRE=-NEXTRE) OR SCREENING PARAMETERS (PUT NGRP=0) C C CURRENTLY, THESE VARIABLES CAN ONLY BE CHANGED WITH NAMELIST INPUT. C----------------------------------------------------------------------- C NLAM=0 NVAR=0 ISVAR=1 NDEN=0 IFIX=0 NFIX=0 MAXLAM=1000 BALAN=.false. MPSEUD=0 IDIAG=0 IWGHT=1 WLG1=-DONE WLG2=-DONE JRAD=0 RAD=' ' PPOT=' ' FAC=' ' MEXPOT=-1 NOCC=0 IPOLFN=0 DO I=1,3 ALFD(I)=DZERO RCUT(I)=DZERO ENDDO ALAV=DZERO RCAV=DZERO IZESP=0 IBWRM=0 ISHFTLS=0 ISHFTIC=0 CMXLSA=D1M5 CMXLSR=D1M5 CMXICA=D1M5 CMXICR=D1M5 TOLE=DZERO TOLB=-DONE RZERO=-DONE IREL=999 INUKE=999 INUK0=2 IGAGR=0 irtard=1 ibreit=0 QED=0 RNUK=-DONE ATM=-DONE SKIN=DZERO TK0=-DONE SCALER=DONE MAXE=-1 ITANAL=0 ICAV=0 AJUSTX=DONE C C READ(5,995)NZION,III,MEXTRE,MGRP,MDEN,MPRINT,MEXPOT,MPNCH,KUTCA X ,MRED,IORT,MDELE,MULTS,M0,MHF,MCFMX C C C IF(MPRINT.EQ.0.AND.BDR)MPRINT=-33 IF(MPRINT.EQ.0)MPRINT=-11 BPRNT0=MOD(MPRINT,10).NE.-3 C ENDIF C C----------------------------------------------------------------------- C C END OF PRIMARY USER INPUT. SUBSEQUENT READS DEPENDENT ON THIS. C C----------------------------------------------------------------------- C IF(NZION.EQ.0)GO TO 95 !<---------------------- TRUE RETURN C IF(IABS(NZION).GT.92)THEN WRITE(6,*)' HERE BE MONSTERS, Z>92 - EXITING...' WRITE(0,*)' HERE BE MONSTERS, Z>92 - EXITING...' GO TO 998 ENDIF C WRITE(6,993) C C C FLAG CORRELATION BY ENERGY, THEN NOT NICELY ORDERED AS ALGEBRAIC CORR. C BECOR=ESKPH.GT.ESKPL.AND.ESKPL.GE.DZERO.OR.ECORR.GT.DZERO IF(ECORR.LE.DZERO)ECORR=9999999 C C RELATIVISTIC GAUGE: IGAGR.GT.0 CONVERT 1/R INTEGRALS TO R**2 C .LT.0 LEAVE ALONE. C IF(IGAGR.EQ.0)THEN IF(BREL)THEN IGAGR=1 ELSE IGAGR=-1 ENDIF ENDIF C C RESTRICT RADIATIVE DATA (DEFAULT ALL) C BOUND MEANS NON-AUTOIONIZING, FREE MEANS AUTOIONIZING C TREAT STATES WITHIN TOLE RYD OF IONIZATION LIMIT AS EITHER. C C RAD='BB' BOUND-BOUND C RAD='BF' OR 'FB' BOUND-FREE C RAD='FF' FREE-FREE C RAD='BBF' OR 'FBB' BOUND-BOUND + BOUND-FREE C RAD='BFF' OR 'FFB' BOUND-FREE + FREE-FREE C IF(RAD.EQ.'BB')JRAD=1 IF(RAD.EQ.'BF'.OR.RAD.EQ.'FB')JRAD=2 IF(RAD.EQ.'FF')JRAD=3 IF(RAD.EQ.'BBF'.OR.RAD.EQ.'FBB')JRAD=4 IF(RAD.EQ.'BFF'.OR.RAD.EQ.'FFB')JRAD=5 IF(JRAD.LT.0.OR.JRAD.GT.5)JRAD=0 C C MINIMUM RADIATIVE RATES RETAINED: E1=(WLG1,RMIN1), E2=(WLG2,RMIN2) C C MINIMUM MIXING COEFFICIENTS TREATED AS NON-ZERO (1.E-5 DEFAULT) C FOR LS AND IC AUTOIONIZATION AND RADIATIVE RATES: CMXLS/IC/A/R C C IDIAG .LE. 0 USE HOUSEHOLDER DIAGONALIZATION IN DIAGON/DIAGFS. C -1 DOES NOT APPLY TESTS THAT DEPEND ON CF LABEL. C IDIAG .GT. 0 USE JACOBI METHOD INSTEAD. C C MPSEUD .NE. 0 USE MODEL POTENTL FOR CORE DEFINED BY KCOR1,2 IN ALGEB1 C .GT. 0 SPIN-ORBIT FROM BLUME & WATSON, SO CORE ORBITALS NEEDED. C .LT. 0 " POTENTIAL DERIVATIVE (TBD). C C MAXLAM IS MAX LAMDA FOR WHICH SLATER AND TWO-BODY FINE-STRUCTURE C INTEGRALS ARE EVALUATED (SHOULD BE SET IN ALGEB). C C MCFMX .GT. 0, FOR EACH ORBITAL 1,...MCFMX READ CONFIGURATION C NUMBER TO BE USED BY STOPOT TO GENERATE MODEL POTENTIAL. C C MDEN .GT. 0 GENERATE PLASMA SCREENING POTENTIAL & READ DENSITY+TEMP C .EQ. 1 OR PPOT='DH' LINEAR DEBYE-HUCKEL MODEL POTENTIAL C .EQ. 2 OR PPOT='IS' ION-SPHERE MODEL POTENTIAL C .GE. 3 OR PPOT='KS' OR 'SC' SELF-CONSIST ION-SPHERE (KOHN-SHAM) C .LT. 0 NO PLASMA POTENTIAL, ITERATES SELF-CONSISTENT (NEEDS STO) C PPOT .EQ. 'SCCA' S.C. CONFIGURATION AVERAGE POT (NON-LOCAL EXCHANGE) C .EQ. 'SCFM' OR 'SCLX' " USING FURNESS & MCCARTHY LOCAL EXCHANGE C IF(MDEN.LE.0)THEN IF(PPOT.EQ.'SCCA')THEN !SELF-CONSISTENT CONFIG. AVERAGE POT IF(MDEN.EQ.0)MDEN=-10 IF(MEXPOT.EQ.-999)MEXPOT=0 ELSEIF(PPOT.EQ.'SCFM'.OR.PPOT.EQ.'SCLX')THEN !FURNESS & MCCARTHY IF(MDEN.EQ.0)MDEN=-10 IF(MEXPOT.EQ.-999)MEXPOT=1 ELSEIF(PPOT.EQ.'DH')THEN MDEN=1 ELSEIF(PPOT.EQ.'IS')THEN MDEN=2 ELSEIF(PPOT.EQ.'KS'.OR.PPOT.EQ.'SC')THEN MDEN=3 ELSEIF(PPOT.NE.' ')THEN WRITE(6,*)'UNRECOGNIZED PPOT OPTION: "',PPOT,'"' WRITE(0,*)'UNRECOGNIZED PPOT OPTION: "',PPOT,'"' GO TO 998 ENDIF ELSEIF(PPOT.NE.' ')THEN WRITE(6,*)'IGNORING PPOT INPUT: "',PPOT,'", AS MDEN=',MDEN WRITE(0,*)'IGNORING PPOT INPUT: "',PPOT,'", AS MDEN=',MDEN ENDIF C IF(MDEN.NE.0)THEN C C MCFMX IGNORED IF NOCC OCCUPATION NOS SPECIFIED C IF(MCFMX.GT.0)THEN !CANNOT USE FAC IF(MOD(NOCC,1000).GT.0)THEN WRITE(6,*)'*** MCFMX CF SPECIFICATION OVERRIDDEN BY NOCC' WRITE(0,*)'*** MCFMX CF SPECIFICATION OVERRIDDEN BY NOCC' ELSE IF(FAC.EQ.'YES')THEN WRITE(6,*)'*** MCFMX.GT.0 CONFLICTS WITH FAC="YES"...' WRITE(0,*)'*** MCFMX.GT.0 CONFLICTS WITH FAC="YES"...' GO TO 998 ENDIF FAC='NO' ENDIF ENDIF C C FAC='YES' MIRRORS FAC USING SINGLE AVERAGE POTENTIAL C ='NO' USES ORBITAL DEPENDENT, AND OTHOGONALIZES CASE NL. C IF(FAC.EQ.' ')FAC='NO' IF(FAC.EQ.'YES')THEN IF(NOCC.LT.0)NOCC=-NOCC !SO FLAG>0 NOCC=NOCC+1000 !ALLOW FOR 0 ELSEIF(FAC.EQ.'NO')THEN IF(NOCC.GT.0)NOCC=-NOCC !SO FLAG<0 NOCC=NOCC-1000 !ALLOW FOR 0 ELSE WRITE(6,*)'UNRECOGNIZED FAC OPTION: "',FAC,'"' WRITE(0,*)'UNRECOGNIZED FAC OPTION: "',FAC,'"' GO TO 998 ENDIF C IF(IEQ(0).LT.0.AND.NOCC.GT.0)THEN WRITE(6,*)'*** RELAXED ORBITALS CONFLICT WITH FAC="YES"...' WRITE(0,*)'*** RELAXED ORBITALS CONFLICT WITH FAC="YES"...' GO TO 998 ENDIF C C NEED NL-SUBSHELL RESOLUTION FOR SELF-CONSISTENT C IF(MDEN.LT.0.AND.NLSTOE.NE.0)THEN IF(NLSTOE.GT.0)THEN WRITE(6,*)'*** RESETS FOR NL-SUBSHELL POTENTIAL RESOLUTION' WRITE(0,*)'*** RESETS FOR NL-SUBSHELL POTENTIAL RESOLUTION' ENDIF NLSTOE=0 ENDIF C C IF MDEN.EQ.0 THEN (ALL STATIC) C MEXPOT .LE. 0 HARTREE STO POTENTIAL (I.E. NON-EXCHANGE) C MEXPOT .EQ. 1 HARTREE-EXCHANGE LINDGREN & ROSEN (XK=0.65) C MEXPOT .EQ. 2 HARTREE-EXCHANGE LINDGREN & ROSEN (XK=1.00) C MEXPOT .GE. 3 HARTREE-EXCHANGE COWAN (XK=1.00) C IF MDEN.NE.0 THE ABOVE IS FIRST ITERATION ONLY. THEREAFTER C MEXPOT .LT. 0 HARTREE MULTIPOLE POTENTIAL C MEXPOT .EQ. 0 HARTREE- EXCHANGE-CONFIGURATION-AVERAGE C MEXPOT .GT. 0 STATIC PLUS FURNESS & MCCARTHY LOCAL EXCHANGE. C IF(MEXPOT.EQ.-999)MEXPOT=1 C IF(III.NE.0.AND.MEXPOT.LT.0)THEN !SINCE WE SCALE EXCHANGE WRITE(6,*)'***SR.MINIM: SETTING INCLUD=0 AS NON-EXCHANGE' X ,' SELF-CONSISTENT SOLUTION FLAGGED' WRITE(0,*)'***SR.MINIM: SETTING INCLUD=0, AS NX SC' III=0 ENDIF IF(MDEN.LT.0.AND.NZION.GT.0)THEN WRITE(6,*)'*** SR.MINIM: SELF-CONSISTENT SOLUTION REQUIRES', X ' STO FLAG, SETTING NZION.LT.0' WRITE(0,*)'***SR.MINIM: SETTING NZION.LT.0' NZION=-NZION ENDIF ENDIF C C MHF .NE. 0 OPERATION SEPARATED INTO C MRAD (OLD MHF.LT.0) AND MHF (AS MHF.GT.0) C SO THAT THEY CAN BE SET INDEPENDENTLY. C IF(MHF.GT.3)MHF=2 !FAC DEFAULT C C MHF .GT. 0 READ EXTERNAL POTENTIAL FROM FILE hffcin/potin C ***CHECK FORMATS IN SR.POTIN*** C .EQ. 1 ORIGINAL HARTREE-FOCK FROZEN-CORE (UNIQUE, USED FOR ALL) C .EQ. 2 FAC (UNIQUE, USED FOR ALL INTERNAL ORBITALS) C .EQ. 3 NL-DEPENDENT, IF NL NOT FOUND, THEN REVERT TO INTERNAL C C MRAD .LT. 0 WRITE P & Q FUNCTIONS AND MAYBE UNIQUE POTENTIAL TO radout C C IF(MRAD.LT.0)MRAD=100*(MRAD/100)-13 !NOW HARD-WIRED TO UNIT13 C C SET BREIT SWITCHES, & DEFAULT NUCLEUS: C IF(BREL)THEN IBREIT=IABS(IBREIT) !.LT.0 TEST ONLY IF(IREL.EQ.999)THEN IREL=1 IF(BFOT)IREL=2 ENDIF IF(ABS(IREL).EQ.2.AND.MHF.LT.0)THEN WRITE(6,*)'*** ILLEGAL INPUT COMBINATION IREL, MHF:',IREL,MHF WRITE(0,*)'*** ILLEGAL INPUT COMBINATION IREL, MHF' GO TO 998 ENDIF IF(INUKE.EQ.999)THEN INUKE=1 !FINITE, NON-UNIFORM (U6) IF(IABS(NZION).LE.30)INUKE=-1 !POINT ENDIF IF(INUKE.LT.0)THEN !POINT NUCLEUS INUK0=999999 ELSE !FINITE INUK0=2 ENDIF ELSE IF(IREL.EQ.999)IREL=1 IF(ABS(IREL).EQ.2)THEN WRITE(6,*)"*** ILLEGAL INPUT FOR CUP='LS/IC' : IREL=",IREL IREL=SIGN(1,IREL) WRITE(6,*)"*** WILL RE-SET IREL=",IREL WRITE(0,*)'*** ILLEGAL INPUT COMBINATION BREL AND IREL' X ,' - RE-SETTING' ENDIF ENDIF C IF(IZESP.GT.0)IREL=IABS(IREL) !SINCE SCREENING NUCLEAR IF(IBWRM.GT.0)THEN IF(IBWRM.GT.MB)THEN IF(NL000.GT.0)THEN WRITE(6,*)'*** ERROR, CANNOT RESET BLUME & WATSON, IBWRM=' X ,IBWRM,' WHEN TWO-BODY FINE-STRUCTURE PRESET' WRITE(0,*)'*** ERROR, CANNOT RESET BLUME & WATSON' X ,' WHEN TWO-BODY FINE-STRUCTURE PRESET' GO TO 998 ENDIF WRITE(6,*)'*** WARNING *** WARNING *** WARNING *** WARNING:' WRITE(6,*)'*** YOU ARE FORCING BLUME & WATSON CLOSED SHELLS' X ,' TO IBWRM=',IBWRM,' BEYOND THOSE SPECIFIED BY KCOR2=',MB WRITE(0,*)'*** WARNING *** WARNING *** WARNING *** WARNING:' WRITE(0,*)'*** YOU ARE FORCING BLUME & WATSON CLOSED SHELLS' X ,' BEYOND THOSE SPECIFIED SR.ALGEB' DO I=MB+1,IBWRM NWRM=NWRM+2*(QL(I)+1) ENDDO ELSE WRITE(6,*)'NOTE: USER IBWRM=',IBWRM,' .LE. KCOR2=',MB X ,' SO BLUME & WATSON UNCHANGED FROM AS DEFAULT' ENDIF ENDIF C C INPUT NUCLEAR CHARGE .LT. 0 IF REQUIRE SLATER-TYPE-ORBITAL POTENTIAL C INPUT NUCLEAR CHARGE .GT. 0 IF REQUIRE THOMAS-FERMI S.M. POTENTIAL C MSHELL=0 BSTO=NZION.LT.0 IF(BSTO)NZION=-NZION C C CHANGE NUMBER OF ELECTRONS C MION=NW+NF-MRED IF(MRED.NE.0)WRITE(6,990)MION,MRED C C SET NOMINAL ASYMPTOTIC CHARGE C NZA=NZION-MION C C ADJUST TO TARGET (I.E. REMOVE ANY RYD/CONT) C if(idw.eq.0)then DO I=1,MAXGR IF(DEY(I).NE.DZERO.AND.QN(I).GE.80)THEN NZA=NZA+1 !AS RYD/CONT INC IN MION GO TO 50 ENDIF ENDDO c else !mion does not inc. cont endif C 50 IF(NZA.LT.0)THEN WRITE(6,*)'*** CANNOT TREAT NEGATIVE IONS, INCREASE NZION TO:' X ,MION !,nzion,nza WRITE(0,*)'*** CANNOT TREAT NEGATIVE IONS, INCREASE NZION' GO TO 998 ENDIF C C NUMERICAL DEGENERATE ENERGY TOLERANCE (SYNC'ED WITH POST-PROCESSORS) C IF(TOLB.LT.DZERO)THEN IF(ICC.GT.0)THEN !FOR PP DZ=NZA*NZA TOLB=MAX(D1P5M7,D1M9*DZ*NZA) ELSE !NO PP TOLB=DZERO ENDIF ENDIF C C MSTEP=M CHANGES INITIAL STEP LENGTH DHNS(1), SEE BELOW, C MSTEP=10 DEFAULT, INCREASE MSTEP FOR SMALLER STEP C C NZ1=NZION-MION !HISTORIC NZ1=NZA C M=10 IF(NZ1.LT.5)M=11 IF(MDEN.GT.0)M=M+1 IF(NZ1.GT.30)M=11 IF(BDR)M=11 IF(BREL)THEN IF(NZ1.GE.88)THEN M=15 ELSEIF(NZ1.GE.50)THEN M=14 ELSEIF(NZ1.GE.38)THEN M=13 ELSEIF(NZ1.GE.28)THEN M=12 ELSE M=11 ENDIF ENDIF C IF(MA.EQ.0)THEN IF(NZION.GT.6.AND.NZ1.LT.5)M=M+1 IF(NZION.GT.9.AND.NZ1.LT.2)M=M+1 ENDIF IF(IORT.LE.-4)M=14 C C NOW SET TO ASYMPTOTIC CHARGE SEEN BY A (TRUE) TARGET ELECTRON C NZA=NZA+1 C if(idw.ne.0.and.maxe.le.0)then te1=maxn te1=nza/te1 te1=te1*te1 maxe=nint(te1) if(maxn.gt.mb+1)then te2=mb+1 te2=nza/te2 te2=te2*te2 maxe=nint(te2-te1) maxe=max(maxe,1) else maxe=nza endif maxe=5*maxe write(6,*)' *** SR.MINIM WARNING: IT IS STRONGLY RECOMMENDED' X ,' THAT YOU SET THE MAXIMUM RYD SCATTERING ENERGY, MAXE...' write(6,*)' I HAVE GUESSED MAXE=',MAXE cpar if(iam.eq.0)then !par write(0,*)' *** SR.MINIM WARNING: YOU' X ,' HAVE NOT SET THE MAXIMUM RYD SCATTERING ENERGY, MAXE!' write(0,*)' I HAVE GUESSED MAXE=',MAXE cpar endif !par endif C IF(MAXE.GT.0)THEN DHNS0=(DCON1/NZION)**(DONE/DTHREE)/ X (NZA**(DTWO/DTHREE)) !/(2**MSTEP) TE=MAXE TE=SQRT(TE) DHNSX=LOG(NPE*DHNS0*TE/PI)/LOG(DTWO) !NPE=NO PTS PER PI MM=INT(DHNSX)+MJH0 c write(0,*)m,mm,dhns0/2**mm M=MAX(M,MM) ELSE IF(BFOT.AND.M.LT.15)M=15 !ASSUME WORST CASE ENDIF IF(M0.GT.0)THEN IF(M0.LT.M)THEN WRITE(6,*)' *** WARNING IN SR.MINIM: YOU ARE REDUCING MSTEP', X ' BELOW THE RECOMMENDED VALUE OF',M WRITE(0,*)'*** WARNING: YOU ARE REDUCING MSTEP BELOW DEFAULT' ENDIF M=M0 ENDIF C MSTEP=M C C SOME RADIAL INITIALIZATIONS C IF(ITOL.EQ.0)ITOL=ITOL0 !TF POT ACCURACY C C NZA=MAX(1,NZION-MION+1) DHNS(1)=(DCON1/NZION)**(DONE/DTHREE)/ !INITIAL STEP X ((2**MSTEP)*NZA**(DTWO/DTHREE)) c write(0,*)mstep,mion,nza,dhns(1) C MAXRS=0 !RADIAL INDEX C C MULTS=0 DOES NOTHING C MULTS .LT. 0 APPLIES LS-COUPLING SELECTION RULES TO INTERMEDIATE C COUPLING RADIATIVE RATES IN SR.DIAGFS C MULTS .GT. 0 AS .LT. 0 BUT ONLY EVALUATES INTERMEDIATE COUPLING C RADIATIVE RATES FOR TERMS WITH SPIN MULTIPLICITY MULT C C |MDELE|=NUMBER OF TERM ENERGY CORRECTIONS TO BE READ BELOW (DO 92) C IF .LT. 0 READS/WRITES TFU FROM/TO UNIT MR+1 (DISABLED). C MDELE IS HISTORICAL, BUT CAN STILL BE USED TO READ TECS FROM C UNIT6. IT HAS BEEN SUPERCEDED BY ISHFTLS AND ISHFTIC. C C ISHFTLS (ISHFTIC) .eq.0, no shifts (default). C .EQ. 1 C READ TERM (LEVEL) NUMBERS AND ENERGY CORRECTIONS FROM FILE SHFTLS C (SHFTIC) PRECEDED BY THE NUMBER OF STATE/ENERGY PAIRS TO BE READ AND C THE ENERGY UNITS USED (AS IP OF H). CAN BE USED TOGETHER IN AN IC RUN, C THEN LS ENERGY SHIFTS ARE APPLIED AS TERM ENERGY CORRECTIONS TO H(IC) C BEFORE DIAGONALIZATION AND THE IC SHIFTS AS A FURTHER CORRECTION AFTER C H(IC) DIAGONALIZATION TO ACHIEVE EXACT LEVEL POSITIONING. THE TERM C (LEVEL) NUMBERS ARE THE ALGEBRAIC T (LV) NUMBERS, NOT THE ENERGY C ORDERED. C .GT. 1 C THEN ASSUMES OBSERVED ENERGIES, RELATIVE TO THE GROUND (AVERAGED C -OVER FINE-STRUCTURE FOR TERMS) NOT CORRECTIONS ARE INPUT AND THEN C ISHFTLS OR ISHFTIC ITERATIONS OF H(IC) ARE CARRIED-OUT. ISHFTLS C ITERATIONS ARE APPLIED AS TERM ENERGY CORRECTIONS (TEC) TO H(IC). C THE FINAL TECS CAN THEN BE INPUT IN SHFTLS WITH ISHFTLS=1 AND THEN C (OPTIONALLY) ISHFTIC ITERATIONS CAN BE APPLIED AS LEVEL ENERGY C CORRECTIONS TO THE DIAGONAL OF H(IC) BEFORE DIAGONALIZATION. THE C FINAL LECS CAN THEN BE INPUTIN SHFTIC WITH ISHFTIC=1 TO REGENERATE C THE FINAL STRUCTURE WITHOUT ITERATION. C .LT. 0 C NO ITERATIONS (AS .EQ. 1) BUT ASSUMES INPUT OBSERVED ENERGIES C (AS .GT. 1). C C SEE ALSO SR.RADCON FOR ABSOLUTE SHIFT OF CONTINUUM C BCORR=MDELE.NE.0.OR.ISHFTLS.NE.0.OR.ISHFTIC.NE.0 IF(ISHFTLS.GT.1.AND.ISHFTIC.GT.1.AND.III.EQ.0)THEN WRITE(6,*)' *** SR.MINIM ERROR: CANNOT ITERATE ON TECS AND LECS' X ,' AT THE SAME TIME! ',ISHFTLS,ISHFTIC WRITE(0,*)' *** SR.MINIM ERROR: CANNOT ITERATE ON TECS AND LECS' X ,' AT THE SAME TIME!' GO TO 998 ENDIF IF(ISHFTLS.NE.0.AND.ISHFTIC.NE.0.AND.III.NE.0)THEN IF(NJO.GT.0)THEN WRITE(6,*)'*** SR.MINIM: IGNORING SHFTLS, USING SHFTIC FILE' WRITE(0,*)'*** SR.MINIM: IGNORING SHFTLS, USING SHFTIC FILE' ISHFTLS=0 ENDIF ENDIF IF(MDELE.LT.0)MDELE=-MDELE IF(MDELE.GE.0)GO TO 11 IF(MDELE.LT.0)GO TO 11 WRITE(6,898) MDELE=0 C C NGRP=!MGRP! SPECIFIES NUMBER OF SIGMA/Q.D. PARAMETERS TO BE REA C MGRP .GT. 0 SCREENING PARAMETERS C MGRP .LT. 0 QUANTUM DEFECTS *100 , .LT. 999.0 ONLY. C SCREEN MUST BE IN RANGE 999 TO 5998 FOR 'REPLACEMENT' IN SR.RADWIN C AND .GE. 5999 FOR 'REPLACEMENT' IN SR.RADCON, .GE. 7999 EVALUATES C CONTINUUM FUNCTION AT USER SUPPLIED ENERGY(S) SEE RADCON, OTHERWIS C EVALUATES CONTINUUM FUNCTION AT THRESHOLD (K=0) FOR EXTRAPOLATION C TO PRINCIPAL QUANTUM NUMBER SPECIFIED BY GIVEN ORBITAL NUMBER. C .LT. -999 HAS SPECIAL MEANING, SEE SR.RADIAL. C 11 NGRP=IABS(MGRP) C C IF BORT .TRUE. REQUIRE SCALING PARAMETERS FOR EACH ORBITAL C I.E. POTENTIAL nl DEPENEDENT AND ORBITALS ARE ORTHONORMALISED C AFTER EVALUATION. C EXCEPTION MORT .EQ. -3, NO ORTHOGONALIZATION IMPOSED, LAM=nl STILL. C |MORT| .EQ. 2 USES MODIFIED HYDROGENIC ORBITALS WHEN CORRELATION C SPECIFIED TO BE CONSISTENT WITH IMPACT, PURE C HYDROGENIC OTHERWISE: ZEFF=-LAM*Z0 EXCEPT C MORT .EQ.-4 ZEFF=-N*LAM/2 FOR PSEUDO-STATE BASIS, THEN C LAM GENERALLY INDEPENDENT OF NL. C MORT .EQ.-5 USES BOX STATES C C |MORT| .GT. 20 RESTARTS CALCULATION OF RADIATIVE RATES IN DIAGFS C (I.E. FOR IC AR ONLY) FROM ENERGY ORDER LEVEL !MORT! . C IF(IORT.NE.0)MORT=IORT BORT=MORT.LT.0 IF(BORT)THEN NPARAM=NGROUP if(idw.ne.0)nparam=max(nparam,nlam) ENDIF C IF(NPARAM.GT.MXVAR)THEN !TOO MANY SCALING PARAMETERS WRITE(6,1000)NPARAM,MXVAR NF=-1 GO TO 95 ENDIF C NP0=0 IF(IPOLFN.LT.0)NP0=-IPOLFN NPARM3=(NP0+1)*NPARAM !MXVAR NPARM2=2*NPARAM C IF(BPRNT0.AND.MXBOX.EQ.0)WRITE(6,777)RZERO C C SKIP IF PREVIOUS INPUT WEIGHTS MAY BE USED (TYPICALLY III=-9999): C IWGHT CONTROLS WEIGHTING: C IWGHT .EQ. 1 FOR UNIT WEIGHTING C .NE. 1 FOR ORIGINAL STATISTICAL WEIGHTING C DF0=DZERO !INITIALZE CORE FUNCTIONAL ENERGY IF(III.GE.-MAXTM)THEN INCLUD=III IF(III.LT.0)THEN NEXTRE=-III C C READ(5,*)(INDEXW(I),WGHT(I),I=1,NEXTRE) C C ENDIF ENDIF C C SWITCH-OFF MINIMIZATION FOR RELATIVISTIC RADIAL FUNCTIONS C c IF(BREL.AND.INCLUD.NE.0)THEN c WRITE(6,692) c WRITE(0,*)' NO MINIMIZATION BECAUSE RELATIVISTIC ORBITALS' c X,' ARE IN USE!' c INCLUD=0 c ENDIF C C DEXTRE PROVIDES (INITIAL) DATA FOR DADJUS(I),I=1,NPARAM, THE S.M/STO C POTENTIAL SCALING PARAMETERS (L- OR NL-DEPENDENT), SEE SR.CALCFX. C DEXTRE(MIN0(I,NEXTRE)) WILL BE ASSIGNED TO DADJUS(I) UNLESS C REDIRECTED BY IEQUAL; DEXTRE RETAINS ANY PREVIOUS VALUES ELSE. C NVAR0=NVAR NVAR=NVAR0+NVARD+NVARQ NLAMDQ=IABS(NLAMD)+IABS(NLAMQ) NLAM=NLAM+NLAMDQ C IF(NLAM.NE.0)MEXTRE=NLAM !NLAM TAKES PRIORITY OVER MEXTRE NEXTRE=MOD(IABS(MEXTRE)-NLAMDQ,10000) !NO OF SCALING PARAMETERS IF(MEXTRE.EQ.0)NEXTRE=NPARAM !DEFAULT IF NOT SPECIFIED C IF(MEXTRE.LE.0)THEN IF(NVAR.GT.0)GO TO 33 GO TO 20 ENDIF C C NON-UNIQUE BASIS DEFAULTS TO UNITY *NOT* PREVIOUS VALUE IF DEXTRE C IS NOT SPECIFIED C IF(IEQ(0).LT.0)THEN !NON-UNIQUE BASIS IF(IPOLFN.LT.0)THEN WRITE(6,*)'*** SR.MINIM: CANNOT USE PERTURBED TF POT WITH', X ' RELAXED ORBITAL BASIS' WRITE(0,*)'***CANNOT USE RELAXED ORBITALS WITH PERTURBED TF' GO TO 998 ENDIF IF(NVAR.EQ.0.AND.INCLUD.NE.0)THEN WRITE(6,*)'*** SR.MINIM: INCLUD=',INCLUD,' BUT NVAR=0.', X ' RE-SETTING INCLUD=0, ELSE SPECIFY NVAR TO OPTIMIZE.' WRITE(0,*)'***INCLUD NE.0 BUT NVAR=0 !' INCLUD=0 ENDIF DO I=1,MAXGR BUF(I)=DZERO ENDDO DO N=1,NEXTRE !NEXTRE SETS C READ(5,*)K,IDUM0 !CF AND NO. OF VALUES TO READ C IF(K.EQ.0)THEN C READ(5,*)(BUF(I),I=1,IDUM0) !COMMON CORE C ELSE C READ(5,*)(DUM(I),I=1,IDUM0) C IB=MIN(IDUM0,MXBORB) KK=MXBORB*(K-1)+MB DO I=1,IB II=KK+I BUF(II)=DUM(I) ENDDO IF(IDUM0.GT.MXBORB)THEN IF(.NOT.BDR)THEN II=KMAX*MXBORB+K+MB !CONT ELSE II=KMAX*MXBORB+K+MB !VALENCE IF(QN(QCG(NF,K)).GE.90)II=II+KMAX !CONT ENDIF I0=MXBORB+1 !CONT. LAMBDA IN FIRST POS AFTER BOUND BUF(II)=DUM(I0) ENDIF ENDIF ENDDO NEXTRE=MXORB MEXTRE=MXORB C ELSE !UNIQUE BASIS C IF(NEXTRE.GT.0)READ(5,*)(BUF(I),I=1,NEXTRE) C IF(ISCALR.GT.0)THEN !PROCESS SLATER SCALING PARAMETER IF(ABS(SCALER-DONE).GT.D1M5)THEN !SCALER-> BUF IF(ISCALR.LE.NEXTRE)THEN !FLAG IF(ABS(BUF(ISCALR)-DONE).GT.D1M5)THEN WRITE(6,*)'*** SLATER SCALING SPECIFIED TWICE! USING ' X ,SCALER WRITE(0,*)'*** SLATER SCALING SPECIFIED TWICE!' ENDIF ENDIF BUF(ISCALR)=SCALER c ELSEIF(ISCALR.LE.NEXTRE)THEN !BUF->SCALER, FOR NON-CALCFX c SCALER=BUF(ISCALR) ENDIF IF(NEXTRE.LT.0)THEN WRITE(6,884)NEXTRE,ISCALR WRITE(0,*)'SR.MINIM: CANNOT USE NLAM.LT.0 WITH ISCALR.GT.0' GO TO 998 ENDIF DO I=NEXTRE+1,ISCALR-1 BUF(I)=DZERO ENDDO NEXTRE=MAX(NEXTRE,ISCALR) ENDIF C IF(IPOLFN.LT.0)THEN IF(NPARM3.GT.MXVAR)THEN WRITE(6,*)'*** SR.MINIM: INCREASE MXVAR TO',NPARM3 WRITE(0,*)'*** SR.MINIM: INCREASE MXVAR' GO TO 998 ENDIF C IF(NLAMD.NE.0)THEN IF(NLAMD.LT.0)THEN WRITE(6,*) X "INPUT DIPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY", X "OUTPUT RELATIVE TO ZERO STILL" WRITE(0,*) X "INPUT DIPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY" NLAMD=-NLAMD TADD=DZERO !=0 FOR I/O RELATIVE TO 1 ELSE TADD=DONE !=1 FOR I/O RELATIVE TO 0 ENDIF READ(5,*)(BUF(NPARAM+I),I=1,NLAMD) IF(NLAMD.GT.NPARAM.and.idw.eq.0)THEN IF(NF.GT.0)WRITE(6,992)NLAMD,NPARAM NLAMD=NPARAM ENDIF DO I=1,NLAMD I1=NPARAM+I BUF(I1)=BUF(I1)+TADD ENDDO ENDIF IF(NLAMQ.NE.0)THEN IF(NLAMQ.LT.0)THEN WRITE(6,*) X "INPUT QUADRUPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY" X ,"OUTPUT RELATIVE TO ZERO STILL" WRITE(0,*) X "INPUT QUADRUPOLE PERTURBTN LAMBDA'S TAKEN RELATIVE TO UNITY" NLAMQ=-NLAMQ TADD=DZERO !=0 FOR I/O RELATIVE TO 1 ELSE TADD=DONE !=1 FOR I/O RELATIVE TO 0 ENDIF READ(5,*)(BUF(NPARM2+I),I=1,NLAMQ) IF(NLAMQ.GT.NPARAM.and.idw.eq.0)THEN IF(NF.GT.0)WRITE(6,992)NLAMQ,NPARAM NLAMQ=NPARAM ENDIF DO I=1,NLAMQ I2=NPARM2+I BUF(I2)=BUF(I2)+TADD ENDDO ENDIF C ENDIF ENDIF C 33 IF(NVAR.GT.0)THEN IFABS=0 IF(IEQ(0).LT.0)THEN !NON-UNIQUE BASIS K0=-1 II=0 I0=II DO N=1,NVAR !NVAR SETS C READ(5,*)K,IDUM0 !CF AND NO. OF VALUES TO READ C IF(K.LE.K0)THEN WRITE(6,*)'***ERROR: INPUT NVAR SETS IN INCREASING CF ', X 'ORDER, NOT:',K0,K WRITE(0,*)'***ERROR: INPUT NVAR SETS IN INCREASING CF ', X 'ORDER' GO TO 998 ENDIF IF(K.EQ.0)THEN C READ(5,*)(IBUF(I),I=1,IDUM0) !COMMON CORE C II=IDUM0 I0=II ELSE C READ(5,*)(IDUM(I),I=1,IDUM0) C KK=MXBORB*(K-1)+MB !ASSUME VAL ORB NO. IN DO I=1,IDUM0 IF(IDUM(I).GT.MXBORB)IFABS=1 !FLAG ABSOLUTE II=II+1 IBUF(II)=KK+IDUM(I) ENDDO ENDIF ENDDO C THIS WON'T CATCH EVERYTHING... IF(IFABS.EQ.1)THEN !-MB IF ABS ORB NO. IN WRITE(0,*)' *** DEFAULT RELAXED ORBITAL INDEX IS RELATIVE ', X 'TO THE CLOSED-SHELL CORE, I.E. A VALENCE INDEX;', X ' CONVERTING YOUR ABSOLUTE INDEX INPUT...' WRITE(0,*)' *** THIS WILL NOT ALWAYS BE CAUGHT!!!' DO I=I0+1,II IBUF(I)=IBUF(I)-MB ENDDO ENDIF C NVAR=II NVAR0=NVAR C ELSE !UNIQUE BASIS C NVAR=NVAR0 C IF(NVAR0.GT.0)READ(5,*)(IBUF(I),I=1,NVAR0) C IF(NVARD.GT.0)THEN C READ(5,*)(IBUF(NVAR+I),I=1,NVARD) C DO I=1,NVARD IBUF(NVAR+I)=IBUF(NVAR+I)+NPARAM ENDDO NVAR=NVAR+NVARD if(nlamd.eq.0)nlamd=1 !need non-zero for set-up ENDIF C IF(NVARQ.GT.0)THEN C READ(5,*)(IBUF(NVAR+I),I=1,NVARQ) C DO I=1,NVARQ IBUF(NVAR+I)=IBUF(NVAR+I)+NPARM2 ENDDO NVAR=NVAR+NVARQ if(nlamq.eq.0)nlamq=1 !need non-zero for set-up ENDIF C ENDIF C IF(INCLUD.EQ.0)THEN NVAR0=0 NVAR=0 NVARD=0 NVARQ=0 ENDIF ENDIF C IF(NVAR.GT.0)THEN IBF0=0 DO K=1,NVAR II=IBUF(K) IF(K.GT.NVAR0)II=II-NPARAM IF(K.GT.NVAR0+NVARD)II=II-NPARAM IF(DEY(II).EQ.DZERO)THEN WRITE(6,994)II WRITE(0,*)'***ERROR, ORBITAL TO BE VARIED DOES NOT EXIST!' GO TO 998 ENDIF IF(IBUF(K).LE.IBF0)THEN WRITE(6,885)(IBUF(L),L=1,NVAR) WRITE(0,*) X '***ERROR, VARIATIONAL PARAMETERS MUST BE IN ASCENDING ORDER' GO TO 998 ENDIF IBF0=mod(IBUF(K)-1,nparam)+1 IF(IBF0.GT.nparam)THEN WRITE(6,886)K,IBF0,nparam WRITE(0,*) X '***ERROR, INCONSISTENT VARIATIONAL & SCALING PARAMETERS' GO TO 998 ENDIF IBF0=IBUF(K) ENDDO IM=nparm3-NVAR !MXVAR-NVAR IF(IM.GT.0)THEN J=0 DO I=1,IM J=J+1 DO K=1,NVAR IF(IBUF(K).EQ.J)J=J+1 !THIS IS WHY WE NEED ASCENDING ENDDO IBUF(I+NVAR)=J ENDDO ENDIF ENDIF C 20 T=DONE NLAM=NEXTRE I0=0 IM=NPARM3-NVAR C 21 MEND=0 DO I=1,nparam !MXVAR IP=I0+I JEND(I)=1 IEQUAL(IP)=NLAM IF(IP.GT.NLAM)THEN IF(MEXTRE.LT.0)GO TO 25 ELSE IEQUAL(IP)=IP IF(MEXTRE.GT.0)THEN J=IP IF(NVAR*IM.GT.0)J=IBUF(IP) DEXTRE(IP)=BUF(J) IF(DEXTRE(IP).EQ.DZERO)DEXTRE(IP)=T IF(IEQ(0).GE.0)T=DEXTRE(IP) ENDIF ENDIF c write(6,*)i,iequal(ip),dextre(ip),buf(j) IF(MEXTRE.GE.0)DAJOLD(IP)=DZERO 25 ENDDO C IF(NLAMD.GT.0)THEN NLAM=NPARAM+NLAMD NLAMD=-NLAMD I0=NPARAM GO TO 21 ENDIF C IF(NLAMQ.GT.0)THEN NLAM=NPARM2+NLAMQ NLAMQ=-NLAMQ I0=NPARAM*2 GO TO 21 ENDIF C NLAMD=IABS(NLAMD) NLAMQ=IABS(NLAMQ) C NVAR=NVAR0+NVARD+NVARQ NLAM=NEXTRE C IF(NVAR.GT.0)THEN DO I=1,nparm3 !MXVAR DO J=1,nparm3 !MXVAR IF(IBUF(J).EQ.I)IEQUAL(I)=J ENDDO ENDDO ENDIF C C INSTEAD OF READING IEQUAL DIRECTLY (SEE BELOW), READ WHICH SCALING C PARAMETER IS TO BE USED BY EACH L- OR NL-DEPENDENT POTENTIAL. C THE DEFAULT IS 1,2,3,4,5,6,7 ETC. OBVIOUSLY, THIS IS ONLY NECESSARY C WHEN MINIMIZATION IS BEING CARRIED-OUT AND YOU WANT TO TIE ONE OR C MORE POTENTIALS TO ONE OR MORE OF THOSE BEING VARIED. (IF NOT MINI- C MIZING THEN YOU CAN TRIVIALLY SET THE LAMBDAS THE SAME.) C TBD: READ NFIXD, NFIXQ FOR PERTURBED TF, ELSE NEED ABSOLUTE POSITION. C IF(NFIX.GT.0)THEN IF(IEQ(0).LT.0)THEN WRITE(6,*)"***ERROR: CANNOT USE NFIX.GT.0 WITH BASIS='RLX'" WRITE(0,*)"***ERROR: CANNOT USE NFIX.GT.0 WITH BASIS='RLX'" GO TO 998 ENDIF C IF(IPOLFN.LT.0)THEN !COULD USE IF USER INPUTS ABSOLUTE INDEX WRITE(6,*)"***ERROR: CANNOT USE NFIX.GT.0 WITH PERTURBED TF" WRITE(0,*)"***ERROR: CANNOT USE NFIX.GT.0 WITH PERTURBED TF" GO TO 998 ENDIF C READ(5,*)(IFYX(I),I=1,NFIX) C DO I=1,NFIX IF(IFYX(I).GT.0)IEQUAL(I)=IEQUAL(IFYX(I)) ENDDO ENDIF C C REDUCE NEXTRE IF NECESS. C IF(NEXTRE.GT.NPARAM.and.idw.eq.0)THEN IF(NF.GT.0)WRITE(6,992)NEXTRE,NPARAM NEXTRE=NPARAM ENDIF C C INITIALZE IF OLD STYLE NEXTRE C IF(INCLUD.NE.0.AND.NVAR.EQ.0)NVAR=NEXTRE C C SET IEQUAL RANGE C K=nparam !MXVAR c IF(BORT)K=NGROUP !=NPARAM AGAIN NOW C IF(IABS(MEXTRE).GE.10000)THEN !HISTORIC SS |MEXTRE|.GE.100 OPTION IF(IEQ(0).LT.0)THEN WRITE(6,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH", X " BASIS='RLX'",MEXTRE WRITE(0,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH", X " BASIS='RLX'" GO TO 998 ENDIF IF(IPOLFN.LT.0)THEN WRITE(6,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH", X " PERTURBED TF POTENTIAL",MEXTRE WRITE(0,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH", X " PERTURBED TF" GO TO 998 ENDIF C C IEQUAL(I)=J FIXES THAT SCALING FACTOR DADJUS(I), FOR L=I-1, EQUAL C TO VARIATIONAL PARAMETER DEXTRE(J). SUPPOSE THE SAME POTENTIAL IS C WANTED FOR P,D AND F ELECTRONS BUT A DIFFERENT POTENTIAL FOR S: C PUT IEQUAL(1)=1,IEQUAL(2)=IEQUAL(3)=IEQUAL(4)=2-THESE ARE THE C DEFAULT VALUES, IN WHICH CASE ONE MIGHT AS WELL SKIP C DO I=1,MXVAR IEQUAL(I)=0 ENDDO C READ(5,*)(IEQUAL(I),I=1,K) C ENDIF C IF(MEXTRE.LT.0)THEN IF(IPOLFN.LT.0)THEN WRITE(6,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH", X " POLARIZED TF POTENTIAL",MEXTRE WRITE(0,*)"***ERROR: CANNOT USE THIS NLAM/MEXTRE WITH", X "POLARIZED TF" GO TO 998 ENDIF DO I=1,NEXTRE DO J=1,K IF(IEQUAL(J).EQ.I)DAJOLD(J)=DZERO ENDDO ENDDO ENDIF C C SCREEN RELATES TO THE EIGENVALUE E (IN RYDBERGS) OF THE ONE- C PARTICLE FUNCTIONS THROUGH E=-(Z-SCREEN)**2/(N*N); N=PRINCIPAL C QUANTUM NUMBER. A GOOD INITIAL VALUE OF SCREEN WILL SPEED UP THE C COMPUTATION IN RADWAV. IF NO APPROXIMATION IS KNOWN USE STANDARD C OPTION BY SKIPPING THIS "READ SCREEN" FOR 1S,2S,2P ETC. C C DO I=1,MAXGR IF(DEY(I).NE.DZERO)THEN IF(QN(I).GE.70.AND.QN(I).LT.80.AND.I.LE.IABS(MPSEUD)) X DEY(I)=DZERO IF(QN(I).GE.90)SCREEN(I)=9999 ENDIF ENDDO C IF(NGRP.GT.0)THEN IF(IEQ(0).LT.0)THEN !NON-UNIQUE BASIS DO I=1,MAXGR BUF(I)=DZERO ENDDO DO N=1,NGRP !NGRP SETS READ(5,*)K,IDUM0 !CF AND NO. OF VALUES TO READ IF(K.EQ.0)THEN READ(5,*)(BUF(I),I=1,IDUM0) !COMMON CORE ELSE READ(5,*)(DUM(I),I=1,IDUM0) IB=MIN(IDUM0,MXBORB) KK=MXBORB*(K-1)+MB DO I=1,IB II=KK+I BUF(II)=DUM(I) ENDDO IF(IDUM0.GT.MXBORB)THEN IF(.NOT.BDR)THEN II=KMAX*MXBORB+K+MB !CONT ELSE II=KMAX*MXBORB+K+MB !VALENCE IF(QN(QCG(NF,K)).GE.90)II=II+KMAX !CONT ENDIF I0=MXBORB+1 !CONT SIGMA IN FIRST POS AFTER BOUND BUF(II)=DUM(I0) ENDIF ENDIF ENDDO NGRP=MXORB ELSE NGRP=MIN(NGRP,MAXGR) READ(5,*)(BUF(I),I=1,NGRP) ENDIF C DO I=1,NGRP IF(BUF(I).NE.DZERO)THEN IF(MGRP.LE.0.AND.ABS(BUF(I)).LT.999)THEN BUF(I)=BUF(I)/D1P2 T1=QN(I)*(MION-1) T0=NZION T1=T1-T0*BUF(I) T0=QN(I) BUF(I)=T1/(T0-BUF(I)) ENDIF SCREEN(I)=BUF(I) ENDIF ENDDO ENDIF C C PERFORM CHECKS ON BOUND, RYDBERG AND CONTINUUM ORBITALS C HFF=.FALSE. !NO EXTERNAL ORBS ICP=0 ICM=0 MODE=1 C DO I=1,MAXGR IF(I.LE.NGROUP.AND.DEY(I).NE.DZERO.AND.SCREEN(I).GE.999)THEN COLD IF(QN(I).GE.80)MODE=2 IF(SCREEN(I).LT.5999)THEN !EXTERNAL HFF=.TRUE. !FOR RADWIN ENTRY ICM=ICM-1 ELSEIF(SCREEN(I).GT.7999)THEN !CONTINUUM COLD MODE=2 ICP=ICP+1 IF(IVAL(I).NE.0)THEN WRITE(6,899)I IV=IV-1 IVAL(I)=0 ENDIF ELSE !DUMMY RYDBERG IV=IV-IVAL(I) IVAL(I)=1 IV=IV+1 SCREEN(I)=MION-1 ENDIF C CLOSED-CORE EXTERNAL ONLY IF RELAXED IF(ICM*IEQ(0).GT.0.AND.I.GT.MB)THEN WRITE(6,997)I WRITE(0,*)'*** SR.MINIM: ERROR, EXTRERNAL ORBITAL CANNOT', X ' BE A RELAXED ONE!' GO TO 998 ENDIF C DO NOT ITERATE VARIATIONALLY FOR THESE RADIAL FUNCTIONS IF(INCLUD*ICP.NE.0)THEN WRITE(6,991)I INCLUD=0 ENDIF C DO NOT VARY FIXED INPUT (ERROR) IF(INCLUD*ICM.NE.0)THEN DO K=1,NVAR KK=IBUF(K) IF(KK.EQ.I)THEN WRITE(6,996)I WRITE(0,*) X '*** SR.MINIM: ERROR, TRYING TO VARY EXTERNAL ORBITAL' GO TO 998 ELSEIF(KK.LT.I)THEN IF(QL(KK).EQ.QL(I).AND.MORT.NE.-3)THEN WRITE(6,897)I,KK WRITE(0,*) X '*** SR.MINIM: ERROR, INCOMPATIBLE VARIATIONAL AND', X ' EXTERNAL ORBITALS!' GO TO 998 ENDIF ENDIF ENDDO ENDIF ENDIF ENDDO C IF(ICM.LT.0)MAUTO=-1 IF(ICP.GT.0)MAUTO=1 IF(ICM*ICP.LT.0)MAUTO=0 IF(ICP.GT.0.AND.MODE.EQ.1)MODE=2 !NEW IF(BDR.AND.IV.LE.0)THEN BDR=.FALSE. WRITE(6,895) ENDIF C IF(MODE.EQ.2.OR.MODE.EQ.3)THEN !B-C IF(NMETAR.GT.0)THEN !SET EIMXLS INQUIRE(FILE='TERMS',EXIST=EX) IF(EX)THEN OPEN(14,FILE='TERMS',STATUS='OLD') READ(14,*,END=331) E2=DZERO DUME=DZERO N1=NMETAR+1 DO N=1,MAXTM IF(N.EQ.N1)E1=DUME READ(14,772,END=331)ISP,NDUM,NDUM,NDUM,NDUM,DUME IF(ISP.EQ.0)GO TO 330 !TERMINATOR ,MYRGE IF(N.EQ.N1)E2=DUME ENDDO 330 IF(E2.EQ.DZERO)E2=-DUME EIMXLS=DUME+(E1+E2)/2 331 CLOSE(14) IUNIT(14)=-1 ENDIF ENDIF IF(NMETARJ.GT.0)THEN !SET EIMXIC INQUIRE(FILE='LEVELS',EXIST=EX) IF(EX)THEN OPEN(15,FILE='LEVELS',STATUS='OLD') READ(15,*,END=333) E2=DZERO DUME=DZERO N1=NMETARJ+1 DO N=1,MAXLV IF(N.EQ.N1)E1=DUME READ(15,773,END=333)NDUM,NDUM,ISP,NDUM,NDUM,NDUM,DUME IF(ISP.EQ.0)GO TO 332 !TERMINATOR ,MYRGE IF(N.EQ.N1)E2=DUME ENDDO 332 IF(E2.EQ.DZERO)E2=-DUME EIMXIC=DUME+(E1+E2)/2 333 CLOSE(15) IUNIT(15)=-1 ENDIF ENDIF ENDIF C C READ CONFIGURATION NOS FOR STOPOT C IF(MCFMX.GT.0.and.mcfmx.le.1000)THEN IF(IEQ(0).LT.0)THEN READ(5,*)K,IDUM0 IF(MCFMX.GT.1.OR.K.NE.0)THEN WRITE(6,*)"*** ONLY SPECIFY STO CF FOR CORE ORBITALS", X " WHEN BASIS='RLX'! THUS, MCFMX=1 WITH K=0." WRITE(0,*)"*** ONLY SPECIFY STO CF FOR CORE ORBITALS" GO TO 998 ENDIF READ(5,*)(MCFSTO(I),I=1,IDUM0) ELSE MCFMX=MIN(MCFMX,MAXGR) READ(5,*)(MCFSTO(I),I=1,MCFMX) ENDIF ELSEIF(MCFMX.EQ.0.AND.MDEN.NE.0)THEN !USE FIRST/GROUND CF IF(IEQ(0).GE.0)THEN IF(NOCC.GT.0)MCFMX=-9999 !FOR FAC='YES' ELSE !SO CORE ONLY MCFMX=1 MCFSTO(1)=1 ENDIF ELSEIF(MCFMX.LT.0.AND.IEQ(0).LT.0)THEN WRITE(6,*)"*** MCFMX.LT.0 INCONSISTENT WITH BASIS='RLX' - ", X "CANNOT USE A COMMON AVERAGE POTENTIAL" WRITE(0,*)"*** MCFMX.LT.0 NOT ALLOWED FOR RELAXED ORBITALS" GO TO 998 ENDIF C NLSTOE=IABS(NLSTOE) C C READ UNIQUE SET OF OCCUPATION NUMBERS FOR MODEL STO/SCF POTENTIAL C VALENCE ORBITALS ONLY, CLOSED-SHELL CANNOT BE CHANGED CURRENTLY, SO NL C NOCC0=NOCC NOCC=MOD(NOCC0,1000) C IF(NOCC.NE.0)THEN C NOCC=IABS(NOCC) C READ(5,*)(TEL(I+MB),I=1,NOCC) C WKT=0 IF(MB.GT.0)THEN DO M=MA,MB TEL(M)=2*QL(M)+2 WKT=WKT+TEL(M) ENDDO ENDIF C DO I=1,NOCC IB=I+MB IF(BORT)THEN WMAX=2*QL(IB)+2 ELSE WMAX=2*QN(IB)**2 ENDIF IF(TEL(IB).GT.WMAX+DELW.OR.TEL(IB).LT.-DELW)THEN WRITE(6,*)'*** SR.MINIM: ILLEGAL OCCUPATION NO. INPUT FOR' X ,' ORBITAL',IB,' :',TEL(IB) WRITE(0,*)'*** SR.MINIM: ILLEGAL OCCUPATION NO. INPUT' GO TO 998 ELSE WKT=WKT+TEL(IB) ENDIF ENDDO C T=ABS(WKT-MION+iswch) IF(T.GT.10*DELW)THEN WRITE(6,*)'*** SR.MINIM: SUM OF OCCUPATION NOS NOT EQUAL TO' X ,' MION:',MION,WKT WRITE(0,*)'*** SR.MINIM: SUM OF OCCUPATION NOS NOT EQUAL TO' X ,' MION' if(t.gt.100*delw)GO TO 998 ENDIF C NOCC=NOCC+MB C IF(IEQ(0).LT.0)THEN WRITE(6,*)'*** SR.MINIM: NOCC IGNORED FOR RELAXED ORBITALS' WRITE(0,*)'*** SR.MINIM: NOCC IGNORED FOR RELAXED ORBITALS' NOCC=1000 ENDIF C IF(NOCC0.LT.0)NOCC=-NOCC NOCC0=NOCC C ENDIF C C FIX ORBITALS DURING SELF-CONSISTENT OPERATION C DEFAULT: C TRUE FOR CLOSED-SHELLS C FALSE FOR VALENCE C TO OVERRIDE, READ-IN IFIX ORBITAL NUMBERS C >0 FOR TRUE C <0 FOR FALSE C IF(MB.GT.0)THEN DO I=MA,MB BFIX(I)=.TRUE. ENDDO ENDIF DO I=MB+1,MXORB BFIX(I)=.FALSE. ENDDO IF(IFIX.GT.0)THEN READ(5,*)(IFYX(I),I=1,IFIX) DO I=1,IFIX J=IABS(IFYX(I)) BFIX(J)=IFYX(I).GT.0 ENDDO ENDIF C C READ DELELS/IC IN UNITS C IF(BCORR)THEN C TERMS IF(INCLUD.NE.0.AND.ISHFTLS.NE.0)THEN !RESET IF(NJO.GT.0)THEN !F-S WEIGHTED LEVELS IOPTIM=-2 ELSE !TERMS IOPTIM=1 ENDIF ISHFTLS=2 IF(INCLUD.GT.0)INCLUD=MAXTM ENDIF C I0=1 !READ TECS IF(ISHFTLS.GT.1)I0=2 !READ OBS WEIGHTED TERM ENERGIES DO I=1,I0 DO K=1,MAXTM DELELS(K,I)=DZERO ENDDO ENDDO C IF(ISHFTLS.NE.0)THEN C IF(IOPTIM.NE.0)ISHFTLS=0 !NOW SWITCH OFF & USE IOPTIM C IF(MDELE.NE.0)THEN WRITE(6,*)'MDELE DATA IGNORED BECAUSE ISHFTLS .NE. ZERO' MD=IABS(MDELE) DO K=1,MD !SKIP READS READ(6,*) ENDDO MDELE=0 !IABS(ISHFTLS) ENDIF C IUN=19 C IF(ISHFTLS.GT.0)IUN=5 IF(ISHFTLS.LT.0)ISHFTLS=-1 C IF(IUNIT(IUN).EQ.0)THEN WRITE(6,*)"ISHFTLS.NE.0 BUT MISSING FILE='SHFTLS'..." WRITE(0,*)'MISSING FILE ON UNIT=19' GO TO 998 ENDIF REWIND(IUN) C READ(IUN,*)NOBS,UNITS TUNIT=UNITS*DTWO C DO K=1,NOBS C READ(IUN,*)I,DEM C IF(I0.EQ.2.AND.DEM.LT.DZERO.AND.DEM.GT.-DONE)THEN WRITE(6,*)' *** SR.MINIM INPUT ERROR: OBSERVED ENERGY ', X '.LT. ZERO, PERHAPS A TEC? ',J,DEM WRITE(0,*)' *** SR.MINIM INPUT ERROR: OBSERVED ENERGY ', X '.LT. 0...' GO TO 998 ENDIF DELELS(I,I0)=DEM/TUNIT ENDDO IF(NJO.LE.0.AND.ISHFTLS.GT.1)THEN WRITE(6,*)'*** NO TEC ITERATION POSSIBLE IN PURE LS RUN, ', X 'SET ISHFTLS.LE.1, OR TURN ON IC' WRITE(0,*)'*** NO TEC ITERATION POSSIBLE IN PURE LS RUN, ', X 'SET ISHFTLS.LE.1, OR TURN ON IC' GO TO 998 ENDIF ENDIF C LEVELS IF(INCLUD.NE.0.AND.ISHFTIC.NE.0)THEN !RESET IF(IOPTIM.EQ.-2)THEN !IGNORE F-S WGHT LEVS WRITE(6,*)' *** IGNORING TERM ENERGIES, USING LEVEL INFO', X ' DURING MINIMIZATION OPERATION' WRITE(0,*)' *** IGNORING TERM ENERGIES, USING LEVEL INFO' ENDIF IF(NJO.LE.0)THEN WRITE(6,*)' *** IGNORING LEVEL ENERGIES IN LS-RUN' WRITE(0,*)' *** IGNORING LEVEL ENERGIES IN LS-RUN' ELSE !LEVELS IOPTIM=2 ENDIF ISHFTIC=2 IF(INCLUD.GT.0)INCLUD=MAXLV ENDIF C J0=1 !READ LECS IF(ISHFTIC.GT.1)J0=2 !READ OBS LEVEL ENERGIES DO J=1,J0 DO K=1,MAXLV DELEIC(K,J)=DZERO ENDDO ENDDO C IF(ISHFTIC.NE.0)THEN C IF(IOPTIM.NE.0)ISHFTIC=0 !NOW SWITCH OFF & USE IOPTIM C IUN=20 C IF(ISHFTIC.GT.0)IUN=5 IF(ISHFTIC.LT.0)ISHFTIC=-1 C IF(IUNIT(IUN).EQ.0)THEN WRITE(6,*)"ISHFTIC.NE.0 BUT MISSING FILE='SHFTIC'..." WRITE(0,*)'MISSING FILE ON UNIT=20' GO TO 998 ENDIF REWIND(IUN) C READ(IUN,*)NOBS,UNITS TUNIT=UNITS*DTWO C DO K=1,NOBS C READ(IUN,*)J,DEM C IF(J0.EQ.2.AND.DEM.LT.DZERO.AND.DEM.GT.-DONE)THEN WRITE(6,*)' *** SR.MINIM INPUT ERROR: OBSERVED ENERGY ', X '.LT. ZERO, PERHAPS A LEC? ',J,DEM WRITE(0,*)' *** SR.MINIM INPUT ERROR: OBSERVED ENERGY ', X '.LT. 0...' GO TO 998 ENDIF DELEIC(J,J0)=DEM/TUNIT ENDDO ENDIF C C OLD TERMS C IF(MDELE.NE.0.AND.ISHFTLS.EQ.0)THEN MD=IABS(MDELE) ISHFTLS=1 DO K=1,MD C READ(5,*)I,DEM C DELELS(I,1)=DEM/(DTWO*DKCM) ENDDO ENDIF C ELSEIF(INCLUD.NE.0.AND.IOPTIM.EQ.0)THEN C C CHECK NOT VARYING SLATER IF NO OBS ENERGIES READ. C DO K=1,NVAR0 IF(IBUF(K).EQ.ISCALR)THEN WRITE(6,*)'***SR.MINIM: VARYING SLATER SCALING TO MINIMIZE' X ,' ABSOLUTE ENERGY SUM WILL NOT CONVERGE!!' WRITE(0,*)'***SR.MINIM: SLATER SCALING WILL NOT CONVERGE' GO TO 998 ENDIF ENDDO C ENDIF C C PLASMA SCREENING INFO: C TKAY=ELECTRON TEMP*K IN RYD. DENE=ELECTRON DENSITY IN CM-3 C ZNP=-999 DENE=DZERO TKAY=DONE IF(MDEN.GT.0)THEN IF(NDEN.LE.0)NDEN=1 NDEN=MIN(NDEN,MXD15) C READ(5,*)(DENS(N),TKAYS(N),N=1,NDEN) C NDEN=NDEN-1 ENDIF C C END READ INPUT AND INITIAL SETUP-------------------------------------- C C 95 NF0=NF C C FOR STUPID G77 COMPILER: C MPRNT0=MPRINT NLAM0=NLAM NVAR0=NVAR*ISVAR IMXIT=IMAXIT TVARY0=TVARY C RETURN C 999 WRITE(6,1997) WRITE(0,*)'*** SR.MINIM0: ERROR READING NAMELIST SMINIM!' !FATAL C 998 NF=-1 GO TO 95 C C 1997 FORMAT('*** SR.MINIM0: ERROR READING NAMELIST SMINIM!'/4X, X'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES') 1000 FORMAT( ' SR.MINIM REQUIRES MXVAR =',I4, ' RATHER THAN',I4) 997 FORMAT(/' *** SR.MINIM: ERROR, YOU HAVE SPECIFIED RELAXED ORBITAL' X ,I3,' AS AN EXTERNAL ORBITAL!') 996 FORMAT(/' *** SR.MINIM: ERROR, TRYING TO VARY EXTERNAL ORBITAL=' X ,I3) 995 FORMAT(16I5) 994 FORMAT('***ERROR, ORBITAL K=',I3,' TO BE VARIED DOES NOT EXIST!') 993 FORMAT(//35X,60('*')/) 992 FORMAT(' SR.MINIM REDUCES NLAM/NEXTRE=',I3, ' TO ',I3) 991 FORMAT(" SR.MINIM RESETS INCLUD=0, BECAUSE YOU'VE FLAGGED " X,"CONTINUUM INPUT FOR ORBITAL NO. =",I2) 990 FORMAT( " SR.MINIM RESETS EFFECTIVE NUMBER OF ELECTRONS TO",I4, X ", BECAUSE YOU'VE SPECIFIED MRED =",I3) 899 FORMAT( ' ERROR IN SR.MINIM, YOU HAVE DECLARED ORBITAL',I3, 'BOTH X AS A VALENCE AND AS A CONTINUUM ORIBTAL' /) 898 FORMAT( ' WARNING, YOU HAVE SPECIFIED MDELE .LT. 0 WITH NO RESTART X, MDELE HAS BEEN RESET TO ZERO BY SR.MINIM') 897 FORMAT(' *** SR.MINIM: ERROR, EXTERNAL ORBITAL',I3,' WOULD', X ' BE REPEATEDLY ORTHOGONALIZED TO VARIATIONAL ORBITAL',I3) 895 FORMAT( ' WARNING, SR.MINIM IS UNABLE TO FIND ANY VALENCE ORBITAL XS SO DR HAS BEEN SWITCHED OFF ') 886 FORMAT('***ERRROR: VARIATIONAL PARAMETER',I3,' HAS VALUE' X ,I3,' WHICH EXCEEDS NUMBER OF SCALING PARAMETERS',I3) 885 FORMAT(//' *****ERROR, VARIATIONAL PARAMETERS MUST BE IN ASCENDING X ORDER, NOT:',15I3) 884 FORMAT(' SR.MINIM: CANNOT USE NEXTRE/NLAM.LT.0 WITH ISCALR.GT.0:' X,2I5) 883 FORMAT(///'**** BAYLISS 1-BODY POLARIZATION POTLS IN USE *****'// X' L',5X,'ALFD',6X,'RCUT'/3(I3,2F10.4/)) 882 FORMAT(///'**** NORCROSS 1-BODY POLARIZATION POTLS IN USE *****'// X' L',5X,'ALFD',6X,'RCUT'/3(I3,2F10.4/)) 881 FORMAT(///'**** BAYLISS 2-BODY POLARIZATION POTLS IN USE *****'// X7X,'',4X,''/3X,2F10.4/) 880 FORMAT(///'**** NORCROSS 2-BODY POLARIZATION POTLS IN USE *****'// X7X,'',4X,''/3X,2F10.4/) 879 FORMAT(' *** SR:MINIM: UNRECOGNIZED OPTION FOR POTIN: ',A4) 878 FORMAT(' *** SR:MINIM: UNRECOGNIZED OPTION FOR RADOUT: ',A3) 877 FORMAT(' *** SR:MINIM: UNRECOGNIZED OPTION FOR POTOUT: ',A3) 777 FORMAT(/' **** BOX STATES IN USE WITH BOUNDARY RZERO INPUT AS: ' X,F5.1/) 773 FORMAT(2I2,2X,2I2,2I5,F18.8,3X,A4) 772 FORMAT(3I2,I5,I5,F18.6,3X,A4) c 692 FORMAT('***SR.MINIM RESETS INCLUD=0 BECAUSE RELATIVISTIC' c X,' ORBITALS ARE IN USE') C END C C ******************* C SUBROUTINE MKALG1(QLMC,MAXEL,DFS,MAM,NAM) C C----------------------------------------------------------------------- C C SR.MKALG1 WORKS OUT SLATER-STATE INTERACTIONS CSLJP-C'S'L'J'P FOR C RADIATIVE MK ALGEBRA, INCLUDING BP CORRECTIONS TO M1 AND E1VEL. C C----------------------------------------------------------------------- C USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DTEN=1.0D1) PARAMETER (TYNY=1.D-5) C PARAMETER (DTOL=1.0D-8) PARAMETER (DFAC1=DTEN/(DTHREE*DTWO**8)) C LOGICAL LX1,LX2,DEBUG,DEBUG1,MSKIP,OSKIP,E1CASE,M1BODY,BPLANT1 X,BPLANT2,BFOT C X,EQUCFG C CHARACTER(LEN=4) CODE C DIMENSION QLMC(MAXEL,*),MAM(*),NAM(*),DFS(*) DIMENSION CLTM(10),VVC1(6,MXVAR),IGAM(5),CLTM2(200),ILAM(200) C EQUIVALENCE (VVC1(1,1),VC1(1)), (MCTO,MLK), (CLTM2(1),CLTM(1)) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,MGAP(5) COMMON /CMKALG1/DVC12,VC1(6*MXVAR),MJS1,MJL1,MJS2,MJL2 X,MJJL,MJJR,QLIT(10),LX1,LX2,MSKIP,OSKIP,M1BODY,NC,ND,ICLR COMMON /CMKALG2/DVC,MJ1,MJ2,MLAM,E1CASE COMMON /CCLSH/NW,NNL(MAXCL,3) CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 C C DATA DEBUG1,DEBUG /.FALSE.,.FALSE./ C BPLANT1=MXORB.LT.200 BPLANT2=MXORB.LT.37 C IFOTMX=0 IF(BFOT)IFOTMX=1 C DQ2=SQRT(DTWO) DQ3=SQRT(DTHREE) DQ3O2=SQRT(DTHREE/DTWO) DQ3O4=DQ3/DTWO C MLAM1=MLAM-2 MLAM2=MLAM+2 MLAMH=MLAM/2 MLK=MJ1-MJ2 MXLL=0 C IRLPS1=IRLPS0+1 NLS01=NLS00+1 C IF(ICLR.LT.0)GO TO 40 C EQUCFG=KF.EQ.KG JBB=JBP C C IN LOOPS 64,65 SCAN THROUGH SLATER STATES IN INITIAL AND C FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR. C DO 64 J1=JA,JB !BEGIN 64 C L1=MAM(J1) C C IF(EQUCFG)JBB=J1 DO 65 J2=JAP,JBB !BEGIN 65 C L2=NAM(J2) C C CALCULATE TRANSFORMATION COEFFICIENT FROM THE LS,ML,MS C REPRESENTATION TO THE J,MJ REPRESENTATION. C DDH=DVC12 IF(ABS(DDH).LT.TYNY)GO TO 65 ! DTOL -> TYNY C CTHESE NEXT 2 STATEMENTS RESOLVE INTERACTIONS BY SLATER STATE COLD IRKPS00=IRKPS+1 COLD IRSS00=IRSS+1 C DO I=IRLPS1,IRLPS IORIG1(I)=0 ENDDO DO I=NLS01,NLS IORIG2(I)=0 ENDDO C C NOW COMPARE INITIAL AND FINAL SLATER STATES AND SELECT ONLY THE C ONES WHICH DIFFER IN NK=0, 1, OR 2 SETS OF QUANTUM NUMBERS C NK=0 N2=0 MU=0 DO 174 I=1,NF N2P=QLMC(I,L1) ICG2=QCG(I,KF) DO 73 L=1,NF IF(QLMC(L,L2).NE.N2P) GO TO 73 IF(IEQ(QCG(L,KG)).NE.IEQ(ICG2)) GO TO 73 LP=L GO TO 74 73 CONTINUE NK=NK+1 IF(NK.GT.2)GO TO 65 IF(NK.EQ.2)THEN IF(M1BODY.or.mskip)GO TO 65 !********* ONE-BODY SWITCH ******** GO TO 76 ENDIF N1=I 76 N1P=I MU=I+MU LP=0 74 QLMC(I,1)=LP 174 CONTINUE C IF(NK.EQ.0) GO TO 88 DO 70 L=1,NF DO 71 I=1,NF IF(QLMC(I,1).EQ.L) GO TO 70 71 CONTINUE N2P=L MU=L+MU IF(N2.NE.0) GO TO 87 C TMP IF(N2.NE.0) GO TO 65 N2=N2P IF(NK.EQ.1) GO TO 87 C L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2 70 CONTINUE C 88 N2=N2+1 IF(N2.GT.NF) GO TO 69 N1=N2 87 ICG1=QCG(N1,KF) ICG2=QCG(N2,KG) IFOT1=0 IF(QN(ICG1).GE.90)IFOT1=1 IFOT2=0 IF(QN(ICG2).GE.90)IFOT2=1 C IF((IFOT1+IFOT2).GT.IFOTMX)GO TO 82 !OMIT CONTINUUM-CONTINUUM C C FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL C ELECTRONS, WHOSE NUMBERS ARE N1,N2. C LR=QL(ICG2) LL=QL(ICG1) LAM=QLMC(N2,L2) QLML2=((LAM+100)/2)*2-100 QLMS2=(LAM-QLML2)*2-1 LAM=QLMC(N1,L1) QLML1=((LAM+100)/2)*2-100 QLMS1=(LAM-QLML1)*2-1 C IF(M1BODY)THEN !************** ONE-BODY SWITCH ************** IF(E1CASE)GO TO 49 IF(IABS(MBP2MX).LT.MLAM)GO TO 42 ENDIF C IF(QLIT(10).EQ.QCUT) GO TO 49 IF(MSKIP)THEN IF(MBP1MX.Lt.0)GO TO 42 !for type 9 pure mk GO TO 49 !for type 8 etc., i.e. inc. alpha^2 corr. ENDIF IF((QCUT.EQ.QLIT(8) .OR. NC.NE.ND) .AND. OSKIP) GO TO 49 C LAM=NF IF(NK.GT.1)GO TO 46 IF(NK.EQ.1)GO TO 44 LAM=N1 44 N1P=-NW 45 N1P=N1P+1 IF(N1P.GT.0) GO TO 77 KP=N1P+NW ICG1P=NNL(KP,1) ICG2P=ICG1P MA=NNL(KP,2) MC=MA GO TO 78 77 IF(N1P.GT.LAM) GO TO 49 IF(N1P.EQ.N1) GO TO 45 N2P=QLMC(N1P,1) C TST ICG1P=QCG(N1P,KF); ICG2P=ICG1P C TST MA=QLMC(N1P,L1); MC=MA; GO TO 78 46 ICG1P=QCG(N1P,KF) ICG2P=QCG(N2P,KG) MA=QLMC(N1P,L1) MC=QLMC(N2P,L2) 78 QLML2P=((MC+100)/2)*2-100 QLMS2P=(MC-QLML2P)*2-1 QLML1P=((MA+100)/2)*2-100 QLMS1P=(MA-QLML1P)*2-1 LLP=QL(ICG1P) LRP=QL(ICG2P) KP=1 47 KO=1 66 LO=IABS(LL-LR) IF(LO.GT.6.OR.MBP2MX.LT.0) GO TO 67 !***** ONE-BODY SWITCH ***** C I1P=IABS(LLP-LRP) C ETC............. ILAM(200)=9999 C +-+ +++++++++++++++++++++++++++++++++++++++ C CLAUDE, INSERT HSC.CZMAGADD.FORT HERE C CLTM2(199)=DDH*KO*KP; ILAM(199)=-9999 C KTERM=200 MTEST2=QLMS1-QLMS2 MTES2P=QLMS1P-QLMS2P IF(MTEST2.NE.0.AND.MTES2P.NE.0) GO TO 67 MX=-MTEST2-MTES2P MTEST1=QLML1-QLML2 MTES1P=QLML1P-QLML2P MP1=QLML1+QLML2+QLML1P+QLML2P DDS=DZERO IF(MTES2P.NE.0)GO TO 203 CC DDS=.5773502691896 DDS=-DONE/DQ3 CC -''' TO ABSORB FACTOR (-1)**(-QLMS1-QLMS2) IF(QLMS1+QLMS2.NE.0)GO TO 202 DDS=SQRT(DTWO/DTHREE) 202 IF(QLMS1.GT.0) DDS=-DDS IF(MTEST2.NE.0)GO TO 204 203 DD=-DONE/DQ3 IF(QLMS1P+QLMS2P.NE.0)GO TO 205 DD=SQRT(DTWO/DTHREE) 205 IF(QLMS1P.GT.0) DD=-DD DDS=DD+DDS 204 I2P=LLP+LRP LP=LL+LR LA=LO C 255 D2C2=VCC(LR,LA,LL,0,0,0,DFS,MXDFS) C ID=LA+2 IC=IABS(LA-2) LB=MAX0(LA-2,LO) 256 IF(LB.GT.LP) GO TO 206 IF(IABS(MTEST1).GT.LB) GO TO 207 C D2C3=VCC(LL,LB,LR,-QLML1,MTEST1,-QLML2,DFS,MXDFS) C IF(MX.NE.0) GO TO 208 C JJJ DD =SJS(LA,2,LB,LR,LL,LR,DFS,MXDFS) * C JJJX SQRT(DBLE((LA+1)*(LB+1)*(LR+2)*(LR+1)*LR*3)) LM=LA+2 IF(LA.GT.LB)GO TO 233 IF(LA.LT.LB)GO TO 231 D2C6J=DZERO IF(LA.EQ.0)GO TO 208 D2C6J=((LL+2)*LL-(LR+2)*LR-LM*LA)*SQRT(((LA+1)*3)/DBLE(LM*LA*4)) GO TO 220 231 D2C6J=-SQRT(((LR+LL+LA+4)*(LR-LL+LM)*(LM+LL-LR)*(LR+LL-LA)*3)/ XDBLE(8*LM)) GO TO 220 233 D2C6J=SQRT(((LR+LL+LM)*(LR-LL+LA)*(LA+LL-LR)*(LR+LL-LA+2)*3)/ XDBLE(8*LA)) 220 CONTINUE C C JJJ IF(DABS(D2C6J-DD).GT.1.E-4)WRITE(6,888)LL,LR,LA,LB, D2C6J, DD C 888 FORMAT( ' *** LL,LR,LA,LB: SJS *** ',4I4,2F10.5) C 208 LC=I1P C 257 D2C4=VCC(LRP,LC,LLP,0,0,0,DFS,MXDFS) C IB=LC+2 IA=IABS(2-LC) LD=LC C 258 IF(LD.LT.I1P.OR.LD.GT.I2P)GO TO 209 IF(IABS(MTES1P).GT.LD) GO TO 209 C D2C5=VCC(LLP,LD,LRP,-QLML1P,MTES1P,-QLML2P,DFS,MXDFS) C IF(LB.NE.LA)GO TO 240 IF(DDS.EQ.DZERO) GO TO 240 IF(LA.NE.LC) GO TO 252 IF(MTEST1.NE.-MTES1P) GO TO 252 KTERM=KTERM-1 IF(KTERM.LE.0)GO TO 99 C CLTM2(KTERM)=(1-MOD(IABS(MCTO+MTEST1),4))*DDS*D2C2*D2C3* CLTM2(KTERM)=(MOD(IABS( MTEST1),4)-1)*DDS*D2C2*D2C3* X D2C4*D2C5*DQ3 ILAM(KTERM)=LA 252 LF=IA MA=MTEST1-MX DD=-1 IF(LC.EQ.0) GO TO 238 DD=(MOD(LC,4)-1)/SQRT(DBLE(LC+1)) LM=(LC+1)*(LC-1) MC=-600 GO TO 250 238 LM=-(LC+1)*(LC+3) MC=600 250 IF(IABS(LF-LA).NE.2) GO TO 237 KTERM=KTERM-1 IF(KTERM.LE.0)GO TO 99 II=(LA-LF+2)/4+LF KK=(LC-LF+2)/4+LF C C NOTE: (-1)**((LA+LC)/2)=+1, BECAUSE M1-TRANSITIONS CONSERVE PARITY C C CLD+ CLTM2(KTERM)=1.154700538 *LM * D2C2*D2C3*D2C4*D2C5* CLAUDE, SECTION 'MX.NE.0' BUG FREE I HOPE, SINCE JULY 23. WERNER AUG80 C CLTM2(KTERM)=((MOD(IABS(MX-MP1),4)-1)*LM*2)*D2C2*D2C3*D2C4*D2C5* X DDS*VCC(LF,2,LA,MA,MX,MTEST1,DFS,MXDFS)*VC1(II) X *DD*VCC(LC,LF,2,MTES1P,MA,MCTO,DFS,MXDFS)*VC1(KK) C C VC1(II)=VCC(LF,2,LA,0,0,0,DFS,MXDFS) C VC1(KK)=VCC(LC,LF,2,0,0,0,DFS,MXDFS) C ILAM(KTERM)=ISIGN(LC,MC)+MC 237 LF=LF+4 IF(LF.LE.IB)GO TO 238 C --- IF(MTEST2.NE.0.OR.MTES2P.NE.0) I.E. 240 IF(MX.NE.0) GO TO 209 IF(MJS2.NE.MJS1) GO TO 209 IF(LB+LC.EQ.0) GO TO 209 IF(IABS(LC-LB).GT.2) GO TO 209 C D2C0=((MOD(IABS(MTES1P+MP1),4)-1)*2)*SQRT(DBLE((LC+1)*3))* X VCC(LC,2,LB,-MTES1P,MCTO,MTEST1,DFS,MXDFS)*D2C2*D2C3*D2C4*D2C5 C LE=IA C 210 DC1=SJS(2,2,2,LE,LD,LB,DFS,MXDFS) C DL1=DONE/SQRT(DBLE(LE+1)) KK=(LC-LE+2)/4+LE LF=IC 264 II=(LA-LF+2)/4+LF DD1=VC1(II)*VC1(KK)*DC1*D2C0 C C VC1(II)=VCC(LF,2,LA,0,0,0,DFS,MXDFS) C VC1(KK)=VCC(2,LE,LC,0,0,0,DFS,MXDFS) C EVT IF(DD1.EQ.0.) GO TO 268 C DC2=SJS(2,2,2,LA,LB,LF,DFS,MXDFS) C DL2=SQRT(DBLE(LF+1)) LG=IABS(2-LE) IF(LE.EQ.0)GO TO 262 LM=(LE+1)*(LE-1) MC=- 500-LE MA=-600-LE+2 GO TO 261 262 LM=-(LE+1)*(LE+3) MC=LE+2+700 MA=LE+2+600 261 IF(IABS(LG-LF).NE.2) GO TO 260 IF(KTERM.LT.5) GO TO 99 I=(LF-LG+2)/4+LG K=(LE-LG+2)/4+LG C C VCC(2,LG,LF,0,0,0,DFS,MXDFS)=VC1(I);VCC(LE,LG,2,..)=(MOD(LE,4)-1)* C VC1(K)*DL1*SQR(3) DD=LM*SJS(LE,LG,2,LF,LB,2,DFS,MXDFS)*DD1*VC1(I)*VC1(K)*DL1*DL2 KTERM=KTERM-1 CLTM2(KTERM)=D2C6J*DC2*DD C CLAUDE, I REINTRODUCED, NOW THROUGH D2C0, A PHASE FACTOR (-1)**MP1 WHICH C#**** YOU HAD THROWN OUT WITH PHS0 IN JULY. PLEASE CLARIFY. WERNER 80AU ILAM(KTERM)=MA IF(LB.NE.LA) GO TO 260 KTERM=KTERM-1 CLTM2(KTERM)=DD*DQ2 ILAM(KTERM)=MC 260 LG=LG+4 IF(LG.LE.LE+2)GO TO 262 IF(LF.NE.LE) GO TO 268 C C NOTE: LF=LC-2 AND LC+2 (SUBJECT TO .GE.LA-2, .LE.LA+2, SEE IC ID) C LE=LC-2 AND LC+2; THUS ALWAYS ONE MATCH FOR LF IN SET LE. C KTERM=KTERM-1 CLTM2(KTERM)=DC2*D2C6J*DD1 ILAM(KTERM)=-400-LF IF(LB.NE.LA) GO TO 268 KTERM=KTERM-1 CLTM2(KTERM)=DD1*DQ2 ILAM(KTERM)=-300-LF 268 LF=LF+4 IF(LF.LE.ID)GO TO 264 LE=LE+4 IF(LE.LE.IB)GO TO 210 C CQ219 IF(MX.NE.0) GO TO 209 C ARCHIVED HSC.CZDIRAFS.MAR80.DATA OF MARCH 15TH DOES NOT YET MAKE C USE OF PARTICLE SYMMETRY PROPERTIES-HAS OLD BULKY CODE. C CO209 LD=LD+2 CO IF(LD.LE.IB)GO TO 258 209 LC=LC+4 IF(LC.LE.I2P)GO TO 257 207 LB=LB+2 IF(LB.LE.ID)GO TO 256 206 LA=LA+4 IF(LA.LE.LP)GO TO 255 C C +-+ +++++++++++++++++++++++++++++++++++++++ C PHS0=(1-MOD((MU+KO+KP)*2,4))*DDH CLTM2(200)=DZERO C TST CLTM2(200)=(1-MOD(MJJR-MJ2,4))*DVC/(17.320508*PHS0) C C C *** STORE TWO-BODY COEFFICIENTS *** C DO 214 K=KTERM,200 C DD=CLTM2(K) IF(DD.EQ.DZERO) GO TO 214 LM=ILAM(K) MC=(IABS(LM)+2)/100 C XXX IF(MC.NE.0) DD=DD+DD C XXX CLAUDE HAS NOW ABSORBED FACTORS 2 INTO CLTM2 -- 1980 JULY KK=0 II=0 C-TST IF(MC.GT.4) GO TO 277 IF(LM.LT.0) GO TO 274 IF(MC.GT.0) GO TO 277 IF(ICG1.LE.ICG2) GO TO 277 274 LM=IABS(LM) C 275 CONTINUE II=1-II 277 IGAM(1+II+KK)=ICG1 IGAM(2-II+KK)=ICG1P IGAM(3+II-KK)=ICG2 IGAM(4-II-KK)=ICG2P CNRB IF(KK.NE.0) GO TO 279 C TST IF(LM.EQ.9999) GO TO 279 CNRB IF(IGAM(1).LT.IGAM(3)) GO TO 279 CNRB KK=2 CNRB IF(MC.NE.0) GO TO 278 CNRB IF(IGAM(4).LT.IGAM(3)) GO TO 275 CNRB 278 IF(MOD(MC,2).EQ.0) GO TO 277 CNRB 279 CONTINUE IGAM(5)=LM C EVT ADD CODE TO REDUCE NUMBER OF INTEGRALS INVOLVING A DERIVATIVE C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C IF(BPLANT2)IPLANT=IGAM(5)+ X((((IGAM(4)*MXORB+IGAM(3))*MXORB+IGAM(2))*MXORB)+IGAM(1))*1000 DO 272 J=NLS01,NLS IF(.NOT.BPLANT2)THEN DO I=5,1,-1 !1,5 SLOWER IF(QSSS(I,J).NE.IGAM(I)) GO TO 272 ENDDO ELSE IF(IPLANT.NE.JORIG2(J))GO TO 272 ENDIF L=J I=IORIG2(L) IF(I.GT.0)THEN DSSS(I)=DD*PHS0+DSSS(I) GO TO 214 ENDIF GO TO 281 272 CONTINUE C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C L=NLS+1 IF(L.GT.MXS2I) GO TO 495 NLS=L DO I=1,5 QSSS(I,L)=IGAM(I) ENDDO IF(BPLANT2)JORIG2(L)=IPLANT 281 IRSS=IRSS+1 IF(IRSS.GT.MXS2C) GO TO 494 IORIG2(L)=IRSS MSSS(IRSS)=L DSSS(IRSS)=DD*PHS0 NSTJ2(IRSS)=L1 NSTJ2D(IRSS)=L2 C 214 CONTINUE C C *** END STORE TWO-BODY COEFFICIENTS *** C C C *********************** END TWO-BODY SECTION ************************* C 67 II=ICG1P ICG1P=ICG1 ICG1=II LM=LLP LLP=LL LL=LM KK=QLML1P QLML1P=QLML1 QLML1=KK KK=QLMS1P QLMS1P=QLMS1 QLMS1=KK KO=KO-1 IF(KO.GE.0) GO TO 66 II=ICG2P ICG2P=ICG2 ICG2=II LM=LRP LRP=LR LR=LM II=QLML2P QLML2P=QLML2 QLML2=II II=QLMS2P QLMS2P=QLMS2 QLMS2=II KP=KP-1 IF(KP.GE.0) GO TO 47 IF(NK.GT.1)GO TO 65 GO TO 45 49 IF(NK.GT.1) GO TO 65 IF(IABS(LL-LR).GT.4) GO TO 82 MTEST2=QLMS1-QLMS2 MTEST1=QLML1-QLML2 DD=DZERO IF(MXLL.EQ.-1) DD=DONE DO 120 K=1,8 CLTM(K)=DD 120 CONTINUE C IF(DEBUG1) WRITE(6,700) NK, L1,L2, LL,LR C C C CCC DDS=VCC(1,2,1,-QLMS1,MTEST2,-QLMS2,DFS,MXDFS) C DDS=DONE/DQ3 IF(QLMS1+QLMS2.NE.0) GO TO 133 DDS=DONE/DQ3O2 133 IF(QLMS1.GT.0) DDS=-DDS MC=1-IABS(MCTO) LP=1 C IF(E1CASE)GO TO 137 !************** ONE-BODY SWITCH ************** C LAM=(LL+2)*LL IF(MSKIP) GO TO 127 IF(LL+LR.EQ.0) GO TO 150 MA=1-IABS(MTEST2) C DD=VCC(LR,4,LL, 0,0,0, DFS,MXDFS) DL2=VCC(LL,4,LR, -QLML1,MTEST1,-QLML2, DFS,MXDFS) DC2=VCC(2,4,2, MTEST2,MTEST1,MCTO, DFS,MXDFS) *(MC*MA) C CLTM(2)=-((LAM-(LR+2)*LR+24))*DL2*DD*DC2*DDS*SQRT(DFAC1) CLTM(3)=-((LAM-(LR+2)*LR-24))*DL2*DD*DC2*DDS*SQRT(DFAC1) CLTM(4)=-DL2*DD*DC2*DDS*SQRT(DTEN/DTHREE) CLTM(5)=CLTM(4) C *** CLTM(1)=....... TERM LM=MIN0(LL,LR)+2 DL1=6 !4->6 LM=LL+2 IF(LR.GT.LL)GO TO 130 IF(LR.EQ.LL)GO TO 131 LM=LR+2 DC1=(LM-2)* LM DD1=(LM+3)*5 DD2=LM-1 GO TO 129 C 131 DL1=6 131 DL1=12 DC1=-(LM+2)*(LM-2) DD1=(LM-3)*(LM-2)*15 DD2=(LM-1)*LM*2 GO TO 129 130 DC1=(LM+2)*(LM+4) DD1=(LM-1)*5 DD2=LM+3 129 II=(LM-LL+2)/4+LL KK=(LR-LM+2)/4+LM C C TST CLTM(1)=VCC(LL,2,LM,0,0,0,DFS,MXDFS)*VCC(LM,2,LR,0,0,0,DFS,MXDFS)* C TSTX SJS(LL,LM,2,2,2,LM,DFS,MXDFS)*SJS(LM,LR,2,2,2,LR,DFS,MXDFS)* C TSTX SJS(LL,LR,4,2,2,LM,DFS,MXDFS)*((LM+1)*30)*DC2*DL2*DDS* C TSTX SQRT(DBLE((LR+2)*LR*(LL+1)*(LM+2)*LM))+CLTM(1) C CLTM(1)=VC1(II)*VC1(KK)* X SQRT(DD1/DD2)*DC2*DL2*DDS*DC1/DL1+CLTM(1) C IF(LR.NE.LL) GO TO 103 IF(LM.LT.LL) GO TO 128 LM=LL-2 IF(LM.EQ.0) GO TO 128 C *** CLTM(1)=.......+CLTM(1) TERM LM=LL-2=LR-2 DC1=-(LM+4)* LM DD1=(LM+5)*(LM+4)*15 DD2=(LM+3)*(LM+2)* 2 GO TO 129 127 LP=8 IF(MTEST2.NE.0)GO TO 150 128 IF(IABS(MTEST1).GT.2) GO TO 103 C 137 DL1=VCC(LL,2,LR, -QLML1,MTEST1,-QLML2, DFS,MXDFS) C IF(MSKIP.AND..NOT.E1CASE)GO TO 149 C DC1=VCC(2,2,2, MTEST2,MTEST1,MCTO, DFS,MXDFS) C IF(E1CASE)GO TO 42 !************** ONE-BODY SWITCH ************** C DD1=SQRT(DBLE(LAM)/6) DD2=SQRT(DBLE((LL+LR-2)*(LL+LR+6))/24)*(MA*DD) C CLTM(2)=(DD1*MA-DD2)*DL1*DC1+CLTM(2) C CLTM(3)=-(DD1*MC+DD2)*DL1*DC1+CLTM(3) DD=(DD1*MA-DD2)*DL1*DC1*MC*DDS CLTM(3)=DD+CLTM(3) CLTM(2)=CLTM(2)-DD IF(MTEST2.NE.0)GO TO 150 149 CLTM(8) =(MOD(IABS(QLMS1+QLMS2),4)-1)*MC* SQRT(DBLE(LAM/4))*DL1 150 IF(MTEST1.NE.0)GO TO 126 DD=DDS*DQ3 CLTM(8)=CLTM(8)+DD IF(MSKIP) GO TO 126 CLTM(4)=CLTM(4)+DD/3 CLTM(5)=CLTM(4)-DD IF(LL.NE.0)CLTM(1)=(LAM*DD)/12+CLTM(1) C OUT IF(QN(ICG2).NE.QN(ICG1)) GO TO 126 CLTM(6)=DD 126 IF(DEBUG) WRITE(6,104) CLTM(6),CLTM(8) 103 MX=8 KTERM=8 CLTM(7)=CLTM(5) PHS0=(1-MOD((N1+N2)*2+QLMS1+QLMS2,4))*DDH GO TO 38 C C ***************** BEGIN NON-BP MK (ONE-BODY) SECTION ***************** C 42 IF (.NOT.E1CASE) THEN ! CASE MK DDV = VCC(LL,MLAM1,LR,0,0,0,DFS,MXDFS) DD = DZERO LP=10 KTERM = 9 IF (DDV.EQ.DZERO) GO TO 55 DDL = DZERO IF (QLMS2.EQ.QLMS1) THEN ! CONTRIBUTION {C[K-1]XL[1]}[K]/DD1 MMM = (MLAM-LL-LR)/2 DDL= VCC(LR,MLAM,LL,QLML2,MLK,QLML1,DFS,MXDFS) X * SJS(LL,LR,MLAM,2,MLAM1,LR,DFS,MXDFS) !MLAM1,2 WRONG! X * SQRT(DBLE((MLAM+1)*(LR+1)*LR/2*(LR/2+1))) X * (-1)**MMM ENDIF ! PLUS {C[K-1] X (K+1)S[1]}[K]/DD1 C WRITE(6,*)'L',LR,MLAM,LL,QLML2,MLK,QLML1,DDL MMM = (MLAM1-LL-LR)/2 !-LL-LR MQL = QLML1-QLML2 MQS = QLMS1-QLMS2 DDS = VCC(LR,MLAM1,LL,QLML2,MQL,QLML1,DFS,MXDFS) X * VCC(1,2,1,QLMS2,MQS,QLMS1,DFS,MXDFS) X * VCC(MLAM1,2,MLAM,MQL,MQS,MLK,DFS,MXDFS) X * DQ3O4*(MLAMH+1)*(-1)**MMM C WRITE(6,*)'S',LR,MLAM1,LL,QLML2,MQL,QLML1,QLMS2,MQS,QLMS1,DDS DD=DDS+DDL IF (DD.NE.DZERO)THEN LP = 9 CLTM(9) = 2*DD*DDV*SQRT(DBLE(MLAMH*(MLAM-1)))/(MLAMH+1) C DD=-DD*SQRT(DBLE(MLAMH*(MLAM-1)))/((MLAMH+1)*(MLAM+1)) ENDIF C IF(MLAM.GT.MBP1MX)GO TO 33 C 55 CONTINUE !LOOK FOR LAM+1 IF NO LAM-1 C C WRITE(6,*)MJ1,MJ2,LL,LR,QLML1,QLML2,QLMS1,QLMS2,MLAM2,MLAM,MLK DDV1 = VCC(LL,MLAM2,LR,0,0,0,DFS,MXDFS) IF (ABS(DD)+ABS(DDV1).EQ.DZERO) GO TO 82 IF (DDV1.EQ.DZERO) GO TO 33 DDL1 = DZERO IF (QLMS2.EQ.QLMS1) THEN ! CONTRIBUTION {C[K+1]XL[1]}[K]/DD1 MMM = (MLAM-LL-LR)/2 DDL1= VCC(LR,MLAM,LL,QLML2,MLK,QLML1,DFS,MXDFS) X * SJS(LL,LR,MLAM,2,MLAM2,LR,DFS,MXDFS) !MLAM2,2 WRONG! X * SQRT(DBLE((MLAM+1)*(LR+1)*LR/2*(LR/2+1))) X * (-1)**MMM c WRITE(6,*)'L1',LR,MLAM,LL,QLML2,MLK,QLML1,DDL1 ENDIF ! PLUS {C[K+1] X (K+1)S[1]}[K]/DD1 MMM = (MLAM2-LL-LR)/2 !-LL-LR MQL = QLML1-QLML2 MQS = QLMS1-QLMS2 DDS1=VCC(LR,MLAM2,LL,QLML2,MQL,QLML1,DFS,MXDFS) X * VCC(1,2,1,QLMS2,MQS,QLMS1,DFS,MXDFS) X * VCC(MLAM2,2,MLAM,MQL,MQS,MLK,DFS,MXDFS) X * DQ3O4*MLAMH*(-1)**MMM !-LL-LR c WRITE(6,*)'S1',LR,MLAM2,LL,QLML2,MQL,QLML1,QLMS2,MQS,QLMS1,DDS1 DD1=(DDS1+DDL1) DD1=DD1*2*SQRT(DBLE((MLAM+3)/(MLAMH+1)))/((MLAM+3)*(MLAM+1)) C DD=DD+DD1 IF(DD.EQ.DZERO)GO TO 82 KTERM=10 CLTM(10)=DD*DDV1 C 33 PHS0 = DDH ! N.B. VC12 ALREADY IN DDH, BUT COUPLE LSJ, NOT SLJ! X *(1-MOD((N1+N2)*2+MJL1+MJS1+MJJL+MJL2+MJS2+MJJR,4)) C WRITE(6,*)MJ1,MJ2,LL,LR,QLML1,QLML2,QLMS1,QLMS2,MLAM2,MLAM,MLK c write(6,*)'lam=',mlam/2,'c9=',ddv,ddh,cltm(9)*phs0 ELSE ! CASE E1VEL KTERM = 1 II = (LL-LR+2)/4+LR CLTM(1) = DC1*DDS*DL1*VC1(II)*SQRT(DBLE(2*(MLAM+1))) PHS0 = MC * DDH ENDIF C C ****************** END NON-BP MK (ONE-BODY) SECTION ****************** C C *** STORE ONE-BODY COEFFICIENTS *** C 38 IGAM(3)=MLAM DO 114 K=LP,KTERM C DD=CLTM(K)*PHS0 IF(DD.EQ.DZERO) GO TO 114 MA=ICG1 MC=ICG2 IF(ICG1.GE.ICG2) GO TO 124 IF(K/2.EQ.1) GO TO 124 MA=MC MC=MC-ICG2+ICG1 124 MX=MX-1 C IGAM(1)=MA IGAM(2)=MC IGAM(4)=K IF(BPLANT1) XIPLANT=(((IGAM(4)*1000+IGAM(3))*1000+IGAM(2))*MXORB)+IGAM(1) DO 72 J=IRLPS1,IRLPS IF(.NOT.BPLANT1)THEN DO I=4,1,-1 IF(QRLPS(I,J).NE.IGAM(I))GO TO 72 ENDDO ELSE IF(IPLANT.NE.JORIG1(J))GO TO 72 ENDIF I=IORIG1(J) IF(I.GT.0)THEN DRKPS(I)=DRKPS(I)+DD GO TO 114 ENDIF L=J GO TO 81 72 CONTINUE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT C L=IRLPS+1 IF(L.GT.MXS1I) GO TO 493 IRLPS=L DO I=1,4 QRLPS(I,L)=IGAM(I) ENDDO IF(BPLANT1)JORIG1(L)=IPLANT 81 IRKPS=IRKPS+1 IF(IRKPS.GT.MXS1C)GO TO 492 IORIG1(L)=IRKPS NRKPS(IRKPS)=L DRKPS(IRKPS)=DD NSTJ1(IRKPS)=L1 NSTJ1D(IRKPS)=L2 C 114 CONTINUE C C *** END STORE OF ONE-BODY COEFFICIENTS *** C 82 IF(NK.EQ.0) GO TO 88 C C NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON C QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED, C THEREFORE PROCEED TO NEXT PAIR OF SLATER STATES. C 69 IF(MXLL.NE.-1) GO TO 65 IF(MX.NE.0) GO TO 65 IF(IRKPS.GE.IRKPS0) GO TO 39 C C 65 CONTINUE !END C 64 CONTINUE !END C C IF .T. RETURN AND COMPUTE FOR DIFFERENT MS,ML GIVING THE SAME MS+ML=MJ C 39 IF(LX2) RETURN C IF(LX1) RETURN C C INSERT ARRAY CLEARING PARAGRAPHS HERE (LX1 AND LX2) C 40 ICLR=0 PHS0=(1-MOD(MJJR-MJ2,4))*SQRT(DBLE(MLAM+1))/DVC C IF(IRKPS.LT.IRKPS0) GO TO 15 C C IF THE MATRIX ELEMENT HAS BEEN CALCULATED CLEAR THE ARRAY DRKPS C OF ZEROS AND ADJUST NRKPS. C K=IRKPS0-1 KP=0 C IF(IRLPS0+1.NE.IRLPS1)STOP'IRLPS ERROR' DO I=IRLPS1,IRLPS IORIG1(I)=0 ENDDO C DO 91 I=IRKPS0,IRKPS JD0=NRKPS(I) JD=IABS(JD0) IF(ABS(DRKPS(I)).GE.TYNY) GO TO 97 IF(IORIG1(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QRLPS AS MAY OCCUR LATER GO TO 94 97 K=K+1 DRKPS(K)=DRKPS(I)*PHS0 NSTJ1(K)=NSTJ1(I) NSTJ1D(K)=NSTJ1D(I) C 94 IF(JD.LE.IRLPS0)THEN WRITE(6,*)'MKALG1: INFORM NRB OF STOP HERE - 1',JD,IRLPS0 WRITE(0,*)'MKALG1: INFORM NRB OF STOP HERE - 1' NF=-1 GO TO 90 C LP=JD C GO TO 92 ENDIF C IF(IORIG1(JD).EQ.0)THEN LP=JD-KP DO 95 L=1,IRLPS0 DO 96 J=1,4 IF(QRLPS(J,JD).NE.QRLPS(J,L))GO TO 95 96 CONTINUE KP=KP+1 IORIG1(JD)=L LP=L GO TO 92 95 CONTINUE ELSE LP=IORIG1(JD) GO TO 92 ENDIF C IORIG1(JD)=LP DO 93 J=1,4 QRLPS(J,LP)=QRLPS(J,JD) 93 CONTINUE C 92 IF(JD0.EQ.0)GO TO 91 NRKPS(K)=LP C IF(JD0.LT.0)NRKPS(K)=-NRKPS(K) 91 CONTINUE C IRLPS=IRLPS-KP IRKPS=K C C SIMILARLY, CLEAR TWO-BODY ARRAYS C 15 IF(IRSS.LT.IRSS0)GO TO 90 C K=IRSS0-1 KP=0 DO I=NLS01,NLS IORIG2(I)=0 ENDDO C DO 391 I=IRSS0,IRSS JD0=MSSS(I) JD=IABS(JD0) IF(ABS(DSSS(I)).GE.TYNY)GO TO 397 IF(IORIG2(JD).GT.0)GO TO 391 JD0=0 !RE-INDEX QSSS AS MAY OCCUR LATER GO TO 394 397 K=K+1 DSSS(K)=DSSS(I)*PHS0 NSTJ2(K)=NSTJ2(I) NSTJ2D(K)=NSTJ2D(I) C 394 IF(JD.LE.NLS00)THEN WRITE(6,*)'MKALG1: INFORM NRB OF STOP HERE - 2',JD,NLS00 WRITE(0,*)'MKALG1: INFORM NRB OF STOP HERE - 2' NF=-1 GO TO 90 C LP=JD C GO TO 392 ENDIF C IF(IORIG2(JD).EQ.0)THEN LP=JD-KP DO 395 L=1,NLS00 DO 396 J=1,5 IF(QSSS(J,JD).NE.QSSS(J,L))GO TO 395 396 CONTINUE KP=KP+1 IORIG2(JD)=L LP=L GO TO 392 395 CONTINUE ELSE LP=IORIG2(JD) GO TO 392 ENDIF C IORIG2(JD)=LP DO 393 J=1,5 QSSS(J,LP)=QSSS(J,JD) 393 CONTINUE C 392 IF(JD0.EQ.0)GO TO 391 MSSS(K)=LP C IF(JD0.LT.0)MSSS(K)=-MSSS(K) 391 CONTINUE C NLS=NLS-KP IRSS=K C C 90 RETURN C C E R R O R M E S S A G E S C 492 WRITE(6,992) GO TO 99 493 WRITE(6,993) IRLPS=L GO TO 99 494 WRITE(6,994) GO TO 99 495 WRITE(6,995) C 99 WRITE(6,990) C WRITE(0,*)'***SR.MKALG1: STORAGE EXCEEDED ***' NF=0 C GO TO 90 C 104 FORMAT(30X,1P,4E16.6,4I5) 990 FORMAT(' ***SR.MKALG1: STORAGE EXCEEDED - INCREASE DIMENSION', X ' INDICATED OR SWITCH-OFF MK OR BP RADIATIVE CORRECTIONS.') 992 FORMAT(/' SR.MKALG1: MXS1C TOO SMALL, ARRAYS DRKPS AND NRKPS') 993 FORMAT(/' SR.MKALG1: MXS1I TOO SMALL, ARRAYS DRLP1 AND QRLPS') 994 FORMAT(/' SR.MKALG1: MXS2C TOO SMALL, ARRAYS DSSS AND MSSS') 995 FORMAT(/' SR.MKALG1: MXS2I TOO SMALL, ARRAYS DNLS AND QSSS') C 400 FORMAT(A1,59X,4I6,3(I7,F9.4)/(84X,3(I7,F9.4))) 700 FORMAT(1X,I5,2X,2(I5,I4),I6) C END C C ******************* C SUBROUTINE MKALG2(DC,mam,nam,KK) C C----------------------------------------------------------------------- C C SR.MKALG2 APPLIES SLATER-STATE ALGEBRA TO INDIVIDUAL LEVELS FOR C RADIATIVE MK ALGEBRA, INCLUDING BP CORRECTIONS TO M1 AND E1VEL. C C----------------------------------------------------------------------- C USE COMMON_COEFF, ONLY: DRKP,QRLP,IRLP,NRKP !F95 USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 USE COMMON_NRBRN2, ONLY: BINDB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.D-5) PARAMETER (DTOL=1.0D-8) C INTEGER*8 N8 CF77 INTEGER*8 NRKP,MSS !F77 C LOGICAL LPT,E1CASE,BFAST !EQUCFG CF77 X ,BINDB !F77 C CHARACTER(LEN=1) MP C REAL*8 DC DIMENSION DC(0:*),mam(*),nam(*) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP,ND1,NDP1,ND2,NDP2 COMMON /CMKALG2/DVC,MJ1,MJ2,MLAM,E1CASE CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /NXRLP/IRKP,IRKP0 COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL000,NL COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /NRBAL4/MBP1MX,MBP2MX,MEKVMX,KUTM1,MPOLM CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 C DATA MG/-2/,IRLP0/0/ C ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C LPT=MPRINT.GT.0 MLAMH=MLAM/2 C EQUCFG=KF.EQ.KG C C C BEGIN MAIN LOOP 165 OVER 1-BODY SLATER STATE INTERACTIONS C IF(MXS1I.LT.MXSOI)GO TO 90 C N8=(NDP1-1) C IF(IRLP.LE.0)THEN !FLAG END OF STRUCTURE INTEGRALS IRLP=-IRLP IRLP0=IRLP ENDIF IRLP11=IRLP IRLP1=IRLP0+1 K0=NADS1(KK-1)+1 C DO J=1,IRLPS JORIG1(J)=0 ENDDO C DO KS=K0,NADS1(KK) C L1=NSTJ1(KS) L2=NSTJ1D(KS) C IF(BFAST)THEN C DDH=DC(L1+ND2)*DC(L2+NDP2)*DRKPS(KS) C C IF(EQUCFG.AND.L1.NE.L2)DDH=DDH+DC(L1+NDP2) C *DC(L2+ND2)*DRKPS(KS) ELSE c m1=mam(l1) if(m1.eq.0)go to 165 c m2=nam(l2) if(m2.eq.0)go to 165 C DDH=DC(m1)*DC(m2)*DRKPS(KS) C C IF(EQUCFG.AND.L1.NE.L2)then !& suppress go to 165 above C m2=mam(l2) C m1=nam(l1) C if(m1*m2.gt.0)then C DDH=DDH+DC(m2)*DC(m1)*DRKPS(KS) C endif C endif c ENDIF C IF(ABS(DDH).LT.DTOL)GO TO 165 C N=NRKPS(KS) L=JORIG1(N) C IF(L.GT.0)THEN K=IORIG1(L) DRKP(K)=DRKP(K)+DDH ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C L=IRLP+1 IRLP=L IRKP=IRKP+1 C IF(IRKP.GT.MXSOC)GO TO 92 IF(L.GT.MXSOI)GO TO 93 C DO I=1,4 QRLP(I,L)=QRLPS(I,N) ENDDO JORIG1(N)=L IORIG1(L)=IRKP NRKP(IRKP)=L DRKP(IRKP)=DDH ENDIF C 165 ENDDO C C CLEAR THE ARRAY DRKP OF ZEROS AND ADJUST NRKP ACCORDINGLY. C IF(IRKP.LT.IRKP0)GO TO 200 K=IRKP0-1 N1=0 C DO I=IRKP0,IRKP C IF(ABS(DRKP(I)).LT.TYNY)GO TO 190 C K=K+1 DRKP(K)=DRKP(I) N2=INT(NRKP(I)) LP=N2-N1 C DO L=IRLP1,IRLP11 DO J=1,4 IF(QRLP(J,N2).NE.QRLP(J,L))GO TO 194 ENDDO LP=L GO TO 191 194 ENDDO C N1=N1-1 DO J=1,4 QRLP(J,LP)=QRLP(J,N2) ENDDO C 191 NRKP(K)=LP+N8*MXSOI C if(iabs(mbp2mx).le.2)then ma=qrlp(1,lp) mc=qrlp(2,lp) mlamh=qrlp(3,lp)/2 !magnetic multipole mlamh=mlamh-1 !electric multipole integral required mn=min(ma,mc) mx=max(ma,mc) in=icol(mn,mx,0) c write(6,*)'bindb:',in,ma,mc,mlamh if(iabs(mbp2mx).lt.2)bindb(in,mlamh/2)=.true. if(iabs(mbp2mx).eq.2)bindb(in,mlamh/2+1)=.true. endif C IF(LPT)THEN MP='M' IF(E1CASE.and.QRLP(3,LP).eq.2)MP='E' IF(IABS(MBP2MX).LT.2)THEN DD=DRKP(K)*DVC WRITE(6,701)K,ND1,NDP1,MA,MC,LP,DRKP(K), X DD,DVC,MJ1,MJ2,MP,QRLP(3,LP)/2,QRLP(4,LP) ELSE WRITE(6,700)K,ND1,NDP1,(QRLP(J,LP),J=1,2),LP,DRKP(K) X ,MP,QRLP(3,LP)/2,QRLP(4,LP) ENDIF ENDIF C 190 N1=N1+1 C ENDDO C IRLP=IRLP-N1 IRKP=K C C C BEGIN MAIN LOOP 265 OVER 2-BODY SLATER STATE INTERACTIONS. C 200 IF(MXS2I.LT.MAXMI)GO TO 91 C NL00=NL NL1=NL000+1 K0=NADS2(KK-1)+1 C DO J=1,NLS JORIG2(J)=0 ENDDO C DO KS=K0,NADS2(KK) C L1=NSTJ2(KS) L2=NSTJ2D(KS) C IF(BFAST)THEN C DDH=DC(L1+ND2)*DC(L2+NDP2)*DSSS(KS) C C IF(EQUCFG.AND.L1.NE.L2)DDH=DDH+DC(L1+NDP2) C *DC(L2+ND2)*DSSS(KS) ELSE c m1=mam(l1) if(m1.eq.0)go to 265 c m2=nam(l2) if(m2.eq.0)go to 265 C DDH=DC(m1)*DC(m2)*DSSS(KS) C C IF(EQUCFG.AND.L1.NE.L2)then !& suppress go to 265 above C m2=mam(l2) C m1=nam(l1) C if(m1*m2.gt.0)then C DDH=DDH+DC(m2)*DC(m1)*DSSS(KS) C endif C endif c ENDIF C IF(ABS(DDH).LT.DTOL)GO TO 265 C M=MSSS(KS) L=JORIG2(M) IF(L.GT.0)THEN K=IORIG2(L) DSS(K)=DSS(K)+DDH ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C L=NL+1 NL=L IRS=IRS+1 C IF(IRS.GT.MXRSS)GO TO 94 IF(L.GT.MAXMI)GO TO 95 C DO K=1,5 QSS(K,L)=QSSS(K,M) ENDDO JORIG2(M)=L IORIG2(L)=IRS MSS(IRS)=L DSS(IRS)=DDH ENDIF C 265 ENDDO C C CLEAR THE ARRAY DSS OF ZEROS AND ADJUST MSS(K) ACCORDINGLY. C IF(IRS.LT.IRS0) GO TO 900 K=IRS0-1 KP=0 C DO I=IRS0,IRS C IF(ABS(DSS(I)).LT.TYNY)GO TO 290 C K=K+1 DSS(K)=DSS(I) JD=INT(MSS(I)) LP=JD-KP C DO L=NL1,NL00 DO J=1,5 IF(QSS(J,JD).NE.QSS(J,L))GO TO 294 ENDDO LP=L GO TO 291 294 ENDDO C KP=KP-1 DO J=1,5 QSS(J,LP)=QSS(J,JD) ENDDO 291 MSS(K)=LP+N8*MAXMI C 290 KP=KP+1 C ENDDO C NL=NL-KP IRS=K C IF(LPT)THEN IF(IRS.GE.IRS0) X WRITE(6,400)ND1,NDP1,IRS,NL,(MSS(I),DSS(I),I=IRS0,IRS) ELSE IF(MPRINT.EQ.-3) WRITE(6,704)IRKP,ND1,NDP1,MG,MG,IRLP, X ND1,NDP1,IRS,NL ENDIF C C 900 RETURN C C E R R O R M E S S A G E S C 90 WRITE(6,990) GO TO 99 91 WRITE(6,991) GO TO 99 92 WRITE(6,992) GO TO 99 93 WRITE(6,993) IRLP=L GO TO 99 94 WRITE(6,994) GO TO 99 95 WRITE(6,995) C 99 WRITE(6,999) WRITE(6,704) IRKP, ND1,NDP1, MG,MG, IRLP, X ND1,NDP1,IRS,NL C WRITE(0,*)'***SR.MKALG2: STORAGE EXCEEDED ***' NF=0 C GO TO 900 C 999 FORMAT(' ***SR.MKALG2: STORAGE EXCEEDED - INCREASE DIMENSION', X' INDICATED OR REDUCE/SWITCH-OFF MK OR BP RADIATIVE CORRECTIONS.') 990 FORMAT(/' SR.MKALG2: SET MXS1I .GE. MXSOI') 991 FORMAT(/' SR.MKALG2: SET MXS2I .GE. MAXMI') 992 FORMAT(/' SR.MKALG2: MXSOC TOO SMALL, ARRAYS DRKP AND NRKP') 993 FORMAT(/' SR.MKALG2: MXSOI TOO SMALL, ARRAYS DRLP1 AND QRLP') 994 FORMAT(/' SR.MKALG2: MXRSS TOO SMALL, ARRAYS DSS AND MSS') 995 FORMAT(/' SR.MKALG2: MAXMI TOO SMALL, ARRAYS DNL AND QSS') 400 FORMAT(57X,2I6,I9,I6,3(I7,F9.4)/(84X,3(I7,F9.4))) 700 FORMAT(I9,3I6,I4,I6, F13.5,3X,A1,I1,I4) 701 FORMAT(I9,3I6,I4,I6, F13.5,2F19.5, 6X,2I4, 3X,A1,I1,I4) 704 FORMAT(I9,3I6,I4,I6,31X,2I6,I9,I6) C END C C ******************* C SUBROUTINE MVDINT(K,DE,INUKP,MAXPS) C C----------------------------------------------------------------------- C C SR.MVDINT DETERMINES THE MASS-VELOCITY AND DARWIN INTEGRALS, C ALSO THE M1BP INTEGRALS D2LL, FOR ALL BOUND ORBITALS L.LE.K WHERE K C IS THE PRESENT ONE BEING DETERMINED. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DTWO=2.0D0) c PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C LOGICAL BREL,BJUMPR,BMVD,BREL2,bm1bp,BSTO,BORT C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TOL,MEND COMMON /COM6/DA(MAXB1) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXQS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBFR/DP(MAXB1) COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/DPT0(MAXB1),DERV1(MAXB1),DERV2(MAXB1),DPT3(MAXB1) C DZ=NZION BORT=MORT.LT.0 BREL2=IABS(IREL).EQ.2 C bm1bp=NL.GE.NL000 tz=dzero dee=dzero if(.not.bm1bp)then igagr=-1 else dza=nzion-mion+1 ! +mred ? if(igagr.gt.0)tz=dza endif tt=dz-tz C C LOOP OVER ALL OTHER COMPUTED ORBITALS L.LE.K, FOR CURRENT ORBITAL K. C DO 613 L=1,K C IF(DEY(L).EQ.DZERO)GO TO 613 IF(QL(L).NE.QL(K))GO TO 613 !check rad/diagfs c if(ql(k).ne.ql(l).and.(.not.bm1bp.or.igagr.lt.0))go to 613 C DD3=DZERO DD2=DZERO DD1=DZERO IF(BREL.AND..not.bm1bp)GO TO 614 !only radiative C .AND.L.EQ.K .OR.BREL2 IF(K.LE.IABS(MPSEUD))GO TO 614 C IF(BORT.AND..NOT.BREL)THEN C IF(MORT.EQ.-3.AND.BREL)GO TO 614 c c dee=dzero c if(igagr.gt.0.and.ql(l).ne.ql(k))dee=dey(l)-duy(l,l) c write(0,*) 'dqnl',dza,tz c DO I=1,MAXPS DS=DZ/DX(I) DD3=DPNL(I,L)*(tt/dx(i)-dee)+DQNL(I,L)/DTWO DD4=DPNL(I,K) DA(I)=DD4*DD3 DD3=DPNL(I,L)*DS+DQNL(I,L)/DTWO DD4=DD4*DS+DQNL(I,K)/DTWO DP(I)=DD4*DD3 c IF(BREL.AND.MHF.GE.0)DP(I)=DP(I)-DD4*DD4*DPNL(I,L)/DPNL(I,K) ? ENDDO GO TO 645 ENDIF C IF(BREL)THEN c write(0,*) 'rel',dza,tz tt=tz-dz DO I=1,INUK DA(I)=DPNL(I,L)*(DPT0(I)-tt/dx(i))*DPNL(I,K) ENDDO DO I=INUKP,MAXPS DA(I)=DPNL(I,L)*(DPOT(I)-tz/dx(i))*DPNL(I,K) ENDDO C IF(BREL2)THEN DO I=1,INUK DA(I)=DA(I)+DQNL(I,K)*(DPT0(I)-tt/dx(i))*DQNL(I,L) ENDDO DO I=INUKP,MAXPS DA(I)=DA(I)+DQNL(I,K)*(DPOT(I)-tz/dx(i))*DQNL(I,L) ENDDO ENDIF ELSE c write(0,*) 'non-rel',dza,tz DO I=1,MAXPS DA(I)=DPNL(I,L)*(DPOT(I)-tz/dx(i))*DPNL(I,K) ENDDO DS=DEY(L)-DUY(L,L) DO I=1,MAXPS DP(I)=DPNL(I,L)*(DE+DPOT(I))*(DS+DPOT(I))*DPNL(I,K) ENDDO ENDIF C 645 CALL WEDDLE(DD2,DA,DD3,MNE,DHNS,MJH,MAXPS) C IF(L.EQ.K)DD3=DE+DD3 C IF(BREL )GO TO 516 C .AND..NOT.BORT C C CALCULATE VALUE OF THE INTEGRAND AT THE ORIGIN. IF(QL(K).EQ.0.AND..NOT.BREL)DD2=DORIG(K)*DORIG(L)*DZ*DZ c c if(.not.brel)then !test Darwin with small-r factor c call diff(dpnl(1,k),da,mne,dhns,mjh) c call diff(dpot,dnuk1,mne,dhns,mjh) c ds=dey(l)-duy(l,l) c de=dey(k)-duy(k,k) cc write(0,*)l,k,ds,de,dpot(maxps)*dx(maxps) c do i=1,maxps c da(i)=dpnl(i,l)*dnuk1(i)*(dpnl(i,k)/dx(i)-da(i)) c t1=done+dalf*(de+dpot(i))/dtwo c t3=done+dalf*(ds+dpot(i))/dtwo c da(i)=da(i)/sqrt(t1*t3) c enddo c call weddle(dd2,da,ddd,mne,dhns,mjh,maxps) c endif C CALL WEDDLE(DD2,DP,DD1,MNE,DHNS,MJH,MAXPS) C DD2=DD2*DALF/(DZ*DEIGHT) c dd2=-ddd*dalf/dfour !test Darwin with small-r factor 516 DD1=-DD1*DALF/DTWO DCD(K,L)=DD2 614 DMASS(K,L)=DD1 D2LL(K,L)=2*DD3 !M1BP RADIATIVE INTEGRAL C 613 CONTINUE !END RELATIVISTIC CORRECTIONS C RETURN C END C C ******************* C INTEGER FUNCTION NCHAJK(KX,KIN,JGIN,LIN,NCJ,NTGJ,DFS) C C----------------------------------------------------------------------- C C FN.NCHAJK: C SETS-UP THE JK-COUPLING CHANNEL LIST FOR JP SYMMETRY INDEX KX C AND RETURNS THE NUMBER OF CHANNELS. C (THIS IS MAINLY FOR INFO SINCE SR.DWXBP REPLICATES IT.) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C INTEGER SA C LOGICAL BLS,BFIRST,BLASTK,BLASTJ,BLASTL,BPRNT0 C DIMENSION NTGJ(*),DFS(*) C COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBDWJ/JSYMM(MXSYJ,MAXJG),NCHGJ(MAXJG),NADGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRJ/NSLJ(MAXSL,MAXJG),NGSLJ(MAXJG) !target COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR C DATA MTJOLD/-1/,MTPOLD/-1/ C BPRNT0=JPRINT.NE.-3 C MTJ=JPI(KX)/10 MTP=JPI(KX)-MTJ*10 MTP=MTP+MTP C BFIRST=MTJOLD.NE.MTJ.OR.MTPOLD.NE.MTP C IF(BFIRST.AND.BPRNT0)WRITE(6,100) C MTJOLD=MTJ MTPOLD=MTP C INASTX=NCHGJ(KX) C NCHJ=0 C KAY2=MTJ+1 IF(MTJ.GT.0)THEN KAY1=MTJ-1 ELSE KAY1=KAY2 ENDIF C DO KAY=KAY1,KAY2,2 !LOOP OVER CHANNEL K C BLASTK=KAY.EQ.KIN C DO JIG=1,NJO !LOOP OVER TARGET JP GROUPS C BLASTJ=BLASTK.AND.JIG.EQ.JGIN C NC=NSLJ(1,JIG) JIP=QPI(NC) LV0=NTGJ(JIG)+1 JI=JN(LV0) L1=IABS(KAY-JI) IF(MOD(JIP+L1,4).NE.MTP)L1=L1+2 L2=KAY+JI IF(MOD(JIP+L2,4).NE.MTP)L2=L2-2 C NCN0=NGSLJ(JIG) C DO LI=L1,L2,4 !LOOP OVER CHANNEL L C BLASTL=BLASTJ.AND.LI.EQ.LIN C LV0=NTGJ(JIG) NCHI=0 C DO NC00=1,NCN0 !BEGIN LOOP OVER TARGET SL GROUPS C NC=NSLJ(NC00,JIG) MC=NSL(NC) SA=QSI(NC) LA=QLI(NC) MCI=NGRPI(NC) BLS=.FALSE. C DO IXX=1,INASTX !LOOP OVER LS SYMMS C IX=JSYMM(IXX,KX) NCN=NCHG(IX) C DO NC0=1,NCN !FIND TARGET SL GROUP IF(NC.EQ.ITARG(NC0,IX))THEN !MATCHED LL1=LLCH(1,NC0,IX) LL2=LLCH(2,NC0,IX) IF(LI.LT.LL1.OR.LI.GT.LL2)GO TO 715 GO TO 720 ENDIF ENDDO C 715 CONTINUE c write(6,*)'NO CONTRIB. FROM LS SYM',IXX,' IX=',IX GO TO 750 !SLP DOES NOT CONTRIBUTE C 720 IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 C IF(MTP.NE.IP+IP)STOP 'IXX ERROR' !REMOVE MTS=IS-1 MTL=IL+IL C IF(KAY.LT.IABS(MTL-SA).OR.KAY.GT.MTL+SA)GO TO 750 !LAST C C CHECK RECOUPLING COEFFICIENT (TRIANGLE SHOULD'VE CAUGHT) C IF(BFIRST)THEN C S61=SJS(MTS,MTL,MTJ,KAY,1,SA,DFS,MXDFS) c c if(abs(s61).lt.1d-70) c x write(0,*)'1:',mts,mtl,mtj,kay,1,sa c S62=SJS(LA,LI,MTL,KAY,SA,JI,DFS,MXDFS) c c if(abs(s62).lt.1d-70) c x write(0,*)'2:',la,li,mtl,kay,sa,ji c S6=S61*S62 C BLS=BLS.OR.ABS(S6).GT.1.D-70 ELSE BLS=.TRUE. GO TO 800 ENDIF C 750 ENDDO !END LOOP OVER LS SYMMS C 800 IF(BLS)THEN !THIS TARGET SL CONTRIBUTES LV=LV0 c write(6,*)jig,ji,nc,jip DO MD1=1,MC !LOOP OVER TARGET LEVELS IT=MD1+MCI LV=LV+1 if(it.ne.nrr(lv))stop 'nchajk???' !test NCHJ=NCHJ+1 IF(BFIRST.AND.BPRNT0)WRITE(6,101)NCHJ,LV,IT,LI/2,KAY IF(BLASTL.AND.MD1+NCHI.EQ.NCJ)GO TO 900 ENDDO !END LOOP OVER TARGET LEVELS ENDIF C LV0=LV0+MC NCHI=NCHI+MC C ENDDO !END LOOP OVER TARGET SL GROUPS C ENDDO !END LOOP OVER CHANNEL L C ENDDO !END LOOP OVER TARGET JP GROUPS C ENDDO !END LOOP OVER CHANNEL K C 900 NCHAJK=NCHJ C RETURN C 100 FORMAT(/9X,'CH',8X,'LV',9X,'T',5X,'SMALL L',6X,'2K') 101 FORMAT(I11,I10,I10,I12,I8) C END C C ******************* C SUBROUTINE NLAM(M0,K1,K2,K3,K4,K,DK) C C----------------------------------------------------------------------- C C SR.NLAM EVALUATES THE N-INTEGRALS OF THE SPIN-ORBIT AND SPIN-SPIN C INTERACTIONS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C DZ=NZION DD=DONE D00=DZERO C DO I=1,MAXRS DPA(I)=DPNL(I,K2)*DPNL(I,K4) ENDDO C I=(QL(K2)+QL(K4))/2+2 C IF(BREL)THEN !SMALL R CORRECTION DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DEL=DE2-DE4 ! A.U. IF(BREL2)THEN T=C4*DTWO DO I=1,MAXRS DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) C DD2=DONE+T*(DE2+POT(I,1)) C DD4=DONE+T*(DE4+POT(I,1)) D24=DD2*DD4 d24=abs(d24) DPA(I)=DPA(I)/SQRT(D24) ENDDO ELSE c t=c4*dtwo DO I=1,MAXRS DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) c dd2=done+t*(de2+dz/dx(i)) c dd4=done+t*(de4+dz/dx(i)) D24=DD2*DD4 d24=abs(d24) DPA(I)=DPA(I)/SQRT(D24) ENDDO dd=dd*rnorm(k2)*rnorm(k4) ENDIF CALL YLAMKR(K,I,DEL,DPA,DP,DD2,DD4,MNH,DHNS,MJH,M0) ELSE CALL YLAMK(K,I,DPA,DP,DD2,DD4,MNH,DHNS,MJH,M0) ENDIF C DO I=1,MAXRS DP(I)=DP(I)*DPNL(I,K1)*DPNL(I,K3) ENDDO C IF(BREL)THEN !SMALL R CORRECTION DE1=DEY(K1)-DUY(K1,K1) DE3=DEY(K3)-DUY(K3,K3) DEL=DE1-DE3 ! A.U. IF(BREL2)THEN T=C4*DTWO DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD3=DONE+T*(DE3+POT(I,1)) D13=DD1*DD3 d13=abs(d13) DP(I)=DP(I)/SQRT(D13) ENDDO ELSE c t=c4*dtwo DO I=1,MAXRS DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) c dd1=done+t*(de1+dz/dx(i)) c dd3=done+t*(de3+dz/dx(i)) D13=DD1*DD3 d13=abs(d13) DP(I)=DP(I)/SQRT(D13) ENDDO dd=dd*rnorm(k1)*rnorm(k3) ENDIF ENDIF C CALL WEDDLE(D00,DP,DKU,MNH,DHNS,MJH,MAXRS) C DK=DKU*DD*C4 C RETURN END C C ******************* C SUBROUTINE NORMS(IR,H,L,F1,F2,F12,B11,B22,B12,TM12,VMAX) C C----------------------------------------------------------------------- C C SR.NORMS EVALUATES THE INTERGALS: C B11=F1*F1, B22=F2*F2, B12=F1*F2 AND TM12=F1*F2*R**L, C USING SIMPSON'S RULE. C VMAX IS THE MAX VALUE OF THE INTEGRAND TM12. C A. BURGESS, DAMTP, CAMBRIDGE. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (C1=1.85575D0) PARAMETER (C2=1.03315D0) C DIMENSION F1(0:*),F2(0:*),F12(0:*) C R=DZERO X=DZERO S1=DZERO S2=DZERO S=DZERO TM12=DZERO C DO I=1,IR R=R+H P1=F1(I) P2=F2(I) F=P1*P2 T=ABS(F)*R IF (T .GT. X) THEN X=T RM=R ENDIF F12(I)=F T=MOD(I,2)+1 S1=T*P1*P1+S1 S2=T*P2*P2+S2 T=T*F S=T+S TM12=TM12+T*R**L ENDDO C T=DTWO*H/DTHREE B11=T*S1 B22=T*S2 B12=T*S TM12=T*TM12 X=L+DHALF T=X**(DONE/DTHREE) VMAX=(C1*T+C2/T+X)*DHALF/RM C RETURN END C C ******************* C SUBROUTINE NUMERO(XA,XB,Y,IND,N,XY) C C----------------------------------------------------------------------- C C SR.NUMERO INTEGRATES COULOMB EQUATION (CHARGE ZN, PLUS POT) C WITH REDUCED NUMEROV (G=0, D.R. HARTREE: NUMERICAL ANALYSIS P.142) C A SECOND ORDER DIFFERENTIAL EQUATION Y2=F(X)*Y+G(X) FROM C XA TO XB IN NSTEPS. THE VALUES F,Y,G FOR THE FIRST 2 POINTS C ARE TO BE GIVEN IN F(2),F(3),Y(2),Y(3),G(2),G(3). THE VALUES AT C THE N POINTS XA+I*DX I=1,N ARE WRITTEN INTO XY(I),I=1,N. C E =EBOUND/RY FOR BOUND, =(K*A0)**2 FOR FREE WAVES; LL=L*(L+1). C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTEN=10.0D0) PARAMETER (DTWELV=12.0D0) C LOGICAL BREL,BJUMPR,BMVD C DIMENSION Y(3),F(3),IND(3),XY(N) C COMMON /COM1/POT(MAXB1),DTOL,IEND COMMON /COM3/E,ZN,TLL COMMON /NRBDEN/ MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C DX=(XB-XA)/N X=XA DO I=2,3 IF(IND(1).EQ.0)THEN A=DTWO*ZN/X ELSE INDEX2=IND(I) A=DTWO*(POT(INDEX2)+VSC(INDEX2)) IF(BREL)A=A+PMVDAR(INDEX2,X) ENDIF F(I)=TLL/X**2-A-E X=X+DX ENDDO C D12=DX*DX/DTWELV D56=DTEN*D12 XY(1)=Y(3) C DO I=2,N F(1)=F(2) F(2)=F(3) Y(1)=Y(2) Y(2)=Y(3) IF(IND(1).EQ.0)THEN A=DTWO*ZN/X ELSE INDEX2=IND(1)+INDEX2 A=DTWO*(POT(INDEX2)+VSC(INDEX2)) IF(BREL)A=A+PMVDAR(INDEX2,X) C IND(2)=IND(3) C IND(3)=INDEX2 ENDIF F(3)=TLL/X**2-A-E A=DONE-D12*F(3) B=(DTWO+D56*F(2))*Y(2) C=(DONE-D12*F(1))*Y(1) Y(3)=(B-C)/A XY(I)=Y(3) X=X+DX ENDDO C RETURN END C C ******************* C SUBROUTINE NUMSYM(JTOT,JPAR,JCUNT0) C C----------------------------------------------------------------------- C C SR.NUMSYM C DETERMINES THE LSP SYMMETRIES WHICH CONTRIBUTE TO THE INPUT J,P. C IF JCOUNT C =0 IT RETURNS THE NUMBER OF LSP C >0 IT SEARCHES THE INAST LSPI SYMMETRIES IN /NRBLS/ AND FLAGS C ANY THAT ARE NOT PRESENT IN THE INAST. C <0 IT EXTENDS THE INAST LSPI SYMMETRY LIST FOR ANY NOT PRESENT. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BTEST1,BTEST2 C COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBLS/LSPI(MAXSL),INAST,MGAP(5) C SAVE QSMIN,QSMAX DATA IFIRST/0/ C C MAX TARGET LS IS IN QMCL,QMCS C IF(IFIRST.EQ.0)THEN !DETERMINE MIN,MAX TOT S QSMIN=999 DO I=1,NSL0 IF(QSI(I).LT.QSMIN)QSMIN=QSI(I) ENDDO QSMIN=ABS(QSMIN-1) QSMAX=QMCS+1 IFIRST=1 ENDIF C JCOUNT=JCUNT0 BTEST1=JCUNT0.NE.0 IF(BTEST1)JCOUNT=0 BTEST2=JCUNT0.LT.0 C DO MTS=QSMIN,QSMAX,2 QLMIN=ABS(JTOT-MTS) QLMAX=JTOT+MTS DO MTL=QLMIN,QLMAX,2 !RANGE OF LTOT FOR JTOT IL=MTL/2 DO N=1,NSL0 IF(ABS(QSI(N)-MTS).gt.1)GO TO 60 if(il.gt.maxlx.and.qsi(n).gt.mts)go to 60 !nx LMIN=ABS(QLI(N)-MTL) LMAX=QLI(N)+MTL DO L=LMIN,LMAX,2 LP=(L+QPI(N))/2 IF(MOD(LP,2).EQ.JPAR)THEN !WE HAVE A WINNER JCOUNT=JCOUNT+1 IF(BTEST1)THEN !SEE IF PRESENT LSPIT=10000*(MTS+1)+IL*10+JPAR DO K=1,INAST IF(LSPIT.EQ.LSPI(K))GO TO 100 ENDDO IF(BTEST2)THEN INAST=INAST+1 LSPI(INAST)=LSPIT ELSE WRITE(6,*)'*** MISSING SYM (2S+1) L P=' X ,MTS+1,IL,JPAR,' FOR 2J P =',JTOT,JPAR WRITE(0,*)'*** MISSING SYM (2S+1) L P=' X ,MTS+1,IL,JPAR,' FOR 2J P =',JTOT,JPAR ENDIF ENDIF GO TO 100 ENDIF ENDDO 60 ENDDO 100 ENDDO ENDDO C IF(.NOT.BTEST2)JCUNT0=JCOUNT C RETURN END C C ******************* C REAL*8 FUNCTION PHASEX(E,C,Q,U,L,Z,X) C C----------------------------------------------------------------------- C C N.R.BADNELL D.A.M.T.P. CAMBRIDGE C C FN.PHASEX CALCULATES THE PHASE ASSOCIATED WITH A MODIFIED COULOMB C POTENTIAL -2Z/X -C/X**2 -Q/X**3 -U/X**4 (Z<0) C L .GE. 0, L DENOTES NON-RELATIVISTIC ANG. MOM. C L .LT. 0, A.M.=-(L+1) I.E. L=KAPPA (J=A.M.+DHALF) C RELATIVISTIC COULOMB PHASE, ASSUMES E,C,Z C CONTAIN THE MODIFIED COULOMB POTENTIAL. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (DSIX=6.0D0) PARAMETER (DNINE=9.0D0) PARAMETER (DELEVN=11.0D0) PARAMETER (DFIFTN=15.0D0) PARAMETER (D24=24.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (DQUART=0.25D0) PARAMETER (D8TH=0.125D0) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M15=1.0D-15) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C PI=ACOS(-DONE) EL=L ZZ=Z*Z CK=SQRT(E) XK=X*CK XZ=X*Z C1=XK*XK-XZ-XZ-C IF(C1.LT.D1M10)THEN WRITE(6,100)E,C,Q,U,L,Z,X C PHASEX=DQUART*PI RETURN ENDIF C CHI=SQRT(C1) IF(CHI.LT.DFIVE)WRITE(6,101)E,C,Q,U,L,Z,X,CHI C PHI=DZERO C1=DONE/CHI P=CHI-D8TH*C1 C IF(ABS(Z)+ABS(C).GT.D1M15)THEN B=E*C+ZZ A=ZZ*(CHI-XK)-CK*C*Z P=P-(A/(D24*B*(CHI+XK))+DFIVE*(XZ+C)*C1*C1/D24)*C1 ENDIF C IF(E.LT.D1M10)THEN P=P+CHI ELSE A=Z/CK P=P+A*(DONE-LOG(CHI+XK-A)) ENDIF C IF(L.LT.0)THEN !RELATIVISTIC T=SQRT(DONE+DALF*E) T=DTWO*(T-DONE)/DALF Z0=Z/(DONE+DHALF*DALF*T) G=-EL+DHALF*DALF*Z0*Z0/EL ETA=DZERO IF(E.GT.D1M10)ETA=ATAN(Z0/(CK*EL))+ATAN(Z/(CK*G)) ETA=ETA*DHALF EL=G-DONE P=P+ETA ENDIF C IF(E.LT.D1M10)THEN P=P-(EL+DQUART)*PI ELSE P=P-DHALF*EL*PI+ARGAM(EL,A) ENDIF C IF(L.EQ.-1111)THEN !TEST RELATIVISTIC S-ORBITAL C1=SQRT(-C) T=DFSC*Z0 IF(ABS(C1+T).GT.DALF)THEN WRITE(6,102)C,Z0 WRITE(0,102)C,Z0 PHASEX=DZERO RETURN ENDIF T0=CHI+XK T1=DONE+T0*DALF/(DTWO*X) T2=DONE+DALF*CK Y=DTWO*T1/(T2*T0) ELSEIF(C.LT.-D1M10)THEN C1=SQRT(-C) T1=C1*CHI-C-XZ T2=C1*XK-XZ Y=LOG(T1/T2)/C1 ELSE C IF(C.LT.D1M10)THEN T0=CHI+XK IF(ABS(Q).GT.D1M15)PHI=Q*(T0+XK)/(DTHREE*X*T0**2) IF(ABS(U).GT.D1M15)PHI=PHI+U*(DNINE*XK*CHI+DELEVN*XK*XK X -DSIX*XZ)/(DFIFTN*X*X*T0**3) C PHASEX=P+DONE/(DFOUR*(CHI+XK))+PHI RETURN C ENDIF C T=CK*C*CHI+ZZ*X+C*Z T1=(ZZ+E*C)*X Y=ACOS(T/T1)/SQRT(C) C ENDIF C IF(ABS(Q).GT.D1M15)PHI=Q*((XZ+XZ+C)/(X*(CHI+XK))-Z*Y)/C IF(ABS(U).GT.D1M15)THEN T1=DTHREE*Z*(XZ+XZ+C)/(X*(CHI+XK))+C*CHI/(X*X) PHI=PHI+U*(Y*(DTHREE*ZZ+E*C)-T1)/(DTWO*C*C) ENDIF C PHASEX=P+(C+D8TH)*Y+PHI/DTWO RETURN C 100 FORMAT('*** FAILED IN PHASEX: E=',1PE10.2,' C=',1PE10.2,' Q=', X1PE10.2,' U=',1PE10.2,' L=',I3,' Z=',1PE10.2,' X=',1PE10.2) 101 FORMAT('*** INACCURACY IN PHASEX FOR E=',1PE10.2,' C=',1PE10.2, X' Q=',1PE10.2,' U=',1PE10.2,' L=',I3,' Z=',1PE10.2,' X=',1PE10.2, X'CHI=',1PE10.2) 102 FORMAT('*** FAILED IN PHASEX FOR RELATIVISTIC S-ORBITAL:' , X' C=',1PE10.2,' Z=',1PE10.2) C END C C ******************* C REAL*8 FUNCTION PMVDAR(J,X) C C----------------------------------------------------------------------- C C FN.PMVDAR EVALUATES THE MASS-VELOCITY AND DARWIN POTENTIALS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C LOGICAL BREL,BJUMPR,BMVD C COMMON /COM1/POT(MAXB1),ZDUM,IEND COMMON /COM3/E,DZ,ELLP !,EQ,ZQ,CQ COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/DPT0(MAXB1),DERV1(MAXB1),DERV2(MAXB1),DPT3(MAXB1) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D3QRT=DTHREE/DFOUR) PARAMETER (DQUART=DONE/DFOUR) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C c IF(J.GT.IEND.and.e.ge.dzero)THEN c T=DONE/X c PMVDAR=EQ-(ZQ+CQ*T)*T c RETURN c ENDIF C TKAP=-DONE !(2J+1)-WEIGHTED KAPPA-AVERAGE IF(KAPPA.NE.0)TKAP=KAPPA c c if(e.lt.dzero)then c l=sqrt(ellp) c if(l.gt.0)tkap=-l-1 !or l !see also radwav c endif C C MASS-VELOCITY C IF(E.LT.DZERO)T=E+DTWO*POT(J) IF(E.GE.DZERO)T=E+POT(J)+DTWO*DZ/X C C DARWIN C c w=done !standard Darwin c if(l.gt.0)w=-2. !see also radwav c TT=DONE+DQUART*DALF*T TT=DONE/TT A=TT*(DERV1(J)*(-DTWO*TKAP/X-D3QRT*DALF*TT*DERV1(J))+DERV2(J)) c c a=tt*(derv1(j)*(-dtwo*tkap/x-(w+dtwo)*alf*tt*derv1(j)) c x +derv2(j))*w C PMVDAR=DQUART*DALF*(T*T+A) C RETURN END C C ******************* C SUBROUTINE PNL(IR,H,L,X,P,JMAX,F) C C----------------------------------------------------------------------- C C SR.PNL INTERPOLATES THE INPUT RADIAL FUNCTION P(X) TO OUTPUT F(Y) C FOR SUBSEQUENT USE BY SR.ROMB AND SR.FILON. C A. BURGESS DAMTP CAMBRIDGE. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) C DIMENSION X(*),P(*),F(0:*) C FLAGR(X1,X2,X3,X4,Z1,Z2,Z3,Z4,Z) = C ((Z-X2)*(Z-X3)*(Z-X4)/((X1-X2)*(X1-X3)*(X1-X4)))*Z1 C + ((Z-X1)*(Z-X3)*(Z-X4)/((X2-X1)*(X2-X3)*(X2-X4)))*Z2 C + ((Z-X1)*(Z-X2)*(Z-X4)/((X3-X1)*(X3-X2)*(X3-X4)))*Z3 C + ((Z-X1)*(Z-X2)*(Z-X3)/((X4-X1)*(X4-X2)*(X4-X3)))*Z4 C R=DZERO F(0)=DZERO M=L+1 J=1 !0 DO I=1,IR R=R+H 1 IF(R.GT.X(J).AND.J.LT.JMAX)THEN J=J+1 GO TO 1 ENDIF IF(J.LT.3)THEN Y1=P(1)/X(1)**M Y2=P(2)/X(2)**M Y3=P(3)/X(3)**M T=FLAGR(DZERO,X(1),X(2),X(3),DZERO,Y1,Y2,Y3,R)*R**M ELSE IF(J.LT.JMAX)THEN T=FLAGR(X(J-2),X(J-1),X(J),X(J+1),P(J-2) X ,P(J-1),P(J),P(J+1),R) ELSE T=P(J)*EXP((X(J)-R)*LOG(P(J-1)/P(J))/(X(J)-X(J-1))) ENDIF ENDIF F(I)=T ENDDO C RETURN END c c ******************* c subroutine pomrecv(nomt,omv,nr,omx) c c----------------------------------------------------------------------- c c sr.pomrecev transfers a slice of a vector (omv) to omega matrix (omx) c where the slice may include part of a column. c c----------------------------------------------------------------------- c implicit real*4 (a-h,o-z) c dimension omx(*),omv(*) c do n=1,nomt nr=nr+1 omx(nr)=omv(n) enddo c return end c c ******************* c subroutine pomsend(ns,omx,nomt,omv) c c----------------------------------------------------------------------- c c sr.pomsend transfers a slice of omega matrix (omx) to a vector (omv) c where the slice may include part of a column. c c----------------------------------------------------------------------- c implicit real*4 (a-h,o-z) c dimension omx(*),omv(*) c do n=1,nomt ns=ns+1 omv(n)=omx(ns) enddo c return end C C ******************* C SUBROUTINE POTIN(Z,MION,MK,MPOT,X,POT,MEND,CAV,PAV,KHLP,MHLP) C C----------------------------------------------------------------------- C C SR.VPNL READS EXTERNAL POTENTIAL AND INTERPOLATES ONTO INTERNAL GRID. C ATTEMPTS TO ADJUST NORMALIZATION BY EXAMINING LARGE R. C (CANNOT CHECK R=0 SINCE MAY BE FINITE NUCLEUS.) C SINCE NO STANDARD FORMAT EXISTS, ADJUST IT AS NEEDED. C CURRENT DEFAULT IS POTIN='FAC', SET IN NAMELIST SMINIM. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD14=100) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (D1M1=1.0D-1) PARAMETER (D1M2=1.0D-2) C DIMENSION PAV(*),CAV(*),POT(*),X(*),KHLP(*) C COMMON /BASIC/NF,MGAP(11) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBUNI/IUNIT(MXD14),NUNIT C DATA MHFR/9/ C IF(IUNIT(MHFR).EQ.0)THEN WRITE(6,*)"MISSING INPUT FILE='hffcin/potin'..." WRITE(0,*)'MISSING FILE ON UNIT=9' GO TO 999 ENDIF C REWIND(MHFR) C MHLP=1 !POTENTIAL "FOUND" C TOLH=D1M2 C C DETERMINE INITIAL ASYMPTOTIC CHARGE C c N=MION ZN=1-MION ZN=Z+ZN ZN1=ZN IF(NINT(ZN1).EQ.0)ZN1=DONE C IF(MHF.EQ.1)THEN C C USE ORIGINAL AS GRID (STILL SO FOR TF) C READ(MHFR,*)MPIN IF(MPIN.GT.MPOT)MPIN=MPOT DO J=1,MPIN READ(MHFR,*)POT(J) T=POT(J)*X(J)-ZN IF(ABS(T/ZN1).GT.TOLH)MEND=J ENDDO L=MPIN+1 GO TO 6 C ELSEIF(MHF.EQ.2)THEN C C FAC (UNIQUE) C DO J=1,MAXB1 READ(MHFR,*,END=80)ICARD,XXX,DUMZ,PPP !FAC FORMAT CAV(J)=XXX PAV(J)=PPP PAV(J)=PAV(J)*CAV(J) !COMMENT OUT IF R*V(R) INPUT ENDDO C 80 MPIN=J-1 C ELSEIF(MHF.EQ.3)THEN C C NL-DEPENDENT C 77 READ(MHFR,*,END=998)MPIN,MYN,MYL C IF(MYN.NE.QN(MK).OR.MYL*2.NE.QL(MK))THEN C DO I=1,MPIN READ(MHFR,*) ENDDO C GO TO 77 C ELSE C MHLP=-1 !SINCE WE WANT TO RETURN C DO I=1,MPIN READ(MHFR,*)CAV(I),PAV(I) PAV(I)=PAV(I)*CAV(I) !COMMENT OUT IF R*V(R) INPUT ENDDO C ENDIF ENDIF C C CHECK NORM C PNORM=PAV(MPIN)/ZN INORM=NINT(PNORM) IF(ABS(PNORM-DBLE(INORM)).GT.D1M1.or.inorm.eq.0)THEN WRITE(6,1004)PAV(MPIN) WRITE(0,1004)PAV(MPIN) GO TO 999 ENDIF C C HELP INTERPOLATE C II=1 DO K=1,MPOT KHLP(K)=0 GO TO 82 81 II=II+1 82 IF(II.GT.MPIN)GO TO 85 IF(II.EQ.MPIN)GO TO 84 IF(CAV(II+1)+CAV(II).LT.X(K)*DTWO)GO TO 81 84 IF(X(K).GT.CAV(MPIN))GO TO 81 KHLP(K)=II 85 ENDDO C C LAGRANGE INTERPOLATION (NLAG+1 POINTS) FROM ARGUMENTS CAV TO X C NLAG=4 C DO L=1,MPOT IF(X(L).GT.CAV(MPIN))GO TO 6 DD1=DZERO M=KHLP(L)-NLAG/2 I1=MAX0(M,1) I2=I1+NLAG IF(I2.GT.MPIN)I2=MPIN DO I=I1,I2 DD=DONE DM=DONE DO J=I1,I2 IF(J.NE.I)THEN DM=(X(L)-CAV(J))*DM DD=(CAV(I)-CAV(J))*DD ENDIF ENDDO DD1=PAV(I)*DM/DD+DD1 ENDDO DD1=DD1*PNORM c j=khlp(l) c write(6,1005)l,x(l),j,i1,i2,cav(j),dd1 c 1005 format(5x,i4,e14.7,14x,3i4,2e14.7) POT(L)=DD1/X(L) T=DD1-ZN IF(ABS(T/ZN1).GT.TOLH)MEND=L ENDDO C C FILL THE REMAINING POTENTIAL AS A COULOMB POTENTIAL C 6 DO J=L,MPOT POT(J)=ZN/X(J) ENDDO C C BACK-UP C IF(MHLP.GT.0)THEN DO J=1,MPOT PAV(J)=POT(J) ENDDO ENDIF C 300 RETURN C 998 MHLP=0 !NOT FOUND GO TO 300 C 999 NF=-1 GO TO 300 C CORIG 990 FORMAT(E14.7) CORIG 991 FORMAT(I5) 1004 FORMAT(' *** SR.STOPOT: UNABLE TO DETERMINE NORM OF EXTERNAL' X ,' POTENTIAL, R*V=',F8.2) C END c c ******************* c subroutine psymj(iam,nproc) c c----------------------------------------------------------------------- c c *** parallel *** may only be called by the parallel version. c c sr.psymj distributes jp symmetries over the nproc processors c by defining local inastj, jpi values, based on the global c values. attempts to load balance 2-body fine-structure with rest, c in the case of inast.le.0. up to user in case of inast.gt.0. c all lspi values that are needed for the jpi on each processor c are calculated independently by said processor. there is no c read of a common calculated set from disk (currently). c c only called in lsj-coupling. c - see psymls for ls-coupling. c c----------------------------------------------------------------------- c implicit real*8 (a-h,o-p,r-z) implicit integer (q) c INCLUDE './PARAM' c COMMON /BASIC/NF,MGAP(11) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT c c inastj=inastj0 here c if(inastj0.gt.0)then c c just extract an iam subset of pre-defined global jpi c jmin=1 jrange=inastj0 !global if(nproc.gt.jrange)then write(6,*)'too many processors for specified inastj,' x ,' use nproc=',jrange if(iam.eq.0)write(0,*) x 'too many processors for specified inastj' nf=-1 go to 999 endif jperproc=jrange/nproc jxtra=jrange-jperproc*nproc c jmin=jmin+iam*jperproc+min(jxtra,iam) jmax=jmin+jperproc-1 if(iam.lt.jxtra)jmax=jmax+1 write(0,*)iam,jmin,jmax c c shift down global jpi symms to form local c i=0 do j=jmin,jmax i=i+1 jpi(i)=jpi(j) enddo inastj=i !local c else c c set-up a global set of jpi and then extract an iam subset c (not the most elegant way of doing it, perhaps, but makes c it easier to play around with the local distribution c because the complete global distribution is present to c select from. of course, at the end of the day, each jpi c must be selected once.) c c defaults (lsp & jp) c if(inast0.le.0)then c if(maxlt.eq.1000)maxlt=30 c if(maxlt.gt.100)maxlt=100 if(minlt.lt.0)minlt=0 if(minsp.lt.1)minsp=1 i1=mod(qmcs,2) i0=mod(minsp-1,2) if(i0.eq.i1)minsp=minsp+1 maxsp=min(maxsp,qmcs+2) endif c ipar=iabs(ipar) ipar=mod(ipar,3) ip0=mod(ipar,2) ip1=min(ipar,1) ipart=max(1,ipar) c if(maxjt.gt.200)maxjt=60 if(minjt.lt.0)minjt=0 mtest=mod(qmcs,2) if(mod(minjt,2).eq.mtest)minjt=minjt+1 if(mod(maxjt,2).eq.mtest)maxjt=maxjt-1 if(mod(maxjfs,2).eq.mtest)maxjfs=maxjfs-1 c if(lrglam.gt.maxjt)then lrglam=-1 !so no top-up else if(lrglam.eq.-999)lrglam=maxjt endif c jfs=min(maxjfs,maxjt) jj=max(minjt,maxjfs+2) c c global no. symms, c check dimension & if too many processors assigned. c jrngfs=max(ipart*(jfs-minjt+2)/2,0) jrng=max(ipart*(maxjt-jj+2)/2,0) jrange=jrngfs+jrng c if(jrange.gt.maxjg)then write(6,194)jrange write(0,194)jrange go to 999 endif c if(nproc.gt.jrange)then write(6,*)'too many processors for jp symmetries,' x ,' use nproc=',jrange if(iam.eq.0)write(0,*)'too many processors for jp symmetries' nf=-1 go to 999 endif c c assign global fine-structure jpi c (want same parity and adjacent j on same processor so as to minimize c the ls recomputation.) c i=0 do ip=ip0,ip1 do ij=minjt,jfs,2 i=i+1 jpi(i)=10*ij+ip enddo enddo c if(jrngfs.ne.i)then if(iam.eq.0)write(0,*)'fine-structure j:',jrngfs,i nf=-1 go to 999 endif inastj0=i !global c c shift down global jpi symms to form local c jrange=jrngfs jperproc=jrange/nproc jxtra=jrange-jperproc*nproc c jmin=1 jmin=jmin+iam*jperproc+min(jxtra,iam) jmax=jmin+jperproc-1 if(iam.lt.jxtra)jmax=jmax+1 c write(6,*)iam,jmin,jmax c i=0 do j=jmin,jmax i=i+1 jpi(i)=jpi(j) enddo inastj=i !local c c assign global ordinary jpi c i=inastj0 do ip=ip0,ip1 do ij=jj,maxjt,2 i=i+1 jpi(i)=10*ij+ip enddo enddo c if(jrng.ne.i-inastj0)then if(iam.eq.0)write(0,*)'ordinary j:',jrng,i-inastj0 nf=-1 go to 999 endif inastj0=i !global c c shift down global jpi symms to form local c jrange=jrng jperproc=jrange/nproc jxtra=jrange-jperproc*nproc c jmin=jrngfs+1 jmin=jmin+iam*jperproc+min(jxtra,iam) jmax=jmin+jperproc-1 if(iam.lt.jxtra)jmax=jmax+1 c write(6,*)iam,jmin,jmax c i=inastj do j=jmin,jmax i=i+1 jpi(i)=jpi(j) enddo inastj=i !local c endif c inastj0=inastj !re-sync. c c now, given the jp set on each processor, we need to assign all of the c necessary local lsp. since currently there is no passing file, and we c don't want to message pass the ls algebra (!), this means lsp symmetry c algebra is being multiplicated. however, since the jk-coupling problem c is an order of magnitude more demanding than the ls-coupling one, this c may not be critical. eventually, will code a restartx file(s), along c the lines of the target algebra restart file. then, each processor can c read the appropriate lsp symmetry data it needs for its jp. c jcount=-1 inast=0 do i=1,inastj ij=jpi(i)/10 ipj=jpi(i)-ij*10 call numsym(ij,ipj,jcount) enddo inast0=inast !re-sync. c 999 return c 194 format('***sr.psymj: too many symmetries, increase maxjg', x ' to:',i4) c end c c ******************* c subroutine psymls(iam,nproc) c c----------------------------------------------------------------------- c c *** parallel *** may only be called by the parallel version. c c sr.psymls distributes lsp symmetries over the nproc processors c by defining local inast, lspi values, based on the global c values. attempts to load balance exchange and non-exchange, c in the case of inast.le.0. up to user in case of inast.gt.0. c there is no allowance for scaling from one-l to the other c since at best there is likely to be a few l per-processor. c c only called in ls-coupling. c - see psymj for lsj-coupling. c c----------------------------------------------------------------------- c implicit real*8 (a-h,o-p,r-z) implicit integer (q) c INCLUDE './PARAM' c COMMON /BASIC/NF,MGAP(11) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO c c inast=inast0 here c if(inast0.gt.0)then c c just extract an iam subset of pre-defined global lspi c lmin=1 lrange=inast0 !global if(nproc.gt.lrange)then write(6,*)'too many processors for specified inast,' x ,' use nproc=',lrange if(iam.eq.0)write(0,*) x 'too many processors for specified inast' nf=-1 go to 999 endif lperproc=lrange/nproc lxtra=lrange-lperproc*nproc c lmin=lmin+iam*lperproc+min(lxtra,iam) lmax=lmin+lperproc-1 if(iam.lt.lxtra)lmax=lmax+1 write(0,*)iam,lmin,lmax c c shift down global lspi symms to form local c i=0 do l=lmin,lmax i=i+1 lspi(i)=lspi(l) enddo inast=i !local c else c c set-up a global set of lspi and then extract an iam subset c (not the most elegant way of doing it, perhaps, but makes c it easier to play around with the local distribution c because the complete global distribution is present to c select from. of course, at the end of the day, each lspi c must be selected once.) c c defaults c if(mxlamx.eq.1000)then !max exchange multipole if(maxlx.ge.100)then mxlamx=nxll+3 !twice max orb l+3 (was +1) else c mxlamx=(maxlx+1)/2 mxlamx=maxlx-nxll/2 endif endif c if(maxlx.ge.100)maxlx=2*mxlamx !max l for exchange if(maxlx.ge.100)maxlx=mxlamx+nxll/2 !max l for exchange maxlx=max(maxlx,qmcl/2-1) !need all channels to scale direct c if(maxloo.ge.100)maxloo=maxlx c if(maxlt.eq.1000)maxlt=30 if(maxlt.gt.100)maxlt=100 c if(lrglam.gt.maxlt)then lrglam=-1 !so no top-up else if(lrglam.eq.-999)lrglam=maxlt endif c if(minlt.lt.0)minlt=0 c if(minsp.lt.1)minsp=1 i1=mod(qmcs,2) i0=mod(minsp-1,2) if(i0.eq.i1)minsp=minsp+1 maxsp=min(maxsp,qmcs+2) c ipar=iabs(ipar) ipar=mod(ipar,3) ip0=mod(ipar,2) ip1=min(ipar,1) ipart=max(1,ipar) c qsrngx=(maxsp-minsp+2)/2 lx=min(maxlx,maxlt) if(minsp.eq.1)then is1=3 is2=max(3,maxsp) else is1=minsp is2=maxsp endif qsrngnx=(is2-is1+2)/2 lnx=max(minlt,maxlx+1) c c global no. symms, c check dimension & if too many processors assigned. c lrngx=max(ipart*(lx-minlt+1)*qsrngx,0) lrngnx=max(ipart*(maxlt-lnx+1)*qsrngnx,0) lrange=lrngx+lrngnx c if(lrange.gt.maxsl)then write(6,194)lrange write(0,194)lrange go to 999 endif c if(nproc.gt.lrange)then write(6,*)'too many processors for lsp symmetries,' x ,' use nproc=',lrange if(iam.eq.0)write(0,*)'too many processors for lsp symmetries' nf=-1 go to 999 endif c c attempt to balance low- and high-l, case more l's than proc's. c ngrpl=nproc ! =nproc, or =1 for sequential l c c assign global exchange lsp c i=0 do n=0,ngrpl-1 il0=minlt+n do il=il0,lx,ngrpl do is=minsp,maxsp,2 do ip=ip0,ip1 i=i+1 lspi(i)=10000*is+10*il+ip enddo enddo enddo enddo c if(lrngx.ne.i)then if(iam.eq.0)write(0,*)'exchange:',lrngx,i nf=-1 go to 999 endif inast0=i !global c c shift down global lspi symms to form local c lrange=lrngx lperproc=lrange/nproc lxtra=lrange-lperproc*nproc c lmin=1 lmin=lmin+iam*lperproc+min(lxtra,iam) lmax=lmin+lperproc-1 if(iam.lt.lxtra)lmax=lmax+1 c write(6,*)iam,lmin,lmax c i=0 do l=lmin,lmax i=i+1 lspi(i)=lspi(l) enddo inast=i !local c c assign global non-exchange lsp c i=inast0 do il=lnx,maxlt do is=is1,is2,2 do ip=ip0,ip1 i=i+1 lspi(i)=10000*is+10*il+ip enddo enddo enddo c if(lrngnx.ne.i-inast0)then if(iam.eq.0)write(0,*)'non-exchange:',lrngnx,i-inast0 nf=-1 go to 999 endif inast0=i !global c c shift down global lspi symms to form local c lrange=lrngnx lperproc=lrange/nproc lxtra=lrange-lperproc*nproc c lmin=lrngx+1 lmin=lmin+iam*lperproc+min(lxtra,iam) lmax=lmin+lperproc-1 if(iam.lt.lxtra)lmax=lmax+1 c write(6,*)iam,lmin,lmax c i=inast do l=lmin,lmax i=i+1 lspi(i)=lspi(l) enddo inast=i !local c endif c inast0=inast !re-sync. c 999 return c 194 format('***sr.psymls: too many symmetries, increase maxsl', x ' to:',i4) c end C C ******************* C SUBROUTINE QEDINT(MAXPS) 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 Very loosely adapted from PHN's GRASP0 routine by NRB. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BREL,BJUMPR,BMVD,BREL2,BJUMP,BJUMP2,BRAD C C Parameter variables C PARAMETER (ZERO=0.D0) PARAMETER (XCL = 137.03599976D0) PARAMETER (XPI = 3.141592653589793D0) PARAMETER (DKEY=999.D0) C C Common variables C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TOL,MEND COMMON /COM6/DA(MAXB1) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXQS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C c write(6,3000) C BREL2=IABS(IREL).EQ.2 C Calculate the vacuum polarisation potential at each of the grid C points C Z=NZION C CALL VACPOL(Z,DX,MAXPS,DPOT) C C Obtain contribution from each orbital C DO K = 1,MAXGR C IF(DEY(K).EQ.ZERO)GO TO 100 IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 100 IF(SCREEN(K).GE.DKEY)GO TO 100 !NOT YET COMPUTED C C Obtain v.p. contribution for orbital K C DO I = 1,MAXPS DA(I)=DPNL(I,K)*DPNL(I,K)*DPOT(I) ENDDO C IF(BREL2)THEN DO I = 1,MAXPS DA(I)=DA(I)+DQNL(I,K)*DQNL(I,K)*DPOT(I) ENDDO ENDIF C CALL WEDDLE(ZERO,DA,ALLINT,MNE,DHNS,MJH,MAXPS) C VPINT(K) = ALLINT C C Obtain s.e. contribution for orbital I C IF (QL(K).GT.2) THEN C C No estimate for other than s, p- or p states C VALU = ZERO C ELSE C IF(BREL)THEN C C ...find average R for Dirac orbital... C DO I = 1,MAXPS DA(I)=DPNL(I,K)*DPNL(I,K)*DX(I) ENDDO C IF(BREL2)THEN DO I = 1,MAXPS DA(I)=DA(I)+DQNL(I,K)*DQNL(I,K)*DX(I) ENDDO ENDIF C CALL WEDDLE(ZERO,DA,RAV,MNE,DHNS,MJH,MAXPS) C C ...find effective Z of Coulomb orbital with same average R... C CALL ZEFR(K,RAV,ZEFF) C IF(ZEFF.LE.ZERO)ZEFF=Z C ELSE C ZEFF=Z-SCREEN(K) C ENDIF C C ...interpolate among P. Mohr data... C CALL FZALF(ZEFF,K,VALU) C C ...scale as required... C VALU = (ZEFF**4/XCL**3)*VALU/(XPI*DBLE(QN(K)**3)) C ENDIF C SLFINT(K) = VALU C C Print contributions if requested C c write (6,3010) k,qn(k),ql(k)/2,vpint(k),slfint(k) c x ,vpint(k)+slfint(k) c x ,zeff,rav C 100 ENDDO C RETURN C c 3000 FORMAT (/25X,' Q.E.D. CONTRIBUTIONS /2RY'/8X,' GAM N L', c +1X,' VACUUM POLARIZ.',5X,'SELF ENERGY',8X,'TOTAL') c 3010 FORMAT (8X,3I5,3(2X,D15.8),2f10.5) C END C C ******************* C INTEGER FUNCTION QPTLS(IX,NC00,ND00,LI0,LF0) C C----------------------------------------------------------------------- C C FN.QPTLS INITIALIZES THE POINTER FOR DETERMINING THE 2-BODY C NFS INTERACTIONS (ALGEBRA) FOR: C INPUT: C IX IS THE LSP SYMMETRY INDEX C NC0 IS THE INITIAL TARGET LSP INDEX C ND0 IS THE FINAL TARGET LSP INDEX C LI IS THE INITIAL CONTINUUM ORBITAL ANG. MOM. C LF IS THE FINAL CONTINUUM ORBITAL ANG. MOM. C bcorr flags if correlation may be present (then corr-corr was c omitted from algebra - default, anyway - see algxls to sync.) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL eqgrp,eqgrpl,eqgrpl0,bcorr,becor,bcor C COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) common /nrbone/ione,ione0 C C----------------------------------------------------------------------- C c if elastic is dropped here then it has an effect on inelastic c transitions between terms of same symmetry because they are mixed c cold ione0=0 !=0 retain elastic here c c if bcor then we have algebraic correlation, and we know how ordered c bcor=kdm*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD(NCOR) c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- C IF(NC00.GT.ND00)THEN IREV=1 NC0=NC00 ND0=ND00 LI=LI0 LF=LF0 ELSEIF(NC00.LT.ND00)THEN IREV=-1 NC0=ND00 ND0=NC00 LI=LF0 LF=LI0 ELSE NC0=NC00 ND0=ND00 IF(LI0.GE.LF0)THEN IREV=1 LI=LI0 LF=LF0 ELSE IREV=-1 LI=LF0 LF=LI0 ENDIF ENDIF C NNN=0 C NCN=NC0 ncorr=0 C DO N=1,NC0 NC=ITARG(N,IX) MC=NSL(NC) L1=LLCH(1,N,IX) L2=LLCH(2,N,IX) LD=((L2-L1)/4+1) NCH=MC*LD if(bcorr)mci=ngrpi(nc) C NCNP=N IF(N.EQ.NC0)NCNP=ND0 C DO NP=1,NCNP ND=ITARG(NP,IX) eqgrp=nc.eq.nd eqgrpl=eqgrpl0.and.eqgrp IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN IF(eqgrp)THEN L1P=L1 LDP=(LD*(LD+1))/2 LD=1 NCH=MC ELSE L1P=LLCH(1,NP,IX) L2P=LLCH(2,NP,IX) LDP=((L2P-L1P)/4+1) ENDIF MCP=NSL(ND) NCHP=MCP*LDP NNN=NNN+NCH*NCHP C if(bcorr)then nco=0 nce=0 c do lli=l1,l2,4 c lf2=l2p c if(nc.eq.nd)lf2=lli c do llf=l1p,lf2,4 mcip=ngrpi(nd) do m=1,mc j1=m+mci j=jndex(j1) do mp=1,mcp j1p=mp+mcip c if(j1p.gt.j1-ione0.and.lli.eq.llf)go to 61 jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then nco=nco+1 !corr.-corr. if(j1.eq.j1p)nce=nce+1 endif enddo c 61 continue enddo ncorr=ncorr+nco*ld*ldp endif ENDIF ENDDO C IF(eqgrpl.and.NMETAG(NC).LT.1)THEN LDD=(L2-L1)/4+1 MM=MC+ione0 NNN=NNN-LDD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr=ncorr-ldd*(nco-nce)/2 !for li.eq.lf c write(0,*)-nadg(ix)-nnn,-ldd*(mm*(mm-1))/2,ldd,mc ENDIF C ENDDO C !ADJUST LAST BLOCK IF(eqgrpl.and.NMETAG(NC).LT.1)THEN NNN=NNN+LDD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr=ncorr+ldd*(nco-nce)/2 !for li.eq.lf ENDIF C IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN NNN=NNN-NCH*NCHP if(bcorr)ncorr=ncorr-nco*ld*ldp C c write(0,*)'nadg',nadg(ix) IF(eqgrp)THEN LD=(LI-L1)/4 LDP=(LD*(LD+1))/2 NNN=NNN+MC*MC*LDP if(bcorr)ncorr=ncorr+nco*ldp c write(0,*)nadg(ix)+nnn,ldp,mc if(eqgrpl)then MM=MC+ione0 NNN=NNN-LD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr=ncorr-ld*(nco-nce)/2 !for li.eq.lf c write(0,*)nadg(ix)+nnn,-ld,mm endif LDP=(LF-L1P)/4 NCHP=MCP*LDP NNN=NNN+MC*NCHP if(bcorr)ncorr=ncorr+nco*ldp c write(0,*)nadg(ix)+nnn,ldp ELSE LD=(LI-L1)/4 NCH=MC*LD NNN=NNN+NCH*NCHP if(bcorr)ncorr=ncorr+nco*ld*ldp LDP=(LF-L1P)/4 NCHP=MCP*LDP NNN=NNN+MC*NCHP if(bcorr)ncorr=ncorr+nco*ldp c write(0,*)-nadg(ix)-nnn ENDIF c ENDIF C IADD=NADG(IX)+NNN-ncorr !assuming corr.-corr. omitted c c write(0,*)irev*ix,nc00,nd00,li0,lf0,nadg(ix),nnn,-ncorr,iadd c write(6,*)irev*ix,nc00,nd00,li0,lf0,nadg(ix),nnn,-ncorr,iadd c if(irev.lt.0)iadd=iadd+1 !for case iadd=0 (e.g. bp nmetag) C QPTLS=IADD*IREV C RETURN END C C ******************* C INTEGER FUNCTION QPTLSJ(KX,IX00,JX00,NC00,ND00,LI0,LF0) C C----------------------------------------------------------------------- C C FN.QPTLSJ INITIALIZES THE POINTER FOR DETERMINING THE 2-BODY C FS INTERACTIONS (ALGEBRA) FOR: C INPUT: C KX IS THE JP SYMMETRY INDEX C IX0 IS THE INITIAL LSP SYMMETRY INDEX C JX0 IS THE FINAL LSP SYMMETRY INDEX C NC0 IS THE INITIAL TARGET LSP INDEX C ND0 IS THE FINAL TARGET LSP INDEX C LI IS THE INITIAL CONTINUUM ORBITAL ANG. MOM. C LF IS THE FINAL CONTINUUM ORBITAL ANG. MOM. C bcorr flags if correlation may be present (then corr-corr was c omitted from algebra - default, anyway - see algxls to sync.) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BSYM,eqgrp,eqgrpl,eqgrpl0,bcorr,becor,bcor C COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDWJ/JSYMM(MXSYJ,MAXJG),NCHGJ(MAXJG),NADGJ(MAXJG) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,ipar common /nrbone/ione,ione0 C C----------------------------------------------------------------------- C c if elastic is dropped here then it has an effect on inelastic c transitions between terms of same symmetry because they are mixed c cold ione0=0 !=0 retain elastic here c c if bcor then we have algebraic correlation, and we know how ordered c bcor=kdm*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD/J(NCOR/J) c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- C IJ=JPI(KX)/10 if(ij.gt.maxjfs)stop 'qptlsj called for 2j>maxjfs!' !shouldn't be C IF(IX00.GT.JX00)THEN IREV=1 IX0=IX00 JX0=JX00 NC0=NC00 ND0=ND00 LI=LI0 LF=LF0 ELSEIF(IX00.LT.JX00)THEN IREV=-1 IX0=JX00 JX0=IX00 NC0=ND00 ND0=NC00 LI=LF0 LF=LI0 ELSE !THEN AS LS CASE, LIKELY NCOR WILL FLAG BUT TO BE SAFE IX0=IX00 JX0=JX00 IF(NC00.GT.ND00)THEN IREV=1 NC0=NC00 ND0=ND00 LI=LI0 LF=LF0 ELSEIF(NC00.LT.ND00)THEN IREV=-1 NC0=ND00 ND0=NC00 LI=LF0 LF=LI0 ELSE NC0=NC00 ND0=ND00 IF(LI0.GE.LF0)THEN IREV=1 LI=LI0 LF=LF0 ELSE IREV=-1 LI=LF0 LF=LI0 ENDIF ENDIF ENDIF C NNN2=0 ncorr2=0 C DO NX=1,IX0 IX=JSYMM(NX,KX) IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 NCN=NCHG(IX) C MXP=NX IF(NX.EQ.IX0)MXP=JX0 C DO MX=1,MXP JX=JSYMM(MX,KX) ISP=LSPI(JX)/10000 IPP=LSPI(JX)-ISP*10000 ILP=IPP/10 IF((IS+ISP-2)*(IL+ILP).GT.0)THEN C BSYM=NX.EQ.IX0.AND.MX.EQ.JX0 IF(BSYM)NCN=NC0 NCNP=NCHG(JX) C c write(0,*)'q-start',kx,nx,mx,nadgj(kx)+nnn2-ncorr2 DO N=1,NCN NC=ITARG(N,IX) MC=NSL(NC) L1=LLCH(1,N,IX) L2=LLCH(2,N,IX) LD=((L2-L1)/4+1) NCH=MC*LD if(bcorr)mci=ngrpi(nc) C IF(IX.EQ.JX)NCNP=N IF(BSYM.AND.N.EQ.NC0)NCNP=ND0 C DO NP=1,NCNP ND=ITARG(NP,JX) eqgrp=ix.eq.jx.and.nc.eq.nd eqgrpl=eqgrpl0.and.eqgrp IF(iabs(NMETAG(NC))+iabs(NMETAG(ND)).LT.2)THEN IF(eqgrp)THEN L1P=L1 LDP=(LD*(LD+1))/2 LD=1 NCH=MC ELSE L1P=LLCH(1,NP,JX) L2P=LLCH(2,NP,JX) LDP=((L2P-L1P)/4+1) ENDIF MCP=NSL(ND) NCHP=MCP*LDP NNN2=NNN2+NCH*NCHP C if(bcorr)then nco=0 nce=0 c do lli=l1,l2,4 c lf2=l2p c if(nc.eq.nd)lf2=lli c do llf=l1p,lf2,4 mcip=ngrpi(nd) do m=1,mc j1=m+mci j=jndex(j1) do mp=1,mcp j1p=mp+mcip c if(ix.eq.jx.and.j1p.gt.j1-ione0.and.lli.eq.llf)go to 61 jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then nco=nco+1 !corr.-corr. if(j1.eq.j1p)nce=nce+1 endif enddo c 61 continue enddo ncorr2=ncorr2+nco*ld*ldp endif ENDIF ENDDO C IF(eqgrpl.and.NMETAG(NC).eq.0)THEN LDD=(L2-L1)/4+1 MM=MC+ione0 NNN2=NNN2-LDD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr2=ncorr2-ldd*(nco-nce)/2 !for li.eq.lf ENDIF C ENDDO c write(0,*)'q-end',kx,nx,mx,nadgj(kx)+nnn2-ncorr2 ENDIF ENDDO ENDDO C !ADJUST LAST BLOCK IF(eqgrpl.and.iabs(NMETAG(NC)).lt.1)THEN NNN2=NNN2+LDD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr2=ncorr2+ldd*(nco-nce)/2 !for li.eq.lf ENDIF C IF(iabs(NMETAG(NC))+iabs(NMETAG(ND)).LT.2)THEN NNN2=NNN2-NCH*NCHP if(bcorr)ncorr2=ncorr2-nco*ld*ldp C c write(0,*)'nadg',nadg(ix) IF(eqgrp)THEN LD=(LI-L1)/4 LDP=(LD*(LD+1))/2 NNN2=NNN2+MC*MC*LDP if(bcorr)ncorr2=ncorr2+nco*ldp c write(0,*)nadgj(kx)+nnn2,ldp,mc if(eqgrpl)then MM=MC+ione0 NNN2=NNN2-LD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr2=ncorr2-ld*(nco-nce)/2 !for li.eq.lf c write(0,*)nadgj(kx)+nnn2,-ld,mm endif LDP=(LF-L1P)/4 NCHP=MCP*LDP NNN2=NNN2+MC*NCHP if(bcorr)ncorr2=ncorr2+nco*ldp c write(0,*)nadgj(kx)+nnn2,ldp ELSE LD=(LI-L1)/4 NCH=MC*LD NNN2=NNN2+NCH*NCHP if(bcorr)ncorr2=ncorr2+nco*ld*ldp LDP=(LF-L1P)/4 NCHP=MCP*LDP NNN2=NNN2+MC*NCHP if(bcorr)ncorr2=ncorr2+nco*ldp c write(0,*)-nadgj(kx)-nnn2 ENDIF c ENDIF C IADJ=NADGJ(KX)+NNN2-ncorr2 !assuming corr.-corr. omitted c if(irev.lt.0)iadj=iadj+1 !for case iadj=0 (e.g. nmetag) C QPTLSJ=IADJ*IREV C RETURN END C C ******************* C SUBROUTINE RADBP1(K2,K4,K,DK,M00) C C----------------------------------------------------------------------- C C SR.RADBP1 CALCULATES M1+BP ONE-BODY RADIATIVE INTEGRALS, K=1-8, OR C ORDINARY MK FOR K=9,10. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD09=MXBLM+2) !+2 CASE BREL C PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C DIMENSION DH(MAXB1),CON(10) C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /TRANS/DRL(MAXRL),DOSC(0:MXD09,MAXGR,MAXGR) X ,NADWE(MAXTM),NAI(MAXTM),NCO,IORIG(MAXTM) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) C COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit c common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C CON(1)=C4 CON(2)=CON(1) CON(3)=CON(1) CON(4)=CON(1) CON(5)=DALF/DTWO CON(6)=DALF/DEIGHT CON(7)=CON(5) CON(8)=DONE CON(9)=DONE CON(10)=CON(1) C M0=MOD(M00,1000) c if(m0.ne.0.or.m0.eq.0.and.k.eq.0)then !should not occur (now) write(6,*)'radbp1, what are we doing here?',m0,m00,k write(0,*)'radbp1, what are we doing here?' go to 999 endif C C COMPUTE M1BP RADIATIVE ONE-BODY INTEGRALS C C P1(R)*P2(R)*F(R) WHERE F(R) DEPENDS ON THE TYPE C c K=IABS(K) if(k.lt.0)then !should not occur (now) write(6,*)'radbp1: k.lt.0!!',m0,m00,k write(0,*)'radbp1: k.lt.0!!' go to 999 endif c N=K DKU=DZERO D00=DZERO C C GO TO (31,32,33,34,35,36,37,35,50,51),N C IF(N.EQ.1)THEN GO TO 31 ELSEIF(N.EQ.2)THEN GO TO 32 ELSEIF(N.EQ.3)THEN GO TO 33 ELSEIF(N.EQ.4)THEN GO TO 34 ELSEIF(N.EQ.5)THEN GO TO 35 ELSEIF(N.EQ.6)THEN GO TO 36 ELSEIF(N.EQ.7)THEN GO TO 37 ELSEIF(N.EQ.8)THEN GO TO 35 ELSEIF(N.EQ.9)THEN GO TO 50 ELSEIF(N.EQ.10)THEN GO TO 51 ELSE STOP 'SR.RADBP1: WE SHOULD NEVER GET HERE!' ENDIF C C TYPE-1: P1*P2/X**2 C 31 DO I=1,MAXRS DP(I)=DPNL(I,K2)*DPNL(I,K4)/(DX(I)*DX(I)) ENDDO C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DP(I)+DQNL(I,K2)*DQNL(I,K4)/(DX(I)*DX(I)) ENDDO ENDIF GO TO 49 C C TYPE-2: (P1/X)*P2' C 32 DO I=1,MAXRS DPA(I)=DPNL(I,K2)/DX(I) DP(I)=DPNL(I,K4) ENDDO GO TO 39 C C TYPE-3: P1*(P2/X)' C 33 DO I=1,MAXRS DPA(I)=DPNL(I,K2) DP(I)=DPNL(I,K4)/DX(I) ENDDO GO TO 39 C C TYPE-4: P1'*P2' C 34 if(igagr.gt.0.and.ql(k2).eq.ql(k4))then !see radial/diagfs dku=d2ll(k2,k4) c write(0,*)k2,k4,dku if(ql(k2)+ql(k4).gt.0)then do i=1,maxrs dp(i)=dpnl(i,k2)*dpnl(i,k4)/(dx(i)*dx(i)) enddo call weddle(d00,dp,dku0,mnh,dhns,mjh,maxrs) tl=ql(k2)*(ql(k2)+2)+ql(k4)*(ql(k4)+2) dku=-dku0*tl/8+dku if(ql(k2).ne.ql(k4))then !see radial/diagfs ds=dey(k2)-duy(k2,k2) de=dey(k4)-duy(k4,k4) do i=1,maxrs dp(i)=dpnl(i,k2)*dpnl(i,k4) enddo call weddle(d00,dp,ovl,mnh,dhns,mjh,maxrs) dku=dku+ovl*(de+ds) c write(0,*)ds,de,k2,k4,ovl endif endif c write(0,*)k2,k4,dku,dku0 go to 52 endif C DO I=1,MAXRS DH(I)=DPNL(I,K2) DP(I)=DPNL(I,K4) ENDDO C IF(QL(K2)+QL(K4).EQ.0)D00=DORIG(K2)*DORIG(K4) C CALL DIFF(DH,DPA,MNH,DHNS,MJH) C C ENTRY POINT FOR TYPES-2 AND-3 C 39 CALL DIFF(DP,DH, MNH,DHNS,MJH) C DO I=1,MAXRS DP(I)=DPA(I)*DH(I) ENDDO GO TO 49 C C TYPES-5 & -8: P1*P2*X**2 C 35 DO I=1,MAXRS DP(I)=DPNL(I,K2)*DPNL(I,K4)*DX(I)*DX(I) ENDDO C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DP(I)+DQNL(I,K2)*DQNL(I,K4)*DX(I)*DX(I) ENDDO ENDIF GO TO 49 C C TYPE-6: P1*P2 C 36 IF(QL(K2).EQ.QL(K4))THEN DKU=DZERO IF(K2.EQ.K4)DKU=DONE GO TO 52 ELSE !not allowed? c write(0,*)'rad:',k2,k4 DO I=1,MAXRS DP(I)=DPNL(I,K2)*DPNL(I,K4) ENDDO C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DP(I)+DQNL(I,K2)*DQNL(I,K4) ENDDO ENDIF GO TO 49 ENDIF C C TYPE-7: P1*P2/X C 37 if(igagr.gt.0.and.ql(k2).eq.ql(k4))then !see radial/diagfs n=5 !not actually used then go to 35 endif c DO I=1,MAXRS DP(I)=DPNL(I,K2)*DPNL(I,K4)/DX(I) ENDDO C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DP(I)+DQNL(I,K2)*DQNL(I,K4)/DX(I) ENDDO ENDIF C C ********************************************** C 49 CALL WEDDLE(D00,DP,DKU,MNH,DHNS,MJH,MAXRS) C C ********************************************** C GO TO 52 C C TYPES-9 AND -10 (FOR 1-BODY MK) P1*P2*X**K C 50 NGROUP=M00/2000 IF(BREL2)THEN TJ=-2/(DFSC*(NGROUP+2)) IF(qn(k2).EQ.qn(k4).OR.irtard.eq.0.AND.NGROUP.GT.1)THEN DO I=1,MAXRS DP(I)=(DPNL(I,K2)*DQNL(I,K4)+DQNL(I,K2)*DPNL(I,K4)) X *DX(I)**NGROUP ENDDO ELSEIF(irtard.lt.0)THEN DEL=DEY(K2)-DUY(K2,K2)-DEY(K4)+DUY(K4,K4) !A.U. TE=abs(DFSC*DEL) TJ=TJ*3/TE**NGROUP DO I=2,NGROUP TJ=TJ*(2*I+1) ENDDO DO I=1,MAXRS TZ=DX(I)*TE DP(I)=DPNL(I,K2)*DQNL(I,K4)+DQNL(I,K2)*DPNL(I,K4) DP(I)=DP(I)*BESSJ(NGROUP,TZ) ENDDO ELSE !NGROUP.EQ.1.or.irtard.gt.0 DEL=DEY(K2)-DUY(K2,K2)-DEY(K4)+DUY(K4,K4) !A.U. TE=DFSC*DEL TE=TE*TE/(2*(2*NGROUP+3)) DO I=1,MAXRS DP(I)=(DPNL(I,K2)*DQNL(I,K4)+DQNL(I,K2)*DPNL(I,K4)) X *DX(I)**NGROUP*(DONE-TE*DX(I)*DX(I)) ENDDO ENDIF C CALL WEDDLE(D00,DP,DKU,MNH,DHNS,MJH,MAXRS) DKU=DKU*TJ c kx=min(k2,k4) if(ngroup.eq.1)then t=dosc(ngroup+1,k2+k4-kx,kx) del=dey(k2)-duy(k2,k2)-dey(k4)+duy(k4,k4) !a.u. te=dfsc*del t=t*2*te*te/6 else t=dosc(ngroup-1,k2+k4-kx,kx) endif c write(0,*)'bess',ngroup,k2,k4,dku,t c ELSE IF(NGROUP.GT.1)THEN KX=MIN(K2,K4) DKU=DOSC(NGROUP-1,K2+K4-KX,KX) c write(0,*)'DOSC',k2,k4,dku ELSE IF(K2.EQ.K4)THEN DKU=DONE ELSE DKU=DZERO ENDIF ENDIF ENDIF GO TO 52 C 51 NGROUP=M00/2000 KX=MIN(K2,K4) DKU=DOSC(NGROUP+1,K2+K4-KX,KX) c write(0,*)'10',k2,k4,dku C 52 if(n.gt.10)then !should not occur (now) write(6,*)'Index error in SR.RADBP1: N.gt.10:',n write(0,*)'Index error in SR.RADBP1' go to 999 endif c DK=DKU*CON(N) C RETURN C 999 M00=-1 RETURN C END C C ******************* C SUBROUTINE RADBP2(BPRNT0) C C----------------------------------------------------------------------- C C SR.RADBP2 CALCULATES THE TWO-BODY M1+BP RADIAL INTEGRALS C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: QSS !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C C PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (C4=DFSC**2/DFOUR) C CHARACTER(LEN=4) MBLK C CF77 INTEGER*8 MSS !F77 C LOGICAL BAUX,BINT,BJUMP,BJUMP2,BRAD,BREL,BJUMPR,BMVD,BREL2 X,BPRNT0,BSTO,BLAG,BBC2 C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 COMMON /EX/DRLP1(MXSOI),DNL(MAXMI) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C DATA MBLK/' '/ C C NN=NL000+1 C IF(BPRNT0)THEN IF(NN.EQ.1)THEN WRITE(6,610) ELSE WRITE(6,982)MBLK ENDIF ENDIF C BREL2=IABS(IREL).EQ.2 C IF(BJUMP)THEN !JUST SCALE EXISTING DO L=NN,NL M=0 DD=DONE DO I=1,4 N=QSS(I,L) M=M+IVAL(N) DD=DD*FACT(N) ENDDO IF(M.GT.0)THEN IF(.NOT.BJUMP2)DNL(L)=DZERO DNL(L)=DNL(L)*DD ENDIF IF(BJUMP2.AND.BPRNT0)WRITE(6,140)L,(QSS(I,L),I=1,5),DNL(L) ENDDO IF(.NOT.BJUMP2)GO TO 121 GO TO 500 !RETURN ENDIF C DO L=NN,NL DNL(L)=DZERO ENDDO C 121 K=0 C DO J=NN,NL !START MAGNETIC TWO-BODY OUTER LOOP C !OVER INNER ORBITAL PAIR (YLAMK) IF(DNL(J).NE.DZERO)GO TO 127 C M=QSS(5,J) MM=(M+2)/100 BAUX=MM.EQ.7 BINT=MOD(MM,2).EQ.0.OR.BAUX !FALSE FOR 1,3,5 C M1=(M-100*MM)/2 IF(M1.GT.MAXLAM)GO TO 127 C MJ0=0 IF(MM.GT.4)THEN K=1 MJ0=3 else k=0 ENDIF C N1=QSS(K+1,J) N2=QSS(K+3,J) IF(MODE.LT.3)THEN IMT=0 IF(IYY(N1).GT.0)IMT=IMT+1 IF(IYY(N2).GT.0)IMT=IMT+1 IF(IMT.GT.1)GO TO 127 ENDIF C M2=(QL(N1)+QL(N2))/2+2 IF((MM+1)/2.EQ.2)THEN !3,4 M2=M2+1 DO I=1,MAXRS DPA(I)=DPNL(I,N2)*DX(I) ENDDO ELSEIF(.NOT.BINT)THEN !1,5 DO I=1,MAXRS DPA(I)=DPNL(I,N2)/DX(I) ENDDO ELSE !IF(MM.NE.4)THEN !0,2,6,7 DO I=1,MAXRS DPA(I)=DPNL(I,N2)*DPNL(I,N1) ENDDO c ELSE c DO I=1,MAXRS c DPA(I)=DPNL(I,N2)*DPNL(I,N1)/DX(I) c ENDDO ENDIF C IF(.NOT.BINT)THEN IF(QL(N2).GT.0)M2=M2-1 C CALL DIFF(DPA,DP,MNH,DHNS,MJH) C DO I=1,MAXRS DPA(I)=DPNL(I,N1)*DP(I)*DX(I) ENDDO ENDIF C IF(BREL)THEN DE1=DEY(N1)-DUY(N1,N1) DE2=DEY(N2)-DUY(N2,N2) DEL=DE1-DE2 ! A.U. T=C4*DTWO DZ=NZION IF(BREL2)THEN DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD2=DONE+T*(DE2+POT(I,1)) D12=DD1*DD2 d12=abs(d12) DPA(I)=DPA(I)/SQRT(D12) ENDDO ELSE dd=rnorm(n1)*rnorm(n2) DO I=1,MAXRS DD1=C4*(DQNL(I,N1)/DPNL(I,N1)+DTWO*DZ/DX(I)) IF(DD1.GT.-DONE)DD1=DONE+DD1 !HIGH-Z POINT NUCL. DD2=C4*(DQNL(I,N2)/DPNL(I,N2)+DTWO*DZ/DX(I)) IF(DD2.GT.-DONE)DD2=DONE+DD2 !HIGH-Z POINT NUCL. c dd1=done+t*(de1+dz/dx(i)) !alt c dd2=done+t*(de2+dz/dx(i)) !alt D12=DD1*DD2 d12=abs(d12) DPA(I)=DPA(I)*dd/SQRT(D12) ENDDO ENDIF CALL YLAMKR(M1,M2,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0) ELSE CALL YLAMK(M1,M2,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0) ENDIF C KX=QSS(4-K,J) IF(MM.EQ.1.OR.MM.EQ.2)THEN WRITE(6,*)'RADBP2 ERROR: KX=',KX WRITE(0,*)'RADBP2 KX ERROR' NF=-1 GO TO 500 !RETURN ELSEIF(MM.EQ.0)THEN C SKIP ELSEIF(MM.EQ.3.OR.MM.EQ.4)THEN DO I=1,MAXRS DP(I)=DP(I)/DX(I) ENDDO ELSEIF(MM.EQ.6)THEN DO I=1,MAXRS DP(I)=DP(I)*DX(I)*DX(I) ENDDO ELSE !MM=5,7 IF(BAUX)THEN !MM=7 ONLY DO I=1,MAXRS DPA(I)=-DPNL(I,KX)*DP(I)*DX(I)**4 ENDDO ENDIF DO I=1,MAXRS DP(I)=DP(I)*DX(I)**3 ENDDO ENDIF C IF(BAUX)CALL DIFF(DPA,DP,MNH,DHNS,MJH) C DO L=J,NL !START INNER MAGNETIC LOOP C !OVER OUTER ORBITAL PAIR IF(QSS(5,L).NE.M)GO TO 602 IF(QSS(K+1,L).NE.N1.OR.QSS(K+3,L).NE.N2)GO TO 602 IF(BAUX.AND.QSS(4-K,L).NE.KX)GO TO 602 C L1=QSS(2-K,L) L2=QSS(4-K,L) JMT=0 IF(MODE.LT.3)THEN IF(IYY(L1).GT.0)JMT=JMT+1 IF(IYY(L2).GT.0)JMT=JMT+1 IF(IMT+JMT.GT.1)GO TO 602 ENDIF C IF(BAUX)THEN DO I=1,MAXRS DPA(I)=DPNL(I,L1)*DP(I)/DX(I) ENDDO ELSE DO I=1,MAXRS DPA(I)=DPNL(I,L1)*DP(I)*DPNL(I,L2) ENDDO ENDIF C IF(BREL)THEN DE1=DEY(L1)-DUY(L1,L1) DE2=DEY(L2)-DUY(L2,L2) C DEL=DE1-DE2 ! A.U. T=C4*DTWO DZ=NZION IF(BREL2)THEN DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD2=DONE+T*(DE2+POT(I,1)) D12=DD1*DD2 d12=abs(d12) DPA(I)=DPA(I)/SQRT(D12) ENDDO ELSE dd=rnorm(l1)*rnorm(l2) DO I=1,MAXRS DD1=C4*(DQNL(I,L1)/DPNL(I,L1)+DTWO*DZ/DX(I)) IF(DD1.GT.-DONE)DD1=DONE+DD1 !HIGH-Z POINT NUCL. DD2=C4*(DQNL(I,L2)/DPNL(I,L2)+DTWO*DZ/DX(I)) IF(DD2.GT.-DONE)DD2=DONE+DD2 !HIGH-Z POINT NUCL. c dd1=done+t*(de1+dz/dx(i)) !alt c dd2=done+t*(de2+dz/dx(i)) !alt D12=DD1*DD2 d12=abs(d12) DPA(I)=DPA(I)*dd/SQRT(D12) ENDDO ENDIF ENDIF C DS=DZERO C CALL WEDDLE(DS,DPA,DD,MNH,DHNS,MJH,MAXRS) C OVL=DONE IF(IRLX.EQ.2)THEN !OVERLAPS KF=IGRCF(N1) KG=IGRCF(N2) IF(KG.EQ.0)KG=IGRCF(L1) IF(KF.NE.KG.AND.KG.GT.0)THEN K1=MIN(KF,KG) K2=MAX(KF,KG) KK=((K2-1)*(K2-2))/2+K1 OVL=OVLPCF(KK) IF(IPAIR(KK).EQ.1)THEN!SURELY THIS CAN BE SIMPLIFIED... IF(IEQ(N1).EQ.IEQ(N2))THEN K1=MIN(N1,N2) K2=MAX(N1,N2) ELSEIF(IEQ(L1).EQ.IEQ(L2))THEN IF(IGRCF(L1).EQ.0)GO TO 611 K1=MIN(L1,L2) K2=MAX(L1,L2) ELSEIF(KF.NE.IGRCF(L1))THEN IF(IEQ(N1).EQ.IEQ(L1))THEN K1=MIN(N1,L1) K2=MAX(N1,L1) ELSEIF(IEQ(L2).EQ.IEQ(N2))THEN IF(IGRCF(L2).EQ.0)GO TO 611 K1=MIN(L2,N2) K2=MAX(L2,N2) else write(6,*)'radbp2: why are we here?', x kf,kg,n1,l1,n2,l2 write(0,*)'radbp2: why are we here?' nf=-1 go to 500 !return ENDIF ELSE IF(IEQ(N1).EQ.IEQ(L2))THEN K1=MIN(N1,L2) K2=MAX(N1,L2) ELSEIF(IEQ(L1).EQ.IEQ(N2))THEN K1=MIN(L1,N2) K2=MAX(L1,N2) else write(6,*)'radbp2: why are we here?', x kf,kg,n1,l1,n2,l2 write(0,*)'radbp2: why are we here?' nf=-1 go to 500 !return ENDIF ENDIF KK=((K2-1)*(K2-2))/2+K1 OVL=OVL/OVLPGR(KK) ENDIF ENDIF ENDIF C 611 DNL(L)=DD*C4*OVL C 602 ENDDO !END INNER LOOP C 127 IF(BPRNT0)WRITE(6,140)J,(QSS(I,J),I=1,5),DNL(J) C ENDDO !END OUTER LOOP C 500 RETURN C 140 FORMAT(I5,3X,2(I5,I4),I6,F14.8) 610 FORMAT(//5X,"N&V( A B C D 2LBD') = MAGNETIC INTEGRALS") 982 FORMAT(A4,26X,4I4,2X,7F9.4) C END C C ******************* C SUBROUTINE RADCN0(MYMO,MYNO,MPO,DHNSX) C C----------------------------------------------------------------------- C C SR.RADCN0 READS USER INPUT FOR RADCON BRANCH AND SETS-UP AN C ENERGY MESH ACCORDINGLY. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD24=2*MAXGR) C PARAMETER (MXTABF=41) !NO OF FINE PRE-TAB'D ENERGIES FOR PI PARAMETER (MXTABC=25) !NO OF COARSE PRE-TAB'D ENERGIES FOR PI PARAMETER (MXFOTE=2*MXENG) !BUFFER SPACE FOR PI ENERGIES C PARAMETER (MXD12=100) PARAMETER (MXD14=100) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DSIX=6.0D0) PARAMETER (DTEN=10.0D0) PARAMETER (DTWELV=12.0D0) PARAMETER (DTON=100.0D0) PARAMETER (D0PT85=0.85D0) PARAMETER (D0PT9=0.9D0) PARAMETER (D1PT05=1.05D0) PARAMETER (D1PT5=1.5D0) PARAMETER (D1P9=1.0D9) PARAMETER (D1P18=1.0D18) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M5=1.0D-5) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M24=1.0D-24) PARAMETER (DKCM=109737.31D0) C CHARACTER(LEN=3) PIG C LOGICAL BLAG,BSTO,BJUMP,BDR,BBC2,BNAME,BFOT,BJUMP2,BRAD,BLOOP,BTWO X ,BECOR,EX C DIMENSION EFOT(MXFOTE),EDUMF(MXTABF),EDUMC(MXTABC) C COMMON /BASIC/NF,MGAP(11) COMMON /COM3/DDY,DZ,TM COMMON /GENINF/DAJOLD(MXVAR),DSIGMA(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MGAPP,MA0,MB0,KSUBCF COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ESKPL,ESKPH,BECOR COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLOO/BLOOP,LNEW,LCON,LSUM,LMAX COMMON /NRBNAM/BNAME,NF0 COMMON /NRBTAR/ETAR(MAXTM),ISTAR(MAXTM),LTAR(MAXTM),JTAR(MAXTM) X ,NTAR,IGAPE COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD C CMOD SAVE MOD,MDUM C NAMELIST/SRADCON/ECOR1,ECOR2,MENG,NREL,ACE,MYN,MYM,MP X ,ECORLS,ECORIC,NLAG,PIG,PMIN,EMIN,EMAX,MDECP X,NDE,DEMIN,DEMAX,MENGI,EMINI,EMAXI,DELTAX,TOLDE,TEAPOT,ilog,tolp CMOD X ,MOD,MDUM !ABOVE FOR SR.RADCX0 COMPATIBILITY C EQUIVALENCE (MENG,MENGI),(EMIN,EMINI),(EMAX,EMAXI) C DATA EDUMC/0.0D+0,2.1D-6,4.6D-6,1.0D-5,2.1D-5,4.6D-5, !DEFAULT X 1.0D-4,2.1D-4,4.6D-4,1.0D-3,2.1D-3,4.6D-3, !MESH X 1.0D-2,2.1D-2,4.6D-2,1.0D-1,2.1D-1,4.6D-1, !MXTABC X 1.0D+0,2.1D+0,4.6D+0,1.0D+1,2.1D+1,4.6D+1,1.0D+2/ !=25 DATA EDUMF/0.0D+0,1.6D-6,2.5D-6,4.0D-6,6.3D-6, !FINE X 1.0D-5,1.6D-5,2.5D-5,4.0D-5,6.3D-5, !TEST X 1.0D-4,1.6D-4,2.5D-4,4.0D-4,6.3D-4, X 1.0D-3,1.6D-3,2.5D-3,4.0D-3,6.3D-3, X 1.0D-2,1.6D-2,2.5D-2,4.0D-2,6.3D-2, X 1.0D-1,1.6D-1,2.5D-1,4.0D-1,6.3D-1, X 1.0D+0,1.6D+0,2.5D+0,4.0D+0,6.3D+0, X 1.0D+1,1.6D+1,2.5D+1,4.0D+1,6.3D+1,1.0D+2/ !41=MXTABF C X,1.6D+2,2.5D+2,4.0D+2,6.3D+2/ !45 C C C SOME INITIALIZATIONS C BDR=IDR.NE.0 PI=ACOS(-DONE) C DZ=NZION DZA=MION-NZION-1 NZA=MAX(NZION-MION+1,1) DZA2=NZA*NZA !=DZA*DZA EXCEPT CASE DZA=0, THEN 1 TQD=DZERO C DYY(1)=DZERO EMIN=-1 EMAX=-2 IF(BFOT)THEN IPIG=1 !LENGTH PMIN=-DONE DO I=1,MXENG IGAG(I)=1 ENDDO ENDIF C C ********** ALL INPUT ENERGIES SHOULD BE IN RYDBERGS *********** C IF(BNAME)THEN C ECOR1=DZERO ECOR2=DZERO ECORLS=DZERO ECORIC=DZERO MENG=0 NREL=0 ACE=DZERO MYN=0 MYM=0 MP=0 NLAG=-1 PIG=' ' PMIN=D1M24 MDECP=0 C CMOD MDUM=0 CMOD MOD=0 C C READ(5,SRADCON,END=998,ERR=998) ! <---------------- NAMELIST C C IF(BFOT)THEN IF(PMIN.LE.DZERO.OR. X PIG.NE.' '.AND.PIG.NE.'VAR')THEN !USE FIXED PI GAUGE PMIN=-DONE IF(PIG.EQ.'LEN')THEN IPIG=1 ELSEIF(PIG.EQ.'VEL')THEN IPIG=0 ELSEIF(PIG.EQ.'ACC')THEN IPIG=-2 ELSE WRITE(0,607)PIG WRITE(6,607)PIG NF=-1 GO TO 999 ENDIF ELSE !USE VARIABLE PI GAUGE PMIN=D1P18*PMIN/DZA2 ENDIF IF(MENG.LE.-1000)THEN MDECP=MAX(MDECP,-MENG/1000,7) MENG=-1000 ENDIF IF(MENG.LE.-100.OR.MENG.EQ.0)THEN IF(MDECP.GT.3)THEN MENG=-1000 ELSE IF(MENG.NE.0)MENG=-100 ENDIF ENDIF ENDIF C IF(NLAG.LT.4.OR.NLAG.GT.10.OR.(-1)**NLAG.LT.0)NLAG=6 IF(.NOT.BFOT.AND.MENG.EQ.0)MENG=-2*NLAG C IF(ECORLS.NE.DZERO)ECOR1=ECORLS IF(ECORIC.NE.DZERO)ECOR2=ECORIC C ELSE C READ(5,590)ECOR1,ECOR2,MENG,NREL,ACE,MYN,MYM,MP CMOD X,MDUM,MOD ECOR1=DZERO ECOR2=DZERO NLAG=6 C ENDIF C C CMOD IF(MOD.GT.0)MODE=MOD C C CORRECTION TO ABSOLUTE POSITION OF CONTINUUM (MODE=2) IN DIAGON AND C DELEN APPLIES RELATIVE TERM CORRECTION TO TARGET (SEE SR.MINIM) IN AU. C ECOR1=ECOR1/DTWO ECOR2=ECOR2/DTWO IF(ABS(ECOR1).GT.DTON)ECOR1=ECOR1/DKCM IF(ABS(ECOR2).GT.DTON)ECOR2=ECOR2/DKCM C IF(MODE.LT.1.OR.MODE.GT.4)THEN WRITE(6,593)MODE NF=-1 ENDIF C C MYN, MYM CONTROL PRINT OPTION FOR ORBITALS ]MYN] TO MYM. C MYN .LT.-10 CHECKS ORTHOGONALITY OF SUPPOSEDLY ORTHOG ORBITALS C AND PRINTS OUT DETAILS OF CONTINUUM ORBITALS AT EACH ENERGY. C IF(MYN.EQ.0)MYN=1 IF(MYM.EQ.0)MYM=-1 C IF(ACE.LT.D1M10)ACE=D1P9 !CAN RESTRICT EXTRAPOLATION C C SAME MENG INTERPOLATION POINTS ARE USED IN DIAGON AND DIAGFS. C MRDE=MENG MRDE0=mod(MRDE,100) IF(MRDE.LT.0)MENG=-MIN0(-NLAG,MRDE0) C IF(MENG.GT.MXENG)THEN WRITE(6,251)MXENG,MENG NF=-1 GO TO 999 C MENG=MXENG ENDIF C IF(MRDE.GT.0)GO TO 208 C C IF(MRDE0.LT.0.AND.EMAX.LT.EMIN)THEN C READ(5,*,END=22,ERR=22)EMIN0,EMAX0 C EMIN=EMIN0 EMAX=EMAX0 C ENDIF C IF(EMAX.GT.EMIN.AND.EMIN.LT.DZERO)EMIN=DZERO !ALLOW EMAX C 22 IF(NF.LE.0)GO TO 999 C BBC2=.FALSE. C C USE INTERNAL ENERGIES FOR PHOTOIONIZATION (PREFERABLY). C C IF(BFOT.AND.MRDE0.eq.0)THEN EMIN=EMIN/DZA2 !PI ONLY EMAX=EMAX/DZA2 MFOT=MXFOTE IF(MRDE.GT.-100)THEN !USE COARSE PI ENERGY MESH IF(MFOT.LT.MXTABC)THEN T=EDUMC(MFOT)*DZA2 WRITE(6,333)T,MXTABC ELSE MFOT=MXTABC ENDIF DO I=1,MFOT EFOT(I)=EDUMC(I) ENDDO ELSEIF(MRDE.GT.-1000)THEN !USE FINE PI ENERGY MESH IF(MFOT.LT.MXTABF)THEN T=EDUMF(MFOT)*DZA2 WRITE(6,333)T,MXTABF ELSE MFOT=MXTABF ENDIF DO I=1,MFOT EFOT(I)=EDUMF(I) ENDDO ELSE DT=DONE/MDECP IF(EMIN.GT.DZERO)THEN EFOT(1)=EMIN T=LOG10(EMIN) ELSE IF(EMAX.GT.DZERO)THEN TT=LOG10(EMAX) T=TT-(MXENG-1)*DT ELSE T=-DSIX ENDIF EFOT(1)=DZERO ENDIF IF(EMAX.GT.DZERO)THEN TT=LOG10(EMAX) TT=(TT-T)/DT M=INT(TT) MFOT=MIN(M+2,MFOT) ENDIF DO I=2,MFOT T=T+DT EFOT(I)=DTEN**T ENDDO ENDIF C IF(EMIN.GT.DZERO.AND.EMAX.LT.DZERO)EMAX=EFOT(MFOT) !ALLOW EMIN C C MFOT=MAX(MRDE0,-MFOT) !RESTRICTION NOT IMPOSED C I0=1 I1=MFOT IF(EMAX.GT.EMIN.AND.EMIN.GE.DZERO)THEN DO I=1,MFOT IF(EFOT(I).LE.EMIN)I0=I IF(EFOT(I).LT.EMAX)I1=I+1 ENDDO IF(I1.GT.MFOT)THEN IF(EFOT(MFOT).LT.EMAX*D0PT9)THEN WRITE(6,713)EFOT(MFOT)*DZA2 WRITE(0,*)'***SR.RADCON: EMAX TOO LARGE FOR DIMEN. MXENG' NF=-1 GO TO 999 ELSE !CLOSE ENOUGH I1=MFOT ENDIF ENDIF ENDIF IF(I1-I0+1.GT.MXENG)I1=I0+MXENG-1 M=0 DO I=I0,I1 M=M+1 DYY(M)=EFOT(I)*DZA2 ENDDO MENG=M GO TO 206 ENDIF C C SET-UP INTERPOLATION ENERGIES FOR AUTOIONIZATION (PREFERABLY). C IF(MENG.EQ.0)THEN WRITE(6,606) WRITE(0,*)'***ERROR, MUST SPECIFY NON-ZERO MENG ENERGIES FOR DR' NF=-1 GO TO 999 ENDIF C BTWO=.FALSE. IF(EMAX.LT.DZERO.OR.EMIN.LT.DZERO)THEN !GET TARGET INFO C E00=DZERO IF(NJO.LE.0)THEN !LS ONLY INQUIRE(FILE='TERMS',EXIST=EX) IF(.NOT.EX)GO TO 820 IUNIT(14)=1 IRDE=14 OPEN(IRDE,FILE='TERMS') READ(IRDE,*,END=822) DO I=1,MAXTM READ(IRDE,*,END=822)ISTAR(I),LTAR(I),IP,ICF,NDUM,ETAR(I) IF(ICF.EQ.0)GO TO 821 ISTAR(I)=(1-2*MOD(IP,2))*ISTAR(I) EMXX=ETAR(I) ENDDO WRITE(6,*)'**ERROR: TOO MANY TERMS, INCREASE MAXTM' WRITE(0,*)'**ERROR: TOO MANY TERMS, INCREASE MAXTM' NF=-1 GO TO 999 ELSE !IC INQUIRE(FILE='LEVELS',EXIST=EX) IF(.NOT.EX)GO TO 820 IUNIT(15)=1 IRDE=15 OPEN(IRDE,FILE='LEVELS') READ(IRDE,*,END=822) DO I=1,MAXTM READ(IRDE,*,END=821)JTAR(I),IP,ISTAR(I),LTAR(I) X ,ICF,NDUM,ETAR(I) IF(ICF.EQ.0)GO TO 821 EMXX=ETAR(I) ENDDO WRITE(6,*)'*ERROR: TOO MANY LEVELS, INCREASE MAXTM' WRITE(0,*)'**ERROR: TOO MANY LEVELS, INCREASE MAXTM' NF=-1 GO TO 999 ENDIF C C DETERMINE ENERGY RANGE(S) FOR AUTOIONIZATION C 821 CONTINUE C E00=ETAR(I) 822 CLOSE(IRDE) IUNIT(IRDE)=-1 C NTAR=I-1 IGAPE=0 IF(EMAX.LT.DZERO.AND.EMIN.LT.DZERO.AND.MENG.GE.2*NLAG)THEN !TWO, DE=DZERO ! MAYBE IE=0 DO I=2,NTAR IF(ETAR(I)-ETAR(I-1).GT.DE)THEN IE=I DE=ETAR(I)-ETAR(I-1) ENDIF ENDDO BTWO=IE.GT.2.AND.DE.GT.D1PT5*(ETAR(NTAR)-ETAR(IE)).AND. !2* X DE.GT.2*ETAR(IE-1) !how big? ELSE !ONE BTWO=.FALSE. ENDIF IF(EMAX.LT.DZERO)THEN IF(BDR)THEN NXX=NMAX IF(JND.GT.0)NXX=NDR(JND) ELSE NXX=NNEW ENDIF TN=DZA/NXX TN=TN*TN EMXX=EMXX-TN EMXX=EMXX*D1PT05 IF(EMXX.LE.DZERO)THEN WRITE(6,*)'*** SR.RADCON WARNING: CHECK/SET INTERPOLATION', X ' ENERGIES; POSSIBLE/PROBABLE INACCURACY' WRITE(0,*)'*** SR.RADCON WARNING: CHECK/SET INTERPOLATION', X ' ENERGIES; POSSIBLE/PROBABLE INACCURACY' EMXX=-TN IF(NXX.GT.1)TN=DZA/(NXX-1) TN=TN*TN EMXX=EMXX+TN EMXX=EMXX*D0PT85 ENDIF EMAX=EMXX ENDIF IF(EMIN.LT.DZERO)THEN NEQ=0 IF(LNEW.LT.0)THEN IF(NNEW.EQ.2)NEQ=MION-2 IF(NNEW.EQ.3)NEQ=MION-10 IF(NNEW.EQ.4)NEQ=MION-28 IF(NEQ.LT.0)NEQ=0 ENDIF DZM=DZA-NEQ DUM=TQDT(TQD,NZION,MION-NEQ,NNEW,MAX(0,LNEW)) c write(0,*)'qd=',tqd N00=0 IF(MB0.EQ.0.AND.MION.GE.10)N00=2 IF(MB0.LE.1.AND.MION.GE.28)N00=3 IF(N00.EQ.0)THEN IF(BDR)THEN N00=NMIN ELSE N00=NNEW ENDIF ENDIF IF(BTWO)THEN TM=DZM/(N00-TQD) TM=TM*TM EMAX2=EMAX EMIN=ETAR(IE)-ETAR(IE-1)-TM EMAX1=MAX(ETAR(IE-1),ETAR(NTAR)-ETAR(IE)) EMAX1=EMAX1-TN IF(EMAX1.LT.D1M2*DZA*DZA)EMAX1=D1M2*DZA*DZA EMAX1=EMAX1*D1PT05 EMIN1=DZERO ELSE IF(BDR)THEN NLOOP=NMAX IF(JND.GT.0)NLOOP=NLOOP+JND ELSE NLOOP=N00 ENDIF EMIN=EMAX/D1PT05 DO N=N00,NLOOP NXX=N IF(BDR.AND.N.GT.NMAX)NXX=NDR(NXX-NMAX) TM=DZM/(NXX-TQD) TM=TM*TM TN=DZA/NXX TN=TN*TN DO I=NTAR,2,-1 DO J=I-1,1,-1 IF(ETAR(I)-ETAR(J)-TN*D0PT9.GE.DZERO)THEN EMIN=MIN(EMIN,ETAR(I)-ETAR(J)-TM) c write(0,*)n,i,j,emin GO TO 824 ENDIF ENDDO 824 ENDDO ENDDO ENDIF C EMIN=EMIN*D0PT9 C IF(LNEW.LT.0)EMIN=EMIN*D0PT9 IF(EMIN.LT.D1M2*DZA*DZA)EMIN=DZERO ENDIF IF((EMAX-EMIN).LT.D1M5)GO TO 820 ENDIF C C SET UP ENERGY GRID FOR INTERPOLATION C IF(.NOT.BTWO)GO TO 825 BBC2=.TRUE. EMIN2=EMIN !TWO RANGES IF(EMAX2-EMIN2.LT.D1M5)THEN EMAX=EMAX2 EMIN=EMIN2 GO TO 820 ENDIF IF(EMAX1-EMIN1.LT.D1M5)THEN EMAX=EMAX1 EMIN=EMIN1 GO TO 820 ENDIF IF(EMIN2-EMAX1.LT.D1M5)THEN EMAX=EMAX2 EMIN=EMIN1 BTWO=.FALSE. GO TO 825 ENDIF c write(6,*)'emin,emax1,2=',emin1,emax1,emin2,emax2 MN2=MENG/2 DD=MN2-1 EMAX=EMAX1+DONE EMIN=EMIN1+DONE DO M=1,MN2 DM=M-1 T=EMAX/EMIN T=T**(DM/DD) DYY(M)=EMIN*T-DONE ENDDO IGAPE=MN2+1 MN1=MN2 MN2=MENG-MN2 DD=MN2-1 EMAX=EMAX2+DONE EMIN=EMIN2+DONE DO M=1,MN2 DM=M-1 T=EMAX/EMIN T=T**(DM/DD) DYY(MN1+M)=EMIN*T-DONE ENDDO C GO TO 206 C 825 IF(EMAX.LT.EMIN)THEN !ONE RANGE (ALSO OPT. PI) T=EMAX EMAX=EMIN EMIN=T ENDIF c write(6,*)'emin, emax=', emin,emax IF(MENG.LE.1)THEN !CASE MXENG=1 WRITE(6,605)-MENG,MXENG WRITE(0,*)'****ERROR IN SR.RADCON, REQUIRE AT LEAST TWO', X ' INTERPOLATION ENERGIES' NF=-1 GO TO 999 ENDIF DD=MENG-1 EMAX=EMAX+DONE EMIN=EMIN+DONE DO M=1,MENG DM=M-1 T=EMAX/EMIN T=T**(DM/DD) DYY(M)=EMIN*T-DONE ENDDO C GO TO 206 C 820 WRITE(6,604)EMIN,EMAX WRITE(0,*)'****ERROR IN SR.RADCON, UNSUITABLE ENERGY RANGE' NF=-1 GO TO 999 C C READ USER SUPPLIED INTERPOLATION ENERGIES C C 208 READ(5,*)(DYY(I),I=1,MENG) C C IF(NF.LE.0)GO TO 999 BBC2=.TRUE. IF(MENG.EQ.1)GO TO 206 C C RE-ORDER INTO ASCENDING ENERGIES C DO I=2,MENG IM=I-1 IF(DYY(I).GT.DYY(IM))GO TO 205 T=DYY(I) DYY(I)=DYY(IM) DYY(IM)=T IT=NREL IF(NREL.EQ.I)NREL=IM IF(IT.EQ.IM)NREL=I IF(IM.EQ.1)GO TO 205 C DO J=2,IM JM=I-J JJ=JM+1 IF(DYY(JJ).GT.DYY(JM))GO TO 205 T=DYY(JJ) DYY(JJ)=DYY(JM) DYY(JM)=T IT=NREL IF(NREL.EQ.JJ)NREL=JM IF(IT.EQ.JM)NREL=JJ ENDDO 205 ENDDO C C DISCARD EQUAL ENERGY ENERGIES C MX=MENG DO I=2,MX IF(I.GT.MENG)GO TO 206 T=ABS(DYY(I)-DYY(I-1)) IF(T.LT.D1M10)THEN IP=I+1 DO J=IP,MENG DYY(J-1)=DYY(J) ENDDO MENG=MENG-1 IF(NREL.GE.I)NREL=NREL-1 ENDIF ENDDO C 206 IF(MION-NZION.EQ.1.AND.DYY(1).LT.D1M2)THEN WRITE(6,*)'*** RE-SETTING E=0 TO 1.D-2 FOR NEUTRALS...' DYY(1)=D1M2 ENDIF IF(NREL.LT.1.OR.NREL.GT.MENG)THEN NREL=1 IF(.NOT.BFOT)NREL=NREL+MENG/2 ENDIF C C TEST MESH FOR INTEGRALS INVOLVING CONTINUUM FUNCTIONS C T=SQRT(DYY(MENG)) IF(T.NE.DZERO)THEN T=PI/T T=T/DHNSX IF(T.LT.DTWELV)THEN IF(T.LT.DSIX)THEN M0=MSTEP+1 WRITE(6,1222)DYY(MENG),M0 WRITE(0,*)'RADIAL MESH TOO COARSE' NF=-1 GO TO 999 ELSE IF(BFOT)THEN M0=MSTEP+1 WRITE(6,1223)DYY(MENG),M0 IF(DYY(MENG).GT.DFOUR*DZA2)THEN WRITE(0,*)'RADIAL MESH TOO COARSE' NF=-1 GO TO 999 ENDIF ENDIF ENDIF ENDIF ENDIF C MYMO=MYM !FOR ANNOYING COMPILERS MYNO=MYN MPO=MP C DUM=NDUM*DUM !SUPRESS WARNINGS ABOUT UNUSED DUMMY VARIABLES C 999 RETURN C 998 WRITE(6,1997) WRITE(0,*)'*** SR.RADCN0: ERROR READING NAMELIST SRADCON!' !FATAL NF=-1 GO TO 999 C C 251 FORMAT( ' TOO MANY INTERPOLATION ENERGIES REQUESTED: REDUCE MENG' X,' OR INCREASE MXENG FROM',I5,' TO',I5/) 333 FORMAT('*** WARNING SR.RADCON: INTERNAL PI ENERGY MESH TRUNCATED'/ X 4X,'EMAX=',1PD12.2,' INCREASE MXENG TO:',I3, X ' TO OBTAIN FULL ENERGY MESH, E.G. FOR RATE COEFFICIENTS') 590 FORMAT(2F10.1,2I5,F10.4,5I5) C 591 FORMAT(7F10.4) 593 FORMAT( ' YOUR VALUE OF',I3, ' FOR MODE IN SR.RADCON IS NOT WITH XIN THE CURRENT VALID RANGE') 604 FORMAT(/' ****ERROR IN SR.RADCON, UNSUITABLE ENERGY RANGE FOR ', X'INTERPOLATION, EMIN=',F10.4,3X,'EMAX=',F10.4/) 605 FORMAT('****ERROR IN SR.RADCON, REQUIRE AT LEAST TWO', X ' INTERPOLATION ENERGIES BUT MENG=',I4/ X ' DIMENSION PROBLEM? MXENG=',I6) 606 FORMAT(/' ***ERROR, MUST SPECIFY NON-ZERO MENG ENERGIES FOR DR') 607 FORMAT(/'*** UNRECOGNIZED PI GAUGE: PIG=',A3) 713 FORMAT('*** SR.RADCON: REQUESTED MAX PI ENERGY TOO LARGE'/ X'*** EITHER REDUCE EMAX TO .LT.',1PD11.2/ X'*** OR INCREASE DIMENSION PARAMETER MXENG'/ X'*** OR INPUT 0 .LT. MENG .LE. MXENG ENERGIES EXPLICITLY') 1222 FORMAT(/' SR.RADCON: EMAX=',1PD8.2,' MESH TOO COARSE, BOUND-', X'CONTINUUM INTEGRALS IN ERROR.'/'*** REDUCE EMAX IN NAMELIST ', X'SRADCON OR INCREASE MSTEP TO',I3,' IN NAMELIST SMINIM') 1223 FORMAT(/' SR.RADCON: WARNING, EMAX=',1PD8.2,' MESH MAYBE TOO ' X,'COARSE, BOUND-CONTINUUM INTEGRALS MAYBE IN ERROR.' X/' *** TRY REDUCING EMAX IN NAMELIST SRADCON OR INCREASING MSTEP ' X,'TO',I3,' IN NAMELIST SMINIM') 1997 FORMAT('*** SR.RADCN0: ERROR READING NAMELIST SRADCON!'/4X, X'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES') C END C C ******************* C SUBROUTINE RADCNX(FRX,PSHFTX,PSHFT0,MDIM1,MDIM2,MDIM3,LNEW,LOLD X ,LCDW,MPOSC0) C C----------------------------------------------------------------------- C C SR.RADCNX CALCULATES/UPDATES THE DEIE DW CONTINUUM BASIS C C IT CALLS: C SR.FCF6 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXNUK=200) !NO. OF RADIAL POINTS FOR FINITE NUCLEUS C PARAMETER (DZERO=0.0D0) c PARAMETER (DONE=1.0D0) C LOGICAL BPRNT0,BREL,BJUMPR,BMVD,BSTO,BORT,BREL2,BTHRSH !,BPRINT C DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3),PSHFT0(0:*) C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TOL,MEND C COMMON /COM3/DDY,DZ,TM !SET IN FCF6 FOR PMVDAR c common /com6/da(maxb1) COMMON /COM7/DNUK(MXNUK),ZS(10) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT c COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP c common /nrbdqe/dqnl(maxb2,maxgr) COMMON /NRBDW1/MXORB COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW6/QPOS(MAXGR),QPOS0(MAXGR) COMMON /NRBFR/GR(MAXB1) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C BPRNT0=JPRINT.GE.3 !FOR DETAILED PRINTOUT c BPRNT0=JPRINT.NE.-3 BORT=MORT.LT.0 IORT=IABS(MORT) BREL2=IABS(IREL).EQ.2 BTHRSH=LCDW.LT.0 IF(BTHRSH)LCDW=-LCDW C C FOR TOTAL LNEW THERE ARE LCDW CONTINUUM ORBITAL ANGULAR MOMENTA C OF LNEW-LCDW/2 THRU LNEW+LCDW/2. C QPOS(L), L=1,LCDW GIVE THE LOCATION OF THE ASSOCIATED ANG. MOM. C ORBITAL. THIS ENABLES US TO RE-USE ANY COMMON ORBITALS FROM LOLD. C THUS, SHOULD GROUP ALL S,PI TOGETHER FOR A GIVEN LTOT AND LOOP C OVER LTOT SEQUENTIALLY, AS IS DONE BY USE OF MINLT,MAXLT. C MPOSC=IABS(MPOSC0) MPOSQ=(LCDW+1)/2-LNEW C IF(LOLD.LT.0)THEN !FIRST TIME DO L=1,LCDW I=MPOSC+L QPOS(L)=L QN(I)=-90 C IVAL(I)=0 !NOT USED DORIG(I)=DZERO !SHOULD NOT BE USED DUY(I,I)=DZERO !FIXED SO THAT DEY CAN HOLD ENERGY DEY(I)=DZERO SCREEN(I)=DZERO !SHOULD NOT BE USED ENDDO IFLAG=0 ELSE DO L=1,LCDW QPOS0(L)=IABS(QPOS(L)) QPOS(L)=0 ENDDO ML=-2*(MPOSQ-1) MU=2*(LNEW+LCDW/2) DO L=1,LCDW I=MPOSC+L IF(QL(I).GE.ML.AND.QL(I).LE.MU)THEN !RE-USE K=MPOSQ+QL(I)/2 QPOS(K)=-QPOS0(L) !FLAG OLD ELSE QPOS0(L)=-QPOS0(L) !NOT WANTED ENDIF ENDDO IFLAG=1 ENDIF C C----------------------------------------------------------------------- C MYL2=-2*MPOSQ C !LABEL & FLAG EXISTENCE DO L=1,LCDW I=MPOSC+L MYL2=MYL2+2 QL(I)=MYL2 IF(QPOS(L).EQ.0)THEN !NEW IFLAG=0 DO K=1,LCDW !LOOK FOR SPACE IF(QPOS0(K).LT.0)THEN QPOS(L)=-QPOS0(K) QPOS0(K)=0 GO TO 100 ENDIF ENDDO WRITE(6,*)' SR.RADCNX: QPOS INDEX ERROR...' WRITE(0,*)' SR.RADCNX: QPOS INDEX ERROR...' NF=-1 GO TO 999 ENDIF 100 CONTINUE c write(0,*)i,l,qpos(l),ql(i),myl2 !debug print ENDDO C IF(IFLAG.NE.0)GO TO 999 !QUICK RETURN C C----------------------------------------------------------------------- C C NOW GENERATE UPDATED CONTINUUM BASIS FOR QPOS(L).GT.0, L=1,LCDW C C----------------------------------------------------------------------- C IF(BPRNT0)THEN IF(MPOSC0.GT.0)THEN WRITE(6,998)LNEW ELSE JNEW=2*LNEW+MOD(LCDW+1,2) WRITE(6,996)JNEW !ASSUMES USER HASN'T RESTRICTED LCONDWJ ENDIF ENDIF C NZA=NZION-MION c DZ=NZION DZ0=-NZION !CHARGES .LT. ZERO IN FCF6 DZA=-NZA DD0=DZERO C MK=MXORB+1 !NOMINAL ORBITAL POSITION IF(BORT)THEN !FIND SCALING PARAMETER IC=MIN(NPARAM,MK) ELSE IC=NPARAM ENDIF DJ=DADJUS(IC) MEND=JEND(IC) MZNM=5 !POTENTIAL PARAMETERS C DO L=1,LCDW C I=MPOSC+L MYL=QL(I)/2 C L0=QPOS(L) C IF(L0.GT.0.AND.MYL.GE.0)THEN C DO M=1,MENG C DDY=DYY(M) C IF(DJ.GT.DZERO.OR.IORT.EQ.2.OR.BREL)THEN ! DW C CALL FCF6(FRX(1,M,L0) X ,DP0,TM,MYL,DDY,DZ0,DZA,DD0,DD0,DD0,ZS,MZNM X ,DPOT,MEND,DNUK,MJH,MNE,DHNS,DX,GR,MAXRS) C IF(MYL.LT.0)THEN WRITE(6,*)'*** FCF6 FAILURE...' WRITE(0,*)'*** FCF6 FAILURE...' NF=-1 GO TO 999 ENDIF c c test c do k=1,mxorb cc c if(2*myl.ne.ql(k))go to 63 c if(dorig(k).eq.dzero)go to 63 cc c if(brel2)then c do i=1,maxrs c da(i)=dpnl(i,k)*frx(i,m,l0)+dqnl(i,k)*gr(i) c enddo c else c do i=1,maxrs c da(i)=dpnl(i,k)*frx(i,m,l0) c enddo c endif cc c call weddle(dzero,da,dd,mne,dhns,mjh,maxrs) cc c if(brel2)then c do i=1,maxrs c frx(i,m,l0)=frx(i,m,l0)-dd*dpnl(i,k) c gr(i)=gr(i)-dd*dqnl(i,k) c enddo c else c do i=1,maxrs c frx(i,m,l0)=frx(i,m,l0)-dd*dpnl(i,k) c enddo c endif cc c 63 enddo C IF(BREL2)THEN DO I=1,MAXRS FRX(MAXRS+I,M,L0)=GR(I) ENDDO ENDIF C ELSE !COULOMBIC C CALL FCF4(FRX(1,M,L0) X ,DP0,DDY,DZA,MYL,MJH,MNE,DHNS,DX) C TM=DZERO C ENDIF C PSHFTX(M,L0)=TM C IF(BPRNT0)WRITE(6,997)MYL,DDY,TM C ENDDO C IF(BTHRSH)PSHFT0(MYL)=PSHFTX(1,L0) C ENDIF C ENDDO C C 999 RETURN C 998 FORMAT(//' *** UPDATING CONTINUUM ORBITAL BASIS FOR LTOT=', X I3/1X,49('-')/) 997 FORMAT(' L=',I2,3X,'E=',F10.5,' RYD',3X,'DEL/PI=',F9.4) 996 FORMAT(//' *** UPDATING CONTINUUM ORBITAL BASIS FOR 2*JTOT=', X I3/1X,51('-')/) C END C C ****************** C C SUBROUTINE RADCON(MAXPS) C WRITE(6,200) C RETURN C 200 FORMAT(' SR.RADCON: THIS IS A DUMMY SUBROUTINE VERSION') C END C C ******************* C SUBROUTINE RADCON(MAXPS) C C----------------------------------------------------------------------- C C N.R.BADNELL D.A.M.T.P. CAMBRIDGE C ********************************* C C SR.RADCON DETERMINES A SET OF RADIAL CONTINUUM FUNCTIONS. C C MODE=1, SUPERSTRUCTURE MODE. C MODE=2, SETS C-C INTERACTIONS TO ZERO, STORES B-C SEPARATELY AND C SETS THEM TO ZERO IN H BEFORE DIAGONALIZATION. C MODE=3, ALL B-B, B-C AND C-C INTERACTIONS EVALUATED AND PUT IN C H FOR DIAGONALIZATION. C MODE=4, NOT USED BY RADCON, RADIAL SHIFTS ENERGIES OF CERTAIN C BOUND ORBITALS TO SUPRESS MIXING. C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: QSS !F95 USE COMMON_DXRL, ONLY: QRL,IRL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD24=2*MAXGR) PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C PARAMETER (MXNUK=200) !NO. OF RADIAL POINTS FOR FINITE NUCLEUS C PARAMETER (MXD12=100) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M6=1.D-6) PARAMETER (D1M10=1.0D-10) PARAMETER (D1M40=1.0D-40) PARAMETER (D1M50=1.0D-50) PARAMETER (DFSC=7.2973525333D-03) !this isn't PARAMETER (DALF=DFSC*DFSC) !very clever PARAMETER (DKCM=109737.31D0) PARAMETER (DTOL=0.01D0) PARAMETER (D99=99.0D0) c CF77 integer*8 nrk,mss !F77 C CHARACTER(LEN=4) MCF4,MCF6,MCF C LOGICAL BLAG,BORT,BSTO,BXTRP,BJUMP,BDR,BSTART,BPRNT0,BBC2, XBHF,BREL,BJUMPR,BFOT,BJUMP2,BRAD,BMVD,BREL2,BECOR,BFIX C DIMENSION MFE(10),DORIG(MAXGR) C COMMON /BASIC/NF,MGAP(11) COMMON /CADJ/DADJUS(MXVAR),DF0,IEQUAL(MXVAR),IDUM COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DL2(MAXB1),TOL,MEND COMMON /COM3/DDY,DZ,TM COMMON /COM6/DA(MAXB1) COMMON /COM7/DNUK(MXNUK),ZS(10) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DAJOLD(MXVAR),DSIGMA(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,ORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR),D2LL(MAXGR,MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBCOR/ECOR1,ECOR2,ECORR,ESKPL,ESKPH,BECOR COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZDUM,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBFR/GR(MAXB1) COMMON /NRBFSI/DNLI(MXENG,MXFSS),NLI(MAXMI) COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBSPL/FR(MAXB1),DERV1(MAXB1),DERV2(MAXB1),BP(MAXB1) COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD C CMOD SAVE MOD,MDUM C DATA MCF6/'FCF6'/,MCF4/'FCF4'/,IDERV/0/ C C IF(NF.LE.0)GO TO 70 C C SOME INITIALIZATIONS C PI=ACOS(-DONE) PIH=PI/DTWO C MRP=10+1 !SCRATCH UNIT C NZA=MAX(NZION-MION+1,1) !CHARGES DZ=NZION DZ0=-NZION !CHARGES .LT. ZERO IN FCF6 DZA=MION-NZION-1 DZA2=NZA*NZA !=DZA*DZA EXCEPT CASE DZA=0, THEN 1 TOLR=D1M6/NZA C BDR=IDR.NE.0 !LOGICALS BSTART=.FALSE. BHF=MHF.GT.0 IF(BJUMPR)BREL=.FALSE. !BJUMPR=.FALSE. FIXED IN RADIAL BREL2=IABS(IREL).EQ.2 BORT=MORT.LT.0 IORT=IABS(MORT) BXTRP=.FALSE. BPRNT0=JPRINT.NE.-3 C MYN=1 !MESH PRINTOUT MYM=-1 II=1 MP=-1 C MZNM=5 !POTENTIAL PARAMETERS CTEST MEND=0 JPOT=-1 DJ=DZERO TOL=DONE/10**ITOL NP0=0 IF(IPOLFN.LT.0)NP0=-IPOLFN C NPARM3=(NP0+1)*NPARAM C MPP=1 !PLASMA POTENTIAL IF(MDEN.LT.0)MPP=2 ZDUM=-D99 C TM=DONE !OLD PHASE - NEEDED? MINK=0 !OLD E SHIFT - COULD REMOVE USE C KK=0 !INTERPOLATION COUNTERS KFS=0 M8=0 C C SEE WHICH ORBITALS TO COMPUTE C K0=-1 NSTORE=1 MAXL=0 IVM=100000 IVP=0 C DO K=1,MAXGR DORIG(K)=DZERO IF(DEY(K).NE.DZERO)THEN IF(IVAL(K).GT.0)THEN IF(K.GT.IVP)IVP=K IF(K.LT.IVM)IVM=K ENDIF IF(DSIGMA(K).LT.5999)THEN !BOUND (CORE) DORIG(K)=ORIG(K)*DZ ELSE IF(K0.LT.0)K0=K IF(DSIGMA(K).LT.7999)THEN !RYDBERG BXTRP=.TRUE. NSTORE=QN(K) IF(QL(K).GT.MAXL)MAXL=QL(K) ENDIF ENDIF ENDIF ENDDO C IF(K0.LT.0)GO TO 133 !NO NEW ORBITALS TO CALC, RECOVER FROM FILE MAXL=1+MAXL/2 IF(BJUMP.OR.MODE.EQ.1)GO TO 113 !NOT FIRST TIME, SKIP SET-UP MSHFT=10000 C C 70 CALL RADCN0(MYM,MYN,MP,DHNS(MJH)) C X,MOD,MDUM) C IF(NF.LE.0)GO TO 1000 !RETURN C BLAG=MENG.GT.1 C C INITIALIZE CONTUNUUM INTERPOLATION INTEGRAL ARRAYS C C *** SLATER (2-BODY NON-FINE STRUCTURE USE SLATER SWITCH SO NOT NECESS) C DO J=1,MXFSL DO I=1,MENG DRLI(I,J)=DZERO ENDDO ENDDO C C *** 2-BODY FINE-STRUCTURE C IF(NL000.GT.0)THEN DO J=1,MXFSS DO I=1,MENG DNLI(I,J)=DZERO ENDDO ENDDO ENDIF C BSTART=BDR IF(BLAG)BDR=BSTART C C FOR CONTINUUM WAVEFUNCTION WE DROP ALL POINTS PAST INPUT MAXPS C SINCE ALL INTEGRALS P*F, P*P SHOULD HAVE CONVERGED BY THEN. C IF BXTRP=TRUE EVALUATE OUT TO POINT WHERE AMP. PHASE CAN BE USED, C FOR WORST CASE E=0, L=MAXL. C IF BDR IS TRUE MUST EVALUATE ALL ORBITALS OUT TO X(MAXRS=MXR) C WITH GRID MFH, MFE. C HOWEVER, INTEGRALS NEED ONLY BE EVALUATED OUT TO MAXPS C WITH GRID MJH, MNE. C 113 IF(BXTRP)THEN DTH=3*MAXL*(MAXL+1)+60 DD0=DTH/(DTWO*SQRT(DZA2)) dd0=max(dd0,rzero) C DO I=1,MAXRS IF(DX(I).GT.DD0)THEN IF(I.GT.MAXPS)MAXPS=I GO TO 202 ENDIF ENDDO MAXPS=MAXRS ENDIF C 202 DHNS0=DHNS(1) MJH0=MJH CMOD IF(MDUM.GT.0)MAXPS=MDUM MAXTS=MAXPS IF(BDR)THEN IF(.NOT.BJUMP)THEN MAXTS=MAXRS ELSE IF(BREL)MAXTS=MAXRS !L=0 SLOW TO CONVERGE... ENDIF ENDIF IF(DENE.GT.DZERO)MAXTS=MAXRS MXR=0 CMOD IF(MDUM.LT.0)MAXTS=-MDUM C DO I=1,MJH0 MFE(I)=MNE(I) MXR=MFE(I)+MXR MFH=I IF(MXR.EQ.MAXTS)GO TO 18 IF(MXR.GT.MAXTS)THEN MXR=MXR-MFE(I) nxtra=9 c if(.not.bsto)nxtra=max(nxtra,2*mne(i-1)) !test MFE(I)=MAX0(MAXTS-MXR,nxtra) MXR=MXR+MFE(I) GO TO 18 ENDIF ENDDO C 18 MAXTS=MAXPS MAXPS=0 DO I=1,MJH0 MAXPS=MNE(I)+MAXPS MJH=I IF(MAXPS.EQ.MAXTS)GO TO 111 IF(MAXPS.GT.MAXTS)THEN MAXPS=MAXPS-MNE(I) MNE(I)=MAX0(MAXTS-MAXPS,9) !since for integrals only MAXPS=MAXPS+MNE(I) GO TO 111 ENDIF ENDDO C 111 MAXRS=MAXPS C MR=5 IF(MYN.LT.0)WRITE(6,250)MAXRS,MXR C C START LOOP TO EVALUATE ALL CONTINUUM ORBITALS C 72 DO K=K0,MAXGR IF(DORIG(K).EQ.DZERO.AND.DEY(K).NE.DZERO)THEN N=K MI=QN(N) QN(N)=-IABS(MI) MYL=QL(N)/2 MNN=-QN(N) DDY=DZERO IF(DSIGMA(N).LT.7999)GO TO 444 IF(BDR)GO TO 69 DDY=2*NSTORE*NSTORE IF(BXTRP)DSHIFT(N)=DZA*DZA/DDY GO TO 69 ENDIF ENDDO C IF(BJUMP)GO TO 133 GO TO 138 C 69 IYY(N)=1 DDY=DYY(NREL) IF(DDY.LE.DZERO)THEN !CHECK FOR NON-NEGATIVE ENERGY IF(DDY.LT.-D1M40)THEN WRITE(6,401)N, DDY IF(N.EQ.MAXGR)GO TO 138 GO TO 72 ENDIF DDY=D1M50 ENDIF C DDY=DDY+DTWO*DSHIFT(N) C 444 M80=M8 DD0=DZERO K0=N+1 IF(K0.GT.MAXGR)K0=N IF(.NOT.BORT)GO TO 646 C DAJOLD(N)=DADJUS(N) IF(BDR)THEN IF(.NOT.BSTO.OR.DDY.LE.DZERO)THEN IF(DADJUS(N).EQ.DJ)GO TO 99 IF(ABS(DX(MXR)*POT(MXR,1)+DZA).LT.D1M2)THEN !WE HAVE A POTL IF(BFOT.AND.IDERV.EQ.0)THEN IDERV=1 CALL DIFF(POT(1,1),DERV,MFE,DHNS,MFH) ENDIF DO I=1,MXR DL2(I)=POT(I,1)-DZ/DX(I) DL2(I)=DL2(I)+DL2(I) ENDDO JPOT=1 DJ=DADJUS(N) MEND=JEND(N) GO TO 618 ENDIF ENDIF ENDIF C JEND(N)=MEND IF(.NOT.BSTO.AND.DADJUS(N).EQ.DJ.AND.IPOLFN.GE.0)GO TO 99 IF(BSTO.AND.N*MCFMX.GT.MCFMX**2.AND.DJ.NE.DZERO)GO TO 99 C DJ=DADJUS(N) DJ0=DJ IF(.NOT.BSTO)THEN DJ1=DONE DJ2=DONE IF(NP0.GT.0)DJ1=DADJUS(NPARAM+N) IF(NP0.EQ.2)DJ2=DADJUS(2*NPARAM+N) ENDIF C MK=N MMM=MION DS=DZ IF(DJ.GT.DZERO)GO TO 611 IF(IORT.EQ.2)GO TO 611 IF(BREL)GO TO 611 C C FOR HYDROGENIC WAVE FUNCTIONS: USE FOLLOWING POTENTIAL CALL: C DS=DZA MMM=1 DJ0=DONE C C 611 IF(.NOT.BSTO)CALL TFDAPO(DS,MMM,MK,DJ0,DJ1,DJ2,DHNS0,MXR,MFH,MFE X ,DHNS,DX,DL2,TOL,MEND,CRRCT1,CRRCT2) C IF(BSTO)CALL STOPOT(DS,MMM,MK,DJ0,DHNS0,MXR,MFH,MFE,DHNS,DX,DL2 X ,DTOL,MEND,MPP) C IF(NF.LE.0)GO TO 1000 !RETURN C IF(DHNS(1).NE.DHNS0)THEN IF(BPRNT0)WRITE(6,710) IF(N.EQ.MAXGR)GO TO 138 GO TO 72 ENDIF IF(BPRNT0)THEN IF(BHF)WRITE(6,773)QN(N),MYL,MHF,MEND,DX(MEND) IF(.NOT.BSTO.AND..NOT.BHF)THEN WRITE(6,774)QN(N),MYL,DJ,MEND,DX(MEND) IF(NP0.GT.0)WRITE(6,1774)1,DJ1-DONE,CRRCT1 !DJ1 IF(NP0.EQ.2)WRITE(6,1774)2,DJ2-DONE,CRRCT2 !DJ2 ENDIF NP=N IF(MCFMX.GT.0)NP=MIN0(N,MCFMX) IF(BSTO.AND..NOT.BHF)WRITE(6,775)QN(N),MYL,MCFSTO(NP),DJ,MEND X ,DX(MEND) ENDIF C ZNP=DX(MXR)*DL2(MXR) C MML=MYL CORE IF(BORT.AND.MK.GE.MGAPP(2).AND.MK.LE.MGAPP(3))MML=-MML IF(MDEN.GT.2.AND.MPP.GT.1)ZDUM=ZNP C CALL VMPOT(ZNP,MML,MXR,DX,DZ,MAXPS,MPP,-MK) C IF(NF.LE.0)GO TO 1000 !FAILURE C IF(MDEN.GT.2)MPP=MPP+1 IF(DENE.GT.DZERO)MEND=MXR C IF(BFOT.AND.IDERV.EQ.0)THEN IDERV=1 CALL DIFF(DL2,DERV,MFE,DHNS,MFH) ENDIF C JPOT=2 DO I=1,MXR POT(I,JPOT)=DL2(I) DL2(I)=DL2(I)-DZ/DX(I) DL2(I)=DL2(I)+DL2(I) ENDDO C DJ=DADJUS(N) JEND(N)=MEND GO TO 618 C 646 JOLD=JPOT JPOT=MYL+1 IF(JPOT.GT.MXPOT)JPOT=MXPOT IF(JPOT.EQ.JOLD)GO TO 99 c IPOT=JPOT C c 58 DJ=DADJUS(IPOT) c IPOT=IPOT-1 !should no longer happen... dj=dadjus(jpot) IF(DJ.EQ.DZERO)then !GO TO 58 write(6,*)'sr.radcon: dj=0' write(0,*)'sr.radcon: dj=0' go to 999 endif C IF(BFOT.AND.IDERV.EQ.0)THEN IDERV=1 CALL DIFF(POT(1,JPOT),DERV,MFE,DHNS,MFH) ENDIF DO I=1,MXR DL2(I)=POT(I,JPOT)-DZ/DX(I) DL2(I)=DL2(I)+DL2(I) ENDDO mend=jend(jpot) C C 618 IF(BREL)THEN C CALL DIFF(DL2,DERV1,MFE,DHNS,MFH) CALL DIFF(DERV1,DERV2,MFE,DHNS,MFH) C T=DZ/RNUK INUKP=INUK+1 IF(INUK.GT.MXNUK)THEN WRITE(6,*)'***SR.RADCON: INCREASE MXNUK TO AT LEAST:',INUK WRITE(0,*)'***SR.RADCON: INCREASE MXNUK' GO TO 999 ENDIF IF(INUKE.EQ.0)THEN !UNIFORM DO I=1,INUK DNUK(I)=T*(DTHREE-(DX(I)/RNUK)**2)-DTWO*DZ/DX(I) DERV1(I)=-T*DX(I)/RNUK**2 DERV2(I)=-T/RNUK**2 ENDDO ELSE !U6 T0=T T00=(T0*63)/16 T8=8*RNUK**2 DO I=1,INUK T=DX(I)/RNUK TT=T*T TTT=TT*TT DNUK(I)=T00-T0*(42-(18-7*TT)*TTT)*TT/16-DTWO*DZ/DX(I) DERV1(I)=-T0*(21-(27-14*TT)*TTT)*DX(I)/T8 DERV2(I)=-T0*(21-(135-98*TT)*TTT)/T8 ENDDO ENDIF C DO I=INUKP,MXR T=DX(I)**2 DERV1(I)=DHALF*DERV1(I)-DZ/T DERV2(I)=DHALF*DERV2(I)+DTWO*DZ/(T*DX(I)) ENDDO C ELSE C M1=0 DD=DZERO C CALL FIT(DD,M1,DHNS(1),DL2,ZS) C ENDIF C C 99 IF(DJ.GT.DZERO.OR.IORT.EQ.2.OR.BREL)THEN ! DW c MEND=JEND(N) if(bort.and.mend.ne.jend(n))stop 'mend.ne.jend' if(mend.eq.0)stop 'sr.radcon: mend=0' C C CALL FCF6(FR,DP0,TM,MYL,DDY,DZ0,DZA,DD0,DD0,DD0,ZS,MZNM,DL2,MEND X ,DNUK,MFH,MFE,DHNS,DX,GR,MAXPS) C IF(MYL.LT.0)THEN WRITE(6,*)'*** FCF6 FAILURE...' WRITE(0,*)'*** FCF6 FAILURE...' GO TO 999 ENDIF C C ELSE !COULOMBIC TM=DZERO C CALL FCF4(FR,DP0,DDY,DZA,MYL,MFH,MFE,DHNS,DX) C ENDIF C IF(MYN.LT.0)WRITE(6,997)MYL,DDY,TM C C NOTE DDY OMITTED FROM DQNL(K,I) FOR K=CONTINUUM (MODE.GT.2 ONLY) C REMEMBER THIS WHEN LOOKING AT RELATIVISTIC INTEGRALS DD3=DZERO IF(DDY.LT.DZERO)DD3=DDY IF(BORT.AND.MODE.LE.2)DD3=DDY CT IF(BREL)DD3=DZERO C IF(BREL2)THEN DO I=1,MXR DPNL(I,N)=FR(I) DQNL(I,N)=GR(I) ENDDO ELSE DO I=1,MXR DPNL(I,N)=FR(I) DQNL(I,N)=(DL2(I)+DD3)*DPNL(I,N) ENDDO ENDIF IF(MP.GT.0)THEN DO I=1,MXR WRITE(6,998)I,DX(I),DPNL(I,N),DQNL(I,N) ENDDO ENDIF C DD3=DZERO MCF=MCF6 IF(DJ.LT.DZERO)MCF=MCF4 IF(.NOT.BORT.AND.MYN.GE.-10.AND.MAUTO.GT.0)GO TO 26 cccccc IF(BREL)GO TO 26 IF((MORT.EQ.-3 ).AND.IRLX.NE.2)GO TO 26 C .OR..NOT.BSTO C C ORTHONORMALIZE (SCHMIDT PROCEDURE DO63, NORMALIZATION DO64-65) C ONLY ATTEMPT TO ORTHOG TO FUNCTIONS K .LT. N C DO K=1,N IF(2*MYL.NE.QL(K))GO TO 63 IF(DORIG(K).EQ.DZERO)GO TO 63 C C AVOID TRYING TO ORTHOG TO CONTINUUM WAVEFUNCTION C IF(QN(K).LT.0)GO TO 63 C C AVOID ORTHOG TO CORRELATION ORBITAL C IF(BORT.AND.DADJUS(K).LT.DZERO)GO TO 63 C C AVOID ORTHOG TO VALENCE ORBITAL DURING DR OPERATION C IF(BDR.AND.IVAL(K).GT.0)GO TO 63 C IF(BREL2)THEN DO I=1,MAXPS BP(I)=DPNL(I,K)*DPNL(I,N)+DQNL(I,K)*DQNL(I,N) ENDDO ELSE DO I=1,MAXPS BP(I)=DPNL(I,K)*DPNL(I,N) ENDDO ENDIF C CALL WEDDLE(DD0,BP,DD,MNE,DHNS,MJH,MAXPS) C I=QL(K)/2 IF(BPRNT0)WRITE(6,960)QN(N),MYL,QN(K),I,DD C IF(IRLX.EQ.2)THEN KKK=((N-1)*(N-2))/2+K OVLPGR(KKK)=DD GO TO 63 ENDIF C DO I=1,MXR DPNL(I,N)=DPNL(I,N)-DD*DPNL(I,K) DQNL(I,N)=DQNL(I,N)-DD*DQNL(I,K) ENDDO C DP0=DP0-DD*DORIG(K)/DZ C DD3=DZERO FOR MODES 1&2,=SUM OVRLAP**2 FOR MODE GT 2 (CONTINUUM) IF(DDY.GE.DZERO.AND.MODE.GT.2)DD3=DD3+DD*DD C 63 ENDDO C C 26 DNORM=DONE IF(DP0.LT.DZERO)THEN C WRITE(6,781 N,(DPNL(M,N),M=1,50) C DNORM=-DNORM C TM=TM+DONE !FOR ASSX C WRITE(6,781) IF(DDY.NE.DZERO)GO TO 9 ENDIF C IF(DDY.GT.DZERO)GO TO 1 IF(DDY.EQ.DZERO)THEN DNORM=MNN DNORM=DNORM-TM DNORM=DZA*DZA/(PIH*DNORM**3) DNORM=SQRT(DNORM) C IF(DP0.LT.DZERO)DNORM=-DNORM c dnorm=1 !<<<<<<<<<<<<<<<<<<<<<<<<<<<dza since large n TT=TT*TT TD=-TT*TT*DD1 ELSE TD=DZERO ENDIF T=(TMV+TD)*DALF c write(6,*)-ddy/2,-tmv*dalf/2,-td*dalf/2,-t/2 if(ddy+t.lt.dzero)t=dzero !use non.rel. DDY=DDY+T ENDIF DDY=-DDY/DTWO !BOUND A.U. IF(BDR)DSHIFT(N)=-DDY DEY(N)=DUY(N,N)+DDY C ELSE !DDY.GT.DZERO C MINK=0 DD1=-MSHFT*MINK DDY=DDY-DSHIFT(N)*DTWO !CONTINUUM RYD DEY(N)=DUY(N,N)+DD1+DDY*(DONE+DD3)/DTWO IF(DEY(N).EQ.DZERO)DEY(N)=D1M10 DUY(N,N)=DUY(N,N)+DDY*DD3/DTWO C ENDIF C IF(MYN.LT.0)WRITE(6,300)N,QN(N),MYL,MION,NZION,TM, MR,DP0, X DX(MXR),DD0,(DPNL(I,N),I=II,MXR),DEY(N) C DSIGMA(N)=TM C C TEST HERE EVALUATION OF SPIN-ORBIT: WITH FULL POTENTIAL IN SMALL-R C CORRECTION FOR FULL RELATIVISTIC WAVEFUNCTIONS, SINCE WE ONLY RETAIN C DIAGONAL IN NL AND CORRECTION DEPENDS ON E-V, AND/OR POTENTIAL C DERIVATIVE - DO NOT USE CLOSED SHELLS THEN! C STORED TEMPORARILY IN DARWIN ARRAY DCD. C ***SEE ALSO SOCC TO SWITCH-OFF CALCULATION THERE. C IF(DDY.LT.DZERO)THEN !REL. SPIN-ORBIT FOR K=0 NL IF(.NOT.BREL2.OR.QL(N).EQ.0)GO TO 72 !TEST: IF(.NOT.BREL) IF(BREL2)THEN DO I=1,MAXPS BP(I)=DPNL(I,N)*DPNL(I,N)+DQNL(I,N)*DQNL(I,N) DA(I)=DONE+DALF*(DDY+POT(I,JPOT))/DTWO ENDDO ELSE DO I=1,MAXPS BP(I)=DPNL(I,N)*DPNL(I,N) DA(I)=DONE+DALF*(DQNL(I,N)/DPNL(I,N)+DTWO*DZ/DX(I))/DFOUR ENDDO ENDIF IF(IREL.GE.0)THEN !NUCLEAR DO I=1,MAXPS BP(I)=BP(I)/(DX(I)*DX(I)*DX(I)) BP(I)=BP(I)/DA(I) ENDDO ELSE !POTENTIAL DERIV DO I=1,MAXPS BP(I)=BP(I)*DERV1(I)/DX(I) BP(I)=BP(I)/DA(I) ENDDO ENDIF DD1=DZERO CALL WEDDLE(DD1,BP,DD3,MNE,DHNS,MJH,MAXPS) IF(IREL.LT.0)DD3=-DD3/(2*DZ) !POTENTIAL DERIV DCD(N,N)=DALF*DD3/DFOUR GO TO 72 ENDIF C C SET UP ARRAY NRLI FOR CASE BLAG=FALSE C ICOUNT=1 IF(.NOT.BLAG)GO TO 327 C C----------------------------------------------------------------------- C CALCULATE CONTINUUM ORBITALS AT INTERPOLATION ENERGIES C----------------------------------------------------------------------- C ICOUNT=0 46 ICOUNT=ICOUNT+1 IF(ICOUNT.EQ.NREL)ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MENG)GO TO 72 C M8=M80 DDY=DYY(ICOUNT) DDY=DDY+DSHIFT(N)*DTWO C IF(DJ.GT.DZERO.OR.IORT.EQ.2.OR.BREL)THEN !DW DD0=DZERO c MEND=JEND(N) if(bort.and.mend.ne.jend(n))stop 'mend.ne.jend on interp' if(mend.eq.0)stop 'sr.radcon: mend=0 on interp' C C CALL FCF6(FR,DP0,TM,MYL,DDY,DZ0,DZA,DD0,DD0,DD0,ZS,MZNM,DL2,MEND X ,DNUK,MFH,MFE,DHNS,DX,GR,MAXPS) C IF(MYL.LT.0)THEN WRITE(6,*)'*** FCF6 FAILURE...' WRITE(0,*)'*** FCF6 FAILURE...' GO TO 999 ENDIF C C ELSE !COULOMBIC TM=DZERO C CALL FCF4(FR,DP0,DDY,DZA,MYL,MFH,MFE,DHNS,DX) C ENDIF C IF(.NOT.BREL2)THEN DO I=1,MAXPS GR(I)=(DL2(I)+DDY)*FR(I) ENDDO ENDIF C IF(MYN.LT.0)WRITE(6,997)MYL,DDY,TM IF(.NOT.BORT)GO TO 120 IF(MORT.EQ.-3 )GO TO 120 C .OR..NOT.BSTO cccccccc IF(BREL)GO TO 120 C DO K=1,N C IF(2*MYL.NE.QL(K))GO TO 121 IF(DORIG(K).EQ.DZERO)GO TO 121 IF(QN(K).LT.0)GO TO 121 IF(DADJUS(K).LT.DZERO)GO TO 121 IF(BDR.AND.IVAL(K).GT.0)GO TO 121 C IF(BREL2)THEN DO I=1,MAXPS BP(I)=DPNL(I,K)*FR(I)+DQNL(I,K)*GR(I) ENDDO ELSE DO I=1,MAXPS BP(I)=DPNL(I,K)*FR(I) ENDDO ENDIF C CALL WEDDLE (DD0,BP,DD,MNE,DHNS,MJH,MAXPS) C DO I=1,MXR FR(I)=FR(I)-DD*DPNL(I,K) GR(I)=GR(I)-DD*DQNL(I,K) ENDDO DP0=DP0-DD*DORIG(K)/DZ C 121 ENDDO C IF(DP0.LT.DZERO)THEN C DP0=-DP0 C WRITE(6,781)N,(FR(I),I=1,50) C WRITE(6,781) C TM=TM+DONE !FOR ASSX C DO I=1,MXR C FR(I)=-FR(I) C ENDDO ENDIF C 120 DM=-MSHFT*MINK DM=DM+DDY/DTWO-DSHIFT(N) C IF(MYN.LT.0)WRITE(6,100)DDY,MCF,MP,MNN,MYL C C IF(MYN.LT.0)WRITE(6,300)N,QN(N),MYL,MION,NZION,TM,MR,DP0, X DX(MXR),DD0,(FR(I),I=II,MXR),DM C IF(BDR)THEN WRITE(MRP)TM,MXR WRITE(MRP)(FR(I),I=1,MXR),(GR(I),I=1,MXR),(DL2(I),I=1,MXR) ENDIF GO TO 327 C C----------------------------------------------------------------------- C IDENTIFY AND RECOVER CONTINUUM INTERPOLATION ORBITALS DURING DR C AND ZERO-OUT INTEGRAL ARRAYS FOR RECOMPUTATION C----------------------------------------------------------------------- C 133 DO J=1,IRL !SLATER KP=NRLI(J) IF(KP.GT.0)THEN M=0 DO I=1,4 N=QRL(I,J) IF(N.GT.0)M=M+IVAL(N) ENDDO IF(M.NE.0)THEN DO I=1,MENG DRLI(I,KP)=DZERO ENDDO ENDIF ENDIF ENDDO C DO J=1,NL000 !FS KP=NLI(J) IF(KP.GT.0)THEN M=0 DO I=1,4 N=QSS(I,J) M=M+IVAL(N) ENDDO IF(M.NE.0)THEN DO I=1,MENG DNLI(I,KP)=DZERO ENDDO ENDIF ENDIF ENDDO C IF(.NOT.BLAG)GO TO 138 REWIND(MRP) C K9=1 135 IF(K9.GT.MAXGR)GO TO 138 C DO K=K9,MAXGR IF(DEY(K).EQ.DZERO)GO TO 134 IF(IVAL(K).GT.0)GO TO 134 IF(QN(K).GT.0)GO TO 134 N=K GO TO 137 134 ENDDO GO TO 138 C 137 ICOUNT=0 K9=N+1 C 136 ICOUNT=ICOUNT+1 !RE-ENTRY POINT IF NOT FIRST TIME IF(ICOUNT.EQ.NREL)ICOUNT=ICOUNT+1 IF(ICOUNT.GT.MENG)GO TO 135 C C *** CONVERT BACK TO RYD SINCE BJUMP .TRUE. N.B.DSHIFT(N)=DZERO C DDY=DYY(ICOUNT)*DTWO C C READ(MRP)TM,MXREAD READ(MRP)(FR(I),I=1,MXREAD),(GR(I),I=1,MXREAD),(DL2(I),I=1,MXREAD) C C--------------------------------------------------------- C *** EVALUATE BOUND-CONTINUUM INTERPOLATION INTEGRALS *** C--------------------------------------------------------- C 327 CONTINUE !ENTRY FOR FIRST PASS C C *** PI DIPOLE INTEGRALS C IF(BFOT.AND.BLAG)THEN C CALL RKDIPI(ICOUNT,N,M8,MAXPS) C IF(M8.GT.MXD24.OR.M8.LT.0)THEN IF(M8.GT.MXD24)WRITE(6,605)(M8+1)*MAXGR/MXD24 GO TO 999 ENDIF ENDIF C C *** SLATER INTEGRALS AND (IF BKUTOO) C 2-BODY NON-FINE STRUCTURE INTEGRALS. C CALL SLATRI(ICOUNT,N,KK,MAXPS,DORIG) C IF(KK.GT.MXFSL.OR.KK.LT.0)THEN IF(KK.GT.MXFSL)WRITE(6,252)KK GO TO 999 ENDIF C C *** 2-BODY FINE-STRUCTURE INTEGRALS C IF(NL000.GT.0)THEN C CALL FSINTI(ICOUNT,N,KFS,MAXPS) C IF(KFS.GT.MXFSS.OR.KFS.LT.0)THEN IF(KFS.GT.MXFSS)WRITE(6,253)KFS GO TO 999 ENDIF ENDIF C C--------------------------------------------------------- C IF(BJUMP)GO TO 136 GO TO 46 C C CHECK COMPLETENESS OF RADIAL FUNCTION SET C COMPUTE RELATIVISTIC INTEGRALS (MASS AND DARWIN TERM, EJN-EQ.60) C 138 MP=0 ICM=100000 IBM=0 DDY=DYY(NREL) IF(.NOT.BJUMP)DDY=DDY/DTWO !A.U. C DO K=1,MAXGR C IF(DEY(K).EQ.DZERO)GO TO 52 MP=K IF(IYY(K).GT.0.AND.K.LT.ICM)ICM=K IF(IVAL(K).EQ.0.AND.QN(K).GT.0.AND.IBM.LT.K)IBM=K C IF(DSIGMA(K).GT.999)THEN WRITE(6,980)K DEY(K)=DZERO NF=-1 GO TO 52 ELSEIF(DSIGMA(K).EQ.999)THEN WRITE(6,970)K ENDIF C IF(NJO.LE.0.AND..NOT.BMVD.or.qn(k).gt.0)GO TO 52 C DORIG(K)=ORIG(K)*DZ IF((MAUTO.EQ.0.OR.BORT).AND..NOT.BREL)GO TO 75 C DX1=DZERO IF(IYY(K).LT.0)DX1=DEY(K)-DUY(K,K) IF(IYY(K).GT.0)DX1=DDY+DSHIFT(K) !A.U. C DO L=1,K C IF(DEY(L).EQ.DZERO)GO TO 613 IF(QL(K).NE.QL(L))GO TO 613 M=IVAL(L)+IVAL(K) IF(BJUMP.AND.M.EQ.0)GO TO 613 C DD3=DZERO DD2=DZERO DD1=DZERO IF(BJUMPR.OR.BREL.AND.NL.LE.NL000)GO TO 614 C .AND.L.EQ.K .OR.BREL2 IMT=0 C IF(QN(K).LT.0)IMT=IMT+1 C IF(QN(L).LT.0)IMT=IMT+1 IF(IYY(K).GT.0)IMT=IMT+1 IF(IYY(L).GT.0)IMT=IMT+1 IF(MODE.LE.2.AND.IMT.Ge.1)GO TO 614 C J=QL(L)/2+1 IF(J.GT.MXPOT)J=MXPOT DX2=DZERO IF(IYY(L).LT.0)DX2=DEY(L)-DUY(L,L) IF(IYY(L).GT.0)DX2=DDY+DSHIFT(L) C DO I=1,MAXPS DA(I)=DPNL(I,L)*POT(I,J)*DPNL(I,K) ENDDO IF(BREL2)THEN DO I=1,MAXPS DA(I)=DA(I)+DQNL(I,K)*POT(I,J)*DQNL(I,L) ENDDO ENDIF IF(.NOT.BREL)THEN DO I=1,MAXPS DERV2(I)=DA(I)*POT(I,J) ENDDO ENDIF C CALL WEDDLE(DD2,DA,DD3,MNE,DHNS,MJH,MAXPS) C IF(.NOT.BREL)THEN !EVALUATE INTEGRAND AT ORIGIN IF(QL(K).EQ.0)DD2=DORIG(K)*DORIG(L) C CALL WEDDLE(DD2,DERV2,DD1,MNE,DHNS,MJH,MAXPS) C DD1=DD1+(DX1+DX2)*DD3 IF(L.EQ.K)DD1=DD1+DX1*DX2 DD2=DD2*DFSC*DFSC/(DZ*DEIGHT) ENDIF C DD1=-DD1*DFSC*DFSC/DTWO IF(L.EQ.K)DD3=DX1+DD3 DCD(K,L)=DD2 C 614 DMASS(K,L)=DD1 C D2LL(K,L) IS USED BY SR.DIPOLE WHICH EVALUATES THE BREIT-PAULI C MODIFICATION OF THE M1 OPERATOR FOR USE BY SR.DIAGFS . D2LL(K,L)=DD3+DD3 C 613 ENDDO C GO TO 52 C C 75 DX1=DZERO IF(MODE.GT.2.AND.IYY(K).GT.0)DX1=(DDY+DSHIFT(K))*DTWO !RYD C DO L=1,K C IF(DEY(L).EQ.DZERO)GO TO 53 IF(QL(K).NE.QL(L))GO TO 53 M=IVAL(K)+IVAL(L) IF(BJUMP.AND.M.EQ.0)GO TO 53 C DP0=DZERO DD=DZERO DM=DZERO C IF(BJUMPR.OR.BREL )GO TO 54 C .AND.L.EQ.K. OR.BREL2 IF(MORT.EQ.-3.AND.BREL)GO TO 54 C IMT=0 C IF(QN(K).LT.0)IMT=IMT+1 C IF(QN(L).LT.0)IMT=IMT+1 IF(IYY(K).GT.0)IMT=IMT+1 IF(IYY(L).GT.0)IMT=IMT+1 IF(MODE.LE.2.AND.IMT.Ge.1)GO TO 54 C DX2=DZERO IF(MODE.GT.2.AND.IYY(L).GT.0)DX2=(DDY+DSHIFT(L))*DTWO !RYD C DO I=1,MAXPS DD3=DTWO*DZ/DX(I) DD2=DPNL(I,L)*(DD3+DX2)+DQNL(I,L) DD1=DPNL(I,K) DA(I)=(DD1*(DD3+DX1)+DQNL(I,K))*DD2 C IF(BREL)DA(I)=DA(I)-DD2*DD2*DPNL(I,K)/DPNL(I,L) ? DERV2(I)=DD1*DD2 IF(QN(K).LT.0.AND.QN(L).LT.0)THEN DD0=DX2*DPNL(I,L)*DPNL(I,K) DA(I)=DA(I)-DX1*DD0 DERV2(I)=DERV2(I)-DD0 ENDIF ENDDO C CALL WEDDLE(DD,DERV2,DP0,MNE,DHNS,MJH,MAXPS) C IF(K.EQ.L)DP0=DP0+DX2 IF(QL(K).EQ.0.AND..NOT.BREL)DD=DORIG(K)*DORIG(L) DD3=DD*DFOUR C CALL WEDDLE(DD3,DA,DM,MNE,DHNS,MJH,MAXPS) C IF(L.EQ.K)DM=DM+DX1*DX2 DM=-DM*DFSC*DFSC/DEIGHT DD=DD*DFSC*DFSC/(DZ*DEIGHT) DCD(K,L)=DD C 54 DMASS(K,L)=DM D2LL(K,L)=DP0 C 53 ENDDO C 52 ENDDO C C IF(BJUMP)GO TO 1000 ctest IF(MORT.EQ.-3)GO TO 126 IF(ICM.GT.IBM)GO TO 21 WRITE(6,601)IBM,ICM GO TO 999 C 21 IF(IVP.LT.ICM)GO TO 125 WRITE(6,602)IVP,ICM GO TO 999 C 125 IF(IBM.LT.IVM)GO TO 126 WRITE(6,603)IBM,IVM GO TO 999 C 126 CONTINUE IF(.NOT.BPRNT0)GO TO 128 IF(II.GT.1.AND.MYN.LT.0 )WRITE(6,400)(DX(I),I=II,MXR) C C IF(MODE.LT.2)THEN WRITE(6,597) GO TO 132 ENDIF IF(BLAG)THEN WRITE(6,594)MAUTO,MODE,ACE,MXFSL,KK WRITE(6,587)MENG,NREL WRITE(6,588)(I,DYY(I),I=1,MENG) GO TO 128 ENDIF C WRITE(6,595)MAUTO,MODE,ACE,MXFSL,KK C C CONVERT FROM RYDBERGS TO ATOMIC UNITS C C ***REMAINS THAT WAY DURING SUBSEQUENT LOOPS! C 128 ACE=ACE/DTWO C DO I=1,MENG DYY(I)=DYY(I)/DTWO ENDDO C C IF(.NOT.BPRNT0)RETURN C C IF(BXTRP)THEN IF(BDR)THEN IF(BLAG)WRITE(6,598) IF(.NOT.BLAG)WRITE(6,597) ELSE DM=NSTORE*NSTORE DDY=DZA*DZA/DM WRITE(6,596)DDY ENDIF ENDIF C DD=ECOR1+ECOR1 DM=ECOR2+ECOR2 DD=DD*DKCM DM=DM*DKCM IF(ECOR1.NE.DZERO.OR.ECOR2.NE.DZERO)WRITE(6,589)DD,DM C C MP IS NOW HIGHEST ORBITAL NUMBER WHICH HAS BEEN CALCULATED C 132 N=MIN0(MYM,MP) IF(N.GT.0)THEN C READ AT 70 READ 590 ALLOWS TO SPECIFY PRINTOUT IF(MYN.LT.0)MYN=-MYN C IF(MYN.LE.N)THEN WRITE(6,990)(I,I=MYN,N) DO L=1,MAXPS WRITE(6,900)L,DX(L),(DPNL(L,I),I=MYN,N) ENDDO ENDIF ENDIF C C 1000 RETURN C 999 NF=-1 GO TO 1000 C C 100 FORMAT(29X,F13.5,30X,A4,I4,I3,I2) 250 FORMAT(/ ' GAM ( N, L,NION, Z, DEL/PI) OLDEPS/RY OF RADIAL IN XPUT-FUNCTIONS',3X, '(ORIGIN N L) FNORM, 3 LAST P, ;ST XPS/PTS=',I4,'/',I4) 252 FORMAT(' *****STORAGE EXCEEDED IN SR.RADCON, INCREASE MXFSL TO ', XI5) 253 FORMAT(' *****STORAGE EXCEEDED IN SR.RADCON, INCREASE MXFSS TO ', XI5) 300 FORMAT('+',I3,I4,I4,I4,I4,F9.5,13X,I4,1X,F11.5,F10.3,17X,F8.3, X 1X,3(1PE9.2),0PF12.4) 400 FORMAT(39X,"READ('') PBAR0 RPEND",15X,"3 LAST R:",3F9.4, X 4X," (H1/2RY)"/) 401 FORMAT(' ****ERROR IN SR.RADCON, CONTINUUM ORBITAL N=',I3 X,' SKIPPED BECAUSE ENERGY DDY .LT. 0.0 =' ,F10.4) 587 FORMAT(' THE',I4,' INPUT CONTINUUM ENERGIES (RYD) ARE AS FOLLOWS' X,' AND THE ENERGY IN POSITION',I4,' WILL BE USED IN H(RC)' X,' PRINT.'/) 588 FORMAT(11(I3,F9.3)) 589 FORMAT(/' ECOR1*CM=',F10.1,5X,'ECOR2*CM=',F10.1) C 591 FORMAT(7F10.4) 594 FORMAT(/' MAUTO=',I3,2X,'MODE=',I2,2X,'ACE=',1PE9.2,' RYD.',2X, X'CONTINUUM FUNCTIONS IN USE; MODES 2 TO 6. INTERPOLATION IS ON, X MXFSL=',I5/100X,'**',6X,'USED=',I5) 595 FORMAT(/' MAUTO=',I3,2X,'MODE=',I2,2X,'ACE=',1PE9.2,' RYD.',2X, X'CONTINUUM FUNCTIONS IN USE; MODES 2 TO 3. INTERPOLATION IS OFF, X MXFSL=',I5/100X,'***',6X,'USED=',I5) 596 FORMAT(/' N.B. THE' X , ' NL VALENCE ORBITALS HAVE BEEN APPROXIMATED BY A K=0 ', X 'CONTINUUM ORBITAL AND SO THE'/ ' INTERPOLATION ENERGIES HAVE B XEEN',' SHIFTED BY (Z-NION+1)**2/N**2 =',F6.3,' RYD TO COMPENSATE.' X/65X,'**********'/) 597 FORMAT(/' N.B. THE' X , ' NL VALENCE ORBITALS HAVE BEEN APPROXIMATED BY A K=0 ', X'CONTINUUM ORBITAL.') 598 FORMAT(/' N.B. THE' X , ' NL VALENCE ORBITALS HAVE BEEN APPROXIMATED BY A K=0 ' , X'CONTINUUM ORBITAL AND SO THE'/ ' INTERNAL AUTOIONIZATION ENERGI XES WILL BE SHIFTED TO COMPENSATE.') 601 FORMAT(/' *****ERROR, THE LARGEST BOUND ORBITAL NUMBER USED=',I4 X, ' IS GREATER THAN THE SMALLEST CONTINUUM ORBITAL NUMBER USED=' X,I4) 602 FORMAT(/' *****ERROR, THE LARGEST VALENCE ORBITAL NUMBER USED=',I4 X, ' IS GREATER THAN THE SMALLEST CONTINUUM ORBITAL NUMBER USED=' X,I4) 603 FORMAT(/' *****ERROR, THE LARGEST CORE ORBITAL NUMBER USED=',I4 X, ' IS GREATER THAN THE SMALLEST VALENCE ORBITAL NUMBER USED=' X,I4) 605 FORMAT(/' ***DIMENSION EXCEEDED IN SR.RADCON, INCREASE MAXGR TO:' X,I5) 710 FORMAT( ' REQUIRE INITIAL STEPLENGTH DOUBLED IN SR.RADCON, INCRE XASE MAXB1 OR CHANGE INITIAL STEPLENGTH IN SR.RADIAL ') 773 FORMAT(13X,'NL =',I3,I2,' EXTERNAL POTENTIAL V(NL) FROM UNIT=' X,I3,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=',I5, X') =',F10.6) 774 FORMAT(23X,'NL =',I3,I2, ' S.M.-POTENTIAL V(NL) WITH SCALE FAC XTOR',F10.5,'; COULOMBIC BEYOND R(IEND=',I5,') =',F10.6) 1774 FORMAT(45X,I1,'-POLE POLARIZED SCALE FACTOR' X,F10.5, '; COULOMBIC DEVIATION AT R(IEND) =',F10.6) 775 FORMAT( 2X,'NL =',I3,I2, ' STO.-POTENTIAL CF=',I3, ' WITH SCAL XE FACTOR',F10.5,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R( XIEND=',I5,') =',F10.6) C 781 FORMAT(' ORTHOGONALIZATION CHANGES SIGN OF ORBITAL K= ',I2, C X' VALUES NEAR ORIGIN ARE: '/10(1PE13.4)) C 781 FORMAT('+',57X,'*') 900 FORMAT(I5,(7F18.6)) 960 FORMAT(' OVERLAP INTEGRAL',4X,I3,I2,' WITH',2I2,' =' X,1PE12.4) 970 FORMAT(61X,"P/Q-INPUT FOR ORBITAL K=",I2, " MISSING, S.M. USED - X ORBITALS MAY"/89X,"NOT BE ORTHOGONAL TO INPUT-PNL'S WITH SAME L") 980 FORMAT(61X,'P/Q-INPUT FOR ORBITAL K=',I2, ' MISSING (OR MAXB2 TO XO SMALL), CASE FAILS') 990 FORMAT(/' OPTIONAL PRINTOUT OF I, R(I), AND P(I):'//(20X,6I18)/) 997 FORMAT(' L=',I2,3X,'E=',F10.5,'RYD',3X,'DEL/PI=',1PD14.6/) 998 FORMAT(I5,3E16.7) C END C C ******************* C SUBROUTINE RADCX0 C C----------------------------------------------------------------------- C C SR.RADCX0 READS USER INPUT FOR CONTINUUM ORBITAL GENERATION AND C SETS-UP AN ENERGY MESH ACCORDINGLY. C IT ALSO CALCULATES THE UNIQUE CONTINUUM DISTORTED-WAVE POTENTIAL C USED BY THE CONTINUUM BASIS, TF OR STO, SPECIFIED AS WITH BOUND. C USER INPUT (SCALING PARAMETER ETC) IS VIA ORBITAL NO. MXORB+1, C I.E. THE NEXT POSITION AFTER THE USER DEFINED BOUND ORBITALS. C IF NONE READ FOR SUCH AN ORBITAL, THEN USES DATA ASSOCIATED WITH C THE LAST ORBITAL POSITION FOR WHICH INFO WAS READ. C IT COMBINES ELEMENTS OF SR.RADCN0 AND SR.RADIAL. C C IT CALLS: C SR.TFDAPO C SR.STOPOT C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD04=5*MXENG) !READ/SET-UP BUFFER PARAMETER (MXD06=MXENG*MXENG) C PARAMETER (MXNUK=200) !NO. OF RADIAL POINTS FOR FINITE NUCLEUS PARAMETER (MXNDE=MXENG) !NO. OF CHARACTERISTIC EXCITATION ENERGIES PARAMETER (MULT=MXD04/MXENG) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DSIX=6.0D0) C PARAMETER (DTWELV=12.0D0) PARAMETER (D1PT2=1.2D0) PARAMETER (D1P10=1.D10) PARAMETER (DHALF=0.5D0) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M5=1.0D-5) PARAMETER (DEL=1.D-4) !FOR CONT. INTS PARAMETER (DTOL=0.01D0) PARAMETER (TOLDE0=0.1D0) COLD PARAMETER (DLAM0=1.3D0) !DEFAULT CONT LAMBDA PARAMETER (DEPS=1.D-10) C LOGICAL BSTO,BORT,BJUMP,BJUMP2,BRAD,BREL,BJUMPR,BMVD,BFIX,BTHRSH x ,btmp !,buse,busi C DIMENSION DELTAE(0:MXNDE) DIMENSION IXX(MXD04),IXX0(MXD04),DXX(MXD04),DXX0(MXD04) c dimension btmp(mxeng,mxeng) c common /nrbuse/buse(mxeng),busi(mxeng,mxeng),btmp(mxeng,mxeng) C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TOL,MEND C COMMON /COM3/DDY,DZ,TM COMMON /COM7/DNUK(MXNUK),ZS(10) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZDUM,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 c COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW7/MNDEX(MXD06,2),MRNDX(MXD06),MTRAN,mlim(mxeng,2) COMMON /NRBDW8/DYY0(MXENG),IYY0(MXENG),MENG0 COMMON /NRBDW9/DSPECJ(MAXLV),INDXJ(MAXLV),JNDXJ(MAXLV),NSPECJ X ,NENERJ COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/FR(MAXB1),DERV1(MAXB1),DERV2(MAXB1),BP(MAXB1) COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD C C THE FULL NAMELIST-ING FROM SR.RADCN0 IS USED, FOR COMPATIBILITY C BUT THE ONLY VARIABLES USED/SPECIFIABLE ARE: C C MENG, EMIN, EMAX - SCATTERED ENERGY DEFINITION, AS "USUAL" C NDE, DEMIN, DEMAX - EXCITATION ENERGY DEFINITION, C FORMAT SPEC. AS FOR SCATTERED ENERGY C MENGI, EMINI, EMAXI - INTERPOLATION ENERGY DEFINITION C MENGI.GT.0 FORMAT SPEC. AS FOR SCATTERED ENERGY C MENGI.LT.0 INSERT -MENGI POINTS BETWEEN SCATTERED C DELTAX - MAX EXCITATION ENERGY RESTRICTION C (DEFAULT USES HIGHEST TARGET) C NLAG - POINT FORMULA, DEFAULT 2 UNLESS MENGI.LT.0 THEN C 2-MENGI. C N.B. LARGE NOT GOOD IF POINTS WIDELY SPACED C TOLDE RELATIVE DIFFERENCE FOR PRUNING OF CLOSELY SPACED C INTERPOLATION ENERGIES. DEFAULT 0.1 C TEAPOT - IONIZATION POTENTIAL. IF MENG=0 THEN SCATTERING C ENERGIES ARE A FUNCTION OF (INTERNAL) I.P. GIVEN C BY BINDING ENERGY OF OUTER ELECTRON OF GROUND CF, C UNLESS OVERRIDEN BY USER: RYD.GT.0. C NAMELIST/SRADCON/MENG,EMIN,EMAX,NLAG,nskpi !DLAMX x,NDE,DEMIN,DEMAX,MENGI,EMINI,EMAXI,DELTAX,TOLDE,TEAPOT,ilog,tolp X,ECOR1,ECOR2,NREL,ACE,MYN,MYM,MP,ECORLS,ECORIC,PIG,PMIN,MDECP C C C SOME INITIALIZATIONS C PI=ACOS(-DONE) TOL=DONE/10**ITOL DHNSX=DHNS(MJH) BORT=MORT.LT.0 IORT=IABS(MORT) DZ=NZION NZA=NZION-MION NZAP=NZA+1 !FOR TARGET ELECTRON DZAP=NZAP C DZAP2=NZAP*NZAP TOLR=DEL/DZAP DLAMX=-DONE C C ********** ALL INPUT ENERGIES SHOULD BE IN RYDBERGS *********** C BTHRSH=LVMAX.GE.0 NLAG=-1 ilog=0 tolp=-done c TOLDE=-DONE DXX(1)=DZERO if(iabs(modd).gt.1)then !back compatible DELTAX=DSPECE(NSPECE) else !but strictly DELTAX=DSPECJ(NSPECJ) endif DELTAX=DELTAX+DELTAX*DEPS !SO AS NOT TO FLAG ZERO*USE OF INTERP E C SCATTERED EMIN=0 EMAX=-3*DELTAX MENG=0 TEAPOT=-DONE C CHARACTERISTIC DELTAE(0)=DZERO NDE=-999 DEMIN=-1 DEMAX=-2 C INTERPOLATION EMINI=-1 EMAXI=-2 MENGI=-999 nskpi=0 C C READ(5,SRADCON,END=998,ERR=998) ! <---------------- NAMELIST C C IF(BTHRSH)THEN IF(MENG.LT.0.OR.MENG.GT.1)THEN WRITE(6,600) 600 FORMAT(/' ****ERROR IN SR.RADCON, CANNOT READ/USE ADDITIONAL' X,' SCATTERING ENERGIES WITH THRESHOLD PARTIAL COLLISION STRENGTHS' X,' (LVMAX.GE.0)'/ X,' ****RE-SET MENG=0 (DEFAULT) AND ADJUST INPUT ACCORDINGLY') NF=-1 GO TO 999 ENDIF C !DR DEFAULTS IF(NLAG.LT.4.OR.NLAG.GT.10.OR.(-1)**NLAG.LT.0)NLAG=6 IF(NDE.EQ.-999.AND.MENGI.EQ.-999)MENGI=-2*NLAG+2 !AS INSERTS ENDIF C IF(NDE.EQ.-999.AND.MENGI.EQ.-999)NDE=-2 IF(NDE.EQ.-999)NDE=0 IF(MENGI.EQ.-999)MENGI=0 C if(nde.lt.0.and.ilog.eq.0)ilog=1 !log spacing c if(nde.eq.0)tolp=d1p10 if(mengi.ge.0)tolp=dzero if(tolp.lt.dzero)tolp=d1pt2 c IF(NLAG.LT.1)THEN !=1 NO INTERP, USE NEAREST NLAG=2 NLAG=MAX(NLAG,NLAG-MENGI) ELSEIF(NLAG.GT.4.AND..NOT.BTHRSH)THEN WRITE(6,*)'USE OF NLAG=',NLAG WRITE(6,*) X 'IS NOT RECOMMENDED UNLESS ENERGIES ARE CLOSELY SPACED' ENDIF C C SAME SCATTERED ENERGIES ARE USED IN DIAGON AND DIAGFS. C MENG0=MENG IF(MENG0.LT.0)MENG=-MIN0(-NLAG,MENG0,-4) C IF(MENG.GT.MXD04)THEN !.or.mxeng.lt.5 MM=MENG/MULT WRITE(6,250)MM+1 WRITE(0,*)' *** NUMBER OF SCATTERING ENERGIES HAS BEEN REDUCED' WRITE(0,*)' *** INCREASE MXENG TO RETAIN ALL' MENG=MXD04 ENDIF C IF(MENG0.LT.0)THEN C IF(EMAX.LT.EMIN)THEN !WAS NOT READ IN NAMELIST READ(5,*,END=22,ERR=22)EMIN0,EMAX0 EMIN=EMIN0 EMAX=EMAX0 ENDIF IF(EMAX.GT.EMIN.AND.EMIN.LT.DZERO)EMIN=DZERO C 22 IF(NF.LE.0)GO TO 999 C C C SET-UP SCATTERED ENERGIES INTERNALY. C IF(EMAX.LT.EMIN)THEN T=EMAX EMAX=EMIN EMIN=T ENDIF c write(6,*)'emin, emax=', emin,emax c IF((EMAX-EMIN).LT.D1M5)THEN WRITE(6,604)EMIN,EMAX WRITE(0,*)'****ERROR IN SR.RADCX0, UNSUITABLE ENERGY RANGE' NF=-1 GO TO 999 ENDIF C IF(MENG.LE.1)THEN !CASE MXENG=1 WRITE(6,605)-MENG,MXENG WRITE(0,*)'****ERROR IN SR.RADCON, REQUIRE AT LEAST TWO ', X 'SCATTERED ENERGIES TO DEFINE RANGE, CASE MENG.LT.0' NF=-1 GO TO 999 ENDIF C DD=MENG-1 EMAX=EMAX+DONE EMIN=EMIN+DONE T0=EMAX/EMIN DO M=1,MENG DM=M-1 T=T0**(DM/DD) DXX0(M)=EMIN*T-DONE ENDDO C MENG0=MENG C ELSEIF(MENG0.GT.0)THEN C C C READ USER SUPPLIED SCATTERED ENERGIES (RYD) C READ(5,*)(DXX0(I),I=1,MENG0) C IF(NF.LE.0)GO TO 999 C IF(BTHRSH)THEN !ONLY HERE IF MENG0=1 IF(DXX0(1).NE.DZERO)THEN !ALLOW USER TO SET ZERO WRITE(0,*)'***RE-SETTING INPUT SCATTERING ENERGY TO ZERO...' DXX0(1)=DZERO ENDIF ENDIF C C RE-ORDER INTO ASCENDING ENERGIES (NOW NECESSARY) C DO I=2,MENG0 IM=I-1 IF(DXX0(I).GT.DXX0(IM))GO TO 200 T=DXX0(I) DXX0(I)=DXX0(IM) DXX0(IM)=T C DO J=2,IM JM=I-J JJ=JM+1 IF(DXX0(JJ).GT.DXX0(JM))GO TO 200 T=DXX0(JJ) DXX0(JJ)=DXX0(JM) DXX0(JM)=T ENDDO C 200 ENDDO C ELSEIF(BTHRSH)THEN !MENG=0 MENG=1 DXX0(1)=DZERO MENG0=MENG ELSE C C SET DEFAULT SCATTERED ENERGIES AS A FUNCTION OF I.P. C IF(TEAPOT.LE.DZERO)THEN I=INDEX(1) IC=NFK(I) DO IB=MXORB,1,-1 IF(NEL(IB,IC).GT.0)GO TO 27 ENDDO C STOP 'SR.RADCX0: SHOULD NEVER GET HERE' 27 TEAPOT=DUY(IB,IB)-DEY(IB) TEAPOT=TEAPOT+TEAPOT ENDIF DEX=MAX(TEAPOT,DELTAX) MENG=4 DXX0(1)=DZERO DXX0(2)=DEX/3 DXX0(3)=DEX DXX0(4)=DEX*3 IF(MAXLT.GT.35)THEN MENG=MENG+1 DXX0(5)=DEX*8 ENDIF MENG0=MENG C ENDIF C IF(NZA.EQ.0.AND.DXX0(1).LT.D1M2)THEN WRITE(6,555) DO M=1,MENG0 IF(DXX0(M).LT.D1M2)THEN DXX0(M)=D1M2 ELSE GO TO 28 ENDIF ENDDO ENDIF C C WRITE SCATTERED ENERGIES C 28 WRITE(6,587)MENG0 WRITE(6,588)(I,DXX0(I),I=1,MENG0) C C----------------------------------------------------------------------- C C SET-UP CHARACTERISTIC EXCITATION ENERGIES DELTAE(I), I=0,NDE C (COULD ALSO ATTEMPT TO SET FROM ACTUAL DSPECE VALUES...) C C ***CURRENTLY, NO INTERPOLATION OF SCATTERED ENERGIES AND SO *MUST* C HAVE DELTAE(0)=0 TO ENSURE INPUT SCATTERED ENERGIES ARE USED C AS INTERPOLATION ENERGIES AS WELL.*** C IF(IABS(NDE).GT.MXNDE)THEN WRITE(6,*)'***SR.RADCX0: INCREASE INTERNAL DIMENSION MXNDE TO' X ,NDE WRITE(0,*)'***SR.RADCX0: INCREASE INTERNAL DIMENSION MXNDE' NF=-1 GO TO 999 ENDIF C IF(NDE.LT.0)THEN !USE A RANGE OF DELTAE C IF(DEMAX.LT.DEMIN)THEN !WAS NOT READ IN NAMELIST DEMIN=DZERO DEMAX=DELTAX C READ(5,*,END=23,ERR=23)DEMIN0,DEMAX0 !ALLOW ONLY NAMELIST C IF(DEMIN0.GE.DZERO)DEMIN=DEMIN0 !TO AVOID CONFUSION C IF(DEMAX0.GT.DEMIN)DEMAX=DEMAX0 ELSE IF(DEMIN.LT.DZERO)DEMIN=DZERO ENDIF C C 23 CONTINUE NDE0=-NDE NDE=0 C IF(DEMIN.GT.DZERO)NDE=-1 !DROP ORIGINAL POINTS, NOT ALLOWED YET C if(ilog.gt.0)then dd=nde0 e2=done e0=done e1=DELTAX+e2 t0=e1/e0 DO I=1,NDE0 di=i t=t0**(di/dd) t=e0*t-e2 IF(T.GE.DEMIN)THEN NDE=NDE+1 DELTAE(NDE)=T IF(T.GT.DEMAX)GO TO 23 ENDIF ENDDO 23 DELTAX=DELTAE(NDE) else DE=DELTAX/NDE0 DO I=1,NDE0 T=DELTAE(I-1)+DE IF(T.GE.DEMIN)THEN NDE=NDE+1 DELTAE(NDE)=T IF(T.GT.DEMAX)GO TO 24 ENDIF ENDDO 24 DELTAX=DELTAE(NDE) endif C ELSEIF(NDE.GT.0)THEN C READ(5,*)(DELTAE(I),I=1,NDE) DELTAX=DZERO DO I=1,NDE !CASE OUT OF ORDER DELTAX=MAX(DELTAX,DELTAE(I)) ENDDO C ENDIF C C WRITE CHARACTERISTIC EXCITATION ENERGIES C IF(NDE.NE.0)THEN WRITE(6,585)NDE+1 WRITE(6,588)(I,DELTAE(I),I=0,NDE) ENDIF C C----------------------------------------------------------------------- C C READ ANY USER SUPPLIED INTERPOLATION ENERGY SET-UP C (MENGI,EMINI,EMAXI,DXXI->DXX) C C C SAME INTERPOLATION ENERGIES ARE USED IN DIAGON AND DIAGFS. C MENGI0=MENGI IF(MENGI0.LT.0)MENGI=-MENGI0 C IF(MENGI+MENG.GT.MXD04)THEN MM=(MENGI+MENG)/MULT WRITE(6,251)MM+1 WRITE(0,*)'*** TOO MANY INTERPOLATION ENERGIES, INCREASE MXENG' NF=-1 GO TO 999 ENDIF C C SET-UP INTERPOLATION ENERGIES INTERNALY BY INSERTING -MENGI POINTS C BETWEEN EXISTING SCATTERING ENERGY POINTS, LIN OR LOG SPACED. C IF(MENGI0.LT.0)THEN C IF(EMAXI.LT.EMINI)THEN !WAS NOT READ IN NAMELIST EMINI=DZERO EMAXI=DXX0(MENG0)+DELTAX C READ(5,*,END=21,ERR=21)EMIN0,EMAX0 !ALLOW ONLY NAMELIST C IF(EMIN0.GE.DZERO)EMINI=EMIN0 !TO AVOID CONFUSION C IF(EMAXI.GT.EMINI)EMAXI=EMAX0 ENDIF IF(EMAXI.GT.EMINI.AND.EMINI.LT.DZERO)EMINI=DZERO C C 21 CONTINUE IF(NF.LE.0)GO TO 999 C IF(EMAXI.LT.EMINI)THEN T=EMAXI EMAXI=EMINI EMINI=T ENDIF c write(0,*)'emini, emaxi=', emini,emaxi c IF((EMAXI-EMINI).LT.D1M5)THEN WRITE(6,606)EMINI,EMAXI WRITE(0,*)'****ERROR IN SR.RADCX0, UNSUITABLE ENERGY RANGE' NF=-1 GO TO 999 ENDIF C IF(MENG0.LT.MXD04.and.nde.eq.0)THEN MP=0 DXX0(MENG0+1)=DXX0(MENG0)+DELTAX ELSE MP=1 ENDIF C DD=MENGI+1 IM=0 C if(ilog.gt.0)then !log spacing of inserted points DO M=1,MENG0-MP IF(DXX0(M).GE.EMINI.AND.DXX0(M+1).LE.EMAXI .AND. X DXX0(M+1)-DXX0(M).LT.TOLP*DELTAX)THEN e0=DXX0(M)+done e1=DXX0(M+1)+done t0=e1/e0 DO I=1,MENGI IM=IM+1 IF(IM.LE.MXD04)THEN di=i t=t0**(di/dd) DXX(IM)=e0*t-done C write(0,*)im,dxx(im),dxx0(m),dxx(im)-dxx0(m) ENDIF ENDDO ENDIF ENDDO else !linear spacing of inserted points DO M=1,MENG0-MP IF(DXX0(M).GE.EMINI.AND.DXX0(M+1).LE.EMAXI .AND. X DXX0(M+1)-DXX0(M).LT.TOLP*DELTAX)THEN DE=(DXX0(M+1)-DXX0(M))/DD DO I=1,MENGI IM=IM+1 IF(IM.LE.MXD04)DXX(IM)=DXX0(M)+I*DE ENDDO ENDIF ENDDO endif C IF(MP.EQ.0)THEN IM=IM+1 IF(IM.LE.MXD04)DXX(IM)=DXX0(MENG0+1) ENDIF C IF(IM.GT.MXD04)THEN MM=IM/MULT WRITE(6,251)MM+1 WRITE(0,*)'***TOO MANY INTERPOLATION ENERGIES, INCREASE MXENG' NF=-1 GO TO 999 ENDIF C MENGI=IM C ELSEIF(MENGI.GT.0)THEN C C READ USER SUPPLIED INTERPOLATION ENERGIES (RYD) C READ(5,*)(DXX(I),I=1,MENGI) C IF(NF.LE.0)GO TO 999 IF(MENGI.EQ.1)GO TO 203 C C RE-ORDER INTO ASCENDING ENERGIES (NOT NECESSARY, BUT LESS CONFUSING) C DO I=2,MENGI IM=I-1 IF(DXX(I).GT.DXX(IM))GO TO 202 T=DXX(I) DXX(I)=DXX(IM) DXX(IM)=T C DO J=2,IM JM=I-J JJ=JM+1 IF(DXX(JJ).GT.DXX(JM))GO TO 202 T=DXX(JJ) DXX(JJ)=DXX(JM) DXX(JM)=T ENDDO C 202 ENDDO C ELSEIF(NDE.EQ.0)THEN C DXX(1)=DXX0(MENG0)+DELTAX MENGI=1 C ENDIF C IF(MENGI0.GT.0.and.nde.eq.0)THEN IF(DXX(MENGI).LT.(0.9D0*DXX0(MENG0)+DELTAX))THEN WRITE(6,500)DXX(MENGI),DXX0(MENG0)+DELTAX WRITE(0,*) X'*** MAX INTERPOLATION ENERGY TOO SMALL FOR MAX SCATTERED ENERGY' ENDIF ENDIF C 203 IF(NZA.EQ.0.AND.DXX(1).LT.D1M2)THEN WRITE(6,556) DO M=1,MENG0 IF(DXX(M).LT.D1M2)THEN DXX(M)=D1M2 ELSE GO TO 204 ENDIF ENDDO ENDIF C C----------------------------------------------------------------------- C C NOW SET-UP COMPLETE BASIS OF INTERPOLATION ENERGIES C (ADD-IN ORIGINAL MENG0 POINTS PLUS ANY DUE TO NDE.) C C----------------------------------------------------------------------- C 204 MENG=(NDE+1)*MENG0+MENGI !MAX POSSIBLE C MX=MIN(MENG,MXD04) DO M=1,MX IXX(M)=0 ENDDO C MENG=MENGI DO M=1,MENG0 C IF(DELTAE(0).EQ.DZERO)THEN MENG=MENG+1 IF(MENG.LE.MXD04)THEN IXX(MENG)=M IXX0(M)=MENG DXX(MENG)=DXX0(M) ENDIF ELSE !POSS. FUTURE DEVELOP. IXX0(M)=0 ENDIF C IF(M.LT.MENG0)THEN T1=DXX0(M+1) ELSE T1=DXX0(M)+TOLP*DELTAX+D1M5 ENDIF C IF(T1-DXX0(M).GE.TOLP*DELTAX)THEN DO N=1,NDE MENG=MENG+1 IF(MENG.LE.MXD04)DXX(MENG)=DXX0(M)+DELTAE(N) ENDDO ENDIF C ENDDO C IF(MENG.GT.MXD04)THEN MM=MENG/MULT WRITE(6,253)MM+1 NF=-1 GO TO 999 ENDIF C C RE-ORDER INTO ASCENDING ENERGIES C DO I=2,MENG IM=I-1 IF(DXX(I).GT.DXX(IM))GO TO 205 T=DXX(I) DXX(I)=DXX(IM) DXX(IM)=T M=IXX(I) IXX(I)=IXX(IM) IXX(IM)=M C DO J=2,IM JM=I-J JJ=JM+1 IF(DXX(JJ).GT.DXX(JM))GO TO 205 T=DXX(JJ) DXX(JJ)=DXX(JM) DXX(JM)=T M=IXX(JJ) IXX(JJ)=IXX(JM) IXX(JM)=M ENDDO C 205 ENDDO C C PRUNE CLOSELY ADJACENT ENERGIES (BUT DO NOT DROP ANY ORIGINAL POINTS, C NOR THE LAST, UNLESS ACCIDENTLY DEGENERATE, AND RETAIN ENOUGH FOR C INTERPOLATION AT HIGH-E - SEE TDE) C IF(TOLDE.LT.DZERO)THEN TOLDE=TOLDE0 IF(NDE.NE.0.OR.MENGI0.LT.0)TOLDE=TOLDE/2 ENDIF TDE=0.95D0*DELTAX C MX=MENG IF(IXX(MX).EQ.0)IXX(MX)=999 C I=2 DO IX=2,MX T=ABS(DXX(I)-DXX(I-1)) IF(T.LE.TOLDE*DXX(I).AND.T.LT.TDE)THEN IP=0 IF(IXX(I).EQ.0)THEN IP=I+1 ELSEIF(IXX(I-1).EQ.0)THEN IP=I ELSEIF(T.LE.D1M5*DXX(I))THEN IP=I ENDIF IF(IP.GT.0)THEN DO J=IP,MENG DXX(J-1)=DXX(J) IXX(J-1)=IXX(J) ENDDO MENG=MENG-1 I=I-1 ENDIF ENDIF I=I+1 if(i.ge.meng)go to 17 !we are done, bail out ENDDO C 17 IF(IXX(MENG).EQ.999)IXX(MENG)=0 C DO M=1,MENG M0=IXX(M) IF(M0.GT.0)IXX0(M0)=M ENDDO C C TRANSFER (REDUCED SET) TO COMMON VARIABLES C IF(MENG.GT.MXENG)THEN WRITE(6,252)MENG NF=-1 GO TO 999 ENDIF C DO M=1,MENG IYY0(M)=IXX0(M) DYY0(M)=DXX0(M) DYY(M)=DXX(M) ENDDO C C WRITE INTERPOLATION ENERGIES (RYD) C WRITE(6,586)MENG WRITE(6,588)(I,DYY(I),I=1,MENG) C C WRITE MAPPING OF SCATTERED TO INTERPOLATION C WRITE(6,584)(M0,IYY0(M0),M0=1,MENG0) C C WRITE LAGRANGE INTERPOLATION INFO C WRITE(6,589)NLAG C C----------------------------------------------------------------------- C C SET-UP A MAPPING OF MTRAN INTERACTING ENERGY PAIRS: C MNDEX(M,MT) GIVES ENERGY PAIRS (M=1,2) FOR MT=1,MTRAN. C FORMALLY, |E1-E2|.GT.DELTAE DO NOT CONTRIBUTE. C FOR INTERPOLATION, WE GO NLAG/2 POINTS FURTHER. C (WILL NOT CATCH USER DELTAX << NEEDED.) C WE MUST ALSO CATCH THE REVERSE CASE BECAUSSE OF USE C OF FALLING ORDER ON TWO-BODY INTEGRALS. C IF(DELTAX.LT.0.9D0*DSPECE(NSPECE))THEN WRITE(6,580)DELTAX,DSPECE(NSPECE) WRITE(0,*) X'***LARGEST FLAGGED EXCITATION ENERGY LESS THAN MAX TARGET ENERGY' WRITE(0,*)'***COLLISION INTEGRALS ARE BEING EXTRAPOLATED!' ENDIF C do m2=1,meng do m1=1,meng btmp(m1,m2)=.false. enddo enddo C C FIRST PASS SETS PAIRS, BUT MAY NOT CATCH REVERSE ENERGY MATCH C c write(6,*)deltax TE=DELTAX+DEPS NLAG2=(NLAG+1)/2 C DO M0=1,MENG0 M2=IYY0(M0) DO M1=M2,MENG IF(DYY(M1)-DYY(M2).GT.TE)THEN LP=M1 GO TO 210 ENDIF ENDDO LP=MENG 210 CONTINUE LM0=MAX(1,M2-NLAG2+1) LP0=MIN(MENG,LP+NLAG2-1) !-NLAG2+1 -> +NLAG2-1 DO M1=LM0,LP0 btmp(m1,m2)=.true. ENDDO ENDDO c c so, if one pair is required, flag the reverse pair as well c do m0=1,meng0 m2=iyy0(m0) do m1=1,meng btmp(m2,m1)=btmp(m1,m2) enddo enddo c c Allow user to flag removal, e.g. from a test-run - see sr.dwx, fn.xint c to uncomment such log info. Be wary if reverse not flagged, maybe need c by falling order reverse integral. c do n=1,nskpi read(5,*)m1,m2 btmp(m1,m2)=.false. enddo c c now we can index c MTRAN=0 do m2=1,meng ml=0 mu=0 do m1=1,meng if(btmp(m1,m2))then MTRAN=MTRAN+1 MNDEX(MTRAN,1)=M1 MNDEX(MTRAN,2)=M2 c write(6,*)mtran,m1,m2,dyy(m1),dyy(m2) mu=m1 else if(mu.eq.0)ml=m1 endif enddo if(ixx(m2).gt.0)then !a scattering energy mlim(m2,1)=ml+1 mlim(m2,2)=mu c write(6,*)m2,ml+1,mu if(mu-ml.lt.nlag)then write(6,597)deltax write(0,*)'Not enough interpolation integral energies' x ,' - check deltax not set too small?' nf=-1 go to 999 endif else !shouldn't be necessary mlim(m2,1)=0 mlim(m2,2)=-1 endif enddo C WRITE(6,582)MTRAN C C SET-UP REVERSE MAPPING INDEX (COULD DO BETTER) C DO M=1,MTRAN M1=MNDEX(M,1) M2=MNDEX(M,2) IF(M1.NE.M2)THEN DO MM=1,MTRAN IF(M1.EQ.MNDEX(MM,2).AND.M2.EQ.MNDEX(MM,1))THEN MRNDX(M)=MM GO TO 33 ENDIF ENDDO write(6,*)'***',m,m1,m2 stop 'mtran index error 2' !should not happen ELSE MRNDX(M)=M ENDIF 33 ENDDO C C----------------------------------------------------------------------- C C GENERATE A UNIQUE CONTINUUM DW POTENTIAL FOR THE BASIS C C----------------------------------------------------------------------- C T=SQRT(DYY(MENG)) !FIRST CHECK RADIAL MESH IF(T.NE.DZERO)THEN T=PI/T T=T/DHNSX C IF(T.LT.DTWELV)THEN IF(T.LT.DSIX)THEN M0=MSTEP+1 WRITE(6,1222)DYY(MENG),M0 WRITE(0,*)'RADIAL MESH TOO COARSE' NF=-1 GO TO 999 ENDIF C ENDIF ENDIF C IF(DLAMX.LE.DZERO)THEN !SET DEFAULT CONT LAMBDA IF(NZA.GT.2)THEN DLAMX=1.3D0 ELSE DLAMX=DONE+0.1D0*NZA ENDIF ENDIF C IF(BORT)THEN !FIND SCALING PARAMETER IF(NPARAM.GT.MXORB)THEN IC=MXORB+1 DJ=DADJUS(IC) ELSE DJ=DLAMX !SINCE LAST BOUND MAY NOT BE APPROPRIATE ENDIF ELSE IC=NPARAM DJ=DADJUS(IC) ENDIF if(dj.eq.dzero)dj=dlamx C IF(DJ.GT.0)THEN IF(.NOT.BSTO)MRED=-1 !ADD AN ELECTRON IF(BSTO)MRED=0 !DONE IN STOPOT MYN=MION-MRED !N+1 DS=DZ DJ0=DJ ELSE IF(IORT.LT.0)DS=-DJ*DZ !I.E. NOT USED. USE ASYMPTOTIC CHARGE DS=NZION-MION MYN=1 DJ0=DONE ENDIF C DHNS0=DHNS(1) MK=MXORB+1 QN(MK)=-90 QL(MK)=0 SCREEN(MK)=9999 IVAL(MK)=0 IF(BSTO.AND.MCFMX.GT.0)THEN IF(MCFSTO(MK).EQ.0)MCFSTO(MK)=1 !ASSUME USER LISTS GROUND FIRST MCFMX=MK ENDIF MPP=1 !PLASMA POTENTIAL IF(MDEN.LT.0)MPP=2 C IF(.NOT.BSTO)CALL TFDAPO(DS,MYN,MK,DJ0,DONE,DONE,DHNS0,MAXRS,MJH X ,MNE,DHNS,DX,DPOT,TOL,MEND,DZERO,DZERO) C IF(BSTO)CALL STOPOT(DS,MYN,MK,DJ0,DHNS0,MAXRS,MJH,MNE,DHNS,DX X ,DPOT,DTOL,MEND,MPP) C IF(NF.LE.0)GO TO 999 !RETURN C IF(DHNS(1).NE.DHNS0)THEN WRITE(6,*)'SR.RADCX0: PROBLEM GENERATING N+1 POTENTIAL' WRITE(0,*)'SR.RADCX0: PROBLEM GENERATING N+1 POTENTIAL' NF=-1 GO TO 999 ENDIF C V(X>X(MEND)) COULOMBIC IF(.NOT.BSTO)WRITE(6,774)DJ,MEND,DX(MEND) IF(BSTO)WRITE(6,775)DJ,MEND,DX(MEND) JEND(MK)=MEND C C NOW LOOK TO REDUCE RADIAL MESH EXTENT FOR SCATTERING INTEGRALS. C THIS IS A BALANCE BETWEEN MEMORY USAGE FOR THE BASIS AND TIME C SPENT RE-GENERATING IT ASYMPTOTICALY. C IF(RZERO.GT.DZERO)THEN DO M=1,MAXRS IF(DX(M).GT.RZERO)GO TO 43 ENDDO M=MAXRS 43 MAXPS=M ELSE MAXPS=0 DO K=1,MXORB IF(DEY(K).NE.DZERO)THEN DO M=1,MAXRS IF(ABS(DPNL(M,K)).GT.TOLR)MAXPS=MAX0(MAXPS,M) ENDDO ENDIF ENDDO ENDIF C MJH0=MJH MAXQS=0 DO I=1,MJH0 MAXQS=MNE(I)+MAXQS MJH=I IF(MAXQS.EQ.MAXPS)GO TO 609 IF(MAXQS.GT.MAXPS)THEN MAXQS=MAXQS-MNE(I) MNE(I)=MAX0(MAXPS-MAXQS,9) MAXQS=MAXQS+MNE(I) GO TO 609 ENDIF ENDDO C 609 WRITE(6,700)MAXRS,DX(MAXRS),MAXQS,DX(MAXQS) MAXRS=MAXQS C C V -> 2(V-Z/R) C DO I=1,MAXRS DPOT(I)=DPOT(I)-DZ/DX(I) DPOT(I)=DPOT(I)+DPOT(I) ENDDO C C INITIALIZE CONTINUUM DW POTENTIAL FOR KAPPA-AVERAGED ORBITALS C (FINITE NUCLEUS INITIALIZED IN SR.RADIAL) C IF(BREL)THEN C CALL DIFF(DPOT,DERV1,MNE,DHNS,MJH) CALL DIFF(DERV1,DERV2,MNE,DHNS,MJH) C T=DZ/RNUK INUKP=INUK+1 IF(INUK.GT.MXNUK)THEN WRITE(6,*)'***SR.RADCX0: INCREASE MXNUK TO AT LEAST:',INUK WRITE(0,*)'***SR.RADCX0: INCREASE MXNUK' GO TO 999 ENDIF IF(INUKE.EQ.0)THEN !UNIFORM DO I=1,INUK DNUK(I)=T*(DTHREE-(DX(I)/RNUK)**2)-DTWO*DZ/DX(I) DERV1(I)=-T*DX(I)/RNUK**2 DERV2(I)=-T/RNUK**2 ENDDO ELSE !U6 T0=T T00=(T0*63)/16 T8=8*RNUK**2 DO I=1,INUK T=DX(I)/RNUK TT=T*T TTT=TT*TT DNUK(I)=T00-T0*(42-(18-7*TT)*TTT)*TT/16-DTWO*DZ/DX(I) DERV1(I)=-T0*(21-(27-14*TT)*TTT)*DX(I)/T8 DERV2(I)=-T0*(21-(135-98*TT)*TTT)/T8 ENDDO ENDIF C DO I=INUKP,MAXRS T=DX(I)**2 DERV1(I)=DHALF*DERV1(I)-DZ/T DERV2(I)=DHALF*DERV2(I)+DTWO*DZ/(T*DX(I)) ENDDO C ELSE !JUST POWER SERIES NEAR ORIGIN C M1=0 DD=DZERO C CALL FIT(DD,M1,DHNS(1),DPOT,ZS) C ENDIF C 999 RETURN C 998 WRITE(6,1997) WRITE(0,*)'*** SR.RADCX0: ERROR READING NAMELIST SRADCON!' !FATAL NF=-1 GO TO 999 C C 250 FORMAT(/' THE NUMBER OF SCATTERED ENERGIES HAS BEEN REDUCED'/ X' INCREASE MXENG TO',I4,' TO RETAIN ALL, CONTINUING...'/) 251 FORMAT(/' TOO MANY INTERPOLATION ENERGIES INCREASE MXENG TO',I4) 252 FORMAT(/' INCREASE MXENG TO',I4,' OR REDUCE NUMBER OF SCATTERING' X,' AND/OR CHARACTERISTIC ENERGIES') 253 FORMAT(/'NOT ENOUGH BUFFER SPACE, INCREASE MXENG TO',I4 X,' OR REDUCE NUMBER OF SCATTERING' X,' AND/OR CHARACTERISTIC ENERGIES') 500 FORMAT(/'*** WARNING: LARGEST USER SUPPLIED INTERPOLATION ENERGY' X,F10.3/'IS LESS THAN LARGEST SCATTERED ENERGY PLUS TARGET ENERGY' X,F10.3/3X, X'TRANSITIONS WITH LARGER EXCITATION ENERGIES WILL BE INACCURATE!') 555 FORMAT(/'*** RE-SETTING SCATTERED ENERGY E=0 TO 0.01 FOR NEUTRALS' X) 556 FORMAT(/'*** RE-SETTING INTERPOLATION ENERGY E=0 TO 0.01 FOR ' X,'NEUTRALS') 580 FORMAT(//'*** WARNING: YOUR LARGEST CHARACTERISTIC EXCITATION ' X,'ENERGY',F10.3,' IS LESS THAN THE MAX TARGET ENERGY',F10.3/4X, X'TRANSITIONS WITH LARGER EXCITATION ENERGIES WILL BE INACCURATE!') 582 FORMAT(/' RESULTANT TOTAL NUMBER OF ENERGY INTEGRAL PAIRS:',I4) 584 FORMAT(//' THE SCATTERED ENERGIES ARE MAPPED TO THE INTERPOLATION' X,' ENERGIES AS FOLLOWS:'/(/15(I5,I3))) 585 FORMAT(//' THE',I4,' CHARACTERISTIC EXCITATION ENERGIES (RYD)' X,' ARE AS FOLLOWS:'/) 586 FORMAT(//' THE',I4,' CONTINUUM INTERPOLATION ENERGIES (RYD)' X,' ARE AS FOLLOWS:'/) 587 FORMAT(//' THE',I4,' INPUT SCATTERED CONTINUUM ENERGIES (RYD)' X,' ARE AS FOLLOWS:'/) 588 FORMAT(11(I3,F9.3)) 589 FORMAT(//' WHERE AN NLAG=',I2 X,'-POINT LAGRANGE INTERPOLATION IS TO BE USED.') 597 format(//'Not enough interpolation integral energies' x ,' - check deltax=',f10.3,' not set too small?') 604 FORMAT(/' ****ERROR IN SR.RADCON, UNSUITABLE ENERGY RANGE FOR ', X'SCATTERING ENERGIES, EMIN=',F10.4,3X,'EMAX=',F10.4/) 605 FORMAT(/'****ERROR IN SR.RADCON, REQUIRE AT LEAST TWO ' X,'SCATTERED ENERGIES TO DEFINE RANGE, CASE MENG.LT.0' X/' BUT MENG=',I3,' AND MXENG=',I3) 606 FORMAT(/' ****ERROR IN SR.RADCON, UNSUITABLE ENERGY RANGE FOR ', X'INTERPOLATION, EMINI=',F10.4,3X,'EMAXI=',F10.4/) 700 FORMAT(/' REDUCING RADIAL EXTENT FROM X(',I5,')=',F8.3,' TO X(' X,I5,')=',F8.3,' FOR',' SCATTERING INTEGRALS'//) 774 FORMAT(///' CONTINUUM S.M.-POTENTIAL WITH SCALE FACTOR' X,F10.5, '; COULOMBIC BEYOND R(IEND=',I5,') =',F10.6) 775 FORMAT(///' CONTINUUM STO.-POTENTIAL WITH SCALE FACTOR' X,F10.5,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=' X,I5,') =',F10.6) 1222 FORMAT(/' SR.RADCX0: EMAX=',1PD8.2,' MESH TOO COARSE, CONTINUUM-', X'CONTINUUM INTEGRALS IN ERROR.'/'*** REDUCE EMAX IN NAMELIST ', X'SRADCON OR INCREASE MSTEP TO',I3,' IN NAMELIST SMINIM') 1997 FORMAT('*** SR.RADCX0: ERROR READING NAMELIST SRADCON!'/4X, X'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES') C END C C ******************* C SUBROUTINE RADIAL(DADJUS) C C----------------------------------------------------------------------- C C SR.RADIAL CALCULATES THOSE RADIAL FUNCTIONS FOR WHICH THE POTENTIAL C V(L) IS TO BE CHANGED SINCE PREVIOUS CALLS, DADJUS(J).NE.DAJOLD(J) C J=L+1; FOR FUNCTIONS NOT NEEDED DEY(K) HAS BEEN INITIALIZED AS 0.; C NK,LK=QN(K),QL(K)/2, NORMALLY (ALGEB1) K=1,2,3.. FOR NL=1S,2S,2P.. C ALTERNATE STO POTENTIAL AND/OR V(NL). C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C c PARAMETER (MXD01=14) PARAMETER (MXD12=100) PARAMETER (MXD14=100) PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C PARAMETER (MAXA=MAXB1) PARAMETER (MXQIN=MAXB2) PARAMETER (MJH0=10) !SEE DATA STATEMENT BELOW C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DTHIRD=DONE/DTHREE) PARAMETER (DHALF=0.5D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DEL=1.D-6) PARAMETER (TINORB=1.D-3) !R-MATRIX RZERO CRITERION PARAMETER (DTOL=0.01D0) PARAMETER (DKEY=999.D0) PARAMETER (D1PT05=1.05D0) PARAMETER (D2PT5=2.5D0) PARAMETER (D1P10=1.0D10) c PARAMETER (C1=2.2677D-5) !GRASP c PARAMETER (C2=DZERO) !GRASP PARAMETER (C1=2.04D-5) PARAMETER (C2=1.40D-5) PARAMETER (C3=1.293D0) !U6 TK0 PARAMETER (C4=0.2D0) !SKIN PARAMETER (D99=99.0D0) PARAMETER (D999=999.0D0) PARAMETER (D5999=5999.0D0) PARAMETER (DLAM0=1.D-10) !DADJUS=DAJOLD PARAMETER (TOLPP=1.D-5) C CHARACTER(LEN=3) LAB1,LAB2 CHARACTER(LEN=4) TLBL,CODE CHARACTER(LEN=12) LABB C LOGICAL HFF,BLAG,BSTO,BORT,BPRNT0,BJUMP,BDR,BBC2,BHF,BREL,BJUMPR X ,BJUMP2,BRAD,BMVD,BREL2,BPRINT,BPRNT3,BMPP,bnorm,HFF0,BFIX C DIMENSION DADJUS(MXVAR),MNH(MJH0),deold(maxgr) C COMMON /BASIC/NF,KV,HFF,MGAP(9) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DPOT(MAXB1),TOL,MEND COMMON /COM6/DA(MAXB1) COMMON /COMIKE/DP0,DQ0,rnorm0 COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXQS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JN(MAXLV),NGR(MAXLV) COMMON /NXRNL/NL000,NL COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBAL3/MCFSS,KCFSS(MAXCF),KUTSS,NTJ(MAXCF),NFJ(MAXLV) X ,KUTSO COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZDUM,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) c COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBFR/DP(MAXB1) COMMON /NRBFSI/DNLI(MXENG,MXFSS),NLI(MAXMI) COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBHF/MHF,MRAD,MSTEP !,xmax0 COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBQED/VPINT(MAXGR),SLFINT(MAXGR),QED COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBRAD/IRAD(MAXGR) COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBSPL/DPT0(MAXB1),DERV1(MAXB1),DERV2(MAXB1),DPT3(MAXB1) COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) c common /nrbinf/rinf2(maxgr) c save xmax C DATA MRWR/13/,HFF0/.FALSE./ C C SET UP THE INTERVALS FOR THE RADIAL FUNCTIONS C NOTE: ANY VALUE MNH(J).LT.9 STEPS PER INTERVAL J WILL CAUSE TROUBLE; C SO WILL A NUMBER MJH0.LT.2 OF INTERVALS; MJH0.LE.DIM(MNH,MNE,DHNS) C SR.TFDAPO REQUIRES LAST INTERVAL TO HAVE AT LEAST TWICE AS MANY C POINTS AS THE PENULTIMATE. C C DATA C X MNH(1),MNH(2),MNH(3),MNH(4),MNH(5) /32,32,64,64,64/, !MJH0/10/ C X MNH(6),MNH(7),MNH(8),MNH(9),MNH(10)/64,64,64,256,9296/ DATA X MNH(1),MNH(2),MNH(3),MNH(4),MNH(5) /16,16,32,32,32/, !MJH0/10/ X MNH(6),MNH(7),MNH(8),MNH(9),MNH(10)/32,32,32,512,9264/ C X MNH(1),MNH(2),MNH(3),MNH(4),MNH(5),MNH(6)/16,16,32,32,32,32/, C X MNH(7),MNH(8),MNH(9),MNH(10),MNH(11)/32,32,64,128,9616/ !/11/ C IF(MJH0.GT.20)THEN WRITE(6,*)'SR.RADIAL: INCREASE NO OF INTERVALS TO',MJH0 WRITE(0,*)'SR.RADIAL: INCREASE NO OF INTERVALS' GO TO 999 !RETURN ENDIF C C THE RADIAL FUNCTIONS WILL BE CALCULATED UNTIL THE RELATIVE CHANGE C IN THE EIGENVALUE IS SMALLER THAN TOL C TOL=DONE/10**ITOL C IF(MDEN.NE.0)THEN C C MIGHT BE FASTER TO USE OLD DENSITY FUNCTIONS? C SO COMMENT-OUT MP0 BELOW..... MP0=0 C C MAX NO OF ITERATIONS OF RADIAL FUNCTIONS FOR SELF-CONSISTENT SOLUTION C SUBJECT TO ALL EPSILONS CONVERGING TO TOLPP (THEN BMPP=.FALSE.) C MPP5=5 IF(MDEN.LT.-1)MPP5=-MDEN MPP=1 IF(BJUMP)MPP=2 BMPP=.FALSE. do i=1,mxorb deold(i)=dzero c rinf2(i)=d1p10 enddo ELSE MPP=0 ENDIF C IF(MAXB2.LT.MAXB1)THEN WRITE(6,*)'***SR.RADIAL ERROR: INCREASE MAXB2 TO MAXB1',MAXB2 X ,MAXB1 WRITE(0,*)'***SR.RADIAL ERROR: INCREASE MAXB2 TO MAXB1' GO TO 999 !RETURN ENDIF C IF(MORT.LE.-4.AND.IUNIT(16).EQ.0)THEN !BOX/LPS IUNIT(16)=1 OPEN(16,FILE='OVRLAP',STATUS='REPLACE') !ORBITAL OVERLAP LIST ENDIF C BDR=IDR.NE.0 C DZ=NZION BREL2=IABS(IREL).EQ.2 C JPOT=-1 LOLD=-1 EOLD=DZERO NZA=MAX(1,NZION-MION+1) TOLR=DEL/NZA BORT=MORT.LT.0 IORT=IABS(MORT) IF(IORT.EQ.5)TOLR=TINORB !RZERO BHF=MHF.GT.0 IF(HFF)HFF0=.TRUE. BPRNT0=BPRINT IF(BPRINT)BPRNT0=JPRINT.NE.-3 BPRNT3=JPRINT.NE.-3 C C PRINT DETAILS OF RELATIVISTIC RADIAL OPERATORS C INUK=0 INUKP=1 IF(BREL.AND.NF.GT.0)THEN IF(BPRNT0)THEN LAB1='OFF' IF(ABS(IREL).EQ.2)LAB1=' ON' LAB2='OFF' IF(IRTARD.NE.0)LAB2=' ON' WRITE(6,880)LAB1,IREL,LAB2,IRTARD LABB=' ' IF(IBREIT.LT.0)LABB='GENERALIZED+' IF(IBREIT.GT.0)LABB='GENERALIZED ' WRITE(6,879)-KUTSO,KUTSS,KUTOO,LABB,IBREIT,QED ENDIF C C SET-UP FINITE NUCLEUS C IF(RNUK.LE.DZERO)THEN IF(ATM.LE.DZERO)ATM=D2PT5*DZ A=ATM**DTHIRD RNUK=A*C1+C2 IF(INUKE.GT.0)THEN IF(TK0.LE.DZERO)TK0=C3 RNUK=RNUK*TK0 ELSE TK0=DONE ENDIF ENDIF IF(SKIN.LT.DZERO)SKIN=C4*RNUK INUK0=MAX(2,INUK0) IF(BPRNT0.AND..NOT.BJUMP)THEN IF(INUKE.LT.0)WRITE(6,751)INUKE IF(INUKE.EQ.0)WRITE(6,752)INUKE,RNUK,ATM,SKIN IF(INUKE.GT.0)WRITE(6,753)INUKE,RNUK/ABS(TK0),ATM,TK0 ENDIF ENDIF C IF(.NOT.BJUMP)THEN MSHFT=10000 TSHFT=4*MSHFT ACE=D1P10 MENG=1 NREL=1 BLAG=.FALSE. IVLSUM=0 DO I=1,MAXGR IVLSUM=IVLSUM+IVAL(I) IRAD(I)=0 DSHIFT(I)=DZERO MI=QN(I) QN(I)=IABS(MI) IYY(I)=-1 C DORIG(I)=DONE ENDDO DO I=1,MAXRL NRLI(I)=0 ENDDO IF(NL000.GT.0)THEN DO I=1,MAXMI NLI(I)=0 ENDDO ENDIF IF(IRLX.EQ.2)THEN II=(MXORB*(MXORB-1))/2 DO I=1,II OVLPGR(I)=DZERO ENDDO II=(KMAX*(KMAX-1))/2 DO I=1,II OVLPCF(I)=DZERO ENDDO ENDIF c c Estimate how far out the radial mesh should extend. c This is for efficiency as the maximum allowed by dimensions can be c very large, unnecessarily so in many cases. c bnorm=.false. !silence stupid compilers lm=0 nm=1 do m=1,mxorb if(dey(m).ne.dzero)then if(bdr)then if(ival(m).ne.0)lm=ql(m) else if(abs(qn(m)).lt.80)then c lm=min(lm,ql(m)) nm=max(nm,mod(qn(m),70)) endif endif endif enddo lm=lm/2 if(bdr)then nout=nmax if(jnd.gt.0)nout=ndr(jnd) nout=min(nout,nsw) else nout=nm endif tl=min(lm,nout-1) xout=nout xout=xout*xout dza=nza e=-dza*dza/xout xout=2*xout/nza xmax=1.4d0*xout 10 xmax=1.1d0*xmax pmax=whitex(xmax,tl,e,dza,bnorm) if(.not.bnorm)then pmax=dzero xmax=1.d10 c stop'radial/whitex/norm' endif if(abs(pmax).gt.tolr/10)go to 10 xmax=max(xmax,rzero) c write(0,*)xout,xmax,pmax,nout c c if(mden.lt.-1)xmax=1.2*xmax c xmax=max(xmax,xmax0) C ENDIF C C EXPERIENCE HAS SHOWN THAT THIS LENGTH FOR THE SMALLEST INTERVAL C GIVES IN MOST CASES A REASONABLE INTERVAL SET-UP C C DHNS(1)=(1.625/NZION)**(1./3.)/((2**M)*(NZION-MION+1)**(2./3.)) C C DEFAULT VALUE OF M SET IN MINIM IS CURRENTLY 10, OTHER VALUES C MAYBE READ-IN THERE. C 615 DHNS0=DHNS(1) h=dhns0 C C MAXRS=NUMBER OF POINTS FOR WHICH THE RADIAL FUNCTIONS WILL BE C CALCULATED; MJH INTERVALS WITH MNE(I),I=1,MJH STEPS C NEED TO RE-DO FOR EACH N (DR-LOOP) BECAUSE RADCON REDUCES MNE(MJH) C MAXRS=0 x=dzero c xmax=1.d10 !test c DO J=1,MJH0 L=MAXRS M=MAXRS+MNH(J) IF(J.EQ.MJH0.OR.M+9.GT.MAXA)M=MAXA MAXRS=MIN0(M,MAXA) MNE(J)=M-L IF(MNE(J).GT.0)MJH=J x=x+mne(j)*h if(x.gt.xmax)then if(j.lt.mjh0)go to 15 !simple bailout t=(x-xmax)/h nxtra=int(t) nxtra=mne(j)-nxtra nxtra=max(nxtra,9) if(.not.bsto)nxtra=max(nxtra,2*mne(j-1)) !to initial dx for tf maxrs=l+nxtra if(maxrs.gt.maxa)then nxtra=nxtra-maxrs+maxa maxrs=maxa endif mne(j)=nxtra c write(0,*)m-l,nxtra,m,maxrs c istep=0 c do i=1,mjh0 c istep=istep+mne(i) c enddo c if(maxrs.ne.istep)write(0,*)maxrs,istep !shouldn't be so! endif h=h+h ENDDO C 15 continue C C CALCULATE DPNL(I,K)= FOR NK,LK=QN(K),QL(K)/2 AT X(I) C ACCORDING TO INTERVAL SET-UP OF STATISTICAL MODEL(=S.M.) POTENTIAL C EVALUATE DUY(J,K)= FOR LJ=LK=L, E&N 2.8, C AND FOR N'=N DEY(K)=DUY(K,K)+EIGENENERGY/2RY(=2EPSILON,E+N2.1) C SR. TFDAPO CALCULATES STATISTICAL MODEL POTENTIAL FOR MION ELECTRONS C AND ELECTRIC NUCLEAR CHARGE DZ; SR. STOPOT CALCULATES SLATER-TYPE- C ORBITAL UNIVERSAL POTENTIAL FOR MION-1 ELECTRON ION WITH CHARGE DZ C OUTPUT: POTENTIAL IN /COM1/, DX(I)=X(I) FROM INTERVAL SET-UP MJH.. C DHNS(M)=DHNS(1)*2**(M-1); DX(IEND)=RANGE OF NON-COULOMB POTENTIAL C SR. RADWAV CALCULATES RADIAL FUNCTIONS RHO IN POTENTIAL FROM TFDAPO C IF BSTO .FALSE. (NZION .GT. 0 READ-IN SR.MINIM) OR FROM STOPOT C IF BSTO .TRUE. (NZION .LT. 0 READ-IN SR.MINIM). C FOR SCREEN(K)=SCREENING PARAMETERS SEE NOTE IN SR MINIM C MAXPS=MAXQS IF(NF.LE.0)GO TO 620 JI=1 IF(BORT.AND.MXQIN.LT.50)WRITE(6,778)MXQIN C MXQ1=MXQIN+1 IF(BPRNT3.AND..NOT.BJUMP)THEN WRITE(6,975)TOL,MAXRS,MSTEP,NZION,MION IF(.NOT.BORT.AND.HFF.AND.MAUTO.GE.0)WRITE(6,976)MXPOT ENDIF C c pre-load external orbitals c if(hff.and.mden.lt.0)then if(maxps.eq.0)then !initialize radial mesh call tfdapo(dzero,myn,0,dj0,dj1,dj2,dhns0,maxrs,mjh x ,mne,dhns,dx,dpot,tol,mend,crrct1,crrct2) if(nf.le.0)go to 500 !return endif do k=1,mxorb if(screen(k).ge.d999.and.screen(k).lt.d5999) !flag computed x dajold(k)=dadjus(k) if(screen(k).lt.d999)dey(k)=dzero !as not yet calculated enddo maxqs=maxrs maxps=0 c call radwin(mxqin,maxps) c hff=.false. do k=1,mxorb if(dajold(k).eq.dadjus(k))screen(k)=-3999 !re-flag external if(screen(k).gt.dzero)dey(k)=done !re-flag for calc enddo endif C C BEGIN OUTER LOOP OVER L/NL-DEPEENDENT LAMADAS/ORBITALS C C NP0=0 IF(IPOLFN.LT.0)NP0=-IPOLFN NPARM3=(NP0+1)*NPARAM C 616 DJ=DZERO C DO 603 J=1,NPARAM !<------------------------------------ C C IF(IORT.LT.4)THEN DO N=0,NP0 N0=N*NPARAM+J IF(ABS(DADJUS(N0)-DAJOLD(N0)).GT.DLAM0)GO TO 617 ENDDO GO TO 603 ENDIF C 617 IPOT=J IF(BORT)THEN JEND(J)=MEND IF(SCREEN(J).GT.D5999.AND.IVAL(J).EQ.0)GO TO 603 IF(SCREEN(J).GT.DKEY.AND.IVAL(J).EQ.0)GO TO 631 JI=J ENDIF C C BEGIN INNER LOOP OVER ORBITALS C DO 632 K=JI,MAXGR !<------------------------------------ C C IF(DEY(K).EQ.DZERO)GO TO 602 IF(BJUMP.AND.IVAL(K).EQ.0)GO TO 602 C MYL=QL(K)/2 IF(DEY(K).EQ.DONE)DUY(K,K)=DZERO MRED=0 C C SET-UP POTENTIAL, EITHER USE EXISTING ONE OR GENERATE A NEW ONE C IF(BORT)THEN IF(.NOT.BSTO)THEN IF(idr.gt.0.AND.MORT.GT.-4)MRED=1 IF(MORT.EQ.-4.AND.K.GE.MA.AND.K.LE.MB)MRED=1 !CORE ENDIF IF(IVAL(K).EQ.0)GO TO 646 MRED=0 IF(JPOT.GT.0)GO TO 601 c IF(.NOT.BSTO.OR.BSTO.AND.IVLSUM.EQ.1)THEN !POT NOT DEFINED IN JPOT=1 !RADCON FOR RYD ORB APPROXED BY K=0 IF(BJUMP)GO TO 11 JPOT=0 c ENDIF GO TO 624 ENDIF C JPOT=MYL+1 IF(JPOT .NE.J)GO TO 632 IF(DADJUS(J).EQ.DJ.AND.IORT.LT.4)GO TO 601 IF(.NOT.BJUMP)GO TO 624 IF(JPOT.GT.MXPOT)JPOT=MXPOT 11 IF(SCREEN(K).GT.DKEY)GO TO 602 C C LOAD OLD POTENTIAL C DO I=1,MAXRS DPOT(I)=POT(I,JPOT) ENDDO MEND=JEND(J) DJ=DADJUS(J) GO TO 300 C C POTENTIAL UNCHANGED FROM LAST CALL C 646 IF(.NOT.BSTO.AND.DADJUS(J).EQ.DJ.AND.IORT.LT.4 X .AND.IPOLFN.GE.0)GO TO 601 C C GENERATE NEW POTENTIAL C 624 DJ=DADJUS(J) DJ0=DJ IF(.NOT.BSTO)THEN DJ1=DONE DJ2=DONE IF(NP0.GT.0)DJ1=DADJUS(NPARAM+J) IF(NP0.EQ.2)DJ2=DADJUS(2*NPARAM+J) ENDIF C MK=K MYN=MION-MRED DS=DZ C IF(DJ.GT.DZERO)GO TO 611 IF(IORT.EQ.2)GO TO 611 !CUSP CONDITION IF(BREL)GO TO 611 !MUST SET POT RADWAV C IF(IORT.LT.4)DS=-DJ*DZ !HYDROGENIC ORBITALS IF(IORT.EQ.4)DS=-QN(K)*(NZION-MYN+1)*DJ/DTWO !PSEUDO-STATE BASIS IF(IORT.EQ.5)DS=-(NZION-MYN+1)*DJ !BOX-STATE BASIS C MYN=1 DJ0=DONE C C THOMAS-FERMI DIRAC AMALDI POTENTIAL C 611 IF(.NOT.BSTO)CALL TFDAPO(DS,MYN,MK,DJ0,DJ1,DJ2,DHNS0,MAXRS,MJH,MNE X ,DHNS,DX,DPOT,TOL,MEND,CRRCT1,CRRCT2) C C SLATER-TYPE ORBITAL POTENTIAL C IF(BSTO)CALL STOPOT(DS,MYN,MK,DJ0,DHNS0,MAXRS,MJH,MNE,DHNS,DX X ,DPOT,DTOL,MEND,MPP) C IF(NF.LE.0)GO TO 500 !RETURN C 610 IF(DHNS(1).NE.DHNS0)THEN DO I=1,NPARM3 DAJOLD(I)=DZERO ENDDO IF(HFF0)THEN REWIND(12) REWIND(5) HFF=.TRUE. ENDIF MAXPS=0 JPOT=-1 DHNS(1)=DHNS0 GO TO 615 ENDIF C IF(.NOT.BPRNT3.OR.MPP.GT.1)GO TO 300 IF(.NOT.BORT)THEN IF(.NOT.BSTO.AND..NOT.BHF)WRITE(6,776)MYL,DJ,MEND,DX(MEND) IF(BSTO.AND..NOT.BHF)WRITE(6,777)MYL,DJ,MEND,DX(MEND) IF(BHF)WRITE(6,772)MYL,MHF,MEND,DX(MEND) GO TO 300 ENDIF C IF(.NOT.BSTO.AND..NOT.BHF)THEN IF(BORT)WRITE(6,774)QN(K),MYL,DJ,MEND,DX(MEND) IF(NP0.GT.0)WRITE(6,1774)1,DJ1-DONE,CRRCT1 !DJ1 IF(NP0.EQ.2)WRITE(6,1774)2,DJ2-DONE,CRRCT2 !DJ2 ENDIF IF(BSTO.AND..NOT.BHF)WRITE(6,775)QN(K),MYL,MCFSTO(K),DJ,MEND X,DX(MEND) IF(BHF)WRITE(6,773)QN(K),MYL,MHF,MEND,DX(MEND) C C EVALUATE MODEL PTOL, E.G. POLARIZATION PTOL, OR PLASMA SCREENING PTOL, C APPLIED TO ALL ORBITALS. TO SWITCH-OFF FOR CORE REQUIRES UNCOMMENTING C 'CORE' BELOW AND IN SR.RADCON C 300 ZNP=DX(MAXRS)*DPOT(MAXRS) MML=MYL CORE IF(BORT.AND.MK.GE.MA.AND.MK.LE.MB)MML=-MML IF(MCFMX.GT.0)ZDUM=-D99 C CALL VMPOT(ZNP,MML,MAXRS,DX,DZ,MAXPS,MPP,MK) C IF(NF.LE.0)GO TO 500 !FAILURE C IF(.NOT.BREL)GO TO 601 C C EVALUATE DIFFERENTIALS OF POTENTIAL FOR MASS-VELOCITY AND DARWIN C FOR USE BY PMVDAR, INCLUDING ALLOWANCE FOR FINITE NUCLEUS. C DO I=1,MAXRS DPT0(I)=DPOT(I)-DZ/DX(I) ENDDO C CALL DIFF(DPT0,DERV1,MNE,DHNS,MJH) CALL DIFF(DERV1,DERV2,MNE,DHNS,MJH) C T2=SKIN/2 IFLG1=999999 DO I=1,MAXRS IF(DX(I)-T2.LT.RNUK)IFLG1=I IF(DX(I).GT.RNUK)THEN INUK=I c write(0,*)inuk,dx(inuk-1),rnuk,dx(inuk) IF(INUK.GT.1)THEN IF(DX(I)-RNUK.GT.RNUK-DX(I-1))INUK=INUK-1 ENDIF if(inuke.gt.0.and.inuk.lt.2)then mstep=mstep+1 !TBD watch for infinite loop if tfdapo doubles dhns0=dhns0/dtwo write(6,977)mstep if(nzion.le.30)write(6,978) go to 610 endif RNUK=DX(INUK) GO TO 305 ENDIF ENDDO C 305 IF(INUK.LT.INUK0)THEN INUK=0 INUKP=1 RNUK=-DONE IFLG1=999999 ELSE c write(6,*)'inuk=',inuk T=DZ/RNUK INUKP=INUK+1 IF(INUKE.EQ.0)THEN !UNIFORM DO I=1,INUK DPOT(I)=DHALF*T*(DTHREE-(DX(I)/RNUK)**2) DERV1(I)=-T*DX(I)/RNUK**2 DERV2(I)=-T/RNUK**2 c write(6,*)i,dx(i),dx(i)*dpot(i),dpot(i),derv1(i),derv2(i) ENDDO ELSE !U6 IFLG1=999999 T0=T T00=(T0*63)/32 T8=8*RNUK**2 DO I=1,INUK T=DX(I)/RNUK TT=T*T TTT=TT*TT DPOT(I)=T00-T0*(42-(18-7*TT)*TTT)*TT/32 DERV1(I)=-T0*(21-(27-14*TT)*TTT)*DX(I)/T8 DERV2(I)=-T0*(21-(135-98*TT)*TTT)/T8 c write(6,*)i,dx(i),dx(i)*dpot(i),dpot(i),derv1(i),derv2(i) ENDDO ENDIF ENDIF C c write(6,*)'inukp=',inukp IFLG2=0 DO I=INUKP,MAXRS IF(DX(I)-T2.LT.RNUK)IFLG2=I DD1=DX(I)**2 DERV1(I)=DERV1(I)-DZ/DD1 DERV2(I)=DERV2(I)+DTWO*DZ/(DX(I)*DD1) c if(i.lt.inukp+10)write(6,*)i,dx(i),dpot(i),dnuk1(i),dnuk2(i) ENDDO IF(IFLG2.GT.IFLG1)THEN c write(0,*)iflg1,iflg2,dx(iflg1),dx(iflg2),dnuk2(iflg1),dnuk2(iflg2) DXX=DX(IFLG1)-DX(IFLG2) DO I=IFLG1,IFLG2 DERV2(I)=DERV2(IFLG1)*(DX(I)-DX(IFLG2))/DXX X -DERV2(IFLG2)*(DX(I)-DX(IFLG1))/DXX c write(0,*)i,dx(i),dnuk2(i) ENDDO ENDIF C C NOW ENTER SECTION TO GENRATE RADIAL ORBITAL, NUMERICALLY IN C RADWAV OR ANALYTICALLY (NON-REL COULOMB, INC. LAGUERRES) IN BDCF3 C 601 KAPPA=0 !kappa=ql(k)/2 !test, else 0 C MYN=QN(K) JEND(J)=MEND SC=SCREEN(K) IF(SC.GT.DKEY)GO TO 602 BJUMPR=.FALSE. IF(SC.LE.-DKEY)THEN QN(K)=-QN(K) SC=(QL(K)+1)*MYN IF(SC.GE.MION)SC=MION-1 MODE=4 ENDIF C IF(DJ.GT.DZERO)GO TO 60 !DW OR REL COULOMB C DS=DJ*DZ !COULOMBIC, LAGUERRES SC=DZ+DS C IF(IORT.EQ.2)GO TO 60 !USE RADWAV IF(BREL)GO TO 60 !REL COULOMB C IF(IORT.EQ.4)DS=MYN*(NZION-MION+MRED+1)*DJ/DTWO !NON-REL LAGUERRES C IF(IORT.EQ.5)THEN !BOX STATES DS=-(NZION-MION+MRED+1)*DJ IF(MXBOX.EQ.0)THEN MAXPS=MAXPS-MOD(MAXPS+1,2) !KEEP ODD MAXRS=0 DO I=1,MJH0 MAXRS=MNE(I)+MAXRS MJH=I IF(MAXRS.EQ.MAXPS)GO TO 629 IF(MAXRS.GT.MAXPS)THEN MAXRS=MAXRS-MNE(I) MNE(I)=MAX0(MAXPS-MAXRS,9) MAXRS=MAXRS+MNE(I) GO TO 629 ENDIF ENDDO 629 MAXPS=MAXRS MXBOX=MAXRS ENDIF ENDIF C IF(MODE.EQ.4)IYY(K)=1 DD2=MYN DE=DS/DD2 DE=-DE*DE M=1 C IF(IORT.NE.5)THEN !HYDROGENIC/PS CALL BDCF3(DP,DE,MYN,MYL,DS,M,MAXRS,DX) IF(MYL.LT.0)GO TO 999 !FAILURE ELSE !BOX IF(MYL.EQ.LOLD)THEN IF(EOLD.GT.DZERO)DE=EOLD*D1PT05 IF(EOLD.LE.DZERO)DE=EOLD/D1PT05 ENDIF C CALL BXSCHN(MJH,MNE,DHNS,DS,MYN,MYL,DE,DP,DX,MXBOX,MSTEP) C IF(MYL.LT.0)THEN WRITE(6,*)'*** BXSCHN FAILURE...' WRITE(0,*)'*** BXSCHN FAILURE...' GO TO 999 ENDIF C LOLD=MYL EOLD=DE ENDIF C DP0=DP(1)/DX(1)**(MYL+1) GO TO 61 C C 55 BJUMPR=.TRUE. C BREL=.FALSE. C C 60 CALL RADWAV(MYN,MYL,DZ,MAXRS,MJH,MNE,DHNS,DX,SC,DP,DPT3,DE,rtwo) C IF(MYL.LT.0)THEN WRITE(6,*)'*** RADWAV FAILURE...' WRITE(0,*)'*** RADWAV FAILURE...' GO TO 999 ENDIF C if(bort.and.mend.ne.jend(k))stop 'mend.ne.jend' if(mend.eq.0)stop 'sr.radial: mend=0' c c rinf2(k)=rtwo !hydrogenic estimate seems good enough rnorm(k)=rnorm0 c write(0,*)k,rtwo !rnorm0 C IF(.NOT.BJUMP.AND.BPRNT3.AND.(MDEN.GT.2.OR.MDEN.LT.0)) X WRITE(6,765)MYN,MYL,DE,MPP IF(MYN.LE.0)GO TO 999 !WATCH FOR CONFLICT WITH MY QN(K).LT.0 C 61 IF(MGRP.LT.0)THEN T0=MION-1 T1=MYN T0=T1*(T0-SC) SC=T0/(DZ-SC) ENDIF IF(SCREEN(K).LT.DKEY)SCREEN(K)=SC C DDE=DE IF(BREL)DDE=DZERO !OMIT FROM DQ, INCASE ORTHOG C DO M=1,MAXRS IF(ABS(DP(M)).GT.TOLR)MAXPS=MAX0(M,MAXPS) DPNL(M,K)=DP(M) ENDDO IF(BREL2)THEN DO M=1,MAXRS DQNL(M,K)=DPT3(M) ENDDO ELSE DO M=1,MAXRS DQNL(M,K)=((DPOT(M)-DZ/DX(M))*DTWO+DDE)*DP(M) CTEST IF(BREL)DQNL(M,K)=DQNL(M,K)+PMVDAR(M,DX(M))*DP(M) c if(m.lt.maxps)write(6,*)m,dx(m),dpot(m)-dz/dx(m) ENDDO IF(BREL)THEN DO M=1,INUK DQNL(M,K)=(DPT0(M)*DTWO+DDE)*DP(M) ENDDO ENDIF ENDIF C IF(BJUMPR)GO TO 642 C if(mden.ne.0)then IF(K.GT.MB.AND.ABS(DE-deold(k)).GT.-TOLPP*de)BMPP=.TRUE. deold(k)=de endif DE=DE/DTWO DDE=DDE/DTWO DEY(K)=DE !FLAG EXISTS, or for radwin IRAD(K)=1 DORIG(K)=DP0 K0=K IF(BJUMP)K0=MAXGR C IF(.NOT.BORT)GO TO 634 DD1=DZERO IF(MORT.EQ.-3.AND.IRLX.NE.2)THEN IF(BREL)GO TO 634 GO TO 62 ENDIF C C ORTHONORMALIZE C DS=DZERO C DO L=1,K C IF(QL(K).NE.QL(L))GO TO 635 !WRONG ORB A.M. C IF(MORT.LT.0.AND.QN(K).EQ.QN(L).AND.L.NE.K)GO TO 635 C IF(MORT.LE.-4.AND.QN(K).EQ.QN(L).AND.L.NE.K)GO TO 635 IF(IVAL(K)+IVAL(L).EQ.2 X .AND.QN(K).EQ.QN(L).AND.L.NE.K)GO TO 635 !SKIP RYDBERG C IF(IVAL(K)+IVAL(L).EQ.1.AND..NOT.BSTO.AND.IRLX.NE.2)GO TO 635 IF(DEY(L).EQ.DZERO)GO TO 635 !DOES NOT EXIST IF(SCREEN(L).GE.DKEY)GO TO 602 !NOT YET COMPUTED IF(L.EQ.K.AND.(DS.EQ.DZERO.OR.IRLX.EQ.2))GO TO 63 !SKIP UNMODFD C IF(BREL2)THEN DO M=1,MAXPS DA(M)=DPNL(M,L)*DPNL(M,K)+DQNL(M,L)*DQNL(M,K) ENDDO ELSE DO M=1,MAXPS DA(M)=DPNL(M,L)*DPNL(M,K) ENDDO ENDIF C CALL WEDDLE(DD1,DA,DS,MNE,DHNS,MJH,MAXPS) C IF(L.EQ.K)GO TO 635 IF(BPRNT0)WRITE(6,780)QN(K),MYL,QN(L),MYL,DS C IF(MORT.LE.-4)THEN IF(IVAL(K).EQ.1)THEN NN=QN(L) IF(DADJUS(L).LT.DZERO)NN=-NN WRITE(16,795)QL(K)/2,QN(K),NN,DS IF(QN(K).LE.NN)THEN WRITE(6,764)K,QN(K),NN,L C GO TO 999 !ERROR: VALENCE N .LE. CORE N GO TO 635 ENDIF IF(DADJUS(L).LT.DZERO)GO TO 635 C ELSE C IF(DADJUS(K)*DADJUS(L).LT.DZERO)THEN C NN=QN(K) C IF(DADJUS(K).LT.DZERO)NN=-NN C WRITE(16,795)QL(L)/2,QN(L),NN,DS C ENDIF ENDIF ENDIF C IF(IRLX.EQ.2)THEN KK=((K-1)*(K-2))/2+L OVLPGR(KK)=DS GO TO 635 ENDIF C DO M=1,MAXRS DPNL(M,K)=DPNL(M,K)-DS*DPNL(M,L) DQNL(M,K)=DQNL(M,K)-DS*DQNL(M,L) ENDDO DP0=DP0-DS*DORIG(L) C 635 ENDDO C C END ORTHOGONALIZATION C IF(DS.LT.DEL)THEN WRITE(6,779) K NF=-1 DEY(K)=DZERO GO TO 602 ENDIF C DS=DONE/SQRT(DS) IF(DP0.LT.DZERO)THEN C DS=-DS C WRITE(6,781)K,(DPNL(M,K),M=1,50) C WRITE(6,781) ENDIF C DO M=1,MAXRS DPNL(M,K)=DS*DPNL(M,K) IF(ABS(DPNL(M,K)).GT.TOLR)MAXPS=MAX0(MAXPS,M) DQNL(M,K)=DS*DQNL(M,K) ENDDO DP0=DS*DP0 DORIG(K)=DP0 C C NEED TO RECALCULATE ORBITALS L .GT. K WITH QL(L) .EQ. QL(K) C DURING MINIMIZATION SO CAN RE-ORTHOGONALIZE TO NEW K. C 63 IF(.NOT.BDR)THEN DO L=K,MAXGR IF(QL(L).EQ.QL(K).AND.DEY(L).NE.DZERO)THEN DO N=0,NP0 N0=N*NPARAM DAJOLD(N0+L)=DZERO ENDDO ENDIF ENDDO ENDIF C C END ORTHONORM C 62 IF(BREL)GO TO 634 !BREL2 C C FORM ONE-BODY ENERGY INTEGRALS (NON-RELATIVISTIC ORBITALS IF BREL) C (RELATIVISTIC LARGE CPT ONLY IF BREL2, C THEN ENERGY FACTOR USUALLY OMITTED C FROM DQNL DURING ORTHOG - SEE DDE) C DO L=1,K0 IF(QL(K).NE.QL(L))GO TO 639 IF(SCREEN(L).GE.DKEY)GO TO 639 DD2=DZERO IF(DEY(L).EQ.DZERO)GO TO 641 IF(K.LE.IABS(MPSEUD))GO TO 641 IF(L.GT.K.AND.IVAL(L).GT.0)GO TO 639 C DO M=1,MAXPS DA(M)=DQNL(M,K)*DPNL(M,L) CTEST DA(M)=DQNL(M,L)*DPNL(M,K) ENDDO IF(MPSEUD.NE.0)THEN DO M=1,MAXPS DA(M)=DA(M)+DTWO*DPNL(M,L)*DPNL(M,K)*(DZ/DX(M)-POTHAM(M)) ENDDO ENDIF C CALL WEDDLE(DD1,DA,DS,MNE,DHNS,MJH,MAXPS) C DD2=DS/DTWO 641 DUY(K,L)=DD2 DUY(L,K)=DD2 C 639 ENDDO C DEY(K)=DUY(K,K)+DE-DDE IF(QN(K).LT.0)DEY(K)=DEY(K)-TSHFT DUY(K,K)=DUY(K,K)-DDE C DE=DE-DDE !SO NOT DOUBLE COUNTED IN D2LL WHEN IN DQNL DEC=DZERO C GO TO 636 C C FORM ONE-BODY ENERGY INTEGRALS (RELATIVISTIC ORBITALS) C REALLY REQUIRES OVERLAPS BE SMALL AS USES UNMODIFIED POTENTIAL C IF ONLY SMALL CPT THEN CAN GO THRU NON-REL BRANCH ABOVE. C 634 DD1=DZERO C DO L=1,K0 C IF(QL(K).NE.QL(L)) GO TO 604 IF(SCREEN(L).GE.DKEY)GO TO 604 DS=DZERO C IF(BREL.AND.L.NE.K)GO TO 605 IF(DEY(L).EQ.DZERO)GO TO 605 IF(K.LE.IABS(MPSEUD))GO TO 605 IF(L.GT.K.AND.IVAL(L).GT.0)GO TO 604 C DO I=1,INUK !RESET FINITE NUCLEUS POT DA(I)=DPT0(I) ENDDO IF(MPSEUD.EQ.0)THEN DO I=INUKP,MAXPS DA(I)=DPOT(I)-DZ/DX(I) ENDDO ELSE DO I=INUKP,MAXPS DA(I)=DPOT(I)-POTHAM(I) ENDDO ENDIF IF(BREL2)THEN DO I=1,MAXPS DA(I)=DA(I)*(DPNL(I,L)*DPNL(I,K)+DQNL(I,L)*DQNL(I,K)) ENDDO ELSE DO I=1,MAXPS DA(I)=DA(I)*DPNL(I,L)*DPNL(I,K) ENDDO ENDIF C CALL WEDDLE(DD1,DA,DS,MNE,DHNS,MJH,MAXPS) C 605 DUY(K,L)=DS DUY(L,K)=DS DCD(K,L)=DZERO DCD(L,K)=DZERO C 604 ENDDO C DEY(K)=DE+DUY(K,K) IF(QN(K).LT.0)DEY(K)=DEY(K)-TSHFT C C END ONE-BODY ENERGY DETERMINATION C C ADD-IN EIGEN-ENERGY C IF(.NOT.BREL2.AND.DDE.EQ.DZERO)THEN !606 DDE=DE+DE DO I=1,MAXRS DQNL(I,K)=DQNL(I,K)+DDE*DPNL(I,K) ENDDO DDE=DE ENDIF C C DETERMINE CORRECTION TO KAPPA AVERAGE ENERGIES C C CAN ALSO TEST HERE EVALUATION OF SPIN-ORBIT: WITH FULL POTENTIAL IN C SMALL R CORRECTION FOR WHEN SMALL CPT IN USE, SINCE WE ONLY RETAIN C DIAGONAL IN NL CORRECTION DEPENDS ON E-V, AND/OR POTENTIAL DERIVATIVE. C DO NOT USE CLOSED SHELLS THEN! STORED TEMPORARILY IN DARWIN ARRAY DCD. C **NO GOOD FOR RADWIN!** SEE ALSO SOCC TO SWITCH-OFF CALCULATION THERE. C 636 IF(.NOT.BREL.OR.K.LE.IABS(MPSEUD).OR.QL(K).EQ.0)GO TO 642 C IF(BREL2)THEN DO I=1,MAXPS DP(I)=DPNL(I,K)*DPNL(I,K) C X +DQNL(I,K)*DQNL(I,K) !for test (B&W) s-o only DA(I)=DONE+DALF*(DE+DPOT(I))/DTWO ENDDO ELSE DO I=1,MAXPS DP(I)=DPNL(I,K)*DPNL(I,K) DA(I)=DONE+DALF*(DQNL(I,K)/DPNL(I,K)+DTWO*(DE-DDE+DZ/DX(I))) X /DFOUR ENDDO ENDIF C DO I=1,MAXPS DPT3(I)=DP(I)*DERV1(I)/DX(I) !POTENTIAL DERIV DP(I)=DP(I)/(DX(I)*DX(I)*DX(I)) !NUCLEAR DP(I)=DP(I)/DA(I) DPT3(I)=DPT3(I)/DA(I) ENDDO DD1=DZERO DD3=DZERO C !BREL2 TEST ONLY & .not.b1mbp CT CALL WEDDLE(DD1,DP,DD3,MNE,DHNS,MJH,MAXPS) C DD3=DALF*DD3/DFOUR C C TEST KAPPA-AVERAGED (NUCLEAR) SPIN-ORBIT CONTRIBUTION. C NEED TO UNCOMMENT KAPPA=QL(K)/2 AT STATEMENT NUMBER 601 ABOVE C c write(0,*)'kappa=',kappa c write(0,*)dd3,dd3*2*dz,dey(k),duy(k,k),de c IF(KAPPA.GT.0)THEN DSOOLD=DD3 ELSEIF(KAPPA.LT.0)THEN I0=(QL(K)/2) I1=I0+1 I2=I0+I1 DD3=(DSOOLD*I0+DD3*I1)/I2 write(0,*)'kappa-averaged spin-orbit=',dd3,dd3*2*dz DSOOLD=DD3 ENDIF C DCD(K,K)=DD3 !DSOOLD C CALL WEDDLE(DD1,DPT3,DD3,MNE,DHNS,MJH,MAXPS) C DD3=DALF*DD3/DFOUR IF(IREL.LT.0)DCD(K,K)=-DD3/DZ !USE POTENTIAL DERIV C C TEST KAPPA-AVERAGED ONE-BODY ENERGY CONTRIBUTION. C NEED TO UNCOMMENT KAPPA=QL(K)/2 AT STATEMENT NUMBER 601 ABOVE C IF(KAPPA.NE.0)THEN DDD=-(KAPPA+1)*DD3 !KAPPA DEPENDENT ONE-BODY ENERGY ELSE DDD=-DZERO*DD3 !KAPPA=-1 .EQ. (2J+1) KAPPA-AVERAGE ENDIF C DUY(K,K)=DUY(K,K)+ddd DEY(K)=DEY(K)+ddd c c write(0,*)ddd,dey(k),duy(k,k),de C C TEST KAPPA-AVERAGED BINDING ENERGY (EPSILON) CONTRIBUTION. C NEED TO UNCOMMENT KAPPA=QL(K)/2 STATEMENT BELOW LINE C "IF(.NOT.BREL)GO TO 601" HIGHER UP THE CODE. C IF(KAPPA.GT.0)THEN DEHOLD=DE ELSEIF(KAPPA.LT.0)THEN I0=(QL(K)/2) I1=I0+1 I2=I0+I1 DE=(DEHOLD*I0+DE*I1)/I2 c write(0,*)'kappa-averaged epsilon=',de c dehold=de ENDIF C IF(KAPPA.GT.0)THEN KAPPA=-KAPPA-1 GO TO 60 ELSEIF(KAPPA.LT.0)THEN KAPPA=0 GO TO 60 ENDIF C C DETERMINE CORRECTION TO KAPPA-AVERAGED BINDING ENERGY C CALL DIFF(DPNL(1,K),DA,MNE,DHNS,MJH) C DO I=1,MAXPS DA(I)=DPT3(I)*DX(I)*DA(I)/DPNL(I,K) ENDDO C CALL WEDDLE(DD1,DA,DD4,MNE,DHNS,MJH,MAXPS) C DD4=DALF*DD4/DFOUR DEC=(QL(K)+1)*(DD3-DD4) c if(brel2)dec=dec/rnorm(k)**2 c c if(ql(k).eq.0)go to 642 !test c write(0,*)'correction to kappa-averaged binding energy=' c x ,dd3,dd4,dec,de,de+dec c dec=0.0 DE=DE+DEC c de=dehold !test use explicitly calculated deviation, above C DEY(K)=DE+DUY(K,K) C IF(.NOT.BREL2.and.dde.ne.dzero)THEN DDE=DE-DDE DDE=DDE+DDE DO I=1,MAXRS DQNL(I,K)=DQNL(I,K)+DDE*DPNL(I,K) ENDDO dde=de ENDIF C C UNCOMMENT TWO LINES 'IF..' BELOW TO LOOP AROUND RADIAL EQUATION TWICE C (BOUND AND CONTINUUM AUTOMATICALLY TAKEN CARE OF) FIRST TO EVALUATE C RELATIVISTIC RADIAL FUNCTION FOR ONE-BODY AND ELECTROSTATIC MATRIX C ELEMENTS THEN TO EVALUATE NON-RELATIVISTIC RADIAL FUNCTION FOR C TWO-BODY FINE-STRUCTURE AND (IF INSERTED IN RADCON AND DIAGON) C TWO-BODY NON-FINE-STRUCTURE. SHOULD NOT BE NEEDED AS USE OF C RELATIVISTIC RADIAL FUNCTIONS FINE FOR ALL OPERATORS - HISTORIC. C N.B. REMOVE SECOND APPEARENCE OF STATEMENT NO 642, UNCOMMENT 55, NEXT C CT642 IF(BREL.AND..NOT.BJUMPR)GO TO 55 CT IF(BJUMPR)BREL=.TRUE. C C ******************DATA TO RELATIVISTIC CONTRIBUTIONS***************** C C IF HFF .TRUE. THEN THERE EXIST ORBITALS TO BE CALCULATED IN C SR.RADWIN, LEAVE CALC OF REL CONTRIB TIL THEN. C 642 IF((.NOT.BMVD.AND.NJO.EQ.0).OR.HFF)GO TO 602 C C MASS-VELOCITY AND DARWIN (+M1+BP RAD) C CALL MVDINT(K,DE,INUKP,MAXPS) C C 602 IF(K.LE.IABS(MPSEUD))THEN DUY(K,K)=DZERO DEY(K)=DZERO ENDIF IF(K.EQ.IABS(MPSEUD).AND..NOT.HFF)THEN CALL VPNL(DZ,-1,0,WK,AJUST,MAXRS,MJH,MNE,DHNS,POTHAM,DTOL,MEND) IF(NF.LE.0)GO TO 500 !RETURN ENDIF C IF(.NOT.BORT)GO TO 632 IF(JPOT.NE.0)GO TO 631 JPOT=1 IPOT=1 GO TO 12 C C END INNER LOOP OVER ORBITALS C 632 CONTINUE !<------------------------------------- C C C ADJUST POTENTIAL STORAGE C IF(J.GT.MXPOT)GO TO 631 IF(BJUMP)GO TO 631 C 12 IF(inukp.le.0)then if(brel)then write(6,*)'inukp=',inukp write(0,*)'inukp.le.0 !' go to 999 endif INUKP=1 endif DO I=INUKP,MAXRS POT(I,IPOT)=DPOT(I) ENDDO IF(BREL)THEN DO I=1,INUK POT(I,IPOT)=DPT0(I)+DZ/DX(I) ENDDO ENDIF C 631 DO N=0,NP0 N0=N*NPARAM DAJOLD(N0+J)=DADJUS(N0+J) ENDDO C C END OUTER LOOP OVER SCALING PARAMETERS C 603 CONTINUE !<------------------------------------ C C C UPDATE DQNL (IF NOT ALREADY DONE SO) C IF(.NOT.BREL2.AND.DDE.EQ.DZERO)THEN DO K=1,MAXGR IF(DEY(K).EQ.DZERO)GO TO 619 IF(SCREEN(K).GT.DKEY)GO TO 619 DE=DEY(K)-DUY(K,K) DE=DE+DE DO M=1,MAXRS DQNL(M,K)=DQNL(M,K)+DE*DPNL(M,K) ENDDO 619 ENDDO ENDIF C C UPDATE PLASMA POTENTIAL ITERATION C IF(MDEN.GT.2.OR.MDEN.LT.0.AND..NOT.BJUMP)THEN IF(MPP.LT.MPP5.AND.BMPP)THEN MPP=MPP+1 I0=0 DO I=1,NPARAM c i0=0 !limit core iterations c if(mpp.gt.qn(i)+1)i0=mb !if troublesome c if(i.ge.i0)then if(screen(i).gt.-d999.AND..NOT.BFIX(I))then do n=0,np0 n0=n*nparam+i DAJOLD(n0)=DZERO enddo endif c endif ENDDO ZDUM=-D99 BMPP=.FALSE. JPOT=-1 GO TO 616 else c do i=1,maxrs c write(66,566)i,dx(i),dx(i)*dpot(i),-dpot(i) c 566 format(i5,3(1pe16.7)) c enddo ENDIF ENDIF c if(iabs(includ).ge.1000000)then do k=1,mxorb if(screen(k).lt.-d999)then de=dey(k)-duy(k,k) !epsilon a.u. de=-2*de screen(k)=dz-sqrt(qn(k)*de) endif enddo endif C C DETERMINE QED CONTRIBUTIONS (ALL ORBITALS) C IF(QED.NE.0)CALL QEDINT(MAXPS) C C INITIALIZE DX IF NOT DONE SO ALREADY C IF(MAXPS.EQ.0)THEN CALL TFDAPO(DZERO,MYN,0,DJ0,DJ1,DJ2,DHNS0,MAXRS,MJH X ,MNE,DHNS,DX,DPOT,TOL,MEND,CRRCT1,CRRCT2) IF(NF.LE.0)GO TO 500 !RETURN ENDIF C 620 IF(.NOT.HFF.and..not.bdr) GO TO 612 C MAXQS=MAXRS !MAX RADIAL EXTENT (TO BE) COMPUTED IF(.NOT.BJUMP)GO TO 4 DO K=1,MAXGR IF(DEY(K).EQ.DZERO)GO TO 5 IF(SCREEN(K).LT.DKEY)GO TO 5 GO TO 9 5 ENDDO IF(.NOT.BLAG)HFF=.FALSE. GO TO 612 C 9 MAXPS=0 C DO K=1,MAXGR IF(DEY(K).EQ.DZERO)GO TO 7 IF(QN(K).LT.0)GO TO 7 IF(SCREEN(K).GT.DKEY)GO TO 7 DO M=1,MAXRS IF(ABS(DPNL(M,K)).GT.TOLR.or.dx(m).lt.rzero)MAXPS=MAX0(MAXPS,M) ENDDO 7 ENDDO C 4 IF(MAUTO.GT.0)GO TO 622 C C C TO READ RADIAL BOUND FUNCTIONS AS INPUT AND PROCESS THEM. C IF(HFF)THEN C CALL RADWIN(MXQIN,MAXPS) C IF(NF.LE.0)GO TO 500 !RETURN C HFF=.FALSE. C IF(MAUTO.EQ.0)GO TO 622 C ENDIF C C PREPARE FOR DROPPING ALL POINTS I BEYOND WHICH ALL //.LT.TOLR C 612 CONTINUE C IF(RZERO.GT.DZERO)THEN DO M=1,MAXRS IF(DX(M).GT.RZERO)GO TO 43 ENDDO M=MAXRS 43 MAXPS=M ENDIF C MAXQS=0 DO I=1,MJH0 MAXQS=MNE(I)+MAXQS MJH=I IF(MAXQS.EQ.MAXPS)GO TO 609 IF(MAXQS.GT.MAXPS)THEN MAXQS=MAXQS-MNE(I) nxtra=9 c if(.not.bsto.and.mauto.gt.0)nxtra=max(nxtra,2*mne(i-1))!test MNE(I)=MAX0(MAXPS-MAXQS,nxtra) MAXQS=MAXQS+MNE(I) GO TO 609 ENDIF ENDDO C 609 IF(MAUTO.Le.0)GO TO 630 !.NOT.HFF.OR. C C***************************************************************** C EVALUATE CONTINUUM FUNCTIONS FOR AUTOIONIZATION RATE EVALUATION C IN SR.DIAGON AND SR.DIAGFS C***************************************************************** C C 622 CALL RADCON(MAXPS) C IF(NF.LE.0)GO TO 500 !RETURN C C C C WRITE RADIAL MESH AND EFFECTIVE CHARGE DUE TO NUCLEUS PLUS CLOSED C SHELL CORE, AND THEN ORBITALS TO FILE 'radout' IN SS/IMPACT FORMAT. C 630 IF(MRAD.GE.0)GO TO 500 C C FIRST DETERMINE EFFECTIVE CHARGE C IF(MPSEUD.EQ.0.AND..NOT.HFF)THEN CALL VPNL(DZ,-1,0,WK,AJUST,MAXPS,MJH,MNE,DHNS,POTHAM,DTOL,MEND) IF(NF.LE.0)GO TO 500 !RETURN ENDIF C IF(IUNIT(MRWR).LT.0)THEN WRITE(6,*)"TRYING TO RE-OPEN FILE='radout'..." WRITE(0,*)'TRYING TO RE-OPEN UNIT=13' GO TO 999 !RETURN ENDIF IUNIT(MRWR)=1 OPEN(MRWR,FILE='radout',STATUS='REPLACE') C MMRAD=MOD(MRAD,100) C MAXW2=(MAXQS-1)/2 MAXW=MAXW2*2-1 MAXW2=MAXW2+1 MAXX=2*MAXW2 ZERO=DZERO NORB=0 TLBL='TFDA' IF(BSTO)TLBL='STO ' IF(BREL)TLBL='REL ' IF(IORT.EQ.4)TLBL='LPS ' IF(IORT.EQ.5)TLBL='BOX ' C IF(MMRAD.NE.0)THEN DO J=1,MAXGR IF(DEY(J).EQ.DZERO.AND.J.GT.IABS(MPSEUD))GO TO 501 NORB=NORB+1 501 ENDDO ENDIF C KEY=-9 WRITE(MRWR,702)KEY,NORB,MB,MAXX,MION,DZ,(DAJOLD(I),I=1,5),TLBL C KEY=-8 I1=1 I2=2 WRITE(MRWR,704)KEY,I1,ZERO,DZ,I2,DX(1),DX(1)*POTHAM(1) C DO I=1,MAXW,2 I1=I+1 I2=I+2 I3=I+3 WRITE(MRWR,704)KEY,I2,DX(I1),DX(I1)*POTHAM(I1),I3,DX(I2),DX(I2) X *POTHAM(I2) ENDDO C IF(MMRAD.EQ.0)GO TO 502 C C WRITE ORBITAL FUNCTIONS P AND Q IN "IMPACT" FORMAT C DO J=1,MAXGR IF(DEY(J).EQ.DZERO.AND.J.GT.IABS(MPSEUD))GO TO 506 KEY=-7 MYN=QN(J) MYL=QL(J)/2 DE=DEY(J)-DUY(J,J) DE=DE+DE T=ZERO IF(J.GE.MA.AND.J.LE.MB)T=2*(QL(J)+1) WRITE(MRWR,705)KEY,J,MYN,MYL,T,DE,MAXW2,TLBL C KEY=-6 I1=1 I2=2 WRITE(MRWR,704)KEY,I1,DORIG(J),ZERO,I2,DPNL(1,J),DQNL(1,J) C DO I=1,MAXW,2 I1=I+1 I2=I+2 I3=I+3 WRITE(MRWR,704)KEY,I2,DPNL(I1,J),DQNL(I1,J),I3,DPNL(I2,J) X ,DQNL(I2,J) ENDDO 506 ENDDO C C FULL ATOMIC STO POTENTIAL FOR E.G. D.W. C C***CURRENTLY, SAME FILE AS ORBITALS, C BUT -100 NO WRITE OF ORBITALS, ONLY POTENTIAL C 502 IF(MRAD.GT.-100.OR..NOT.BSTO.OR..NOT.BORT)GO TO 508 MNP=MION+1 DJ0=DADJUS(MCFMX) C CALL STOPOT(DZ,MNP,MCFMX,DJ0,DHNS0,MAXQS,MJH,MNE,DHNS,DX,DPOT,DTOL X ,MEND,MPP) IF(NF.LE.0)GO TO 500 !RETURN C KEY=-14 J=-1 DJ0=DZERO T=ZERO WRITE(MRWR,705)KEY,J,MEND,J,T,DJ0,MAXW2,TLBL C KEY=-4 I1=1 I2=2 POT0=DTHREE*DPOT(1) WRITE(MRWR,704)KEY,I1,POT0,POT0,I2,DPOT(1),DPOT(1) C DO I=1,MAXW,2 I1=I+1 I2=I+2 I3=I+3 WRITE(MRWR,704)KEY,I2,DPOT(I1),DPOT(I1),I3,DPOT(I2),DPOT(I2) ENDDO C 508 WRITE(MRWR,702) C CLOSE(MRWR,STATUS='KEEP') IUNIT(MRWR)=-1 C 500 CONTINUE C C CHECK RADIAL OVERLAPS C C DO 450 K=1,MAXGR C IF(DEY(K).EQ.DZERO)GO TO 450 C DO 451 J=K,MAXGR C IF(DEY(J).EQ.DZERO)GO TO 451 C IF(QL(J).NE.QL(K))GO TO 451 C DD2=DZERO C DO I=1,MAXPS C DA(I)=DPNL(I,K)*DPNL(I,J) C IF(BREL)DA(I)=DA(I)+DQNL(I,K)*DQNL(I,J) C ENDDO C CALL WEDDLE(DD2,DA,DD1,MNE,DHNS,MJH,MAXPS) C WRITE(6,453) K,J,DD1 C 453 FORMAT(2I5,1PE15.5) C 451 ENDDO C 450 ENDDO C IF(MAXPS.EQ.MAXRS.AND.MXBOX.LE.0)THEN IF(MAXRS.EQ.MAXB1)THEN !END OF PHYSICAL ARRAY WRITE(6,771)MSTEP WRITE(0,*)'SR.RADIAL: RADIAL ARRAY FULL' GO TO 999 !RETURN ELSE WRITE(6,*)' WARNING: INTERNAL RADIAL ARRAY MAYBE TOO SHORT...' WRITE(0,*)' WARNING: INTERNAL RADIAL ARRAY MAYBE TOO SHORT...' write(0,*)'xmax=',xmax ENDIF ENDIF C RETURN C 999 NF=-1 RETURN C 702 FORMAT(3I5,9X,2I4,F5.1,5F7.3,A4) 704 FORMAT(I5,2(I4,2(1PE14.7))) 705 FORMAT(3I5,I3,F5.1,2X,F12.6,I6,29X,A4) 751 FORMAT(/5X,'INUKE=',I2,': POINT NUCLEUS IN USE') 752 FORMAT(/5X,'INUKE=',I2,': UNIFORM NUCLEAR CHARGE DISTRIBUTION WITH X',' R= ',1PD9.3,' AND A= ',0PF5.1,' , BUT WITH SKIN= ' X,1PD9.3) 753 FORMAT(/5X,'INUKE=',I2,': U6 NUCLEAR CHARGE DISTRIBUTION WITH' X,' R=',1P,E9.3,' AND A= ',0P,F5.1,' , AND K0= ',0PF9.5) 764 FORMAT(' WARNING: ORBITAL',I3,' HAS VALENCE N=',I3,' .LE. CORE N=' X,I3,' OF ORBITAL',I3) 765 FORMAT(' N=',I3,5X,'L=',I3,5X,'EPSILON=',F12.5,10X,'MPP=',I3) 771 FORMAT( ' SR.RADIAL: RADIAL ARRAY FULL -- TRY BIGGER INTEGRATION X RANGE - MORE POINTS (INCREASE MAXB1 2) OR LONGER STEPS (DECREASE' X,' MSTEP IN NAMELIST SMINIM)'/' CURRENTLY, MSTEP=',I3) 772 FORMAT(16X,'LL =',I2, ' EXTERNAL POTENTIAL V(LL) FROM UNIT=',I2 X,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=',I5,') =' X,F10.6) 773 FORMAT(13X,'NL =',I3,I2,' EXTERNAL POTENTIAL V(NL) FROM UNIT=' X,I2,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=',I5, ' X) =',F10.6) 774 FORMAT(23X,'NL =',I3,I2, ' S.M.-POTENTIAL V(NL) WITH SCALE FAC XTOR',F10.5, '; COULOMBIC BEYOND R(IEND=',I5,') =',F10.6) 1774 FORMAT(45X,I1,'-POLE PERTURBED SCALE FACTOR' X,F10.5, '; COULOMBIC DEVIATION AT R(IEND) =',F10.6) 775 FORMAT( 2X,'NL =',I3,I2, ' STO.-POTENTIAL CF=',I3, ' WITH SCAL XE FACTOR',F10.5,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R( XIEND=',I5,') =',F10.6) 776 FORMAT(24X,'LL =',I2, ',.. S.M.-POTENTIAL V(LL) WITH SCALE FACT XOR',F10.5, '; COULOMBIC BEYOND R(IEND=',I5,') =',F10.6) 777 FORMAT( 3X,'LL =',I2, ',.. STO.-POTENTIAL V(LL) WITH SCALE FACT XOR',F10.5,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=' X,I5,') =',F10.6) 778 FORMAT( ' NON-ORTHOGONAL ORBITALS IN USE; BUT MAXB2=',I5, ' INSUF XFICIENT FOR DQNL, ERRORS MAY ARISE IN ONE-BODY INTEGRALS ') 779 FORMAT( ' NEAR IDENTICAL FUNCTION FOR ORBITAL K=',I2, ' CASE SKI XPPED ') 780 FORMAT( ' OVERLAP INTEGRAL',4X,I3,I2,' WITH',2I2,' =' X,1PE12.4) C 781 FORMAT( ' ORTHOGONALIZATION CHANGES SIGN OF ORBITAL K=' ,I2, C X ' VALUES NEAR ORIGIN ARE: '/10(1PE13.4)) C 781 FORMAT('+',57X,'*') 795 FORMAT(3I5,1PE13.4) 879 FORMAT(/5X,'BREIT INTERACTIONS: ',1X,'KUTSO=',I2,3X,'KUTSS=',I2 X ,3X,'KUTOO=',I2,4X,A12,1X,'(IBREIT=',I2,')',12X,'QED=',I2) 880 FORMAT(//' *** KAPPA-AVERAGED RELATIVISTIC WAVEFUNCTIONS ' X,'IN USE: ',' SMALL COMPONENT IS ',A3,' (IREL=',I2,')',3X X,'RETARDATION IS ',A3,' (IRTARD=',I2,')'/ 75X,'***',28X,'***') 975 FORMAT(/// ' RADIAL FUNCTIONS: PRECISION OF EIGENVALUE IS', X1PE9.2,4X,I6, ' POINTS (MSTEP=',I2,'); ATOMIC NUMBER',I3, X', NUMBER OF ELECTRONS',I3) 976 FORMAT('+',122X,'MXPOT=',I2) 977 FORMAT(/'*** SR.RADIAL: MESH AT ORIGIN TOO COARSE FOR FINITE ', X'NUCLEUS, RECALCULATING WITH INITIAL STEP HALVED, I.E. MSTEP=',I2) 978 FORMAT(15X,'ALTERNATIVELY, TRY A POINT NUCLEUS (INUKE=-1)...') C END C C ******************* C SUBROUTINE RADWAV(N,L,Z,NPOINT,NI,NTI,DXI,X,SCREEN,P,Q,EA,rinf2) C C----------------------------------------------------------------------- C C SR.RADWAV CALCULATES ELECTRON BOUND WAVE FUNCTIONS IN A POTENTIAL POT C -IF SR.TFDAPO/STOPOT IS RUN BEFORE RADWAV THEN COMMON /COM1/WILL C CONTAIN THE POTENTIAL POT(I) AT RADIAL MESH POINTS X(I),I=1,NPOINT C SUBROUTINES REQUIRED: NUMERO, WHITEX, WEDDLE. C QUANTITIES REQUIRED -APART FROM POT(I) AND X(I) - C N=PRINCIPAL QUANTUM NUMBER, L=ANGULAR MOMENTUM, C Z=NUCLEAR CHARGE, ASYMPTOTIC CHARGE =POT(NPOINT)*X(NPOINT) ASSUMED C NI=NUMBER OF INTERVALS INTO WHICH THE WHOLE RANGE IS DIVIDED, C NTI(J)=NUMBER OF STEPS (.GE.8) IN EACH INTERVAL J=1,NI, C DXI(J)=STEP LENGTH IN INTERVAL J, NPOINT=TOTAL NUMBER OF STEPS C SCREEN IS AN ESTIMATE OF THE SCREENING VALUE IN A RYDBERG FORMULA; C AFTER EXCECUTING RADWAV THE INITIAL VALUE OF SCREEN IS REPLACED BY C THECALCULATED SIGMA. OTHER INPUT ARE IEND, DTOL(=10**(-ITOL)) C RESULTS C P(I) I=1,NPOINT VALUES OF THE NORMALIZED WAVE FUNCTION C E=ENERGY EIGENVALUE IN RYDBERGS (INACCURACY ABS(DE/E).LT.DTOL); C SCREEN=SCREENING PARAMETER IN A RYDBERG FORMULA (FOR E=EA). C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C LOGICAL BSHORT,BNORM,BREL,BJUMPR,BMVD,BREL2 C DIMENSION P(*),X(*),DXI(*),NTI(*),Y(6),A(12),U(3),IND(3),PKOEF(4) X,Q(*) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DSIX=6.0D0) PARAMETER (DSIXTH=DONE/DSIX) PARAMETER (DTHIRD=DONE/DTHREE) PARAMETER (D2THRD=DTWO/DTHREE) PARAMETER (DHALF=0.5D0) PARAMETER (DQUART=0.25D0) PARAMETER (D3QRT=0.75D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (C3=2.094D0) PARAMETER (D99=99.0D0) PARAMETER (D180=180.0D0) PARAMETER (D840=840.0D0) PARAMETER (DPT9=0.9D0) PARAMETER (D2PT5=2.5D0) PARAMETER (D2PT42=2.42D0) PARAMETER (D1PT5=1.5D0) PARAMETER (D1PT3=1.3D0) PARAMETER (D1PT1=1.1D0) PARAMETER (D1PT05=1.05D0) PARAMETER (D1M3=1.0D-3) PARAMETER (D1M30=1.0D-30) C COMMON /COM1/POT(MAXB1),DTOL,IEND COMMON /COM3/EE,ZN0,TLL COMMON /COM6/PQ(MAXB1) COMMON /COMIKE/PMIKE,QMIKE,pnorm COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBNUK/RNUK,SKIN,ATM,TK0,INUKE,INUK,INUK0 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C EQUIVALENCE (Y(1),A(7)) C MAXIT=25 IF(N.EQ.1)MAXIT=30 IF(BREL.AND.N.EQ.1)MAXIT=40 IF(DENE.GT.DZERO)MAXIT=45 BREL2=IABS(IREL).EQ.2 EMINIM=1.D-70 NK=5 NPRES=NPOINT ITERA=MAXIT BSHORT=.TRUE. IJPGT=0 NCORR=0 TLL=L*(L+1) NODES=N-L C C ZN=ASYMPTOTIC SCREENING CHARGE=POT(.GT.IEND)*X(.GT.IEND) C ZN=POT(NPOINT)*X(NPOINT) ZNS=VSC(NPOINT)*X(NPOINT) ZN0=ZN+ZNS C C CORRECT THE SCREENING CHARGE IF TOO LARGE C IF(Z-ZN.LT.SCREEN)SCREEN=Z-ZN C C NK=NUMBER OF TERMS IN THE WAVE EXPANSION AT THE ORIGIN (SEE DATA) C NC=NK-2 C C EXPAND POT(X)=PKOEF(1)/X+PKOEF(2) +..+PKOEF(NC+1)*X**(NC-1) C PKOEF(1)=DSIXTH DO I=1,NC A(I)=(POT(I)+VSC(I))*X(I)-Z PKOEF(I+1)=PKOEF(I)/X(1) ENDDO C PKOEF(1)=Z PKOEF(2)=((A(1)*2-A(2))*9+A(3)*2)*PKOEF(2) PKOEF(3)=(-A(1)*5+A(2)*4-A(3))*3*PKOEF(3) PKOEF(4)=((A(1)-A(2))*3+A(3))*PKOEF(4) C IF(BREL)NK=3 C C CALCULATE A FIRST APPROXIMATION TO THE EIGENVALUE C BNORM=.FALSE. ZS=Z-SCREEN E=-(ZS/N)**2 T=ZN/X(NPRES-5) IF(.NOT.BREL.AND.-E.LT.T)E=-T C C PLASMA POTENTIAL TE=DZERO IF(DENE.GT.DZERO)THEN 26 IF(MDEN.EQ.1)THEN T=N T1=ZN*DEBYE T1=T*T/T1 TE=(ZN/T)**2*(DONE-(DONE-T1)*EXP(-T1)) GO TO 28 ENDIF 19 IF(MDEN.EQ.2)THEN T1=D2PT42*ZN**D2THRD*DENE**DTHIRD T2=N*N*(5*N*N+1-3*L*(L+1)) T2=DHALF*T2/(ZN*ZN) T2=C3*DENE*T2 C 1.5 TO ALLOW FOR DENSITY DEPENDENT T2=D1PT5*T2 TE=T1-T2 TE=TE+TE GO TO 28 ENDIF IF(GAMQ.LT.D2PT5)THEN MDEN=1 GO TO 26 ELSE MDEN=2 GO TO 19 ENDIF 28 E=E+TE IF(E.GE.DZERO)THEN E=E-TE TE=TE*DPT9 GO TO 28 ENDIF ENDIF C Z0=Z ZW=ZN TLB=TLL TLW=TLL EH=-(Z/N)**2+TE IF(EH.GT.DZERO)EH=E+E IF(Z.EQ.ZN)EH=D1PT1*EH EL=-(ZN/N)**2+TE IF(EL.GT.DZERO)EL=DZERO IF(Z.EQ.ZN)EL=DPT9*EL IF(BREL)THEN TL=L T=(DFOUR*N/(TL+DHALF)-DTHREE) EH=EH-DQUART*DALF*(Z/N)**4*T EL=EL-DQUART*DALF*(ZN/N)**4*T E=E-DQUART*DALF*(ZS/N)**4*T IF(L.LE.0)THEN EH=EH+DALF*(Z/N)**4*N EL=EL+DALF*(ZN/N)**4*N E=E+DALF*(ZS/N)**4*N ENDIF ENDIF EE=E C C CALCULATE JOINING DISTANCE FOR INWARD AND OUTWARD INTEGRATION. WE C CHOOSE IT AS THE OUTER ONE OF THE TWO POINTS FOR WHICH THE SECOND C DERIVATIVE OF THE WAVE FUNCTION IS DZERO C 30 IF(E.GE.EL)THEN E=(E+EE)/DTWO EL=EL/D1PT05 IF(E.GT.EL) E=EL ENDIF 22 IF(E.LE.EH)THEN E=(E+EE)/DTWO EH=EH*D1PT05 IF(E.LT.EH) E=EH ENDIF EW=E EE=E IF(BREL)THEN EW=E+DQUART*DALF*E*E Z0=Z+DHALF*DALF*Z*E ZW=ZN+DHALF*DALF*ZN*E TLB=TLL-DALF*Z*Z TLW=TLL-DALF*ZN*ZN ENDIF C C THE SEARCH FOR RJ IS DONE STEP BY STEP FROM X(NPOINT) INWARDS JJ=NPOINT C ZW0=ZW C 31 ZW0=ZW+X(JJ)*VSC(JJ) RJ=DZERO IF(EW.LT.DZERO)RJ=-ZW0/EW IF(X(JJ).LE.RJ) GO TO 41 T=DTWO*(POT(JJ)+VSC(JJ))-TLL/X(JJ)**2+E IF(BREL)T=T+PMVDAR(JJ,X(JJ)) IF(T.LT.DZERO)THEN JJ=JJ-1 IF(JJ.GT.0)GO TO 31 GO TO 70 ENDIF rinf2=x(jj) c write(0,*)rinf2,e c 32 RJ=X(JJ) C C FIND THE JOINING POINT. WE TAKE AS JOINING POINT THE FIRST X C WHICH IS LARGER THAN THE JOINING DISTANCE. C 41 NOUTW=0 C WRITE(6,1001)JJ,X(JJ),RJ,ZN,E,TLL,POT(JJ),T C1001 FORMAT(I5,7F12.6) C C RUN THROUGH THE BIG (INDEX I) AND THE SMALL (INDEX J) INTERVALS DO I=1,NI NHI=I NC=NTI(I) DO J=1,NC NOUTW=NOUTW+1 IF(RJ.LE.X(NOUTW).AND.J.GE.4)THEN NTINHI=J II=NTI(I)-NTINHI IF(I.GT.1) GO TO 80 IJPGT=IJPGT-1 WRITE(6,996) JJ=NTI(1)+7 IF(IJPGT.GT.-10) GO TO 32 N=0 GO TO 250 ENDIF ENDDO ENDDO C 70 JJ=NPOINT-5 IJPGT=IJPGT+1 WRITE(6,997) IF(IJPGT.LE.4)GO TO 32 75 N=-N GO TO 250 C C SHIFT JOINING POINT IF TOO NEAR TO END OF INTERVAL C AS WE CALCULATE THE DERIVATIVE WITH 7 POINTS. C 80 IF(II.LT.4)THEN NOUTW=NOUTW-(4-II) NTINHI=NTINHI+II-4 ENDIF C C CALCULATE FIRST TWO POINTS FOR NUMEROV INTEGRATION WITH A SERIES C EXPANSION OF THE WAVE FUNCTION AT THE ORIGIN C IF(BREL)THEN TL=L A(1)=DONE IF(RNUK.LT.DZERO)THEN !POINT NK=2 B=DONE+(E+DFOUR/DALF)*X(1)/Z B=DONE/B B=B*B T=L*(L+1)-DALF*Z*Z+D3QRT*B TLAM=DQUART+T TLAM=SQRT(TLAM)-DHALF A(2)=(TLAM+DONE)*(TLAM+DTWO)-T A(2)=-DTWO*Z*(DONE+E*DALF/DTWO)/A(2) A(3)=TLAM/DTWO !FOR Q NORM ELSE !FINITE NK=3 A(2)=DZERO T=(L+2)*(L+3)-L*(L+1) IF(INUKE.EQ.0)THEN T1=DONE T3=DTHREE ELSE !U6 POTENTIAL T1=21 T1=T1/8 T3=63 T3=T3/16 ENDIF TNUK=T3*Z/RNUK TT=DONE+DQUART*DALF*(E+TNUK) TT=T1*D3QRT*DALF*Z/(TT*RNUK**3) TT=TT-(TNUK+E)*(DONE+DQUART*DALF) A(3)=TT/T ENDIF ELSE A(1)=DONE A(2)=-A(1)*PKOEF(1)/(L+1) TL=L DO I=3,NK II=I-1 A(I)=DZERO DO J=1,II A(I)=A(I)+A(J)*PKOEF(I-J) ENDDO A(I)=-(DTWO*A(I)+A(I-2)*E)/(II*(2*L+I)) ENDDO ENDIF C DO I=1,2 II=I+1 U(II)=DZERO !CONTAINS THE VALUE OF THE FUNCTION TLAM=TL DO J=1,NK T=J T=T+TL U(II)=U(II)+A(J)*X(I)**T ENDDO PQ(I)=U(II) IND(II)=I ENDDO C C CHECK THAT THE FUNCTION DOES NOT CHANGE SIGN BETWEEN THE FIRST TWO C POINTS. IF IT DOES, THEN PRINT ERROR MESSAGE AND STOP C IF(PQ(1)*PQ(2).LE.DZERO)THEN WRITE(6,991) N=0 GO TO 250 ENDIF C C C OUTWARD INTEGRATION C NC=NUMBER OF POINTS EXCLUDING THE ORIGIN FOR INTEGRATION. C XA=ORIGIN, XB=END OF INTEGRATION C NC=NTI(1)-1 XA=X(1) XB=X(NC+1) C C NODE AT THE ORIGIN DOES NOT COUNT C NODS=1 C C FIRST 2 POINTS C J=2 IX0=2 X0=Z0*Z0+TLB*EW if(x0.lt.dzero)then WRITE(6,*) X '*** SR.RADWAV ERROR: NO RADIAL SOLUTION FOR THIS POTENTIAL!' WRITE(0,*) X '*** SR.RADWAV ERROR: NO RADIAL SOLUTION FOR THIS POTENTIAL!' l=-999 go to 250 endif X0=SQRT(X0)+Z0 X0=TLB/X0 C C ARRAY INDEX IN NUMEROV MUST INCREASE (STEPS +1 OF INDEX TO X0) C IND(1)=1 DO I=1,NHI C CALL NUMERO(XA,XB,U,IND,NC,P) C DO II=2,NC J=J+1 PQ(J)=P(II) C C MAKE SURE THE SIGN OF PQ IS ALWAYS WELL DEFINED. C IF(PQ(J).EQ.DZERO)PQ(J)=EMINIM C C C START COUNTING NODES WHEN FIRST TURNING POINT IS REACHED C IF(X(J).GE.X0)THEN C C ANODE IMPLIES A CHANGE OF SIGN IN PQ C IF(PQ(J)*PQ(J-1).LT.DZERO)NODS=NODS+1 C C NOT YET TOO MANY NODES, OUTWARD INTEGRATION MAY GO ON C IF(NODS.GT.NODES)THEN C C TOO MANY NODES. THE PRESENT ABSOLUTE OF E THEREFORE REPRESENTS C ALOWER LIMIT EL C EL=E C C INCREASE THE ABSOLUTE OF E, BUT NOT BY TOO MUCH C E=E*D1PT5 IF(L.LT.5)GO TO 22 X1=-ZN*ZN/TLW IF(BREL)E=E-DQUART*DALF*E*E IF(E.LT.X1)E=DTWO*(E/DTHREE+X1)/DTHREE IF(.NOT.BREL)GO TO 22 T=SQRT(DONE-DALF*E) E=DTWO*(DONE-T)/DALF GO TO 22 ENDIF ELSE IX0=J ENDIF C ENDDO C C CALCULATE THE STARTING VALUES FOR NUMEROV FOR THE NEXT INTERVAL C IF(I.LT.NHI)THEN U(2)=P(NC-2) U(3)=P(NC) XA=X(J-2) IND(2)=J-2 IND(3)=J C C IND(3) GIVES THROUGH X(IND(3)) THE INITIAL POINT OF THE PARTICULAR C NUMEROV INTEGRATION C NC=NTI(I+1)+1 IF(I.EQ.NHI-1)NC=NTINHI+5 XB=X(J+NC-1) ENDIF ENDDO C C ELSE CHECK NODES C IF(NODS.NE.NODES)THEN C C CHECK WHETHER NUMBER OF NODES IS CORRECT C IF NOT ENOUGH NODES IN THE WAVE FUNCTION REDUCE THE ENERGY AND C START THE PROCESS AGAIN C THE PRESENT ABSOLUTE OF E THEN REPRESENTS AN UPPER LIMIT EH C EH=E E=E/D1PT3 C C START INTEGRATION AGAIN WITH NEW E C GO TO 30 C C C C FIND STARTING POINT X(NP) FOR INWARD INTEGRATION C ENDIF C C IF STARTING VALUE.LT.1.D0-30 MOVE INWARDS I=NPRES+5 IF(I.GT.NPOINT)I=NPOINT SQRE=SQRT(-E) SQRW=SQRT(-EW) IF(.NOT.BNORM)PNORM=DONE 151 NC=I 157 NP=I XA=X(NP) I=I-4 IF(I.LE.NOUTW)THEN WRITE(6,993)MSTEP GO TO 75 ENDIF C C THE STARTING VALUES WILL BE CALCULATED WITH A WHITTAKER FUNCTION C EXP(-SQRT(-E)*XA) MUST NOT BECOME DZERO-REDUCE IF MACHINE ALLOWS C IF(XA*SQRW.GE.D180)GO TO 151 C ZW0=ZW+X(NP)*VSC(NP) C PO=WHITEX(XA,TLAM,EW,ZW0,BNORM) C IF(.NOT.BNORM)PNORM=DONE PO=ABS(PO)*PNORM IF(PO.GE.D1M30)GO TO 152 IF(I.GT.IEND)GO TO 157 IF(PO.LT.EMINIM)GO TO 151 C C THE FUNCTION WILL BE CALCULATED FOR ALL X.LE.X(NP) C 152 NPRES=NP IF(BSHORT)THEN NP=IEND+5 IF(NOUTW.GT.IEND) NP=NOUTW+5 NP=NP+NCORR IF(NP.GT.NPRES) NP=NPRES ENDIF C C CHECK WHETHER NEW STARTING POINT FALLS NOT TOO NEAR TO END OF C INTERVAL; PP WILL BE USED FOR DERIVATIVES, NTI(NHI) FOR WEDDLE C II=0 PP=DXI(NHI)*D840 DO J=1,NI IF(NTI(J).LT.8) GO TO 156 NHI=J JJ=II+NTI(J) IF(JJ.LT.NP)GO TO 155 IF(JJ.EQ.NP)GO TO 140 IF(NP-II.GE.8) GO TO 140 NP=II+8 IF(NP.LE.NC) GO TO 140 NHI=J-1 NP=II II=II-NTI(J-1) IF(NOUTW+4.GT.NP)GO TO 156 GO TO 140 155 II=JJ ENDDO C 156 WRITE(6,994) N=0 GO TO 250 140 NTINHI=NTI(NHI) NTI(NHI)=NP-II C C C INWARD INTEGRATION C ARRAY INDEX IN NUMEROV MUST DECREASE (IND(1) NEGATIVE) C C GIVE THE STARTING VALUES FOR THE NUMEROV INTEGRATION C CALCULATE THE TWO OUTERMOST POINTS WITH THE WHITTAKER FUNCTION C XA=X(NP) ZW0=ZW+X(NP)*VSC(NP) C P(NP)=WHITEX(XA,TLAM,EW,ZW0,BNORM)*PNORM C I=NP-1 XB=X(I) ZW0=ZW+X(I)*VSC(I) C U(3)=WHITEX(XB,TLAM,EW,ZW0,BNORM)*PNORM C IF(BNORM) GO TO 159 U(3)=(U(3)/P(NP))*D1M30 P(NP)=D1M30 GO TO 159 C C C A NEW INTERVAL WITH A SMALLER SET UP HAS BEEN ENTERED. C THE SECOND STARTING POINT HAS TO BE CALCULATED BY AN INTERPOLATION, C AT 6 EQUIDISTANT POINTS X(J): J=I+3,I+2,I+1,I-1,I-3,I-5. C INTEGRATE OVER ANOTHER 3 INTERVALS OF THE OLD LENGTH C 170 IND(1)=-2 I=I-1 DO J=1,4 Y(J)=X(I+3-2*J) ENDDO XB=Y(4) C CALL NUMERO(XA,XB,U,IND,4,A) C Y(5)=X(I+3) Y(6)=X(I+2) A(5)=P(I+3) A(6)=P(I+2) C C INTERPOLATE TO GET A FUNCTION VALUE P(I) AT X(I), THEN PROCEED C TO USE NUMERO C U(3)=DZERO DO II=1,6 XA=DONE XB=DONE DO JJ=1,6 IF(JJ.NE.II)THEN XA=XA*(X(I)-Y(JJ)) XB=XB*(Y(II)-Y(JJ)) ENDIF ENDDO U(3)=A(II)*XA/XB+U(3) ENDDO C 159 P(I)=U(3) C C ASSIGN STARTING VALUES FOR THE CONTINUATION OF THE NUMEROV C INTEGRATION C U(2)=P(I+1) C C C INTEGRATE INWARDS TO THE MATCHING POINT C 160 IND(2)=I+1 IND(3)=I C THE U(2),U(3) ALREADY CONTAIN THEIR PROPER VALUES. XA=X(I+1) C C DETERMINE NEW I AND INTERVAL C I SHALL GIVE THE ARRAY INDEX OF XB C DO J=2,12 C IF THE END HAS NOT BEEN REACHED YET, CONTINUE WITH THE INTEGRATION IF(I.LE.NOUTW-4)THEN IF(J.EQ.2) GO TO 190 GO TO 180 ENDIF C CHECK WHETHER THE NEW STEP HAS THE SAME LENGTH AS THE PREVIOUS ONE IF(X(I+1)-X(I).GT.(X(I)-X(I-1))*D1PT05 )THEN IF(J.EQ.2) GO TO 170 GO TO 180 ENDIF I=I-1 NC=J ENDDO C 180 IND(1)=-1 XB=X(I) C CALL NUMERO(XA,XB,U,IND,NC,A) C C STORE RESULT IN P C DO J=2,NC II=I+NC-J P(II)=A(J) ENDDO GO TO 160 C C C IF INWARD AND OUTWARD FUNCTIONS HAVE DIFFERENT SIGNS, CHANGE C THE SIGN OF THE INWARD FUNCTION. C SCALE OUTWARD AND INWARD FUNCTION TO PQ(NOUTW)=P(NOUTW)=1.*SIGN(P) C 190 RJ=DONE/ABS(P(NOUTW)) C WRITE(6,1003)PQ(NOUTW),P(NOUTW) IF(PQ(NOUTW)*P(NOUTW).LT.DZERO)RJ=-RJ II=NOUTW-4 DO I=II,NP P(I)=P(I)*RJ ENDDO QUOT=ABS(DONE/PQ(NOUTW)) JJ=NOUTW+4 DO I=1,JJ PQ(I)=PQ(I)*QUOT ENDDO C C CALCULATE DERIVATIVES XB AND XA OF INWARD AND OUTWARD FUNCTIONS C I=NOUTW XB=( 672*(P(I+1)-P(I-1))-168*(P(I+2)-P(I-2)) X +32*(P(I+3)-P(I-3))-3*(P(I+4)-P(I-4)) )/PP XA=( 672*(PQ(I+1)-PQ(I-1))-168*(PQ(I+2)-PQ(I-2)) X +32*(PQ(I+3)-PQ(I-3))-3*(PQ(I+4)-PQ(I-4)) )/PP C C CALCULATE P(X)*P(X), INTEGRATE THAT FUNCTION AND CALCULATE C THE ENERGY CORRECTION ACCORDING TO HARTREE PO=DZERO DO I=1,NOUTW P(I)=PQ(I) IF(ABS(P(I)).GT.PO)PO=ABS(P(I)) PQ(I)=PQ(I)*PQ(I) ENDDO C PMIN=PO*EMINIM IF(P(NOUTW).LT.DZERO)PMIN=-PMIN POO=PO*D1M30 DO I=NOUTW,NP IF(ABS(P(I)).LT.POO)P(I)=PMIN PQ(I)=P(I)*P(I) ENDDO C C INTEGRATE P(X)*P(X) AND CORRECT ASYMPTOTICALLY; RESTORE NTI(NHI) C CALL WEDDLE(DZERO,PQ,PP,NTI,DXI,NHI,NP) C NTI(NHI)=NTINHI PO=PQ(NP)/(DTWO*SQRW) PP=PP+PO C C ENERGY CORRECTION; E MUST NOT BECOME POSITIVE C DE=P(NOUTW)*(XB-XA)/PP IF(EW.GE.DE) DE=EW/D1PT5 C WRITE(6,1001)NOUTW,XA,XB,DE,PP C C ENERGY CORRECTION; E MUST NOT BECOME SO NEGATIVE THAT THERE CAN C NO OUTWARD TURNING POINT. C IF(L.GE.5)THEN XB=-ZN*ZN/TLW T=EW-DE IF(.NOT.BREL)THEN IF(T.LT.XB)DE=DTWO*(EW-XB)/DTHREE ELSE TT=E-DQUART*DALF*E*E E=SQRT(DONE+DALF*T) E=DTWO*(E-DONE)/DALF T=E-DQUART*DALF*E*E IF(T.LE.XB)THEN T=(TT+DTWO*XB)/DTHREE T=SQRT(DONE-DALF*T) E=DTWO*(DONE-T)/DALF TT=E+DQUART*DALF*E*E DE=EW-TT ENDIF ENDIF ENDIF C C THE APPROXIMATION IS TERMINATED WHEN THE RELATIVE CORRECTION TO C THE EIGENVALUE IS SMALLER THAN DTOL C XB=ABS(DE/EW) IF(.NOT.BSHORT)THEN IF(XB.LT.DTOL)GO TO 225 ENDIF C ITERA=ITERA-1 IF(XB.LT.D99*DTOL.OR.ITERA*2.LT.MAXIT)BSHORT=.FALSE. EW=EW-DE IF(BREL)THEN T=SQRT(DONE+DALF*EW) DE=E-DTWO*(T-DONE)/DALF ENDIF E=E-DE IF(PO.GT.D1M3*PP) NCORR=NCORR+10 PNORM=ABS(RJ)*PNORM IF(ITERA.GE.0)GO TO 30 C WRITE(6,990) E,DE, MAXIT, N,L IF(XB.GT.D99*DTOL)THEN WRITE(6,*)'*** SR.RADWAV ERROR: RADIAL FUNCTION TOO INACCURATE' WRITE(0,*)'*** SR.RADWAV ERROR: RADIAL FUNCTION TOO INACCURATE' L=-999 GO TO 250 ENDIF C C NORMALIZE THE FUNCTION C SET ALL FUNCTION VALUES FOR X.GE.X(NP) TO DZERO C 225 PNORM=DONE/SQRT(PP) IF(P(IX0).LT.DZERO)PNORM=-PNORM PMIN=PMIN*PNORM DO I=1,NPOINT IF(I.GT.NP)P(I)=PMIN P(I)=P(I)*PNORM ENDDO PO=POT(NP)*X(NP) IF(NP.LE.IEND)WRITE(6,992)NP,X(NP),PO,ZN,N,L C C DMIKE CONTAINS THE CORRECT ANORM FOR THE STARTING EXPANSION C IF(PNORM.LT.DZERO)PNORM=-PNORM PMIKE=PNORM*QUOT QMIKE=(DTWO*PKOEF(2)+E)*PMIKE C C CALCULATE THE CORRECT SCREENING VALUE C EA=E SCREEN=Z-N*SQRE C pnorm=done IF(.NOT.BREL)GO TO 250 !RETURN C C NORMALIZE TRANSFORMED RELATIVISTIC SOLUTION C DO I=1,NP PQ(I)=P(I)*P(I)*(POT(I)+VSC(I)) ENDDO C CALL WEDDLE(DZERO,PQ,PP,NTI,DXI,NHI,NP) C PNORM=DONE+DQUART*DALF*(E+DTWO*PP) PNORM=DONE/SQRT(PNORM) c w=done !standard Darwin c if(l.gt.0)w=-2. DO I=1,NP PP=DONE+DQUART*DALF*(E+DTWO*(POT(I)+VSC(I))) pp=abs(pp) PP=SQRT(PP) c pp=pp**(w/dtwo) P(I)=P(I)*PNORM*PP c pq(i)=p(i)*p(i) ENDDO c c call weddle(dzero,pq,pp,nti,dxi,nhi,np)!further renorm for w.ne.1 c pp=done/sqrt(pp) c pnorm=pnorm*pp c do i=1,np c p(i)=p(i)*pp c enddo c write(0,*)l,pp c PP=DONE IF(RNUK.GT.DZERO)PP=PP+DQUART*DALF*(E+DTHREE*Z/RNUK) PP=SQRT(PP) PMIKE=PMIKE*PNORM*PP QMIKE=QMIKE*PNORM*PP C c IF(BREL2)THEN QMIKE=DHALF*DFSC*PMIKE IF(L.EQ.0)QMIKE=QMIKE*DTWO*A(3) IF(L.GT.0)QMIKE=QMIKE*TLAM c tkap=-1 c if(l.gt.0)tkap=l !-l-1 or l !see also pmvdar C CALL DIFF(P,PQ,NTI,DXI,NI) C DO I=1,NP T=DONE+DQUART*DALF*(E+DTWO*(POT(I)+VSC(I))) t=abs(t) Q(I)=DHALF*DFSC*(PQ(I)+tkap*P(I)/X(I))/T C Q(I)=DZERO PQ(I)=Q(I)*Q(I) ENDDO C CALL WEDDLE(DZERO,PQ,PP,NTI,DXI,NHI,NP) C PNORM=DONE+PP PNORM=DONE/SQRT(PNORM) if(brel2)then DO I=1,NP Q(I)=Q(I)*PNORM P(I)=P(I)*PNORM ENDDO PMIKE=PMIKE*PNORM QMIKE=QMIKE*PNORM C IF(NPOINT.GT.NP)THEN QMIN=PNORM*PMIN*Q(IX0)/P(IX0) DO I=NP,NPOINT Q(I)=QMIN ENDDO ENDIF ENDIF C TL=L T=-DQUART*DALF*(DFOUR*N/(TL+DHALF)-DTHREE) IF(L.EQ.0)T=T+DALF*N TL=DONE+DFOUR*T*E TL=SQRT(TL) TL=(DONE-TL)/(DTWO*T) SQRE=SQRT(TL) SCREEN=Z-N*SQRE C C 250 RETURN C 997 FORMAT( ' RADWAV: JOINING DISTANCE GT LIMIT') 996 FORMAT( ' RADWAV: JOINING POINT LIES IN FIRST INTERVAL -- HAS CHA XRGE Z GONE OUT OF HAND') C (Z WRONG, OR SIGMA0 POORLY SPECIFIED) 994 FORMAT( ' RADWAV: MIXUP IN JOINING AREA (CHECK NTI-INPUT FIRST)') 993 FORMAT( ' SR.RADWAV: WHITEX ALWAYS ZERO -- TRY BIGGER INTEGRATION X RANGE - MORE POINTS (INCREASE MAXB1 2) OR LONGER STEPS (DECREASE' X,' MSTEP IN NAMELIST SMINIM)'/' CURRENTLY, MSTEP=',I3) 992 FORMAT( ' RADWAV-WARNING: INWARD-INTEGRATION STARTED AT X(',I5, X') =',F7.3, ': Z(X)-ZN =',F10.6,' -',F3.0,5X, 'FOR (N L) =',2I3) 991 FORMAT( ' RADWAV: CHANGE OF SIGN AT BEGINNING') 990 FORMAT( ' SR.RADWAV GIVES UP WITH (E,DE)=',2F13.7,' AFTER',I3, ' XITERATIONS OF (N,L)=',2I2,'. CHECK WHETHER PRECISION GOOD ENOUGH') C END C C ******************* C C SUBROUTINE RADWIN(MXQIN,MAXPS) C WRITE(6,200) C RETURN C 200 FORMAT(' SR.RADWIN: THIS IS A DUMMY SUBROUTINE VERSION') C END C C ******************* C SUBROUTINE RADWIN(MXQIN,MAXPS) C C----------------------------------------------------------------------- C C SR.RADWIN READS RADIAL FUNCTION INPUT AND PROCESSES IT FOR C ORBITALS K MARKED BY SIGMA(K).GE.999 & .LT. 5999. IT EXPECTS INPUT C IN COLLALG/IMPACT FORMAT -- UNLESS KEY.NE.-9 IN (T1,I5) OF FIRST C C AFTER A HEADING CARD WITH KEY.GE.0, THIS VERSION OF SR.RADWIN C READS HARTREE-FOCK-FROESE FUNCTIONS P(N,L) AND Q(N,L) AS PROVIDED C BY H.SARAPH OR D.C.GRIFFIN FROM CHARLOTTE FROESE'S PROGRAM AT C THE USUAL RADII. PROGRAM ASSUMES THESE ARE BOUND FUNCTIONS. C USE KEY .EQ. -20 TO READ IN CONTINUUM FUNCTIONS (FORMAT SAME AS C OUTPUT RADIAL FUNCTIONS PRODUCED BY AUTOSTRUCTURE). C NOTE KEY CAN BE REDEFINED BETWEEN ORBITALS SO A MIXTURE OF BOUND AND C CONTINUUM FUNCTIONS CAN BE READ IN. ALTERNATIVE BRANCHES MAY BE C INSERTED USING KEY. C EXTENDED SO AS TO READ AND PROCESS STO INPUT IF KEY=-10. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD14=100) PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C LOGICAL BLAG,BBC2,BPRNT,BSTO,BORT,BREL,BJUMPR,BNAME,HFF X ,BJUMP,BJUMP2,BRAD,BMVD,BFIX C PARAMETER (IREAD=5) PARAMETER (OVRLP=2.D-6) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DEIGHT=8.0D0) PARAMETER (D999=999.0D0) PARAMETER (D3999=3999.0D0) PARAMETER (D5999=5999.0D0) PARAMETER (D1M1=1.0D-1) PARAMETER (D1M2=1.0D-2) PARAMETER (D1M4=1.0D-4) PARAMETER (D1M5=1.0D-5) PARAMETER (D1M6=1.0D-6) PARAMETER (D1M7=1.0D-7) PARAMETER (D1M10=1.0D-10) PARAMETER (D1P10=1.0D10) PARAMETER (ID=4) PARAMETER (CON1=85.196D0) C CHARACTER(LEN=4) MBLNK,MHEAD C DIMENSION DOVLP(MAXGR),BH(MAXB1),DORIG(MAXGR) X,DY(0:MAXB1),BP(MAXB1),BQ(MAXB1),KHLP(MAXB1) * ,JRAD(0:22),ZE(0:22),CJ(0:22) C COMMON /BASIC/NF,KVV,HFF,MGAP(9) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DA(MAXB1),TDUM,MDMM COMMON /COM6/DPH(MAXB1) COMMON /CRAD/DHNS(20),MNE(20),MJH,MXR,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),DSIGMA(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /JSPOR/NJO,NRR(MAXLV),NT(MAXJG),JJ(MAXLV),NGR(MAXLV) COMMON /NXRNL/NL000,NL COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,ORIG(MAXGR) COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR) X ,D2LL(MAXGR,MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHL,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBNAM/BNAME,NF0 COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBRAD/IRAD(MAXGR) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBSPL/DSP1(MAXB1),DSP2(MAXB1),DSP3(MAXB1),DSP4(MAXB1) COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD C EQUIVALENCE (BP(1),DPH(1)), (BQ(1),DA(1)) X , (DY(1),DSP2(1)), (KHLP(1),DSP1(1)), (BH(1),DSP3(1)) C NAMELIST/SRADWIN/KEY,MR,ACE !,MDUM C DATA MXPIN/MAXB1/,MBLNK/' '/ C IPMX=0 DY(0)=DZERO MR=IREAD MWR=10 MHLP=0 BLAG=.FALSE. BPRNT=JPRINT.NE.-3 MINK=0 MSHFT=10000 KEY=0 IORB=0 SCREEN=DONE DZ=NZION BORT=MORT.LT.0 IF(.NOT.BORT)WRITE(6,101) K00=1000 KST=1 C IF(NF.GT.0)THEN DO K=1,MAXGR DORIG(K)=DZERO IF(DEY(K).EQ.DZERO)GO TO 66 IF(DSIGMA(K).GE.D999.AND.DSIGMA(K).LT.D5999)GO TO 66 DORIG(K)=ORIG(K)*DZ 66 ENDDO II=1 ENDIF 70 MXE=MXPIN C IF(BNAME)THEN MRR=MR MR=0 C MDUM=0 ACE=DZERO KEY0=KEY KEY=-9 IF(KEY0.NE.-9)THEN C READ(MRR,SRADWIN,END=1000,ERR=1000) ! <------------- NAMELIST C KEY0=KEY IF(KEY.EQ.-15)KEY=-9 ENDIF IF(KEY.EQ.-10.AND.MR.EQ.0)MR=MRR MORE=MR ELSE IF(KEY.NE.-9)READ(MR,590)KEY,MORE ,ACE C ,MDUM ENDIF C IF(KEY.GE.0.AND.KEY.LT.10)BPRNT=.FALSE. IF(MORE.GT.0)MR=MORE IF(MORE.LE.0)MR=MWR+2 IF(MR.NE.IREAD)THEN IF(IUNIT(MR).EQ.0)THEN WRITE(6,*)"MISSING INPUT FILE='radwin'..." WRITE(0,*)'MISSING FILE ON UNIT=12' GO TO 99 ENDIF REWIND(MR) ENDIF C MXORB=0 MPS=0 C IF(KEY.EQ.-9)READ(MR,589)KEY,MXORB,MPS,MPMX C IF(MXORB.LE.0)MXORB=MAXGR IF(IABS(MPSEUD).GT.0.AND.MPS.NE.IABS(MPSEUD))THEN WRITE(6,*)'CLOSED-SHELL POTENTIAL INPUT TO RADWIN NOT' X ,' CONSISTENT WITH CLOSED-SHELL DEFINITION IN ALGEB',MPS,MPSEUD WRITE(0,*)'CLOSED-SHELL POTENTIAL INPUT TO RADWIN NOT' X ,' CONSISTENT WITH CLOSED-SHELL DEFINITION IN ALGEB' GO TO 99 ENDIF C J=KEY IF(KEY.NE.-20)GO TO 11 IF(MODE.EQ.1)MODE=2 C IF(MDUM.GT.0)MODE=MDUM IF(MODE.GT.0.AND.MODE.LT.4)GO TO 1 WRITE(6,593)MODE GO TO 99 C 1 IF(MHLP.NE.0)GO TO 72 IF(ACE.LT.D1M4)ACE=D1P10 IF(BPRNT)WRITE(6,592) KEY, MODE, ACE C C C FOR CONTINUUM WAVEFUNCTION WE DROP ALL POINTS PAST INPUT MAXPS C SINCE ALL INTEGRALS P*F, P*P SHOULD HAVE CONVERGED BY THEN, C UNLESS GOING INTO SR.RADCON NEXT. C MPMX=MXR MAXTS=MAXPS if(maxps.eq.0)maxts=mxr IF(MAUTO.EQ.0)MAXTS=MXR MJH0=MJH MXR=0 DO I=1,MJH0 MXR=MNE(I)+MXR MJH=I IF(MXR.EQ.MAXTS)GO TO 18 IF(MXR.GT.MAXTS)THEN MXR=MXR-MNE(I) MNE(I)=MAX0(MAXTS-MXR,9) MXR=MXR+MNE(I) GO TO 18 ENDIF ENDDO C 18 IF(BPRNT)WRITE(6,250) MXR ,MPMX 72 IF(KEY.NE.-20)GO TO 12 C READ(MR,591)MYN,MYL,DDY,MPMX,MHEAD,MP C C PROGRAM ASSUMES SAME ENERGY FOR EACH CONTINUUM ORBITAL, WILL PUT DDY C IN DYY(NREL) FOR NOW WHERE NREL=1 IS DEFAULT SET IN SR.RADIAL, C NO DSHIFT AND NO INTERPOLATION POSSIBLE. C C MP .GT. 0 PRINTS OUT INPUT FUNCTION AS INTERPOLATED ONTO C SUPERSTRUCTURE GRID. MP .GT. 5 PRINTS OUT CONTIUUM FUNCTION ON C ORIGINAL GRID C IF(MYL.LT.0)GO TO 79 IF(MPMX.GT.0)GO TO 13 IF(MPMX.EQ.0)GO TO 79 MHLP=1 GO TO 70 13 IF(DDY.LT.DZERO)WRITE(6,997)DDY C DO I=1,MPMX IF(I.LE.MXE)THEN READ(MR,998)L,DY(I),BP(I),BQ(I) IF(MP.GT.5)WRITE(6,998)L,DY(I),BP(I),BQ(I) ENDIF ENDDO C DP0=DZERO IF(DY(1).GT.DZERO)DP0=BP(1)/DY(1)**(MYL+1) IF(MHLP.GE.0)GO TO 40 GO TO 14 C 11 IF(BPRNT)WRITE(6,250) MXR,MXR DP0=DZERO DDY=DZERO IF(KEY.EQ.-9)GO TO 43 IF(KEY.EQ.-10)GO TO 12 C C ASSUME MXE.LE.MXPIN POINTS DY FOR (HARTREE-FOCK-FROESE) CARD INPUT C (ADDITIONAL CARDS WILL BE SKIPPED-DO49; 2 POINTS PER CARD) C DM=DONE/(DFOUR*DFOUR) DD=-DFOUR C DO I=1,MXE DY(I)=EXP(DD)/DZ DD=DD+DM ENDDO GO TO 40 C C ADDRESS ARRAY KHLP WILL HELP TO INTERP. DY ONTO DX 41 MXE=IPMX 40 II=1 MHLP=-1 DO K=1,MXR KHLP(K)=0 GO TO 82 81 II=II+1 82 IF(II.GT.MXE)GO TO 85 IF(II.EQ.MXE)GO TO 84 IF(DY(II+1)+DY(II).LT.DX(K)*DTWO)GO TO 81 84 IF(DX(K).GT.DY(MXE))GO TO 81 KHLP(K)=II 85 ENDDO C IF(KEY.EQ.-20)GO TO 14 12 MYN=0 N=0 NSTO=0 DP0=DZERO IORB=IORB+1 IF(IORB.GT.MXORB)GO TO 79 IF(KEY.GE.0) GO TO 42 C READ(MR,570,END=79)J,N,MYN,MYL,DDY,MPMX,MHEAD,MP C IF(J.EQ.0)GO TO 79 IF(J.EQ.-5)GO TO 79 SCREEN=DZERO MPMX=MPMX*2 DDY=-ABS(DDY) !COMPENSATE FOR MCHF IF(KEY.GE.-9)GO TO 43 IF(J.LE.0)GO TO 43 C C COMPUTE SLATER TYPE ORBITALS FROM INPUT IN RMATRX/STG1 FORMAT, C I.E. READ ISTO(K),ZESTO(K),CSTO(K), WHEN KEY=-10. C MPMX=0 MP=0 MHEAD=MBLNK DY(1)=DZERO INORM=N N=J READ(MR,*)(JRAD(K),K=1,N) READ(MR,*)(ZE(K),K=1,N) READ(MR,*)(CJ(K),K=1,N) NSTO=N C C --- COMPUTE P AND Q BAR0, AND SATISFY CUSP CONDITION IF SO TOLD BY MYN 88 K=1 32 L=JRAD(K) DM=DZERO DD1=DZERO DP0=DZERO DD2=DZERO DQ0=DZERO DO K=1,N IF(JRAD(K).LT.L)GO TO 32 IF(JRAD(K).EQ.L)THEN IF (ZE(K).GT.DM) DM=ZE(K) DP0=CJ(K)+DP0 DD=ZE(K)*CJ(K) DD1=DD+DD1 DQ0=(DZ*2-(2*L+1)*ZE(K))*DD+DQ0 ELSEIF(JRAD(K).EQ.L+1)THEN DD2=CJ(K)+DD2 DQ0=((L*2+1)*ZE(K)-DZ)*2*CJ(K)+DQ0 ENDIF ENDDO C JRAD(0)=L if(myn.le.0)MYL=L-1 MYN=-1 !**** NRB CJ(0)=DZERO ZE(0)=DZ C C TRY IF (ZE(0).LE.DM*1.1) MYN=-2 C MODIFY Z(0) FOR CUSP CORRECTION IF REQUIRED. C DDY=DZERO IF(MYN+1.NE.0)THEN IF(MYN+1.LT.0)ZE(0)=-MYN*DM DD=(DD2-DD1)*L+DZ*DP0 IF(ABS(DD).LT.D1M5)GO TO 35 IF(L*ZE(0).LE.DZ)ZE(0)=(DZ+DONE)/L CJ(0)=DD/(L*ZE(0)-DZ) DP0=CJ(0)+DP0 DDY=(DZ*2-(2*L+1)*ZE(0))*ZE(0)*CJ(0)+DQ0 ENDIF DQ0=DDY C 35 SCREEN=CJ(0) C ###### POSSIBLY TEMPORARY, FOR PRINTING C(0) CUSP CORRECTION. c DDY=-ZE(0) DDY=DZERO C DO K=1,MAXGR IF(2*MYL.NE.QL(K))GO TO 36 IF(DEY(K).EQ.DZERO)GO TO 36 IF(DORIG(K).NE.DZERO)GO TO 36 MYN=MOD(QN(K),70) GO TO 28 36 ENDDO C WRITE(6,800) GO TO 72 C C --- COMPUTE SLATER TYPE ORBITAL AT THE INTERNAL GRID POINTS (I=1,MXR) C 28 MYLLP=MYL*(MYL+1) !CASE PSEUDO, NOT X**(L+1) DO I=1,MXR DD1=DX(I) J=L DD2=DD1**J DM=(MYLLP/DD1-2*DZ)/DD1 BP(I)=DZERO BQ(I)=DZERO DO K=0,N IF (ZE(K)*DD1.LT.CON1)THEN IF(JRAD(K).NE.J)DD2=DD1**JRAD(K) J=JRAD(K) DD=CJ(K)*DD2*EXP(-ZE(K)*DD1) BP(I)=DD+BP(I) BQ(I)=(((1-J)/DD1+ZE(K)*2)*J/DD1-ZE(K)*ZE(K)+DM)*DD+BQ(I) ENDIF ENDDO ENDDO C J=KEY GO TO 34 C C-- END OF STO EXTENSION C 42 READ(MR,600,END=79)MYN,MYL,J,N,DDY,SCREEN,MPMX,DP0,DM,MHEAD,MP C C A BLANK (P/Q) HEADING CARD SERVES AS A DATA INPUT TERMINATOR. C 43 IF(MPMX.LT.0)GO TO 70 IF(MPMX.EQ.0)GO TO 79 C C DO 49 PROCESSES A RANDOM ORDERED SET THAT MAY EXCEED BUFFER SIZES. C DO 49 I=1,MPMX,2 C READ(MR,600)L,L,L,I1,DD1,DD,I2,DD2,DM C I2=I1+1 IF(J.NE.-9)GO TO 46 IF(I1.GT.MXE)GO TO 49 IF(I1.EQ.MXE)GO TO 45 DY(I2)=DD2 BH(I2)=DM 45 DY(I1)=DD1 BH(I1)=DD GO TO 49 46 IF(I1.GT.MXE)GO TO 49 IF(I1.EQ.MXE)GO TO 48 BP(I2)=DD2 BQ(I2)=DM 48 BP(I1)=DD1 BQ(I1)=DD 49 CONTINUE C IF(DP0.EQ.DZERO.AND.DY(1).GT.DZERO)DP0=BP(1)/DY(1)**(MYL+1) IF(DDY.GT.DZERO)WRITE(6,996)DDY C 14 IF(NF.LE.0)GO TO 72 IF(MXQIN.EQ.1)GO TO 72 IPMX=MIN0(MPMX,MXE) IF(J.EQ.-9)GO TO 41 C IF(N.LE.-MPSEUD)GO TO 72 ! POTENTIAL DERIVATIVE IF(MPSEUD.LT.0.AND.N.LE.IABS(MPSEUD))GO TO 72 !CASE N=0 & MPSEUD=0 C REQUIRES A CONSISTENT ORBITAL NUMBER BE READ-IN. IF(KEY.NE.-20)THEN L=MPMX-IPMX IF(MPMX.GT.MXE+1)WRITE(6,580)L,MPMX,MXPIN,MXE,DY(IPMX),BP(IPMX) ENDIF C 34 II=MXR-2 IF(BPRNT)WRITE(6,100)DDY,MHEAD,MP, MYN,MYL IF(KEY.NE.-20.AND.DDY.EQ.DZERO)DDY=-D1M10 IF(MPSEUD.GT.0.AND.N.LE.MPSEUD)GO TO 69 ! DITTO N=0 C DO K=1,MAXGR IF(2*MYL.NE.QL(K))GO TO 68 IF(DORIG(K).NE.DZERO)GO TO 68 IF(DEY(K).EQ.DZERO)GO TO 68 C IF(K.LE.IABS(MPSEUD))GO TO 68 N=K IF(N.LT.K00)K00=N MQN=MOD(QN(K),70) IF(MQN.NE.IABS(MYN))THEN WRITE(6,940)K,MYN WRITE(0,*) 'SR.RADWIN: MIS-MATCH OF ORBITALS?',K,MQN,MYN C GO TO 99 ENDIF IF(QN(K).LT.80.AND.QN(K).GT.69)QN(K)=IABS(MYN) IF(KEY.GE.0.AND.JPRINT.NE.-3)WRITE(6,995)QN(N),MYL IF(DDY.LT. DZERO)GO TO 69 QN(N)=-QN(N) IYY(N)=1 DYY(NREL)=DDY C N.B.DYY CONTAINS INTERPOLATION ENERGIES. PROGRAM ASSUMES SAME C INTERPOLATION ENERGY FOR EACH CONTINUUM ORBITAL. GO TO 69 68 ENDDO C WRITE(6,800) GO TO 72 C 69 IF(DP0.NE.DZERO)GO TO 60 DP0=BP(1) BP(1)=DZERO BQ(1)=DZERO C C ALLOW FOR CONTINUUM ELECTRON WITH ZERO ENERGY C NEW IF(BP(IPMX).EQ.DZERO) IPMX=IPMX-1 C LAGRANGE INTERPOLATION (ID+1 POINTS) FROM ARGUMENTS DY TO DX(L) C 60 DO L=1,MXR ML=L DD1=BP(L) DD2=BQ(L) DD3=DZERO IF(NSTO.NE.0)GO TO 74 DD2=DZERO DD1=DZERO IF(DX(L).GT.DY(IPMX))GO TO 74 C FUNCTION VALUES BEYOND THE SUPPLIED AND HELD RANGE ARE SET =0. M=KHLP(L)-ID/2 I1=MAX0(M,1) I2=I1+ID IF(I2.GT.IPMX)I2=IPMX DO I=I1,I2 DD=DONE DM=DONE DO J=I1,I2 IF(J.NE.I)THEN DM=(DX(L)-DY(J))*DM DD=(DY(I)-DY(J))*DD ENDIF ENDDO DD2=BQ(I)*DM/DD+DD2 DD1=BP(I)*DM/DD+DD1 DD3=BH(I)*DM/DD+DD3 ENDDO J=KHLP(L) IF(MP.GT.0)WRITE(6,999)L,DX(L),J,I1,I2,DY(J),DD1 74 IF(L.LE.MXQIN)DQNL(L,N)=DD2 DPNL(L,N)=DD1 POTHAM(L)=DD3/DX(L) IF(ABS(DD1).GT.D1M6)MAXPS=MAX0(MAXPS,ML) ENDDO C DD3=DZERO ORIG(N)=DP0 DORIG(N)=DP0*DZ IF(N.LE.MPSEUD)GO TO 72 ! BLUME & WATSON C IF(MPSEUD.GT.0.AND.N.LE.MPSEUD)GO TO 72 ! BLUME & WATSON C C GENERATE A Q-FUNCTION INTERNALLY IF NONE SUPPLIED (KEY=-15) C E.G. IF INPUT FROM GRASP. C IF(KEY0.EQ.-15)THEN DTOL=D1M2 TOL=D1M7 MPP=1 IORT=IABS(MORT) DHNS0=DHNS(1) DJ=DAJOLD(N) DJ0=DJ MK=N NELC=MION !-MRED DS=DZ IF(DJ.GT.DZERO) GO TO 611 IF(IORT.EQ.2)GO TO 611 IF(BREL)GO TO 611 C IF(IORT.LT.4)DS=-DJ*DZ !HYDROGENIC WAVE FUNCTIONS IF(IORT.EQ.4)DS=-QN(MK)*(NZION-NELC+1)*DJ/DTWO !PSEUDO-STATES IF(IORT.EQ.5)DS=-(NZION-NELC+1)*DJ !BOX-STATE BASIS C NELC=1 DJ0=DONE C 611 IF(.NOT.BSTO)CALL TFDAPO(DS,NELC,MK,DJ0,DONE,DONE,DHNS0,MXR,MJH X ,MNE,DHNS,DX,DA,TOL,MEND,CRRCT1,CRRCT2) IF(BSTO)CALL STOPOT(DS,NELC,MK,DJ0,DHNS0,MXR,MJH,MNE,DHNS,DX,DA X ,DTOL,MEND,MPP) C IF(DHNS(1).NE.DHNS0)THEN WRITE(6,*)'***ERROR SR.RADWIN: UNABLE TO DETERMINE POTENTIAL', X ' INTERNALLY...' WRITE(0,*)'***ERROR SR.RADWIN: UNABLE TO DETERMINE POTENTIAL', X ' INTERNALLY...' GO TO 99 ENDIF C IF(MPP.EQ.1)THEN IF(BORT)THEN IF(.NOT.BSTO)WRITE(6,774)QN(MK),MYL,DJ,MEND,DX(MEND) IF(BSTO)WRITE(6,775)QN(K),MYL,MCFSTO(MK),DJ,MEND,DX(MEND) ELSE IF(.NOT.BSTO)WRITE(6,776)MYL,DJ,MEND,DX(MEND) IF(BSTO)WRITE(6,777)MYL,DJ,MEND,DX(MEND) ENDIF ENDIF DO I=1,MXR DQNL(I,N)=DPNL(I,N)*((DA(I)-DZ/DX(I))*DTWO+DDY) !DDY(RYD) ENDDO ENDIF C C ORTHONORMALIZE (SCHMIDT PROCEDURE DO63, NORMALIZATION DO64-65) C ONLY ATTEMPT TO ORTHOG TO FUNCTIONS K .LT. N IF BORT TRUE C K0=MAXGR 153 IF(BORT)THEN K0=N IF(MORT.EQ.-3.AND.IRLX.NE.2)KST=N+1 ENDIF DD=DZERO C DO K=KST,K0 C IF(QL(N).NE.QL(K)) GO TO 63 IF(DSIGMA(K).GE.D999)GO TO 63 IF(DEY(K).EQ.DZERO)GO TO 63 C IF(K.LE.IABS(MPSEUD))GO TO 63 IF(QN(K).LT.0)GO TO 63 !AVOID TRYING TO ORTHOG TO CONTINUUM C DO I=1,MAXPS DA(I)=DPNL(I,K)*DPNL(I,N) ENDDO C CALL WEDDLE(DZERO,DA,DD,MNE,DHNS,MJH,MAXPS) C IF(K.LT.N)THEN L1=N L2=K ELSE L1=K L2=N ENDIF C IF(JPRINT.NE.-3)WRITE(6,960)QN(L1),MYL,QN(L2),MYL,DD C IF(MORT.LE.-4)THEN IF(IVAL(L1).EQ.1)THEN NN=QN(L2) IF(DAJOLD(L2).LT.DZERO)NN=-NN WRITE(16,795)QL(L1)/2,QN(L1),NN,DD IF(QN(L1).LE.NN)THEN WRITE(6,764)L1,QN(L1),NN,L2 C GO TO 99 !ERROR: VALENCE N .LE. CORE N GO TO 63 ENDIF IF(DAJOLD(L2).LT.DZERO)GO TO 63 C ELSE C IF(DAJOLD(L1)*DAJOLD(L2).LT.DZERO)THEN C NN=QN(L1) C IF(DAJOLD(L1).LT.DZERO)NN=-NN C WRITE(16,795)QL(L2)/2,QN(L2),NN,DD C ENDIF ENDIF ENDIF C IF(IRLX.EQ.2)THEN KK=((L1-1)*(L1-2))/2+L2 OVLPGR(KK)=DD GO TO 63 ENDIF C DO I=1,MXR IF(I.LE.MXQIN)DQNL(I,L1)=DQNL(I,L1)-DD*DQNL(I,L2) DPNL(I,L1)=DPNL(I,L1)-DD*DPNL(I,L2) ENDDO C ORIG(L1)=ORIG(L1)-DD*ORIG(L2) DOVLP(K)=DD C C DD3=DZERO FOR MODES 1&2,=SUM OVERLAP**2 FOR MODE GT 3(CONTINUUM) IF(K.LT.N.AND.QN(N).LT.0.AND.MODE.GT.2)DD3=DD3+DD*DD C 63 ENDDO C C CTEST WRITE(6,100) DDY,M,MP, MYN,MYL C C AVOID RE-NORMALISATION OF CONTINUUM FUNCTION C if(nf.gt.1.and.screen.eq.dzero.and.ddy.lt.dzero)then screen=dz-sqrt(-qn(n)*ddy) endif c DSIGMA(N)=SCREEN DO K=N,K0 IF(QL(N).NE.QL(K))GO TO 86 IF(DSIGMA(K).GE.D999)GO TO 86 IF(DEY(K).EQ.DZERO)GO TO 86 C IF(K.LE.IABS(MPSEUD))GO TO 86 DM=DONE IF(MORT.LE.-4.AND.N.NE.K.AND.QN(N).EQ.QN(K))GO TO 15 C IF(K.EQ.N.AND.DD.EQ.DZERO)GO TO 15 !ONLY IF INPUT NORMALIZED IF(QN(K).LT.0)GO TO 15 DO I=1,MAXPS DA(I)=DPNL(I,K)**2 ENDDO C CALL WEDDLE(DZERO,DA,DD,MNE,DHNS,MJH,MAXPS) C IF(DD.LT.OVRLP.AND.NSTO.LE.0)THEN !IGNORE NEAR-IDENTICAL FUNCTN WRITE(6,700) OVRLP GO TO 72 ENDIF C DM=DONE/SQRT(DD) C C THIS TEST IS ALSO SUPRESSED IN THE ORIGINAL VERSION OF SS. C IF(ORIG(K).LT.DZERO)DM=-DM !EVENTUALLY POSITIVE SLOPE AT ORIGIN R=0 C 15 DO M=1,MXR DD1=DM*DPNL(M,K) IF(ABS(DD1).GT.D1M6)MAXPS=MAX0(M,MAXPS) C =DEL IF(I.LE.MXQIN)DQNL(M,K)=DM*DQNL(M,K) DPNL(M,K)=DD1 ENDDO ORIG(K)=ORIG(K)*DM 86 ENDDO C C NOW DETERMINE ONE-BODY ENERGY INTEGRALS C DO 94 K=1,K0 IF(QL(K).NE.QL(N)) GO TO 94 IF(DSIGMA(K).GE.D999)GO TO 94 IF(DEY(K).EQ.DZERO)GO TO 94 C IF(K.LE.IABS(MPSEUD))GO TO 94 DD2=DZERO IF(QN(K).LT.0.AND.QN(N).LT.0.AND.MODE.LE.2)GO TO 93 DO I=1,MAXPS DA(I)=DZERO IF(I.LE.MXQIN)THEN DA(I)=DQNL(I,N)*DPNL(I,K) CTEST DA(I) =(DPNL(I,K)*DQNL(I,N)+DA(I))/2 IF(MPSEUD.NE.0)DA(I)=DA(I)+DTWO*DPNL(I,N)*DPNL(I,K) X *(DZ/DX(I)-POTHAM(I)) ENDIF ENDDO C CALL WEDDLE(DZERO,DA,DD,MNE,DHNS,MJH,MAXPS) C DD2=DD/DTWO C 93 DUY(N,K)=DD2 DUY(K,N)=DD2 IF(K.GT.N)THEN DE=DEY(K)-DUY(K,K) DUY(K,K)=DUY(K,K)-DOVLP(K)*DUY(K,N)*DTWO+DUY(N,N)*DOVLP(K)**2 DEY(K)=DUY(K,K)+DE ENDIF 94 CONTINUE C IF(QN(N).GT.0)THEN DEY(N)=DUY(N,N) C DM=DONE !ONLY IF INPUT NORMALIZED DUY(N,N)=DUY(N,N)-DDY/DTWO IF(IRAD(N).GT.0)GO TO 79 GO TO 20 ENDIF MINK=0 DD1=-MSHFT*MINK DM=DZERO DEY(N)=DUY(N,N)+DD1+DDY*(DONE+DD3)/DTWO IF(DEY(N).EQ.DZERO)DEY(N)=D1M10 DUY(N,N)=DUY(N,N)+DDY*DD3/DTWO C 20 IF(BPRNT)WRITE(6,300)N,QN(N),MYL,MION,NZION,SCREEN,MR,ORIG(N), X DY(IPMX),DM, (DPNL(I,N),I=II,MXR), DEY(N) IF(KEY.NE.-10)GO TO 72 C STO IF(ABS(DM-DONE).LT.D1M1.OR.INORM.NE.0)GO TO 12 WRITE(6,950) DORIG(N)=DZERO DSIGMA(N)=D3999 IF(NSTO.LE.0)THEN WRITE(6,*)'CONFUSION OVER NORMALIZATION FOR ORBITAL:',N WRITE(0,*)'CONFUSION OVER STO/CLEMENTI NORMALIZATION' GO TO 99 ENDIF DO J=1,NSTO DD=ZE(J)*DTWO DO K=1,2*JRAD(J) DD=ZE(J)*DD*DTWO/K ENDDO CJ(J)=SQRT(DD)*CJ(J) ENDDO N=NSTO NSTO=-N GO TO 88 C 79 IF(BORT.and.(MORT.ne.-3.or.IRLX.NE.2))THEN KST=K00 IF(N.GT.0)IRAD(N)=0 C DO K57=K00,MAXGR IF(IRAD(K57).NE.0)THEN N=K57 MYL=QL(N)/2 DDY=(DEY(N)-DUY(N,N))*DTWO !EPS(RYD) SCREEN=DSIGMA(N) DSIGMA(N)=3999 GO TO 153 !RE-ORTHONORMALIZE ENDIF ENDDO ENDIF C IF(NF.LE.0)GO TO 90 C C CHECK COMPLETENESS OF RADIAL FUNCTION SET C COMPUTE RELATIVISTIC INTEGRALS (MASS AND DARWIN TERM, EJN-EQ.60) C C MP=MYN C IF(MAUTO.EQ.0)GO TO 56 !ALL DONE IN RADCON C MP=0 DO K=1,MAXGR C IF(DEY(K).EQ.DZERO)GO TO 52 C IF(K.LE.IABS(MPSEUD))GO TO 52 MP=K IF(DSIGMA(K).LT.D999.or.dsigma(k).gt.D5999)GO TO 96 !FOR RADCON IF(DSIGMA(K).NE.D999)THEN WRITE(6,980) K DEY(K)=DZERO NF=-1 GO TO 52 ENDIF WRITE(6,970) K 96 IF(NJO.LE.0.AND..NOT.BMVD.or.qn(k).lt.0)GO TO 52 C DORIG(K)=ORIG(K)*DZ DX1=DZERO IF(MODE.GT.2.AND.IYY(K).GT.0)DX1=DYY(NREL) C DO L=1,K IF(DEY(L).EQ.DZERO)GO TO 53 DP0=DZERO C IF(L.LE.IABS(MPSEUD))GO TO 53 IF(QL(K).NE.QL(L))GO TO 53 DD=DZERO DM=DZERO IF(BREL.AND.NL.LE.NL000)GO TO 54 IF(MODE.LE.2.AND.(QN(K).LT.0.OR.QN(L).LT.0))GO TO 54 DX2=DZERO IF(MODE.GT.2.AND.IYY(L).GT.0)DX2=DYY(NREL) C DO I=1,MAXPS DA(I)=DZERO DPH(I)=DZERO IF(I.LE.MXQIN)THEN DD3=2*DZ/DX(I) DD2=DPNL(I,L)*(DD3+DX2)+DQNL(I,L) DD1=DPNL(I,K) DA(I)=(DD1*(DD3+DX1)+DQNL(I,K))*DD2 DPH(I)=DD1*DD2 IF(QN(K).LT.0.AND.QN(L).LT.0)THEN DD0=DX2*DPNL(I,L)*DPNL(I,K) DA(I)=DA(I)-DX1*DD0 DPH(I)=DPH(I)-DD0 ENDIF ENDIF ENDDO C CALL WEDDLE(DD,DPH,DP0,MNE,DHNS,MJH,MAXPS) C IF(K.EQ.L)DP0=DP0+DX2 IF(BREL)GO TO 53 IF(QL(K).EQ.0) DD=DORIG(K)*DORIG(L) DD3=DD*DFOUR C CALL WEDDLE(DD3,DA,DM,MNE,DHNS,MJH,MAXPS) C IF(L.EQ.K)DM=DM+DX1*DX2 DM=-DM*DALF/DEIGHT DD=DD*DALF/(DZ*DEIGHT) 54 DMASS(K,L)=DM DCD(K,L)=DD 53 D2LL(K,L)=DP0 ENDDO C 52 ENDDO C IF(BREL)THEN IF(IABS(IREL).EQ.2)THEN DO K=1,MAXGR IF(DEY(K).NE.DZERO)THEN DO I=1,MXR DQNL(I,K)=DZERO !LARGE CPT ONLY READ ENDDO ENDIF ENDDO C COULD CONTINUE ZEROED OUT, TBD: ESTIMATE FROM LARGE CPT WRITE(6,*)'***SR.RADWIN ERROR: SMALL COMPONENT NOT AVAILABLE!' WRITE(0,*)'***SR.RADWIN ERROR: SMALL COMPONENT NOT AVAILABLE!' GO TO 99 ENDIF ENDIF C C 56 CONTINUE IF(BPRNT .AND.II.GT.1)WRITE(6,400)(DX(I),I=II,MXR) IF(MAXPS.GT.MXQIN)WRITE(6,500)MXQIN,MAXPS,DX(MXQIN) C C TERMINATOR CARD (READ AT 72READ570/600) ALLOWS TO SPECIFY PRINTOUT C N=MIN0(MYN,MP) IF(N.GT.0)THEN WRITE(6,990) M=MIN0(MAXPS,MXQIN) DO L=1,M WRITE(6,900)L,DX(L),(DPNL(L,I),DQNL(L,I),I=1,N) ENDDO ENDIF C 90 RETURN C 1000 WRITE(6,1997) WRITE(0,*)'*** SR.RADWIN: ERROR READING NAMELIST SRADWIN!' !FATAL C 99 NF=-1 GO TO 90 C C 100 FORMAT(27X,F13.5,30X,A4,I4,I3,I2) 101 FORMAT(// ' ****WARNING IN SR.RADWIN, YOU ARE ASSUMING ORTHOGONAL X ORBITALS, ERRORS MAY ARISE') 250 FORMAT(/ 'GAM ( N, L,NION, Z, DEL/PI) OLDEPS/RY OF RADIAL IN XPUT-FUNCTIONS',4X, '(ORIGIN N L) FNORM, 3 LAST P, ;STP XS/PTS=',I5,'/',I5) 300 FORMAT(I3,I4,I4,I4,I4,F9.5,13X,I4,1X,F11.5,F10.3,17X,F8.3, X 1X,3E9.2,F12.4) 400 FORMAT(38X, 'READ("") PBAR0 RPEND',15X,'3 LAST R:',3F9.4, X 4X, ' (H1/2RY)'/) 500 FORMAT( ' SR.RADWIN: P/Q DATA READ WHILE MAXB2=',I3, ' -- SHOULD X BE .GE.MAXPS=',I5/12X, 'RESULTS INVOLVING Q(N,L) MAY BE POOR - R( XMAXB2)/A0 =',F9.3) 570 FORMAT(3I5,I3,7X,F12.6,2X,I4,29X,A4,I4) 580 FORMAT(66X, '**WARNING** FOR THE FOLLOWING FUNCTION P'/68X,I3, X ' OF THE IPMX=',I4, ' INPUT VALUES P/Q HAVE BEEN IGNORED',/68X, X 'EITHER BECAUSE BUFFER(MXPIN=',I5, ') CANNOT HOLD THEM'/68X, 'OR XBECAUSE ARGUMENTS R HAVE BEEN READ IN FOR ONLY MXE=',I4,' POINTS'/ X 68X, '-- CUT-OFF RADIUS ',F6.2, '*A0, P(RCUT) =',E10.2) 589 FORMAT(3I5,8X,I5) 590 FORMAT(2I5,5X,F8.4) 591 FORMAT(2I2,F10.4,I4,A4,I4) 592 FORMAT(/' KEY=',I3,2X,'MODE=',I2,2X, 'ACCURACY OF ENERGY CONSER XVATION=',F8.4,' A.U.',4X, 'CONTINUUM FUNCTIONS IN USE; MODES 2 TO X3'/) 593 FORMAT( ' YOUR VALUE OF',I3, ' FOR MODE IN SR.RADWIN IS NOT WITH XIN THE CURRENT VALID RANGE') 600 FORMAT(I2,I1,I2,2(I4,2E14.7),3X,A4,I4) 700 FORMAT(84X, 'WILL BE SKIPPED, OVERLAP .LT. ',1PE7.1) 764 FORMAT(' WARNING: ORBITAL',I3,' HAS VALENCE N=',I3,' .LE. CORE N=' X,I3,' OF ORBITAL',I3) 774 FORMAT(23X,'NL =',I3,I2, ' S.M.-POTENTIAL V(NL) WITH SCALE FAC XTOR',F10.5, '; COULOMBIC BEYOND R(IEND=',I5,') =',F10.6) 775 FORMAT( 2X,'NL =',I3,I2, ' STO.-POTENTIAL CF=',I3, ' WITH SCAL XE FACTOR',F10.5,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R( XIEND=',I5,') =',F10.6) 776 FORMAT(24X,'LL =',I2, ',.. S.M.-POTENTIAL V(LL) WITH SCALE FACT XOR',F10.5, '; COULOMBIC BEYOND R(IEND=',I5,') =',F10.6) 777 FORMAT( 3X,'LL =',I2, ',.. STO.-POTENTIAL V(LL) WITH SCALE FACT XOR',F10.5,'; NON-COULOMB POT .LT. 1% OF COULOMBIC BEYOND R(IEND=' X,I5,') =',F10.6) 795 FORMAT(3I5,1PE13.4) 800 FORMAT(84X, 'WILL BE SKIPPED, BECAUSE NO MORE FUNCTIONS ARE'/ X77X, 'SPECIFIED BY SIGMA.GE.999 & .LT. 5999 FOR THIS ORBITAL L') 900 FORMAT(I5,(7F18.6)) 940 FORMAT(' SR.RADWIN: MIS-MATCH FOR ORBITAL',I3,' FILE N=',I3) 950 FORMAT(' REPEAT SINCE NORM INDICATES CLEMENTI TYPE INPUT FORMAT:') 960 FORMAT( ' OVERLAP INTEGRAL',4X,I3,I2,' WITH',2I2,' =' X,1PE12.4) 970 FORMAT(61X, "P/Q-INPUT FOR ORBITAL K=",I2, " MISSING, S.M. USED - X ORBITALS MAY"/89X,"NOT BE ORTHOGONAL TO INPUT-PNL'S WITH SAME L") 980 FORMAT(61X, 'P/Q-INPUT FOR ORBITAL K=',I2, ' MISSING (OR MAXB2 TO XO SMALL), CASE FAILS') 990 FORMAT(/ " OPTIONAL PRINTOUT OF I, R(I), N P(I) AND Q(I)'S:"/) 995 FORMAT(10X,'NL =',I3,I2,4X,'HARTREE-FOCK FROZEN-CORE P-Q INPUT') 996 FORMAT( ' *****WARNING IN SR.RADWIN, YOU HAVE SPECIFIED A BOUND O XRBITAL WITH POSITIVE ENERGY=' ,1PE14.7) 997 FORMAT( ' *****WARNING IN SR.RADWIN, YOU HAVE SPECIFIED A CONTINU XUM ORBITAL WITH NEGATIVE ENERGY=' ,F10.4) 998 FORMAT(I5,3F18.6) 999 FORMAT(5X,I4,E14.7,14X,3I4,2E14.7) 1997 FORMAT('*** SR.RADWIN: ERROR READING NAMELIST SRADWIN!'/4X, X'IF PRESENT, CHECK FOR ILLEGAL OR MISTYPED VARIABLE NAMES') END C C ******************* C SUBROUTINE REDSS(DC,IDC,MAM,NAM,QLMC,QBML,QBMS,JYI,JYF,MAXEL) C C----------------------------------------------------------------------- C C SR.REDSS REDUCES THE TARGET SLATER SLATE EXPANSION TO THE MINIMUM C REQUIRED BY THE COLLISION PROBLEM (IDW.NE.0). C CURRENT OPTIONS: C ALL M_S.LT.0, AS USED BY AN IC TARGET, ARE RESTRICTED C TO M_S.GE.-NF+2*(NF/2), FOR A BP COLLISION PROBLEM C WITH SOME/ALL TARGET CONFIGS OMITTING 2-BODY FINE STRUCTURE. C (NOTE: THE LS PROBLEM HAS ALREADY BEEN RESTRICTED BY SR.VCG.) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C LOGICAL BFAST,BDISK C INTEGER*8 MDCF8,MDCFT8 C REAL*8 DC DIMENSION DC(0:*),IDC(*),MAM(*),NAM(*),JYI(*),JYF(*) DIMENSION QLMC(MAXEL,*),QBML(*),QBMS(*) C COMMON /BASIC/NF,MBASE(11) COMMON /MQVC/MODE,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF) COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /NRBAL1/MSTAT(MAXCF),KM,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) C IF(IABS(MODE).GT.1)RETURN !SINCE LS COUPLING, DONE IN VCG C IEND=MTGD MTGD1=MTGD+1 C IF(KUTSSX.NE.-9)THEN !SET COLLISION 2FS CFGS MKT=KUTSSX IF(MKT.EQ.-999)MKT=-1 IF((MKT+3)/2.EQ.1)MKT=1+MKT !ALIGNS DEFAULT KUTSSX=0 AND -1 MKT=IABS(MKT) ELSE RETURN !SINCE 2FS ON ALL TARGET CFGS ENDIF C C INITIALIZE (OPEN) WRITE REDUCED DC ARRAY TO DUMP DSKDMP (UNIT33). C WILL THEN MOVE BACK TO PERMANENT DISKDC (UNIT32) C BDISK=KUTDSK.LT.KM !USE DISKDC C IF(BDISK)THEN MOLD=MDCBUF !HOLD OLD BUFFER FOR READS MNEW=0 !DETERMINE REDUCED BUFFER CALL DISKDC(33,DC,IDC,0,0,0,0,0,0) IUD=33 !POINT TO DSKDMP MDCF8=0 MDCFT8=0 ENDIF C C STRIKE OUT SLATER STATES WITH M_S .LT. MSMIN C MSMIN0=-NF+2*(NF/2) C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C c jbf=jyf(km) c JM0=0 LB=JYI(1)-1 M=0 K1=0 !FOR BFAST C DO KF=1,KM C BDISK=KF.GT.KUTDSK !USE DISKDC C IF(KF.GT.MKT)THEN !CAN RESTRICT MSMIN=MSMIN0 ELSE !CANNOT AS 2-FS PRESENT MSMIN=-999 ENDIF C JA=JYI(KF) JYI(KF)=LB+1 JB=JYF(KF) C JM=0 L=JA-1 C c write(6,*)'kf=',kf DO J=JA,JB C I=L+1 ML=QBML(J) MS=QBMS(J) C IF(MS.GE.MSMIN)THEN C L=I LB=L-JM0 C QBML(LB)=ML QBMS(LB)=MS c write(6,*)lb,ms,ml C MAM(J)=LB C DO I=1,NF QLMC(I,LB)=QLMC(I,J) ENDDO C ELSE C MAM(J)=-1 JM=JM+1 C ENDIF C ENDDO C c write(0,*)' ss reduction for configuration',kf,':',jyf(kf),lb JYF(KF)=LB JM0=JM0+JM C C NOW STRIKE-OUT CORRESPONDING VCC'S C M1=M+1 N=NTG(KF-1) KSL0=KGCF(KF)-KGCF(KF-1) C DO K0=1,KSL0 C IF(BDISK)THEN !READ OLD MDCBUF=MOLD ISTRT=MTGD1 CALL DISKDC(32,DC,IDC,ISTRT,IEND,KF,K0,1,0) IF(IEND.LT.0)GO TO 999 ENDIF C KTT=NKSL(K0,KF) C IF(BFAST)THEN !ORIGINAL FAST ACCESS, WITHOUT MEMORY POINTER C DO KT=1,KTT N=N+1 I=JTGD(N) JTGD(N)=M-JYI(KF)+1 c write(6,*)'n,jd=',n,jtgd(n) C DO J=JA,JB IF(MAM(J).GT.0)THEN M=M+1 DC(M)=DC(J+I) c write(6,*)j-ja+jyi(kf),j+jd,dc(j+jd) ENDIF ENDDO ENDDO C ELSE !MEMORY EFFICIENT OPTION IN USE C DO KT=1,KTT C N=N+1 C K2=JTGD(N) !absolute end flagged IF(K2.LT.0)THEN !bdisk first so KT=1... K2=-K2 K1=MTGD ENDIF K1=K1+1 C c write(6,*)'n,jd=',n,m+1 DO K12=K1,K2 J=IDC(K12) IF(MAM(J).GT.0)THEN M=M+1 DC(M)=DC(K12) IDC(M)=MAM(J) c write(6,*)mam(j),m,dc(m) ENDIF ENDDO C K1=K2 JTGD(N)=SIGN(M,JTGD(N)) C ENDDO C ENDIF C IF(BDISK)THEN !WRITE NEW MDCBUF=MNEW ISTRT=M1 IFIN=M CALL DISKDC(33,DC,IDC,ISTRT,IFIN,KF,K0,-1,0) MNEW=MDCBUF M=M1-1 ENDIF C ENDDO C ENDDO c write(0,*)'total ss reduction:',jbf,lb c write(0,*)'total vcc reduction:',mtgd,m MTGD=M MTGD1=MTGD+1 !shouldn't be necess. C c write(6,*)'lb,mtgd=',lb,mtgd C C JUGGLE FILES... C IF(BDISK)THEN MDCFT8=MDCFT8+MDCF8 !pick-up final config WRITE(6,22)MDCFT8 IF(KUTDSK.LT.KFBUFF)THEN !TBD write(0,*)'kutdsk.ge.1000 not yet coded for idw.ne.0' write(6,*)'kutdsk.ge.1000 not yet coded for idw.ne.0' nf=-1 c note:old mdcbuf2,3 no help since likely will store multiple target slp c per total LSP. Ditto, 2FS. So, c MDCBUF=MAXDC !SINCE UNKNOWN AHEAD OF TIME c IF(MDCFT8.LE.MAXDC)THEN c M=INT(MDCFT8) c MDCBUF=MIN(MDCBUF,MTGD+M) !FOR SUBSEQUENT ALLOCATE c ENDIF ELSE MDCBUF=MNEW MDCBUF=MDCBUF+MDCBUF+MTGD !SINCE NEED TO HOLD TWO SLICES c IF(MDCBUF.GT.MAXDC)THEN !not poss. since mnew.lt.mold c WRITE(6,140)MDCBUF c NF=-1 c ENDIF ENDIF CALL DISKDC(32,DC,IDC,0,0,0,0,0,0) !CLOSE/DELETE DISKDC c write(0,*)mold,mdcbuf ENDIF C 999 IF(IEND.LT.0)NF=-1 C RETURN C 22 FORMAT(/47X,"TOTAL NUMBER OF VCC'S STORED ON DISK:",I12/) C END C C ******************* C SUBROUTINE RES1(QLML,MAXEL,DFS,MAM,NAM,IZX) C C----------------------------------------------------------------------- C C SR.RES1 CALCULATES THE ALGEBRA OF THE MATRIX ELEMENTS OF THE C SPIN-SPIN MUTUAL SPIN-ORBIT AND SPIN-OTHER ORBIT INTERACTION C BETWEEN A PAIR OF STATES OF THE TYPE !CBSLJ MJ), WHERE C = C CONFIGURATION, B=DEGENERACY PARAMETER OF TERM S,L AND J, MJ = C TOTAL ANGULAR MOMENTUM AND ITS AZIMUTHAL COMPONENT. C ORIGINAL ROUTINE WRITTEN BY MICHAEL JONES, C REFERENCES: JONES,M., J.PHYS.B.:ATOM. MOLEC.PHYS. VOL. 4(1971). C ***THIS VERSION EVALUATES THE SLATERSTATE INTERACTIONS ONLY - NRB C C----------------------------------------------------------------------- C USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (TYNY=1.0D-6) PARAMETER (TTYNY=10*TYNY) PARAMETER (FSTYNY=10*TTYNY) C LOGICAL LN,LH,LK,LMM,BVC,LX,SKP,SPN,BSS,BSO,BSOO,BDLBD X ,BPLANT2 !,LOGJ C CHARACTER(LEN=4) CODE C DIMENSION QLML(MAXEL,*),DFS(*),MAM(*),NAM(*) DIMENSION Q1(2,2),Q2(2,2),Q3(2,2),Q4(2,2),VC(2),VK(2,3) X,JSS(4),IGAM(5),NEN(2,2),NES(2) C COMMON /BASIC/NF,NEK(2),JA,JB,JAP,JBP,MGAP(5) COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /COMRES/DVC12,LX,ICLRS,ICLRR COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE!MXORB SET IN ALG1 COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT C C MVC(MLX,MLY)=((MLX+2)*MLX/2+MLY )/2+1 C BPLANT2=MXORB.LT.37 SKP=MXLL.EQ.-1 C NLS01=NLS00+1 IF(ICLRR.LT.0)GO TO 400 C KF=NEK(1) KG=NEK(2) C C GO TO (101,102,103,104,105,106,107,108),QQCUT C IF(QQCUT.EQ.1)THEN BSS=.TRUE. !101 BSO=.TRUE. BSOO=.TRUE. ELSEIF(QQCUT.EQ.2)THEN BSS=.FALSE. !102 BSO=.TRUE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.3)THEN BSS=.FALSE. !103 BSO=.FALSE. BSOO=.TRUE. ELSEIF(QQCUT.EQ.4)THEN BSS=.TRUE. !104 BSO=.FALSE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.5)THEN BSS=.FALSE. !105 BSO=.FALSE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.6)THEN BSS=.TRUE. !106 BSO=.FALSE. BSOO=.TRUE. ELSEIF(QQCUT.EQ.7)THEN BSS=.TRUE. !107 BSO=.TRUE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.8)THEN BSS=.FALSE. !108 BSO=.TRUE. BSOO=.TRUE. ENDIF C C IN LOOPS 110,120 SCAN THROUGH SLATER STATES IN INITIAL AND C FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR. C DO 110 J1=JA,JB C JC=MAM(J1) NES(1)=JC C DO 120 J2=JAP,JBP C JD=NAM(J2) C CTHIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE COLD IRSS00=IRSS+1 C DO I=NLS01,NLS IORIG2(I)=0 ENDDO C NES(2)=JD NK=0 C C NOW COMPARE INITIAL AND FINAL SLATER STATES AND SELECT ONLY THE C ONES WHICH DIFFER IN NK=TWO, ONE, OR NO SETS OF QUANTUM NUMBERS C MEN=0 IF(JD.EQ.JC)GO TO 75 C C FIND THE POSITIONS OF THE ELECTRONS WITH DIFFERING QUANTUM NUMBERS C STORE THESE IN THE ARRAY NEN C IF(MAXGR.GT.MXS2I)THEN !UNLIKELY WRITE(6,*)'***RES1: INCREASE MXS2I' WRITE(0,*)'***RES1: INCREASE MXS2I' GO TO 1 ENDIF C DO I=1,NF KB=QLML(I,JC) KC=IEQ(QCG(I,KF)) DO L=1,NF IF(QLML(L,JD).NE.KB)GO TO 23 IF(IEQ(QCG(L,KG)).NE.KC)GO TO 23 LP=L IGRGR(QCG(I,KF))=QCG(L,KG) GO TO 22 23 ENDDO NK=NK+1 IF(NK.GT.2)GO TO 120 NEN(1,NK)=I MEN=I+MEN LP=0 22 QLML(I,1)=LP ENDDO C K=0 DO L=1,NF DO I=1,NF IF(QLML(I,1).EQ.L)GO TO 20 ENDDO K=K+1 NEN(2,K)=L MEN=L+MEN IF(K.EQ.NK)GO TO 75 20 ENDDO C 75 II=0 240 II=II+1 IF(II.GT.NF)GO TO 13 IF(NK.EQ.1.AND.II.EQ.NEN(1,1))GO TO 240 KK=0 250 KK=KK+1 IF(KK.GE.II.AND.NK.EQ.0)GO TO 240 C C THE ELECTRON LABELLED BY (K1,K2) BELONGS TO THE CONFIGURATION KX C AND TO THE SLATER STATE KY. K1=NO. OF ELECTRON WITHIN A PAIR AND C K2=NO. OF PAIR. C IMT=0 DO K2=1,2 KP=II IF(NK.EQ.0.AND.K2.EQ.2) KP=KK DO K1=1,2 NI=K1 IF(NK-1.LT.0)GO TO 752 IF(NK-1.GT.0)GO TO 754 IF(K2.EQ.1)GO TO 754 NI=1 GO TO 752 754 KP=NEN(K1,K2) 752 KX=NEK(NI) KY=NES(NI) C WRITE(0,*)KP C IF(KP.LE.0)THEN C WRITE(0,*)'KP.LE.0' C NF=-1 C GO TO 999 C ENDIF IH=QCG(KP,KX) IF(QN(IH).GE.90)IMT=IMT+1 IF(IMT.GT.1)GO TO 14 MU=QLML(KP,KY) ML=((100+MU)/2)*2-100 Q1(K1,K2)=QL(IH) Q2(K1,K2)=IH Q3(K1,K2)=ML Q4(K1,K2)=(MU-ML)*2-1 ENDDO ENDDO C IF(NK.EQ.1)Q2(2,2)=IGRGR(Q2(2,2)) C C INITIALIZE DATA FOR LAMBDA-LOOP C VK(1,2)=DZERO VK(1,3)=DZERO VK(2,2)=DZERO VK(2,3)=DZERO DV2=DZERO DV3=DZERO NI=0 KC=0 78 KB=0 C 265 L1=Q1(1,1+KC) L2=Q1(1,2-KC) IF(L1+L2.EQ.0)GO TO 14 L3=Q1(2,1+KB) L4=Q1(2,2-KB) IF(L3+L4.EQ.0)GO TO 14 MU=MIN0(L1+L3,L2+L4) MLAM2=MAX0(IABS(L1-L3),IABS(L2-L4)) MLAM0=MLAM2-4 IF(MLAM2.GT.0)MLAM2=MLAM0 MLAM0=MLAM0-4 !FIX SPIN-SPIN NRB FROM PETE FEB 90 IF(MLAM2.GT.MU)GO TO 76 JSS(1+KC)=Q2(1,1) JSS(2-KC)=Q2(1,2) JSS(3+KB)=Q2(2,1) JSS(4-KB)=Q2(2,2) ML1=Q3(1,1+KC) ML2=Q3(1,2-KC) ML3=Q3(2,1+KB) ML4=Q3(2,2-KB) C COLD LOGJ=JSS(2).LE.JSS(1).OR.JSS(3).NE.JSS(2).OR.JSS(4).NE.JSS(1) COLD =FALSE FOR EXPLOITING N(B,A;A,B)=N(A,B;B,A) WHEN B.LT.A. C DSJ=SQRT(DBLE((L1+1)*(L2+1)*(L3+1)*(L4+1))) X *DBLE(MOD(IABS((KB+KC+MEN)*2+MLAM2-ML1-ML2),4)-1)*DVC12 C SPN=.FALSE. IF(SKP)GO TO 267 C MDIFF1=ML1-ML3 MDIFF2=ML2-ML4 NI=MIN0(IABS(MDIFF1),IABS(MDIFF2)) M1=Q4(1,1+KC) M2=Q4(1,2-KC) M3=Q4(2,1+KB) M4=Q4(2,2-KB) MD1=M1-M3 MD2=M2-M4 MST=MD1+MD2 DV1=VCC(1,2,1,M3,MD1,M1,DFS,MXDFS) DV2=VCC(1,2,1,M4,MD2,M2,DFS,MXDFS) DD1=DZERO IF(BSS)DD1=-VCC(2,2,4,MD1,MD2,MST,DFS,MXDFS) X *DV1*DV2*DTHREE/(DTWO*SQRT(DFIVE)) M1=MVC(L1,-ML1) M2=MVC(L2,-ML2) M3=MVC(L3,ML3) M4=MVC(L4,ML4) DDR1=DZERO DDR2=DZERO IF(MD1*MD2.NE.0)SPN=.TRUE. IF(MD2.EQ.0)THEN IF(BSO)DDR1=DV1 IF(BSOO)DDR2=DV1+DV1 ENDIF IF(MD1.EQ.0)THEN IF(BSOO)DDR1=DV2+DV2+DDR1 IF(BSO)DDR2=DV2+DDR2 ENDIF C C ----- BEGIN OF LAMBDA-LOOP (INNER LOOP) C 267 MLAM=MLAM2 IF(MLAM.GT.MU)GO TO 76 DSJ=-DSJ 40 MLAM2=MLAM0+2 MLAM1=MLAM2+2 VK(1,1)=VK(1,2) VK(1,2)=VK(1,3) VK(2,1)=VK(2,2) VK(2,2)=VK(2,3) VK(1,3)=DZERO VK(2,3)=DZERO DV1=DV2 DV2=DV3 DV3=DZERO IF(MLAM1.LT.NI)GO TO 59 LMM=MOD(MU-MLAM0,4).NE.0 IF(LMM)GO TO 59 LH=L1+L3.LT.MLAM1 LN=L2+L4.LT.MLAM1 LK=MLAM0.LT.0 .OR. MLAM0.NE.MLAM DD=DONE C IF(SKP)GO TO 59 C C THE N-CASE MLAM=-2 (AND ALSO MLAM0.LT.MLAM) C KP=MLAM1/4 K1=KP+1 IF(.NOT.BVC)THEN IF(L1.GT.MXLL)GO TO 42 IF(L3.GT.MXLL)GO TO 42 ENDIF IF(.NOT.LK)THEN VC(1)=VCB(M1,M3,KP) IF(LH)GO TO 53 ENDIF VK(1,3)=VCA(M1,M3,K1) GO TO 53 C 42 IF(.NOT.LK)THEN VC(1)=VCC(L1,L3,MLAM0,0,0,0,DFS,MXDFS) X *VCC(L1,L3,MLAM2,-ML1,ML3,-MDIFF1,DFS,MXDFS) IF(LH)GO TO 53 ENDIF VK(1,3)=VCC(L1,L3,MLAM1,0,0,0,DFS,MXDFS)/ DBLE(MLAM1+1) X *VCC(L1,L3,MLAM1,-ML1,ML3,-MDIFF1,DFS,MXDFS) C 53 IF(.NOT.BVC)THEN IF(L2.GT.MXLL)GO TO 45 IF(L4.GT.MXLL)GO TO 45 ENDIF IF(.NOT.LK)THEN VC(2)=VCB(M2,M4,KP) IF(LN)GO TO 59 ENDIF VK(2,3)=VCA(M2,M4,K1) GO TO 46 C 45 IF(.NOT.LK)THEN VC(2)=VCC(L2,L4,MLAM0,0,0,0,DFS,MXDFS) X *VCC(L2,L4,MLAM2,-ML2,ML4,-MDIFF2,DFS,MXDFS) IF(LN)GO TO 59 ENDIF VK(2,3)=VCC(L2,L4,MLAM1,0,0,0,DFS,MXDFS)/ DBLE(MLAM1+1) X *VCC(L2,L4,MLAM1,-ML2,ML4,-MDIFF2,DFS,MXDFS) C 46 IF(.NOT.LH)DV3=VCC(MLAM1,MLAM1,2,MDIFF1,MDIFF2,-MST,DFS,MXDFS) X *VK(1,3)*VK(2,3) C 59 MLAM0=MLAM2 IF(MLAM0.LE.MLAM)GO TO 40 IF(MLAM1.LT.NI)GO TO 267 !NEXT LAMBDA C C NOW MLAM2=MLAM+2 C AND MLAM1=MLAM+4 C IF(LMM)GO TO 60 DDR=DZERO ML=MLAM+200 IF(LK)GO TO 66 IF(IABS(L4-L2).GT.MLAM)GO TO 64 IF(LH)GO TO 62 IF(SKP)GO TO 70 C C FOLLOWING STATEMENT: SPIN-SPIN; THEREAFTER: MUTUAL SPIN-ORBIT. C DDR=SQRT(DBLE((MLAM+5)*MLAM1*(MLAM+3)*MLAM2*(MLAM+1)))*DD1* X VCC(MLAM1,MLAM,4,MDIFF1,MDIFF2,-MST,DFS,MXDFS)*VK(1,3)*VK(2,1) C IF(SPN) GO TO 68 C MD2=(MLAM2-L4+L2)*(MLAM2-L2+L4)*(L2-MLAM+L4) IF(MD2.EQ.0) GO TO 62 CORWE IF(MLAM2.LT.IABS(L2-L4))GO TO 4503-*4502 C C 2ND V2 C DDR=DDR-VCC(MLAM1,MLAM2,2,MDIFF1,MDIFF2,-MST,DFS,MXDFS) X *SQRT(DBLE((MLAM1+L2+L4)*(MLAM+5)*MD2) X /DBLE((MLAM+1)*MLAM1*32))*DDR2*VC(2)*VK(1,3) C 62 IF(SPN)GO TO 267 IF(IABS(L3-L1).GT.MLAM)GO TO 64 MD1=(MLAM2-L3+L1)*(MLAM2-L1+L3)*(L3-MLAM+L1) IF(MD1.EQ.0)GO TO 63 IF(SKP)GO TO 70 C C 1ST V2 C DDR=SQRT( DBLE((MLAM1+L1+L3)*MD1)/(32*MLAM2))*VC(1)*VK(2,1) X *DDR1*VCC(MLAM2,MLAM,2,MDIFF1,MDIFF2,-MST,DFS,MXDFS)+DDR C 63 IF(MLAM.EQ.0)GO TO 64 IF(SKP)GO TO 70 C C********************************************************************** C 1ST V3 , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER C , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL C , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON) C , SO STAY WITH MINUS FOR NOW. - NRB C********************************************************************** C DDR=DDR-SQRT( DBLE((MLAM+1)*MLAM)/ DBLE(64*MLAM2)) X *DBLE((L1*(L1+2)-L3*(L3+2)-MLAM*MLAM2))*DDR1*DV1 C 64 IF(LH)GO TO 68 IF(LN)GO TO 68 66 IF(SPN)GO TO 267 IF(SKP)GO TO 70 C C********************************************************************** C 2ND V3 , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER C , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL C , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON) C , SO STAY WITH MINUS FOR NOW. - NRB C********************************************************************** C DDR=DDR-DDR2*DV3 X *SQRT(DBLE((MLAM+5)*(MLAM+6))/DBLE(64*MLAM1)) X *DBLE((L2*(L2+2)-L4*(L4+2)-(MLAM+6)*MLAM1)) C 68 DD=DDR*DSJ GO TO 69 C 60 IF(SPN)GO TO 267 !NEXT LAMBDA ML=MLAM+100 IF(SKP)GO TO 70 C DD=SQRT( DBLE(((MLAM+3)*MLAM2*MLAM1)/4))*DV2*DDR1*DSJ 69 IF(ABS(DD).LT.TTYNY)GO TO 267 !NEXT LAMBDA C 70 IGAM(5)=ML C C IMPOSE V(AB;CD)=V(AD;CB) C IMPOSE N(AB;CD)=N(AD;CB)=N(CD;AB)=N(CB;AD) C BY WAY OF FALLING ORDER - NRB C IF(LMM)THEN DO K1=1,3,2 IGAM(K1)=JSS(K1) ENDDO K11=2 ELSE K11=1 ENDIF DO K1=K11,2 IF(JSS(K1).LT.JSS(K1+2))THEN KP=2 JP=0 ELSE KP=0 JP=2 ENDIF IGAM(K1)=JSS(K1+KP) IGAM(K1+KP+JP)=JSS(K1+JP) ENDDO c c test suppress falling-order c do j=1,4 c igam(j)=jss(j) c enddo COLD C DO K1=1,4 C KP=K1 C IF(.NOT.LMM.AND..NOT.LOGJ)THEN C KP=K1-2 C IF(KP.LE.0)KP=K1+2 C ENDIF C IGAM(K1)=JSS(KP) C ENDDO C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C IF(BPLANT2)IPLANT=IGAM(5)+ X ((((IGAM(4)*MXORB+IGAM(3))*MXORB+IGAM(2))*MXORB)+IGAM(1))*1000 c c test - exclude "core" c imt=0 c do i=1,4 c if(qn(igam(i)).lt.80)imt=imt+1 c enddo c if(imt.gt.2)go to 267 C DO J=NLS01,NLS IF(.NOT.BPLANT2)THEN DO I=5,1,-1 !1,5 SLOWER IF(QSSS(I,J).NE.IGAM(I))GO TO 272 ENDDO ELSE IF(IPLANT.NE.JORIG2(J))GO TO 272 ENDIF L=J I=IORIG2(L) IF(I.GT.0)THEN DSSS(I)=DSSS(I)+DD GO TO 267 !NEXT LAMBDA ENDIF GO TO 301 272 ENDDO C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C L=NLS+1 IF(L.GT.MXS2I)GO TO 1 NLS=L DO I=1,5 QSSS(I,L)=IGAM(I) ENDDO IF(BPLANT2)JORIG2(L)=IPLANT C 301 IRSS=IRSS+1 IF(IRSS.GT.MXS2C)GO TO 1 IORIG2(L)=IRSS MSSS(IRSS)=L DSSS(IRSS)=DD NSTJ2(IRSS)=JC NSTJ2D(IRSS)=JD C GO TO 267 !NEXT LAMBDA C C ----- END OF LAMBDA-LOOP C 76 IF(KB.NE.0)THEN IF(KC.NE.0)GO TO 78 KC=1 GO TO 265 ENDIF KB=1 IF(KC.EQ.0)GO TO 265 14 IF(NK-1.LT.0)GO TO 250 IF(NK-1.EQ.0)GO TO 240 13 CONTINUE C 120 CONTINUE !END SCAN OF INITIAL SLATER STATES C 110 CONTINUE !END SCAN OF FINAL SLATER STATES C C IF(LX) RETURN C C ELIMINATE COEFFICIENTS /DSSS/.LT.TYNY AND ARGUMENTS QSSS THAT HAVE C BEEN LISTED BEFORE IN THE REFERENCE LIST C 400 ICLRR=0 IF(IRSS.LT.IRSS0)RETURN !AS NONE C K=IRSS0-1 KP=0 DO I=NLS01,NLS IORIG2(I)=0 ENDDO C DO I=IRSS0,IRSS JD0=MSSS(I) JD=IABS(JD0) IF(ABS(DSSS(I)).LT.FSTYNY)THEN IF(IORIG2(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QSSS AS MAY OCCUR LATER GO TO 94 ENDIF K=K+1 DSSS(K)=DSSS(I) NSTJ2(K)=NSTJ2(I) NSTJ2D(K)=NSTJ2D(I) C 94 IF(JD.LE.NLS00)THEN WRITE(6,*)'RES1: INFORM NRB OF STOP HERE' WRITE(0,*)'RES1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 C LP=JD C GO TO 92 ENDIF C IF(IORIG2(JD).EQ.0)THEN LP=JD-KP DO L=1,NLS00 DO J=1,5 IF(QSSS(J,JD).NE.QSSS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG2(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG2(JD) GO TO 92 ENDIF C IORIG2(JD)=LP DO J=1,5 QSSS(J,LP)=QSSS(J,JD) ENDDO C 92 IF(JD0.NE.0)THEN MSSS(K)=LP C IF(JD0.LT.0)MSSS(K)=-MSSS(K) ENDIF C 91 ENDDO C NLS=NLS-KP IRSS=K C 999 RETURN C 1 IZX=1 GO TO 999 C END C C ******************* C SUBROUTINE RES2(DC,mam,nam,KK,IZX) C C----------------------------------------------------------------------- C C SR.RES2 EVALUATES ALGEBRAIC CONTRIBUTIONS TO THE SPIN-ORBIT MATRIX C ELEMENTS BY LOOPING OVER ALL SLATER-STATE INTERACTIONS - NRB. C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-7) PARAMETER (TTYNY=10*TYNY) PARAMETER (FSTYNY=10*TTYNY) C LOGICAL BFAST C CF77 INTEGER*8 MSS !F77 C REAL*8 DC DIMENSION DC(0:*),mam(*),nam(*) C COMMON /BASIC/NF,KF,KG,JGAP(5),NJ2,NJP2,MGAP(2) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL,NL000 C C IF(MXS2I.LT.MAXMI)GO TO 11 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C NL00=NL C NL1=NL00+1 C DO J=1,NLS JORIG2(J)=0 ENDDO C C C BEGIN MAIN LOOP 65 OVER SLATER STATE INTERACTIONS C K0=NADS2(KK-1)+1 C DO 65 KS=K0,NADS2(KK) C L1=NSTJ2(KS) L2=NSTJ2D(KS) C IF(BFAST)THEN DDH=DC(L1+NJ2)*DC(L2+NJP2)*DSSS(KS) ELSE m1=mam(l1) if(m1.eq.0)go to 65 m2=nam(l2) if(m2.eq.0)go to 65 DDH=DC(m1)*DC(m2)*DSSS(KS) ENDIF C IF(ABS(DDH).LT.TYNY)GO TO 65 C M=MSSS(KS) L=JORIG2(M) IF(L.GT.0)THEN K=IORIG2(L) DSS(K)=DSS(K)+DDH ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C L=NL+1 NL=L IRS=IRS+1 IF(IRS.GT.MXRSS)GO TO 1 IF(L.GT.MAXMI)GO TO 1 DO K=1,5 QSS(K,L)=QSSS(K,M) ENDDO JORIG2(M)=L IORIG2(L)=IRS MSS(IRS)=L DSS(IRS)=DDH ENDIF C 65 CONTINUE C C CLEAR THE ARRAY OF ZEROS AND ADJUST MSS(K) ACCORDINGLY C IF(IRS.LT.IRS0) RETURN C K=IRS0-1 KP=0 DO I=IRS0,IRS IF(ABS(DSS(I)).LT.FSTYNY)GO TO 90 K=K+1 DSS(K)=DSS(I) JD=INT(MSS(I)) LP=JD-KP DO L=1,NL00 DO J=1,5 IF(QSS(J,JD).NE.QSS(J,L))GO TO 94 ENDDO LP=L GO TO 91 94 ENDDO KP=KP-1 DO J=1,5 QSS(J,LP)=QSS(J,JD) ENDDO 91 MSS(K)=LP 90 KP=KP+1 ENDDO C NL=NL-KP IRS=K RETURN C 1 IZX=1 RETURN C 11 WRITE(6,991) WRITE(0,*)'***SR.RES2: SET MXS2I .GE. MAXMI ***' GO TO 1 C 991 FORMAT(/' SR.RES2: SET MXS2I .GE. MAXMI') END C C ******************* C SUBROUTINE RESX1(QLMC,NAM,qnf1,DFS,MAXEL) C C----------------------------------------------------------------------- C C SR.RESX1 CALCULATES THE SLATER-STATE SPIN-SPIN, MUTUAL SPIN-ORBIT C AND SPIN-OTHER ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE C PAIR BEING CONTINUUM. C C IT CALLS: C FN.VCC C C----------------------------------------------------------------------- C USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C PARAMETER (MXD27=MAXCF*MAXCF) PARAMETER (MXD31=MAXLL+1) PARAMETER (MXD32=MXD31*MXD31) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (TYNY=1.0D-6) PARAMETER (TTYNY=10*TYNY) PARAMETER (FSTYNY=10*TTYNY) C LOGICAL LN,LH,LK,LMM,BVC,LX,SKP,SPN,BSS,BSO,BSOO,BDLBD X ,BPLANT2,EQUALM,brev C DIMENSION QLMC(MAXEL,*),DFS(*),NAM(*),qnf1(*) X ,NEN(2,2),NES(2),Q1(2,2),Q2(2,2),Q3(2,2),Q4(2,2) X ,JSS(4),IGAM(5),VC(2),VK(2,3) C COMMON /BASIC/NF,NEK(2),JA,JB,MGAP(4),LLCH(2),MAXLX COMMON /CFCT/BVC,MXLL,VCA(MXD32,MXD32,MXD31) X ,VCB(MXD32,MXD32,MXD31),BDLBD COMMON /CMDVC/DVC12O,LX,ICLRR,EQUALM COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 COMMON /NRBLAM/MAXLAM,MXLAMX C SAVE BSS,BSO,BSOO DATA IFIRST/0/ C C MVC(MLX,MLY)=((MLX+2)*MLX/2+MLY )/2+1 C MXORBC=MXORB+LCONDWJ BPLANT2=MXORBC.LT.37 MPOSC=MXORB+(LCONDWJ+1)/2 C SKP=IDW.LT.0 !MXLL.EQ.-1 C NLS01=NLS00+1 IF(ICLRR.LT.0)GO TO 400 C mxlam=2*iabs(mxlamx) C KF=NEK(1) KG=NEK(2) brev=kf.lt.kg NF1=NF+1 C IF(IFIRST.NE.0)GO TO 109 C C GO TO (101,102,103,104,105,106,107,108),QQCUT C IF(QQCUT.EQ.1)THEN BSS=.TRUE. !101 BSO=.TRUE. BSOO=.TRUE. ELSEIF(QQCUT.EQ.2)THEN BSS=.FALSE. !102 BSO=.TRUE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.3)THEN BSS=.FALSE. !103 BSO=.FALSE. BSOO=.TRUE. ELSEIF(QQCUT.EQ.4)THEN BSS=.TRUE. !104 BSO=.FALSE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.5)THEN BSS=.FALSE. !105 BSO=.FALSE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.6)THEN BSS=.TRUE. !106 BSO=.FALSE. BSOO=.TRUE. ELSEIF(QQCUT.EQ.7)THEN BSS=.TRUE. !107 BSO=.TRUE. BSOO=.FALSE. ELSEIF(QQCUT.EQ.8)THEN BSS=.FALSE. !108 BSO=.TRUE. BSOO=.TRUE. ENDIF C 109 CONTINUE IFIRST=1 C C BEGIN MAIN SLATER-STATE INTERACTION LOOP (110) C DVC12=DVC12O C DO 110 J1=JA,JB C kk=nam(j1) if(brev.or.kk.lt.0)then kk=iabs(kk) i1=2 i2=1 else i1=1 i2=2 endif nes(i1)=kinti(kk) nes(i2)=kintf(kk) jc=nes(1) jd=nes(2) c c write(6,*)kf,jc,' ',kg,jd c IF(EQUALM)THEN IF(JD.GT.JC)GO TO 110 IF(JD.LT.JC)THEN DVC12=2*DVC12O ELSE DVC12=DVC12O ENDIF ENDIF C DO I=NLS01,NLS IORIG2(I)=0 ENDDO C NK=1 !0->1 SINCE CONT-CONT IS ONE DO K=1,2 !INITIALIZE NK=1 CONT-CONT NEN(K,1)=NF1 ENDDO C DDH=DONE !PHASE FACTOR FOR REMAINING NF-NK SETS C NU=0 IF(JD.EQ.JC)GO TO 240 !SO EQCFS=.TRUE C C NK.EQ.2 HERE C nk=2 nen2=ken2(kk) if(nen2.lt.0)then ddh=-ddh nen2=-nen2 endif nen(i1,2)=nen2/nf1 nen(i2,2)=nen2-nen(i1,2)*nf1 c C test c do k=1,2 c nen(k,1)=nen(k,2) c nen(k,2)=nf1 c enddo c go to 72 C C NOW NK=1 (CASE JC.EQ.JD ONLY NOW) C 240 NU=NU+1 IF(NU.GT.NF)GO TO 110 NEN(1,2)=NU C C THE ELECTRON LABELLED BY (K1,K2) BELONGS TO THE CONFIGURATION KX C AND TO THE SLATER STATE KY. K1=NO. OF ELECTRON WITHIN A PAIR AND C K2=NO. OF PAIR. C 72 DO l=1,2 !=1 FOR SLATER STATES JC (OF KF),=2 FOR JD (OF KG) I=L DO K=1,2 !=1 FOR FOR FIRST PAIR OF ELECTRON STATES,=2 FOR 2'ND IF(NK.LT.K)I=1 KP=NEN(I,K) LP=NES(I) MU=QLMC(KP,LP) LP=NEK(I) LP=QCG(KP,LP) IF(LP.GT.MXORB)THEN !CONTINUUM Q1(L,K)=LLCH(L) Q2(L,K)=(LLCH(L)-MTJ+1)/2+MPOSC if(jc.eq.jd.and.l.eq.2)mu=qnf1(jd) ELSE Q1(L,K)=QL(LP) Q2(L,K)=LP ENDIF c ML=((100+MU)/2)*2-100 ! 100 -> Q1=QL ML=Q1(L,K) ML=((ml+MU)/2)*2-ml Q3(l,k)=ML Q4(l,k)=(MU-ML)*2-1 ENDDO ENDDO C C INITIALIZE DATA FOR LAMBDA-LOOP C VK(1,2)=DZERO VK(1,3)=DZERO VK(2,2)=DZERO VK(2,3)=DZERO DV2=DZERO DV3=DZERO NI=0 KC=0 78 KB=0 C 265 L1=Q1(1,1+KC) L2=Q1(1,2-KC) IF(L1+L2.EQ.0)GO TO 14 L3=Q1(2,1+KB) L4=Q1(2,2-KB) IF(L3+L4.EQ.0)GO TO 14 MU=MIN0(L1+L3,L2+L4) MLAM2=MAX0(IABS(L1-L3),IABS(L2-L4)) MLAM0=MLAM2-4 IF(MLAM2.GT.0)MLAM2=MLAM0 MLAM0=MLAM0-4 IF(MLAM2.GT.MU)GO TO 76 if(mlam2.gt.mxlam)go to 76 JSS(1+KC)=Q2(1,1) JSS(2-KC)=Q2(1,2) JSS(3+KB)=Q2(2,1) JSS(4-KB)=Q2(2,2) ML1=Q3(1,1+KC) ML2=Q3(1,2-KC) ML3=Q3(2,1+KB) ML4=Q3(2,2-KB) C DSJ=SQRT(DBLE((L1+1)*(L2+1)*(L3+1)*(L4+1))) X *DBLE(MOD(IABS((KB+KC)*2+MLAM2-ML1-ML2),4)-1)*DDH*DVC12 C SPN=.FALSE. IF(SKP)GO TO 267 C MDIFF1=ML1-ML3 MDIFF2=ML2-ML4 NI=MIN0(IABS(MDIFF1),IABS(MDIFF2)) M1=Q4(1,1+KC) M2=Q4(1,2-KC) M3=Q4(2,1+KB) M4=Q4(2,2-KB) MD1=M1-M3 MD2=M2-M4 MST=MD1+MD2 DV1=VCC(1,2,1,M3,MD1,M1,DFS,MXDFS) DV2=VCC(1,2,1,M4,MD2,M2,DFS,MXDFS) C C SPIN-SPIN C DD1=DZERO IF(BSS)DD1=-VCC(2,2,4,MD1,MD2,MST,DFS,MXDFS) X *DV1*DV2*DTHREE/(DTWO*SQRT(DFIVE)) C M1=MVC(L1,-ML1) M2=MVC(L2,-ML2) M3=MVC(L3,ML3) M4=MVC(L4,ML4) DDR1=DZERO DDR2=DZERO IF(MD1*MD2.NE.0)SPN=.TRUE. IF(MD2.EQ.0)THEN IF(BSO)DDR1=DV1 IF(BSOO)DDR2=DV1+DV1 ENDIF IF(MD1.EQ.0)THEN IF(BSOO)DDR1=DV2+DV2+DDR1 IF(BSO)DDR2=DV2+DDR2 ENDIF C C ----- BEGIN OF LAMBDA-LOOP (INNER LOOP) C 267 MLAM=MLAM2 IF(MLAM.GT.MU)GO TO 76 if(mlam.gt.mxlam)go to 76 DSJ=-DSJ 40 MLAM2=MLAM0+2 MLAM1=MLAM2+2 VK(1,1)=VK(1,2) VK(1,2)=VK(1,3) VK(2,1)=VK(2,2) VK(2,2)=VK(2,3) VK(1,3)=DZERO VK(2,3)=DZERO DV1=DV2 DV2=DV3 DV3=DZERO IF(MLAM1.LT.NI)GO TO 59 LMM=MOD(MU-MLAM0,4).NE.0 IF(LMM)GO TO 59 LH=L1+L3.LT.MLAM1 LN=L2+L4.LT.MLAM1 LK=MLAM0.LT.0 .OR. MLAM0.NE.MLAM DD=DONE C IF(.NOT.SKP)THEN C C THE N-CASE MLAM=-2 (AND ALSO MLAM0.LT.MLAM) C KP=MLAM1/4 K1=KP+1 IF(.NOT.BVC)THEN IF(L1.GT.MXLL)GO TO 42 IF(L3.GT.MXLL)GO TO 42 ENDIF IF(.NOT.LK)THEN VC(1)=VCB(M1,M3,KP) IF(LH)GO TO 53 ENDIF VK(1,3)=VCA(M1,M3,K1) GO TO 53 C 42 IF(.NOT.LK)THEN VC(1)=VCC(L1,L3,MLAM0,0,0,0,DFS,MXDFS) X *VCC(L1,L3,MLAM2,-ML1,ML3,-MDIFF1,DFS,MXDFS) IF(LH)GO TO 53 ENDIF VK(1,3)=VCC(L1,L3,MLAM1,0,0,0,DFS,MXDFS)/ DBLE(MLAM1+1) X *VCC(L1,L3,MLAM1,-ML1,ML3,-MDIFF1,DFS,MXDFS) C 53 IF(.NOT.BVC)THEN IF(L2.GT.MXLL)GO TO 45 IF(L4.GT.MXLL)GO TO 45 ENDIF IF(.NOT.LK)THEN VC(2)=VCB(M2,M4,KP) IF(LN)GO TO 59 ENDIF VK(2,3)=VCA(M2,M4,K1) GO TO 46 C 45 IF(.NOT.LK)THEN VC(2)=VCC(L2,L4,MLAM0,0,0,0,DFS,MXDFS) X *VCC(L2,L4,MLAM2,-ML2,ML4,-MDIFF2,DFS,MXDFS) IF(LN)GO TO 59 ENDIF VK(2,3)=VCC(L2,L4,MLAM1,0,0,0,DFS,MXDFS)/ DBLE(MLAM1+1) X *VCC(L2,L4,MLAM1,-ML2,ML4,-MDIFF2,DFS,MXDFS) C 46 IF(.NOT.LH)DV3=VCC(MLAM1,MLAM1,2,MDIFF1,MDIFF2,-MST,DFS,MXDFS) X *VK(1,3)*VK(2,3) ENDIF C 59 MLAM0=MLAM2 IF(MLAM0.LE.MLAM)GO TO 40 IF(MLAM1.LT.NI)GO TO 267 !NEXT LAMBDA C C NOW MLAM2=MLAM+2 C AND MLAM1=MLAM+4 C IF(LMM)GO TO 60 DDR=DZERO ML=MLAM+200 IF(LK)GO TO 66 IF(IABS(L4-L2).GT.MLAM)GO TO 64 IF(LH)GO TO 62 IF(SKP)GO TO 70 C C FOLLOWING STATEMENT: SPIN-SPIN; THEREAFTER: MUTUAL SPIN-ORBIT. C DDR=SQRT(DBLE((MLAM+5)*MLAM1*(MLAM+3)*MLAM2*(MLAM+1)))*DD1* X VCC(MLAM1,MLAM,4,MDIFF1,MDIFF2,-MST,DFS,MXDFS)*VK(1,3)*VK(2,1) C IF(SPN) GO TO 68 C MD2=(MLAM2-L4+L2)*(MLAM2-L2+L4)*(L2-MLAM+L4) IF(MD2.EQ.0) GO TO 62 C C 2ND V2 C DDR=DDR-VCC(MLAM1,MLAM2,2,MDIFF1,MDIFF2,-MST,DFS,MXDFS) X *SQRT(DBLE((MLAM1+L2+L4)*(MLAM+5)*MD2) X /DBLE((MLAM+1)*MLAM1*32))*DDR2*VC(2)*VK(1,3) C 62 IF(SPN)GO TO 267 IF(IABS(L3-L1).GT.MLAM)GO TO 64 MD1=(MLAM2-L3+L1)*(MLAM2-L1+L3)*(L3-MLAM+L1) IF(MD1.EQ.0)GO TO 63 IF(SKP)GO TO 70 C C 1ST V2 C DDR=SQRT( DBLE((MLAM1+L1+L3)*MD1)/(32*MLAM2))*VC(1)*VK(2,1) X *DDR1*VCC(MLAM2,MLAM,2,MDIFF1,MDIFF2,-MST,DFS,MXDFS)+DDR C 63 IF(MLAM.EQ.0)GO TO 64 IF(SKP)GO TO 70 C C********************************************************************** C 1ST V3 , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER C , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL C , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON) C , SO STAY WITH MINUS FOR NOW. - NRB C********************************************************************** C DDR=DDR-SQRT( DBLE((MLAM+1)*MLAM)/ DBLE(64*MLAM2)) X *DBLE((L1*(L1+2)-L3*(L3+2)-MLAM*MLAM2))*DDR1*DV1 C 64 IF(LH)GO TO 68 IF(LN)GO TO 68 66 IF(SPN)GO TO 267 IF(SKP)GO TO 70 C C********************************************************************** C 2ND V3 , POS SIGN IN 1ST AND 2ND V3 GIVE M.JONES TABLE 2 -WERNER C , HOWEVER THEY DO NOT GIVE SAME RESULTS FOR CLOSED SHELL C , WHEN TREATED AS OPEN (2-BODY F.S.) AS CLOSED (BLUME-WATSON) C , SO STAY WITH MINUS FOR NOW. - NRB C********************************************************************** C DDR=DDR-DDR2*DV3 X *SQRT(DBLE((MLAM+5)*(MLAM+6))/DBLE(64*MLAM1)) X *DBLE((L2*(L2+2)-L4*(L4+2)-(MLAM+6)*MLAM1)) C 68 DD=DDR*DSJ GO TO 69 C 60 IF(SPN)GO TO 267 !NEXT LAMBDA ML=MLAM+100 IF(SKP)GO TO 70 C C V1 C DD=SQRT( DBLE(((MLAM+3)*MLAM2*MLAM1)/4))*DV2*DDR1*DSJ 69 IF(ABS(DD).LT.TTYNY)GO TO 267 !NEXT LAMBDA C 70 IGAM(5)=ML C----------------------------------------------------------------------- c c There is little to be gained here due to the lesser symmetry compared c to Slater integrals and the fact that we have a continuum pair. Also, c for l=l' the case of N(C'C;BB)=N(BC;C'B) for Bound and Continuum needs c a further flag so as to distinguish it from N(C'C;BB)=N(C'B;BC), c since in the former we need C'=M2 while in the latter C'=M1 for c distinct energies. The latter case needs its energy indexes to be c swapped when forming H. If want to implement then see also sr.fsintx c and sr.dwxbp. C C IMPOSE V(AB;CD)=V(AD;CB) C IMPOSE N(AB;CD)=N(AD;CB)=N(CD;AB)=N(CB;AD) C BY WAY OF FALLING ORDER - NRB C c IF(LMM)THEN !V c DO K1=1,3,2 c IGAM(K1)=JSS(K1) c ENDDO c K11=2 c ELSE !N c K11=1 c ENDIF c DO K1=K11,2 c IF(JSS(K1).LT.JSS(K1+2))THEN c KP=2 c JP=0 c ELSE c KP=0 c JP=2 c ENDIF c IGAM(K1)=JSS(K1+KP) c IGAM(K1+KP+JP)=JSS(K1+JP) c ENDDO c so do j=1,4 igam(j)=jss(j) enddo c C----------------------------------------------------------------------- C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C IF(BPLANT2)IPLANT=IGAM(5)+ X ((((IGAM(4)*MXORBC+IGAM(3))*MXORBC+IGAM(2))*MXORBC)+IGAM(1))* X 1000 C DO J=NLS01,NLS IF(.NOT.BPLANT2)THEN DO I=5,1,-1 !1,5 SLOWER IF(QSSS(I,J).NE.IGAM(I))GO TO 272 ENDDO ELSE IF(IPLANT.NE.JORIG2(J))GO TO 272 ENDIF L=J I=IORIG2(L) IF(I.GT.0)THEN DSSS(I)=DSSS(I)+DD GO TO 267 !NEXT LAMBDA ENDIF GO TO 301 272 ENDDO C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C NLS=NLS+1 IF(NLS.GT.MXS2I)GO TO 999 l=nls ! l -> nls below & remove C DO I=1,5 QSSS(I,L)=IGAM(I) ENDDO IF(BPLANT2)JORIG2(L)=IPLANT C 301 IRSS=IRSS+1 IF(IRSS.GT.MXS2C)GO TO 999 IORIG2(L)=IRSS MSSS(IRSS)=L DSSS(IRSS)=DD NSTJ2(IRSS)=JC NSTJ2D(IRSS)=JD C GO TO 267 !NEXT LAMBDA C C --- END OF LAMBDA-LOOP C 76 IF(KB.NE.0)THEN IF(KC.NE.0)GO TO 78 KC=1 GO TO 265 ENDIF KB=1 IF(KC.EQ.0)GO TO 265 14 IF(NK-1.EQ.0)GO TO 240 C 110 CONTINUE !END SLATER-STATE LOOP C C IF(LX) RETURN C C ELIMINATE COEFFICIENTS /DSSS/.LT.TYNY AND ARGUMENTS QSSS THAT HAVE C BEEN LISTED BEFORE IN THE REFERENCE LIST C 400 ICLRR=0 IF(IRSS.LT.IRSS0)RETURN !AS NONE C K=IRSS0-1 KP=0 DO I=NLS01,NLS IORIG2(I)=0 ENDDO C DO I=IRSS0,IRSS JD0=MSSS(I) JD=IABS(JD0) IF(ABS(DSSS(I)).LT.FSTYNY)THEN IF(IORIG2(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QSSS AS MAY OCCUR LATER GO TO 94 ENDIF K=K+1 DSSS(K)=DSSS(I) NSTJ2(K)=NSTJ2(I) NSTJ2D(K)=NSTJ2D(I) C 94 IF(JD.LE.NLS00)THEN WRITE(6,*)'RESX1: INFORM NRB OF STOP HERE' WRITE(0,*)'RESX1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 ENDIF C IF(IORIG2(JD).EQ.0)THEN LP=JD-KP DO L=1,NLS00 DO J=1,5 IF(QSSS(J,JD).NE.QSSS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG2(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG2(JD) GO TO 92 ENDIF C IORIG2(JD)=LP DO J=1,5 QSSS(J,LP)=QSSS(J,JD) ENDDO C 92 IF(JD0.NE.0)MSSS(K)=LP C 91 ENDDO C NLS=NLS-KP IRSS=K C 999 RETURN C END C C ******************* C SUBROUTINE RESX2(DC,iam,ibm,KK) C C----------------------------------------------------------------------- C C SR.RESX2 CALCULATES THE LEVEL-RESOLVED SPIN-SPIN, MUTUAL SPIN-ORBIT C AND SPIN-OTHER ORBIT INTERACTION BETWEEN PAIRS OF ELECTRONS, ONE C PAIR BEING CONTINUUM. C C----------------------------------------------------------------------- C USE COMMON_DMQSS3, ONLY: DSS,MSS,QSS !F95 USE COMMON_DMQSSS, ONLY: DSSS,MSSS,QSSS !F95 USE COMMON_NSTS2, ONLY: NADS2,NSTJ2,NSTJ2D,IORIG2,JORIG2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-6) PARAMETER (TTYNY=10*TYNY) PARAMETER (FSTYNY=10*TTYNY) c CF77 INTEGER*8 MSS !F77 C LOGICAL BFAST C REAL*8 DC DIMENSION DC(0:*),iam(*),ibm(*) C COMMON /BASIC/NF,KF,KG,NJ1,NJ2,NJP1,NJP2,MGAP(5) CF77 COMMON /DMQSS3/DSS(MXRSS),MSS(MXRSS),QSS(5,MAXMI) !F77 CF77 X ,NADR(0:MXAJS) !F77 CF77 COMMON /DMQSSS/DSSS(MXS2C),MSSS(MXS2C),QSSS(5,MXS2I) !F77 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS2/NADS2(0:MXD27),NSTJ2(MXS2C),NSTJ2D(MXS2C) !F77 CF77 X ,IORIG2(MXS2I),JORIG2(MXS2I) !F77 COMMON /NXRLS/IRS,IRS0 COMMON /NXRNL/NL,NL000 COMMON /NRBDW1/MXORB COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX C C IF(MXS2I.LT.MAXMI)GO TO 11 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C NL00=NL C NL1=NL00+1 C DO J=1,NLS JORIG2(J)=0 ENDDO C IRS0=IRS+1 c mtj2=(mtj/2)*2 C C BEGIN MAIN LOOP 65 OVER SLATER STATE INTERACTIONS C K0=NADS2(KK-1)+1 C DO 65 KS=K0,NADS2(KK) C L1=NSTJ2(KS) m1=iam(l1) if(m1.eq.0)go to 65 c L2=NSTJ2D(KS) C IF(BFAST)THEN DDH=DC(m1)*DC(L2+NJP2)*DSSS(KS) !DC(L1+NJ2) ELSE m2=ibm(l2) if(m2.eq.0)go to 65 DDH=DC(m1)*DC(m2)*DSSS(KS) ENDIF C IF(ABS(DDH).LT.TYNY)GO TO 65 C M=MSSS(KS) L=JORIG2(M) IF(L.GT.0)THEN K=IORIG2(L) DSS(K)=DSS(K)+DDH ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C L=NL+1 NL=L IRS=IRS+1 IF(IRS.GT.MXRSS)GO TO 1 IF(L.GT.MAXMI)GO TO 1 C DO K=1,5 QSS(K,L)=QSSS(K,M) ENDDO if(qss(1,l).gt.mxorb.and.qss(3,l).gt.mxorb x .or.qss(2,l).gt.mxorb.and.qss(4,l).gt.mxorb)then else qss(5,l)=qss(5,l)-mtj2 !exchange endif C JORIG2(M)=L IORIG2(L)=IRS MSS(IRS)=L DSS(IRS)=DDH ENDIF C 65 CONTINUE C C CLEAR THE ARRAY OF ZEROS AND ADJUST MSS(K) ACCORDINGLY C IF(IRS.LT.IRS0) RETURN C K=IRS0-1 KP=0 DO I=IRS0,IRS IF(ABS(DSS(I)).LT.FSTYNY)GO TO 90 K=K+1 DSS(K)=DSS(I) JD=INT(MSS(I)) LP=JD-KP DO L=1,NL00 DO J=1,5 IF(QSS(J,JD).NE.QSS(J,L))GO TO 94 ENDDO LP=L GO TO 91 94 ENDDO KP=KP-1 DO J=1,5 QSS(J,LP)=QSS(J,JD) ENDDO 91 MSS(K)=LP 90 KP=KP+1 ENDDO C NL=NL-KP IRS=K 1 RETURN C C 11 WRITE(6,991) WRITE(0,*)'***SR.RES2: SET MXS2I .GE. MAXMI ***' GO TO 1 C 991 FORMAT(/' SR.RES2: SET MXS2I .GE. MAXMI') END C C ******************* C SUBROUTINE RK1ST(X0,Y0,H,N,X1,Y1) C C----------------------------------------------------------------------- C C SR.RK1ST INTEGRATES 1 RUNGE-KUTTA STEP WITH INITIAL VALUES X0,Y0(N). C RESULT X1=X+H (H=LENGTH OF STEP), Y1(N)=SOLUTION AT X1. C FKT(X,Y,N,Z) REPRESENTS THE SYSTEM TO BE INTEGRATED, Z(N)= C DERIVATIVES. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DHALF=0.5D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) C DIMENSION Y0(*),Y1(*),Y(2),A(5),Z(2) C X1=X0 HH=H*DHALF A(1)=HH A(2)=HH A(5)=HH A(4)=H A(3)=H DO K=1,N Y(K)=Y0(K) Y1(K)=Y0(K) ENDDO C DO I=1,4 Z(1)=Y(2) Z(2)=DFOUR*X1*SQRT(Y(1)**3)+Y(2)/X1 X1=X0+A(I) DO K=1,N Y(K)=Y0(K)+A(I)*Z(K) Y1(K)=Y1(K)+A(I+1)*Z(K)/DTHREE ENDDO ENDDO C RETURN END C C ******************* C SUBROUTINE RKDIPI(ICOUNT,N,M8,MAXPS) C C----------------------------------------------------------------------- C C SR.RKDIPI CALCULATES DIPOLE PHOTOIONIZATION INTEGRALS INVOLVING C CONTINUUM FUNCTIONS (ORBITAL N) AT THE ICOUNT'TH INTERPOLATION ENERGY C INDEXED BY M8. C C----------------------------------------------------------------------- C USE COMMON_NRBRN2, ONLY: BINDB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD24=2*MAXGR) CF77 PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) !F77 CF77 PARAMETER (MXD37=MXBLM/2) !F77 C PARAMETER (MXD12=100) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DTON=100.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (D1PT05=1.05D0) PARAMETER (D1P6=1.0D6) PARAMETER (D1P10=1.0D10) PARAMETER (D8M4=8.0D-4) PARAMETER (D4M5=4.0D-5) PARAMETER (DQUART=DONE/DFOUR) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) C LOGICAL BREL,BJUMPR,BMVD,BLAG,BBC2,BSTO,BREL2,BLOOP X,BFOT,BJUMP,BJUMP2,BRAD,brtard,BWARN CF77 X ,BINDB !F77 C DIMENSION CP(100),CM(100),JDUM(100) C COMMON /CHARY/DEY(MAXGR) c COMMON /COM1/DL2(MAXB1),TOL,MDMM COMMON /COM3/DDY,DZ,TM c COMMON /COM6/DA(MAXB1) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),DSIGMA(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,ORIG(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MGAPP,MA0,MB0,KSUBCF COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDR/IDR,NMIN,NMAX,NS0,NSX,NSW,NRAD,JND,NDR(MXD12) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBFR/GR(MAXB1) COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLOO/BLOOP,LNEW,LCON,LSUM,LMAX COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBSPL/FR(MAXB1),DL1(MAXB1),DPH(MAXB1),BP(MAXB1) COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD c common /nrbnfg/fnorm,gnorm C DATA BWARN/.TRUE./ C ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C c brtard=irtard.ne.0 !only for brel=.true. BREL2=IABS(IREL).EQ.2 c DM=DZERO DD=DZERO PI=ACOS(-DONE) PIH=PI/DTWO MXRM=MAXPS-1 DZA=MION-NZION-1 C C NSW=LNEW*LNEW/4+NS0 C IF(NSW.GT.35)NSW=35 P100=DONE IF(NNEW.GE.NSW)P100=DTON C IF(PMIN.GT.DZERO)THEN !DETERMINE SAFE IPIG L=LNEW IF(L.LT.0)L=NNEW-1 LP=L+1 DE=DZA/NNEW DE=DE*DE+DDY E2=DDY/(DZA*DZA) C CALL DIPOL(1,NNEW,0,E2,LP,CP,CM,JDUM) C TL=L+L TLP=LP+LP T=TLP*CP(LP)*D1P10**JDUM(LP) IF(L.GT.0)T=T+TL*CM(L)*D1P10**JDUM(L) T=T*DE/DZA**4 IPIG=1 IF(T.LT.PMIN*P100)THEN !LENGTH FAILURE IPIG=0 c write(6,*)'switch to velocity, icount=',icount IF(T.LT.PMIN*P100/D1P6)THEN !VELOCITY FAILURE IF(BREL)THEN IF(BWARN)THEN WRITE(6,100)DYY(ICOUNT-1)/D1PT05 WRITE(0,101)DYY(ICOUNT-1)/D1PT05 BWARN=.FALSE. ENDIF CABORT WRITE(0,*)'ERROR: CANNOT USE ACC GAUGE FOR PI IN ICR MODE' CABORT M8=-1 CABORT GO TO 999 !RETURN ELSE IPIG=-1 c write(6,*)'switch to acceleration, icount=',icount IF(T.LT.PMIN*P100/(D1P6*D1P6))THEN !ACC. FAILURE (WARN) IF(NNEW.GE.NSW) X WRITE(6,*)'PI ACCELERATION MAYBE INACCURATE' ENDIF ENDIF ENDIF ENDIF IGAG(ICOUNT)=IPIG ENDIF C IF(IPIG.EQ.0)CALL DIFF(FR,DUM1,MNE,DHNS,MJH) !VELOCITY C IF(IPIG.LT.0)DAX=DZERO !ACCELERATION IF(IPIG.EQ.0)DAX=D8M4*(DONE-DZA)**2 !VELOCITY IF(IPIG.GT.0)DAX=D4M5*(DONE-DZA)**2 !LENGTH C C BEGIN DIPOLE PI LOOP C DO J=1,N C IF(DEY(J).EQ.DZERO)GO TO 332 IF(BJUMP.AND.IVAL(J).EQ.0)GO TO 332 IF(IYY(J).GT.0.AND.MODE.LE.2)GO TO 332 IF((QL(J)-QL(N))**2.NE.4)GO TO 332 IF(J.GE.MA0.AND.J.LE.MB0)GO TO 332 IN=ICOL(J,N,0) IF(.NOT.BINDB(IN,0))GO TO 332 brtard=irtard.ne.0.and.qn(j).gt.0 C DE=DEY(J)-DUY(J,J)-DDY*DHALF !A.U. IF(BREL)THEN TE=ABS(DE*DFSC) TJ=3/TE ENDIF C MN=0 IF(IPIG.GT.0)MN=1 !LENGTH IF(IPIG.LT.0)MN=-2 !ACCELERATION IF(QN(J).LT.0.AND.DDY.LE.DAX)MN=-2 !DITTO C IF(IPIG.EQ.0.AND.MN.EQ.0)THEN !VELOCITY IAP=1 MN=-1 DLL=DBLE(MAX(QL(J),QL(N))*(QL(N)-QL(J))/2) IF(BREL.and.brtard)THEN IF(BREL2)THEN T=-2*DE*TJ/3 DO I=1,MAXPS TZ=DX(I)*TE TB0=BESSJ(0,TZ) TB2=BESSJ(2,TZ) BP(I)=(DPNL(I,J)*FR(I)+DQNL(I,J)*GR(I))*TZ*(TB0-TB2/2) B0=(0*TB0+TZ*BESSJP(0,TZ)) B2=0 !(TB2+TZ*BESSJP(2,TZ)) BP(I)=BP(I)+(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))*(B0-B2/2) BP(I)=BP(I)*T ENDDO ELSE CALL DIFF(DPNL(1,J),BP,MNE,DHNS,MJH) DO I=1,MAXPS TZ=DX(I)*TE BP(I)=FR(I)*DPNL(I,J)*DLL*BESSJ(1,TZ)*TJ/DX(I)**2 X +(DUM1(I)*DPNL(I,J)-FR(I)*BP(I))*BESSJP(1,TZ)*3 ENDDO ENDIF ELSE IF(BREL2.and.qn(j).gt.0)THEN T=2/DFSC DO I=1,MAXPS BP(I)=(FR(I)*DPNL(I,J)+GR(I)*DQNL(I,J))*DLL/DX(I) X -(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))*T ENDDO ELSE DO I=1,MAXPS BP(I)=(FR(I)*DLL/DX(I)+DUM1(I)*2)*DPNL(I,J) ENDDO ENDIF ENDIF ELSE !LENGTH/ACCELERATION IAP=0 DO I=1,MAXPS BP(I)=DPNL(I,J)*FR(I) ENDDO IF(BREL2)THEN DO I=1,MAXPS BP(I)=BP(I)+DQNL(I,J)*GR(I) ENDDO ENDIF IF(MN.EQ.-2.AND.BFOT)THEN DO I=1,MAXPS BP(I)=-BP(I)*DERV(I) ENDDO ELSE IF(MN.EQ.1.AND.BREL.and.brtard)THEN IF(BREL2)THEN DO I=1,MAXPS TZ=DX(I)*TE TB=BESSJ(2,TZ) BP(I)=BP(I)*TJ*(BESSJ(1,TZ)-TZ*TB/2) B2=(TB+TZ*BESSJP(2,TZ))*TJ/2 BP(I)=BP(I)-(FR(I)*DQNL(I,J)-GR(I)*DPNL(I,J))*B2 ENDDO ELSE DO I=1,MAXPS TZ=DX(I)*TE BP(I)=BP(I)*TJ*BESSJ(1,TZ) ENDDO ENDIF ELSE DO I=1,MAXPS BP(I)=BP(I)*DX(I)**MN ENDDO ENDIF IF(MN.EQ.1.AND.ALAV*RCAV.NE.DZERO)THEN DO I=1,MAXPS BP(I)=BP(I)*(DONE- X ALAV*(DONE-EXP(-(DX(I)/RCAV)**3))/DX(I)**3) ENDDO ENDIF ENDIF ENDIF C CALL WEDDLE(DM,BP,DD,MNE,DHNS,MJH,MAXPS) C REM=DZERO IST=1 IF(QN(J).GT.0)GO TO 339 IST=2 IF(MN.EQ.0)GO TO 339 C C LONG-RANGE INTEGRAL F*G*X**MN (VEL ALSO FP*G) C DX1=DX(MAXPS) DT=DX(MAXPS)-DX(MXRM) ML1=QL(N)/2 DS=ML1*(ML1+1) ML2=QL(J)/2 DC=ML2*(ML2+1) DNORM=-QN(J) DNORM=DNORM-DSIGMA(J) TN=DZA/DNORM TN=TN*TN DNORM=TN/(PIH*DNORM) DNORM=SQRT(DNORM) TN=DSIGMA(J) C DO IAA=0,IAP MN=MN+IAA F0=FR(MXRM) F1=FR(MAXPS) G0=DPNL(MXRM,J) G1=DPNL(MAXPS,J) IF(IAA.EQ.0)THEN CALL ASS2X(DX1,DT,DX2,F0,F1,G0,G1,DDY,DM,DS,DC,DM,DM,DM,DM, X DZA,MN,REM2) TMP=TM ctest rem00=0. !ctest ELSE !VEL: F=A*SIN(B), SO FP=A*BP*COS(B)+ap*sin(b) P0=DUM1(MXRM) P1=DUM1(MAXPS) CALL ASS2PX(DX1,DT,DX2,F0,F1,P0,P1,G0,G1,DDY,DM,DS,DC,DM, X DM,DM,DM,DZA,MN,REM2) c ctest contribution from ap*sin(b) ctest rem00=0. ctest call assx(dx2,mn-2,tm,tn,ddy,dm,dza,ml1,ml2,ds,dc ctest x ,dm,dm,dm,dm,rem00) ctest rem00=-rem00*dnorm*dza/(dtwo*ddy) c ctest contribution from a*(z/k)*cos(b)/r ctest rem00=0. ctest call assx(dx2,mn-1,tm+dhalf,tn,ddy,dm,dza,ml1,ml2,ds,dc ctest x ,dm,dm,dm,dm,rem00) ctest rem00=-rem00*dnorm*dza/sqrt(ddy) c TE=DDY TZ=DZA IF(BREL)THEN TZ=TZ+DHALF*DALF*TZ*TE TE=TE+DQUART*DALF*TE*TE ENDIF PNORM=DSQRT(TE)*(done-tz/(te*dx2)) !approx z/r contrib. DNORM=DNORM*PNORM !NORM*BP TMP=TM+DHALF !AS ASSX EXPECTS SIN ENDIF C REM0=DZERO C CALL ASSX(DX2,MN,TMP,TN,DDY,DM,DZA,ML1,ML2,DS,DC,DM,DM,DM,DM, X REM0) C REM0=REM0*DNORM !+rem00 !ctest c c if(iaa.gt.0)then c f1=p1 c f1=f1/pnorm !as ddy.ne.0 here c g1=g1*pnorm c endif c if(fnorm.ne.dzero)f1=f1/fnorm c if(gnorm.ne.dzero)g1=g1/(gnorm*dnorm) cc c write(6,*)'*** ',mn,rem2,rem0,f1,g1,dx1,dx2 c REM0=REM2+REM0 IF(MN.EQ.-1)REM0=REM0*DLL IF(MN.EQ.0)REM0=REM0*2 REM=REM+REM0 ENDDO C IF(MN.EQ.-2)THEN REM=-REM*DZA !BFOT=.TRUE. HERE DE=DONE ELSE DE=-DHALF*DDY CWORSEDE=0.5*DDY+DSHIFT(J) ENDIF C 339 IF(.NOT.BJUMP)M8=M8+1 IF(BJUMP)M8=NFOSS(N,J) NFOSS(N,J)=M8 C c write(6,*)j,n,icount,ist,mn,dd,rem,dd+rem,tm,tn c DD=DD+REM IF(MN.EQ.-2)DD=DD/DE**2 !ACC IF(MN.EQ.-1.OR.mn.eq.0)DD=-DD/(2*DE) !VEL IF(QN(J).LT.0)DD=DD*DE**2 !FOR INTERP C DFOSS(M8,ICOUNT,IST)=DD C 332 ENDDO !END DIPOLE PI LOOP C CABORT 999 CONTINUE RETURN C 100 FORMAT(//'*** SR.RKDIPI: ERROR, CANNOT USE ACC GAUGE FOR PI IN' X ,' ICR MODE, REDUCE EMAX (RYD) TO:',F6.0/4X X ,'CONTINUING WITH VELOCITY GAUGE, AT YOUR OWN RISK -' X ,' NO MORE WARNINGS!'/) 101 FORMAT(/'*** STRONG WARNING: VEL GAUGE LIKELY INACCURATE ***'/ X ,' (NO ACC GAUGE FOR ICR MODE) YOU ARE ADVISED TO REDUCE' X ,' EMAX(RYD) TO:',F6.0/4X,'PROCEED AT YOUR OWN RISK -' X ,' NO MORE WARNINGS!'/) C END C C ******************* C SUBROUTINE RKINT(BPRNT0) C C----------------------------------------------------------------------- C C SR.RKINT CALCULATES R^K RADIATIVE MULTIPOLE INTEGRALS FOR BOUND-BOUND C AND BOUND-FREE TRANSITIONS. C OPTIONALLY, CALCAULATES FINITE AND/OR INFINITE ENERGY BORN INTEGRALS. C C LENGTH IN LOWER TRIANGLE OF DOSC, VELOCITY IN UPPER. C ACCELERATION STORED IN ACC (USES NZION/R FOR THE POTENTIAL). C C----------------------------------------------------------------------- C USE COMMON_NRBRN2, ONLY: BINDB,MENGB !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD09=MXBLM+2) !+2 CASE BREL PARAMETER (MXD24=2*MAXGR) PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) PARAMETER (MXD28=(MAXGR*(MAXGR+1))/2) PARAMETER (MXD33=(MXGRB*(MXGRB+1))/2) PARAMETER (MXD34=((MXD33+1)*MXD33)/2) PARAMETER (MXD37=MXBLM/2) PARAMETER (MXD39=MXGRB/MAXGR) !=0 (FINITE E) OR 1 (INF. E ONLY) C !BORN MOM. TRANSFER (K) INFO PARAMETER (NLAGB=4) !PT LAG, EVEN, CORRELATE WITH NPDEC PARAMETER (NPDEC=4) !NO. OF K-STEPS PER DECADE PARAMETER (IVV0=3) !STARTING AT 10**-IVV0 PARAMETER (NDEC=IVV0+2) !NO. OF DECADES (ALLOW K-SHELL) C PARAMETER (MXNXV=NDEC*NPDEC+3) !NO. OF K_MAX (INC ZERO & INF) PARAMETER (MXD21=IVV0*NPDEC-NPDEC/4+3) !NO. OF K_MIN: UP TO 1.0 PARAMETER (MXD38=(1-MXD39)*((MXNXV*(MXNXV-1))/2 X -((MXNXV-MXD21)*(MXNXV-1-MXD21))/2)+MXD39) C PARAMETER (MXNXB=10) !NO. OF BPW X-VALUES (THRESH. UNITS) PARAMETER (MXNXB1=MXNXB+1) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (D1PT1=1.1D0) PARAMETER (D0PT35=0.35D0) PARAMETER (PIH=1.5707963D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (DBIG=100.0D0) PARAMETER (D1M6=1.0D-6) C CHARACTER(LEN=3) IEXP,PIG CHARACTER(LEN=4) CODE CHARACTER(LEN=5) XMANT C LOGICAL BPRNT0,BFOT,BFOTJ,BNOVAR,BSTO,BBORN,BJUMP,BJUMP2 X,BPOL,BREL,BJUMPR,BMVD,BRAD,BLAG,BBC2,BORT,BREL2,brtard CF77 X ,BINDB !F77 C X,BBC1 C DIMENSION LIMR(MAXGR),IHAR(MAXGR),DDY(MXENG),VV(MXNXV) C COMMON /BASIC/NF,MGAP(11) COMMON /CACC/ACC(MAXGR,MAXGR) COMMON /CCLSH/NW,NNL(MAXCL,3) COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,IEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /TRANS/DRL(MAXRL),DOSC(0:MXD09,MAXGR,MAXGR) X ,NADRU(MAXTM),NAI(MAXTM),NC0,JORIG(MAXTM) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSH,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRNT0,MR,MA0,MB0,KSUBCF COMMON /NRBAL2/MDEL,MXORB,MPOL0,MPOLE,MPOLX,CODE COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBFOT/DERV(MAXB1),BFOT COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBORN/BL(MXD38,MXD34,0:MXD37),OBO(MXD38),TM2(MXD34) COMMON /NRBRN1/SBL(MXD33),DBL(MXD33,MXBIF),DG(0:MXBLM) X ,MB3(0:MXD33),MB4(0:MXD33),INDX(MXD28) X ,INDK(MXD34),INDL(MXD34) c x,iflagb(mxd34) CF77 COMMON /NRBRN2/BINDB(MXD28,0:MXD37),MENGB !F77 COMMON /NRBRN3/V0(MXNXV),V1(MXNXV),XB(MXNXB),XS(0:MXNXB1) X ,DB0(MXNXV),DB1(MXNXV),OMEGAB(0:MXNXB1) X ,MV0,MV1,XMANT(0:MXNXB1),IEXP(0:MXNXB1),MINFB COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSHF/DSHIFT(MAXGR),MSHFT COMMON /NRBTS1/DFOT(MXENG),DFOSS(MXD24,MXENG,2) X ,PMIN,NFOSS(MAXGR,MAXGR),IPIG,IGAG(MXENG) COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD C ICOL(ILI,ILF,IONE)=((ILF-1)*(ILF-2*IONE))/2+ILI C C C INITIALIZE LOGICALS C c brtard=irtard.ne.0 !only for brel=.true. BREL2=IABS(IREL).EQ.2 BBORN=MENGB.GE.0 BFOTJ=.NOT.BFOT.OR..NOT.BLAG IF(.NOT.BFOTJ.AND.PMIN.GT.DZERO)IPIG=1 BORT=MORT.LT.0 BNOVAR=(JPRINT.GE.0.OR.JPRINT.LT.0.AND.INCLUD.EQ.0) X .AND..NOT.BPRNT0 C C SET CHARGES ETC. C NZA=NZION-MION+1 DZA=-NZA DZM=-NZION DDY(1)=DONE MXRM=MAXRS-1 mxmm=0 C C INITIALIZE FOR PI C IF(BFOT)THEN PIG='VAR' IF(IPIG.LT.0)THEN !ACCELERATION DAX=DZERO PIG='ACC' ELSEIF(IPIG.EQ.0)THEN !VELOCITY DAX=8.D-4*(DONE-DZA)**2 PIG='VEL' ELSEIF(IPIG.GT.0)THEN !LENGTH DAX=4.D-5*(DONE-DZA)**2 IF(PMIN.LT.DZERO)PIG='LEN' !OR VARIABLE ENDIF NAX=0 IF(BLAG)THEN DO I=1,MENG IF(DYY(I).LT.DAX)NAX=I ENDDO NAX=NAX+1 ENDIF ENDIF C C INITIALIZE FOR NLAG-POINT LAGRANGE INTERPOLATION FORMULA FOR C BOUND-CONTINUUM INTEGRALS. C NLAG MUST BE AN EVEN NUMBER .GE. 4 . READ IN SRADCON. C DEFAULT: NLAG=6. C C NLAG2=NLAG-2 NP1=1 NP2=MAX(1,NLAG) NPH=NP2/2 C BBC1=MENG.LE.NP2 C IF(BBC1)NP2=MENG C C INITIALIZE NLAGB-POINT LAGRANGE INTERPOLATION FORMULA FOR C BORN INTEGRALS. C NLAGB MUST BE AN EVEN NUMBER, DEFAULT: NLAGB=4. C NPDEC DETERMINES THE NODES AND IS THE NUMBER OF INTERVALS PER C DECADE (OF MOMENTUM TRANSFER), DEFAULT: NPDEC=4. C THUS, THE VALUES OF NLAGB AND NPDEC ARE INTERTWINED. C IF(MENGB.EQ.0)THEN !FINITE ENERGY BORN MV0=MXD21 MV1=MXNXV !K-SHELL IF(MA0.EQ.1)THEN !NO K-SHELL MV0=MV0-1 MV1=MV1-NPDEC ENDIF IF(NLAGB.GT.MV0)THEN WRITE(6,*)'NOT ENOUGH K-VALUES FOR MOM. TRANSF. INTERP' X ,MV0,NLAGB WRITE(0,*)'NOT ENOUGH K-VALUES FOR MOM. TRANSF. INTERP' GO TO 999 ENDIF DELTA=DONE/NPDEC DELTA=10**DELTA VV(2)=10**IVV0 VV(2)=DONE/VV(2) MV11=MV1-1 DO I=3,MV11 VV(I)=VV(I-1)*DELTA ENDDO VV(1)=VV(2)/2 !FIRST POINT VV(MV1)=10*VV(MV11) !INFINITE ENERGY POINT MINFB=MV11 DO I=1,MV1 V1(I)=VV(I)*NZA ENDDO DO I=1,MV0 V0(I)=VV(I)*NZA MENGB=MENGB+MV1-I ENDDO IF(MENGB.GT.MXD38)THEN !SHOULD NOT HAPPEN NOW WRITE(6,*)'***INCREASE MXD38 TO',MENGB WRITE(0,*)'***INCREASE MXD38' GO TO 999 ENDIF ELSEIF(MENGB.EQ.1)THEN !INFINITE ENERGY BORN ONLY MINFB=1 V0(1)=DZERO V1(1)=DBIG*NZA ELSE MINFB=1 ENDIF C IF(BPRNT0.AND.BBORN)THEN IF(MENGB.GT.1)THEN WRITE(6,706)MV0,MV1,(I,V1(I),I=1,MV1) WRITE(6,707)((I,J,J=I+1,MV1),I=1,MV0) ENDIF WRITE(6,704) ENDIF C DD0=DZERO N=0 !WATCH THIS NC=0 MB3(0)=0 IF(BBORN)THEN !BORN INDEX c tt=-done !for logging run only DO J=0,MXD37 DO I=1,MXD34 DO K=1,MENGB BL(K,I,J)=DZERO c obo(k)=done !for logging run only ENDDO ENDDO ENDDO ENDIF C DO K=1,MXORB !*****BEGIN OUTER ORBITAL LOOP C IHAR(K)=10000 IF(DEY(K).EQ.DZERO)GO TO 825 C IF(K.LE.IABS(MPSEUD))GO TO 825 IF(BNOVAR.AND..NOT.BBORN.OR.BJUMP2)GO TO 116 DO I=1,MAXRS DPA(I)=DPNL(I,K) IF(ABS(DPA(I)).GT.D1M6)LIMR(K)=I ENDDO IF(.NOT.BNOVAR)CALL DIFF(DPA,DP, MNH,DHNS,MJH) 116 IHAR(K)=QL(K)/2 NGROUP=K C 825 DO J=1,K !***BEGIN INNER ORBITAL LOOP C DD=DZERO DB=DZERO IF(DEY(J)*DEY(K).EQ.DZERO)GO TO 828 C IF(J.LE.IABS(MPSEUD))GO TO 828 M=IVAL(K)+IVAL(J) IF(BJUMP.AND.M.EQ.0)GO TO 828 IF(.NOT.BJUMP2)GO TO 117 C TM=FACT(K)*FACT(J) DOSC(1,K,J)=TM*DOSC(1,K,J) ACC(K,J)=TM*ACC(K,J) C IF(J.EQ.K)GO TO 828 DOSC(1,J,K)=TM*DOSC(1,J,K) IF(BFOTJ)GO TO 828 M8=NFOSS(K,J) IF(M8.EQ.0)GO TO 828 C DO I=1,MENG DFOSS(M8,I,2)=TM*DFOSS(M8,I,2) ENDDO GO TO 340 C C INITIALIZE DOSC TO ZERO C 117 DO I=0,MXD09 DOSC(I,K,J)=DZERO DOSC(I,J,K)=DZERO ENDDO ACC(K,J)=DZERO C OVL=DONE IF(IRLX.EQ.2)THEN !OVERLAPS KF=IGRCF(J) KG=IGRCF(K) IF(KF.NE.KG.AND.KF*KG.GT.0)THEN K1=MIN(KF,KG) K2=MAX(KF,KG) KK=((K2-1)*(K2-2))/2+K1 IF(IPAIR(KK).EQ.1)OVL=OVLPCF(KK) ENDIF ENDIF C C MODE .LE. 2 SET CONTINUUM-CONTINUUM TO ZERO C IF(MODE.LE.2.AND.QN(J).LT.0.AND.QN(K).LT.0)GO TO 338 C IF(.NOT.BREL.AND.IGAGR.LT.0.AND..NOT.BBORN.AND.QL(K)+QL(J).EQ. X 0)GO TO 827 LM=IABS(QL(K)-QL(J))/2 M=LM IF(M.EQ.0)M=2 IF(M.GT.MPOLE/2)GO TO 827 C IF(M.GE.2.AND.NPRINT.LT.0.AND.BNOVAR)GO TO 827 MM=M M0=M LL=QL(K)+QL(J) LP=LL/2 LP=MIN(LP,MPOLE/2) IF(BREL)LP=LP+2 !FOR RETARDATION IF(LP.EQ.0.AND.IGAGR.GT.0)LP=2 C IF(.NOT.BBORN)GO TO 841 IF(MENGB.EQ.1.AND.LP.EQ.1)GO TO 841 IF(NW.GT.0)THEN IF(J.LE.NNL(NW,1))GO TO 841 ENDIF IF(LL.GT.MPOLE)WRITE(6,705)LL/2 C C BORN C NC=NC+1 IF(NC.GT.MXD33)GO TO 841 MB4(NC)=J MB3(NC)=K IN=ICOL(J,K,0) INDX(IN)=NC JP=MOD(LM,2) C DO I=1,NC KM=IABS(QL(MB3(I))-QL(MB4(I)))/2 IP=MOD(KM,2) IF(IP.EQ.JP)THEN KP=(QL(MB3(I))+QL(MB4(I)))/2 KM=MAX(KM,LM) IF(MENGB.EQ.1.AND.KM.EQ.1)KM=KM+2 !SKIP DIPOLE KP=MIN(KP,LP) IF(KM.LE.KP)THEN N0=N IM=ICOL(MB4(I),MB3(I),0) DO LAM=KM,KP,2 LH=LAM/2 IF(BINDB(IN,LH).AND.BINDB(IM,LH))THEN !NEEDED N0=N+1 C CALL BORN(LAM,K,J,MB3(I),MB4(I),IHAR,LIMR,MENGB X ,MV0,MV1,V0,V1,OBO,OINT,TT) C IF(LAM.LT.0)GO TO 999 !FAILURE IF (LAM.EQ.1)TM2(N0)=TT DO IE=1,MENGB BL(IE,N0,LH)=OBO(IE) ENDDO IF(BPRNT0)WRITE(6,699)N0,NC,K,J,MB3(I),MB4(I) X ,2*LAM,(BL(IE,N0,LH),IE=1,MENGB) ENDIF ENDDO IF(N0.EQ.N+1)THEN N=N+1 INDL(N)=NC INDK(N)=I ENDIF ENDIF ENDIF ENDDO IF(QL(K)+QL(J).EQ.0.AND.IGAGR.LT.0)GO TO 827 !.AND.NOT.BREL C C LENGTH C 841 IN=ICOL(J,K,0) c c 840 write(6,*)in,j,k,m,bindb(in,m/2) 840 IF(.NOT.BINDB(IN,M/2))THEN M=M+2 MM=M IF(MM.LE.LP)GO TO 840 GO TO 827 ENDIF C C BEGIN MULTIPOLE LOOP C 842 BPOL=MM.EQ.1.AND.ALAV*RCAV.NE.DZERO IF(BREL2)THEN DO I=1,MAXRS DPA(I)=DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J) DPA(I)=DPA(I)*DX(I)**MM ENDDO ELSE DO I=1,MAXRS DPA(I)=DPNL(I,K)*DPNL(I,J)*DX(I)**MM ENDDO ENDIF IF(BPOL)THEN DO I=1,MAXRS DPA(I)=DPA(I)*(DONE- X ALAV*(DONE-EXP(-(DX(I)/RCAV)**3))/DX(I)**3) ENDDO ENDIF C CALL WEDDLE(DD0,DPA,DB,MNH,DHNS,MJH,MAXRS) C DB=DB*OVL C c del=dey(j)-duy(j,j)-(dey(k)-duy(k,k)) !test use of orb ener a.u. IF(MM.GT.0)THEN IF(MM.EQ.M0)THEN DOSC(0,K,J)=DB DD=DB ENDIF DOSC(MM,K,J)=DB MM=MM+2 c if(mm.le.lp)write(6,*)in,j,k,mm,bindb(in,mm/2) IF(MM.LE.LP.AND.BINDB(IN,MM/2))GO TO 842 !TO NEXT MULTIPOLE ELSE c db=db/del**2 !test use of orb ener a.u. ACC(K,J)=-DB*DZM GO TO 641 ENDIF C C ACCELERATION (DIPOLE) C ACC(K,J)=DZERO IF(BNOVAR)GO TO 827 IF(M.LT.2)THEN MM=-2 IF(.NOT.BFOT)GO TO 842 IF(BREL2)THEN DO I=1,MAXRS DPA(I)=DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J)*DERV(I) ENDDO ELSE DO I=1,MAXRS DPA(I)=DPNL(I,K)*DPNL(I,J)*DERV(I) ENDDO ENDIF C CALL WEDDLE(DD0,DPA,DB,MNH,DHNS,MJH,MAXRS) C DB=-DB*OVL ACC(K,J)=DB ENDIF C C VELOCITY C 641 MM=M C C BEGIN MULTIPOLE LOOP C 741 MMM=MM-1 D2=(IHAR(K)+1)*IHAR(K)-(IHAR(J)+1)*IHAR(J) IF(BREL2)THEN T=MM*2/DFSC DO I=1,MAXRS DPA(I)=((DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J))*D2/DX(I) X -(DPNL(I,K)*DQNL(I,J)-DQNL(I,K)*DPNL(I,J))*T) X *DX(I)**MMM ENDDO ELSE DD2=D2+MMM*MM DO I=1,MAXRS DPA(I)=(DPNL(I,K)*DD2/DX(I)+DP(I)*MM*2)*DPNL(I,J) X *DX(I)**MMM ENDDO ENDIF C CALL WEDDLE(DD0,DPA,DC,MNH,DHNS,MJH,MAXRS) C DC=DC*OVL c dc=-dc/(del*2) !test use of orb ener a.u. C IF(J.NE.K)THEN IF(MM.EQ.M0)DOSC(0,J,K)=DC DOSC(MM,J,K)=DC ELSE DOSC(MM-1,J,K)=DC !PUT DIAGONAL VELOCITY DOWN 1 POLE ENDIF MM=MM+2 IF(MM.LE.LP.AND.BINDB(IN,MM/2))GO TO 741 !TO NEXT MULTIPOLE C C DIPOLE PHOTOIONIZATION C (OPTIONALLY, TEST FULL RETARDATION ON B-B, LOWEST MULTIPOLE ONLY.) C 827 M8=NFOSS(K,J) IF(M8.GT.0.or.irtard.lt.0.and.qn(j).ne.qn(k))THEN MM=M IF(IRLX.EQ.2.and.m8.gt.0)THEN DO I=1,MENG DFOSS(M8,I,1)=DFOSS(M8,I,1)*OVL ENDDO ENDIF C IF(IYY(K).GT.0)THEN DEL=DEY(J)-DUY(J,J)-DYY(NREL) !A.U. ELSE DEL=DEY(J)-DUY(J,J)-DEY(K)+DUY(K,K) !A.U. ENDIF c brtard=irtard.ne.0.and.qn(j).gt.0 C ALWAYS DO PI LENGTH IF(BREL.and.brtard.and.mm.le.mxd09)THEN MP=MM+1 TE=abs(DFSC*DEL) TJ=3/TE**MM DO I=2,MM TJ=TJ*(2*I+1) ENDDO IF(BREL2)THEN DO I=1,MAXRS TZ=DX(I)*TE TB=BESSJ(MP,TZ) DPA(I)=(DPNL(I,K)*DPNL(I,J)+DQNL(I,K)*DQNL(I,J)) X *TJ*(BESSJ(MM,TZ)-TZ*TB/MP) B2=(MM*TB+TZ*BESSJP(MP,TZ))*TJ/MP DPA(I)=DPA(I)- X (DPNL(I,K)*DQNL(I,J)-DQNL(I,K)*DPNL(I,J))*B2 ENDDO ELSE DO I=1,MAXRS TZ=DX(I)*TE DPA(I)=DPNL(I,K)*DPNL(I,J)*TJ*BESSJ(MM,TZ) ENDDO ENDIF IF(BPOL)THEN DO I=1,MAXRS DPA(I)=DPA(I)*(DONE- X ALAV*(DONE-EXP(-(DX(I)/RCAV)**3))/DX(I)**3) ENDDO ENDIF C CALL WEDDLE(DD0,DPA,DD,MNH,DHNS,MJH,MAXRS) DD=DD*OVL IF(MM.EQ.M0)DOSC(0,K,J)=DD DOSC(MM,K,J)=DD else if(brel.and.brtard)then mxmm=max(mxmm,mm) go to 828 endif ENDIF C IF(IPIG.GT.0.and.m8.gt.0)DFOSS(M8,NREL,1)=DD !LENGTH C IF(IPIG.LT.0)THEN !ACCELERATION IF(BREL)THEN WRITE(6,*)'***SR.RKINT: ERROR, ACC GAUGE NOT CODED FOR' X ,' PI WITH RELATIVISTIC ORBITALS' WRITE(0,*)'***SR.RKINT: ERROR, ACC GAUGE NOT CODED FOR' X ,' PI WITH RELATIVISTIC ORBITALS' GO TO 999 ENDIF T=-DONE IF(.NOT.BFOT)THEN IP=K IF(.NOT.BORT)IP=QL(K)/2+1 IF(DADJUS(IP).LT.DZERO)T=DZA!not if use orb ener. above IF(DADJUS(IP).GE.DZERO)T=DZM!not if use orb ener. above ENDIF c DEL=DEY(J)-DUY(J,J)-DYY(NREL) !not if use orb ener. above DB=-DB*T/DEL**2 !not if use orb ener. above if(m8.gt.0)DFOSS(M8,NREL,1)=DB ENDIF C IF(IPIG.EQ.0)THEN !VELOCITY IF(BREL.and.brtard)THEN C MP=MM+1 C DEL=DEY(J)-DUY(J,J)-DYY(NREL) C TE=abs(DFSC*DEL) C TJ=3/TE IF(BREL2)THEN MMM=MM-1 T=-2*DEL*TJ/(2*MM+1) DO I=1,MAXRS TZ=DX(I)*TE TB0=BESSJ(MMM,TZ) TB2=BESSJ(MP,TZ) DPA(I)=(DPNL(I,J)*DPNL(I,K)+DQNL(I,J)*DQNL(I,K))*TZ X *(TB0-TB2*MM/MP) B0=(0*TB0+TZ*BESSJP(MMM,TZ)) B2=0 !(TB2+TZ*BESSJP(MP,TZ)) DPA(I)=(DPNL(I,K)*DQNL(I,J)-DQNL(I,K)*DPNL(I,J)) X *(B0-B2*MM/MP)+DPA(I) DPA(I)=DPA(I)*T ENDDO ELSE DD2=(IHAR(K)+1)*IHAR(K)-(IHAR(J)+1)*IHAR(J) CALL DIFF(DPNL(1,J),DPA,MNH,DHNS,MJH) DO I=1,MAXRS TZ=DX(I)*TE DPA(I)= X DPNL(I,J)*DPNL(I,K)*DD2*BESSJ(MM,TZ)/DX(I)**2 X +(DP(I)*DPNL(I,J)-DPNL(I,K)*DPA(I))*BESSJP(MM,TZ)*TE DPA(I)=DPA(I)*TJ ENDDO ENDIF CALL WEDDLE(DD0,DPA,DC,MNH,DHNS,MJH,MAXRS) C IF(J.NE.K)THEN IF(MM.EQ.M0)DOSC(0,J,K)=DC DOSC(MM,J,K)=DC ELSE DOSC(MM-1,J,K)=DC !PUT DIAGONAL VELOCITY DOWN 1 POLE ENDIF ELSE MX=MM IF(J.EQ.K)MX=MMM DC=DOSC(MX,J,K) ENDIF c DEL=DEY(J)-DUY(J,J)-DYY(NREL)!not if use orb ener. above if(m8.gt.0) X DFOSS(M8,NREL,1)=-DC/(DEL*2)!=dc if use orb. ener. above ENDIF ENDIF GO TO 828 C C CASE OF RYDBERG APPROX BY ZERO-ENERGY CONTINUUM C 338 IF(.NOT.BFOT)GO TO 828 IF(DEY(J)*DEY(K).EQ.DZERO)GO TO 828 C IF(J.LE.IABS(MPSEUD))GO TO 828 IF(IYY(J).GT.0.OR.IYY(K).LT.0)GO TO 828 IF((QL(J)-QL(K))**2.NE.4)GO TO 828 IN=ICOL(J,K,0) IF(.NOT.BINDB(IN,0))GO TO 828 C MN=0 IF(IPIG.GT.0)MN=1 !LENGTH IF(IPIG.LT.0.OR.DYY(NREL).LE.DAX)MN=-2 !ACCELERATION IF(IPIG.EQ.0.AND.MN.EQ.0)THEN !VELOCITY WRITE(6,905)NREL WRITE(0,*)'REDUCE NREL FOR FREE-FREE PI VELOCITY GAUGE' GO TO 999 C MN=-1 C DLL=MAX(QL(J),QL(K))*(QL(K)-QL(J))/2 C DO I=1,MAXRS C DPA(I)=(DPNL(I,K)*DLL/DX(I)+DP(I)*2)*DPNL(I,J) C ENDDO ELSE !LENGTH/ACCELERATION DO I=1,MAXRS DPA(I)=DPNL(I,K)*DPNL(I,J) ENDDO IF(BREL2)THEN DO I=1,MAXRS DPA(I)=DPA(I)+DQNL(I,K)*DQNL(I,J) ENDDO ENDIF IF(MN.EQ.-2.AND.BFOT)THEN DO I=1,MAXRS DPA(I)=-DPA(I)*DERV(I) ENDDO ELSE IF(MN.EQ.1.AND.ALAV*RCAV.NE.DZERO)THEN DO I=1,MAXRS DPA(I)=DPA(I)*(DONE- X ALAV*(DONE-EXP(-(DX(I)/RCAV)**3))/DX(I)**3) ENDDO ENDIF DO I=1,MAXRS DPA(I)=DPA(I)*DX(I)**MN ENDDO ENDIF ENDIF C CALL WEDDLE(DD0,DPA,DD,MNH,DHNS,MJH,MAXRS) C REM=DZERO IF(MN.EQ.0)GO TO 353 C C EVALUATE LONG-RANGE INTEGRAL C DTH=DX(MAXRS)-DX(MXRM) DD1=DPNL(MXRM,K) DD2=DPNL(MAXRS,K) DD3=DPNL(MXRM,J) DD4=DPNL(MAXRS,J) DX1=DX(MAXRS) TM=SCREEN(K) TN=SCREEN(J) DB=DTWO*DYY(NREL) DC=-QN(J) DC=DC-TN DS=DZA/DC DS=DS*DS DNORM=DS/(PIH*DC) DNORM=SQRT(DNORM) ML1=QL(K)/2 DS=ML1*(ML1+1) ML2=QL(J)/2 DC=ML2*(ML2+1) C CALL ASS2X(DX1,DTH,DX2,DD1,DD2,DD3,DD4,DB,DD0,DS,DC,DD0,DD0, X DD0,DD0,DZA,MN,REM2) C CALL ASSX(DX2,MN,TM,TN,DB,DD0,DZA,ML1,ML2,DS,DC,DD0,DD0,DD0, X DD0,REM) C REM=REM*DNORM REM=REM2+REM C IF(MN.EQ.-1)REM=REM*DLL IF(MN.EQ.-2)REM=-REM*DZA C 353 M8=NFOSS(K,J) DD=DD+REM DD=DD*OVL C IF(MN.EQ.1)DD=DD*DYY(NREL)**2 CWORSE IF(MN.EQ.1)DD=DD*(DYY(NREL)+DSHIFT(J))**2 IF(MN.EQ.-1)DD=DD*DYY(NREL)/2 C IF(M8.GT.0)THEN IF(IRLX.EQ.2)THEN DO I=1,MENG DFOSS(M8,I,2)=DFOSS(M8,I,2)*OVL ENDDO ENDIF DFOSS(M8,NREL,2)=DD ENDIF IF(M8.EQ.0)GO TO 828 C C LOOP OVER CONTINUUM ENERGIES C 340 DO I=1,MENG TM=DYY(I)+DSHIFT(J) XP=DZERO C C USE +1.1 TO EXTRAP HIGH E FROM NEAREST NEIGHEBOUR RATHER THAN INTERP. C IF(TM.LT.-D1PT1*DYY(I).OR..NOT.BLAG)THEN DAS=DFOSS(M8,I,2) GO TO 354 ENDIF IF(NAX.GT.MENG)THEN WRITE(6,*)' *** TOO FEW PI ENERGIES FOR FREE-FREE', X ' INTERPOLATION' WRITE(0,*)' *** TOO FEW PI ENERGIES FOR FREE-FREE', X ' INTERPOLATION' GO TO 999 ENDIF CNAX IF(BBC1)GO TO 341 C DO L=NAX,MENG IF(DYY(L).GE.TM)THEN LP=L GO TO 343 ENDIF ENDDO LP=MENG C C343 IF(BBC2)GO TO 344 343 NP2=LP+NPH-1 NP1=LP-NPH IF(NP1.LT.NAX)THEN NP1=NAX NP2=NP1+2*NPH-1 NP2=MIN(NP2,MENG) GO TO 341 ENDIF IF(NP2.GT.MENG)THEN NP1=NP1-NP2+MENG NP2=MENG NP1=MAX(NP1,NAX) ENDIF C C GO TO 341 C344 NP2=LP C NP1=LP-1 C DO 346 M=1,NLAG2 C IF(NP2.EQ.MENG)GO TO 347 C IF(NP1.LE.1)GO TO 348 C DD=DYY(NP2+1)-TM C DAS=TM-DYY(NP1-1) C IF(DD.LE.DAS)NP2=NP2+1 C IF(DD.GT.DAS)NP1=NP1-1 C346 CONTINUE C GO TO 341 C347 NP1=NP2-NLAG+1 C GO TO 341 C348 NP2=NLAG C NP1=1 C 341 DAS=DZERO DO L=NP1,NP2 DD=DONE DO M=NP1,NP2 IF(L.NE.M)THEN DD=DD*(TM-DYY(M)) DD=DD/(DYY(L)-DYY(M)) ENDIF ENDDO DDY(L)=DD ENDDO c if(tm.lt.dyy(nax))then !test forcing zero energy pi=0 c do l=np1,np2 c ddy(l)=ddy(l)*tm/dyy(l) c enddo c endif C IF(TM.LT.DYY(NAX))XP=D0PT35!BETTER CHOICE BY COMP WITH EXACT DO M=NP1,NP2 DAS=DAS+DDY(M)*DFOSS(M8,M,2)/DYY(M)**XP ENDDO C 354 DFOSS(M8,I,1)=DAS*TM**XP/TM**2 c CWORSEDFOSS(M8,I,1)=DAS/(TM+DSHIFT(J))**2 C ENDDO C C END LOOP OVER CONTINUUM ENERGIES C COLD IF(DYY(1).EQ.DZERO.AND.DSHIFT(J).LT.DYY(2).AND.BLAG) COLD XDFOSS(M8,1,1)=DFOSS(M8,2,1)*(DONE+DYY(2)/DSHIFT(J))**D1PT5 C COLD DDD=DFOSS(M8,NREL,2) COLD IF(MN.EQ.-2)DDD=DDD/(DYY(NREL)+DSHIFT(J))**2 COLD IF(MN.EQ.-1)DDD=DDD/(DYY(NREL)+DSHIFT(J)) DDD=DFOSS(M8,NREL,1) C DOSC(0,K,J)=DDD !NO E SHIFT ON THIS (LENGTH) ELEMENT DOSC(0,J,K)=DZERO DOSC(1,K,J)=DDD DOSC(1,J,K)=DZERO ACC(K,J)=DZERO C C 828 ENDDO ! *** END INNER ORBITAL LOOP C ENDDO ! *** END OUTER ORBITAL LOOP C C if(mxmm.gt.mxd09)then write(6,703)mxmm-2,mxmm 703 format(/'*** full retardation restricted to lambda=',i2,' set' x ,' (mxd09=)mxblm+2=',i2,' to get full expansion.') endif c IF(NC.GT.MXD33)THEN !BORN T=NC NU=NINT(SQRT(8*T+1)) NU=(NU-1)/2 WRITE(6,*)'**SR.RKINT DIMENSION ERROR: INCREASE MXGRB TO: ' X ,NU WRITE(0,*)'**SR.RKINT DIMENSION ERROR: INCREASE MXGRB' GO TO 999 ELSE MB3(0)=NC MB4(0)=N ENDIF C IF(BPRNT0)THEN WRITE(6,983)(QN(I),IHAR(I),I=1,NGROUP) DO I=1,NGROUP WRITE(6,982)QN(I),IHAR(I),(DOSC(0,I,J),J=1,NGROUP) ENDDO IF(.NOT.BFOTJ)THEN WRITE(6,984)PIG DO I=1,NGROUP DO J=1,I-1 M8=NFOSS(I,J) IF(M8.GT.0)THEN WRITE(6,700)M8,J,I,(DFOSS(M8,IC,1),IC=1,MENG) IF(QN(J).LT.0)WRITE(6,700)M8,J,I, X (DFOSS(M8,IC,2),IC=1,MENG) !/(DYY(IC)+DSHIFT(J))**2 ENDIF ENDDO ENDDO ENDIF ENDIF C 998 RETURN C 999 NF=-1 GO TO 998 C 699 FORMAT(2I5,I3,I4,I5,I4,I6,7F14.7,1X/(32X,7F14.7)) 700 FORMAT(I5,I8,I9,10X,7F14.7,1X/(32X,7F14.7)) 704 FORMAT(/' N(B) NC B(A, B, C, D, 2LBD) = BORN-INTEGRALS') 705 FORMAT('***STRONG WARNING: BORN MULTIPOLE EXPANSION MAY BE' X,' INCOMPLETE, SET KPOLE=',I3) 706 FORMAT(/I2,'-',I2,' BORN MOMENTUM TRANSFERS:',1X,10(I3,1PE9.2)/ X(31X,10(I3,E9.2))) 707 FORMAT(/31X,7(7X,I3,'-',I3)/(31X,7(7X,I3,'-',I3))) 905 FORMAT('***SR.RKINT: REDUCE NREL FOR FREE-FREE PI VEL GAUGE:',I4) 982 FORMAT(I4,I2,(2X,15F8.4)) 983 FORMAT(/ " DIPOLE LENGTH INTEGRALS (K=1, FOR /L-L'/=1) AND QUAD XRUPOLE (K=2) INTEGRALS ; ('N**' STANDS FOR: NL NO XT COMPUTED)"/8X,"ABOVE THE DIAGONAL ARE VELOCITY INTEGRALS "/3X,"N L",(2X,15(I3,I2,3X))) 984 FORMAT(/12X,'A',8X,'C',14X, X' PHOTO-IONIZATION (DIPOLE) INTEGRALS; GAUGE=',A3,' :') C END C C ******************* C SUBROUTINE RKX(DP1,DP2,DQ1,DQ2,JJ,DPA,DP,DX,DPOLA,REM,ovlp,SUM) C C----------------------------------------------------------------------- C C SR.RKX CALCULATES THE EIE SLATER INTEGRAL USING INPUT YK (DP), C INCLUDING ANY LONG-RANGE CONTRIBUTION. AND ANY EXHANGE OVERLAP. C C IT CALLS: C SR.WEDDLE C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C LOGICAL BREL,BJUMPR,BMVD,BREL2,BSTO C DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*) C common /com1/dpot(maxb1),tol,mend COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBFR/GR(MAXB1) COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C C----------------------------------------------------------------------- DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2 DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV)) C----------------------------------------------------------------------- C BREL2=IABS(IREL).EQ.2 IPOLF2=IPOLFN/10 MI=IABS(JJ)/2 C IF(BREL2)THEN IF(JJ.GT.0)THEN DO I=1,MAXRS GR(I)=DP1(I)*DP2(I)+DQ1(I)*DQ2(I) DPA(I)=GR(I)*(DP(I)+REM*DX(I)**MI) ENDDO ELSE DO I=1,MAXRS GR(I)=DP1(I)*DP2(I)+DQ1(I)*DQ2(I) DPA(I)=GR(I)*DP(I) ENDDO ENDIF ELSE IF(JJ.GT.0)THEN DO I=1,MAXRS GR(I)=DP1(I)*DP2(I) DPA(I)=GR(I)*(DP(I)+REM*DX(I)**MI) ENDDO ELSE DO I=1,MAXRS GR(I)=DP1(I)*DP2(I) DPA(I)=GR(I)*DP(I) ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,DPA,SUM,MNE,DHNS,MJH,MAXRS) c if(jj.eq.0)then if(ovlp.eq.dzero)then !direct ctest call weddle(dzero,gr,ovlp0,mne,dhns,mjh,maxrs) !e.g.rlx2 sum=sum+rem !*ovlp0 !subtract any divergent monopole elseif(mort.ne.-3)then !exchange call weddle(dzero,gr,ovlp0,mne,dhns,mjh,maxrs) do i=1,maxrs dpa(i)=gr(i)*dpot(i) enddo call weddle(dzero,dpa,rem0,mne,dhns,mjh,maxrs) rem0=-rem0/(dpot(maxrs)*dx(maxrs)) !a.u. per electron c write(6,*)ovlp*rem0,ovlp0*rem xovlp=ovlp*rem0+ovlp0*rem xovlp=xovlp/dtwo !average sum=sum+xovlp ovlp=ovlp*ovlp0 else ovlp=dzero endif endif C IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN !DIELECTRIC POLARIZATION IF(IPOLF2.EQ.1)THEN DO I=1,MAXRS DPA(I)=DPOL1(DX(I))*GR(I) ENDDO ELSEIF(IPOLF2.EQ.2)THEN DO I=1,MAXRS DPA(I)=DPOL2(DX(I))*GR(I) ENDDO ELSE STOP 'HERE BE MONSTERS' ENDIF CALL WEDDLE(DZERO,DPA,DPOLB,MNE,DHNS,MJH,MAXRS) c write(0,*)(qrl(i,l),i=1,5),db,alav*dpola*dpolb SUM=SUM-ALAV*DPOLA*DPOLB ENDIF C RETURN C END C C ******************* C SUBROUTINE ROMB(ID,CF,L,R1,I1,F1,R2,I2,F2,VM,V0,V1,M0,S1,S2,S3, X S4,S5,BINT,OINT,EB,EO,TOLR,TM2) C C----------------------------------------------------------------------- C C SR.ROMB IMPLEMENTS A SINGLE STEP OF ROMBERG'S RULE. C (A. BURGESS, DAMTP, CAMBRIDGE) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C LOGICAL CF C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (D1M7=1.0D-7) C DIMENSION BI(0:20),OI(0:20),F1(0:*),F2(0:*) DIMENSION S1(0:*),S2(0:*),S3(0:*),S4(0:*),S5(0:*) C X0=V0/(V0+VM) X1=V1/(V1+VM) X=X0 V=V0 K=0 C 1 CALL FILON(L,V,R1,I1,F1,FB1,FO1) IF(CF)THEN CALL FILON(L,V,R2,I2,F2,FB2,FO2) ELSE FB2=FB1 FO2=FO1 ENDIF T=V+VM T=T*T/VM T2=FB1*FB2*V IF(L.EQ.0)THEN T1=T2 T2=FO1*FO2*V ELSE IF(L.GT.1)THEN T1=FB1*FB2*V**(L+L-3) ELSEIF(V.GT.D1M7)THEN T1=(FB1*FB2-TM2*VM/(V+VM))/V ELSE T1=TM2/VM c stop'romb' ENDIF DO J=1,L T2=T2*V*V ENDDO ENDIF C S1(K)=V S2(K)=FB1 S3(K)=FB2 S4(K)=T1 S5(K)=T2 IF(K.EQ.0)THEN B0=T*T1 O0=T*T2 X=X1 V=V1 K=ID GO TO 1 ENDIF B0=(T*T1+B0)*DHALF O0=(T*T2+O0)*DHALF H=X1-X0 BI(0)=B0*H OI(0)=O0*H SB=DZERO SO=DZERO M=0 C 3 M=M+1 H=H*DHALF X=X0-H N=2**(M-1) DO I=1,N X=X+H+H V=VM*X/(1-X) T=V+VM T=T*T/VM CALL FILON(L,V,R1,I1,F1,FB1,FO1) IF(CF) THEN CALL FILON(L,V,R2,I2,F2,FB2,FO2) ELSE FB2=FB1 FO2=FO1 ENDIF T2=FB1*FB2*V IF(L.EQ.0)THEN T1=T2 T2=FO1*FO2*V ELSE IF(L.GT.1)THEN T1=FB1*FB2*V**(L+L-3) ELSEIF(V.GT.D1M7)THEN T1=(FB1*FB2-TM2*VM/(V+VM))/V ELSE T1=TM2/VM c stop'romb' ENDIF T2=FB1*FB2*V DO J=1,L T2=T2*V*V ENDDO ENDIF SB=T1*T+SB SO=T2*T+SO K=NINT(((X-X0)*ID)/(X1-X0)) S1(K)=V S2(K)=FB1 S3(K)=FB2 S4(K)=T1 S5(K)=T2 ENDDO C T0=BI(0) BI(0)=(B0+SB)*H U0=OI(0) OI(0)=(O0+SO)*H DO I=1,M T3=DONE/(2**(I+I)-1) T1=BI(I-1) U1=OI(I-1) T2=(T1-T0)*T3+T1 U2=(U1-U0)*T3+U1 T3=T0 T0=BI(I) BI(I)=T2 U3=U0 U0=OI(I) OI(I)=U2 ENDDO C EB=ABS((T2-T3)/T2) EO=ABS((U2-U3)/U2) C c write(77,*)m,t3,t2,eb IF (M.LT.M0.AND.EB.GT.TOLR) GO TO 3 c write(77,*)m,v0,v1 C BINT=T2 OINT=U2 C RETURN END C C ******************* C SUBROUTINE ROTSYM(N,NP,EIVEC,C,S,IP,IQ,A,V,MXMAT) C C----------------------------------------------------------------------- C C SR.ROTSYM EXECUTES A JACOBI ROTATION IN THE ROW IP AND THE COLUMN IQ C OF A AND V. C,S=COSINES,SINES OF THE ROTATION. THE RESULTS ARE AGAIN C IN A AND V. N,NP=ACTUAL DIMENSIONS OF A AND V,A(I,J),I=1,NP,J=1,N. C EIVEC SEE SR.JACORD. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C LOGICAL EIVEC C DIMENSION A(MXMAT,MXMAT),V(MXMAT,MXMAT) C C H=A(IP,IQ)*S/C A(IP,IP)=A(IP,IP)-H A(IQ,IQ)=A(IQ,IQ)+H C DO J=1,IP-1 H=C*A(J,IP)-S*A(J,IQ) A(J,IQ)=S*A(J,IP)+C*A(J,IQ) A(J,IP)=H ENDDO C DO J=IP+1,IQ-1 H=C*A(IP,J)-S*A(J,IQ) A(J,IQ)=S*A(IP,J)+C*A(J,IQ) A(IP,J)=H ENDDO C DO J=IQ+1,N H=C*A(IP,J)-S*A(IQ,J) A(IQ,J)=S*A(IP,J)+C*A(IQ,J) A(IP,J)=H ENDDO C IF(.NOT.EIVEC)RETURN C DO J=1,NP H=C*V(J,IP)-S*V(J,IQ) V(J,IQ)=S*V(J,IP)+C*V(J,IQ) V(J,IP)=H ENDDO C RETURN END C C ******************* C REAL*8 FUNCTION SJS(J1,J2,J3,L1,L2,L3,FCT,MFD) C C----------------------------------------------------------------------- C C FN.SJS EVALUATES THE WIGNER 6J-SYMBOL: C THE SIX QUANTUM NUMBER ARGUMENTS HAVE TWICE THEIR PHYSICAL VALUE; C FACTORIALS MUST BE SUPPLIED BY FCT(I)=(I/2-1)'/16**(I/2-1),I=4,M,2 C (FCT(2)=0'=1), AND PHASE FACTORS BY FCT(I)=MOD(I+1,4)-1,I=1,MFD,2. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C DIMENSION FCT(MFD) C OMEGA=DZERO C IF(J1+J2.LT.J3)GO TO 700 IF(J1+L2.LT.L3)GO TO 700 IF(J2+L3.LT.L1)GO TO 700 IF(J3+L1.LT.L2)GO TO 700 C IF(IABS(J1-J2).GT.J3)GO TO 700 IF(IABS(J1-L2).GT.L3)GO TO 700 IF(IABS(J2-L3).GT.L1)GO TO 700 IF(IABS(J3-L1).GT.L2)GO TO 700 C IJ0=J1+J2+J3+2 IJ1=J1+L2+L3+2 IJ2=L1+J2+L3+2 IJ3=L1+L2+J3+2 C IF(MOD(IJ0,2)+MOD(IJ1,2)+MOD(IJ2,2)+MOD(IJ3,2).NE.0)GO TO 700 IWMIN=MAX0(IJ0,IJ1,IJ2,IJ3)+2 C ID1=IJ0+IJ1-J1-J1+2 ID2=IJ0+IJ2-J2-J2+2 ID3=IJ0+IJ3-J3-J3+2 IWMAX=MIN0(ID1,ID2,ID3)-2 C IF(IWMAX.LT.IWMIN)GO TO 700 IF(IWMAX.GT.MFD)THEN !SHOULD NOT HAPPEN, CHECKED IN ALGEB0 WRITE(6,703)IWMAX WRITE(0,*)'FCT.SJS: FACTORIAL ARRAY TOO SHORT' GO TO 700 ENDIF C DO IW=IWMIN,IWMAX,2 OMEGA=-FCT(IW-1)*FCT(IW)/(FCT(ID1-IW)*FCT(ID2-IW)*FCT(ID3-IW)* X FCT(IW-IJ0)*FCT(IW-IJ1)*FCT(IW-IJ2)*FCT(IW-IJ3))+OMEGA ENDDO C IJ0=IJ0+2 IJ1=IJ1+2 IJ2=IJ2+2 IJ3=IJ3+2 OMEGA=OMEGA*SQRT( X (FCT(ID1-IJ0)*FCT(ID2-IJ0)*FCT(ID3-IJ0)/FCT(IJ0))* X (FCT(ID1-IJ1)*FCT(ID2-IJ1)*FCT(ID3-IJ1)/FCT(IJ1))* X (FCT(ID1-IJ2)*FCT(ID2-IJ2)*FCT(ID3-IJ2)/FCT(IJ2))* X (FCT(ID1-IJ3)*FCT(ID2-IJ3)*FCT(ID3-IJ3)/FCT(IJ3)))/16 C 700 SJS=OMEGA C RETURN C 703 FORMAT('FCT.SJS: FACTORIAL ARRAY TOO SHORT; INCREASE TO GREATER' X,' THAN',I5) C END C C ******************* C SUBROUTINE SLATRI(ICOUNT,N,KK,MAXPS,DORIG) C C----------------------------------------------------------------------- C C SR.SLATRI CALCULATES SLATER INTEGRALS INVOLVING CONTINUUM FUNCTIONS C (ORBITAL N) AT THE ICOUNT'TH INTERPOLATION ENERGY, INDEXED BY KK, C AND (IF BKUTOO) 2-BODY NON-FINE STRUCTURE INTEGRALS. C C----------------------------------------------------------------------- C USE COMMON_DXRL, ONLY: QRL,IRL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) c CF77 integer*8 nrk !F77 C LOGICAL BREL,BJUMPR,BMVD,BLAG,BBC2,BSTO,BORT,BREL2,BCALC,BKUTOO C DIMENSION DORIG(*) C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DL2(MAXB1),TOL,MDMM COMMON /COM3/DRY,DZ,TM COMMON /COM6/DA(MAXB1) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DAJOLD(MXVAR),DSIGMA(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,ORIG(MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBCOW/SCALER,ISCALR COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBFR/GR(MAXB1) COMMON /NRBHAM/POTHAM(MAXB1),MPSEUD COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBNFI/DZLI(MXENG,MXFOO),DXTWOI(MXENG,MXFOO) X ,DETAI(MXENG,MXFOO),FRI(MAXB1),GRI(MAXB1) COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/FR(MAXB1),DERV1(MAXB1),DERV2(MAXB1),BP(MAXB1) C SAVE DEHLD C C----------------------------------------------------------------------- DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2 DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV)) C----------------------------------------------------------------------- C C BREL2=IABS(IREL).EQ.2 BORT=MORT.LT.0 BKUTOO=KUTOO.NE.0 IPOLF2=IPOLFN/10 DM=DZERO DD=DZERO PI=ACOS(-DONE) PIH=PI/DTWO MXRM=MAXPS-1 DZA=MION-NZION-1 C IF(BKUTOO)THEN !SWAP CONTINUUM FR->DPNL IF(ICOUNT.EQ.1.OR.NREL.EQ.1.AND.ICOUNT.EQ.2)THEN!BACK-UP NREL'TH DEHLD=DEY(N) DEY(N)=DRY/DTWO DO I=1,MAXPS FRI(I)=DPNL(I,N) DPNL(I,N)=FR(I) GRI(I)=DQNL(I,N) DQNL(I,N)=GR(I) ENDDO ELSE !JUST LOAD NEW CONTINUUM DEY(N)=DRY/DTWO DO I=1,MAXPS DPNL(I,N)=FR(I) DQNL(I,N)=GR(I) ENDDO ENDIF ENDIF C DO 102 J=1,IRL C KP=NRLI(J) C ****TEST 108 IF(KP.GT.0)then !.AND. for stupid compilers if(DRLI(ICOUNT,KP).NE.DZERO)GO TO 102 endif IF(QRL(5,J).GT.2*MAXLAM)GO TO 102 N1=QRL(1,J) C C FALLING ORDER MEANS THAT IF 'A' IS NOT *THE* CONTINUUM ORBITAL N C THEN NEITHER IS 'B,C OR D'. SLATER INTEGRAL (A,B,C,D) C IF(N1.NE.N)GO TO 102 N2=QRL(3,J) IF(DORIG(N2).EQ.DZERO)GO TO 102 IF(IYY(N2).GT.0.AND.MODE.LE.2)GO TO 102 C IF(QN(N2).LT.0)GO TO 102 C IF(QRL(5,J).GE.0)GO TO 103 C IF(.NOT.BLAG)GO TO 325 IF(.NOT.BORT)GO TO 83 IF(BREL2)GO TO 83 C DO I=1,MAXPS BP(I)=DQNL(I,N2)*FR(I) ENDDO IF(MPSEUD.NE.0)THEN DO I=1,MAXPS BP(I)=BP(I)+DTWO*DPNL(I,N2)*FR(I)*(DZ/DX(I)-POTHAM(I)) ENDDO ENDIF GO TO 57 C 83 IF(BREL2)THEN DO I=1,MAXPS BP(I)=(DPNL(I,N2)*FR(I)+DQNL(I,N2)*GR(I))*DL2(I) ENDDO ELSE DO I=1,MAXPS BP(I)=DPNL(I,N2)*FR(I)*DL2(I) ENDDO ENDIF IF(MPSEUD.NE.0)THEN DO I=1,MAXPS BP(I)=BP(I)+DTWO*BP(I)*(DZ/DX(I)-POTHAM(I))/DL2(I) ENDDO ENDIF C C ONE-BODY INTEGRALS C 57 CALL WEDDLE(DM,BP,DD,MNE,DHNS,MJH,MAXPS) C 325 IF(KP.LE.0)THEN KK=KK+1 IF(KK.GT.MXFSL)GO TO 102 KP=KK NRLI(J)=KK ENDIF C DRLI(ICOUNT,KP)=DD/DTWO C GO TO 102 ! **** TEST 108 C C TWO-BODY INTEGRALS C 103 BCALC=.FALSE. MJ=(QL(N1)+QL(N2))/2+2 JJ=QRL(5,J) MI=JJ/2 C DO L=J,IRL !START YLAMK LOOP C IF(QRL(1,L).NE.N1)GO TO 104 IF(QRL(3,L).NE.N2)GO TO 104 IF(QRL(5,L).NE.JJ)GO TO 104 M1=QRL(2,L) IF(DORIG(M1).EQ.DZERO)GO TO 104 IF(IYY(M1).GT.0.AND.MODE.LE.2)GO TO 104 IF(.NOT.BLAG)GO TO 326 M2=QRL(4,L) IF(DORIG(M2).EQ.DZERO)GO TO 104 C IF(BCALC)GO TO 105 BCALC=.TRUE. C C CALCULATE YLAMDA C IF(BREL2)THEN DO I=1,MAXPS BP(I)=FR(I)*DPNL(I,N2)+GR(I)*DQNL(I,N2) ENDDO ELSE DO I=1,MAXPS BP(I)=FR(I)*DPNL(I,N2) ENDDO ENDIF C IF(BREL)THEN DEL=DEY(N2)-DUY(N2,N2)-DRY/DTWO ! A.U. CALL YLAMKR(MI,MJ,DEL,BP,DA,DD1,DD2,MNE,DHNS,MJH,0) ELSE CALL YLAMK(MI,MJ,BP,DA,DD1,DD2,MNE,DHNS,MJH,0) ENDIF C IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN !DIELECTRIC POLARIZATION IF(IPOLF2.EQ.1)THEN DO I=1,MAXPS BP(I)=DPOL1(DX(I))*BP(I) !DPNL(I,N1)*DPNL(I,N2) ENDDO ELSEIF(IPOLF2.EQ.2)THEN DO I=1,MAXPS BP(I)=DPOL2(DX(I))*BP(I) !DPNL(I,N1)*DPNL(I,N2) ENDDO ELSE STOP 'HERE BE MONSTERS' ENDIF CALL WEDDLE(DM,BP,DPOLA,MNE,DHNS,MJH,MAXPS) ENDIF C REM=DZERO IF(MI.EQ.0.OR.QN(N2).GT.0)GO TO 105 C C LONG-RANGE INTEGRAL LAMBDA .GT. 0 C DX1=DX(MAXPS) DT=DX(MAXPS)-DX(MXRM) DD=FR(MXRM) TN=FR(MAXPS) DD1=DPNL(MXRM,N2) DD2=DPNL(MAXPS,N2) DE=DRY ML1=QL(N1)/2 DS=ML1*(ML1+1) ML2=QL(N2)/2 DC=ML2*(ML2+1) MN=-MI-1 C CALL ASS2X(DX1,DT,DX2,DD,TN,DD1,DD2,DE,DM,DS,DC,DM,DM,DM,DM X ,DZA,MN,REM2) C TN=DSIGMA(N2) C CALL ASSX(DX2,MN,TM,TN,DE,DM,DZA,ML1,ML2,DS,DC,DM,DM,DM,DM X ,REM) C DNORM=-QN(N2) DNORM=DNORM-TN DNORM=DZA*DZA/(PIH*DNORM**3) DNORM=SQRT(DNORM) c dnorm=1 !<<<<<<<<<<<<<<<<<<<<<<<<<<<)') 302 FORMAT(//' I(R) R( A, B, C, D, 2LBD ) = SLATER-INTEGRALS' X,': BELOW IS 0.5*TWO-BODY NON-FINE-STRUCTURE INTEGRALS (2LBD+1)*X2 X, ZLBD, ETALBD.') 555 FORMAT(//' *** COWAN SLATER INTEGRAL SCALE FACTOR: ',F7.4) 700 FORMAT(I5,3X,2(I5,I4),I6,7F14.7,1X/(32X,7F14.7)) 703 FORMAT(32X,7F14.7,1X/(32X,7F14.7)) c END C C ******************* C SUBROUTINE SLATRX(FRX,PSHFTX,MDIM1,MDIM2,MDIM3 X ,DRL,DZL,DXTWO,DETA X ,M1,M2,LNEW,MAXLX,MPOSC) C C----------------------------------------------------------------------- C C SR.SLATRX CALCULATES/UPDATES THE DEIE SLATER INTEGRALS (INCLUDING THE C EXCHANGE OVERLAP) AND (IF BKUTOO) 2-BODY NON-FINE STRUCTURE INTEGRALS C C IT CALLS: C SR.YLAMKX C SR.RKX C SR.LDFGX C FN.ETA C FN.XTWO C FN.ZLAM C C----------------------------------------------------------------------- C USE COMMON_DXRL, ONLY: QRL,IRL !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C c PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) c PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C PARAMETER (DZERO=0.0D0) c PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) c CF77 integer*8 nrk !F77 C LOGICAL BPRNT0,BREL,BJUMPR,BMVD,BREL2,BKUTOO,BDIR C !,BPRINT,BSTO,BEX C DIMENSION FRX(MDIM1,MDIM2,MDIM3),PSHFTX(MDIM2,MDIM3) X ,DRL(*),DZL(*),DXTWO(*),DETA(*) C c COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) c COMMON /COM1/DPOT(MAXB1),TOL,MEND COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) CF77 COMMON /DXRL/DRK(MAXRK),QRL(5,MAXRL),NRK(MAXRK),IRL !F77 CF77 X ,NAD(0:MAXAD) !F77 COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT c COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) c COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBDW6/QPOS(MAXGR),QPOS0(MAXGR) c COMMON /NRBFR/GR(MAXB1) COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO c COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) c COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSPL/FR(MAXB1),DERV1(MAXB1),DERV2(MAXB1),BP(MAXB1) C BPRNT0=JPRINT.GE.4 !FOR DETAILED PRINTOUT c BPRNT0=JPRINT.NE.-3 BKUTOO=KUTOOX.NE.0 BREL2=IABS(IREL).EQ.2 C MAXRS1=MAXRS IF(BREL2)MAXRS1=MAXRS1+1 C IF(BPRNT0)THEN WRITE(6,300)M1,DYY(M1),M2,DYY(M2) IF(BKUTOO)WRITE(6,302) ENDIF C C INITIALIZE C IF(BKUTOO)THEN DO L=1,IRL DRL(L)=DZERO DXTWO(L)=DZERO DZL(L)=DZERO DETA(L)=DZERO ENDDO ELSE DO L=1,IRL DRL(L)=DZERO ENDDO ENDIF C MLAMX2=MXLAMX*2 C C OUTER LOOP TO DETERMINE SLATER INETGRALS C cc write(63,*)'L=',lnew c icountt=0 C DO J=1,IRL C IF(DRL(J).NE.DZERO)GO TO 814 JJ=QRL(5,J) IF(JJ.LT.0)GO TO 814 !NOT NEEDED FOR THIS LTOT C N1=QRL(1,J) N2=QRL(3,J) IF(QL(N1).LT.0)GO TO 814 IF(QL(N2).LT.0)GO TO 814 n3=n2 C BDIR=QN(N2).LT.0 !DIRECT c BEX=.NOT.BDIR !EXCHANGE C C DETERMINE YLAMK C Q1=QPOS(N1-MPOSC) q1=iabs(q1) IF(BDIR)THEN C Q2=QPOS(N2-MPOSC) q2=iabs(q2) T1=PSHFTX(M1,Q1) T2=PSHFTX(M2,Q2) DEL=DYY(M1)-DYY(M2) !BREL ONLY C CALL YLAMKX(FRX(1,M1,Q1),FRX(1,M2,Q2),FRX(MAXRS1,M1,Q1) X ,FRX(MAXRS1,M2,Q2),N1,N2,JJ,M1,M2,T1,T2,DEL,FR,BP X ,DX,DPOLA,REM,ovlp) C IF(BKUTOO)THEN if(n1.eq.n2)then !same orb. (l) but diff. e n2=n1+1-2*((n1-mposc)/lcondwj) lhold=ql(n2) ql(n2)=ql(n1) else lhold=ql(n2) endif CALL LDFGX(M1,N1,FRX(1,M1,Q1),FRX(MAXRS1,M1,Q1) X ,MAXRS,BREL,BREL2) CALL LDFGX(M2,N2,FRX(1,M2,Q2),FRX(MAXRS1,M2,Q2) X ,MAXRS,BREL,BREL2) ENDIF C ELSE C IF(LNEW.GT.MAXLX.OR.JJ.GT.MLAMX2)GO TO 814 DEL=DYY(M1)-(DEY(N2)-DUY(N2,N2))*DTWO !RYD C CALL YLAMKX(FRX(1,M1,Q1),DPNL(1,N2),FRX(MAXRS1,M1,Q1) X ,DQNL(1,N2),N1,N2,-JJ,M1,M2,T1,T2,DEL,FR,BP X ,DX,DPOLA,REM,ovlp) C IF(BKUTOO)THEN CALL LDFGX(M1,N1,FRX(1,M1,Q1),FRX(MAXRS1,M1,Q1) X ,MAXRS,BREL,BREL2) ENDIF C ENDIF C C INNER LOOP OVER ALL INTGERALS UTILIZING THIS YLAMK C c icount=0 DO L=J,IRL C IF(QRL(1,L).NE.N1)GO TO 815 IF(QRL(3,L).NE.n3)GO TO 815 IF(QRL(5,L).NE.JJ)GO TO 815 K1=QRL(2,L) K2=QRL(4,L) IF(QL(K1).LT.0)GO TO 815 IF(QL(K2).LT.0)GO TO 815 C C DETERMINE SLATER RK (A.U.) C IF(BDIR)THEN rem0=rem if(jj.eq.0.and.k1.ne.k2)rem0=dzero !could test rlx2 CALL RKX(DPNL(1,K1),DPNL(1,K2),DQNL(1,K1) X ,DQNL(1,K2),JJ,FR,BP,DX,DPOLA,REM0,ovlp,SUM) ELSE Q2=QPOS(K1-MPOSC) q2=iabs(q2) ovlp0=ovlp CALL RKX(FRX(1,M2,Q2),DPNL(1,K2),FRX(MAXRS1,M2,Q2) X ,DQNL(1,K2),-JJ,FR,BP,DX,DPOLA,REM,ovlp0,SUM) c sum0=sum c add-in energy factor if(jj.eq.0)then dex=-dyy(m1)/dtwo+dey(k2)-duy(k2,k2) !a.u. x -dyy(m2)/dtwo+dey(n2)-duy(n2,n2) dex=dex/dtwo !average sum=sum+ovlp0*dex endif c write(6,*)sum0,ovlp0,sum c sum=sum0 !test drop overlap c sum=0. !test nx ENDIF C DRL(L)=SUM C C EVALUATE TWO-BODY NON-FINE-STRUCTURE INTEGRALS, CONVERT ZL,X2 TO A.U. C IF(BKUTOO)THEN IF(.NOT.BDIR)THEN if(n1.eq.k1)then !same orb. (l) but diff. e k1=n1+1-2*((n1-mposc)/lcondwj) lhold=ql(k1) ql(k1)=ql(n1) else lhold=ql(k1) endif CALL LDFGX(M2,K1,FRX(1,M2,Q2),FRX(MAXRS1,M2,Q2) X ,MAXRS,BREL,BREL2) ENDIF MI=JJ/2 DXTWO(L)=XTWO(MI,N1,K1,N2,K2)/DTWO DZL(L)=ZLAM(MI,N1,K1,N2,K2)/DTWO DETA(L)=ELAM(MI,N1,K1,N2,K2) if(.not.bdir)ql(k1)=lhold ENDIF c c icount=icount+1 C 815 ENDDO ! *** END INNER SLATER LOOP c if(bkutoo.and.bdir)ql(n2)=lhold c c write(63,*)j,icount,bdir c call flush(63) c icountt=icountt+icount C 814 IF(BPRNT0)THEN TEST=DRL(J) IF(BKUTOO)TEST=TEST+DXTWO(J)+DZL(J)+DETA(J) IF(TEST.NE.DZERO)WRITE(6,700)J,(QRL(I,J),I=1,5),DRL(J) IF(BKUTOO)WRITE(6,703)DXTWO(J),DZL(J),DETA(J) ENDIF C ENDDO ! *** END OUTER SLATER LOOP c c write(63,*)'icountt=',icountt C RETURN C 300 FORMAT(/ ' I(R) R( A, B, C, D, 2LBD ) = SLATER-INTEGRALS' X,3X,'FOR E(',I2,')=',F10.3,5X,'E(',I2,')=',F10.3,' RYD') 302 FORMAT( X ': BELOW IS 0.5*TWO-BODY NON-FINE-STRUCTURE INTEGRALS (2LBD+1)*X2 X, ZLBD, ETALBD.') 700 FORMAT(I5,3X,2(I5,I4),I6,7F14.7,1X/(32X,7F14.7)) 703 FORMAT(32X,7F14.7,1X/(32X,7F14.7)) C END C C ******************* C SUBROUTINE SOCC C C----------------------------------------------------------------------- C C SR.SOCC CALCULATES THE BLUME AND WATSON CONTRIBUTIONS TO THE C SPIN-ORBIT PARAMETERS. C C----------------------------------------------------------------------- C USE COMMON_COEFF, ONLY: QRLP,IRLP !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD25=(MAXGR*(MAXGR-1))/2) PARAMETER (MXD26=(MAXCF*(MAXCF-1))/2) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DSIX=6.0D0) PARAMETER (DKCM=109737.31D0) C CF77 INTEGER*8 NRKP !F77 C LOGICAL BJUMP,BPRNT0,BREL,BJUMPR,BJUMP2,BRAD,BSTO,BMVD,BLAG,BBC2 X ,BPRINT,HFF C DIMENSION DFS(MXDFS),TNINT(3,2) C COMMON /BASIC/NF,KVAR,HFF,MGAP(9) COMMON /CCLSH/NW,NNL(MAXCL,3) CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /EX/DRLP1(MXSOI),DNL(MAXMI) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /REL/DMASS(MAXGR,MAXGR),DCD(MAXGR,MAXGR),D2LL(MAXGR,MAXGR) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBINT/DRLI(MXENG,MXFSL),DYY(MXENG),IYY(MAXGR) X ,NRLI(MAXRL),MENG,NREL,BLAG,BBC2,NLAG COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO COMMON /NRBOLP/OVLPGR(MXD25),OVLPCF(MXD26),IPAIR(MXD26) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD COMMON /NRBZSP/ZESP(MAXLL),IZESP,NWRM C DATA MT/MXDFS/ C IF(IRLP.LE.0) GO TO 500 C BPRNT0=BPRINT IF(BPRINT)BPRNT0=JPRINT.NE.-3 IF(BPRNT0)THEN IF(IZESP.NE.0)WRITE(6,189)IZESP,(I,ZESP(I),I=1,IABS(IZESP)) IF(KUTOO.NE.98)WRITE(6,180) IF(KUTOO.EQ.98)WRITE(6,187) ENDIF C DFS(1)=1 DFS(2)=1 DO K=3,MT,2 DFS(K)=-DFS(K-2) DFS(K+1)=(K-1)*DFS(K-1)/32 ENDDO C C RUN THROUGH ALL PAIRS OF VALENCE ELECTRON QUANTUM NUMBERS C IF(KUTOO.EQ.98)THEN C DXSI ONLY USED FOR TEST PURPOSES DO I=1,MAXGR DO J=I,MAXGR M=IVAL(I)+IVAL(J) IF(BJUMP.AND.M.EQ.0)GO TO 85 DXSI(I,J)=DZERO DXSI(J,I)=DZERO 85 ENDDO ENDDO ENDIF C K0=0 C C START LOOP OVER ALL COEFFICIENTS C DO 510 LP=1,IRLP C K1=QRLP(1,LP) K3=QRLP(2,LP) K=QRLP(4,LP) c K=(K3-1)/MAXGR C DC1=DZERO IF(K.NE.0)GO TO 30 !RADIATIVE INTEGRALS C M=IVAL(K1)+IVAL(K3) IF(BJUMP.AND.M.EQ.0)THEN DC1=DRLP1(LP) GO TO 16 ENDIF C DI=DZERO !DIRECT W1=DZERO !EXCHANGE C IMT=0 C IF(QN(K1).LT.0)IMT=IMT+1 C IF(QN(K3).LT.0)IMT=IMT+1 IF(IYY(K1).GT.0)IMT=IMT+1 IF(IYY(K3).GT.0)IMT=IMT+1 IF(MODE.LE.2.AND.IMT.Ge.1)GO TO 16 c IF(BREL.AND.K1.NE.K3)GO TO 16 C N1=IABS(QN(K1)) N3=IABS(QN(K3)) C MQLA=QL(K1) QLA=MQLA/2 MQLB=0 C V1=DZERO V2=DZERO V3=DZERO C OVL=DONE IF(IRLX.EQ.2)THEN !DETERMINE OVERLAP KF=IGRCF(K1) KG=IGRCF(K3) IF(KF.NE.KG.AND.KF*KG.GT.0)THEN KK1=MIN(KF,KG) KK2=MAX(KF,KG) KK=((KK2-1)*(KK2-2))/2+KK1 IF(IPAIR(KK).EQ.1)OVL=OVLPCF(KK) ENDIF ENDIF C J2=-1 K2=0 GO TO 12 C C J2 NUMBERS THE ELECTRONS IN THE CORE C0, J2=1,2,.....NW AND C SO CANNOT BE A CONTINUUM ELECTRON OR A DR VALENCE ELECTRON. C 11 K2=NNL(J2,1) 13 K4=K2 MQLB=QL(K2) QLB=MQLB/2 IF(BREL)DCD(K2,K2)=DZERO C C CALCULATE THE DIRECT INTEGRAL, N(ABAB,LBD=0). C M0=3 C CALL NLAM(M0,K1,K2,K3,K4,0,DM) !CALL RAD(K1,K2,K3,K4,0,DM,M0) C DM=DM*OVL C DI=DI-((MQLB+1)*4)*DM !DIRECT B&W C CPRNT WRITE(6,182) J2, K1,K2,K3,K4, DM C TNINT(2,1)=DZERO TNINT(3,1)=DZERO TNINT(2,2)=DZERO TNINT(3,2)=DZERO QX=QLA+QLB L=IABS(MQLB-MQLA)/2 K=L-3 IF(L.EQ.0)THEN DC1=DONE L=1 K=-1 ENDIF C 165 K=K+1 TNINT(1,1)=TNINT(2,1) TNINT(2,1)=TNINT(3,1) TNINT(1,2)=TNINT(2,2) TNINT(2,2)=TNINT(3,2) C C COMPUTE N-INTEGRALS (IF M0=+3) AND V-INTEGRALS (M0=-3) C DM=DZERO DK=DZERO IF(K.GT.MAXLAM)GO TO 45 C C CALL RAD(K1,K2,K4,K3,K,DK,M0) C IF(M0.GT.0)THEN CALL NLAM(M0,K1,K2,K4,K3,K,DK) ELSEif(m0.lt.0)then CALL VLAM0(M0,K1,K2,K4,K3,K,DK) else write(6,*) 'socc: m0=0 ??' write(0,*) 'socc: m0=0 ??' nf=-1 go to 500 ENDIF C DK=DK*OVL C DM=DK IF(M0*K1.EQ.3*K3)GO TO 45 C C USE THE RELATION N(AB,BA,K)=N(BA,AB,K) IN CASE A=C. C C CALL RAD(K2,K1,K3,K4,K,DM,M0) C IF(M0.GT.0)THEN CALL NLAM(M0,K2,K1,K3,K4,K,DM) ELSEif(m0.lt.0)then CALL VLAM0(M0,K2,K1,K3,K4,K,DM) else write(6,*) 'socc: m0=0 ??' write(0,*) 'socc: m0=0 ??' nf=-1 go to 500 ENDIF C DM=DM*OVL C 45 TNINT(3,2)=DM TNINT(3,1)=DK C C TNINT(J1,1) CONTAINS INTEGRALS OF THE TYPE N(AB,BC) AND TNINT(J1,2) C CONTAINS INTEGRALS N(BA,CB). THE INDEX J1 GIVES THE ORDER OF THE C INTEGRAL, THUS J1=I CORRESPONDS TO ORDER K+I-3. C CPRNT WRITE(6,183) K,M0, DK, DM M0=-M0 IF(K.LT.L)GO TO 165 C MK=2*K DK=K DKU=K+1 IF(M0.LE.0)THEN C C IF QLA+QLB+K IS AN ODD INTEGER THEN THE CONTRIBUTIONS FROM V1 C AND V3 ARE ZERO. C DC1=VCC(MQLA,MK,MQLB,0,0,0,DFS,MT) DM=QLA*(QLA+1)+K*(K+1)-QLB*(QLB+1) W1=-DM/(MQLA*(QLA+1)) V1=V1-6*DC1*DC1*W1*(TNINT(2,1)-TNINT(2,2)) C =V1-6*DC1*DC1*W1*(V(K1,K2,K4,K3,K-1)-V(K2,K1,K3,K4,K-1)) V3=V3-3*DC1*DC1*W1*((DM-MK*DKU)*(DK*TNINT(3,1)-DKU*TNINT(1,2)) X +DM*(DK*TNINT(3,2)-DKU*TNINT(1,1)))/(DK*DKU) ELSE C MS=QX+K IWT=(MS+1)*(MS-MQLB)*(MS-MQLA)*(MS-MK+1) W1=DSIX*IWT/(MQLA*(MQLA+2)) C DC1=VCC(MQLA,MK-2,MQLB,0,0,0,DFS,MT) DM=DC1*DC1*(TNINT(2,1)+TNINT(2,2))/(DK*DKU) V2=V2+W1*DM IF(KUTOO.NE.98)GO TO 101 C C TEST TWO-BODY NON-FINE-STRUCTURE VALENCE-CLOSED SHELL CONTRIB. C IF(KUTOO*QLA*QLB.NE.0)THEN WO1=IWT C C JONES (A.U.) WO1=IWT/(2*(MQLB+1)) C DXSI(K1,K3)=DXSI(K1,K3)+WO1*DM C C T=(MK+1)*(MK-1)*DC1*DC1 C WRITE(6,*)K,T,DC1 C ENDIF C ENDIF C CP101 WRITE(6,184) DC1,W1, V1,V2,V3 C 101 IF(K.LT.QX) GO TO 165 C C BLUME AND WATSON CLOSED-SHELL: C ONLY NEED TO CONSIDER EACH CLOSED SHELL ONCE, C SO INCREASE J2 BY THE NUMBER OF ELECTRONS IN THE CLOSED SHELL C (IREL .LT. 0 USES POTENTIAL DERIVATIVE - SO SKIP) C (IZESP.GT. 0 USES PURE NUCLEAR SCREENING BY ZESP - SO SKIP) C 12 IF(IREL.GE.0.AND.IZESP.LE.0)THEN J2=J2+2*(MQLB+1) IF(J2.LT.NW)GO TO 11 C C OPTIONALLY FORCE R-MATRIX BLUME & WATSON "CLOSED-SHELL" CONTRIBUTION C (ADJUST TESTS ON N2,N1,N3 TO REPRODUCE DESIRED R-MATRIX RESULT.) C IF(J2.LT.NWRM)THEN K2=K2+1 N2=IABS(QN(K2)) IF(N2.LT.N1.AND.N2.LT.N3) X GO TO 13 ENDIF ENDIF C C IF ALL THE CORE ELECTRONS HAVE BEEN CONSIDERED, THE NEXT SET OF C EQUIVALENT ELECTRONS IN THE VALENCE SHELLS MAY BE CONSIDERED C C SUM OF B&W EXCHANGE CONTRIBUTIONS C W1=V1+V2+V3 C C *** NUCLEAR SPIN-ORBIT C IF(BREL)THEN C UNCOMMENT IF REL ORB S-O INTEGRAL COMPUTED IN RADIAL/RADCON. c DK=DCD(K1,K3) c write(0,*)k1,k3 c write(0,*)dk DCD(K1,K3)=DZERO DCD(K3,K1)=DZERO c GO TO 26 ENDIF C CALL ZETA(K1,K3,DK) ! CALL RAD(K1,K2,K3,K4,0,DK,0) c c write(0,*)dk C c 26 CONTINUE C C COMBINE NUCLEAR WITH ANY DIRECT AND EXCHANGE BLUME & WATSON C DC1=2*NZION*DK+DI+W1 C C MULTIPY BY ANY SCREENING FACTOR C (IZESP.GT.0 HAS ALREADY SWITCHED-OFF ANY B&W, OR POTENTIAL DERVATIVE) C IF(IZESP.NE.0)THEN IZ=IABS(IZESP) IZ=MIN(IZ,QLA) DC1=DC1*ZESP(QLA) ENDIF C 16 DM=DTWO*DKCM*DC1 DKU=DM/NZION**4 DRLP1(LP)=DC1 C IF(KUTOO.NE.98)THEN IF(.NOT.BJUMP.AND.BPRNT0)WRITE(6,181)LP,K1,K3,DC1,DM,DKU,DI,W1 IF(BJUMP.AND.BPRNT0)WRITE(6,181)LP,K1,K3,DC1,DM,DKU ELSE DXSI(K3,K1)=DXSI(K1,K3) IF(.NOT.BJUMP.AND.BPRNT0)WRITE(6,186)LP,K1,K3,DC1,DM,DKU,DI,W1 X ,DXSI(K1,K3) IF(BJUMP.AND.BPRNT0)WRITE(6,186)LP,K1,K3,DC1,DM,DKU,DZERO X ,DZERO,DXSI(K1,K3) ENDIF C GO TO 510 !EXIT LOOP C C--------------------------------------------------------------------- C C THE FOLLOWING SECTION PROVIDES FOR RELATIVISTIC RADIATIVE INTEGRALS C C--------------------------------------------------------------------- C 30 K2=K1 !-K*MAXGR K4=K3 !-K*MAXGR IF(K0.EQ.0)THEN K0=K C TMP K=-K0 IF(BPRNT0)WRITE(6,185) ENDIF C M=IVAL(K2)+IVAL(K4) IF(BJUMP.AND.M.EQ.0)THEN DC1=DRLP1(LP) GO TO 17 ENDIF C IMT=0 C IF(QN(K2).LT.0)IMT=IMT+1 C IF(QN(K4).LT.0)IMT=IMT+1 IF(IYY(K2).GT.0)IMT=IMT+1 IF(IYY(K4).GT.0)IMT=IMT+1 C IF(MODE.GT.2.OR.IMT.LE.1)THEN C M0=0 IF(K.GT.8)M0=1000*QRLP(3,LP) C CALL RADBP1(K2,K4,K,DC1,M0) C if(m0.lt.0)then !should not occur (now) nf=-1 go to 500 endif C OVL=DONE IF(IRLX.EQ.2.AND.K.LT.9)THEN !DETERMINE OVERLAP KF=IGRCF(K2) KG=IGRCF(K4) IF(KF.NE.KG.AND.KF*KG.GT.0)THEN KK1=MIN(KF,KG) KK2=MAX(KF,KG) KK=((KK2-1)*(KK2-2))/2+KK1 IF(IPAIR(KK).EQ.1)OVL=OVLPCF(KK) ENDIF ENDIF DC1=DC1*OVL ENDIF C 17 IF(BPRNT0)WRITE(6,188)LP,K1,K3,DC1,K C DRLP1(LP)=DC1 C C END M1+BP RADIATIVE C 510 CONTINUE C C END LOOP OVER ALL COEFFICIENTS C 500 RETURN C 180 FORMAT(//5X,'ZETA( A B ) = SPIN-ORBIT PARAMETERS',37X, X 'BLUME AND WATSON CLOSED SHELL CONTRIBUTION, IN 2RY'/33X,'2*RY', X 17X,'1/CM',13X,'Z**4/CM',14X,'DIRECT CONTRIBUTION',4X, X 'EXCHANGE CONTRIB.') 181 FORMAT(I5,4X,2I5,8X,E14.7,2(5X,1PE14.7),11X,2(7X,0PE14.6)) CP182 FORMAT(/21X,'. DM',6X,,I4,8X,4I4,E18.5) CP183 FORMAT(20X,'..N1- OR V1-2',4X ,2I4,16X,2E18.5) 184FOR./77X,3E18.5 CP184 FORMAT (19X,'...DC1,W1,V1-3',28X,2E18.5/77X,3E18.5) 185 FORMAT(47X,'NOW FOLLOWING ARE RADIATIVE INTEGRALS') 186 FORMAT(I5,2X,2I5,5X,1PE14.7,2(3X,E14.7),1X,2(7X,E14.6) X,5X,E14.7) 187 FORMAT(//5X,'ZETA( A B ) = SPIN-ORBIT PARAMETERS',19X,'BLUME' X,' AND WATSON CLOSED SHELL CONTRIBUTION, IN 2RY.',5X X,'| ORBIT-ORBIT' X/27X,'*2RY',14X,'1/CM',11X,'Z**4/CM',10X,'DIRECT CONTRIB.' X,4X,'EXCHANGE CONTRIB.',5X,'| XI PARAMETER') 188 FORMAT(I5,4X,2I5,8X,E14.7,I7) 189 FORMAT(//5X,'EFFECTIVE SPIN-ORBIT SCREENING PARAMETERS FOR IZESP=' X,I3//5X,'L=',10(I7,F10.4)) C END C C ******************* C SUBROUTINE SPOR0(KK,QLMC,MAXEL) C C----------------------------------------------------------------------- C C SR.SPOR0 CHECKS WHICH SLATER-STATES OF TWO CFS DIFFER BY ZERO OR ONE C PAIR AND SETS POINTERS TO THEM FOR LATER USE BY SPOR1 IF THEY SATISFY C THE SPIN-ORBIT SELECTION RULES. IT CLOSELY RESEMBLES SR.FLGLX0 - NRB. C C----------------------------------------------------------------------- C USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2,KPTCFM,KINT,MPOINT !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C LOGICAL EQCFS,BTEMP(MXEL0,MXEL0) C DIMENSION QLMC(MAXEL,*) X,JTEMP(MAXGR),KTEMP(MXEL0*MXEL0+1),LTEMP(MXEL0*MXEL0) X,MTEMP(MXEL0),NTEMP(MAXGR) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,JGAP(5) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) !F95 COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 C NF1=NF+1 EQCFS=KG.EQ.KF C DO L=1,NF J=QCG(L,KG) JTEMP(L)=IEQ(J) K=QCG(L,KF) NTEMP(L)=IEQ(K) ENDDO C K=0 DO I=NF,1,-1 DO L=NF,1,-1 BTEMP(L,I)=JTEMP(L).EQ.NTEMP(I) IF(BTEMP(L,I))THEN K=K+1 LTEMP(K)=L KTEMP(K)=I ENDIF ENDDO ENDDO KTEMP(K+1)=0 KMAX=K C C INITIALIZE GROUP RANGES C MXD02=QMCL/2 !F95 C MG2=MXD02 MG1=-MXD02 C MG2P=MXD02 MG1P=-MXD02 C C LOOP OVER INITIAL ML GROUPS OF CONFIG KF C DO MG=MG2,MG1,-1 C M1=MPOINT(MG+1,KF)+1 !SLATER-STATE RANGE M2=MPOINT(MG,KF) C C LOOP OVER FINAL MLP GROUPS OF CONFIG KG C IF(EQCFS)MG1P=MG C DO MGP=MG2P,MG1P,-1 C M1P=MPOINT(MGP+1,KG)+1 !SLATER-STATE RANGE M2P=MPOINT(MGP,KG) C C LOOP OVER INITIAL SLATER STATES OF ML C DO M=M1,M2 C J=M C C LOOP OVER FINAL SLATER STATES OF MLP C IF(EQCFS.AND.MG.EQ.MGP)M2P=M C DO MP=M1P,M2P C JD=MP C NEN2=0 IF(JD.EQ.J)GO TO 75 !SO EQCFS=.TRUE. C NK=0 C C DETERMINE THE PAIR OF INDIVIDUAL SETS IN WHICH SLATER C STATE JD DIFFERS FROM J, AND THE PHASE FACTOR THAT RESULTS FROM C THE REMAINING NF-1 SETS: C N1=0 MU=0 DO I=1,NF MTEMP(I)=0 ENDDO C C CASES WHERE ORBITAL NL'S MATCH C I0=0 DO K=1,KMAX I=KTEMP(K) L=LTEMP(K) IF(I.NE.I0)THEN !NEED TO CHECK L STILL IF(QLMC(L,JD).EQ.QLMC(I,J))THEN MTEMP(I)=L I0=I ELSEIF(KTEMP(K+1).NE.I)THEN !HAVE MOVED TO A NEW I NK=NK+1 IF(NK.GT.1)GO TO 57 N1=I MU=I+MU ENDIF ENDIF ENDDO C C CASES WHERE ORBITALS DO NOT MATCH, SEE IF A DIFFERENCE C HAS ALREADY BEEN FLAGGED, IF NOT, DO SO. C DO I=NF,1,-1 IF(MTEMP(I).EQ.0.AND.N1.NE.I)THEN DO L=NF,1,-1 IF(.NOT.BTEMP(L,I))THEN NK=NK+1 IF(NK.GT.1)GO TO 57 N1=I MU=I+MU GO TO 580 ENDIF ENDDO ENDIF 580 ENDDO C ICG1=QCG(N1,KF) LP=QL(ICG1) IF(LP.EQ.0)GO TO 57 !S-STATES GIVE NO SPIN-ORBIT CONTRIBS C K=0 DO L=NF,1,-1 DO I=NF,1,-1 IF(MTEMP(I).EQ.L)GO TO 60 ENDDO K=K+1 N2=L MU=L+MU IF(K.EQ.NK)GO TO 74 60 ENDDO C 74 ICG2=QCG(N2,KG) IF(QL(ICG2).NE.LP)GO TO 57 !ZERO IF L-VALUES DIFFER IF(QN(ICG1).GE.90.AND.QN(ICG2).GE.90)GO TO 57 C IPHASE=(1-2*MOD(MU,2)) !*IPHASE C C NK.EQ.1 HERE C IF(NK.NE.1)THEN WRITE(6,*)'SPOR0: ERROR, SHOULD NOT BE HERE',KF,KG,J,JD STOP'SPOR0: ERROR, SHOULD NOT BE HERE' ENDIF C NEN2=NF1*N1+N2 NEN2=NEN2*IPHASE C C FLAG THIS PAIR AS INTERACTING (TBD DON'T BOTHER TO STORE J=JD CASE?) C 75 KINT=KINT+1 IF(KINT.LE.MXSTX)THEN !COULD PACK FURTHER... KINTI(KINT)=J KINTF(KINT)=JD KEN2(KINT)=NEN2 C WRITE(6,*)KF,J,' ** ',KG,JD ENDIF C 57 CONTINUE C ENDDO !END FINAL ML SLATER STATE LOOP C ENDDO !END INITIAL ML SLATER STATE LOOP C KPTCFM(MGP,MG,KK)=KINT IF(EQCFS)KPTCFM(MG,MGP,KK)=KINT C ENDDO !END FINAL MLP GROUP LOOP FOR KG C ENDDO !END INITIAL ML GROUP LOOP FOR KF C C RETURN C END C C ******************* C SUBROUTINE SPOR1(QLMC,MAXEL,MAM,NAM,IZY) C C----------------------------------------------------------------------- C C SR.SPOR1 EVALUATES SLATER-STATE INTERACTIONS FOR THE SPIN-ORBIT C MATRIX ELEMENTS - NRB. C C----------------------------------------------------------------------- C USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DFOUR=4.0D0) PARAMETER (TYNY=1.0D-6) C LOGICAL LX C DIMENSION QLMC(MAXEL,*),MAM(*),NAM(*) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,MGAP(5) CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 COMMON /COMRES/DVC12,LX,ICLRS,ICLRR COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 C IRLPS1=IRLPS0+1 IF(ICLRS.LT.0)GO TO 40 C C IN LOOPS 64,65 SCAN THROUGH SLATER STATES IN INITIAL AND C FINAL STATES RESP., AND CALCULATE CONTRIBUTIONS DUE TO EACH PAIR. C C DO 64 J1=JA,JB C L1=MAM(J1) C DO 65 J2=JAP,JBP C L2=NAM(J2) C CTHIS NEXT STATEMENT RESOLVES INTERACTIONS BY SLATER STATE COLD IRKPS00=IRKPS+1 C DO I=IRLPS1,IRLPS IORIG1(I)=0 ENDDO C NK=0 N1=0 IF(L2.EQ.L1)GO TO 88 !DIAGONAL C C NOW COMPARE INITIAL AND FINAL SLATERSTATES, L1 AND L2, C AND SELECT ONLY THE ONES WHICH DIFFER IN ONE SET OF QUANTUM NUMBERS C DO ICG2=1,NF N1=ICG2+N1 DO ICG1=1,NF IF(QLMC(ICG1,L1).NE.QLMC(ICG2,L2))GO TO 67 IF(IEQ(QCG(ICG1,KF)).NE.IEQ(QCG(ICG2,KG)))GO TO 67 N1=N1-ICG1 GO TO 66 67 ENDDO IF(NK.NE.0)GO TO 65 !SS DIFFER IN MORE THAN ONE PAIR NK=1 N2=ICG2 66 ENDDO C C L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2 C GO TO 87 C 88 N1=N1+1 IF(N1.GT.NF)GO TO 65 C N2=N1 87 ICG1=QCG(N1,KF) LP=QL(ICG1) C IF(LP.EQ.0)GO TO 81 !S-STATES GIVE NO SPIN-ORBIT CONTRIBS C ICG2=ICG1 IF(NK.NE.0)ICG2=QCG(N2,KG) IF(QN(ICG1).GE.90.AND.QN(ICG2).GE.90)GO TO 65 C C FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL C ELECTRONS,WHOSE NUMBERS ARE N1,N2. C MAUX=QLMC(N1,L1) QLML1=((MAUX+100)/2)*2-100 QLMS1=(MAUX-QLML1)*2-1 DD=QLMS1*QLML1 C IF(NK.NE.0)THEN !OFF-DIAGONAL C IF(QL(ICG2).NE.LP)GO TO 65 !ZERO IF THE L-VALUES DIFFER C C NOW PROCEED FOR (L+).(S-) OR (L-).(S+) RATHER THAN (L0).(S0) C C QLML2=((100+QLMC(N2,L2))/2)*2 -100 C QLMS2=(QLMC(N2,L2)-QLML2)*2-1 C QLMS2+QLML2=QLMS1+QLML1 FOR NK=0,1 C IF(QLMC(N2,L2).NE.MAUX)THEN MAUX=QLMS1+QLML1 DD=SQRT(DBLE((LP-MAUX+1)*(LP+MAUX+1))) ENDIF IF(((N1+N2)/2)*2.NE.N1+N2)DD=-DD IF(ICG2.GT.ICG1)THEN MAUX=ICG2 ICG2=ICG1 ICG1=MAUX ENDIF ENDIF C DD=DVC12*DD/DFOUR C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C DO J=IRLPS1,IRLPS IF(QRLPS(2,J).NE.ICG2) GO TO 72 IF(QRLPS(1,J).NE.ICG1) GO TO 72 I=IORIG1(J) IF(I.GT.0)THEN DRKPS(I)=DRKPS(I)+DD GO TO 81 ENDIF L=J GO TO 82 72 ENDDO C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C L=IRLPS+1 IF(L.GT.MXS1I)GO TO 1 C QRLPS(1,L)=ICG1 QRLPS(2,L)=ICG2 IRLPS=L C 82 IRKPS=IRKPS+1 IF(IRKPS.GT.MXS1C)GO TO 1 C IORIG1(L)=IRKPS NRKPS(IRKPS)=L DRKPS(IRKPS)=DD NSTJ1(IRKPS)=L1 NSTJ1D(IRKPS)=L2 C 81 IF(NK.EQ.0) GO TO 88 C C NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON C QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED, C THEREFORE PROCEED TO NEXT PAIR OF SLATER STATES. C 65 CONTINUE !END SCAN OF INITIAL SLATER STATES C 64 CONTINUE !END SCAN OF FINAL SLATER STATES C C C IF THE COEFFICIENTS OF THE SPIN-ORBIT PARAMETERS IN THE MATRIX C ELEMENT HAVE NOT BEEN COMPLETELY CALCULATED, RETURN - SPOR1 WILL C BE CALLED AGAIN, FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=QMJ. C IF(LX)RETURN C C ELIMINATE COEFFICIENTS /DRKPS/.LT.TYNY AND ARGUMENTS QRLPS THAT C HAVE BEEN LISTED BEFORE IN THE REFERENCE LIST C IF(KF.GT.0)RETURN C 40 ICLRS=0 IF(IRKPS.LT.IRKPS0)RETURN C K=IRKPS0-1 KP=0 DO I=IRLPS1,IRLPS IORIG1(I)=0 ENDDO C DO 91 I=IRKPS0,IRKPS C JD0=NRKPS(I) JD=IABS(JD0) IF(ABS(DRKPS(I)).LT.TYNY)THEN IF(IORIG1(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QRLPS AS MAY OCCUR LATER GO TO 94 ENDIF C K=K+1 DRKPS(K)=DRKPS(I) NSTJ1(K)=NSTJ1(I) NSTJ1D(K)=NSTJ1D(I) C 94 IF(JD.LE.IRLPS0)THEN WRITE(6,*)'SPOR1: INFORM NRB OF STOP HERE' WRITE(0,*)'SPOR1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 C LP=JD C GO TO 92 ENDIF C IF(IORIG1(JD).EQ.0)THEN LP=JD-KP DO L=1,IRLPS0 DO J=1,2 IF(QRLPS(J,JD).NE.QRLPS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG1(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG1(JD) GO TO 92 ENDIF C IORIG1(JD)=LP DO J=1,2 QRLPS(J,LP)=QRLPS(J,JD) ENDDO C 92 IF(JD0.NE.0)THEN NRKPS(K)=LP C IF(JD0.LT.0)NRKPS(K)=-NRKPS(K) ENDIF C 91 CONTINUE C C IRLPS=IRLPS-KP IRKPS=K 999 RETURN C 1 IZY=-1 GO TO 999 C END C C ******************* C SUBROUTINE SPOR1F(QLMC,MAXEL,NAM,IZY) C C----------------------------------------------------------------------- C C SR.SPOR1F EVALUATES SLATER-STATE INTERACTIONS FOR THE SPIN-ORBIT C MATRIX ELEMENTS. IT DIFFERS FROM SPOR1 IN THAT THE INTERACTING C PAIRS HAVE ALREADY BEEN SET-UP BY SR.SPOR0 - NRB. C C----------------------------------------------------------------------- C USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 USE COMMON_NRBFL0, ONLY: KINTI,KINTF,KEN2 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C CF77 PARAMETER (MXD02=14) !MAX TARGET L (NOT X2) !F77 CF77 PARAMETER (MXD03=MXD02+1) !F77 CF77 PARAMETER (MXD19=(MAXCF*(MAXCF+1))/2) !F77 C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DONE=1.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (TYNY=1.0D-6) C LOGICAL LX,brev C DIMENSION QLMC(MAXEL,*),NAM(*) X ,NEJ(2),NEN(2) C COMMON /BASIC/NF,KF,KG,JA,JB,JAP,JBP,MGAP(5) CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 COMMON /COMRES/DVC12,LX,ICLRS,ICLRR COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX CF77 COMMON /NRBFL0/KINTI(MXSTX),KINTF(MXSTX),KEN2(MXSTX) !F77 CF77 X ,KPTCFM(-MXD02:MXD03,-MXD02:MXD03,0:MXD19) !F77 CF77 X ,MPOINT(-MXD02:MXD03,MAXCF),KINT !F77 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 C EQUIVALENCE (NEN(1),N1),(NEN(2),N2) C IRLPS1=IRLPS0+1 IF(ICLRS.LT.0)GO TO 40 C brev=kf.lt.kg NF1=NF+1 C C BEGIN MAIN SLATER-STATE INTERACTION LOOP (64) C DO 64 J1=JA,JB C kk=nam(j1) if(brev.or.kk.lt.0)then kk=iabs(kk) i1=2 i2=1 else i1=1 i2=2 endif nej(i1)=kinti(kk) nej(i2)=kintf(kk) l1=nej(1) l2=nej(2) c c write(6,*)kf,j,' ',kg,jd C DO I=IRLPS1,IRLPS IORIG1(I)=0 ENDDO C DDH=DONE NK=0 N1=0 IF(L2.EQ.L1)GO TO 88 !DIAGONAL C C NK=1, L1 AND L2 DIFFER IN ONE PAIR, IN POSITIONS NUMBERED N1 AND N2 C nk=1 nen2=ken2(kk) c if(nen2.eq.0)stop 'nen2 error' if(nen2.lt.0)then ddh=-ddh nen2=-nen2 endif nen(i1)=nen2/nf1 c if(nen(i1).eq.0)stop 'nen(1) error' nen(i2)=nen2-nen(i1)*nf1 c if(nen(i2).eq.0)stop 'nen(2) error' c GO TO 87 C C NK=0 C 88 N1=N1+1 IF(N1.GT.NF)GO TO 64 C N2=N1 87 ICG1=QCG(N1,KF) LP=QL(ICG1) C !RETAIN TESTS FOR NK=0 LOOP OVER ORBS IF(LP.EQ.0)GO TO 81 !S-STATES GIVE NO SPIN-ORBIT CONTRIBS C ICG2=ICG1 IF(NK.NE.0)ICG2=QCG(N2,KG) IF(QN(ICG1).GE.90.AND.QN(ICG2).GE.90)GO TO 64 C C FIND THE AZIMUTHAL COMPONENTS OF L AND S FOR THE INDIVIDUAL C ELECTRONS,WHOSE NUMBERS ARE N1,N2. C MAUX=QLMC(N1,L1) QLML1=((MAUX+100)/2)*2-100 QLMS1=(MAUX-QLML1)*2-1 DD=QLMS1*QLML1 C IF(NK.NE.0)THEN !OFF-DIAGONAL C !SO NO TEST NEEDED C IF(QL(ICG2).NE.LP)GO TO 64 !ZERO IF THE L-VALUES DIFFER C C NOW PROCEED FOR (L+).(S-) OR (L-).(S+) RATHER THAN (L0).(S0) C C QLML2=((100+QLMC(N2,L2))/2)*2 -100 C QLMS2=(QLMC(N2,L2)-QLML2)*2-1 C QLMS2+QLML2=QLMS1+QLML1 FOR NK=0,1 C IF(QLMC(N2,L2).NE.MAUX)THEN MAUX=QLMS1+QLML1 DD=SQRT(DBLE((LP-MAUX+1)*(LP+MAUX+1))) ENDIF C IF(((N1+N2)/2)*2.NE.N1+N2)DDH=-DDH !TAKE FROM SPOR0 IF(ICG2.GT.ICG1)THEN MAUX=ICG2 ICG2=ICG1 ICG1=MAUX ENDIF ENDIF C DD=DDH*DVC12*DD/DFOUR C C STORE CONTRIBUTION TO (EXISTING) COEFFICIENT C DO J=IRLPS1,IRLPS IF(QRLPS(2,J).NE.ICG2) GO TO 72 IF(QRLPS(1,J).NE.ICG1) GO TO 72 I=IORIG1(J) IF(I.GT.0)THEN DRKPS(I)=DRKPS(I)+DD GO TO 81 ENDIF L=J GO TO 82 72 ENDDO C C CANNOT FIND OLD SET OF ARGUMENTS, SO START CONSTRUCTING A NEW SET C L=IRLPS+1 IF(L.GT.MXS1I)GO TO 1 C QRLPS(1,L)=ICG1 QRLPS(2,L)=ICG2 IRLPS=L C 82 IRKPS=IRKPS+1 IF(IRKPS.GT.MXS1C)GO TO 1 C IORIG1(L)=IRKPS NRKPS(IRKPS)=L DRKPS(IRKPS)=DD NSTJ1(IRKPS)=L1 NSTJ1D(IRKPS)=L2 C 81 IF(NK.EQ.0) GO TO 88 C C NK.EQ.1 FOR STATES WHICH DIFFER IN ONE SET OF ONE-ELECTRON C QUANTUM NOS, THE NECESSARY TERM HAS ALREADY BEEN EVALUATED, C THEREFORE PROCEED TO NEXT INTERACTION. C 64 CONTINUE !END SLATER-STATE INTERACTION LOOP C C C IF THE COEFFICIENTS OF THE SPIN-ORBIT PARAMETERS IN THE MATRIX C ELEMENT HAVE NOT BEEN COMPLETELY CALCULATED, RETURN - SPOR1 WILL C BE CALLED AGAIN, FOR DIFFERENT (MS,ML) GIVING THE SAME MS+ML=QMJ. C IF(LX)RETURN C C ELIMINATE COEFFICIENTS /DRKPS/.LT.TYNY AND ARGUMENTS QRLPS THAT C HAVE BEEN LISTED BEFORE IN THE REFERENCE LIST C IF(KF.GT.0)RETURN C 40 ICLRS=0 IF(IRKPS.LT.IRKPS0)RETURN C K=IRKPS0-1 KP=0 DO I=IRLPS1,IRLPS IORIG1(I)=0 ENDDO C DO 91 I=IRKPS0,IRKPS C JD0=NRKPS(I) JD=IABS(JD0) IF(ABS(DRKPS(I)).LT.TYNY)THEN IF(IORIG1(JD).GT.0)GO TO 91 JD0=0 !RE-INDEX QRLPS AS MAY OCCUR LATER GO TO 94 ENDIF C K=K+1 DRKPS(K)=DRKPS(I) NSTJ1(K)=NSTJ1(I) NSTJ1D(K)=NSTJ1D(I) C 94 IF(JD.LE.IRLPS0)THEN WRITE(6,*)'SPOR1: INFORM NRB OF STOP HERE' WRITE(0,*)'SPOR1: INFORM NRB OF STOP HERE' NF=-1 GO TO 999 C LP=JD C GO TO 92 ENDIF C IF(IORIG1(JD).EQ.0)THEN LP=JD-KP DO L=1,IRLPS0 DO J=1,2 IF(QRLPS(J,JD).NE.QRLPS(J,L))GO TO 95 ENDDO KP=KP+1 IORIG1(JD)=L LP=L GO TO 92 95 ENDDO ELSE LP=IORIG1(JD) GO TO 92 ENDIF C IORIG1(JD)=LP DO J=1,2 QRLPS(J,LP)=QRLPS(J,JD) ENDDO C 92 IF(JD0.NE.0)THEN NRKPS(K)=LP C IF(JD0.LT.0)NRKPS(K)=-NRKPS(K) ENDIF C 91 CONTINUE C C IRLPS=IRLPS-KP IRKPS=K 999 RETURN C 1 IZY=-1 GO TO 999 C END C C ******************* C SUBROUTINE SPOR2(DC,mam,nam,KK,IZY) C C----------------------------------------------------------------------- C C SR.SPOR2 EVALUATES ALGEBRAIC CONTRIBUTIONS TO THE SPIN-ORBIT MATRIX C ELEMENTS BY LOOPING OVER ALL SLATER-STATE INTERACTIONS - NRB. C C----------------------------------------------------------------------- C USE COMMON_COEFF, ONLY: DRKP,QRLP,IRLP,NRKP !F95 USE COMMON_COEFFS, ONLY: DRKPS,QRLPS,NRKPS !F95 USE COMMON_NSTS1, ONLY: NADS1,NSTJ1,NSTJ1D,IORIG1,JORIG1 !F95 C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD27=MAXCF*MAXCF) C PARAMETER (DZERO=0.0D0) PARAMETER (TYNY=1.0D-9) PARAMETER (TTYNY=10*TYNY) C LOGICAL BFAST C CF77 INTEGER*8 NRKP !F77 C REAL*8 DC DIMENSION DC(0:*),mam(*),nam(*) C COMMON /BASIC/NF,KF,KG,JGAP(4),IGAP,NJ2,NJP2,MGAP(2) CF77 COMMON /COEFF/DRKP(MXSOC),NRKP(MXSOC),QRLP(4,MXSOI),IRLP !F77 CF77 X ,NADP(MXADJ) !F77 CF77 COMMON /COEFFS/DRKPS(MXS1C),QRLPS(4,MXS1I),NRKPS(MXS1C) !F77 COMMON /NXRLP/IRKP,IRKP0 COMMON /NSSADR/IRKPS,IRKPS0,IRLPS,IRLPS0,IRSS,IRSS0,NLS,NLS00 CF77 COMMON /NSTS1/NADS1(0:MXD27),NSTJ1(MXS1C),NSTJ1D(MXS1C) !F77 CF77 X ,IORIG1(MXS1I),JORIG1(MXS1I) !F77 C C IF(MXS1I.LT.MXSOI)GO TO 10 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C IRLP0=IRLP C IRLP1=IRLP0+1 C DO J=1,IRLPS JORIG1(J)=0 ENDDO C C C BEGIN MAIN LOOP 65 OVER SLATER STATE INTERACTIONS C K0=NADS1(KK-1)+1 C DO 65 KS=K0,NADS1(KK) C L1=NSTJ1(KS) L2=NSTJ1D(KS) C IF(BFAST)THEN DDH=DC(L1+NJ2)*DC(L2+NJP2)*DRKPS(KS) ELSE m1=mam(l1) if(m1.eq.0)go to 65 m2=nam(l2) if(m2.eq.0)go to 65 DDH=DC(m1)*DC(m2)*DRKPS(KS) ENDIF C IF(ABS(DDH).LT.TYNY)GO TO 65 C N=NRKPS(KS) L=JORIG1(N) IF(L.GT.0)THEN K=IORIG1(L) DRKP(K)=DRKP(K)+DDH ELSE C C CANNOT FIND AN OLD SET OF ARGUMENTS EQUAL TO THE NEW SET, SO C MUST START CONSTRUCTING A NEW COEFFICIENT. C L=IRLP+1 IRLP=L IRKP=IRKP+1 C IF(IRKP.GT.MXSOC)GO TO 1 IF(L.GT.MXSOI)GO TO 1 C QRLP(1,L)=QRLPS(1,N) QRLP(2,L)=QRLPS(2,N) QRLP(3,L)=0 QRLP(4,L)=0 JORIG1(N)=L IORIG1(L)=IRKP NRKP(IRKP)=L DRKP(IRKP)=DDH ENDIF C 65 CONTINUE C C IF THE MATRIX ELEMENT HAS BEEN CALCULATED CLEAR THE ARRAY DRKP C OF ZEROS AND ADJUST NRKP. C IF(IRKP.LT.IRKP0)RETURN C K=IRKP0-1 N1=0 C DO I=IRKP0,IRKP IF(ABS(DRKP(I)).LT.TTYNY)GO TO 90 K=K+1 DRKP(K)=DRKP(I) N2=INT(NRKP(I)) LP=N2-N1 DO L=1,IRLP0 DO J=1,2 IF(QRLP(J,N2).NE.QRLP(J,L))GO TO 94 ENDDO LP=L GO TO 91 94 ENDDO N1=N1-1 DO J=1,2 QRLP(J,LP)=QRLP(J,N2) ENDDO 91 NRKP(K)=LP 90 N1=N1+1 ENDDO C IRLP=IRLP-N1 IRKP=K RETURN C 1 IZY=-1 RETURN C 10 WRITE(6,990) WRITE(0,*)'***SR.SPOR2: SET MXS1I .GE. MXSOI ***' GO TO 1 C 990 FORMAT(/' SR.SPOR2: SET MXS1I .GE. MXSOI') END C C ******************* C SUBROUTINE STOPOT(Z,MION,MK,AJUST0,DX,MPOT,MI,MTI,DXI,X,POT,TOL X ,MEND,MPP) C C----------------------------------------------------------------------- C C N.R. BADNELL D.A.M.T.P. CAMBRIDGE C C SR. STOPOT CALCULATES A SLATER-TYPE-ORBITAL UNIVERSAL POTENTIAL. C BORT=.FALSE. C FOR MION ELECTRON FILL UP PRINCIPAL QUANTUM NUMBER SHELLS WITH C MION-1 ELECTRONS. ADJUSTABLE PARAMETER IS APPLIED TO ALL SHELLS. C BORT=.TRUE. C CALCULATE NEW STO POTENTIAL FOR EACH NL ORBITAL MK, BASED ON C CONFIGURATION NO MCFSTO(MK). IF NONE SPECIFIED THEN C AVERAGES NUMBER OF ELECTRONS FOR EACH ORBITAL OVER NUMBER OF C CONFIGURATIONS WHICH CONTAIN THEM. EXCLUDE CORRELATION CONFIGS C ALSO, EXCLUDE VALENCE DR, CONTINUUM AND SPECTATOR ELECTRONS. C ELECTRON WITH PRINCIPAL QUANTUM NUMBER NS IS A SPECTATOR ELECTRON C IF THERE ARE NO ELECTRONS WITH P.Q. NO NS-1 IN ANY OF THE CONFIGS C IF REQUIRE INPUT OF CONTINUUM ORBITALS FROM RADWIN RESET C DKEY TO 999, SEE BELOW. C SHELL NUMBER EQUALS PRINCIPAL QUANTUM NUMBER I.E. MC(N)=N. C ADJUSTABLE PARAMETER SCALES RADIAL COORDINATE AND IS APPLIED C TO ALL SHELLS, FOR NOW. C QUANTITIES REQUIRED: TOL AND ALL ARGUMENTS UPTO DXI; C Z=NUCLEAR CHARGE, MION=NUMBER OF ELECTRONS IN THE ION C ADJUST=SCALING PARAMETER (A VALUE GT 1.0 CONTRACTS THE EFFECTIVE C RADIAL SCALE, I.E. Z FALLS OFF MORE SLOWLY TOWARDS RESIDUAL ZN. C DXI(J),J=1,MI=STEP LENGTH IN THE J'TH INTERVAL -- STEP LENGTH IS C DOUBLED IN SUCCESSIVE INTERVALS, DX=DXI(1) IS INPUT-SO ARE THE C NUMBERS MTI(J) OF STEPS IN THE MI INTERVALS J; ANOTHER RESULT IS C X(I),I=1,MPOT=RADIAL DISTANCE AT THE MPOT RADIAL POINTS I; C MPOT MUST BE EITHER EXACT OR LE 0 AND WILL BE EXACT ON RETURN. C MEND=INDEX OF THE LAST POINT FOR WHICH THE EFFECTIVE CHARGE HAS C NOT NECESSARILY THE RESIDUAL VALUE ZN; FOR X.GT.X(MEND) THE C POTENTIAL IS ZN/X=(Z-MION+1)/X. IF THE RANGE X(MPOT) IS TOO C SMALL FOR THE EFFECTIVE CHARGE TO DROP TO ZN CONTROL IS RETURNED C WITH DX=2*DX -- WHILE DXI(1) CONTAINS THE ORIGINAL DX. C POT(I),I=1,MPOT=VALUE OF THE POTEMTIAL AT THE POINTS X(I). C POT(I) WAS STORED IN /COM1/- POT,DTOL,MEND NOW OUTPUT THROUGH C ARGUMENT LIST & THEN STORED IN /COM1/IN RADIAL FOR USE IN RADWAV. C C DX(MEND) IS LAST POINT FOR WHICH POT*X/ZN .GT. DTOL (TYPICALLY=0 C THEN POTENTIAL IS COULOMB TO 1% AT DX(MEND)) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) C PARAMETER (MXD14=100) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DMONE=-1.0D0) PARAMETER (D1M2=1.0D-2) PARAMETER (D7999=7999.0D0) PARAMETER (TOLW=1.D-3) !TOLERANCE FOR MATCHING OCCUPATION NOS WK C DIMENSION POT(*),X(*),DXI(*),MTI(*),MEL(MAXGR) DIMENSION PAV(MAXB1),CAV(MAXB1),KHLP(MAXB1) C LOGICAL BSTO,BORT,BCORE,BALAN,BJUMP,BJUMP2,BRAD,BNLSUB X ,BREL,BJUMPR,BMVD,BREL2,BPRINT,BPRNT0,BFIX,BPRNTX,bdw C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MMMM,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /CALAN/DALAN(MXVAR),BALAN COMMON /MQVC/MDUM,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /OUTP2/BPRINT,MPNCH,KUTCA,KDUM COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),R(MAXB1) X ,DORIG(MAXGR) COMMON /NRB/MAUTO,MODE,SACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBBOX/RZERO,MXBOX C COMMON /NRBCAV/ECAVX(MAXCF),ECAV(MAXCF),AJUSTX,ICAV COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX0,NOCC0 X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) C COMMON /NRBUNI/IUNIT(MXD14),NUNIT COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD C EQUIVALENCE (PAV(1),DUM1(1)),(CAV(1),DUM2(1)),(KHLP(1),DUM3(1)) C DATA DX0/DMONE/,MPOLD/0/,MP0/0/,MP00/0/,MHLP/-1/ BPRNT0=BPRINT IF(BPRINT)BPRNT0=JPRINT.NE.-3 C BREL2=IABS(IREL).EQ.2 BORT=MORT.LT.0 C NOCC=MOD(NOCC0,1000) C IF(MPP.LT.MP0)MP0=MPP C MCFMX=MCFMX0 IF(MCFMX.GT.1000)MCFMX=0 !AVERAGE OVER MOD(MCFMX0,1000) C C IF REQUIRE TWO ELECTRONS IN A CONFIGURATION WITH N .GT. MAXGR C INCREASE MXSH, COMMON /NRBSTO/ (THR' WHOLE PROG) & DIMEN TEL. C WORKS FOR ONE ELECTRON WITH N .GT. MXSH. C MXSH=MAXGR C DTOL=TOL C DTOL=0.01 DKEY=5999 C DKEY=999 C ISWCH0=0 DO I=1,MAXGR IF(QN(I).LT.0.OR.IVAL(I).NE.0.OR.SCREEN(I).GE.D7999)ISWCH0=1 ENDDO BNLSUB=(MION-ISWCH0).GT.NLSTOE.OR.BALAN !RESOLVE BY NL-SUBSHELL C ISWCH=0 IF(QN(MK).LT.0.OR.IVAL(MK).NE.0.OR.SCREEN(MK).GE.D7999)ISWCH=1 C MCFMXX=MCFMX IF(MCFMXX.LT.0.AND.ISWCH.EQ.1)THEN !CASE IF -MCFMX TOO LARGE KF=KMAX IF(KCUT.GT.0.AND.IEQ(0).GE.0)KF=MIN(KCUT,KMAX) DO K=1,KF I=QCG(NF,K) IF(QN(I).LT.0.OR.IVAL(I).NE.0.OR.SCREEN(I).GE.D7999)MCFMX=K ENDDO MCFMX=-MCFMX ENDIF C C DETERMINE INITIAL ASYMPTOTIC CHARGE c N=MION ZN=1-MION ZN=Z+ZN ZN1=ZN IF(NINT(ZN1).EQ.0)ZN1=DONE C C SET UP THE X ARRAY: C DX=STEP LENGTH IN THE FIRST INTERVAL (I=1) C THE STEP LENGTH DOUBLES FROM ONE INTERVAL TO THE NEXT FOR USE IN S C IF !MAUTO! .LT.100, OTHERWISE STEP INCREASES BY FACTOR MAUTO/100 C IF(NINT(DX/DX0).NE.1.OR.MPOT.gt.MPOLD)THEN ISTEP=0 V0=DTWO IF(IABS(MAUTO).GE.100)THEN V0=MAUTO V0=V0*D1M2 IF(V0.LT.DZERO)V0=-V0 ENDIF C H=DX XB=DZERO DO J=1,MI DXI(J)=H II=MTI(J) DO I=1,II ISTEP=ISTEP+1 XB=XB+H X(ISTEP)=XB ENDDO H=V0*H ENDDO DX0=DX C IF(MPOT.LE.0)MPOT=ISTEP IF(ISTEP.NE.MPOT)THEN WRITE(6,992) WRITE(0,*)'STOPOT: NPOINT INCOMPATIBLE WITH NTI,NI' GO TO 999 ENDIF MPOLD=MPOT ENDIF C IF(Z.EQ.DZERO)GO TO 300 !RETURN C TOLH=D1M2 C C GO READ EXTERNAL POTENTIAL (MAYBE) C IF(MHF*MK.GT.0)THEN C IF(MHLP.LT.0)THEN !CALCULATE C CALL POTIN(Z,MION,MK,MPOT,X,POT,MEND,CAV,PAV,KHLP,MHLP) C IF(MHLP.EQ.0)THEN MHLP=-1 !RE-INITIALIZE GO TO 55 !TRY AND GENERATE INTERNALLY ENDIF C ELSE C C (RE-) INITIALIZE (SINCE THERE IS ONLY ONE POTENTIAL HERE) C DO I=1,MPOT POT(I)=PAV(I) ENDDO C ENDIF C GO TO 300 !RETURN C ENDIF C C CHECK RZERO C 55 IF(RZERO.GT.DZERO.AND.MXBOX.EQ.0)THEN DO I=1,MPOT IF(X(I).GT.RZERO)THEN MXBOX=I-MOD(I+1,2) !KEEP ODD GO TO 51 ENDIF ENDDO MXBOX=MPOT C 51 MPOT=0 MI0=MI DO I=1,MI0 MPOT=MPOT+MTI(I) MI=I IF(MPOT.EQ.MXBOX)GO TO 53 IF(MPOT.GT.MXBOX)THEN MPOT=MPOT-MTI(I) MTI(I)=MAX0(MXBOX-MPOT,9) MPOT=MPOT+MTI(I) GO TO 53 ENDIF ENDDO 53 MXBOX=MPOT ENDIF C C NEGATIVE SCALING PARAMETERS/LAMDAS FLAG SCREENED HYDROGENIC C AJUST=AJUST0 IF(ABS(AJUST).LT.D1M2.AND.MPP.LT.2)AJUST=DONE !FOR DIRECT STO C IF(AJUST.LT.DZERO)THEN A=-AJUST*Z B=(DONE+AJUST)*Z ZH=Z/DTWO DO J=1,MPOT T=EXP(-ZH*X(J)) !HISTORIC CUSP CONDITION AT ORIGIN T=T*B POT(J)=(A+T)/X(J) IF(ABS(T/A).GT.TOLH)MEND=J ENDDO IF(MEND.LT.MPOT)GO TO 300 !RETURN DX=DX+DX T=T/X(MEND) WRITE(6,996) AJUST,X(MEND),POT(MEND),T GO TO 300 !RETURN ENDIF C C IF ONLY ONE ELECTRON IS PRESENT THE POTENTIAL IS PURELY COULOMBIC C IF(MION.EQ.1)THEN MEND=1 DO I=1,MPOT POT(I)=ZN/X(I) ENDDO GO TO 300 !RETURN ENDIF C IF(BORT)GO TO 12 C C V(LL) POTENTIAL C IOK=2 NN=MION-1 MS=0 IF(NN.GT.88)MS=-1 !JUICYS C IF(MSHELL.GT.0)GO TO 15 IF(MS.EQ.0)GO TO 14 C MSHELL=2 MEL(1)=88 MEL(2)=NN-88 GO TO 15 14 MC(1)=1 MEL(1)=2 MC(2)=2 MEL(2)=8 IF(NN.GT.56)GO TO 8 MC(3)=3 MEL(3)=8 MC(4)=4 MEL(4)=2 MC(5)=3 MEL(5)=10 MC(6)=4 MEL(6)=6 MC(7)=5 MEL(7)=2 MC(8)=4 MEL(8)=10 MC(9)=5 MEL(9)=6 MC(10)=6 MEL(10)=2 GO TO 9 8 MC(3)=3 MEL(3)=18 MC(4)=4 MEL(4)=18 MC(5)=5 MEL(5)=8 MC(6)=6 MEL(6)=2 MC(7)=4 MEL(7)=14 MC(8)=5 MEL(8)=10 MC(9)=6 MEL(9)=6 MC(10)=7 MEL(10)=2 C 9 DO I=1,MXSH NN=NN-MEL(I) IF(NN.LE.0)GO TO 11 ENDDO 11 NN=NN+MEL(I) MEL(I)=NN MSHELL=I C 15 IF(NOCC.NE.0)THEN MSHELL=IABS(NOCC) IF(MSHELL.GT.10)THEN WRITE(6,*)'*** SR.STOPOT: ONLY 10 SHELLS DEFINED' X ,' USER NOCC GIVES MSHELL=',MSHELL WRITE(0,*)'*** SR.STOPOT: ONLY 10 SHELLS DEFINED' X ,' USER NOCC GIVES MSHELL=',MSHELL GO TO 999 ENDIF WKT=0 DO I=1,MSHELL WKT=WKT+TEL(I) ENDDO IF(ABS(WKT-MION).GT.TOLW)THEN WRITE(6,1005)WKT,MION WRITE(0,1005)WKT,MION GO TO 999 ENDIF ELSE DO I=1,MSHELL TEL(I)=MEL(I) ENDDO ENDIF GO TO 30 C C V(NL) POTENTIAL C 12 IF(MPP.GT.1)GO TO 50 C BCORE=MK.GE.MA.AND.MK.LE.MB C DO J=1,MXSH MC(J)=J IF(BNLSUB)MC(J)=mod(QN(J),70) !CASE RADWIN FLAGGED ENDDO C IF(BNLSUB)THEN MS=MK IF(QN(MK).LT.0)MS=-MS ELSE MS=QN(MK) MS=MOD(MS,70) ENDIF C C USER INPUT OCCUPATION NUMBERS C IF(NOCC.NE.0)THEN MSHELL=IABS(NOCC) IF(MS.LT.0.OR.IVAL(MK).GT.0)MS=0 ZN=ZN+ISWCH0 GO TO 30 ENDIF C C DETERMINE OCCUPATION NUMBERS INTERNALLY C DO J=1,MXSH TEL(J)=DZERO MEL(J)=0 ENDDO C MSHELL=0 KAV=0 NZ=0 C IF(MCFMX.GT.0.AND.(IEQ(0).GE.0.OR.IEQ(0).LT.0.AND.BCORE))THEN C C DETERMINE OCCUPATION NUMBERS FOR CONFIG. SPECIFIED FOR THIS ORBITAL C IF(MK.GT.MCFMX)THEN KS=MCFSTO(MCFMX) ELSE KS=MCFSTO(MK) ENDIF KF=KS IF(KS.LE.0)THEN WRITE(6,993)MK,KS WRITE(0,*)'SR.STOPOT: ORBITAL NOT FOUND IN CONFIGURATION' GO TO 999 ENDIF ELSE C C USE CONFIGURATION AVERAGE C KS=1 KF=KMAX IF(IEQ(0).GE.0)THEN IF(KCUT.GT.0)KF=MIN(KCUT,KMAX) IF(MCFMX0.GT.1000)KF=MIN(MOD(MCFMX0,1000),KMAX) !SO NOT KCUT IF(mcfmx.lt.0)kf=min(-mcfmx,kmax) ENDIF ENDIF C 19 bdw=idw.ne.0.and.qn(mk).lt.0 c allow target average but an override for cont e.g. Laguerres if(bdw.and.mcfsto(mk).ne.0)then ks=mcfsto(mk) kf=ks endif c DO 23 K=KS,KF IF(.NOT.BCORE.and.mcfmx.ge.0)THEN C C AVERAGE OVER ONLY THOSE CONFIGS THAT CONTAIN MK. C DO I=1,NF IF(QCG(I,K).EQ.MK)THEN IF(IEQ(0).LT.0.AND.MCFSTO(MK).EQ.0)MCFSTO(MK)=K GO TO 21 ENDIF ENDDO IF(MCFMX.LE.0)then if(bdw)go to 21 GO TO 23 ENDIF COLD IF(IVAL(MK).GT.0.OR.SCREEN(MK).GT.DKEY)GO TO 21 MF=QCG(NF,K) IF(SCREEN(MK).GT.DKEY.AND.(QN(MF).LT.0.OR.IVAL(MF).NE.0.OR. X SCREEN(MF).GT.DKEY).or.bdw)GO TO 21 IF(IEQ(0).LT.0)GO TO 23 MS=0 IF(MHF.GE.-100.OR.MK.NE.MCFMX)THEN !NEED FOR POTOUT='YES' WRITE(6,993) MK,K WRITE(0,*)'*****ERROR IN SR.STOPOT: ORBITAL NOT FOUND IN CF' GO TO 999 ENDIF ENDIF C C USE MCFMX.LT.0 TO AVERAGE OVER -MCFMX C 21 KAV=KAV+1 N0=100 IOK=0 DO 25 L=1,NF I=QCG(L,K) IF(I.EQ.MK)IOK=IOK+1 MJ=QN(I) J=MOD(MJ,70) IF(BNLSUB)J=I NZ=NZ+1 IF(IVAL(I).GT.0.AND.(QN(I).GE.IABS(QN(MK)).OR.QN(MK).LT.0)) X GO TO 25 if(dajold(i).lt.dzero.and.qn(mk).lt.0)go to 25 !for dw IF(SCREEN(I).GT.DKEY)GO TO 25 IF(QN(I).LT.0)GO TO 25 IF(J.GT.MXSH)GO TO 25 IF((J-N0).GT.1.AND.IABS(MS).LT.J)GO TO 25 NZ=NZ-1 N0=J IF(J.GT.MSHELL)MSHELL=J MEL(J)=MEL(J)+1 25 CONTINUE IF(MS.GT.MXSH.OR.MS.LT.0.OR.IVAL(MK).GT.0)NZ=NZ-1 23 CONTINUE C IF(KAV.EQ.0)THEN IF(MCFMX.EQ.0.AND.KF.LT.KMAX)THEN !CORRELATION ORBITAL KF=KMAX !NOT IN KCUT, SO GO TO 19 ELSE WRITE(6,991)MK,KF WRITE(0,*)'*****ERROR IN SR.STOPOT: ORBITAL NOT FOUND IN CFS' GO TO 999 ENDIF ENDIF C IF(MB.GT.0)THEN DO I=MA,MB MJ=QN(I) J=MOD(MJ,70) IF(BNLSUB)J=I IF(J.GT.MSHELL)MSHELL=J MEL(J)=MEL(J)+2*(QL(I)+1)*KAV ENDDO ENDIF C T1=KAV TZ=NZ TZ=TZ/T1 ZN=ZN+TZ IF(MPP.EQ.0)THEN NZ=NINT(TZ) IF(ABS(TZ-NZ).GT.TOLW)THEN !FOR MCFMX.GT.0 NZ IS 0 OR 1 IF(BPRNT0)WRITE(6,1001)TZ C WRITE(0,1001)TZ C GO TO 999 ENDIF ENDIF c write(6,*)mk,ajust,zn C DO J=1,MSHELL T2=MEL(J) TEL(J)=T2/T1 c if(t2.ne.dzero)write(6,*)j,tel(j) ENDDO C IF(MS.LT.0.OR.IVAL(MK).GT.0)MS=0 C C POTENTIAL RE-ENTRY POINT C 30 CONTINUE C c write(6,*)-mk,ajust DO J=1,MSHELL ALF(J)=AJUST IF(BALAN)ALF(J)=DALAN(J) C WRITE(6,997)J,ALF(J) c if(tel(j).ne.dzero)write(6,*)j,tel(j) ENDDO C DZ=-Z MEND=1 TS=DONE MN=QN(MK) MN=IABS(MN) IF(.NOT.BCORE.AND.IOK.EQ.1)MN=-MN ML=QL(MK)/2 ZN1=ZN IF(NINT(ZN1).EQ.0)ZN1=DONE C DO I=1,MPOT C POT(I)=-ZEFX(MS,MN,ML,DZ,TS,MSHELL,MC,TEL,ALF,X(I),MEXPOT) C c write(6,997) i,x(i),pot(i) c 997 format(i5,2f10.6) C T=POT(I)*X(I)/ZN1 IF(ABS(T).GT.DTOL)MEND=I POT(I)=POT(I)+ZN/X(I) C ENDDO c c do j=1,mend c write(66,*)x(j),pot(j),x(j)*pot(j) c enddo C IF(MEND.GE.MPOT)THEN DX=DX+DX DZ=ZN/X(MPOT) T=POT(I)-DZ WRITE(6,996)AJUST,X(MPOT),DZ,T ENDIF GO TO 300 !RETURN C C SELF-CONSISTENT C 50 CONTINUE C C NOCC.LT.0 USES A DIFFERENT POTENTIAL FOR EACH ORBITAL. C IF MCFMX IS SET APPROPRIATELY, IT CAN BE THE SAME AVERAGE C POTENTIAL FOR EACH ORBITAL SAVE FOR THE OMITTED SELF-INTERACTION C TERM I.E. THE ORBITALS ARE (STILL) NOT ORTHOGONAL. c if(nocc0.lt.0.or.iswch.gt.0)then C BPRNTX=MCFMX.LT.0.AND.BPRNT0.AND.MP00.EQ.0 IF(BPRNTX.AND.MP00.EQ.0)WRITE(6,994)NOCC,MCFMX C CALL VPNL(Z,MION,MK,WK,AJUST,MPOT,MI,MTI,DXI,POT,DTOL,MEND) C IF(BPRNTX)THEN DO J=1,MSHELL IF(TEL(J).NE.DZERO)WRITE(6,995)J,TEL(J) c write(0,*)j,tel(j) ENDDO WRITE(6,*) ENDIF C MP0=MPP IF(BPRNT0)MP00=MP0 C wkt=0 do k=1,maxgr c if(mpp.eq.2.and.tel(k).gt.tolw)write(0,*)k,tel(k) wkt=wkt+tel(k) enddo if(abs(wkt-mion).gt.tolw.and.abs(wkt-mion+iswch).gt.tolw x .and.abs(wkt-mion+iswch0).gt.tolw)then IF(BPRNT0)WRITE(6,1003)WKT,MION-iswch,MK if(iswch.eq.1)then write(0,1003)wkt,mion-iswch,mk if(.not.bprnt0)write(6,1003)wkt,mion-iswch,mk go to 999 endif endif endif C C NOCC.GE.0 USES A SINGLE UNIQUE POTENTIAL BY AVERAGING OVER THE C POTENTIALS USED FOR EACH ORBITAL - THE AVERAGE OF THE MODEL C CONFIGURATION. C IF(MPP.GT.MP0.and.nocc0.ge.0)THEN C DO I=1,MPOT PAV(I)=DZERO CAV(I)=DZERO ENDDO C IF(BPRNT0.AND.MP00.EQ.0)WRITE(6,994)NOCC,MCFMX WKT=0 DO K=1,MAXGR IF(DEY(K).NE.DZERO.AND.IVAL(K).EQ.0.AND.SCREEN(K).LT.DKEY.and. x (nocc.eq.0.or.nocc.ne.0.and.tel(k).gt.tolw))THEN C CALL VPNL(Z,MION,K,WK,AJUST,MPOT,MI,MTI,DXI,POT,DTOL,MEND) C IF(BPRNT0.AND.MP00.EQ.0)THEN c write(0,995)k,wk WRITE(6,995)K,WK ENDIF WKT=WKT+WK IF(WK.GT.TOLW)THEN DO I=1,MPOT T=DPNL(I,K)*DPNL(I,K) IF(BREL2)T=T+DQNL(I,K)*DQNL(I,K) T=T*WK PAV(I)=PAV(I)+POT(I) !*T !IF NOT IN VPNL CAV(I)=CAV(I)+T ENDDO ENDIF ENDIF ENDDO IF(BPRNT0.AND.MP00.EQ.0)THEN WRITE(6,1000)WKT WRITE(6,997) ENDIF C c if(mp0.eq.0)write(0,*)wkt IF(ABS(WKT-MION).GT.TOLW.and.abs(wkt-mion+iswch0).gt.tolw)THEN IF(BPRNT0)WRITE(6,1002)WKT,MION-iswch0 c WRITE(0,1002)WKT,MION-iswch0 c GO TO 999 ENDIF C C (RE-) INITIALIZE C DO I=1,MPOT POT(I)=PAV(I)/CAV(I) T=POT(I)-ZN/R(I) T=T*R(I)/ZN1 IF(ABS(T).GT.DTOL)MEND=I if(bprnt0)write(77,*)i,x(i),x(i)*pot(i),-pot(i) ENDDO C MP0=MPP IF(BPRNT0)MP00=MP0 C IF(MEND.LT.MPOT)GO TO 300 C T=POT(MPOT)*R(MPOT) C WRITE(6,1006)MK,R(MPOT),ZN,T C ENDIF C C 300 MCFMX=MCFMXX C RETURN C 999 NF=-1 GO TO 300 C 991 FORMAT(' *** ERROR IN SR.STOPOT: ORBITAL',I4,' NOT FOUND IN' X,' THE FIRST',I4,' CONFIGURATIONS') 992 FORMAT( ' SR.STOPOT: MPOT INCOMPATIBLE WITH MTI,MI') 993 FORMAT( '*** ERROR IN SR.STOPOT: ORBITAL ', I3, X' NOT FOUND IN CONFIGURATION ', I3) 994 FORMAT(//' CONFIGURATION AVERAGE OCCUPATION NUMBERS FOR NOCC=',I3 X,5X,'MCFMX=',I5/) 995 FORMAT(I3,F10.4) 996 FORMAT( ' SR.STOPOT (ADJUST,X(MPOT),COUL-POT(MPOT),NON-COUL) =', X4F10.5/ ' RETURN WITH INITIAL STEP LENGTH DOUBLED') 997 FORMAT(///) 1000 FORMAT(/'SUM',F10.3) 1001 FORMAT(' *** SR.STOPOT: WARNING, ASYMPTOTIC CHARGE= Z-N+',F6.2) 1002 FORMAT(' *** SR.STOPOT: SR.VPNL GIVES FICTIONAL AVERAGE CF' X ,' WITH WK.NE.MION:',F6.2,I3) 1003 FORMAT(' *** SR.STOPOT: SR.VPNL GIVES FICTIONAL AVERAGE CF' X ,' WITH WK.NE.MION:',F6.2,I3,' FOR ORBITAL',I3) 1005 FORMAT('*** SR.STOPOT: USER INPUT NOCC GIVES' X ,' WK.NE.MION:',F6.2,I3) 1006 FORMAT(' *** SR.STOPOT: NOT ENOUGH MESH POINTS FOR ORBITAL?',I5 X,' CHECK IF ASYMPTOTIC POTENTIAL ACCURATE ENOUGH:',1P,3E11.3) C END C C ******************* C SUBROUTINE STORAD(ZA,MAXRS,MAXPS) C C----------------------------------------------------------------------- C C SR.STORAD INITIALIZES DPNL TO STO'S. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (D1P2=1.0D2) PARAMETER (D1M6=1.0D-6) C COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /RADF/P(MAXB1,MAXGR),DUY(MAXGR,MAXGR),R(MAXB1) X ,DORIG(MAXGR) C DO I=1,MAXGR IF(DEY(I).EQ.DZERO)GO TO 1 IF(QN(I).LT.0.OR.QN(I).GT.10)GO TO 1 N=QN(I) NT=1 DO J=1,N NT=NT*2*J*(2*J-1) ENDDO AN=DBLE(N*NT/2) AN=SQRT(ZA/AN) T=N T=ZA/T DO J=1,MAXRS P(J,I)=DZERO TR=T*R(J) IF(TR.LT.D1P2)P(J,I)=AN*(TR+TR)**N*EXP(-TR) IF(ABS(P(J,I)).GT.D1M6)MAXPS=MAX0(MAXPS,J) ENDDO 1 ENDDO C RETURN END C C ******************* C SUBROUTINE SYMLS C C----------------------------------------------------------------------- C C SR.SYMLS C DETERMINES THE LSP SYMMETRIES AND CHANNEL LIST BASED-UPON THE USER C SPECIFIED MINST, MAXST & MINLT, MAXLT, OR DIRECT LSP INPUT, C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BKUTOO,BPRNT0,LX,LY,BTHRSH x,eqgrp,eqgrpl,eqgrpl0,bcorr,becor,bcor C COMMON /BASIC/NF,INASTX,NCHMX,J1,J2,J1P,J2P,ND1,NDP1,LL(2),NGAP COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /MQVC/MODE,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) c COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,NXLL,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,IPAR COMMON /NRBOO/KUTOO,KUTOOX,MAXLOO common /nrbone/ione,ione0 C C----------------------------------------------------------------------- C c if elastic is dropped here then it has an effect on inelastic c transitions between terms of same symmetry because they are mixed c cold ione0=0 !=0 retain elastic here c c if bcor then we have algebraic correlation, and we know how ordered c bcor=km*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD(NCOR) c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- C C INITIALIZATIONS C BKUTOO=KUTOOX.NE.0 C BPRNT0=JPRINT.NE.-3 C BTHRSH=LVMAX.GE.0 C C SCATTERING SYMMETRY RESTRICTIONS C IF(MXLAMX.EQ.1000)THEN !MAX EXCHANGE MULTIPOLE IF(MAXLX.GE.100)THEN MXLAMX=NXLL+3 !TWICE MAX ORB L+3 (was +1) ELSE C MXLAMX=(MAXLX+1)/2 MXLAMX=MAXLX-NXLL/2 ENDIF ENDIF C C IF(MAXLX.GE.100)MAXLX=2*MXLAMX !MAX L FOR EXCHANGE IF(MAXLX.GE.100)MAXLX=MXLAMX+NXLL/2 !MAX L FOR EXCHANGE IF(INAST0.LE.0.AND.MAXLX.LT.MAXLT+2)THEN MAXLX=MAX(MAXLX,QMCL/2-1) !NEED ALL CHANNELS TO SCALE DIRECT ENDIF NGAP=MAXLX !PASS THRU TO RESX1 C IF(MAXLOO.GE.100)MAXLOO=MAXLX C WRITE(6,1007) WRITE(6,1112)MAXLX IF(MXLAMX.NE.1000)WRITE(6,152)MXLAMX IF(BKUTOO)WRITE(6,153)MAXLOO C IF(INAST0.GT.0)THEN C WRITE(6,1113) DO I=1,INAST0 IS=LSPI(I)/10000 IP=LSPI(I)-IS*10000 IL=IP/10 IP=IP-IL*10 WRITE(6,1114)I,IS,IL,IP ENDDO MAXLT=-1 !FLAG FOR FUTURE C ELSE IF(IABS(MODE).GT.1)THEN C IF(BTHRSH)THEN C MAXL=LVMAX+QMCL/2 IF(MAXLT.EQ.1000)MAXLT=MAXL IF(MAXLT.GT.MAXL)THEN WRITE(6,1007) WRITE(6,1008)MAXL,LVMAX WRITE(6,1007) MAXLT=MAXL ELSEIF(MAXLT.LT.MAXL)THEN WRITE(6,1007) WRITE(6,1009)MAXLT,LVMAX,MAXL WRITE(6,1007) C MAXLT=MAXL !ALLOW USER TO RESTRICT... ENDIF C MINL=LVMIN-QMCL/2 MINL=MAX(0,MINL) IF(MINLT.GT.MINL)THEN WRITE(6,1007) WRITE(6,1010)MINLT,LVMIN,MINL WRITE(6,1007) c MINLT=MINL !ALLOW USER TO RESTRICT... ELSEIF(MINLT.LT.MINL)THEN WRITE(6,1007) WRITE(6,1011)MINL,LVMIN WRITE(6,1007) MINLT=MINL ENDIF C ELSE C IF(MAXLT.EQ.1000)MAXLT=30 IF(MAXLT.GT.100)THEN MAXLT=100 WRITE(0,*)'*** SR.ALGXLS: REDUCING MAXLT TO',MAXLT MINLT=MIN(MINLT,MAXLT) ENDIF C IF(MINLT.LT.0)MINLT=0 C ENDIF ENDIF C IF(MINSP.LT.1)MINSP=1 !2S+1 TOT I1=MOD(QMCS,2) I0=MOD(MINSP-1,2) IF(I0.EQ.I1)MINSP=MINSP+1 MAXSP=MIN(MAXSP,QMCS+2) C WRITE(6,1115)MINSP,MAXSP,MINLT,MAXLT C IF(IPAR.NE.2)WRITE(6,1119)IPAR IPAR=IABS(IPAR) IPAR=MOD(IPAR,3) !0-EVEN, 1-ODD, 2-BOTH IPART=MAX(1,IPAR) C ENDIF C WRITE(6,1007) C C SET-UP SCATTERING SYMMETRY LIST C IF(INAST0.GT.0)THEN C INAST=INAST0 INASTX=999 IFOUR=0 LFACT=100 C ELSE C INAST=0 INASTX=0 !999 for no use of symmetry,0 for use cpar inastx=999 !par IFOUR=(MAXSP-MINSP)/2 IF(MINSP.GT.1)IFOUR=IFOUR+1 IFOUR=IFOUR*IPART C IP0=MOD(IPAR,2) IP1=MIN(IPAR,1) FACTL=DBLE(LFACT)/1.D2 IL=MINLT C 54 DO IS=MINSP,MAXSP,2 DO IP=IP0,IP1 INAST=INAST+1 LX=INAST.LE.MAXSL IF(LX)LSPI(INAST)=10000*IS+10*IL+IP ENDDO ENDDO C if(lfact.gt.100)il0=il IF(IL.GT.MAX(MAXLX,15))IL=NINT(IL*FACTL) IL=IL+1 IF(IL.LE.MAXLT)GO TO 54 if(lfact.gt.100)then if(lrglam.gt.il0)lrglam=il0 !case factl "misses" maxlt=il0 endif C IF(INAST.GT.MAXSL)THEN WRITE(6,194)INAST WRITE(0,194)INAST GO TO 999 ENDIF C ENDIF C C SET-UP CHANNEL LIST BY GROUP C MXX=0 NNN=0 NCHTOT=0 NCHMX=0 INAST0=INAST !SINCE WILL REDUCE IF NO CHANNELS IX=0 IPAR4=0 ncorr=0 C DO I0=1,INAST0 C IX=IX+1 IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 C !ALIGN MTS=IS-1 MTL=IL+IL MTP=IP+IP C LUP=0 LLOW=999 NN=0 DO N=1,NSL0 IF(QSI(N)+1.ne.MTS.and.QSI(N)-1.ne.MTS)GO TO 60 if(il.gt.maxlx.and.qsi(n).gt.mts)go to 60 !nx LCON=MIN(QLI(N),LCONDW-1) LMIN=ABS(MTL-LCON) LMAX=MTL+LCON I1=MOD(LMAX,4) IF(MTP.NE.ABS(I1-QPI(N)))THEN LMAX=LMAX-2 LMIN=LMIN+2 ENDIF IF(LMAX.GE.LMIN)THEN NN=NN+1 LY=NN.LE.MXCHG IF(LY)THEN ITARG(NN,IX)=N LLCH(1,NN,IX)=LMIN LLCH(2,NN,IX)=LMAX ENDIF QSNX=QSI(N) LUP=MAX(LUP,LMAX) LLOW=MIN(LLOW,LMIN) ENDIF 60 ENDDO C C SINCE WE ARE KEYED ON SMALL L. (THIS IS "APPROXIMATE" FOR 2FS!) C c IF(BTHRSH.AND.(LVMAX.LT.LLOW/2.OR.LVMIN.GT.LUP/2))NN=0 !DROP c c Can't use if scaling non-exchange since indexing currently assumes c same S present for each Lp, i.e. we can use MAXST or IPAR (or MAXLT) c since the same selection is applied to ALL symmetries but cannot vary c selection between symmetries. Not a big saving since it likely only c affects a couple of symmetries on the final L. So, re-working the c NX indexing is not a high priority esp. since BTHRSH is ADAS-specific. C IF(NN.GT.0)THEN MXX=MAX(MXX,NN) NWT=IS if(il.gt.maxlx)nwt=-2*(qsnx+1) !nx C IF(BPRNT0)WRITE(6,1116)IX,NWT,IL,IP C NCHG(IX)=NN NADG(IX)=NNN-ncorr C NCHL=0 IF(LY)THEN DO N=1,NN NC=ITARG(N,IX) MC=NSL(NC) MCI=NGRPI(NC) L1=LLCH(1,N,IX) L2=LLCH(2,N,IX) LD=((L2-L1)/4+1) NCH=MC*LD DO L=L1,L2,4 DO M=1,MC J1=M+MCI NCHL=NCHL+1 IF(BPRNT0)WRITE(6,1117)NCHL,J1,L/2 c write(6,1118)nch,ii,qsi(ii)+1,qli(ii)/2,qpi(ii)/2,l/2 ENDDO ENDDO DO NP=1,N ND=ITARG(NP,IX) eqgrp=nc.eq.nd eqgrpl=eqgrpl0.and.eqgrp IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN IF(eqgrp)THEN LDP=(LD*(LD+1))/2 LD=1 NCH=MC ELSE L1P=LLCH(1,NP,IX) L2P=LLCH(2,NP,IX) LDP=((L2P-L1P)/4+1) ENDIF MCP=NSL(ND) NCHP=MCP*LDP NNN=NNN+NCH*NCHP if(bcorr)then nco=0 nce=0 c do li=l1,l2,4 c lf2=l2p c if(nc.eq.nd)then c lf2=li c l1p=llch(1,np,ix) c endif c do lf=l1p,lf2,4 mcip=ngrpi(nd) do m=1,mc j1=m+mci j=jndex(j1) do mp=1,mcp j1p=mp+mcip c if(j1p.gt.j1-ione0.and.li.eq.lf)go to 61 jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then nco=nco+1 !corr.-corr. if(j1.eq.j1p)nce=nce+1 endif enddo c 61 continue enddo c enddo c enddo ncorr=ncorr+nco*ld*ldp endif ENDIF ENDDO IF(eqgrpl.and.NMETAG(NC).LT.1)THEN LD=(L2-L1)/4+1 MM=MC+ione0 NNN=NNN-LD*(MM*(MM-1))/2 !FOR LI.EQ.LF if(bcorr)ncorr=ncorr-ld*(nco-nce)/2 !for li.eq.lf ENDIF ENDDO NCHMX=MAX(NCHMX,NCHL) NCHTOT=NCHTOT+NCHL ENDIF IF(.NOT.BPRNT0)WRITE(6,1120)IX,NWT,IL,IP,NCHL ELSE !QUIETLY DISCARD INAST=INAST-1 IF(IL.GT.MAXLX.AND.IS.GT.1)IPAR4=1 LHOLD=LSPI(IX) DO I=IX+1,INAST0 LSPI(I-1)=LSPI(I) ENDDO LSPI(INAST0)=LHOLD !NEED FOR IC IX=IX-1 ENDIF C IF(IL.LE.MAXLX)INASTX=MAX(INASTX,IX) C ENDDO C IF(MXX.GT.MXCHG)THEN WRITE(6,195)MXX WRITE(0,195)MXX GO TO 999 ENDIF C IADD=NNN-ncorr !assuming corr.-corr. omitted c c if(ncorr.gt.0)then c write(0,*)iadd,ncorr,iadd-ncorr c stop 'ncorr test' c endif C IF(MAXLT.LT.0)THEN !NO SCALING, EXCHANGE CAN BE OFF THOUGH INASTX=INAST ELSE INASTX=INASTX+2*(IFOUR-IPAR4) !FURTHER THAN XCHNG INASTX=MIN(INASTX,INAST) ENDIF C INASTX IS PASSED THRU TO SR.ALGXLS VIA COMMON/BASIC/.... C NAST=INAST C RETURN C 999 WRITE(6,190) NF=-1 !ABORT C RETURN C 152 FORMAT(/44X,' MAX EXCHANGE LAMDA (MXLAMX)=',I3) 153 FORMAT(/44X,' MAX 2-BODY NFS L (MAXLOO)=',I3) 190 FORMAT( ' SR.SYMLS: FAILURE - CASE SKIPPED') 194 FORMAT('***SR.SYMLS: TOO MANY SYMMETRIES, INCREASE MAXSL', X ' TO:',I4) 195 FORMAT('***SR.SYMLS: TOO MANY CHANNEL GROUPS, INCREASE', X ' MXCHG TO:',I4) 1007 FORMAT(//1X,136('-')//) 1008 FORMAT(/' NOTE: REDUCING MAXLT TO',I3,', THAT NEEDED BY LVMAX=' X,I3) 1009 FORMAT(/' ***WARNING: YOU HAVE SET MAXLT=',I3,', LESS THAN THAT' X,' FORMALLY NEEDED BY LVMAX=',I3/22X,'SET MAXLT=',I3 X,', TO SATISFY TRIANGLE RELATION') 1010 FORMAT(/' ***WARNING: YOU HAVE SET MINLT=',I3,', GREATER THAT' X,' FORMALLY NEEDED BY LVMIN=',I3/22X,'SET MINLT=',I3 X,', TO SATISFY TRIANGLE RELATION') 1011 FORMAT(/' NOTE: INCREASING MINLT TO',I3,', THAT NEEDED BY LVMIN=' X,I3) 1112 FORMAT(' *** PARTIAL WAVE SYMMETRY RESTRICTIONS:',5X,'MAXIMUM' X,' EXCHANGE L (MAXLX) =',I3) 1113 FORMAT(//' SY 2S+1 L (P-0/1 FOR EVEN/ODD)',5X, X'*** NO TOP-UP ***') 1114 FORMAT(1X,4I4) 1115 FORMAT(//' MINST=',I2,3X,'MAXST=',I2,5X,'MINLT=',I2,3X,'MAXLT=',I3 X) c 1118 format(7x,i8,i9,3i4,i10) 1119 format(/' PARITY IPAR=',i2) 1116 FORMAT(/' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3/ X 13X,'CH',8X,'T',3X,'SMALL L') 1117 FORMAT(7X,I8,I9,I10) 1120 FORMAT(' SY=',I3,5X,'(2S+1) L P =',I3,I4,I3,5X,'NCHT=',I5) C END C C ******************* C SUBROUTINE SYMLSJ C C----------------------------------------------------------------------- C C SR.SYMLSJ C DETERMINES THE LSJ SYMMETRIES AND CHANNEL LIST BASED-UPON THE USER C SPECIFIED MINJT, MAXJT. OR DIRECT JP INPUT, AND CHECKS CONSISTENCY C WITH ANY SUPPLIED LSP, MAXJFS. C C IT CALLS: C SR.NUMSYM C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BPRNT0,BTEST,LX,LY,BTHRSH x,eqgrp,eqgrpl,eqgrpl0,bcorr,becor,bcor,b2fs C COMMON /BASIC/NF,MXX,NCHMX,NGAP(9) COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /MQVC/MODD,KCUT,QMCL,QMCS,NEL(MAXGR,MAXCF) C COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /TERMS/KM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBCOR/EGAP(5),BECOR COMMON /NRBIAD/IADD,IADJ,IADJT COMMON /NRBDW/IDW X ,INAST0,MINSTB,MAXSTB,MINLTB,MAXLTB X ,INASTJ0,MINJTB,MAXJTB,MAXLX,MAXJFS X ,LFACT,JFACT,KUTSSX,LRGLAM COMMON /NRBDW2/LCONDW,MGP2(5),LCONDWJ,MTJ,LVMIN,LVMAX COMMON /NRBDW4/DSPECE(MAXTM),INDEX(MAXTM),JNDEX(MAXTM),NSPECE X ,NENERG COMMON /NRBDWJ/JSYMM(MXSYJ,MAXJG),NCHGJ(MAXJG),NADGJ(MAXJG) COMMON /NRBDWM/NMETA,NMETAJ,NMETAG(0:MAXSL),NMETGJ(MAXJG) COMMON /NRBDWX/LLCH(2,MXCHG,MAXSL),ITARG(MXCHG,MAXSL),NCHG(MAXSL) COMMON /NRBGRP/NGRPI(MAXSL),NADG(MAXSL) COMMON /NRBJ/JPI(MAXJG),INASTJ,MINJT,MAXJT COMMON /NRBLAM/MAXLAM,MXLAMX COMMON /NRBLS/LSPI(MAXSL),INAST,MINSP,MAXSP,MINLT,MAXLT,ipar common /nrbone/ione,ione0 C C----------------------------------------------------------------------- C c if elastic is dropped here then it has an effect on inelastic c transitions between terms of same symmetry because they are mixed c cold ione0=0 !=0 retain elastic here c c if bcor then we have algebraic correlation, and we know how ordered c bcor=km*kcut.ne.kcut*kcut c c if becor then we have correlation by energy, and we know not where, so c eqgrpl0=.not.becor !false for full li=lf mx c c if only algebraic then can reduce memory requirement NAD/J(NCOR/J) c bcorr=bcor.and..not.becor C C----------------------------------------------------------------------- C C INITIALIZATIONS C BPRNT0=JPRINT.NE.-3 BTEST=BPRNT0 !.TRUE. !DETAILED PRINTOUT C BTHRSH=LVMAX.GE.0 C C SCATTERING SYMMETRY RESTRICTIONS C MTEST=MOD(QMCS,2) WRITE(6,1111) WRITE(6,1112)MXLAMX C IF(INASTJ0.GT.0)THEN WRITE(6,1113) INASTJ=INASTJ0 IX=0 DO I0=1,INASTJ0 IX=IX+1 IJ=JPI(IX)/10 IF(IJ.LE.MAXJT)THEN !LEGACY OF MAXJFS, NOT ON MAXLT IP=JPI(IX)-IJ*10 WRITE(6,1114)IX,IJ,IP IF(MOD(IJ,2).EQ.MTEST)THEN WRITE(6,1120) WRITE(0,*)'***SR.SYMLSJ ERROR: ILLEGAL TOTAL 2J REQUESTED' GO TO 999 ENDIF ELSE !QUIETLY DISCARD INASTJ=INASTJ-1 jhold=jpi(ix) DO J=IX+1,INASTJ0 JPI(J-1)=JPI(J) ENDDO jpi(inastj0)=jhold IX=IX-1 ENDIF ENDDO MAXJT=-1 !FLAG FOR FUTURE ELSE IF(MAXJT.GT.200)MAXJT=60 IF(MINJT.LT.0)MINJT=0 IF(MOD(MINJT,2).EQ.MTEST)MINJT=MINJT+1 IF(MOD(MAXJT,2).EQ.MTEST)MAXJT=MAXJT-1 IF(MOD(MAXJFS,2).EQ.MTEST)MAXJFS=MAXJFS-1 IF(MAXJFS.GT.MAXJT)THEN WRITE(6,1111) WRITE(6,1110) MAXJFS=MAXJT ENDIF WRITE(6,1115)MINJT,MAXJT if(ipar.ne.2)write(6,1119)ipar ipar=iabs(ipar) ipar=mod(ipar,3) !0-even, 1-odd, 2-both ENDIF C WRITE(6,1111) C C SET-UP LSJ SCATTERING SYMMETRY LIST C IF(INASTJ0.LE.0)THEN INASTJ=0 IF(MINJT.GT.MAXJT)GO TO 57 C ip0=mod(ipar,2) ip1=min(ipar,1) FACTJ=DBLE(JFACT)/2.D2 IJ=MINJT C 54 DO IP=ip0,ip1 INASTJ=INASTJ+1 LX=INASTJ.LE.MAXJG IF(LX)JPI(INASTJ)=10*IJ+IP ENDDO C if(jfact.gt.200)ij0=ij IF(IJ.GT.MAX(MAXJFS,30))THEN IJ=NINT(IJ*FACTJ) IF(MOD(IJ,2).NE.MOD(MAXJT,2))IJ=IJ-1 ENDIF IJ=IJ+2 IF(IJ.LE.MAXJT)GO TO 54 if(jfact.gt.200)then if(lrglam.gt.ij0)lrglam=ij0 !case factj "misses" maxjt=ij0 endif C IF(INASTJ.GT.MAXJG)THEN WRITE(6,194)INASTJ WRITE(0,194)INASTJ GO TO 999 ENDIF ENDIF C 57 IF(INASTJ.EQ.0)THEN !NO J-SYMMS WRITE(0,*)'ATTENTION: NO J-SYMMETRIES FOR BP...' WRITE(6,1000) RETURN !<----------RETURN ENDIF C C IDENTIFY LSP SYMMETRIES WHICH GIVE RISE TO THE REQUESTED JPI ONES. C INASTJ IS THE ACTUAL NUMBER OF JP SYMMS TO BE USED. C MXX=0 NNN=0 NNN2=0 NCHTOT=0 NCHMX=0 INASTJ00=INASTJ !SINCE WILL REDUCE IF NO LS SYMMS KX=0 ncorr=0 ncorr2=0 JFAIL=0 C DO J0=1,INASTJ00 C KX=KX+1 IJ=JPI(KX)/10 IPJ=JPI(KX)-IJ*10 C NN=0 JCOUNT=0 CALL NUMSYM(IJ,IPJ,JCOUNT) !NO. OF LSP SYMMS EXPECTED IF(JCOUNT.EQ.0)GO TO 50 !NONE POSSIBLE C DO IX=1,INAST0 !inast0,1,-1 !MIRRORS ALGEB3 TERM ORDER if(nchg(ix).eq.0)go to 60 IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 C IF(IP.NE.IPJ)GO TO 60 C !ALIGN MTS=IS-1 MTL=IL+IL C MTP=IP+IP IF(IABS(MTL-MTS).GT.IJ.OR.(MTL+MTS).LT.IJ)GO TO 60 NN=NN+1 LY=NN.LE.MXSYJ IF(LY)THEN JSYMM(NN,KX)=IX ENDIF 60 ENDDO C IF(NN.LT.JCOUNT.AND..NOT.BTHRSH)THEN !ALLOW IF BTHRSH CALL NUMSYM(IJ,IPJ,JCOUNT) !PRINT MISSING SYMMS JFAIL=JFAIL+JCOUNT-NN ELSEIF(NN.GT.JCOUNT)THEN WRITE(6,*)'SR.SYMLSJ: DROPPING',NN-JCOUNT,'SPECIFIED SLP FOR' x ,'JP SYJ=',KX,':',IJ,IPJ c write(0,*)'sr.algxfs: something amiss with slp vs jp...' IF(LY.and.BTEST)THEN WRITE(6,*)'SYJ=',KX,':',IJ,IPJ DO N=1,NN IX=JSYMM(NN,KX) IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IP=IP-IL*10 nwt=is if(il.gt.maxlx)nwt=-2*is+2 WRITE(6,*)'SYM=',IX,':',nwt,IL,IP ENDDO ENDIF c GO TO 999 ENDIF C 50 IF(NN.GT.0)THEN MXX=MAX(MXX,NN) C IF(BPRNT0)WRITE(6,*)' ' IF(BTEST)WRITE(6,1116)KX,IJ,IPJ,NN C NCHGJ(KX)=NN NADGJ(KX)=NNN2-ncorr2 c write(0,*)'kx=',kx,' nadgj(kx)=',nadgj(kx) C IF(LY)THEN NCHJ=0 DO NX=1,NN IX=JSYMM(NX,KX) IS=LSPI(IX)/10000 IP=LSPI(IX)-IS*10000 IL=IP/10 IF(BPRNT0)THEN nwt=is if(il.gt.maxlx)nwt=-2*is+2 WRITE(6,1117)IX,nwt,IL,IPJ ENDIF NCN=NCHG(IX) m1=1 if(ij.gt.maxjfs)m1=nx DO MX=m1,NX JX=JSYMM(MX,KX) ISP=LSPI(JX)/10000 IPP=LSPI(JX)-ISP*10000 ILP=IPP/10 NCNP=NCHG(JX) c write(0,*)'start symljs: ',kx,nx,mx,nnn2-ncorr2 DO N=1,NCN NC=ITARG(N,IX) MC=NSL(NC) L1=LLCH(1,N,IX) L2=LLCH(2,N,IX) LD=((L2-L1)/4+1) NCH=MC*LD if(bcorr)mci=ngrpi(nc) if(ix.eq.jx)ncnp=n DO NP=1,ncnp ND=ITARG(NP,JX) eqgrp=ix.eq.jx.and.nc.eq.nd eqgrpl=eqgrpl0.and.eqgrp b2fs=ij.le.maxjfs X .and. (IS+ISP-2)*(IL+ILP).GT.0 x .and. iabs(NMETAG(NC))+iabs(NMETAG(ND)).lt.2 IF(NMETAG(NC)+NMETAG(ND).LT.2)THEN IF(eqgrp)THEN LDP=(LD*(LD+1))/2 LD=1 NCH=MC ELSE L1P=LLCH(1,NP,JX) L2P=LLCH(2,NP,JX) LDP=((L2P-L1P)/4+1) ENDIF MCP=NSL(ND) NCHP=MCP*LDP NADD=NCH*NCHP NNN=NNN+NADD if(b2fs)NNN2=NNN2+NADD c if(bcorr)then nco=0 nce=0 c do li=l1,l2,4 c lf2=l2p c if(eqgrp)then c lf2=li c l1p=llch(1,np,ix) c endif c do lf=l1p,lf2,4 mcip=ngrpi(nd) do m=1,mc j1=m+mci j=jndex(j1) do mp=1,mcp j1p=mp+mcip c if(ix.eq.jx.and.j1p.gt.j1-ione0.and.li.eq.lf)go to 61 jp=jndex(j1p) if(j.lt.0.and.jp.lt.0)then nco=nco+1 !corr.-corr. if(j1.eq.j1p)nce=nce+1 endif enddo c 61 continue enddo c enddo c enddo naddc=nco*ld*ldp ncorr=ncorr+naddc if(b2fs)ncorr2=ncorr2+naddc endif ENDIF ENDDO if(eqgrpl.and.nmetag(nc).lt.1)then LD=(L2-L1)/4+1 MM=MC+ione0 NADD=LD*(MM*(MM-1))/2 NNN=NNN-NADD !FOR LI.EQ.LF if(b2fs)NNN2=NNN2-NADD if(bcorr)then naddc=ld*(nco-nce)/2 ncorr=ncorr-naddc !for li.eq.lf if(b2fs)ncorr2=ncorr2-naddc endif endif if(ix.eq.jx)nchj=nchj+nch ENDDO c write(0,*)'end symlsj: ',kx,nx,mx,nnn2-ncorr2 ENDDO ENDDO c write(0,*)'end symlsj: ',kx,nnn2,-ncorr2 c write(0,*)'nchj=',nchj NCHMX=MAX(NCHJ,NCHMX) NCHTOT=NCHTOT+NCHJ ENDIF ELSE !QUIETLY DISCARD INASTJ=INASTJ-1 jhold=jpi(kx) DO J=KX+1,INASTJ00 JPI(J-1)=JPI(J) ENDDO jpi(inastj00)=jhold KX=KX-1 ENDIF C ENDDO C C NASTJ=INASTJ !RE-SET IADJT=NNN-ncorr !NOT USED CURRENTLY IADJ=NNN2-ncorr2 !ONLY USED BY 2-FS C IF(JFAIL.GT.0)THEN WRITE(6,1121)JFAIL GO TO 999 ENDIF C IF(MXX.GT.MXSYJ)THEN WRITE(6,195)MXX WRITE(0,195)MXX GO TO 999 ENDIF C RETURN C 999 WRITE(6,190) NF=-1 !<-------------------- ABNORMAL RETURN C RETURN C 190 FORMAT( ' SR.SYMLSJ: FAILURE - CASE SKIPPED') 194 FORMAT('***SR.SYMLSJ: TOO MANY SYMMETRIES, INCREASE MAXJG', X ' TO:',I4) 195 FORMAT('***SR.SYMLSJ: TOO MANY LSP SYMMS PER JP, INCREASE', X ' MXSYJ TO:',I4) 1000 FORMAT(/' *** NO J-SYMMETRIES FOUND FOR BP RUN, CHECK INPUT'/) 1110 FORMAT(/' NOTE: REDUCING MAXJFS TO MAXJT') 1111 FORMAT(//1X,136('-')//) 1112 FORMAT(' *** PARTIAL WAVE LEVEL SYMMETRY RESTRICTIONS:' X,5X,'MAX EXCHANGE LAMDA=',I3//) 1113 FORMAT(' SYJ 2J P') 1114 FORMAT(1X,3I4) 1115 FORMAT(' MINJT=',I2,3X,'MAXJT=',I3) 1116 FORMAT(' SYJ=',I3,4X,'2J P =',I3,I3,' FORMED BY SY=',I2, X ' (2S+1) L P ') 1117 FORMAT(39X,I3,7X,I3,I4,I3) 1119 format(/' PARITY IPAR=',i2) 1120 FORMAT('***SR.SYMLSJ ERROR: REQUESTED TOTAL 2J NOT POSSIBLE FOR ' X ,'THIS ATOMIC TARGET - ADD/SUBTRACT 1 TO/FROM 2J') 1121 FORMAT(//'*** SR.SYMLSJ ERROR: SPECIFY THE MISSING',I4 X ,' LSP SYMMETRIES LISTED ABOVE AND RE-RUN'//) C END C C ******************* C SUBROUTINE TARGET(TIME,TTIME) C C----------------------------------------------------------------------- C C SR.TARGET EVALUATES ENERGY LEVELS, RADIATIVE & AUTOIONIZATION RATES, C AND PHOTOIONIZATION CROSS SECTIONS FROM (QUASI)-BOUND STATE TARGETS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C UNIX-F77 CF77 REAL*4 TARRY,TIME,TTIME !F77 CF77 DIMENSION TARRY(2) !F77 C LOGICAL BLOOP,BNAME C COMMON /BASIC/NF,MGAP(11) COMMON /NRBLOO/BLOOP,LNEW,LCON,LSUM,LMAX COMMON /NRBNAM/BNAME,NF0 C C----------------------------------------------------------------------- C C INITIALIZE FOR ANY RYDBERG L-LOOP C BLOOP=.FALSE. LSUM=0 LNEW=-1 C C----------------------------------------------------------------------- C C SR.ALGEB EVALUATES ANGULAR ALGEBRA (LS AND IC). C 80 CALL ALGEB(IRET) C IF(NF.Lt.0.OR.IRET.EQ.1)GO TO 1999 C C----------------------------------------------------------------------- C C SR.MINIM SETS-UP & DIAGONALIZES H FOR LS & IC ENERGIES AND OPTIONALLY C EVALUATES RADIATIVE RATES (E_K & M_K), AUTOIONIZATION RATES, C PHOTOIONIZATION CROSS SECTIONS AND (INF &) FINITE ENERGY BORN C COLLISION STRENGTHS. C C if(nf.gt.0)CALL MINIM C C----------------------------------------------------------------------- C C UNIX-F77 CF77 DUM=DTIME(TARRY) !F77 CF77 TIME=TARRY(1) !F77 CF77 TIME=TIME/60.0 !F77 CF77 TTIME=TTIME+TIME !F77 C C UNIX-F95 CALL CPU_TIME(TTIME) !F95 TTIME=TTIME/60.0D0 !F95 TIME=TTIME-TIME !F95 C WRITE(6,999)TIME,TTIME 999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN',5X,'TOTAL CPU TIME=',F9.3 X,' MIN') C TIME=TTIME !F95 C C----------------------------------------------------------------------- C IF(NF0.GT.0.AND.(.NOT.BNAME.OR.BLOOP))GO TO 80 C 1999 CONTINUE C RETURN END C C ********************* C SUBROUTINE TFDAPO(Z,NION,MK,ADJUST,ADJUS1,ADJUS2,DX,NPOINT,NI,NTI X ,DXI,X,POT,DTOL,IEND,CRRCT1,CRRCT2) C C----------------------------------------------------------------------- C C SR. TFDAPO CALCULATES A THOMAS-FERMI-DIRAC-AMALDI POTENTIAL (EN PART C 2.2). QUANTITIES REQUIRED: DTOL, ALL ARGUMENTS EXCEPT DXI AND X; C Z=NUCLEAR CHARGE, NION=NUMBER OF ELECTRONS IN THE ION C ADJUST=SCALING PARAMETER (A VALUE GT 1.0 CONTRACTS THE EFFECTIVE C RADIAL SCALE, I.E. Z FALLS OFF MORE SLOWLY TOWARDS RESIDUAL ZN. C DXI(J),J=1,NI=STEP LENGTH IN THE J'TH INTERVAL -- STEP LENGTH IS C DOUBLED IN SUCCESSIVE INTERVALS, DX=DXI(1) IS INPUT-SO ARE THE C NUMBERS NTI(J) OF STEPS IN THE NI INTERVALS J; ANOTHER RESULT IS C X(I),I=1,NPOINT=RADIAL DISTANCE AT THE NPOINT RADIAL POINTS I; C NPOINT MUST BE EITHER EXACT OR LE 0 AND WILL BE EXACT ON RETURN. C IEND=INDEX OF THE LAST POINT FOR WHICH THE EFFECTIVE CHARGE HAS C NOT NECESSARILY THE RESIDUAL VALUE ZN; FOR X.GT.X(IEND) THE C POTENTIAL IS ZN/X=(Z-NION+1)/X. IF THE RANGE X(NPOINT) IS TOO C SMALL FOR THE EFFECTIVE CHARGE TO DROP TO ZN CONTROL IS RETURNED C WITH DX=2*DX -- WHILE DXI(1) CONTAINS THE ORIGINAL DX. C POT(I),I=1,NPOINT=VALUE OF THE POTENTIAL AT THE POINTS X(I). C POT(I) WAS STORED IN /COM1/- POT,DTOL,IEND NOW OUTPUT THROUGH C ARGUMENT LIST & THEN STORED IN /COM1/IN RADIAL FOR USE IN RADWAV. C DTOL, TYPICALLY 1.E-6, =ACCURACY; DTOL C MUST MATCH MACHINE PRECISION: A 24-BIT MANTISSA REQUIRES .GE.1.E-5 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C C PARAMETER (MXD14=100) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (DMONE=-1.0D0) PARAMETER (DHALF=DONE/DTWO) PARAMETER (D2THRD=DTWO/DTHREE) PARAMETER (D1M1=1.0D-1) PARAMETER (D1P2=1.0D2) PARAMETER (D1P10=1.0D10) PARAMETER (BB=.079157174720D0) PARAMETER (DMU0=.88534131027D0) PARAMETER (D1M2=1.0D-2) PARAMETER (TOLP=1.D-5) !SET POLARIZ=0 IF SMALLER THAN TOLP C DIMENSION POT(*),X(*),DXI(*),NTI(*) DIMENSION PAV(MAXB1),CAV(MAXB1),KHLP(MAXB1) C LOGICAL BOOL,BSTO C DIMENSION F(2),FE(2) C COMMON /BASIC/NF,MGAP(11) COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBBOX/RZERO,MXBOX COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBNF2/DUM1(MAXB1),DUM2(MAXB1),DUM3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) C COMMON /NRBUNI/IUNIT(MXD14),NUNIT C EQUIVALENCE (PAV(1),DUM1(1)),(CAV(1),DUM2(1)),(KHLP(1),DUM3(1)) C DATA DX0/DMONE/,NPOLD/0/,MHLP/-1/ C N=NION C DETERMINE ASYMPTOTIC CHARGE ZN=Z-N+1 C C SET UP THE X ARRAY: C DX=STEP LENGTH IN THE FIRST INTERVAL (I=1) C THE STEP LENGTH DOUBLES FROM ONE INTERVAL TO THE NEXT FOR USE IN S C IF !MAUTO! .LT.100, OTHERWISE STEP INCREASES BY FACTOR MAUTO/100 C IF(NINT(DMU0*DX/DX0).NE.1.OR.NPOINT.gt.NPOLD)THEN ISTEP=0 V0=DTWO IF(IABS(MAUTO).GE.100)THEN V0=MAUTO V0=V0/D1P2 IF(V0.LT.DZERO)V0=-V0 ENDIF C H=DX XB=DZERO DO J=1,NI DXI(J)=H II=NTI(J) DO I=1,II ISTEP=ISTEP+1 XB=XB+H X(ISTEP)=XB ENDDO H=V0*H ENDDO DX0=DX C IF(NPOINT.LE.0)NPOINT=ISTEP IF(ISTEP.NE.NPOINT)THEN WRITE(6,992) WRITE(0,*)'TFDAPO: NPOINT INCOMPATIBLE WITH NTI,NI' GO TO 999 ENDIF NPOLD=NPOINT ENDIF C IF(Z.EQ.DZERO)GO TO 300 !RETURN C TOLH=D1M2 C C GO READ EXTERNAL POTENTIAL (MAYBE) C IF(MHF*MK.GT.0)THEN C IF(MHLP.LT.0)THEN !CALCULATE C CALL POTIN(Z,NION,MK,NPOINT,X,POT,IEND,CAV,PAV,KHLP,MHLP) C IF(MHLP.EQ.0)THEN MHLP=-1 !RE-INITIALIZE GO TO 55 !TRY AND GENERATE INTERNALLY ENDIF C ELSE C C (RE-) INITIALIZE (SINCE THERE IS ONLY ONE POTENTIAL HERE) C DO I=1,NPOINT POT(I)=PAV(I) ENDDO C ENDIF C GO TO 300 !RETURN C ENDIF C C CHECK RZERO C 55 IF(RZERO.GT.DZERO.AND.MXBOX.EQ.0)THEN DO I=1,NPOINT IF(X(I).GT.RZERO)THEN MXBOX=I-MOD(I+1,2) !KEEP ODD GO TO 51 ENDIF ENDDO MXBOX=NPOINT C 51 NPOINT=0 NI0=NI DO I=1,NI0 NPOINT=NPOINT+NTI(I) NI=I IF(NPOINT.EQ.MXBOX)GO TO 53 IF(NPOINT.GT.MXBOX)THEN NPOINT=NPOINT-NTI(I) NTI(I)=MAX0(MXBOX-NPOINT,9) NPOINT=NPOINT+NTI(I) GO TO 53 ENDIF ENDDO 53 MXBOX=NPOINT ENDIF C C NEGATIVE SCALING PARAMETERS/LAMDAS FLAG SCREENED HYDROGENIC C IF(ADJUST.LT.DZERO)THEN A=-ADJUST*Z B=(DONE+ADJUST)*Z ZH=Z/DTWO IEND=1 DO J=1,NPOINT TT=EXP(-ZH*X(J)) !HISTORIC CUSP CONDITION AT ORIGIN TT=TT*B POT(J)=(A+TT)/X(J) IF(ABS(TT/A).GT.TOLH)IEND=J ENDDO IF(IEND.LT.NPOINT)GO TO 300 !RETURN DX=DX+DX TT=TT/X(IEND) WRITE(6,997) ADJUST,X(IEND),POT(IEND),TT GO TO 300 !RETURN ENDIF C C IF ONLY ONE ELECTRON IS PRESENT THE POTENTIAL IS PURELY COULOMBIC C I=1 IEND=1 IF(N.EQ.1)GO TO 194 C C *** NON-HYDROGENIC C DMUE=((N/(N-DONE))**2/Z)**(DONE/DTHREE)*DMU0*ADJUST C C WE SHALL TRANSFORM X OF EN 2.20 TO Y WITH Y*Y=X C Y1=DX/(DTWO*DTWO) YY1=SQRT(Y1/DMUE) IF(YY1.GT.D1M2)YY1=D1M2 Y1=YY1*YY1*DMUE IEND=0 DLOW=DZERO YLOW=DZERO ILOW=1 ISTEP=1 m0=max(mstep-10,2) C C TRY THE INTEGRATION FROM THE END OF EACH INTERVAL UNTIL THE C FUNCTION REACHES A VALUE GT 1 AT Y.EQ.0. C DO 21 I=1,NI C II=IEND+1 NT0=NTI(I) IF(I.EQ.NI)NT0=min(nt0,m0*NTI(I-1)) IEND=IEND+NT0 IF(IEND.GT.NPOINT.and.npoint.eq.maxb1)THEN WRITE(6,993)IEND,NPOINT WRITE(0,*)'*** DIMENSION MAXB1 EXCEEDED IN SR.TFDAPO?' GO TO 999 ENDIF C C FILL POT(I) TEMPORARILY WITH Y(I) CORRESPONDING TO X(I) C DO J=II,IEND POT(J)=SQRT(X(J)/DMUE) ENDDO J=8 C C IN THE FIRST INTERVAL THE INTEGRATION IS DONE FROM A SMALL C DISTANCE TO ASSURE THAT THE FIRST FUNCTION VALUE AT Y.EQ.0 IS LT.1 C IF(I.EQ.1)GO TO 13 C 33 ISTEP=7 IF(I.EQ.NI)GO TO 11 IF(I.LE.3)GO TO 21 IF(ZN.LT.(DTWO+D1M1))GO TO 11 IF(MOD(I,2).NE.0)GO TO 21 11 J=IEND C 12 ISTEP=ISTEP-1 IF(ISTEP.EQ.1)GO TO 13 IF(POT(J)-POT(J-ISTEP).GT.DHALF)GO TO 12 !REDUCE INTGRTN INTERVL C 13 IHIGH=J YHIGH=POT(J) Y0=YHIGH C F(1)=BB*Y0*Y0*DMUE/Z !CALCULATE THE FUNCTION AT X0 C F(2)=DTWO*(F(1)-ZN/Z)/Y0 !CALCULATE THE FIRST DERIVATIVE AT X0 C 20 Y0=POT(J) J=J-ISTEP BOOL=J.GT.0 H=YY1-Y0 IF(BOOL) H=POT(J)-Y0 C CALL RK1ST(Y0,F,H,2,YY0,FE) !INTEGRATE 1 STEP C F(1)=FE(1) IF(FE(1).GT.D1P10)THEN J=IHIGH-NT0/10-1 GO TO 13 ENDIF F(2)=FE(2) IF(BOOL)GO TO 20 C HIGH=FE(1)+( SQRT(FE(1))*YY1)**3*D2THRD-FE(2)*(YY1/DTWO+YY1**4) IF(HIGH.GT.DONE)GO TO 22 IF(I.NE.NI)GO TO 32 C IF(IEND.LT.(II+17))GO TO 32 !CUT FINAL INTERVAL IF TOO LONG WRITE(6,994)IEND,HIGH IEND=(II-1+IEND)/2 WRITE(6,995)I, II,IEND GO TO 33 C 32 YLOW=YHIGH ILOW=IHIGH DLOW=HIGH C 21 CONTINUE C C END INTERVAL LOOP C DX=DX+DX WRITE(6,996) ADJUST,X(IEND),FE(1) GO TO 300 !RETURN C C FIND AN IMPROVED APPROXIMATION TO Y0 C 22 Y0=YLOW+(DONE-DLOW)*(YHIGH-YLOW)/(HIGH-DLOW) YHIGH=YHIGH+DTHREE*DTOL YLOW=YLOW-DTHREE*DTOL Y0=(Y0+(YHIGH+YLOW)/DTWO)/DTWO C 23 DO J=ILOW,IHIGH IF(POT(J).GT.Y0)THEN IEND=J-1 GO TO 25 ENDIF ENDDO C 25 J=IEND C C BOUNDARY CONDITION C F(1)=BB*Y0*Y0*DMUE/Z F(2)=DTWO*(F(1)-ZN/Z)/Y0 C YY0=Y0 26 J=J-ISTEP BOOL=(J.GT.0) H=YY1-YY0 IF(BOOL)H=POT(J)-YY0 C CALL RK1ST(YY0,F,H,2,YL,FE) C F(1)=FE(1) F(2)=FE(2) IF(.NOT.BOOL)GO TO 27 YY0=POT(J) GO TO 26 C C EXPAND AT YY1 IN A TAYLOR SERIES TO CALCULATE FE AT Y.EQ.0. C 27 FE(1)=FE(1)+( SQRT(FE(1))*YY1)**3*D2THRD-FE(2)*(YY1/DTWO+YY1**4) TOL1=FE(1)-DONE IF(YHIGH-YLOW.LT.YHIGH*DTOL/DTWO)THEN IF(TOL1.LT.DZERO)YHIGH=YHIGH-TOL1 IF(TOL1.GT.DZERO)YLOW=YLOW-TOL1 ENDIF C ISTEP=1 IF(ABS(FE(1)-DONE).GT.D1M1)ISTEP=2 YL=(Y0*(DLOW-DONE)-YLOW*(FE(1)-DONE))/(DLOW-FE(1)) YH=(Y0*(HIGH-DONE)-YHIGH*(FE(1)-DONE))/(HIGH-FE(1)) IF(FE(1).LT.DONE)THEN YLOW=Y0 DLOW=FE(1) ILOW=IEND ELSE YHIGH=Y0 HIGH=FE(1) IHIGH=IEND+1 ENDIF C Y0=(YL+YH)/DTWO IF(Y0.LT.YLOW.OR.Y0.GE.YHIGH) Y0=(YLOW+YHIGH)/DTWO IF(ABS(FE(1)-DONE).GT.DTWO*DTOL)GO TO 23 C C FIND THE FINAL VALUE FOR Y0 C 70 RY0=Y0*Y0*DMUE V0=ZN/RY0-BB DO I=1,NPOINT IF(X(I).GT.RY0)THEN IEND=I-1 GO TO 90 ENDIF ENDDO WRITE(6,993)NPOINT,IEND WRITE(0,*)'*** DIMENSION MAXB1 EXCEEDED IN SR.TFDAPO?' GO TO 999 C 90 FE(1)=BB*Y0*Y0*DMUE/Z FE(2)=DTWO*(FE(1)-ZN/Z)/Y0 YY1=Y0 I=IEND 100 IF(I.EQ.0)THEN YY0=YY1 YY1=SQRT(Y1/DMUE) ELSE XB=X(I) YY0=YY1 YY1=SQRT(XB/DMUE) ENDIF F(1)=FE(1) F(2)=FE(2) H=YY1-YY0 C C INTEGRATE FROM YY0 TO YY0+H C CALL RK1ST(YY0,F,H,2,TOL1,FE) C IF(I.NE.0)THEN POT(I)=FE(1)*Z/XB+V0 I=I-1 GO TO 100 ENDIF C C EXTRAPOLATE TO X=0 C FE(1)=FE(1)+(SQRT(FE(1))*YY1)**3*D2THRD-FE(2)*(YY1/DTWO+YY1**4) TOL1=FE(1)-DONE IF(YHIGH-YLOW.LT.YHIGH*DTOL/DFIVE)THEN IF(TOL1.GT.DZERO)YLOW=YLOW-TOL1 IF(TOL1.LT.DZERO)YHIGH=YHIGH-TOL1 ENDIF YL=(Y0*(DLOW-DONE)-YLOW*(FE(1)-DONE))/(DLOW-FE(1)) YH=(Y0*(HIGH-DONE)-YHIGH*(FE(1)-DONE))/(HIGH-FE(1)) IF(FE(1).GT.DONE)THEN YHIGH=Y0 HIGH=FE(1) ELSE YLOW=Y0 DLOW=FE(1) ENDIF Y0=(YL+YH)/DTWO IF(Y0.LE.YLOW.OR.Y0.GE.YHIGH)Y0=(YLOW+YHIGH)/DTWO C C IF THE APPROXIMATION IS NOT GOOD ENOUGH REPEAT THE PROCESS C IF(ABS(TOL1).GE.DTOL)GO TO 70 I=IEND+1 C C FILL THE REMAINING POTENTIAL AS A COULOMB POTENTIAL C 194 DO J=I,NPOINT POT(J)=ZN/X(J) ENDDO c c do j=1,i c write(65,*)x(j),pot(j),x(j)*pot(j) c enddo C C OPTIONALLY ADD-IN DIPOLE AND QUADRUPOLE POLARIZATION AS A PERTURBATION C IF(ABS(ADJUS1-DONE).GT.TOLP.OR.ABS(ADJUS2-DONE).GT.TOLP) X CALL CORTFD(X,POT,IEND,ADJUS1,ADJUS2,CRRCT1,CRRCT2) C C 300 CONTINUE C RETURN C 999 NF=-1 GO TO 300 C 996 FORMAT( ' SR.TFDAPO (ADJUST,X(IEND),FE(1)) =',3F10.5/ X' RETURN WITH INITIAL STEP LENGTH DOUBLED') 995 FORMAT(3I5) 994 FORMAT(I15,1PE12.3) 993 FORMAT(/' SR.TFDAPO: IEND.GT.NPOINT, TRY INCREASING MAXB1:',2I6) 992 FORMAT( ' SR.TFDAPO: NPOINT INCOMPATIBLE WITH NTI,NI') 997 FORMAT( ' SR.TFDAPO: (ADJUST,X(IEND),COUL-POT(IEND),NON-COUL) =', X4F10.5/ ' RETURN WITH INITIAL STEP LENGTH DOUBLED') COLD 990 FORMAT(E14.7) C END C C ******************* C REAL*8 FUNCTION TLAM(LAM,K1,K2,K3,K4) C C----------------------------------------------------------------------- C C FN.TLAM EVALUATES THE T-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXPS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBNF2/D1(MAXB1),D2(MAXB1),D3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C DO I=1,MAXPS D1(I)=DPNL(I,K3)/DX(I) ENDDO C CALL DIFF(D1,D2,MNE,DHNS,MJH) C DO I=1,MAXPS D1(I)=D2(I)*DPNL(I,K1)*DX(I) ENDDO M=QL(K1)/2+QL(K3)/2+1 IF(QL(K3).EQ.0)M=M+1 C IF(BREL)THEN !SMALL R CORRECTION DE1=DEY(K1)-DUY(K1,K1) DE3=DEY(K3)-DUY(K3,K3) DEL=DE1-DE3 ! A.U. DZ=NZION T=C4*DTWO IF(BREL2)THEN DO I=1,MAXPS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD3=DONE+T*(DE3+POT(I,1)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ ENDDO ELSE dd=rnorm(k1)*rnorm(k3) DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) c dd1=done+t*(de1+dz/dx(i)) c dd3=done+t*(de3+dz/dx(i)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)*dd/DSQ ENDDO ENDIF CALL YLAMKR(LAM,M,DEL,D1,D2,DD1,DD2,MNE,DHNS,MJH,1000) ELSE CALL YLAMK(LAM,M,D1,D2,DD1,DD2,MNE,DHNS,MJH,0) ENDIF C DO I=1,MAXPS D1(I)=DPNL(I,K4)/DX(I) ENDDO C CALL DIFF(D1,D3,MNE,DHNS,MJH) C DO I=1,MAXPS D1(I)=D2(I)*D3(I)*DX(I)*DPNL(I,K2) ENDDO C IF(BREL)THEN !SMALL R CORRECTION DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DEL=DE2-DE4 ! A.U. IF(BREL2)THEN DO I=1,MAXPS DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) C DD2=DONE+T*(DE2+POT(I,1)) C DD4=DONE+T*(DE4+POT(I,1)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ ENDDO ELSE dd=rnorm(k2)*rnorm(k4) DO I=1,MAXPS DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) c dd2=done+t*(de2+dz/dx(i)) c dd4=done+t*(de4+dz/dx(i)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D1(I)=D1(I)*dd/DSQ ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,D1,TT,MNE,DHNS,MJH,MAXPS) C TP=2*LAM+1 TLAM=DALF*TT/TP C C WRITE(6,100) K1, K2, K3, K4, 2*LAM, TLAM C100 FORMAT(8X,2(I5,I4),I6,F14.7,' =TLAM') C RETURN END C C ******************* C SUBROUTINE TOP1(NZA,LITLAM,EI,EJ,SS,OMT) C C----------------------------------------------------------------------- C C SR.TOP1 CALCULATES DIPOLE TOP-UP USING BURGESS (1974) FORMULA WITH C COULOMB-BETHE PARTIAL COLLISION STRENGTHS C C IT CALLS C FN.DIP (IONS C FN.DIP0 (NEUTRALS) C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (D16O3=16.0D0/3.0D0) C PARAMETER (TOLE=1.D-10) PARAMETER (DEPS=1.D-4) C DATA IPRTOP/0/ C C IF(SS.LT.DZERO)THEN !DIPOLE C COEF=-D16O3*SS*LITLAM DELE=MAX(EI-EJ,TOLE) C IF(NZA.GT.0)THEN !ION C TZLMSQ=DONE/(LITLAM*LITLAM) C IFAIL=IPRTOP FI=FDIP(EI,LITLAM,EJ,LITLAM-1,IFAIL) C IF(IFAIL.NE.0.AND.IPRTOP.EQ.2) X WRITE(6,7205)IFAIL,EI,LITLAM,EJ,LITLAM-1 C IFAIL=IPRTOP FJ=FDIP(EI,LITLAM-1,EJ,LITLAM,IFAIL) C IF(IFAIL.NE.0.AND.IPRTOP.EQ.2) X WRITE(6,7205)IFAIL,EI,LITLAM,EJ,LITLAM-1 ELSE !NEUTRAL C TZLMSQ=DZERO C IFAIL=IPRTOP FI=FDIP0(EI,LITLAM,EJ,LITLAM-1,DEPS,IFAIL) C IF(IFAIL.NE.0.AND.IPRTOP.EQ.2) X WRITE(6,7205)IFAIL,EI,LITLAM,EJ,LITLAM-1 C IFAIL=IPRTOP FJ=FDIP0(EI,LITLAM-1,EJ,LITLAM,DEPS,IFAIL) C IF(IFAIL.NE.0.AND.IPRTOP.EQ.2) X WRITE(6,7205)IFAIL,EI,LITLAM,EJ,LITLAM-1 C ENDIF C OMI=COEF*FI*FI OMJ=COEF*FJ*FJ OMT=(TZLMSQ+EJ)*OMI-(TZLMSQ+EI)*OMJ OMT=OMT/DELE C ELSE OMT=DZERO ENDIF C RETURN C 7205 FORMAT('SR.TOP1: FDIP FAILURE, IFAIL=',I2,' FOR E,L=' X ,2(1PE13.5,I3)) C END C C ******************* C SUBROUTINE TOP2(LITLAM,LRGLAM,EI,EJ,OMPW) C C----------------------------------------------------------------------- C C SR.TOP2 CALCULATES NON-DIPOLE (ALLOWED) TOP-UP USING GEOMETRIC C SERIES, GOING OVER TO DEGENERATE ENERGY LIMITING CASE. C SEE BURGESS, HUMMER & TULLY (1970) FOR BACKGROUND DETAILS. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C DATA ITOP/-2/,IPRTOP/0/ !ITOP=STGICF DEFAULT C IF(OMPW.LT.DZERO)THEN OMPW=-OMPW IPRTOP=3 ENDIF IF(LITLAM.GT.1)THEN !NON-DIPOLE ALLOWED C TLTOP=LRGLAM C IF(EI.EQ.DZERO)THEN AQ=DONE ELSE AQ=EJ/EI ENDIF C IF(ITOP.EQ.-1)THEN C C INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN C L.LT.2*EJ/(EI-EJ), AS PER STGF DEFAULT C O1=DONE+TLTOP/(LITLAM-DONE) O1=O1/DTWO C IF(AQ.GT.0.99D0)THEN !CATCH EI=EJ OMPW=OMPW*O1 IF(IPRTOP.EQ.3)WRITE(6,803)AQ,O1 ELSE O2=DONE/(DONE-AQ) BQ=AQ*O2 IF(TLTOP.GT.DTWO*BQ)THEN OMPW=OMPW*O2 IF(IPRTOP.EQ.3)WRITE(6,804)BQ,O2 ELSE T=TLTOP/(BQ*DTWO) O3=O2*T+O1*(DONE-T) OMPW=OMPW*O3 IF(IPRTOP.EQ.3)WRITE(6,802)AQ,BQ,O1,O2,O3 ENDIF ENDIF C ELSE C C INTERPOLATE BETWEEN DEGENERATE AND NON-DEGENERATE LIMITS WHEN C ENERGY-RATIO EXCEEDS J-RATIO, AS PER STGICF DEFAULT C BQ=TLTOP/(TLTOP+1) BQ=BQ**(2*LITLAM-1) C IF(AQ.LT.BQ)THEN O1=DONE/(DONE-AQ) OMPW=OMPW*O1 IF(IPRTOP.EQ.3)WRITE(6,803)AQ,O1 ELSE O2=DONE+TLTOP/(LITLAM-DONE) O2=O2/DTWO IF(AQ.LT.DONE)THEN O1=DONE/(DONE-AQ) O3=O1*((DONE-AQ)/(DONE-BQ))**2 X +O2*(AQ-BQ)*(DTWO-AQ-BQ)/(DONE-BQ)**2 ELSE O3=O2 ENDIF OMPW=OMPW*O3 IF(IPRTOP.EQ.3)WRITE(6,802)AQ,BQ,O1,O2,O3 ENDIF ENDIF C ENDIF C RETURN C 802 FORMAT(18X,5F10.3) 803 FORMAT(18X,F10.3,10X,F10.3) 804 FORMAT(18X,10X,F10.3,10X,F10.3) C END C C ******************* C REAL*8 FUNCTION TQDT(QD,NZ0,NE,N,L) C C----------------------------------------------------------------------- C C FN.TQDT EVALUATES A ONE-ELECTRON ENERGY WITH NON-ZERO QUANTUM DEFECT C C : QD0, UNIVERSAL QUANTUM DEFECT GIVEN BY C QD0*(NE**1.67-1)/(Z0**.67*Z**.33*(1+L**3)) C CURRENT VALUE IN FUNCTION QDT IS QD0=0.182 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (DTHIRD=DONE/DTHREE) PARAMETER (D2THRD=DTWO/DTHREE) PARAMETER (D5THRD=DFIVE/DTHREE) PARAMETER (QD0=0.182D0) C IF(N.LE.0)THEN QD=DZERO TQDT=DZERO RETURN ENDIF C TZ0=NZ0 TZ=NZ0-NE+1 IF(L.LT.0.OR.NE.LE.1)THEN QD=DZERO ELSE TL=L**3+1 TE=NE QD=QD0*(TE**D5THRD-DONE)/(TZ0**D2THRD*TZ**DTHIRD*TL) ENDIF C TN=N TN=TN-QD TQDT=-(TZ/TN)**2 C RETURN END C C ******************* C REAL*8 FUNCTION ULAM(LAM,K1,K2,K3,K4) C C----------------------------------------------------------------------- C C FN.ULAM EVALUATES THE U-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXPS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBNF2/D1(MAXB1),D2(MAXB1),D3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C DO I=1,MAXPS D1(I)=DPNL(I,K1)*DPNL(I,K3)/DX(I) D2(I)=DPNL(I,K4)/DX(I) ENDDO C CALL DIFF(D2,D3,MNE,DHNS,MJH) C M=QL(K1)/2+QL(K3)/2+1 C IF(BREL)THEN !SMALL R CORRECTION DE1=DEY(K1)-DUY(K1,K1) DE3=DEY(K3)-DUY(K3,K3) DEL=DE1-DE3 ! A.U. DZ=NZION T=C4*DTWO IF(BREL2)THEN DO I=1,MAXPS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD3=DONE+T*(DE3+POT(I,1)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ ENDDO ELSE dd=rnorm(k1)*rnorm(k3) DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) c dd1=done+t*(de1+dz/dx(i)) c dd3=done+t*(de3+dz/dx(i)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)*dd/DSQ ENDDO ENDIF CALL YLAMKR(LAM,M,DEL,D1,D2,DD1,DD2,MNE,DHNS,MJH,1) ELSE CALL YLAMK(LAM,M,D1,D2,DD1,DD2,MNE,DHNS,MJH,1) ENDIF C DO I=1,MAXPS D2(I)=D2(I)*D3(I)*DPNL(I,K2)*DX(I) ENDDO C IF(BREL)THEN !SMALL R CORRECTION DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DEL=DE2-DE4 ! A.U. IF(BREL2)THEN DO I=1,MAXPS DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) C DD2=DONE+T*(DE2+POT(I,1)) C DD4=DONE+T*(DE4+POT(I,1)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D2(I)=D2(I)/DSQ ENDDO ELSE dd=rnorm(k2)*rnorm(k4) DO I=1,MAXPS DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) c dd2=done+t*(de2+dz/dx(i)) c dd4=done+t*(de4+dz/dx(i)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D2(I)=D2(I)*dd/DSQ ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,D2,TT,MNE,DHNS,MJH,MAXPS) C TP=LAM+2 U=-TP*TT C IF(LAM.NE.1)THEN DO I=1,MAXPS D2(I)=D3(I)*DPNL(I,K2)*DX(I) ENDDO M=1+QL(K2)/2+QL(K4)/2 IF(QL(K4).EQ.0)M=M+1 C IF(BREL)THEN !SMALL R CORRECTION DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DEL=DE2-DE4 ! A.U. IF(BREL2)THEN DO I=1,MAXPS DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) C DD2=DONE+T*(DE2+POT(I,1)) C DD4=DONE+T*(DE4+POT(I,1)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D2(I)=D2(I)/DSQ ENDDO ELSE dd=rnorm(k2)*rnorm(k4) DO I=1,MAXPS DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) c dd2=done+t*(de2+dz/dx(i)) c dd4=done+t*(de4+dz/dx(i)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D2(I)=D2(I)*dd/DSQ ENDDO ENDIF CALL YLAMKR(LAM,M,DEL,D2,D3,DD1,DD2,MNE,DHNS,MJH,1) ELSE CALL YLAMK(LAM,M,D2,D3,DD1,DD2,MNE,DHNS,MJH,1) ENDIF C DO I=1,MAXPS D2(I)=D1(I)*D3(I) ENDDO C CALL WEDDLE(DZERO,D2,TT,MNE,DHNS,MJH,MAXPS) C TP=LAM-1 U=U+TP*TT ENDIF C TP=2*(2*LAM+1) ULAM=DALF*U/TP C C WRITE(6,100) K1, K2, K3, K4, 2*LAM, ULAM C100 FORMAT(8X,2(I5,I4),I6,F14.7,' =ULAM') C RETURN END C C ******************* C SUBROUTINE VA04A(X,E,N,NL,F,ESCALE,IPRINT,ICON,MAXIT) C C----------------------------------------------------------------------- C C SR.VA04A HAS BEEN WRITTEN BY M.J.D.POWELL, C SEE REF. M.J.D. POWELL, COMP.J.7(1965)303-7, C AND MODIFIED (BY WE) SO AS TO ACCEPT A RETURN VALUE NN=0 AFTER C CALL CALCFX(NN,X,F) AS A COMMAND TO QUIT WITHOUT FINISHING. C SR.CALCFX SUPPLIES THE VARIATIONAL FUNCTIONAL F. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) C INCLUDE './PARAM' C PARAMETER (MXD29=MXVAR*(MXVAR+3)) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFIVE=5.0D0) PARAMETER (DTEN=10.0D0) PARAMETER (DTWENT=20.0D0) PARAMETER (DHALF=0.5D0) PARAMETER (DPT1=0.1D0) PARAMETER (DPT4=0.4D0) PARAMETER (DPT03=0.03D0) PARAMETER (DPT05=0.05D0) C DIMENSION X(MXVAR),E(MXVAR), W(MXD29) C FHOLD=DZERO DDMAG=DPT1*ESCALE SCER=DPT05/ESCALE NFCC=1 NN=N J=NN+1 JJ=J*NN JJJ=JJ+NN DO K=J,JJ W(K)=DZERO ENDDO ISGRAD=0 ITERC=0 IND=0 INN=0 K=0 DO I=1,NN K=K+J W(K)=ABS(E(I)) W(I)=ESCALE ENDDO C CALL CALCFX(NL,X,F) C FKEEP=ABS(F)+ABS(F) 5 ITONE=1 ITERC=ITERC+1 FP=F SUMM=DZERO IXP=JJ DO I=1,N IXP=IXP+1 W(IXP)=X(I) ENDDO C IF(NN.EQ.0)GO TO 77 C IDIRN=N+1 ILINE=1 7 DMAX=W(ILINE) DACC=DMAX*SCER D=DPT1*DMAX IF(DDMAG.LT.D)D=DDMAG DDMAX=DTWENT*DACC IF(DDMAX.GT.D)D=DDMAX DDMAX=DTEN*D C IF(ITONE.LT.0)GO TO 71 C DL=DZERO DA=DL FA=F FPREV=F IS=5 C 8 DD=D-DL DL=D 58 K=IDIRN DO I=1,N X(I)=X(I)+DD*W(K) K=K+1 ENDDO C CALL CALCFX(NL,X,F) C IF(NN.EQ.0) GO TO 77 C NFCC=NFCC+1 C C GO TO (10,11,12,13,14,96),IS C IF(IS.EQ.1)THEN GO TO 10 ELSEIF(IS.EQ.2)THEN GO TO 11 ELSEIF(IS.EQ.3)THEN GO TO 12 ELSEIF(IS.EQ.4)THEN GO TO 13 ELSEIF(IS.EQ.5)THEN GO TO 14 ELSEIF(IS.EQ.6)THEN GO TO 96 ELSE STOP 'SR.VA04A: WE SHOULD NEVER GET HERE!' ENDIF C 14 IF(F.LT.FA)GO TO 15 IF(F.GT.FA)GO TO 24 IF(ABS(D).LT.DMAX)THEN D=D+D GO TO 8 ELSE WRITE(6,1000) GO TO 20 ENDIF C 15 FB=F DB=D GO TO 21 C 24 FB=FA DB=DA FA=F DA=D 21 IF(ISGRAD.NE.0)GO TO 83 23 D=DB+DB-DA IS=1 GO TO 8 C 83 D=DHALF*(DA+DB-(FA-FB)/(DA-DB)) IS=4 IF((DA-D)*(D-DB).GE.DZERO)GO TO 8 25 IS=1 IF(ABS(D-DB).LE.DDMAX)GO TO 8 26 IS=1 D=DB+SIGN(DDMAX,DB-DA) DDMAX=DDMAX+DDMAX DDMAG=DDMAG+DDMAG IF(DDMAX.LE.DMAX)GO TO 8 DDMAX=DMAX GO TO 8 C 13 IF(F.GE.FA)GO TO 23 28 FC=FB DC=DB 29 FB=F DB=D GO TO 30 C 12 IF(F.LE.FB)GO TO 28 FA=F DA=D GO TO 30 C 11 IF(F.GE.FB)GO TO 10 FA=FB DA=DB GO TO 29 C 71 DL=DONE DDMAX=DFIVE FA=FP DA=-DONE FB=FHOLD DB=DZERO D=DONE 10 FC=F DC=D 30 A=(DB-DC)*(FA-FC) B=(DC-DA)*(FB-FC) IF((A+B)*(DA-DC).GT.DZERO)GO TO 34 FA=FB DA=DB FB=FC DB=DC GO TO 26 C 34 D=DHALF*(A*(DB+DC)+B*(DA+DC))/(A+B) DI=DB FI=FB IF(FB.LE.FC)GO TO 44 DI=DC FI=FC 44 IF(ITONE.LT.0)GO TO 85 IF(ABS(D-DI)-DACC.LE.DZERO)GO TO 41 IF(ABS(D-DI)-DPT03*ABS(D).LE.DZERO)GO TO 41 GO TO 45 C 85 ITONE=0 45 IF((DA-DC)*(DC-D).LT.DZERO)GO TO 47 FA=FB DA=DB FB=FC DB=DC GO TO 25 C 47 IS=2 IF((DB-D)*(D-DC).GE.DZERO)GO TO 8 IS=3 GO TO 8 C 41 F=FI D=DI-DL DD=SQRT((DC-DB)*(DC-DA)*(DA-DB)/(A+B)) DO I=1,N X(I)=X(I)+D*W(IDIRN) W(IDIRN)=DD*W(IDIRN) IDIRN=IDIRN+1 ENDDO W(ILINE)=W(ILINE)/DD ILINE=ILINE+1 C IF(IPRINT.NE.1)GO TO 51 50 WRITE(6,1052)ITERC,NFCC,F,(X(I),I=1,N) IF(IPRINT.GT.1)GO TO 53 C 51 IF(ITONE.LE.0)GO TO 38 C IF(FPREV-F-SUMM.LT.DZERO)GO TO 94 SUMM=FPREV-F JIL=ILINE 94 IF(IDIRN.LE.JJ)GO TO 7 IF(IND.NE.0)GO TO 72 92 FHOLD=F IS=6 IXP=JJ DO I=1,N IXP=IXP+1 W(IXP)=X(I)-W(IXP) ENDDO DD=DONE GO TO 58 C 96 IF(IND.EQ.0)THEN IF(FP.LE.F)GO TO 37 D=DTWO*(FP+F-DTWO*FHOLD)/(FP-F)**2 IF(D*(FP-FHOLD-SUMM)**2.GE.SUMM)GO TO 37 ENDIF J=JIL*N+1 IF(J.LE.JJ)THEN DO I=J,JJ K=I-N W(K)=W(I) ENDDO DO I=JIL,N W(I-1)=W(I) ENDDO ENDIF C ITONE=-1 IDIRN=IDIRN-N K=IDIRN IXP=JJ AAA=DZERO DO I=1,N IXP=IXP+1 W(K)=W(IXP) DDMAG=ABS(W(K)/E(I)) IF(DDMAG.GT.AAA)AAA=DDMAG K=K+1 ENDDO DDMAG=DONE W(N)=ESCALE/AAA ILINE=N GO TO 7 C 37 IXP=JJ AAA=DZERO F=FHOLD DO I=1,N IXP=IXP+1 X(I)=X(I)-W(IXP) IF(AAA*ABS(E(I)).LT.ABS(W(IXP)))AAA=ABS(W(IXP)/E(I)) ENDDO GO TO 72 C 38 AAA=AAA*(DONE+DI) IF(IND.EQ.0)GO TO 72 INN=0 IF(AAA.LE.DPT1)GO TO 20 GO TO 35 C 72 IF(IPRINT.GE.2)GO TO 50 53 IF(IND.NE.0)GO TO 88 IF(AAA.GT.DPT1)GO TO 76 IF(ICON.LE.1)GO TO 20 IND=2 IF(INN.GT.0)GO TO 101 INN=2 K=JJJ DO I=1,N K=K+1 W(K)=X(I) X(I)=X(I)+DTEN*E(I) ENDDO FKEEP=F C CALL CALCFX(NL,X,F) C NFCC=NFCC+1 DDMAG=DZERO GO TO 108 C 76 IF(F.LT.FP)GO TO 35 78 WRITE(6,1080) GO TO 20 C 88 IND=0 if(fp.lt.f)fp=f !assume diff small... 35 ISGRAD=1 DDMAG=DPT4*SQRT(FP-F) 108 IF(ITERC.LT.MAXIT)GO TO 5 GO TO 81 C 77 WRITE(6,1075) ITERC=ITERC-1 IF(INN*IND.EQ.0)THEN FKEEP=FP JJJ=JJ ENDIF C 81 WRITE(6,1082)ITERC C IF(F.GT.FKEEP)THEN F=FKEEP DO I=1,N JJJ=JJJ+1 X(I)=W(JJJ) ENDDO ENDIF C C ====== 20 RETURN C ====== IS.GT.0 ON ENTRY IN FOLLOWING OFF-LINE SECTION C 101 FP=FKEEP IF(F.EQ.FKEEP)GO TO 78 IF(F.GT.FKEEP)THEN IS=0 FP=F F=FKEEP ENDIF IXP=JJ DO I=1,N IXP=IXP+1 K=IXP+N FHOLD=W(K) IF(IS.EQ.0)THEN FHOLD=X(I) X(I)=W(K) ENDIF W(IXP)=FHOLD ENDDO JIL=2 GO TO 92 C 1000 FORMAT(5X,'VA04A MAXIMUM CHANGE DOES NOT ALTER FUNCTION') 1052 FORMAT(//' ITERATION',I5,I15,' FUNCTION VALUES', X 9X,'F =',E21.14/(5E24.14)) 1075 FORMAT(' VA04A ACCEPTS COMMAND FROM CALCFX TO GIVE UP ',24('/')/) 1080 FORMAT (5X,'VA04A ACCURACY LIMITED BY ERRORS IN F') 1082 FORMAT(I5,' ITERATIONS COMPLETED BY VA04A') C END C C ******************* C SUBROUTINE VACPOL(Z,RGRID,N,TB) 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 The potential is accumulated in array TB(I),I=1,N . C C No subroutines called. C C Based on PHN's GRASP0 routine and freely adapted by NRB. C C----------------------------------------------------------------------- C IMPLICIT NONE 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) DOUBLE PRECISION XCL PARAMETER (XCL = 137.03599976D0) DOUBLE PRECISION XPI PARAMETER (XPI = 3.141592653589793D0) C C Local variables C DOUBLE PRECISION FACTOR,X,Y INTEGER I C C Argument variables C DOUBLE PRECISION Z DOUBLE PRECISION RGRID(*) DOUBLE PRECISION TB(*) INTEGER N C 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 TB(I)=TB(I)/RGRID(I) ENDDO C END C C ******************* C REAL*8 FUNCTION VCC(J1,J2,J,M1,M2,M,FCT,N) C C----------------------------------------------------------------------- C C FN.VCC EVALUATES VECTOR COUPLING COEFFICIENTS. C THE SIX QUANTUM NUMBER ARGUMENTS HAVE TWICE THEIR PHYSICAL VALUE; C FACTORIALS MUST BE SUPPLIED BY FCT(I)=(I/2-1)'/16**(I/2-1),I=4,N,2 C (FCT(2)=0'=1), AND PHASE FACTORS BY FCT(I)=MOD(I+1,4)-1,I=1,N,2. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C INTEGER Z,ZMIN,ZMAX C DIMENSION FCT(N) C EQUIVALENCE (ZMIN,JG),(ZMAX,JH),(Z,JI) C c if(nint(fct(2)).ne.1)then !this is initialized correctly by AS c write(6,*)'factorial array incorrect set-up',fct(2) c stop'factorial array incorrect set-up' c endif C CC=DZERO C IF(M1+M2.NE.M)GO TO 1 IF(IABS(M1).GT.J1)GO TO 1 IF(IABS(M2).GT.J2)GO TO 1 IF(IABS(M).GT.J)GO TO 1 IF(J.LT.IABS(J1-J2))GO TO 1 K0=J1+J2-J+2 IF(K0.LE.0)GO TO 1 JB=K0+2 JJ=JB+J+J C IF(JJ.GT.N)THEN !SHOULD NOT HAPPEN, CHECKED IN ALGEB0 WRITE(6,703)JJ,N WRITE(0,*)'****FCT.VCC: FACTORIAL ARRAY TOO SHORT' GO TO 1 ENDIF C ZMIN=0 K4=J-J2+M1 IF(K4.LT.0)ZMIN=-K4 K3=J-J1-M2 IF(K3+ZMIN.LT.0)ZMIN=-K3 ZMAX=K0 K2=J2+M2+2 IF(K2.LT.ZMAX)ZMAX=K2 K1=J1-M1+2 IF(K1.LT.ZMAX)ZMAX=K1 JC=K1+2 JD=K2+2 C ZMIN=ZMIN+2 DO Z=ZMIN,ZMAX,2 CC=FCT(Z-1)/(FCT(Z)*FCT(JB-Z)*FCT(Z+K3)*FCT(JC-Z)* X FCT(Z+K4)*FCT(JD-Z))+CC ENDDO C JB=K4+K1 JC=K3+K2 C JB=(J+J1-J2)+2, JH=(J+M1+M2)+2, JD=(J1+M1)+2; K1=(J1-M1)+2 C JC=(J-J1+J2)+2, JI=(J-M1-M2)+2, JG=(J2-M2)+2; K2=(J2+M2)+2 JD=K4+K0 JG=K0+K3 JH=K2+K4 JI=K1+K3 T=(DBLE(J+1)*FCT(K0)*FCT(JB)*FCT(JC)/(FCT(JJ)*16))* X FCT(K1)*FCT(JG)*FCT(JH)*FCT(JI)*FCT(JD)*FCT(K2) c if(t.lt.dzero)then !graceful exit for any earlier problem write(6,*)'vcc:',J1,J2,J,M1,M2,M write(0,*)'vcc "failure"' c stop'vcc failure' t=dzero endif c CC=SQRT(T)*CC 1 VCC=CC C RETURN C 703 FORMAT('****FCT.VCC: FACTORIAL ARRAY TOO SHORT,',I4,'.GT.N=',I4) C END C C ******************* C SUBROUTINE VCE(QLML,QLMS,QBML,QBMS,DU,DL,DS,NO,MAXEL) C C----------------------------------------------------------------------- C C SR.VCE COMPUTES NB SIMULTANEOUS O.N. EIGENVECTORS DU(N,K),K=1,NB C WITH EIGENVALUES DS(K)/4 & DL(K)/4 OF TOTAL SPIN S AND ORBITAL L, C FROM A COMPLETE SET OF NB SLATER STATES J (=NO(N),N=1,NB),TO PAIRS C BIG MS,ML=QBMS/2,QBML/2 OF A CONFIGURATION KF WITH NF ELECTRONS; C TWICE LITTLE L,MS,ML OF I'TH ELECTRON QL(QCG(I,KF)),QLMS,+L(I,J). C C NRB: NOW ONLY CALLED FOR EQUIVALENT ELECTRON CONFIGURATION NL^Q C SO FAST (DIAGONALIZATION) *AND* MAXDF IS SMALL: 4F^7=119 !!! C C INPUT: NB,NO,QLML,QLMS,QBML,QBMS, KF,NF,QCG,QL; MXS,MT,ME C C OUTPUT: DU,DL,DS; C N.B. WORKING ARRAYS: DV,DA (DU=DV*DA IN JACORD) C C CONDITIONS: KF.LE.MAXCF, NF.LE.MAXEL.LE.MXEL0, NB.LE.MAXDF, NO.LE.MXS C C REFERENCE: EQU'S 19-25 IN COMPUTER PHYS. COMMUN. 8(1974)270-306. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (TOL0=1.0D-14) PARAMETER (TOL1=3.0D-09) C LOGICAL MSEQS C CF77 DIMENSION DV(MAXDF,MAXDF),DA(MAXDF,MAXDF) !F77 ALLOCATABLE :: DV(:,:),DA(:,:) !F95 C DIMENSION DU(MAXDF,*),QLML(MAXEL,*),QLMS(MAXEL,*) X ,NO(*),QBML(*),QBMS(*),DL(*),DS(*) C DIMENSION DE(MAXDF),IWRK1(MAXDF),IWRK2(MAXDF) C COMMON /DBD2/QXX(MXEL0,MAXCF),QL(MAXGR),QX(MAXGR) COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBVCX/NF,KF,NB,JA,JB,KSI,KSF,NTGA,NTGB,QCG(MXEL0) C C ALLOCATE(DV(MAXDF,MAXDF),DA(MAXDF,MAXDF),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'VCE: ALLOCATION FAILS FOR DV,DA' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C C IF(IDIAG.EQ.0)THEN STOL=TOL1 DTOL=TOL0 ELSE STOL=TOL1 DTOL=STOL ENDIF C MSEQS=.TRUE. C DO 60 M12=1,2 C DO 61 K=1,NB C J=NO(K) DO I=1,NB DS(I)=DZERO ENDDO DS(K)=((M12-1)*QBML(J)+(2-M12)*QBMS(J))**2 C DO 62 I=1,NF C N3=QCG(I) NI=QLMS(I,J) JD=2 IF(.NOT.MSEQS)THEN NI=QLML(I,J) JD=(QL(N3)+2)*QL(N3)-NI*NI ENDIF DS(K)=JD+DS(K) C DO 64 L=1,NF C IF(L.EQ.I)GO TO 64 N4=QCG(L) DO JD=1,NF QLML(JD,1)=QLML(JD,J) QLMS(JD,1)=QLMS(JD,J) ENDDO IF(.NOT.MSEQS)THEN QLML(I,1)=NI-2 KG=(QL(N3)+NI)*(QL(N3)-NI+2) QL0=QLML(L,J) QLML(L,1)=QL0+2 KP=(QL(N4)-QL0)*(QL(N4)+QL0+2) ELSE QLMS(I,1)=NI-2 KG=(1+NI)*(3-NI) QS0=QLMS(L,J) QLMS(L,1)=QS0+2 KP=(1-QS0)*(3+QS0) ENDIF C IF(KG.LE.0 .OR. KP.LE.0)GO TO 64 DD=KG*KP DD=SQRT(DD) C DO JD=1,NF KG=QCG(JD) IF(N3.NE.KG .AND. N4.NE.KG)GO TO 55 DO KP=JD,NF IF(QCG(KP).NE.KG)GO TO 56 IF(KP.EQ.JD)GO TO 56 NRJ=QLML(KP,1) QS0=QLMS(JD,1) QL0=QLML(JD,1) IF(.NOT.MSEQS)THEN IF(QL0.GE.NRJ)GO TO 58 QLML(JD,1)=NRJ QLML(KP,1)=QL0 GO TO 59 ENDIF IF(KP-JD.NE.1)GO TO 56 C ASSUMING SLATER STATES IN SLATER ORDER - 58 IF(QL0.NE.NRJ)GO TO 56 IF(QLMS(KP,1).EQ.QS0)GO TO 64 IF(QLMS(KP,1).LT.QS0)GO TO 56 59 QLMS(JD,1)=QLMS(KP,1) QLMS(KP,1)=QS0 DD=-DD 56 ENDDO 55 ENDDO C DO KG=1,NB JD=NO(KG) DO KP=1,NF IF(QLML(KP,JD).NE.QLML(KP,1))GO TO 66 IF(QLMS(KP,JD).NE.QLMS(KP,1))GO TO 66 ENDDO DS(KG)=DS(KG)+DD GO TO 64 66 ENDDO C 64 CONTINUE C 62 CONTINUE C C C MATRIX S**2 (IF M12=1) OR L**2 IN DU; TAS CH.VII.4.8(P.221IN1964) C IF(MSEQS)THEN NLO=1 CL IF(IDIAG.EQ.0)NLO=K DO L=NLO,NB IF(ABS(DS(L)).LT.STOL)DS(L)=DZERO DU(L,K)=DS(L) ENDDO ELSE DO L=1,NB DU(L,K)=DS(L) ENDDO ENDIF C 61 CONTINUE C C IF(.NOT.MSEQS)THEN C DO L=1,NB DO I=L+1,NB DU(I,L)=(DU(I,L)+DU(L,I))/DTWO !SYMMETRIZE DU(L,I)=DU(I,L) ENDDO ENDDO C DO L=1,NB DO I=1,NB DA(I,L)=DZERO DO K=1,NB DA(I,L)=DV(K,I)*DU(K,L)+DA(I,L) ENDDO ENDDO ENDDO C NLO=1 DO L=1,NB CL IF(IDIAG.EQ.0)NLO=L DO I=NLO,NB DU(I,L)=DZERO ENDDO DO K=1,NB DO I=NLO,NB DU(I,L)=DA(I,K)*DV(K,L)+DU(I,L) ENDDO ENDDO DO I=NLO,NB IF(ABS(DU(I,L)).LT.STOL)DU(I,L)=DZERO ENDDO ENDDO C ENDIF C C IF(IDIAG.EQ.0)THEN C C TRY HOUSEHOLDER-QL OR LAPACK DIAGONALIZATION METHOD FIRST C CALL DIAG(NB,-1,DU,DE,DS,IWRK1,IWRK2,MAXDF) C IF(NB.EQ.0)GO TO 999 C IF(MSEQS)THEN DO K=1,NB DO I=1,NB DD=DU(I,K) IF(ABS(DD).LT.DTOL)DD=DZERO DV(I,K)=DD ENDDO ENDDO MSEQS=.FALSE. ELSE DO K=1,NB DS(K)=DZERO DO I=1,NB DD=DU(I,K) IF(ABS(DD).LT.DTOL)DD=DZERO DS(K)=DD*DL(I)*DD+DS(K) DA(I,K)=DD ENDDO ENDDO ENDIF DO K=1,NB DL(K)=DE(K) ENDDO C C ELSE C C C TRY (SLOWER) JACOBI METHOD C CALL JACORD(NB,.TRUE.,DU,DA,MAXDF) C IF(MSEQS)THEN DO K=1,NB DO I=1,NB DD=DA(I,K) IF(ABS(DD).LT.DTOL)DD=DZERO DV(I,K)=DD ENDDO ENDDO MSEQS=.FALSE. ELSE DO K=1,NB DS(K)=DZERO DO I=1,NB DD=DA(I,K) IF(ABS(DD).LT.DTOL)DD=DZERO DS(K)=DD*DL(I)*DD+DS(K) DA(I,K)=DD ENDDO ENDDO ENDIF DO K=1,NB DL(K)=DU(K,K) ENDDO C C ENDIF C C 60 CONTINUE ! END M12 LOOP C C DO L=1,NB DO I=1,NB DU(I,L)=DZERO ENDDO DO K=1,NB DO I=1,NB DU(I,L)=DV(I,K)*DA(K,L)+DU(I,L) ENDDO ENDDO ENDDO C 999 CONTINUE C C DEALLOCATE (DV,DA,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'VCE: DE-ALLOCATION FAILS FOR DV,DA' !F95 NF=0 !F95 ENDIF !F95 C C RETURN C END C C ******************* C SUBROUTINE VCG(DC,IDC,QLML,QLMS,QBML,QBMS,DFS,MAXST,MAXEL) C C----------------------------------------------------------------------- C C SR VCG COUPLES TWO SUBCONFIGURATIONS (OF SLATER STATES) TO FORM A C NEW SUBCONFIGURATION, COMPLETE WITH SLATERSTATE EXPANSION. C (SAME FUNCTION AS PJS'S OF THE SAME NAME OR WE'S COLLAG.) C C INPUT: RESULTS FROM VCU FOR TWO SUBCONFIGURATIONS OF CONFIGURATION KF C THE FIRST IS STORED IN THE USUAL LOCATIONS (SEE BELOW) THE SECOND C USES THE SAME ARRAYS BUT INDEXED BY NFS,JAS,JBS,NTGA,NTGB, C QCGS(MXEL0). C NEL(K,KF) EQUIVALENT ELECTRONS WITH ANGULAR LITTLE L=QL(K)/2; C JB=HIGHEST INDEX TO SLATER STATE ARRAYS QBXX AND QLXX OCCUPIED C BY CONFIGURATIONS .LT.KF; NTG(KF-1)=HIGHEST PREVIOUS INDEX TO C TERM ARRAYS XTGX; VCC-ARRAY DC (OF LENGTH MXD) HAS BEEN FILLED C UP TO MTGD IN PREVIOUS CALL. C QCS0,QCL0=2*(SMAX,LMAX) IN CONFIGURATIONS .LT.KF C C OUTPUT: RESULTANT, STORED IN USUAL LOCATIONS WITH INDEXES UPDATED. C VIZ. NF=NUMBER OF ELECTRONS, QCG(I,KF)=GROUP NUMBER OF I'TH C ELECTRON, SLATERSTATES QLML+QLMS(I,J),I=1,NF,J=JA,JB QBML+QBMS(J); C NUMBER OF SL-TERMS ND=NTG(KF)-NTG(KF-1), TERMS 2S,2L,NO=QTGS,L,D C (K),K=NTG(KF-1),NTG(KF), COUPLING COEFFICIENTS DC(J+JTGD(K)). C PARITY QCP(KF) (0,2 FOR EVEN,ODD). UPDATED JB, MTGD, QCS0,QCL0 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (TYNY=1.0D-5) PARAMETER (TTYNY=TYNY*TYNY) C LOGICAL MGE3,MSEQS,BCUT,BCUTP,BSKP,BSKP0,BANAL X ,BFINAL,BFAST,BDROP,BDISK X ,BLOCAL !F95 C INTEGER*8 MDCF8,MDCFT8 C REAL*8 DC DIMENSION DC(0:*),IDC(*) DIMENSION QLML(MAXEL,*),QLMS(MAXEL,*),QBML(*),QBMS(*),DFS(*) DIMENSION NX1(MXEL0),LX1(MXEL0),JHOLD(MAXSL) CF77 DIMENSION NTJ(MXST0),NTJS(MXST0),BSKP(MAXTM) !F77 C ALLOCATABLE NTJ(:),NTJS(:),BSKP(:) !F95 C COMMON /BASIC/NF,KY,KG,JA,JB,JSP1,MGAP(6) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MODD,KCUT,QCLX,QCSX,NEL(MAXGR,MAXCF) COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,ND,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /TERMS/KDM,NSL0,NSL(MAXSL),QSI(MAXSL),QLI(MAXSL),QPI(MAXSL) X ,NFI(MAXCT),NFK(MAXCT),NFQ(MAXCT) COMMON /NRBDSK/MDCF8,MDCFT8,MDCBUF,KUTDSK,MTGD1,IUD,KFBUFF COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBGCF/KGSL(MAXCF,MAXSL),KGCF(0:MAXCF),NKSL(MAXSL,MAXCF) COMMON /NRBJ/JPI(MAXJG),NASTJ,MINJT,MAXJT COMMON /NRBKUT/KCUTDM,LSKUT(MAXSL),NASTK !KCUT IN /MQVC/ COMMON /NRBKUTP/KCUTP,LSKUTP(MAXSL),NASTKP COMMON /NRBLIM/ECNTRB,ITANAL,BANAL(MAXCF) !ALGEBRAIC COMMON /NRBLS/LSPI(MAXSL),NAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP COMMON /NRBPNT/NTGP(MAXCT),NTGS(MAXCT),NTP1,NTP2 COMMON /NRBVCX/NFS,KF,NB,JAS,JBS,KSI,KSF,NTGA,NTGB,QCGS(MXEL0) C DATA QBMS1/0/ C C BLOCAL=.FALSE. !F95 C BFAST=DC(0).LT.DZERO !ELSE OPT MEMORY C BFINAL=MAXST.LT.0 IF(BFINAL)MAXST=-MAXST C BDROP=.NOT.BFAST.AND.BFINAL C BDISK=KF.GT.KUTDSK !USE DISKDC BDISK=BDISK.AND.BFINAL C NF0=NF NF=NF+NFS C DO I=1,NFS QCG(NF0+I,KF)=QCGS(I) ENDDO C C IF NO PREVIOUS TO COUPLE TO THEN INITIALIZE C IF(NF0.EQ.0)THEN JA=JAS JB=JBS NTP1=0 N1=NTGA+1 QCS=QTGS(N1) QCL=QTGL(N1) K0=1 J=0 N=0 DO I=N1,NTGB N=N+1 NFI(N)=QTGS(I) NFK(N)=QTGL(I) NFQ(N)=QTGD(I) IF(QCS.EQ.QTGS(I).AND.QCL.EQ.QTGL(I))THEN J=J+1 ELSE NKSL(K0,KF)=J QCS=QTGS(I) QCL=QTGL(I) K0=K0+1 J=1 ENDIF ENDDO NKSL(K0,KF)=J KSL0=K0 NTP2=N C C IF FIRST AND FINAL THEN MUST COMPLETE FINAL TRANSFER ETC C IF(BDROP)THEN !VARIABLE LENGTH C CALL DIMUSE('MAXDC',MTGD) !HOLD MAX BUFFER USED C C INDEX (SINCE NO GAPS) C K=MTGD+1 DO N=NTP2,1,-1 DO J=JB,JA,-1 K=K-1 IDC(K)=J ENDDO ENDDO C MTGD1=K K=K-1 MTGD=K N=NTGA C I11=1 IF(BDISK)I11=-1 C C REDUCE AND RE-INDEX C DO K0=1,KSL0 KTT=NKSL(K0,KF) DO KT=1,KTT N=N+1 COLD DO N=N1,NTGB DO J=JA,JB K=K+1 IF(ABS(DC(K)).GT.TTYNY)THEN MTGD=MTGD+1 IDC(MTGD)=J DC(MTGD)=DC(K) ENDIF ENDDO JTGD(N)=MTGD IF(I11.LT.0)THEN JTGD(N)=-JTGD(N) !FLAG FIRST I11=1 ENDIF ENDDO IF(BDISK)THEN !DUMP TO DISK CALL DISKDC(IUD,DC,IDC,MTGD1,MTGD,KF,K0,-1,0) MTGD=MTGD1-1 I11=-1 ENDIF ENDDO C NTG(KF)=NTGB NTGA=NTG(KF) QBMS1=MAX(0,QBMS1) CALL DIMUSE('MXST0',QBMS1) CALL DIMUSE('MAXCT',NTGB) C IF(NTP2.EQ.0)THEN !NO TERMS - POSSIBLE???? WRITE(6,505)KF IF(IDW.NE.0)NF=-1 ENDIF GO TO 999 C C FIXED LENGTH, COMPLETE SAVE ANY DISK WRITES, SO: C ELSEIF(BDISK)THEN C CALL DIMUSE('MAXDC',MTGD) !HOLD MAX BUFFER USED C JBA1=JB-JA+1 NBA=NTGB-NTGA MTGD=MTGD-JBA1*NBA MTGD1=MTGD+1 C DO K0=1,KSL0 KTT=NKSL(K0,KF) MTGD=MTGD+KTT*JBA1 CALL DISKDC(IUD,DC,IDC,MTGD1,MTGD,KF,K0,-1,0) MTGD1=MTGD+1 !SINCE DC HOLDS ALL ENDDO C NEW INDEX MTGD=MTGD-JBA1*NBA MTGD1=MTGD+1 N=NTGA DO K0=1,KSL0 KTT=NKSL(K0,KF) DO KT=1,KTT N=N+1 JTGD(N)=MTGD+1-JA MTGD=MTGD+JBA1 ENDDO MTGD=MTGD1-1 ENDDO ENDIF C GO TO 50 !AND RETURN EVNTLY ENDIF C IF(NB.NE.0)GO TO 50 !VCU FAILURE - RETURN EVNTLY C C FLAG ANY TERMS TO BE SKIPPED, BASED ON ITANAL C BSKP0=.FALSE. IF(ITANAL.GT.0)THEN !ONLY SET ON "FINAL" COUPLING 10 READ(31,300,END=40)I00,NTT,KK,NFF,(NX1(IJ),LX1(IJ),IJ=1,NF) IF(NF.NE.NFF)THEN DO I=1,I00 READ(31,*) ENDDO GO TO 10 ENDIF DO N=NF,1,-1 J=QCG(N,KF) IF(QN(J).NE.NX1(N).OR.QL(J).NE.2*LX1(N))THEN !SKIP RECORDS DO I=1,I00 READ(31,*) ENDDO GO TO 10 ENDIF ENDDO BANAL(KF)=.TRUE. !FLAG MATCH SO DO NOT REWRITE IF(KF.LE.KCUT.AND.KK.LT.0)WRITE(6,302)KF IF(KF.GT.KCUT.AND.KK.GT.0)WRITE(6,303)KF BSKP0=.TRUE. ALLOCATE(BSKP(NTT)) !F95 DO I=1,NTT BSKP(I)=.FALSE. ENDDO J0=0 DO I=1,I00 READ(31,301)I0,DD BSKP(I0)=DD.LT.ECNTRB IF(BSKP(I0))J0=J0+1 ENDDO WRITE(6,304)KF,J0 IF(I00.NE.J0)WRITE(6,305)I00-J0,ECNTRB ENDIF C C INITIALIZE C 40 BCUT=KCUT**2.LT.KF*KCUT BCUTP=KCUTP**2.LT.KF*KCUTP C MSEQS=MPRINT+4.LT.0 !OLD+2. IF TRUE: SIZE CHECK ONLY - NO VCC'S IF(MSEQS)THEN MTGDMX=0 ELSE MTGDMX=MAXDC+1 ENDIF C C COUPLE THE TWO SUBCONFIG'S TERMS, STORED IN QTGX, TO FORM NEW SET. C FIRST SET INDEXED BY NTG(KF-1)+1 THRU NTG(KF) C SECOND SET INDEXED BY NTGA=NTG(KF)+1 THRU NTGB C STORE RESULTANT (EVENTUALLY) IN QTGX, OVERWRITING ORIGINAL SETS, C I.E RESULTANT STARTS AT NTG(KF-1)+1 STILL BUT WITH INCREMENTED NTG(KF) C MGE3=IABS(MODD).GE.3 C IF(.NOT.MGE3)THEN !INITIALIZE FOR LOCAL MAX S,L QCSX=0 QCLX=0 ENDIF C C *TBD*: THE I,J LOOPS SHOULD REALLY BE OVER SYMMETRY GROUPS BECAUSE THE C TERMS ARE SYMMETRY ORDERED HERE - INELEGANT MORE THAN ANYTHING. C K0=0 K=NTGB DO I=NTG(KF-1)+1,NTG(KF) DO J=NTGA+1,NTGB C QSTMN=QTGS(I)-QTGS(J) QSTMN=ABS(QSTMN) QSTMX=QTGS(I)+QTGS(J) QLTMN=QTGL(I)-QTGL(J) QLTMN=ABS(QLTMN) QLTMX=QTGL(I)+QTGL(J) C DO QLT=QLTMX,QLTMN,-2 DO QST=QSTMX,QSTMN,-2 C IF(MGE3.AND.(QCSX.NE.QST.OR.QCLX.NE.QLT))GO TO 44 C LSPT=10000*(QST+1)+5*QLT+QCP(KF)/2 !QLT=2*L C PARENT IF(NASTP.GT.0)THEN !SEE IF PARENT TERM WANTED NASTP0=NLSPIP(KF) IF(NASTP0.EQ.0)GO TO 27 !UNRESTRICTED BY NASTP DO N=1,NASTP0 IF(LSPIP(N,KF).EQ.LSPT)GO TO 27 !YES ENDDO GO TO 44 !NO ELSEIF(NASTP.LT.0)THEN IF(QST+1.LT.MINSTP.OR.QST+1.GT.MAXSTP)GO TO 44 IF(QLT/2.LT.MINLTP.OR.QLT/2.GT.MAXLTP)GO TO 44 ENDIF C 27 IF(KCUTP.GT.0)THEN !LOOK FOR EXISTING PARENT SYM DO N=1,NASTKP IF(LSKUTP(N).EQ.LSPT)GO TO 45 !FOUND ENDDO IF(BCUTP)GO TO 44 !CORR, SO NOT WANTED NASTKP=NASTKP+1 !WANTED, ADD TO LIST LSKUTP(NASTKP)=LSPT c write(6,*)'vcg',-nastkp,qst+1,qlt/2,qcp(kf)/2 GO TO 45 ENDIF C FINAL CF IF(NAST.GT.0)THEN !SEE IF TERM WANTED DO N=1,NAST IF(LSPI(N).EQ.LSPT)GO TO 28 !YES ENDDO GO TO 44 !NO ELSEIF(NAST.LT.0)THEN IF(QST+1.LT.MINSP.OR.QST+1.GT.MAXSP)GO TO 44 IF(QLT/2.LT.MINLT.OR.QLT/2.GT.MAXLT)GO TO 44 ELSEIF(NASTJ.GT.0)THEN !CHECK TRIANGLE CONTRIB TO J DO N=1,NASTJ JT=JPI(N)/10 IF(QCP(KF)/2.EQ.JPI(N)-10*JT)THEN !SAME PARITY IF(QST+QLT.GE.JT.AND.ABS(QST-QLT).LE.JT)GO TO 28!YES ENDIF ENDDO GO TO 44 !NONE FOUND ELSEIF(NASTJ.LT.0)THEN !CHECK TRIANGLE CONTRIB TO J IF(QST+QLT.LT.MINJT.OR.ABS(QST-QLT).GT.MAXJT)GO TO 44 ENDIF C 28 IF(KCUT.GT.0)THEN !LOOK FOR EXISTING SYMMETRY DO N=1,NASTK IF(LSKUT(N).EQ.LSPT)GO TO 45 !FOUND ENDDO IF(BCUT)GO TO 44 !CORR, SO NOT WANTED NASTK=NASTK+1 !WANTED, ADD TO LIST LSKUT(NASTK)=LSPT c write(6,*)'vcg',nastk,qst+1,qlt/2,qcp(kf)/2 ENDIF C 45 IF(BSKP0)THEN K0=K0+1 IF(BSKP(K0))GO TO 44 ENDIF C QCSX=MAX(QCSX,QST) QCLX=MAX(QCLX,QLT) C K=K+1 IF(K.LE.MAXCT)THEN NTGP(K)=I NTGS(K)=J QTGS(K)=QST QTGL(K)=QLT c c qtgd(k)=0 c do n=ntgb+1,k c if(qtgs(n).eq.qst.and.qtgl(n).eq.qlt)qtgd(k)=qtgd(k)+1 c enddo c write(6,100)i,qtgs(i)+1,qtgl(i)/2,j,qtgs(j)+1,qtgl(j)/2 c x ,k-ntgb,qst+1,qlt/2,qtgd(k) c 100 format(i5,i3,i2,i5,i3,i2,i7,i3,2i2) c ENDIF 44 ENDDO ENDDO ENDDO ENDDO C IF(BSKP0)DEALLOCATE(BSKP) !F95 C IF(K.GT.MAXCT)THEN WRITE(6,499)K WRITE(0,*)'*** SR.VCG: INCREASE MAXCT & MAXTM' NB=-2 GO TO 50 !RETURN ELSE NTT=K CALL DIMUSE('MAXCT',NTT) ENDIF C IF(NTT.EQ.NTGB)THEN !NO RESULTANT TERMS JB=JA-1 NTGB=NTG(KF-1) MTGD=JTGD(NTGB) IF(NFS.EQ.0.OR.MGE3)GO TO 50 !WILL RETURN IF(BCUT.OR.BCUTP)THEN WRITE(6,502)KF IF(IDW.EQ.0)GO TO 50 NF=-1 GO TO 999 ELSE IF(NAST+NASTJ.EQ.0)THEN WRITE(6,500)KF NF=-1 GO TO 999 ELSE WRITE(6,501)KF IF(IDW.EQ.0)GO TO 50 NF=-1 GO TO 999 ENDIF ENDIF ENDIF C C SORT TERMS INTO STANDARD ORDER, BEFORE WE GENERATE SLATERSTATES C K0=0 N1=NTGB+1 I=NTGB C QCL=QCLX C 60 QCS=QCSX C 70 I0=I+1 J=0 DO K=N1,NTT IF(QTGL(K).EQ.QCL.AND.QTGS(K).EQ.QCS)THEN I=I+1 NFI(I)=K J=J-1 QTGD(I)=J ENDIF ENDDO C IF(J.LT.0)THEN J=-J J0=J+1 DO II=I0,I QTGD(II)=QTGD(II)+J0 ENDDO C K0=K0+1 NKSL(K0,KF)=J !NO. TERMS IN SL GROUP ENDIF C QCS=QCS-2 IF(QCS.GE.0)GO TO 70 !LOOP UP FOR NEXT SPIN C QCL=QCL-2 IF(QCL.GE.0)GO TO 60 !LOOP UP FOR NEXT ORB A.M. C KSL0=K0 !NO. OF SL GROUPS IN CF C C NOW RE-INDEX C DO K=N1,NTT I=NFI(K) NFK(K)=QTGS(I) NFQ(K)=QTGL(I) ENDDO C C AND TRANSFER BACK C DO K=N1,NTT QTGS(K)=NFK(K) QTGL(K)=NFQ(K) c write(6,*)k-ntgb,qtgs(k)+1,qtgl(k)/2,qtgd(k) ENDDO C C DITTO PARENT INFO C DO K=N1,NTT I=NFI(K) NFK(K)=NTGS(I) NFQ(K)=NTGP(I) ENDDO C C AND TRANSFER BACK C DO K=N1,NTT NTGS(K)=NFK(K) NTGP(K)=NFQ(K) ENDDO C C C NOW FORM RESULTANT SLATERSTATES FROM THE TWO SUBCONFIG SETS C FIRST SET INDEXED BY JA,JB C SECOND SET INDEXED BY JAS,JBS C RESULTANT INDEXED(EVENTUALLY) BY JA THRU NEW JB, C OVERWRITING ORIGINAL SETS, ALL STORED IN DC. C ORDERED BY DESCENDING ML, FOR IDW.GT.0. C DOES NOT YET ASSUME THE ORIGINAL SETS WERE SO ORDERED, C ALTHOUGH THEY MUST BE FOR IDW.NE.0 IN CASE VCG NOT NEEDED C E.G. CF WITH SINGLE OPEN SUBSHELL. C IF(MODD.GT.0.AND..NOT.MGE3)THEN !RESET MOD MODD=-MODD WRITE(6,497)MODD ENDIF C MSMAX=QCSX MLMAX=QCLX C IF(MODD.EQ.0)THEN MSMIN=-MSMAX MLMIN=-MLMAX MJMIN=-999 if(idw.ne.0)then if(jsp1.le.0)msmin=-NF+2*(NF/2) !LS: ASSUMES MTMS=MST !!! c write(0,*)'jsp, msmin=',jsp1,msmin endif ELSEIF(MODD.EQ.-1)THEN MSMIN=-MSMAX MLMIN=-MLMAX MJMIN=NF-2*(NF/2) ELSEIF(MODD.EQ.-2)THEN MSMIN=NF-2*(NF/2) MLMIN=0 MJMIN=-999 ELSEIF(MGE3)THEN !HAS LITTLE MEANING NOW MSMIN=QCSX MLMIN=QCLX MJMIN=-999 ELSE WRITE(6,498)MODD WRITE(0,*)'*** SR.VCG: ILLEGAL MOD VALUE' NF=-1 GO TO 999 ENDIF C !F95 C LOCAL (TBD: USE ACTUAL DIMENSIONS) !F95 ALLOCATE (NTJ(MXST0),NTJS(MXST0),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'VCG: ALLOCATION FAILS FOR NTJ,NTJS' !F95 NF=0 !F95 GO TO 999 !F95 ENDIF !F95 BLOCAL=.TRUE. !F95 C JBT=JBS JAT=JBT+1 NTS=0 C MTML=MLMAX C 55 DO JS=JAS,JBS !SLATERSTATE LOOP MBLS=QBML(JS) MBSS=QBMS(JS) C DO J=JA,JB !SLATERSTATE LOOP MBL=QBML(J) MBLT=MBL+MBLS IF(MBLT.NE.MTML)GO TO 57 C MBS=QBMS(J) MBST=MBS+MBSS MBJT=MBST+MBLT IF( !SELECTION RULES X MBST.GE.MSMIN .AND. MBST.LE.MSMAX .AND. C X MBLT.GE.MLMIN .AND. MBLT.LE.MLMAX .AND. X MBJT.GE.MJMIN X )THEN C JBT=JBT+1 IF(JBT.GT.MAXST)THEN !FLAG VIA VCU SS QBMS(1)=(JB-JA+1)*(JBS-JAS+1)+JBS WRITE(6,503)QBMS(1),QBMS(1)*NF WRITE(0,*)'*** SR.VCG: DIMENSION EXCEEDED, INCREASE MXEST' NB=-3 GO TO 50 !RETURN ENDIF QBMS(JBT)=MBST QBML(JBT)=MBLT DO I=1,NF0 QLMS(I,JBT)=QLMS(I,J) QLML(I,JBT)=QLML(I,J) ENDDO DO I=1,NFS QLMS(NF0+I,JBT)=QLMS(I,JS) QLML(NF0+I,JBT)=QLML(I,JS) ENDDO NTS=NTS+1 NTJ(NTS)=J NTJS(NTS)=JS ENDIF 57 ENDDO ENDDO C MTML=MTML-2 IF(MTML.GE.MLMIN)GO TO 55 C QBMS1=MAX(QBMS1,JBT) !MAX SS STORAGE NEEDED BY VCG C MTGD1=MTGD+1 J1=JA-1 c iv=mtgd c jcmax=0 C !TERM LOOP NT=NTGB DO K0=1,KSL0 KTT=NKSL(K0,KF) DO KT=1,KTT NT=NT+1 C DO NT=N1,NTT JTGD(NT)=MTGD+1-JAT QST=QTGS(NT) QLT=QTGL(NT) NP=NTGP(NT) NS=NTGS(NT) QSP=QTGS(NP) QLP=QTGL(NP) QSS=QTGS(NS) QLS=QTGL(NS) JT=JTGD(NP) JTS=JTGD(NS) c c write(6,*)qst,qlt c jcount=0 C DO N=1,NTS C JS=NTJS(N) MBSS=QBMS(JS) MBLS=QBML(JS) C J=NTJ(N) MBS=QBMS(J) MBL=QBML(J) C MBST=MBS+MBSS MBLT=MBL+MBLS C MTGD=MTGD+1 IF(MTGD.LT.MTGDMX)THEN DC(MTGD)=DZERO VC1=DC(JT+J) IF(ABS(VC1).GT.TYNY)THEN VC2=DC(JTS+JS) IF(ABS(VC2).GT.TYNY)THEN V1=VCC(QSP,QSS,QST,MBS,MBSS,MBST,DFS,MXDFS) V2=VCC(QLP,QLS,QLT,MBL,MBLS,MBLT,DFS,MXDFS) T=VC1*VC2*V1*V2 c c write(6,*)qsp,qss,qst,mbs,mbss,mbst c x ,' ',qlp,qls,qlt,mbl,mbls,mblt c write(6,*)nt,n,v1,v2,vc1,vc2,mtgd,t c if(abs(t).gt.tyny)then c iv=iv+1 c jcount=jcount+1 c endif c IF(ABS(T).GT.TTYNY)THEN !<--- TTYNY DC(MTGD)=T IF(BDROP)IDC(MTGD)=N+J1 ELSEIF(BDROP)THEN MTGD=MTGD-1 ENDIF ELSEIF(BDROP)THEN MTGD=MTGD-1 ENDIF ELSEIF(BDROP)THEN MTGD=MTGD-1 ENDIF ENDIF ENDDO c write(6,*)nt-ntgb,jcount c jcmax=max(jcmax,jcount) ENDDO IF(BDROP)JHOLD(K0)=MTGD !FINALIZE IF(BDISK)THEN IEND=MIN(MTGD,MAXDC) CALL DISKDC(IUD,DC,IDC,MTGD1,IEND,KF,K0,-1,0) CALL DIMUSE('MAXDC',MTGD) !HOLD MAX BUFFER USED MTGD=MTGD1-1 ENDIF ENDDO C c write(0,*)kf,jcmax,iv-mtgd1+1,mtgd-mtgd1+1 IF(BDISK)THEN MTGDMX=0 CALL DIMUSE('MAXDC',MTGDMX) ELSE MTGDMX=MTGD ENDIF IF(MTGDMX.GT.MAXDC)THEN WRITE(6,504)MTGDMX NB=-1 GO TO 50 !RETURN ENDIF C IF(MSEQS)THEN !FILL-IN FOR DIMENSION CHECK DO J=MTGD1,MTGD DC(J)=DONE ENDDO DO NT=N1,NTT QTGD(NT)=-QTGD(NT) ENDDO IF(BDROP)THEN M=MTGD1-1 DO NT=N1,NTT DO N=1,NTS M=M+1 IDC(M)=N+J1 ENDDO ENDDO ENDIF ENDIF C C NOW OVERWRITE SUBCONFIGURATION STORAGE WITH RESULTANT C (BACK-UP PARENT SLP FOR OPTIONAL PRINTING IN ALGEB1.) C I0=NTG(KF-1)+1 I1=JTGD(I0)-1+JA C I=I1 DO J=MTGD1,MTGD I=I+1 DC(I)=DC(J) ENDDO IF(BDROP)THEN MHOLD=MTGD1-I1-1 I=I1 DO J=MTGD1,MTGD I=I+1 IDC(I)=IDC(J) ENDDO ENDIF C CALL DIMUSE('MAXDC',MTGD) !HOLD MAX BUFFER USED MTGD=I C K=JA-1 DO J=JAT,JBT K=K+1 QBMS(K)=QBMS(J) QBML(K)=QBML(J) DO I=1,NF QLMS(I,K)=QLMS(I,J) QLML(I,K)=QLML(I,J) ENDDO ENDDO C JB=K C N=0 DO I=NTG(KF-1)+1,NTG(KF) N=N+1 NFI(N)=QTGS(I) NFK(N)=QTGL(I) NFQ(N)=QTGD(I) ENDDO NTP1=N C DO I=NTGA+1,NTGB N=N+1 NFI(N)=QTGS(I) NFK(N)=QTGL(I) NFQ(N)=QTGD(I) ENDDO NTP2=N C J=NTG(KF-1) J0=JTGD(N1)-JTGD(J+1) !AS JA <- JAT DO N=N1,NTT J=J+1 JTGD(J)=JTGD(N)-J0 QTGS(J)=QTGS(N) QTGL(J)=QTGL(N) QTGD(J)=QTGD(N) NTGS(J)=NTGS(N) NTGP(J)=NTGP(N) ENDDO C NTGB=J C 50 CONTINUE C NTG(KF)=NTGB NTGA=NTG(KF) C C FINALLY, RE-DEFINE JTGD(N) TO GIVE THE *ABSOLUTE* POSITION OF C THE *END* OF THE DC(I) ARRAY FOR TERM N. C (ABSOLUTE SIMPLIFIES SPECIFICATION OF THE VARIABLE ARRAY LENGTH C WHILE *END* MEANS WE JUST NEED TO START AT JTGD(0)=0.) C IF(BDROP)THEN JA1=JA-1 N=NTG(KF-1) I11=1 IF(BDISK)I11=-1 DO K0=1,KSL0 KTT=NKSL(K0,KF) DO KT=1,KTT-1 N=N+1 JTGD(N)=JTGD(N+1)+JA1 IF(I11.LT.0)THEN JTGD(N)=-JTGD(N) !FLAG FIRST I11=1 ENDIF ENDDO N=N+1 JTGD(N)=JHOLD(K0)-MHOLD IF(I11.LT.0)JTGD(N)=-JTGD(N) !CASE KTT=1 IF(BDISK)I11=-1 ENDDO if(n.ne.ntgb)stop 'vcg' c for .not.bdisk only c DO N=NTG(KF-1)+1,NTG(KF)-1 c JTGD(N)=JTGD(N+1)+JA1 c ENDDO c JTGD(NTGB)=MTGD CALL DIMUSE('MXST0',QBMS1) ENDIF C 999 CONTINUE C IF(BFINAL)KGCF(KF)=KSL0 c c if(bdcwr)then c n=ntg(kf-1) c do k0=1,ksl0 c ktt=nksl(k0,kf) c do kt=1,ktt c n=n+1 c write(6,*)kf,k0,n,jtgd(n) c enddo c enddo c endif C !F95 IF(BLOCAL)THEN !F95 DEALLOCATE (NTJ,NTJS,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'VCG: DE-ALLOCATION FAILS FOR NTJ,NTJS' !F95 IF(NF.GT.0)NF=0 !F95 ENDIF !F95 ENDIF !F95 C !F95 RETURN C 300 FORMAT(3I6,I3,100(I3,I2)) 301 FORMAT(I6,6X,F13.3) 302 FORMAT(/'*** ATTENTION: CONFIGURATION',I4,' IS NOW SPECTROSCOPIC' X,' BUT WAS CORRELATION IN ITANAL...') 303 FORMAT(/'*** ATTENTION: CONFIGURATION',I4,' IS NOW CORRELATION' X,' BUT WAS SPECTROSCOPIC IN ITANAL...') 304 FORMAT(//' CONFIGURATION CF=',I4,' DROPS',I5,' TERMS, BASED ON' X,' USER SUPPLIED ITANAL FILE') 305 FORMAT(22X,' NOTE:',I5,' TERMS WERE RETAINED BECAUSE YOU HAVE' X,' REDUCED ECNTRB TO',F8.2,' /CM') 497 FORMAT(/'*** SR.VCG: MOD RESET TO -MOD:',I3) 498 FORMAT(/'*** SR.VCG: ILLEGAL MOD VALUE: ',I3) 499 FORMAT(/'*** SR.VCG: INCREASE MAXCT & MAXTM TO;',I6) 500 FORMAT(/'*** VCG ERROR COUPLING SUBCONFIGURATIONS OF KF=',I3) 501 FORMAT(/'*** ATTENTION: BECAUSE OF NAST/J THE FOLLOWING', X ' CF=',I3,' CONTRIBUTES NO TERMS/LEVELS...') 502 FORMAT(/'*** ATTENTION: THE FOLLOWING CORRELATION CF=',I3, X ' CONTRIBUTES NO TERMS/LEVELS...') 503 FORMAT(/'*** SR.VCG: SLATER-STATE STORAGE (MAXST) NEEDED: ',I7 X /' TRY INCREASING MXEST TO AT LEAST',I8) 504 FORMAT(/'*** SR.VCG: INCREASE MAXDC TO AT LEAST: ',I9) 505 FORMAT(/'*** ATTENTION: THE FOLLOWING CONFIGURATION CF=',I3, X ' CONTRIBUTES NO TERMS/LEVELS...') C END C C ******************* C SUBROUTINE VCU(DC,IDC,QLML,QLMS,QBML,QBMS,DL,DS,NO,MAXST,MAXEL) C C----------------------------------------------------------------------- C C SR VCU SETS UP SLATER STATES TO A CONFIGURATION GIVEN AS GROUPS OF C EQUIVALENT ELECTRONS, AND COMPUTES VECTOR COUPLING COEFFICIENTS C (VCC) FOR CONSTRUCTING TERMS OF TOTAL SL FROM THE SLATER STATES. C IT REQUIRES SR VCE (WHICH REQUIRES SR JACORD AND ROTSYM). C M, IN /MQVC/, RULES DIFFERENT MODES, SEE COMMENT AT THE END. C NB=0: SUCCESSFUL RUN; OTHERWISE STUDY RETURN-COMMENTS AND CHECK NB C C INPUT: CONFIGURATION KF, CONSISTING OF GROUPS K=1,2..MAXGR OF C NEL(K,KF) EQUIVALENT ELECTRONS WITH ANGULAR LITTLE L=QL(K)/2; C NEL.LT.0 IS IGNORED IN THIS PROGRAM (MIGHT BE USED FOR MARKING C CLOSED SUBSHELLS ELSEWHERE). FOR A KF.GT.KCUT SEE NOTE AT END. C JB=HIGHEST INDEX TO SLATER STATE ARRAYS QBXX AND QLXX OCCUPIED C BY CONFIGURATIONS .LT.KF; NTG(KF-1)=HIGHEST PREVIOUS INDEX TO C TERM ARRAYS XTGX; VCC-ARRAY DC (OF LENGTH MXD) HAS BEEN FILLED C UP TO MTGD IN PREVIOUS CALL. C QCS0,QCL0=2*(SMAX,LMAX) IN CONFIGURATIONS .LT.KF C C OUTPUT: NF=NUMBER OF ELECTRONS, QCG(I,KF)=GROUP NUMBER OF I'TH C ELECTRON, SLATERSTATES QLML+QLMS(I,J),I=1,NF,J=JA,JB QBML+QBMS(J); C NUMBER OF SL-TERMS ND=NTG(KF)-NTG(KF-1), TERMS 2S,2L,NO=QTGS,L,D C (K),K=NTG(KF-1),NTG(KF), COUPLING COEFFICIENTS DC(J+JTGD(K)). C PARITY QCP(KF) (0,2 FOR EVEN,ODD). UPDATED JB, MTGD, QCS0,QCL0 C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (STOL=1.0D-6) PARAMETER (TYNY=1.0D-5) PARAMETER (TTYNY=TYNY*TYNY) PARAMETER (DPT1=0.1D0) C LOGICAL MGE3,MSEQS,BCUT,BCUTP C CF77 DIMENSION DU(MAXDF,MAXDF) !F77 ALLOCATABLE :: DU(:,:) !F95 C REAL*8 DC DIMENSION DC(0:*),IDC(*) DIMENSION QLML(MAXEL,*),QLMS(MAXEL,*),QBML(*),QBMS(*) X ,DL(*),DS(*),NO(*) C C COMMON /BASIC/NF,KF,NB,JA,JB,MGAP(7) COMMON /DBD2/QXX(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/M,KCUT,QCL0,QCS0,NEL(MAXGR,MAXCF) COMMON /OUTP1/MPRINT,KUTSS,QCUT,QQCUT COMMON /QTG/MTGD,ND,NTG(0:MAXCF),JTGD(0:MAXCT),QCP(MAXCF) X ,QTGS(MAXCT),QTGL(MAXCT),QTGD(MAXCT) COMMON /NRBDIJ/IDIAG,JRAD COMMON /NRBJ/JPI(MAXJG),NASTJ,MINJT,MAXJT COMMON /NRBKUT/KDUM,LSKUT(MAXSL),NASTK !KCUT IN /MQVC/ COMMON /NRBKUTP/KCUTP,LSKUTP(MAXSL),NASTKP COMMON /NRBLS/LSPI(MAXSL),NAST,MINSP,MAXSP,MINLT,MAXLT,ipar COMMON /NRBLSP/LSPIP(MAXSL,MAXCF),NLSPIP(MAXCF),NASTP X ,MINSTP,MAXSTP,MINLTP,MAXLTP COMMON /NRBVCX/NF,KF,NB,JA,JB,KSI,KSF,NTGA,NTGB,QCG(MXEL0) C C SUPPRESS COMPILER WARNINGS (SIGH...) C IDUM=IDC(1) C c data timev/0.d0/ c save timev C C ALLOCATE(DU(MAXDF,MAXDF),STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'VCU: ALLOCATION FAILS FOR DU ' !F95 NF=0 !F95 RETURN !F95 ENDIF !F95 C C BCUT=KCUT**2.LT.KF*KCUT BCUTP=KCUTP**2.LT.KF*KCUTP C IDIAG0=IDIAG JB0=JB MTGD0=MTGD c c store resultant at end of arrays so can sort by M_L on moving down. c ja0=ja mshift=MAXST+jb0+1 C 52 JB=JB0 MTGD=MTGD0 MSEQS=MPRINT+4.LT.0 !OLD+2. IF TRUE: SIZE CHECK ONLY -- NO VCC'S C C COMPILE ALL THE SLATER STATES THAT FORM THE GIVEN CONFIGURATION -- C IN ARRAY LOCATIONS J=JA,JB, FOR NF ELECTRONS I=1,NF C NB=-3 ND=0 KG=JB+2 JA=KG-1 NF=0 KP=0 C C LOOP OVER SUBCONFIGURATION DEFINED BY KSI,KSF C DO K=KSI,KSF NRJ=NEL(K,KF) IF(NRJ.LE.0)GO TO 11 C NI=NF+1 NU=NF+NRJ NF=NU IF(NU.GT.MAXEL)THEN !TOO MANY ELECTRONS NB=-4 GO TO 999 ENDIF C KP=NRJ*QL(K)+KP J=JA JD=KG-J C 15 KG=J+JD JB=KG-1 C IF(mshift.lt.2*kg)THEN !NOT ENOUGH SS STORAGE JB.GE.MXS QBMS(1)=2*kg-jb0-1 !JB GO TO 999 ENDIF C jx=mshift-j IF(NU.GE.NI)THEN MS=1 ML=QL(K) DO I=NI,NU QCG(I)=K QLMS(I,Jx)=MS QLML(I,Jx)=ML MS=-MS ML=ML-1-MS ENDDO ENDIF C DO L=J,KG NU=L-JD IF(NU.LT.JA)NU=L lx=mshift-l DO I=1,NF IF(I.EQ.NI)NU=J nux=mshift-nu QLML(I,Lx)=QLML(I,NUx) QLMS(I,Lx)=QLMS(I,NUx) ENDDO ENDDO C J=KG jx=mshift-j DO I=NI,NF MS=QLMS(I,Jx) ML=QLML(I,Jx)-1+MS IF(ML.LT.-QL(K))GO TO 11 QLMS(I,Jx)=-MS QLML(I,Jx)=ML NU=I-1 IF(I.EQ.NF)GO TO 15 IF(QLMS(I+1,Jx).EQ.MS)GO TO 15 IF(QLML(I+1,Jx).NE.ML)GO TO 15 ENDDO C 11 ENDDO C QCP(KF)=MOD(QCP(KF)+KP,4) !ACCUMULATE SUB-SHELLS C C ACCUMULATE SUBSHELL SS WEIGHTS, TO FORM WHOLE CONFIG. C MAX VCU SS STORAGE DETERMINED BY *UNCOUPLED* PARENT+SUBSHELL HERE. C QBMS(1)=(QBMS(1)-1)*(JB-JA+1)+1 c write(0,*)ja-1,jb-1,qbms(1)-1 C C FORM M_X C mlmax=-999 mlmin=999 DO jj=JA,JB j=mshift-jj QBML(J)=0 QBMS(J)=0 DO I=1,NF QBML(J)=QLML(I,J)+QBML(J) QBMS(J)=QLMS(I,J)+QBMS(J) ENDDO mlmin=min(mlmin,qbml(j)) mlmax=max(mlmax,qbml(j)) ENDDO c c order by descending M_L (currently, only required by IDW.NE.0). c mtml=mlmax j0=jb0 54 do jj=ja,jb j=mshift-jj if(qbml(j).eq.mtml)then j0=j0+1 qbml(j0)=qbml(j) qbms(j0)=qbms(j) do i=1,nf qlml(i,j0)=qlml(i,j) qlms(i,j0)=qlms(i,j) enddo endif enddo c mtml=mtml-2 if(mtml.ge.mlmin)go to 54 c if(j0.ne.jb)then write(0,*)ja0,jb0,ja,jb,j0,mshift stop 'indexing error' endif C C LISTING OF ND TERMS (SL) CONTAINED IN THE (JB-JA+1) SLATER STATES C IN ARRAY LOCATIONS K=NTG(KF-1)+1,NTG(KF) (FOR NTG(KF-1)-NTG(KF).LE.ND) C MGE3=IABS(M).GE.3 NB=-2 N2=NTGA !NTG(KF-1) IF WHOLE CF N1=N2+1 QCS=0 !LOCAL MAX S QCL=0 !LOCAL MAX L C QDS=999 !LOCAL MIN S C QDL=999 !LOCAL MIN L IF(.NOT.MGE3)THEN QCS0=0 !WAS GLOBAL, NOW LOCAL QCL0=0 !WAS GLOBAL, NOW LOCAL ENDIF C KG=0 IF(M.LE.-3)KG=2 C C START TERM GENERATION LOOP C 41 QL0=-1 QS0=0 DO J=JA,JB MS=QBMS(J) IF(MS.GE.-NF.AND.QBML(J).GE.QL0)THEN IF(QBML(J).GT.QL0.OR.MS.GT.QS0)THEN QL0=QBML(J) QS0=MS ENDIF ENDIF ENDDO C IF(QL0.LT.0)GO TO 50 ML=-QL0 IF(MGE3)THEN IF(QL0.LT.QCL0-KG)GO TO 45 IF(QS0.LT.QCS0)GO TO 45 IF(QS0.GT.QCS0)GO TO 44 IF(QL0.NE.QCL0)GO TO 44 ENDIF C C APPLY USER SELECTIONS C LSPT=10000*(QS0+1)+5*QL0+QCP(KF)/2 !QL0=2*L C IF(NASTP.GT.0)THEN !SEE IF PARENT TERM WANTED NASTP0=NLSPIP(KF) IF(NASTP0.EQ.0)GO TO 27 !UNRESTRICTED BY NASTP DO I=1,NASTP0 IF(LSPIP(I,KF).EQ.LSPT)GO TO 27 ENDDO GO TO 44 ELSEIF(NASTP.LT.0)THEN IF(QS0+1.LT.MINSTP.OR.QS0+1.GT.MAXSTP)GO TO 44 IF(QL0/2.LT.MINLTP.OR.QL0/2.GT.MAXLTP)GO TO 44 ENDIF C 27 IF(KCUTP.GT.0)THEN !LOOK FOR EXISTING PARENT SYM DO I=1,NASTKP IF(LSKUTP(I).EQ.LSPT)GO TO 101 !FOUND ENDDO IF(BCUTP)GO TO 44 !CORR, SO NOT WANTED NASTKP=NASTKP+1 !WANTED, ADD TO LIST LSKUTP(NASTKP)=LSPT c write(6,*)'vcu',-nastkp,qs0+1,ql0/2,qcp(kf)/2 GO TO 101 ENDIF C FINAL CF IF(NAST.GT.0)THEN !SEE IF TERM WANTED DO I=1,NAST IF(LSPI(I).EQ.LSPT)GO TO 28 !YES ENDDO GO TO 44 !NO ELSEIF(NAST.LT.0)THEN IF(QS0+1.LT.MINSP.OR.QS0+1.GT.MAXSP)GO TO 44 IF(QL0/2.LT.MINLT.OR.QL0/2.GT.MAXLT)GO TO 44 ELSEIF(NASTJ.GT.0)THEN !CHECK TRIANGLE CONTRIB TO J DO I=1,NASTJ JT=JPI(I)/10 IF(QCP(KF)/2.EQ.JPI(I)-10*JT)THEN !SAME PARITY IF(QS0+QL0.GE.JT.AND.ABS(QS0-QL0).LE.JT)GO TO 28 !YES ENDIF ENDDO GO TO 44 !NONE FOUND ELSEIF(NASTJ.LT.0)THEN !CHECK TRIANGLE CONTRIB TO J IF(QS0+QL0.LT.MINJT.OR.ABS(QS0-QL0).GT.MAXJT)GO TO 44 ENDIF C 28 IF(KCUT.GT.0)THEN !LOOK FOR EXISTING SYMMETRY DO I=1,NASTK IF(LSKUT(I).EQ.LSPT)GO TO 101 !FOUND ENDDO IF(BCUT)GO TO 44 !CORR, SO NOT WANTED NASTK=NASTK+1 !WANTED, ADD TO LIST LSKUT(NASTK)=LSPT c write(6,*)'vcu',nastk,qs0+1,ql0/2,qcp(kf)/2 ENDIF C C END USER SELECTION C 101 N2=N2+1 !NO. OF TERMS SELECTED IF(N2.GT.MAXCT)GO TO 44 !TERM ARRAYS TOO SMALL FOR PROBLEM C C DETERMINE LOCAL MAX{S} AND MAX{L} IF(QCS.LT.QS0)QCS=QS0 IF(QCL.LT.QL0)QCL=QL0 C C DETERMINE LOCAL MIN{S} AND MIN{L} C IF(QDS.GT.QS0)QDS=QS0 C IF(QDL.GT.QL0)QDL=QL0 C QTGS(N2)=QS0 QTGL(N2)=QL0 QTGD(N2)=0 DO K=N1,N2 IF(QTGL(K).EQ.QL0.AND.QTGS(K).EQ.QS0)QTGD(K)=QTGD(K)-1 ENDDO C 44 ND=ND+1 !NO. OF TERMS IN CF C 45 MS=-QS0 C 46 DO J=JA,JB IF(QBMS(J).EQ.MS.AND.QBML(J).EQ.ML)THEN QBMS(J)=QBMS(J)-NF-NF-1 GO TO 48 ENDIF ENDDO C 48 MS=MS+2 IF(MS.LE.QS0)GO TO 46 C ML=ML+2 IF(ML.LE.QL0)GO TO 45 C GO TO 41 C C TERMS COMPLETE C 50 NTGB=N2 !=NTG(KF) IF WHOLE CF C IF(N2.GT.MAXCT)GO TO 999 !TERM ARRAYS TOO SMALL FOR PROBLEM C C CROSS OUT UNWANTED SLATER STATES J, SET UP VCC ORGANIZATION C (AND FOR M=1, 2ND ENTRY THROUGH 30 NB=0, CANCEL FURTHER STATES) C NB=-1 NU=NF-(NF/2)*2 NI=QCS+NU IF(MSEQS)THEN !SIZE CHECK ONLY DD=DONE ELSE DD=-DZERO ENDIF C 30 L=JA-1 IF(N2.LT.N1)GO TO 39 C DO 33 J=JA,JB I=L+1 ML=QBML(J) C IF(NB.EQ.0)THEN MTGD=MTGD+N1-N2-1 MS=QBMS(J) IF(ML+MS.NE.NU)GO TO 33 DO K=N1,N2 JD=JTGD(K) DC(JD+I)=DC(JD+J) ENDDO GO TO 36 ENDIF C MS=QBMS(J)+NF+NF+1 IF(MGE3)THEN IF(MS.NE.QCS)GO TO 33 IF(ML.GT.QCL)GO TO 33 IF(ML.LT.QCL-KG)GO TO 33 GO TO 36 ENDIF C DO K=N1,N2 C MOD>0 IF(M.GT.0)THEN IF(M.EQ.1)THEN IF(ML.GT.NI)GO TO 33 GO TO 17 ENDIF IF(ML.NE.0)GO TO 33 IF(MS.NE.NU)GO TO 33 GO TO 36 ENDIF C MOD=0 (NOW NEED ALL MS,ML FOR SUB-SHELL RE-COUPLING) IF(M.EQ.0)GO TO 36 CWE IF(M.EQ.0)THEN CWE IF(KCUT.EQ.0)GO TO 36!APPLY TO CORR ONLY? ->IF(.NOT.BCUT) CWE IF(MS.GT.QTGS(K)+2)GO TO 19 CWE IF(MS.GE.-1)GO TO 36 COLFS IF(MS+ML.GE.-1)GO TO 36 CWE GO TO 33 CWE ENDIF C MOD<0 17 IF(ML+MS.LT.0)GO TO 33 IF(IABS(MS).GT.QTGS(K))GO TO 19 IF(IABS(ML).GT.QTGL(K))GO TO 19 C IF(M.GE.-1)GO TO 36 IF(M.GE.-1)THEN IF(NAST.NE.0.AND.M.EQ.-1)THEN MDF=QTGS(K)-QTGL(K) IF(MS+ML.LT.IABS(MDF))GO TO 19 ENDIF GO TO 36 ENDIF IF(MS*ML.LT.0)GO TO 33 IF(NAST.NE.0.AND.M.EQ.-2)THEN C IF(MS.LT.QDS)GO TO 33 C IF(ML.LT.QDL)GO TO 33 IF(MS.LT.QTGS(K))GO TO 19 IF(ML.LT.QTGL(K))GO TO 19 ENDIF GO TO 36 C 19 ENDDO C GO TO 33 C 36 L=I QBML(L)=ML QBMS(L)=MS DO I=1,NF QLML(I,L)=QLML(I,J) QLMS(I,L)=QLMS(I,J) ENDDO C 33 CONTINUE C DO K=N1,N2 MTGD=L-JA+1+MTGD IF(MTGD.LE.MAXDC)THEN JD=MTGD-L DO J=JA,L IF(NB.EQ.0)THEN I=JTGD(K) DD=DC(J+I) ENDIF DC(J+JD)=DD ENDDO ENDIF JTGD(K)=JD ENDDO C 39 JB=L C C NORMAL RETURN (NB=0) FOR M.EQ.1 (AFTER 2ND ENTRY, THROUGH 30); C IF(NB.EQ.0)GO TO 999 C C INCASES MGE3=T OR KF.GT.KCUT: RETURN (NB=0) IF NO TERMS SL IN KF. C IF(N2.LT.N1)GO TO 88 C C AS PROBLEM TOO LARGE FOR VCC ARRAY DC(MAXDC). C IF(MTGD.GT.MAXDC)GO TO 999 C C----------------------------------------------------------------- C VCE BY SIMULTANEOUSLY DIAGONALIZING L**2 AND S**2 (IN SR VCE) C----------------------------------------------------------------- C IF(QCL0.LT.QCL)QCL0=QCL !GLOBAL MAX L IF(QCS0.LT.QCS)QCS0=QCS !GLOBAL MAX S C C NO VCC'S WILL BE COMPUTED IN 'DIMENSION CHECK ONLY' C IF(MSEQS)GO TO 88 !SO RETURN C ML=QCL IF(M.GT.1)QCL=0 C 85 MS=QCS C 86 NB=0 C DO J=JA,JB IF(QBML(J).EQ.ML.AND.QBMS(J).EQ.MS)THEN NB=NB+1 IF(NB.LE.MAXDF)NO(NB)=J ENDIF ENDDO C C BUFFER ARRAYS DU,DL,DS,NO (DA,DV) TOO SMALL (NB.GT.0); AUGMENT MAXDF C IF(NB.GT.MAXDF) GO TO 999 C IF(NB.EQ.0)GO TO 89 C C THIS CALL CAN BE REPLACED BY THE WHOLE BODY OF SR VCE. C NB0=NB C c call cpu_time(timei) c CALL VCE(QLML,QLMS,QBML,QBMS,DU,DL,DS,NO,MAXEL) C IF(NF.LE.0)GO TO 999 c c call cpu_time(timef) c write(71,*)'vce',nb,ml,ms,timef-timei c timev=timev+timef-timei C IF(NB.EQ.0)THEN !VCE DIAG FAILURE NB=NB0 GO TO 999 ENDIF C DO 81 L=1,NB C DO J=N1,N2 NRJ=JTGD(J) QL0=QTGL(J) QS0=QTGS(J) C C IDENTIFY L'TH TERM, RESULTING FROM DIAGONALIZING S*(S+1) AND C L*(L+1) FOR (MS,ML)/2, WITH ONE OF THE TERMS J=N1,N2 C IF(((QS0+2)*QS0-DS(L))**2 X +((QL0+2)*QL0-DL(L))**2.GT.NB*STOL*DPT1)GO TO 82 C C AND CROSS OUT THE EXHAUSTED TERM C QTGS(J)=QS0+1 C C SET UP VCC (EIGENV OF DIAGON.) IN APPROPRIATE LOCATION OF DC: C DO I=1,NB JD=NO(I)+NRJ DC(JD)=DU(I,L) ENDDO C C ESTABLISH PROPER PHASES WITH PREVIOUS (MS,ML); FOR DEGENERATE SL, C DO SO AFTER THE LAST TERM, QTGD=1, HAS BEEN FOUND. (NEW USE FOR MSEQS) C MSEQS=QTGD(J).LT.0 QTGD(J)=IABS(QTGD(J)) IF(MSEQS.OR.QTGD(J).GT.1)GO TO 81 C C NOTE HOW THE (IF-)LOOPS FOR MS AND ML ARE NESTED: STEP DOWN S C WITHIN EACH ML=CONST COMPLEX, AND APPLY L- ONLY IF MS=S C MSEQS=MS.EQ.QS0 N4=J N3=N4 GO TO 91 82 ENDDO C GO TO 81 C C ONLY IN CASE MGE3=T OR KF.GT.KCUT; SEE COMPLETENESS CHECK IN DO84 C 91 IF(N3.GT.N1)THEN !FOR STUPID COMPILERS IF(QTGD(N3-1).GT.1)THEN !BREAK INTO TWO N3=N3-1 GO TO 91 ENDIF ENDIF C IF(MSEQS)THEN DI=(QL0+ML+2)*(QL0-ML) ELSE DI=(QS0+MS+2)*(QS0-MS) ENDIF C DO 92 I=1,NB JD=NO(I) DD=DZERO DO J=N3,N4 NI=JTGD(J)+JD DD=DC(NI)**2+DD DC(NI)=DZERO ENDDO C IF(DD.LT.TTYNY)GO TO 92 C DO J=JA,JB C K=0 IF(MSEQS)K=2 IF(QBML(J)-K.NE.ML)GO TO 94 IF(QBMS(J)+K-2.NE.MS)GO TO 94 C DD=DZERO DO K=N3,N4 NI=JTGD(K)+J DD=DC(NI)**2+DD ENDDO C IF(DD.LT.TTYNY)GO TO 94 C KG=0 KP=0 C DO NI=1,NF KP=KP+NI DO K=1,NF IF(QLML(K,J).EQ.QLML(NI,JD))THEN C IF(QLMS(K,J).NE.QLMS(NI,JD) .OR. QCG(K).NE.QCG(NI)) IF(QCG(K)*QLMS(K,J).EQ.QCG(NI)*QLMS(NI,JD))THEN KP=KP-K GO TO 97 ENDIF ENDIF ENDDO IF(KG.NE.0)GO TO 94 KG=NI 97 ENDDO C C SLATER STATES J AND JD DIFFER IN ONE INDIVIDUAL SET, IN POSITION C KP AND KG; ENSURE THAT THE PAIR DOES NOT DIFFER IN NL: C NI=QCG(KP) IF(QCG(KG).EQ.NI)THEN IF(MSEQS)THEN DD=(QL(NI)+QLML(KP,J))*(QL(NI)-QLML(KG,JD)) ELSE DD=(1+QLMS(KP,J))*2 ENDIF DD=(-1)**(KG+KP)*SQRT(DD/DI) DO K=N3,N4 NI=JTGD(K)+JD DC(NI)=DD*DC(NI+J-JD)+DC(NI) ENDDO ENDIF 94 ENDDO C C SIGN ONLY NEEDS TO BE ESTABLISHED IF L'TH TERM SL NOT DEGENERATE C IF(N4.EQ.N3)THEN IF(ABS(DC(NRJ+JD)).GT.TYNY)GO TO 90 ENDIF C 92 CONTINUE C GO TO 81 90 DD=DC(NRJ+JD)/DU(I,L) C C VCC MAYBE TOO INACCURATE C IF(ABS(ABS(DD)-DONE).GT.STOL) THEN WRITE(6,*)"SR.VCU: ARE VCC'S ACCURATE ENOUGH? " WRITE(6,*)DC(NRJ+JD),DU(I,L),ABS(DD)-DONE IF(ABS(ABS(DD)-DONE).GT.100*STOL) THEN IF(IDIAG.EQ.0)THEN WRITE(6,1001)KF IDIAG=-1 GO TO 52 ENDIF GO TO 999 ENDIF ENDIF C IF(DD.LT.DZERO)THEN DO I=1,NB JD=NO(I)+NRJ DC(JD)=-DU(I,L) ENDDO ENDIF C 81 CONTINUE C C C RESTORE 2*S-ARRAY, WHICH HAS BEEN USED FOR MARKING: C DO J=N1,N2 IF((QTGS(J)/2)*2.EQ.QTGS(J)-NU)THEN IF(QTGL(J).LT.IABS(ML))GO TO 84 IF(QTGS(J).LT.IABS(MS))GO TO 84 C IF(IDIAG.EQ.0)THEN WRITE(6,1001)KF C IDIAG=-1 C GO TO 52 ENDIF IF(IDIAG.NE.0)WRITE(6,1000) WRITE(6,1002) J, MS,ML,NB, (DS(I),DL(I),I=1,NB) GO TO 999 ELSE QTGS(J)=QTGS(J)-1 ENDIF 84 ENDDO C 89 IF(MGE3)GO TO 87 !NORMAL RETURN FOR M.GE.3 C MS=MS-2 IF(MS+QCS.GE.0)GO TO 86 C 87 ML=ML-2 IF(ML+QCL.GE.0)GO TO 85 C 88 NB=0 C C CANCEL AUXILIARY SLATER STATES AND COEFFICIENTS BEFORE RETURNING; C IF(M.EQ.1)GO TO 30 C 999 CONTINUE C IDIAG=IDIAG0 C C DEALLOCATE (DU,STAT=IERR) !F95 IF(IERR.NE.0)THEN !F95 WRITE(0,*)'VCU: DE-ALLOCATION FAILS FOR DU ' !F95 NF=0 !F95 ENDIF !F95 C c c write(71,*)'vce total',timev c call flush(71) c timev=0.d0 C RETURN C C NORMAL RETURN FOR M.NE.1 C KF.GT.KCUT(.GT.0): ONLY THOSE TERMS RETAINED THAT SERVE AS CORRE- C LATION TERMS TO TERMS OF PREVIOUS CONFIGURATIONS KF. C M.EQ.0: ALL VCC FOR ALL COMPLETE TERMS I OF CONFIG C STORED IN DC C OLD RESTRICTIONS SUPRESSED NOW THAT WE RE-COUPLE SUB-SHELLS CWE PROVIDED KCUT=0 IS SPECIFIED (WHICH DEFAULTS TO KCUT.GE.KF) CWE OTHERWISE RESTRICTIONS ON MS APPLY: SEE LOOP DO33. CWE COLFS MAY HAVE TO BE OPENED FOR FS-COLLISION PROBLEMS. C M.EQ.1: ONLY VCC FOR SLATSTATES WITH /ML=MS/=MIN OF ALL TERMS K OF C C M.EQ.2: ONLY VCC FOR SLATSTATES WITH ML=0,MS=MIN OF ALL TERMS K OF C C M.GE.3: ONLY SLSTATES AND VCC WITH ML=L,MS=S OF TERM 2S=QCS0,2L=QCL0 C M.LE.-3: ANY ML=L-1 ALSO INCLUDED (KCUT IGNORED FOR IABS(M).GE.3) C M.EQ.-1,M.EQ.-2 EQUIV+1,2 FOR ML,MS.LT.0, BUT ALL -,-.GT.0 RETAINED C NOTE: AT THE BEGINNING FOR ANY M STORAGE FOR ALL SLATER STATES C REQUIRED, AND FOR M=1 SOME VCC BUFFER IN DC (SEE LOOP 33). C CODE OF UNSUCCESSFUL RETURNS (NB.NE.0): C NB=-5: TOO MANY CONFIGURATIONS - NOT USED C -4: TOO MANY ELECTRONS; AFFECTS QLMS,QLML C -3: TOO MANY SLATER STATES; " " AND QBMS,QBML C -2: TOO MANY TERMS; AFFECTS QTGS,QTGL,QTGD,JTGD C -1: TOO MANY VCC; AFFECTS DC(MAXDC) C .GT.MAXDF: BUFFER ARRAYS DA,DU,DV,DL,DS,NO TOO SMALL C .GT.0: NUMERICAL TROUBLE-ACCURACY. C 1000 FORMAT(//' VCE FAILS -- EIGENVALUES INACCURATE-CHECK FOR ENOUGH' X,' SWEEPS IN JACORD') c 1001 FORMAT(//' HOUSEHOLDER-QL METHOD FAILS FOR SIMULTANEOUS', c X' DIAGONALIZATION OF S**2 AND L**2 MATRICES'/' TRY THE (SLOWER)' c X,' JACOBI METHOD INSTEAD: ***SET IDIAG=1*** IN NAMELIST SALGEB') 1001 FORMAT(//' NOTE: HOUSEHOLDER-QL METHOD FAILS FOR SIMULTANEOUS', X' DIAGONALIZATION OF S**2 AND L**2 MATRICES'/' TRYING THE' X,' (SLOWER) JACOBI METHOD INSTEAD FOR THIS CF=',I3,' ONLY.') 1002 FORMAT(/4I5,10F10.5/(20X,10F10.5)) C END C C ******************* C SUBROUTINE VFREE(YFREE,EFREE,NION,TPLASMA,Z,RION,NOO,MKK) C C----------------------------------------------------------------------- C C SR.VFREE EVALUATES A SELF-CONSISTENT FREE ELECTRON PLASMA POTENTIAL C FOR A FIXED BOUND STATE CONFIGURATION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C LOGICAL BSTO,BCORE,BFIX C PARAMETER(NOD=2000) C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D1P1=1.0D1) PARAMETER (D1M2=1.0D-2) PARAMETER (A1=+0.3480242D0) PARAMETER (A2=-0.0958798D0) PARAMETER (A3=+0.7478556D0) PARAMETER (PP=0.47047D0) C DIMENSION MEL(MAXGR) DIMENSION DENB(NOD),DENF(NOD),DENF1(NOD),YFREE(NOD) DIMENSION YXC(NOD),EDP(NOD) C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /MQVC/MDUM,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /RADF/P(MAXB1,MAXGR),DUY(MAXGR,MAXGR),R(MAXB1) X ,DORIG(MAXGR) COMMON /NRB/MAUTO,MODE,HACE,BSTO,MSH,MORT,MGRP COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX,NOCC0 X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) C C ERROR FUNCTION C ERF(XX)=DONE-(A1/(DONE+PP*XX)+A2/(DONE+PP*XX)**2+A3/(DONE+PP*XX) X **3)*EXP(-XX**2) C PI=ACOS(-DONE) C C NO. OF SELF-CONSISTENT ITERATIONS ALLOWED C NITT=20 C C DIMENSION CONSISTANCY CHECK C IF(NOD.GT.MAXB1)THEN WRITE(6,*)'*** DIMENSION ERROR IN SR.VFREE, INCREASE MAXB1 TO: ' X ,NOD WRITE(0,*)'INCREASE MAXB1' GO TO 999 ENDIF C NOCC=MOD(NOCC0,1000) IF(NOCC.NE.0)THEN NWF=IABS(NOCC) GO TO 30 !USER INPUT OCCUPATION NOS ENDIF C C DETERMINE OCCUPATION NUMBERS C NWF0=MAXGR DO J=1,NWF0 TEL(J)=DZERO MEL(J)=0 IF(DEY(J).NE.DZERO)NWF=J ENDDO C MK=IABS(MKK) C IF(MORT.LT.0.AND.BSTO.AND.MK.NE.0)THEN C C DETERMINE OCCUPTN NUMBERS FOR CONFIGURATION SPECIFIED FOR THIS ORBITAL BCORE=MK.GE.MA.AND.MK.LE.MB KAV=0 IF(MCFMX.GT.0)THEN IF(MK.GT.MCFMX)THEN KS=MCFSTO(MCFMX) ELSE KS=MCFSTO(MK) ENDIF KF=KS ELSE C USE CONFIGURATION AVERAGE KS=1 KF=KMAX IF(KCUT.GT.0)KF=KCUT IF(mcfmx.lt.0)kf=min(-mcfmx,kmax) ENDIF C DO K=KS,KF IF(.NOT.BCORE.and.mcfmx.ge.0)THEN C C AVERAGE OVER ONLY THOSE CONFIGS THAT CONTAIN MK. DO I=1,NF IF(QCG(I,K).EQ.MK)GO TO 81 ENDDO IF(MCFMX.LE.0)GO TO 83 WRITE(6,1010)MK,K WRITE(0,*)'*****ERROR IN SR.VFREE, ORBITAL NOT FOUND' GO TO 999 ENDIF C USE MCFMX.LT.0 TO AVERAGE OVER ALL CONFIGS C 81 KAV=KAV+1 C C EQUAL WEIGHTING, COULD TRY ALTERNATIVE...... DO L=1,NF I=QCG(L,K) IF(QN(I).GT.0.AND.QN(I).LT.90)MEL(I)=MEL(I)+1 ENDDO 83 ENDDO C IF(MB.GT.0)THEN DO I=MA,MB MEL(I)=MEL(I)+2*(QL(I)+1)*KAV ENDDO ENDIF T1=KAV C WRITE(6,*) MK DO J=1,NWF T2=MEL(J) TEL(J)=T2/T1 C WRITE(6,*)J,TEL(J) ENDDO C ELSE C C CHOOSE FIRST SUITABLE BOUND (MKK.GE.0) OR CONTINUUM (MKK.LT.0) CONFIG. C IF(MA*MB.GT.0)THEN DO I=MA,MB TEL(I)=2*(QL(I)+1) ENDDO ENDIF C DO M=1,MAXCF I=QCG(NF,M) IF(MKK.GE.0.AND.QN(I).GE.0.AND.QN(I).LT.90)GO TO 9 IF(MKK.LT.0.AND.(QN(I).LT.0.OR.QN(I).GE.90))GO TO 9 ENDDO C 9 DO N=1,NF I=QCG(N,M) IF(QN(I).GT.0.AND.QN(I).LT.90)TEL(I)=TEL(I)+DONE ENDDO C ENDIF C C RE-ENTRY POINT FOR USER SUPPLIED OCCUPATION NOS C 30 CONTINUE C C RION=(0.2387*(Z-N)/DPLASMA)**0.3333 C NO=NOO MAXP=NION DO I=1,MAXP IF(R(I).GT.RION)GO TO 2 ENDDO I=MAXP 2 NION=I IF(NION.GT.NOD)THEN WRITE(6,1000)NION C NION=NOD WRITE(0,*)' ***SR.VFREE REQUIRES LARGER NOD' GO TO 999 ENDIF IF(NO.GT.NOD)THEN WRITE(6,1000)NO C NO=NOD WRITE(0,*)' ***SR.VFREE REQUIRES LARGER NOD' GO TO 999 ENDIF C C EPS--CONVERGENCE FACTOR C PAR--ASYMPTOTIC PARAMETER FOR ERROR FUNCTION C EPS=D1M2 PAR=D1P1 C C ZERO ARRAYS C DO I=1,NO DENB(I)=DZERO DENF(I)=DZERO DENF1(I)=DZERO YFREE(I)=DZERO YXC(I)=DZERO EDP(I)=DZERO ENDDO C C CALCULATE BOUND ELECTRON DENSITY C WOCC=DZERO DO J=1,NWF IF(TEL(J).NE.DZERO)THEN WOCC=WOCC+TEL(J) C=TEL(J)/(DFOUR*PI) DO I=1,NO DENB(I)=DENB(I)+C*P(I,J)**2/R(I)**2 !R(I)**2 NOT R(I) ENDDO ENDIF ENDDO C C CALCULATE UNIFORM FREE ELECTRON DENSITY C DO I=1,NION DENF(I)=(Z-WOCC)/((DFOUR/DTHREE)*PI*RION**3) ENDDO C C BEGIN SELF-CONSISTENT LOOP C DO ITT=1,NITT C C CALCULATE TOTAL POTENTIAL AND THEN FREE ELECTRON DENSITY C DO K=1,NION C C CALCULATE ELECTROSTATIC POTENTIAL C V1=(R(1)/DTWO)*((DENF(1)+DENB(1))*R(1)**2)/R(K) IF(K.GE.2)THEN DO J=2,K V1=V1+((R(J)-R(J-1))/DTWO)*((DENF(J)+DENB(J))*R(J)**2 X +(DENF(J-1)+DENB(J-1))*R(J-1)**2)/R(K) ENDDO ENDIF V2=DZERO DO J=K+1,NION V2=V2+((R(J)-R(J-1))/DTWO)*((DENF(J)+DENB(J))*R(J) X +(DENF(J-1)+DENB(J-1))*R(J-1)) ENDDO C C CALCULATE EXCHANGE-CORRELATION POTENTIAL C WITH SELF-INTERACTION CORRECTION C DENT=DENB(K)+DENF(K) CALL VXC(DENT,TPLASMA,UXCT) C DENT=DENB(K) CALL VXC(DENT,TPLASMA,UXCB) C VTOT=DFOUR*PI*(V1+V2)+UXCT-UXCB-Z/R(K) C C CALCULATE FREE ELECTRON DENSITY FOR NEW POTENTIAL C WA=-VTOT/TPLASMA IF(WA.LE.DZERO)THEN DENF1(K)=EXP(WA) ELSEIF(WA.GT.DZERO.AND.WA.LE.PAR)THEN DENF1(K)=EXP(WA)*(DONE-ERF(SQRT(WA)))+DTWO/SQRT(PI/WA) ELSEIF(WA.GT.PAR)THEN DENF1(K)=DTWO*SQRT(WA/PI)+DONE/SQRT(PI*WA) ENDIF C IF(K.EQ.1)THEN ANF=(R(K)/DTWO)*DFOUR*PI*(DENF1(K)*R(K)**2) ELSE ANF=ANF+((R(K)-R(K-1))/DTWO)*DFOUR*PI*(DENF1(K)*R(K)**2 X +DENF1(K-1)*R(K-1)**2) ENDIF C ENDDO C C NORMALIZE FREE ELECTRON DENSITY C DO K=1,NION DENF1(K)=DENF1(K)*(Z-WOCC)/ANF ENDDO C C SELF-CONSISTENT CHECK C AA=ABS(DENF(1)-DENF1(1)) T=(R(1)/DTWO)*DFOUR*PI*AA*R(1)**2 QU=INT(T) DO K=2,NION AA=ABS(DENF(K)-DENF1(K)) BB=ABS(DENF(K-1)-DENF1(K-1)) T=((R(K)-R(K-1))/DTWO)*DFOUR*PI*(AA*R(K)**2+BB*R(K-1)**2) QU=QU+INT(T) ENDDO C IF(QU.LE.EPS*(Z-WOCC))GO TO 101 C DO K=1,NION DENF(K)=DENF1(K) ENDDO ENDDO C WRITE(6,*)'CONVERGENCE FAILURE IN VFREE' WRITE(0,*)'CONVERGENCE FAILURE IN VFREE' GO TO 999 C C END SELF-CONSISTENT LOOP C 101 CONTINUE C C FINAL CALCULATION FOR FREE ELECTRON POTENTIAL C DO K=1,NION C V1=(R(1)/DTWO)*(DENF1(1)*R(1)**2)/R(K) IF(K.GE.2)THEN DO J=2,K V1=V1+((R(J)-R(J-1))/DTWO)*(DENF1(J)*R(J)**2 X +DENF1(J-1)*R(J-1)**2)/R(K) ENDDO ENDIF V2=DZERO DO J=K+1,NION V2=V2+((R(J)-R(J-1))/DTWO)*(DENF1(J)*R(J) X +DENF1(J-1)*R(J-1)) ENDDO C DENT=DENF1(K) CALL VXC(DENT,TPLASMA,UXC) C YXC(K)=UXC YFREE(K)=DFOUR*PI*(V1+V2)+UXC C DENT=DENB(K)+DENF1(K) CALL WXC(DENT,TPLASMA,FXCT) C DENT=DENB(K) CALL WXC(DENT,TPLASMA,FXCB) C EDP(K)=DENB(K)*(YFREE(K)-YXC(K))+FXCT-FXCB C ENDDO C C SCREENING CORRECTION TO BOUND ELECTRON ENERGY C EFREE=(R(1)/DTWO)*EDP(1)*R(1)**2 DO J=2,NION EFREE=EFREE+((R(J)-R(J-1))/DTWO)*(EDP(J)*R(J)**2 X +EDP(J-1)*R(J-1)**2) ENDDO C EFREE=DFOUR*PI*EFREE C RETURN C 999 NF=-1 RETURN C 1000 FORMAT(' ***SR.VFREE REQUIRES NOD AT LEAST',I5) 1010 FORMAT(' *****ERROR IN SR.VMPOT, ORBITAL',I4,' NOT FOUND IN' X,' CONFIGURATION',I4) C END C C ******************* C REAL*8 FUNCTION VLAM(LAM,K1,K2,K3,K4) C C----------------------------------------------------------------------- C C FN.VLAM EVALUATES THE V-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION, IT C IS NOT QUITE SAME AS V-LAMDA INTEGRAL OF SPIN-ORBIT, NO PARTIAL DIFF. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXPS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBNF2/D1(MAXB1),D2(MAXB1),D3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C DO I=1,MAXPS D1(I)=DPNL(I,K2)*DPNL(I,K4) ENDDO M=QL(K2)/2+QL(K4)/2+2 C IF(BREL)THEN !SMALL R CORRECTION DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DEL=DE2-DE4 ! A.U. DZ=NZION T=C4*DTWO IF(BREL2)THEN DO I=1,MAXPS DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) C DD2=DONE+T*(DE2+POT(I,1)) C DD4=DONE+T*(DE4+POT(I,1)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ ENDDO ELSE dd=rnorm(k2)*rnorm(k4) DO I=1,MAXPS DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) c dd2=done+t*(de2+dz/dx(i)) c dd4=done+t*(de4+dz/dx(i)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D1(I)=D1(I)*dd/DSQ ENDDO ENDIF CALL YLAMKR(LAM,M,DEL,D1,D2,DD1,DD2,MNE,DHNS,MJH,-3) ELSE CALL YLAMK(LAM,M,D1,D2,DD1,DD2,MNE,DHNS,MJH,-3) ENDIF C DO I=1,MAXPS D1(I)=D2(I)*DPNL(I,K1)*DPNL(I,K3) ENDDO C IF(BREL)THEN !SMALL R CORRECTION DE1=DEY(K1)-DUY(K1,K1) DE3=DEY(K3)-DUY(K3,K3) DEL=DE1-DE3 ! A.U. IF(BREL2)THEN DO I=1,MAXPS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD3=DONE+T*(DE3+POT(I,1)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ ENDDO ELSE dd=rnorm(k1)*rnorm(k3) DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) c dd1=done+t*(de1+dz/dx(i)) c dd3=done+t*(de3+dz/dx(i)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)*dd/DSQ ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,D1,TT,MNE,DHNS,MJH,MAXPS) C VLAM=DALF*TT/DFOUR C C WRITE(6,100) K1, K2, K3, K4, 2*LAM, VLAM C100 FORMAT(8X,2(I5,I4),I6,F14.7,' =VLAM') C RETURN END C C ******************* C SUBROUTINE VLAM0(M0,K1,K2,K3,K4,K,DK) C C----------------------------------------------------------------------- C C SR.VLAM0 EVALUATES THE V-INTEGRALS OF THE SPIN-ORBIT INTERACTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C DZ=NZION DD=DONE D00=DZERO C DO I=1,MAXRS DPA(I)=DPNL(I,K3)/DX(I) ENDDO C CALL DIFF(DPA,DP,MNH,DHNS,MJH) C DO I=1,MAXRS DPA(I)=DPNL(I,K1)*DP(I)*DX(I) ENDDO C I=(QL(K1)+QL(K3))/2+1 IF(QL(K3).EQ.0) I=I+1 C IF(BREL)THEN !SMALL R CORRECTION DE1=DEY(K1)-DUY(K1,K1) DE3=DEY(K3)-DUY(K3,K3) DEL=DE1-DE3 ! A.U. IF(BREL2)THEN T=C4*DTWO DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD3=DONE+T*(DE3+POT(I,1)) D13=DD1*DD3 d13=abs(d13) DPA(I)=DPA(I)/SQRT(D13) ENDDO ELSE c t=c4*dtwo DO I=1,MAXRS DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) c dd1=done+t*(de1+dz/dx(i)) c dd3=done+t*(de3+dz/dx(i)) D13=DD1*DD3 d13=abs(d13) DPA(I)=DPA(I)/SQRT(D13) ENDDO dd=dd*rnorm(k1)*rnorm(k3) ENDIF CALL YLAMKR(K,I,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,M0) ELSE CALL YLAMK(K,I,DPA,DP,DD1,DD2,MNH,DHNS,MJH,M0) ENDIF C DO I=1,MAXRS DP(I)=DPNL(I,K2)*DPNL(I,K4)*DP(I)*DX(I) ENDDO C IF(BREL)THEN !SMALL R CORRECTION DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DEL=DE2-DE4 ! A.U. IF(BREL2)THEN T=C4*DTWO DO I=1,MAXRS DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) C DD2=DONE+T*(DE2+POT(I,1)) C DD4=DONE+T*(DE4+POT(I,1)) D24=DD2*DD4 d24=abs(d24) DP(I)=DP(I)/SQRT(D24) ENDDO ELSE c t=c4*dtwo DO I=1,MAXRS DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) c dd2=done+t*(de2+dz/dx(i)) c dd4=done+t*(de4+dz/dx(i)) D24=DD2*DD4 d24=abs(d24) DP(I)=DP(I)/SQRT(D24) ENDDO dd=dd*rnorm(k2)*rnorm(k4) ENDIF ENDIF C CALL WEDDLE(D00,DP,DKU,MNH,DHNS,MJH,MAXRS) C DK=DKU*DD*C4 C RETURN END C C ******************* C SUBROUTINE VMPOT(ZN,L,MAXRS,DX,DZ,MAXPS,MPP,MK) C C----------------------------------------------------------------------- C C SR.VMPOT EVALUATES A MODEL POTENTIAL C C POLARIZATION: NORCROSS OR BAYLISS FORM C OR C DENSE PLASMA POTENTAL: DEBYE-HUCKEL, ION-SPHERE OR SELF-CONSISTENT C FREE-ELECTRON. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (D1M20=1.0D-20) PARAMETER (D5M2=5.0D-2) PARAMETER (DCON1=0.23873D0) C DIMENSION DX(*) C COMMON /BASIC/NF,MGAP(11) COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 C IF(ZNP.EQ.ZN)GO TO 900 !RETURN C DO I=1,MAXRS VSC(I)=DZERO ENDDO c c Add C60 potential !!! c c do i=1,maxrs c if(dx(i).gt.5.8.and.dx(i).lt.7.5)vsc(i)=vsc(i)+.604154/2 c enddo C IF(L.LT.0)GO TO 900 !RETURN C ZNP=ZN C IF(IPOLFN.LE.0)GO TO 6 C LP=L+1 IF(LP.GT.3)LP=3 cold IF(ALFD(LP)*RCUT(LP).EQ.DZERO)GO TO 6 C C ONE-BODY POLARIZATION POTENTIAL C ZNP=-99 IPOLF1=MOD(IPOLFN,10) C IF(IPOLF1.EQ.1)THEN C NORCROSS DO I=1,MAXRS VSC(I)=ALFD(LP)*(DONE-EXP(-(DX(I)/RCUT(LP))**6))/DX(I)**4 ENDDO ELSEIF(IPOLF1.EQ.2)THEN C BAYLISS DO I=1,MAXRS VSC(I)=ALFD(LP)*DX(I)*DX(I)/(DX(I)*DX(I)+RCUT(LP)*RCUT(LP))**3 ENDDO ENDIF C C EVALUATE PLASMA SCREENING POTENTIAL: C CAN NEGLECT PLASMA SCREENING POTENTIAL COMPARED TO NUCLEAR C (TO WITHIN 100*TF%) FOR X.LT.XC1. C PLASMA SCREENING COMPLETE FOR X.GT.XC2. C 6 IF(MDEN.LE.0)GO TO 900 !RETURN C TF=D5M2 IF(MDEN.NE.1)GO TO 2 C C DEBYE-HUCKEL C XC1=LOG(DONE-TF)*DEBYE XC2=LOG(TF)*DEBYE DO I=1,MAXRS T=DX(I) TZ=-ZN/T T=-T/DEBYE VSC(I)=TZ*(DONE-EXP(T)) ENDDO GO TO 900 !RETURN C C ION-SPHERE C 2 ZN1=ZN IF(MK.GE.0)ZN1=ZN1-DONE R0=ZN1 R0=R0*DCON1/DENE R0=R0**(DONE/DTHREE) XC1=(DTWO/DTHREE)*TF*R0 XC2=R0 C IF(MDEN.NE.2)GO TO 4 IF(DENE.LT.D1M20)GO TO 900 !RETURN C TZ=-ZN1/(R0*DTWO) DO I=1,MAXRS T=DX(I) VSC(I)=-ZN1/T T=T/R0 IF(T.LT.DONE)VSC(I)=TZ*(DTHREE-T*T) ENDDO GO TO 900 !RETURN C C SELF-CONSISTENT FREE ELECTRON POTENTIAL C 4 MP0=MP0+1 C WRITE(6,*)MPP,MP0,MK C C USE STORAD TO INITIALIZE PNL WITH STO'S AND SO DO NOT RETURN C IF(MPP.EQ.1.AND.MP0.EQ.1.AND.MK.GE.0)CALL STORAD(ZN,MAXRS,MAXPS) C NION=MAXRS CALL VFREE(VSC,T,NION,TKAY,DZ,R0,MAXPS,MK) C IF(NF.LE.0)GO TO 900 !RETURN C DO I=1,NION VSC(I)=-VSC(I) C WRITE(6,*)I,DX(I),VSC(I) ENDDO C C WRITE(6,*)R0 C ZN1=-DX(NION)*VSC(NION) C NT=1 DO I=NION+1,MAXRS VSC(I)=-ZN1/DX(I) C C TEST NEUTRALIZATION EFFECT IF(MK.GE.0)VSC(I)=VSC(I)-(DX(I)-R0)**NT/DX(I)**(NT+1) C VSC(I)=VSC(I)-(DONE-EXP(DONE-DX(I)/R0))/DX(I) C WRITE(6,*)I,DX(I),VSC(I) ENDDO C 900 RETURN END C C ******************* C SUBROUTINE VNRKX(DP1,DP2,DQ1,DQ2,DE1,DE2,DPA,DP,DX,dnorm,DD) C C----------------------------------------------------------------------- C C SR.VNYKX CALCULATES THE DEIE V & N "RK" FINE-STRUCTURE INTEGRAL C C IT CALLS: C SR.WEDDLE C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (C4=DFSC**2/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*) C c common /com1/dpot(maxb1),tol,mend COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JEND(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C C BREL2=IABS(IREL).EQ.2 C DO I=1,MAXRS DPA(I)=DP1(I)*DP(I)*DP2(I) ENDDO C IF(BREL)THEN C DEL=DE1-DE2 ! A.U. T=C4*DTWO DZ=NZION IF(BREL2)THEN DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+DPOT(I)) C DD2=DONE+T*(DE2+DPOT(I)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)/DSQ ENDDO ELSE DO I=1,MAXRS DD1=DONE+C4*(DQ1(I)/DP1(I)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) DD2=DONE+C4*(DQ2(I)/DP2(I)+DTWO*DZ/DX(I)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)*dnorm/DSQ ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,DPA,DD,MNH,DHNS,MJH,MAXRS) C DD=DD*C4 C RETURN END C C ******************* C SUBROUTINE VNYKX(DP1,DP2,DQ1,DQ2,BINT,MI,ML,DE1,DE2,DPA,DP,DX X ,dnorm) C C----------------------------------------------------------------------- C C SR.VNYKX CALCULATES THE DEIE V & N "YK" FINE-STRUCTURE INTEGRAL C C IT CALLS: C SR.DIFF C SR.YLAMKR C SR.YLAMK C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (DFSC=DONE/137.03599976D0) PARAMETER (C4=DFSC**2/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2,BINT C DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*) C c common /com1/dpot(maxb1),tol,mend COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JEND(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C C BREL2=IABS(IREL).EQ.2 C IF(BINT)MJ0=3 !N IF(.NOT.BINT)MJ0=-3 !V C IF(BINT)THEN DO I=1,MAXRS DPA(I)=DP2(I)*DP1(I) ENDDO ELSE DO I=1,MAXRS DPA(I)=DP2(I)/DX(I) ENDDO C CALL DIFF(DPA,DP,MNH,DHNS,MJH) C DO I=1,MAXRS DPA(I)=DP1(I)*DP(I)*DX(I) ENDDO ENDIF C IF(BREL)THEN DEL=DE1-DE2 ! A.U. T=C4*DTWO DZ=NZION IF(BREL2)THEN DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD2=DONE+T*(DE2+DZ/DX(I)) C DD1=DONE+T*(DE1+DPOT(I)) C DD2=DONE+T*(DE2+DPOT(I)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)/DSQ ENDDO ELSE DO I=1,MAXRS DD1=DONE+C4*(DQ1(I)/DP1(I)+DTWO*DZ/DX(I)) if(dd1.le.dzero)dd1=done+t*(de1+dz/dx(i)) DD2=DONE+C4*(DQ2(I)/DP2(I)+DTWO*DZ/DX(I)) if(dd2.le.dzero)dd2=done+t*(de2+dz/dx(i)) DSQ=DD1*DD2 DSQ=SQRT(DSQ) DPA(I)=DPA(I)*dnorm/DSQ ENDDO ENDIF CALL YLAMKR(MI,ML,DEL,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0) ELSE CALL YLAMK(MI,ML,DPA,DP,DD1,DD2,MNH,DHNS,MJH,MJ0) ENDIF C IF(.NOT.BINT)THEN DO I=1,MAXRS DP(I)=DP(I)*DX(I) ENDDO ENDIF C RETURN END C C ******************* C SUBROUTINE VPNL(Z,MION,MKK,WK,AJUST0,MAXRS,MJH,MNE,DHNS,POT,DTOL X ,MEND) C C----------------------------------------------------------------------- C C SR.VPNL EVALUATES THE BOUND ELECTRON POTENTIAL FOR A FIXED BOUNDSTATE C CONFIGURATION. FOR USE WITH GENRATION OF A SELF-CONSISTENT RADIAL C SOLUTION. USES NL SUB-SHELL RESOLUTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (MXD01=14) C PARAMETER (MT=60) !~3*max atomic orb 2*l C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (dthree=3.0D0) PARAMETER (D0PT8=0.8D0) PARAMETER (D7999=7999.0D0) PARAMETER (DKEY=5999) parameter (dfsc2=3.6486763d-03) !alpha/2 PARAMETER (TOLW=1.D-3) !TOLERANCE FOR MATCHING OCCUPATION NOS WK parameter (tolp0=5.d-2) !defines end of wavefunction parameter (sigma=0.2d0) !for exchange gaussian damping factor C LOGICAL BCORE,BEQNL,BREL,BJUMPR,BMVD,BREL2,BJUMP,BJUMP2,BRAD,BFIX x ,bdw C DIMENSION MEL(MAXGR),MNE(MJH),DHNS(MJH),POT(MAXB1),DFS(MT+1) C COMMON /BASIC/NF,MGAP(11) COMMON /CHARY/DEY(MAXGR) COMMON /COM6/DA(MAXB1) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DAJOLD(MXVAR),SCREEN(MAXGR),MMMM,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /MQVC/MDUM,KCUT,QGAP(2),NEL(MAXGR,MAXCF) COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),R(MAXB1) X ,DORIG(MAXGR) COMMON /NRBAL1/MSTAT(MAXCF),KMAX,NPRINT,MR,MA,MB,KSUBCF COMMON /NRBDQE/DQNL(MAXB2,MAXGR) COMMON /NRBDW/IDW,IGAP(MXD01) COMMON /NRBFR/DP(MAXB1) COMMON /NRBHF/MHF,MRAD,MSTEP COMMON /NRBORB/IEQ(0:MAXGR),IGRCF(MAXGR),IGRGR(MAXGR),IRLX COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit COMMON /NRBSTO/ALF(MAXGR),MC(MAXGR),TEL(MAXGR),MCFMX0,NOCC0 X ,MCFSTO(MAXGR),MEXPOT,NLSTOE,BFIX(MAXGR) COMMON /NRBVAL/FACT(MAXGR),IVAL(MAXGR),BJUMP,BJUMP2,BRAD X ,NNEW,NNOLD c common /nrbinf/rinf2(maxgr) C DFS(1)=1 DFS(2)=1 DO K=3,MT,2 DFS(K)=-DFS(K-2) DFS(K+1)=(K-1)*DFS(K-1)/32 ENDDO C BREL2=IABS(IREL).EQ.2 MK=IABS(MKK) !MKK.LT.0 CURRENTLY NOT USED MS=MK IF(MK.GT.0)THEN IF(QN(MK).LT.0)MS=-MS IVALMK=IVAL(MK) ELSE IVALMK=0 ENDIF C AJUST=AJUST0 !(EXCHANGE) SCALING FACTOR IF(AJUST.EQ.DZERO)AJUST=DONE if(nocc0.lt.0)then AJUST=D0PT8*AJUST !A LA COWAN else AJUST=DZERO !FAC - NX DEFAULT? endif C MCFMX=MCFMX0 IF(MCFMX.GT.1000)MCFMX=0 !AVERAGE OVER MOD(MCFMX0,1000) C IF(NOCC0.LT.0)TOLX=10000 IF(NOCC0.GT.0)TOLX=10000 if(nocc0.eq.0)then if(mion.ge.0)stop 'nocc0=0 - inform nrb' !shouldn't happen endif C NOCC=MOD(NOCC0,1000) C C USER INPUT OCCUPATION NOS C IF(NOCC.NE.0)THEN NCO=0 IF(MA*MB.GT.0.AND.(MION.LT.0.OR.MK.EQ.0))THEN !FOR CORE POT DO I=MA,MB NCO=NCO+NINT(TEL(I)) ENDDO ENDIF MSHELL=IABS(NOCC) ISWCH0=0 DO I=1,MAXGR IF(QN(I).LT.0.OR.IVAL(I).NE.0.OR.SCREEN(I).GE.D7999)ISWCH0=1 ENDDO ISWCH=0 IF(MK.GT.0)THEN IF(QN(MK).LT.0.OR.IVAL(MK).NE.0.OR.SCREEN(MK).GE.D7999)ISWCH=1 ENDIF TZ=ISWCH0-ISWCH GO TO 30 ENDIF C C DETERMINE OCCUPATION NUMBERS INTERNALLY C DO J=1,MAXGR TEL(J)=DZERO MEL(J)=0 ENDDO C MSHELL=0 WK=0 NZ=0 C IF(MK.NE.0.AND.MION.GT.0)THEN C BCORE=MK.GE.MA.AND.MK.LE.MB KAV=0 C IF(MCFMX.GT.0.AND.(IEQ(0).GE.0.OR.IEQ(0).LT.0.AND.BCORE))THEN C C DETERMINE OCCUPATION NUMBERS FOR CONFIG. SPECIFIED FOR THIS ORBITAL C IF(MK.GT.MCFMX)THEN KS=MCFSTO(MCFMX) ELSE KS=MCFSTO(MK) ENDIF KF=KS ELSE C C USE CONFIGURATION AVERAGE C KS=1 KF=KMAX IF(IEQ(0).GE.0)THEN IF(KCUT.GT.0)KF=MIN(KCUT,KMAX) IF(MCFMX0.GT.1000)KF=MIN(MOD(MCFMX0,1000),KMAX) !SO NOT KCUT IF(mcfmx.lt.0)kf=min(-mcfmx,kmax) ENDIF ENDIF C 89 bdw=idw.ne.0.and.qn(mk).lt.0 c allow target average but an override for cont e.g. Laguerres if(bdw.and.mcfsto(mk).ne.0)then ks=mcfsto(mk) kf=ks endif c DO K=KS,KF IF(.NOT.BCORE.and.mcfmx.ge.0)THEN C C AVERAGE OVER ONLY THOSE CONFIGS THAT CONTAIN MK. C DO I=1,NF IF(QCG(I,K).EQ.MK)THEN IF(IEQ(0).LT.0.AND.MCFSTO(MK).EQ.0)MCFSTO(MK)=K GO TO 81 ENDIF ENDDO IF(MCFMX.LE.0)then if(bdw)go to 81 GO TO 83 ENDIF COLD IF(IVAL(MK).GT.0.OR.SCREEN(MK).GT.DKEY)GO TO 81 MF=QCG(NF,K) IF(SCREEN(MK).GT.DKEY.AND.(QN(MF).LT.0.OR.IVAL(MF).NE.0.OR. X SCREEN(MF).GT.DKEY).or.bdw)GO TO 81 IF(IEQ(0).LT.0)GO TO 83 MS=0 IF(MHF.GE.-100.OR.MK.NE.MCFMX)THEN !SHOULD BE CAUGHT... WRITE(6,1010)MK,K WRITE(0,*)'*****ERROR IN SR.VPNL: ORBITAL NOT FOUND IN CF' GO TO 999 ENDIF ENDIF C C USE MCFMX.LT.0 TO AVERAGE OVER ALL CONFIGS C 81 KAV=KAV+1 C C EQUAL WEIGHTING, COULD TRY ALTERNATIVE...... C DO 85 L=1,NF I=QCG(L,K) NZ=NZ+1 IF(IVAL(I).GT.0.AND.(QN(I).GE.IABS(QN(MK)).OR.QN(MK).LT.0)) X GO TO 85 if(dajold(i).lt.dzero.and.qn(mk).lt.0)go to 85 !for dw IF(SCREEN(I).GT.DKEY)GO TO 85 IF(QN(I).LT.0)GO TO 85 NZ=NZ-1 IF(I.GT.MSHELL)MSHELL=I MEL(I)=MEL(I)+1 85 ENDDO IF(MS.GT.MAXGR.OR.MS.LT.0.OR.IVAL(MK).GT.0)NZ=NZ-1 83 ENDDO C IF(KAV.EQ.0)THEN IF(MCFMX0.EQ.0.AND.KF.LT.KMAX)THEN !CORRELATION ORBITAL KF=KMAX !NOT IN KCUT, SO GO TO 89 ELSE WRITE(6,1011)MK,KF WRITE(0,*)'*****ERROR IN SR.VPNL: ORBITAL NOT FOUND IN CFS' GO TO 999 ENDIF ENDIF C IF(MB.GT.0)THEN DO I=MA,MB IF(I.GT.MSHELL)MSHELL=I MEL(I)=MEL(I)+2*(QL(I)+1)*KAV ENDDO ENDIF T1=KAV TZ=NZ TZ=TZ/T1 NZ=NINT(TZ) c IF(ABS(TZ-NZ).GT.TOLW)THEN c WRITE(6,1001)TZ c WRITE(0,1001)TZ c GO TO 999 c ENDIF c write(6,*)mk,ajust,zn DO J=1,MSHELL T2=MEL(J) TEL(J)=T2/T1 c if(tel(j).ne.dzero)write(6,*)j,tel(j) ENDDO C ELSE C C CHOOSE FIRST SUITABLE BOUND (MKK.GE.0) OR CONTINUUM (MKK.LT.0) CONFIG. C NCO=0 IF(MA*MB.GT.0)THEN DO I=MA,MB TEL(I)=2*(QL(I)+1) NCO=NCO+NINT(TEL(I)) IF(I.GT.MSHELL)MSHELL=I ENDDO ENDIF C IF(MION.GE.0.AND.MKK.NE.0)THEN DO M=1,MAXCF I=QCG(NF,M) IF(MKK.GT.0.AND.QN(I).GE.0)THEN DO L=1,NF IF(QCG(L,M).EQ.MK)GO TO 9 ENDDO ENDIF IF(MKK.LT.0)THEN !NOT USED IF(IVAL(I).GT.0.AND.QN(I).GE.IABS(QN(MK)))GO TO 9 IF(SCREEN(I).GT.DKEY)GO TO 9 IF(QN(I).LT.0)GO TO 9 ENDIF ENDDO GO TO 30 C 9 DO 86 N=1,NF I=QCG(N,M) IF(MKK.LT.0)THEN !NOT USED NZ=NZ+1 IF(IVAL(I).GT.0.AND.QN(I).GE.IABS(QN(MK)))GO TO 86 IF(SCREEN(I).GT.DKEY)GO TO 86 IF(QN(I).LT.0)GO TO 86 NZ=NZ-1 ENDIF TEL(I)=TEL(I)+DONE IF(I.GT.MSHELL)MSHELL=I 86 ENDDO IF(MKK.LT.0)THEN !NOT USED IF(MS.GT.MAXGR.OR.MS.LT.0.OR.IVAL(MK).GT.0)NZ=NZ-1 ENDIF ENDIF C TZ=NZ C ENDIF C C RE-ENTRY POINT FOR USER SUPPLIED OCCUPATION NOS C 30 CONTINUE C C SET EFFECTIVE OCCUPATION FOR THIS ORBITAL SUB-SHELL C IF(MS.LT.0.OR.IVALMK.GT.0)THEN MS=0 !SELF-SCREENING NOT IN TEL ELSE MS=1 ENDIF IF(MK.GT.0)WK=TEL(MK)+MS-1 C C SET ASYMPTOTIC CHARGE C IF(MION.GE.0)THEN ZN=MION-1-TZ ELSE ZN=NCO-TZ ENDIF ZN=Z-ZN ZN1=ZN IF(NINT(ZN1).EQ.0)ZN1=DONE C C INITIALIZE POT(I) WITH NUCLEAR POTENTIAL (ANY FINITE IS ADDED LATER) C if(nocc0.lt.0.or.mk.le.0)then DO I=1,MAXRS POT(I)=Z/R(I) ENDDO else T=WK*Z IF(BREL2)THEN DO I=1,MAXRS POT(I)=T*(DPNL(I,MK)*DPNL(I,MK)+DQNL(I,MK)*DQNL(I,MK))/R(I) ENDDO ELSE DO I=1,MAXRS POT(I)=T*DPNL(I,MK)*DPNL(I,MK)/R(I) ENDDO ENDIF endif C IF(MION.LT.0.AND.NCO.EQ.0)GO TO 900 !RETURN C C FORM CONFIGURATION AVERAGE POTENTIAL C(STATIC ONLY IF FURNESS & MCCARTHY EXCHANGE) C i1=0 c DO J=1,MSHELL C BEQNL=J.EQ.MK.AND.MS.GT.0 C MJX=0 C=TEL(J) IF(BEQNL)THEN C=C-DONE IF(MEXPOT.LE.0)MJX=MIN(QL(J),6) ENDIF C IF(ABS(C).GT.TOLW)THEN C C DIRECT IF(BREL2)THEN DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,J)+DQNL(I,J)*DQNL(I,J) ENDDO ELSE DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,J) ENDDO ENDIF C MI=QL(J)+2 F0=DBLE((MI-1))/DBLE((2*MI-3)) F=DONE C DO MJ=0,MJX,2 C CALL YLAMK(MJ,MI,DP,DA,DD1,DD2,MNE,DHNS,MJH,0) !NO RETARDN C IF(MJ.GT.0)THEN DC1=VCC(QL(J),2*MJ,QL(J),0,0,0,DFS,MT) F=-F0*DC1*DC1/(MI-1) ENDIF c write(6,*)ql(j),2*mj,ql(j),' f=',f C if(nocc0.lt.0.or.mk.le.0)then DO I=1,MAXRS POT(I)=POT(I)-C*F*DA(I) ENDDO else T=WK*C*F IF(BREL2)THEN DO I=1,MAXRS POT(I)=POT(I)-T*DA(I)* X (DPNL(I,MK)*DPNL(I,MK)+DQNL(I,MK)*DQNL(I,MK)) ENDDO ELSE DO I=1,MAXRS POT(I)=POT(I)-T*DA(I)*DPNL(I,MK)*DPNL(I,MK) ENDDO ENDIF endif C ENDDO C C EXCHANGE IF(.NOT.BEQNL.AND.MEXPOT.EQ.0.AND.MS*MK.NE.0 x .and.abs(ajust).gt.tolw)THEN c if(i1.eq.0.and.nocc0.lt.0)then de=dey(mk)-duy(mk,mk) de=de+de fnu=sqrt(-zn1*zn1/de) l=ql(mk)/2 el=l a1=max(fnu*fnu-el*(el+done),dzero) a1=sqrt(a1) ri=fnu*(fnu+a1) ri=dthree*ri/zn1 tolp=tolp0/zn1 c write(6,*)ri/dthree,de,zn1,fnu c do i=maxrs,1,-1 if(abs(DPNL(I,MK)).gt.tolp)then i1=i c write(6,*)mk,r(i),ri/dthree,rinf2(mk) go to 50 endif enddo endif C 50 ME1=IABS(QL(J)-QL(MK))/2 ME2=(QL(J)+QL(MK))/2 MI=ME2+2 ME2=MIN(ME2,6) C IF(BREL2)THEN DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,MK)+DQNL(I,J)*DQNL(I,MK) ENDDO ELSE DO I=1,MAXRS DP(I)=DPNL(I,J)*DPNL(I,MK) ENDDO ENDIF C DO MJ=ME1,ME2,2 C CALL YLAMK(MJ,MI,DP,DA,DD1,DD2,MNE,DHNS,MJH,0) !NO RETARDN DC1=VCC(QL(J),2*MJ,QL(MK),0,0,0,DFS,MT) G=-DC1*DC1/(2*QL(MK)+2) c write(6,*)ql(j),2*mj,ql(mk),' g=',g G=G*AJUST !TRY SCALING EXCHANGE C if(nocc0.lt.0)then IF(BREL2)THEN DO I=1,i1 !MAXRS T=DPNL(I,J)*DPNL(I,MK)+DQNL(I,J)*DQNL(I,MK) T=T/(DPNL(I,MK)*DPNL(I,MK)+DQNL(I,MK)*DQNL(I,MK)) if(r(i).gt.ri)t=t*exp(-((r(i)/ri-done)/sigma)**2) IF(ABS(T).LT.TOLX.or.r(i).lt.ri)then POT(I)=POT(I)-C*G*DA(I)*T c else c write(6,99)j,mk,i,r(i),t,DPNL(I,J),DPNL(I,MK),pot(i)*r(i) c 99 format(3i5,1p,5d10.3) endif ENDDO ELSE DO I=1,i1 !MAXRS c if(dpnl(i,mk).eq.dzero)then c write(6,*)i,mk c stop c else if(brel)then dqnj=dpnl(i,j) dqnk=dpnl(i,mk) h=r(i) if(i.gt.1)then dqnj=dqnj-dpnl(i-1,j) dqnk=dqnk-dpnl(i-1,mk) h=h-r(i-1) endif dqnj=dfsc2*(dqnj/h-dpnl(i,j)/r(i)) dqnk=dfsc2*(dqnk/h-dpnl(i,mk)/r(i)) t=dpnl(i,j)*dpnl(i,mk)+dqnj*dqnk t=t/(dpnl(i,mk)*dpnl(i,mk)+dqnk*dqnk) else T=DPNL(I,MK) IF(T.EQ.DZERO)T=DPNL(I,J)/TOLX T=DPNL(I,J)/T endif if(r(i).gt.ri)t=t*exp(-((r(i)/ri-done)/sigma)**2) IF(ABS(T).LT.TOLX.or.r(i).lt.ri)then POT(I)=POT(I)-C*G*DA(I)*T c else c write(6,99)j,mk,i,r(i),t,DPNL(I,J),DPNL(I,MK),pot(i)*r(i) c 99 format(3i5,1p,5d10.3) endif ENDDO ENDIF else T=WK*C*G IF(BREL2)THEN DO I=1,MAXRS POT(I)=POT(I)-T*DA(I)* X (DPNL(I,J)*DPNL(I,MK)+DQNL(I,J)*DQNL(I,MK)) ENDDO ELSE DO I=1,MAXRS POT(I)=POT(I)-T*DA(I)*DPNL(I,J)*DPNL(I,MK) ENDDO ENDIF endif ENDDO C ENDIF C ENDIF C ENDDO C C STATIC + EXCHANGE (FURNESS & MCCARTHY 1973) C? .OR.MION.LT.0 IF(MEXPOT.GT.0.OR.MEXPOT.EQ.0.AND.MS.EQ.0 )THEN C DO I=1,MAXRS DP(I)=DZERO ENDDO C DO J=1,MSHELL C=TEL(J) IF(J.EQ.MK.AND.MS.GT.0)C=C-DONE IF(ABS(C).GT.TOLW)THEN DO I=1,MAXRS DP(I)=DP(I)+C*(DPNL(I,J)/R(I))**2 ENDDO ENDIF ENDDO C E=DZERO C E=-DEY(MK)+DUY(MK,MK) T2=AJUST/DTWO !TRY SCALING EXCHANGE IF(T2.GT.TOLW)THEN DO I=1,MAXRS T1=(E+POT(I))**2+DP(I) IF(T1.GT.DZERO)POT(I)=POT(I)+(SQRT(T1)-(E+POT(I)))*T2 ENDDO ENDIF C ENDIF c if(nocc0.gt.0)go to 900 C C DETERMINE POINT OF ASYMPTOTIC COULOMB SCREENING C DO I=1,MAXRS T=POT(I)-ZN/R(I) T=T*R(I)/ZN1 IF(ABS(T).GT.DTOL)MEND=I ENDDO C IF(MEND.LT.MAXRS)GO TO 900 c if(abs(t).lt.2*dtol)go to 900 c write(6,*)t,dtol C T=POT(MAXRS)*R(MAXRS) C WRITE(6,1000)MK,R(MAXRS),ZN,T C c WRITE(6,*)MEND,MAXRS c do i=1,maxrs c write(6,1999)i,r(i),pot(i),r(i)*pot(i) c 1999 format(i5,1p3e14.6) c enddo C 900 RETURN C 999 NF=-1 GO TO 900 C 1000 FORMAT(' *** SR.VPNL: NOT ENOUGH MESH POINTS FOR ORBITAL?',I5 X,' CHECK IF ASYMPTOTIC POTENTIAL ACCURATE ENOUGH:',1P,3E11.3) c 1001 FORMAT(' *** SR.VPNL: WARNING, ASYMPTOTIC CHARGE= Z-N+',F6.2) 1010 FORMAT(' *** ERROR IN SR.VPNL: ORBITAL',I4,' NOT FOUND IN' X,' CONFIGURATION',I4) 1011 FORMAT(' *** ERROR IN SR.VPNL: ORBITAL',I4,' NOT FOUND IN' X,' THE FIRST',I4,' CONFIGURATIONS') C END C C ******************* C SUBROUTINE VXC(DENS,TPLASMA,U) C C----------------------------------------------------------------------- C C SR.VXC EVALUATES FREE ELECTRON PLASMA POTENTIAL, AT GIVEN TEMPERATURE C AND DENSITY. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D1M8=1.0D-8) PARAMETER (C1=4.7853D0) PARAMETER (C2=0.6109D0) PARAMETER (C3=2.83431D0) PARAMETER (C4=0.21512D0) PARAMETER (C5=5.27586D0) PARAMETER (C6=3.94309D0) PARAMETER (C7=7.91379D0) PARAMETER (C8=0.638168D0) C PI=ACOS(-DONE) C IF(DENS.LE.D1M8)THEN U=DZERO ELSE R=(DTHREE/(DFOUR*PI*DENS))**(DONE/DTHREE) T=(TPLASMA/C1)*DENS**(-DTWO/DTHREE) C C EXCHANGE PART C UX0=-C2/R UX=UX0*(DONE+C3*T**2-C4*T**3+C5*T**4) UX=UX/(DONE+C6*T**2+C7*T**4)*TANH(DONE/T) C C CORRELATION PART C ASYMPTOTIC FORM FOR HIGH-T ELECTRON GAS C UCHA=-C8/SQRT(T*R) C U=UX+UCHA ENDIF C RETURN END C C ******************* C SUBROUTINE WEDDLE (A0,A,B,NH,HN,JH,NDIM) C C----------------------------------------------------------------------- C C SR.WEDDLE INTEGRATES ARRAY A, USING WEDDLE'S RULE -- J.A.BELLING, UCL C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C DIMENSION A(NDIM),NH(JH),HN(JH) C N=1 A1=A0 JH0=0 B=DZERO C DO J=1,JH J1=NH(J) IF(N+J1-1.GT.NDIM)THEN J1=NDIM-N+1 IF(J1.LT.6)RETURN JH0=J ENDIF H=HN(J) C J16=MOD(J1,6) J2=J16+1 C C GO TO (7,1,2,3,4,5),J2 C IF(J16.EQ.1)THEN B=B+(19087*A1+65112*A(N)-46461*A(N+1)+37504*A(N+2)- !1 X 20211*A(N+3)+6312*A(N+4)-863*A(N+5))/60480*H ELSEIF(J16.EQ.2)THEN B=B+(1139*A1+5640*A(N)+33*A(N+1)+1328*A(N+2)-807* !2 X A(N+3)+264*A(N+4)-37*A(N+5))/3780*H ELSEIF(J16.EQ.3)THEN B=B+(685*A1+3240*A(N)+1161*A(N+1)+2176*A(N+2)-729* !3 X A(N+3)+216*A(N+4)-29*A(N+5))/2240*H ELSEIF(J16.EQ.4)THEN B=B+2*(143*A1+696*A(N)+192*A(N+1)+752*A(N+2)+87* !4 X A(N+3)+24*A(N+4)-4*A(N+5))/945*H ELSEIF(J16.EQ.5)THEN B=B+5*(743*A1+3480*A(N)+1275*A(N+1)+3200*A(N+2)+ !5 X 2325*A(N+3)+1128*A(N+4)-55*A(N+5))/12096*H ENDIF C IF(J16.NE.0)THEN M=N+J2-2 A1=A(M) ENDIF C N=N+J2-1 !7 J2=J1/6 C DO J1=1,J2 B=B+(41*(A1+A(N+5))+216*(A(N)+A(N+4))+27*(A(N+1)+A(N+3))+ X 272*A(N+2))*H/140 N=N+5 A1=A(N) N=N+1 ENDDO C IF(JH0.EQ.J)RETURN C ENDDO C RETURN END C C ******************* C REAL*8 FUNCTION WHITEX(R,TL,E,ZN,BNORM) C C----------------------------------------------------------------------- C C FN.WHITEX CALCULATES THE VALUE OF THE WHITTAKER FUNCTION AT POINT R C L=ANGULAR MOMENTUM, E=ENERGY/RY (E.LT.0), ZN=ASYMPTOTIC CHARGE C IF WHITEX CANNOT BE NORMALIZED, THEN BNORM=.FALSE. ELSE .TRUE. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DONE=1.0D0) PARAMETER (D1M10=1.0D-10) PARAMETER (ENFFCT=1.0D-6) C LOGICAL BNORM C SUPFCT=55 BNORM=.FALSE. A=SQRT(-E) P=ZN/A H1=P+TL+DONE H2=P-TL C C DO NOT NORMALIZE WHITTAKER FUNCTION C IF FOR ARGUMENTS H1 OR H2 GAMMA(H) IS OUTSIDE MACHINE RANGE C FN=DONE IF(H2.LE.ENFFCT)GO TO 3 IF(H1.GT.SUPFCT)GO TO 3 C C NORMALIZATION CAN BE CALCULATED C BNORM=.TRUE. D1=SQRT(GAMA7(H1)) D2=SQRT(GAMA7(H2)) D3=SQRT(P/A) FN=DONE/(D1*D2*D3) C 3 A=A*R FN=FN*EXP(-A)*(A+A)**P C A=DONE/(A+A) DL=TL*(TL+1) PS2=(DL-(P-1)*P)*A PS1=PS2 SUMM=DONE C C EXPAND TO A MAXIMUM OF 30 TERMS C CONTINUE THE EXPANSION AS LONG AS ADDITIONAL TERMS BECOME SMALLER C STOP THE EXPANSION OF ADDITIONAL TERMS WHICH BECOME VANISHINGLY C SMALL C DO I=1,30 IF(ABS(PS2).GT.ABS(PS1))GO TO 2 SUMM=SUMM+PS2 IF(ABS(PS2).LT.ABS(SUMM)*D1M10)GO TO 2 PS1=PS2 PS2=PS2*(DL-(P-I)*(P-I+1))*A/I ENDDO C C PRINT A WARNING IF EXPANSION EXHAUSTED WRITE(6,999) C 2 WHITEX=FN*SUMM C RETURN C 999 FORMAT(' WHITEX: EXPANSION TOO RESTRICTED') END C C ******************* C SUBROUTINE WXC(DENS,TPLASMA,U) C C----------------------------------------------------------------------- C C SR.WXC EVALUATES FREE ELECTRON PLASMA POTENTIAL, AT GIVEN TEMPERATURE C AND DENSITY. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (D3Q=DTHREE/DFOUR) PARAMETER (D1M8=1.0D-8) PARAMETER (C1=4.7853D0) PARAMETER (C2=0.6109D0) PARAMETER (C3=3.04363D0) PARAMETER (C4=0.09227D0) PARAMETER (C5=1.7035D0) PARAMETER (C6=8.31051D0) PARAMETER (C7=5.1105D0) PARAMETER (C8=0.425437D0) C PI=ACOS(-DONE) C IF(DENS.LE.D1M8)THEN U=DZERO ELSE R=(DTHREE/(DFOUR*PI*DENS))**(DONE/DTHREE) C D4*PIE NOT D4+PI !!! T=(TPLASMA/C1)*DENS**(-DTWO/DTHREE) C C EXCHANGE PART C UX0=-C2/R UX=UX0*(D3Q+C3*T**2-C4*T**3-C5*T**4) UX=UX/(DONE+C6*T**2+C7*T**4)*TANH(DONE/T) C C CORRELATION PART C ASYMPTOTIC FORM FOR HIGH-T ELECTRON GAS C UCHA=-C8/SQRT(T*R) C U=UX+UCHA ENDIF C RETURN END C C*********************************************************************** C REAL*8 FUNCTION XINT(DE,ENERG,NLAG0,RHO,M,ml,mu) C C----------------------------------------------------------------------- C C FN.XINT INTEPOLATES RHO (REACTANCE) MATRIX C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) C PARAMETER (FRACKY=1.D-4) C LOGICAL BBC,blog c logical buse !,busi,btmp common /nrbuse/buse(mxeng) !,busi(mxeng,mxeng),btmp(mxeng,mxeng) C DIMENSION ENERG(*),RHO(*) C SAVE IP,NP1,NP2,NPH C DATA IP0,NLAG/0,0/ C IF(DE.LE.FRACKY*ENERG(M))THEN !USE ELASTIC XINT=RHO(M) RETURN ELSE TE=ENERG(M)+DE ENDIF C blog=mu.lt.0 mu=iabs(mu) c IF(NLAG.EQ.0)THEN np1=-999 NPH=(NLAG0+1)/2 ENDIF C BBC=mu-ml.lt.NLAG0 !MENG.LE. IF(BBC)THEN NP1=ml !1 NP2=mu !MENG NLAG=NP2-ml+1 IP=NP2 ENDIF C IF(.NOT.BBC)THEN IF(TE.GT.ENERG(mu))THEN !EXTRAPOLATING NLAG=MIN(3,NLAG0) NP2=mu !MENG NP1=NP2-NLAG+1 IP=NP2 c if(te.gt.1.1*energ(mu)) c x write(0,*)'*** Extrapolating upwards:',ml,mu,m GO TO 1 ELSEIF(TE.LT.ENERG(ml))THEN !EXTRAPOLATING NLAG=MIN(3,NLAG0) NP1=ml !1 NP2=NLAG+ml-1 IP=NP2 c if(te.lt.0.9*energ(ml)) c x write(0,*)'*** Extrapolating downwards:',m,ml,mu GO TO 1 ENDIF C C FIND INTERPOLATION ENERGIES C DO I=M+1,mu !MENG IF(ENERG(I).GT.TE)THEN IP=I GO TO 2 ENDIF ENDDO IP=mu !MENG C 2 IF(NLAG0.GT.2.AND.IP.NE.IP0)THEN NP2=IP+NPH-1 NP1=IP-NPH IF(MOD(NLAG0,2).NE.0)THEN !REMOVE EVEN POINT i0=0 if(ip.gt.ml+1.and.ip.lt.mu)i0=1 !2,meng IF(ABS(ENERG(IP+i0)-TE).LT.ABS(ENERG(IP-1-i0)-TE))THEN NP1=NP1+1 ELSE NP2=NP2-1 ENDIF ELSE IP0=IP ENDIF IF(NP1.LT.ml)THEN !1 NP2=NP2-NP1+ml !1 NP1=ml !1 ELSEIF(NP2.GT.mu)THEN !MENG NP1=NP1-NP2+mu !MENG NP2=mu !MENG ENDIF ELSEIF(NLAG0.EQ.2)THEN NP2=IP NP1=IP-1 ENDIF C IF(ENERG(M)+ENERG(NP1).EQ.DZERO)THEN !EXCLUDE 0-0 FROM INELASTIC IF(NP2.LT.mu)NP2=NP2+1 !MENG IF(NP1+1.LT.NP2)NP1=NP1+1 ENDIF C NLAG=NLAG0 ENDIF C C NOW INTERPOLATE C 1 CONTINUE c if(nlag.gt.1)blog=blog.and.te.gt.2*de.and.energ(np1).gt.dzero c IF(NLAG.EQ.1)THEN IF(IP.EQ.1)THEN XINT=RHO(IP) ELSE IF(ENERG(IP)-TE.LT.TE-ENERG(IP-1))THEN XINT=RHO(IP) ELSE XINT=RHO(IP-1) ENDIF ENDIF ELSEIF(NLAG.EQ.2)THEN T10=ENERG(NP1) T20=ENERG(NP2) if(blog)then te=log(te) t10=log(t10) t20=log(t20) endif T=T20-T10 T1=T20-TE T2=TE-T10 XINT=(T2*RHO(NP2)+T1*RHO(NP1))/T buse(np1)=.true. !flag used buse(np2)=.true. !flag used c busi(np1,m)=.true. !flag used c busi(np2,m)=.true. !flag used ELSE if(blog)te=log(te) XINT=DZERO DO J=NP1,NP2 buse(j)=.true. !flag used c busi(j,m)=.true. !flag used TJ=ENERG(J) if(blog)tj=log(tj) DD=DONE DO N=NP1,NP2 IF(J.NE.N)THEN TN=ENERG(N) if(blog)tn=log(tn) DD=DD*(TE-TN) DD=DD/(TJ-TN) ENDIF ENDDO XINT=XINT+DD*RHO(J) ENDDO ENDIF C RETURN END C C ******************* C REAL*8 FUNCTION XTWO(LAM,K1,K2,K3,K4) C C----------------------------------------------------------------------- C C FN.XTWO EVALUATES THE X-TWO INTEGRAL OF 2-BODY DARWIN+ C CONTACT-SPIN-SPIN INTERACTION, INCLUDING THE (2LBD+1) FACTOR. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXPS,JDUM(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBNF2/D1(MAXB1),D2(MAXB1),D3(MAXB1) X ,DETA(MXRLO),DXSI(MAXGR,MAXGR),DZL(MXRLO),DXTWO(MXRLO) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 DD=DONE C DO I=1,MAXPS D1(I)=DPNL(I,K1)*DPNL(I,K2)*DPNL(I,K3)*DPNL(I,K4)/(DX(I)*DX(I)) ENDDO C IF(BREL)THEN !SMALL R CORRECTION DE1=DEY(K1)-DUY(K1,K1) DE3=DEY(K3)-DUY(K3,K3) DE2=DEY(K2)-DUY(K2,K2) DE4=DEY(K4)-DUY(K4,K4) DZ=NZION IF(BREL2)THEN T=C4*DTWO DO I=1,MAXPS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ DD2=DONE+T*(DE2+DZ/DX(I)) DD4=DONE+T*(DE4+DZ/DX(I)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ ENDDO ELSE dd=rnorm(k1)*rnorm(k3)*rnorm(k2)*rnorm(k4) DO I=1,MAXPS DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) DSQ=DD1*DD3 DSQ=SQRT(DSQ) D1(I)=D1(I)/DSQ DD2=DONE+C4*(DQNL(I,K2)/DPNL(I,K2)+DTWO*DZ/DX(I)) DD4=DONE+C4*(DQNL(I,K4)/DPNL(I,K4)+DTWO*DZ/DX(I)) DSQ=DD2*DD4 DSQ=SQRT(DSQ) D1(I)=D1(I)*dd/DSQ ENDDO ENDIF ENDIF C CALL WEDDLE(DZERO,D1,TT,MNE,DHNS,MJH,MAXPS) C TP=2*LAM+1 XTWO=DALF*TT*TP*DD if(.not.brel)xtwo=xtwo/DTWO !add-in 2-body Darwin C C C WRITE(6,100) K1, K2, K3, K4, XTWO C100 FORMAT(8X,2(I5,I4),F20.7,' =XTWO') C RETURN END c !ADAS C ******************* !ADAS c !ADAS subroutine xxcftr(icfsel,cstrgi,cstrgo) !ADAS c !ADAS c dummy routine for normal (non-ADAS) useage. !ADAS c !ADAS implicit none !ADAS c !ADAS integer icfsel,idum !ADAS c !ADAS character(len=*) cstrgi(*),cstrgo(*) !ADAS character(len=1) cdum !ADAS c !ADAS c suppress compiler warnings (sigh...) !ADAS c !ADAS cdum=cstrgi(1) !ADAS idum=icfsel !ADAS c !ADAS write(cstrgo(1),'(a15)')'dummy sr.xxcftr' !ADAS c !ADAS return !ADAS end !ADAS C C ******************* C SUBROUTINE YLAMK(L,M0,A,B,Y1,Y2,NH,HN,JH,MODE) C C----------------------------------------------------------------------- C C SR.YLAMK EVALUATES RADIAL MULTIPOLE FUNCTIONS (OUTPUT ARRAY B) FOR C RADIAL FUNCTION PRODUCT (INPUT ARRAY A) OF LAMDA=L. ALSO OUTPUT C Y1 INTEGRAL [0:INF) A*X**L C Y2 INTEGRAL [0:INF) A/X**(L+1) C C IT USES THE MODIFIED BODY OF J. A. BELLING'S SR.YLAM. C C MODE.EQ.0: YLAMK COMPUTES COULOMB INTEGRALS YLAMBDA (REL.TO RLAM) C MODE.LT.0: MAGNETIC INTEGRALS RELATED TO VLAM C MODE.GT.0: NLAM C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C DIMENSION A(*),B(*),NH(JH),HN(JH),C(5),E(5),F(5) C M=MIN(M0,15) C K=1 IF(MODE.NE.0)K=IABS(MODE) J=L+K C C N=J C IF(MODE.NE.0)N=2 IF(J.LE.0 .OR. JH.LE.0)GO TO 50 C .OR. M.LT.N N=8 DO I=1,JH IF(HN(I).LT.DZERO)GO TO 50 IF(NH(I).LT.N)GO TO 50 N=5 ENDDO C H=HN(1) J1=M-1 X=DZERO DO I=1,4 X=X+H C(I)=A(I)/X**J1 ENDDO C Z=H*24 E(1)=(96*C(1)-72*C(2)+32*C(3)-6*C(4))/Z Z=H*Z E(2)=(-104*C(1)+114*C(2)-56*C(3)+11*C(4))/Z Z=H*Z E(3)=(36*C(1)-48*C(2)+28*C(3)-6*C(4))/Z Z=H*Z E(4)=(-4*(C(1)+C(3))+6*C(2)+C(4))/Z X=DZERO C DO N=1,4 X=X+H C(N)=DZERO DO I1=1,4 I2=5-I1 Z=L+M+I2 C(N)=E(I2)/Z+C(N)*X ENDDO B(N)=C(N)*X**(M-K+1) C(N)=B(N)*X**J ENDDO C E(4)=A(4)*X**L N=4 I1=8 C DO J1=1,JH H=HN(J1) H1=2*H/45 E(1)=E(4) C(1)=C(4) C DO I=2,5 N=N+1 X=X+H Z=X**L E(I)=Z*A(N) F(I)=Z*X**K ENDDO C C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720 B(N-3)=C(2)/F(2) C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90 B(N-2)=C(3)/F(3) C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80 B(N-1)=C(4)/F(4) I2=NH(J1) C IF(I2.GE.I1)THEN N=N-1 X=X-H DO I=I1,I2 N=N+1 X=X+H Z=X**L F(5)=Z*X**K E(5)=Z*A(N) C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3)) B(N)=C(5)/F(5) DO I3=1,4 C(I3)=C(I3+1) E(I3)=E(I3+1) ENDDO ENDDO ENDIF I1=4 ENDDO C Y1=C(5) IF(MODE.GT.0)GO TO 90 C(5)=DZERO C TEST C(5)=Y2 !MUST ENSURE Y2 INPUT THEN I1=1 X=X+H C DO J1=1,JH I3=JH-J1+1 H=HN(I3) H1=2*H/45 E(1)=E(5) C(1)=C(5) I2=NH(I3) I3=N DO I=I1,5 X=X-H F(I)=X**L E(I)=A(N)/(F(I)*X**K) N=N-1 ENDDO C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720 C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90 C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80 C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3)) C DO I=I1,5 IF(MODE.LE.-999)B(I3)=DZERO B(I3)=C(I)*F(I)+B(I3) I3=I3-1 ENDDO C DO I=5,I2 DO I3=1,4 E(I3)=E(I3+1) C(I3)=C(I3+1) ENDDO E(5)=DZERO IF(N.NE.0)THEN X=X-H Z=X**L E(5)=A(N)/(Z*X**K) ENDIF C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3)) IF(N.EQ.0)GO TO 20 IF(MODE.LE.-999)B(N)=DZERO B(N)=C(5)*Z+B(N) N=N-1 ENDDO I1=2 ENDDO C 20 Y2=C(5) C 90 RETURN C C SHOULD NOT HAPPEN SINCE SUITABLE MESH PRE-SET BY RADIAL C 50 WRITE(6,999)L,MODE,M,JH,(NH(I),HN(I),I=1,JH) WRITE(0,*)'INPUT ERROR IN YLAMK' C STOP'INPUT ERROR IN YLAMK' RETURN C 999 FORMAT(/20X,'INPUT ERROR IN YLAMK',20X,'L,MODE=',2I5,5X,'M=',I3, X 5X,'JH=',I3,5X,'NH,HN='/(10X,5(I5,E16.8))) C END C C ******************* C SUBROUTINE YLAMKR(L,M0,DEL0,A,B,Y1,Y2,NH,HN,JH,MOD0) C C----------------------------------------------------------------------- C C SR.YLAMKR EVALUATES RADIAL MULTIPOLE FUNCTIONS WITH FULL RETARDATION C USING SPHERICAL BESSEL FUNCTIONS OF THE FIRST AND SECOND KIND, I.E. C ONLY THE REAL PART IS CONSIDERED. C IT USES THE MODIFIED BODY OF SR.YLAMK. C ONLY CALLED IF BREL=.TRUE., I.E. RELATIVISTIC WAVEFUNCTIONS IN USE. C C INPUT: C MODE.EQ.0: YLAMK COMPUTES COULOMB INTEGRALS YLAMBDA (REL.TO RLAM) C .LT.0: MAGNETIC INTEGRALS RELATED TO VLAM C .GT.0: NLAM C L IS THE MULTIPOLE C M0 CHARACTERISES THE SMALL-R BEHAVIOUR OF ARRAY C A WHICH CONTAINS THE PRODUCT OF THE TWO ORBITALS ON C NH,HN,JH DEFINED STANDARD RADIAL MESH C C DEL IS THE TRANSVERSE PHOTON ENERGY (A.U.). C ***IF USER SETS IBREIT IN UNIT5 INPUT THEN C IBREIT.GT.0 (REAL PART OF) GENERALIZED BREIT INTERACTION. C IBREIT.EQ.0 USUAL YLAMK IS CALLED - ZERO ENERGY TRANSVERSE PHOTON. C (TEST: IBREIT.LT.0 APPLIES NON-ZERO ENERGY TO THE COULOMB, AS MOLLER) C C OUTPUT: C YK IN ARRAY B. C Y1,Y2 INTEGRALS ZERO TO INFINITY. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DFSC=7.2973525333D-03) PARAMETER (WMIN=0.1D0) C LOGICAL BREL,BJUMPR,BMVD,bbreit C DIMENSION A(*),B(*),NH(JH),HN(JH),C(5),E(5),F(5) C COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C bbreit=ibreit.lt.0.or.ibreit.gt.0.and.mod0.ne.0 mode=mod(mod0,1000) c M=MIN(M0,15) C K=1 IF(MODE.NE.0)K=IABS(MODE) J=L+K C C N=J C IF(MODE.NE.0)N=2 IF(J.LE.0 .OR. JH.LE.0)GO TO 50 C .OR. M.LT.N N=8 MAXRS=0 DO I=1,JH IF(HN(I).LT.DZERO)GO TO 50 IF(NH(I).LT.N)GO TO 50 N=5 MAXRS=MAXRS+NH(I) ENDDO C C DEL=ABS(DEL0) W=DFSC*DEL IF(W.LT.WMIN.or..not.bbreit)THEN !UNRETARDED CALL YLAMK(L,M0,A,B,Y1,Y2,NH,HN,JH,MODE) RETURN ENDIF C H=HN(1) J1=M-1 X=DZERO DO I=1,4 X=X+H C(I)=A(I)/X**J1 ENDDO C Z=H*24 E(1)=(96*C(1)-72*C(2)+32*C(3)-6*C(4))/Z Z=H*Z E(2)=(-104*C(1)+114*C(2)-56*C(3)+11*C(4))/Z Z=H*Z E(3)=(36*C(1)-48*C(2)+28*C(3)-6*C(4))/Z Z=H*Z E(4)=(-4*(C(1)+C(3))+6*C(2)+C(4))/Z C TW=-(2*L+1)*W**K DO I=1,K-1 TW=TW/(2*(L+I)-1) ENDDO X=DZERO DO N=1,4 X=X+H C(N)=DZERO DO I1=1,4 I2=5-I1 Z=L+M+I2 C(N)=E(I2)/Z+C(N)*X ENDDO B(N)=C(N)*X**(M-K+1) !/TW C(N)=B(N)*X**J ENDDO C J=J-1 Z=X*W E(4)=BESSJ(L,Z)*A(4) N=4 I1=8 C DO J1=1,JH H=HN(J1) H1=2*H/45 E(1)=E(4) C(1)=C(4) C DO I=2,5 N=N+1 X=X+H Z=X*W E(I)=BESSJ(L,Z)*A(N) F(I)=BESSN(J,Z) ENDDO C C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720 B(N-3)=C(2)*F(2) C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90 B(N-2)=C(3)*F(3) C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80 B(N-1)=C(4)*F(4) I2=NH(J1) C IF(I2.GE.I1)THEN N=N-1 X=X-H DO I=I1,I2 N=N+1 X=X+H Z=X*W E(5)=BESSJ(L,Z)*A(N) F(5)=BESSN(J,Z) C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3)) B(N)=C(5)*F(5) DO I3=1,4 C(I3)=C(I3+1) E(I3)=E(I3+1) ENDDO ENDDO ENDIF I1=4 ENDDO C Y1=C(5) IF(MODE.GT.0)GO TO 90 C C(5)=DZERO C TEST C(5)=Y2 !MUST ENSURE Y2 INPUT THEN I1=1 X=X+H C DO J1=1,JH I3=JH-J1+1 H=HN(I3) H1=2*H/45 E(1)=E(5) C(1)=C(5) I2=NH(I3) I3=N DO I=I1,5 X=X-H Z=X*W E(I)=BESSN(J,Z)*A(N) F(I)=BESSJ(L,Z) N=N-1 ENDDO C(2)=C(1)+H*(251*E(1)+646*E(2)-264*E(3)+106*E(4)-19*E(5))/720 C(3)=C(1)+H*(29*E(1)+124*E(2)+24*E(3)+4*E(4)-E(5))/90 C(4)=C(1)+H*(9*E(1)+34*E(2)+24*E(3)+14*E(4)-E(5))*3/80 C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3)) C DO I=I1,5 IF(MODE.LE.-999)B(I3)=DZERO B(I3)=C(I)*F(I)+B(I3) I3=I3-1 ENDDO C DO I=5,I2 DO I3=1,4 E(I3)=E(I3+1) C(I3)=C(I3+1) ENDDO E(5)=DZERO IF(N.NE.0)THEN X=X-H Z=X*W E(5)=BESSN(J,Z)*A(N) F(5)=BESSJ(L,Z) ENDIF C(5)=C(1)+H1*(7*(E(1)+E(5))+32*(E(2)+E(4))+12*E(3)) IF(N.EQ.0)GO TO 20 IF(MODE.LE.-999)B(N)=DZERO B(N)=C(5)*F(5)+B(N) N=N-1 ENDDO I1=2 ENDDO C 20 Y2=C(5) C Y2=Y2*TW 90 Y1=Y1*TW DO I=1,MAXRS B(I)=TW*B(I) ENDDO C RETURN C C SHOULD NOT HAPPEN SINCE SUITABLE MESH PRE-SET BY RADIAL C 50 WRITE(6,999)L,MODE,M,JH,(NH(I),HN(I),I=1,JH) WRITE(0,*)'INPUT ERROR IN YLAMKR' C STOP'INPUT ERROR IN YLAMKR' RETURN C 999 FORMAT(/20X,'INPUT ERROR IN YLAMKR',20X,'L,MODE=',2I5,5X,'M=',I3, X 5X,'JH=',I3,5X,'NH,HN='/(10X,5(I5,E16.8))) C END C C ******************* C SUBROUTINE YLAMKX(DP1,DP2,DQ1,DQ2,N1,N2,JJ,M1,M2,TM,TN,DEL0,DPA,DP X ,DX,DPOLA,REM,ovlp) C C----------------------------------------------------------------------- C C SR.YLAMKX CALCULATES THE DEIE YK INTEGRAL, C INCLUDING ANY LONG-RANGE CONTRIBUTION C C IT CALLS: C SR.YLAMKR C SR.YLAMK C SR.ASS2X C SR.ASSX C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C LOGICAL BREL,BJUMPR,BMVD,BREL2,BSTO C DIMENSION DP1(*),DP2(*),DQ1(*),DQ2(*),DPA(*),DP(*),DX(*) C common /com1/dpot(maxb1),tol,mend COMMON /CRAD/DHNS(20),MNE(20),MJH,MAXRS,JEND(MAXGR) COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),SCREEN(MAXGR),MION,NZION X ,NPARAM,ITOL,INCLUD,JPRINT COMMON /NRB/MAUTO,MODE,ACE,BSTO,MSHELL,MORT,MGRP COMMON /NRBDW5/DYY(MXENG),MENG,NLAG COMMON /NRBPOL/ALFD(0:3),RCUT(0:3),ALAV,RCAV,IPOLFN COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C C----------------------------------------------------------------------- DPOL1(X)=SQRT(DONE-EXP(-(X/RCAV)**6))/X**2 DPOL2(X)=X/((X*X+RCAV*RCAV)*SQRT(X*X+RCAV*RCAV)) C----------------------------------------------------------------------- C BREL2=IABS(IREL).EQ.2 IPOLF2=IPOLFN/10 DZA=-(NZION-MION) !CHARGE .LT.0 IN ASS C REM=DZERO C IF(BREL2)THEN DO I=1,MAXRS DPA(I)=DP1(I)*DP2(I)+DQ1(I)*DQ2(I) ENDDO ELSE DO I=1,MAXRS DPA(I)=DP1(I)*DP2(I) ENDDO ENDIF c if(jj.eq.0)then !determine one-body contribution if(qn(n2).lt.0.or.mort.ne.-3)then !direct or exchange do i=1,maxrs dp(i)=dpa(i)*dpot(i) enddo call weddle(dzero,dp,rem0,mne,dhns,mjh,maxrs) rem0=-rem0/(dpot(maxrs)*dx(maxrs)) !a.u. per electron if(qn(n2).lt.0)rem=rem0 !direct else rem0=dzero endif endif C ML=(QL(N1)+QL(N2))/2+2 MI=IABS(JJ)/2 C IF(BREL)THEN DEL=DEL0/DTWO ! A.U.!! CALL YLAMKR(MI,ML,DEL,DPA,DP,DD1,DD2,MNE,DHNS,MJH,0) ELSE CALL YLAMK(MI,ML,DPA,DP,DD1,DD2,MNE,DHNS,MJH,0) ENDIF C IF(IPOLF2.GT.0.AND.MI.EQ.1)THEN !DIELECTRIC POLARIZATION IF(IPOLF2.EQ.1)THEN DO I=1,MAXRS DPA(I)=DPOL1(DX(I))*DPA(I) ENDDO ELSEIF(IPOLF2.EQ.2)THEN DO I=1,MAXRS DPA(I)=DPOL2(DX(I))*DPA(I) ENDDO ELSE STOP 'HERE BE MONSTERS' ENDIF CALL WEDDLE(DZERO,DPA,DPOLA,MNE,DHNS,MJH,MAXRS) ENDIF C IF(JJ.LT.0)RETURN !EXCHANGE C IF(JJ.EQ.0)THEN if(rem.eq.dzero)then !exchange ovlp=dd1 rem=rem0 else !direct ovlp=dzero endif RETURN ENDIF C C EVALUATE LONG-RANGE INTEGRAL (SO DIRECT) C E1=DYY(M1) !RYD E2=DYY(M2) !RYD ML1=QL(N1)/2 ML2=QL(N2)/2 C IF(E1*E2.EQ.DZERO.AND.ML1+ML2.GT.60)THEN REM=DZERO RETURN ENDIF C DS=ML1*(ML1+1) DC=ML2*(ML2+1) C DX1=DX(MAXRS) DTH=DX(MAXRS)-DX(MAXRS-1) C DD1=DP1(MAXRS-1) DD2=DP1(MAXRS) DD3=DP2(MAXRS-1) DD4=DP2(MAXRS) C MN=-MI-1 C CALL ASS2X(DX1,DTH,DX2,DD1,DD2,DD3,DD4,E1,E2,DS,DC,DZERO,DZERO X ,DZERO,DZERO,DZA,MN,REM2) C CALL ASSX(DX2,MN,TM,TN,E1,E2,DZA,ML1,ML2,DS,DC,DZERO,DZERO X ,DZERO,DZERO,REM) C C SUM=REM2+REM C WRITE(0,1111)E1,E2,DX1,REM2,DX2,REM,SUM C1111 FORMAT(2F9.3,2(F7.1,F12.6),F13.6) C REM=REM2+REM C RETURN 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 Based on PHN's GRASP0 routine and freely adapted by NRB. C C----------------------------------------------------------------------- C IMPLICIT NONE INCLUDE './PARAM' C C Parameter variables C DOUBLE PRECISION ONE PARAMETER (ONE=1.D0) DOUBLE PRECISION TWO PARAMETER (TWO=2.D0) DOUBLE PRECISION THREE PARAMETER (THREE=3.D0) DOUBLE PRECISION EPS5 PARAMETER (EPS5=1.D-5) DOUBLE PRECISION EPS6 PARAMETER (EPS6=1.D-6) DOUBLE PRECISION XCL PARAMETER (XCL = 137.03599976D0) 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 DOUBLE PRECISION ZE1,ZE3 INTEGER I,II,K,L INTEGER MK,NN,NNS C C Common variables C INTEGER QCG,QL,QN COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) c Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C----------------------------------------------------------------------- NN = QN(J) L = QL(J)/2 K = -L-1 5 CONTINUE 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)/XCL 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).le.EPS6) go to 40 !40,40,20 c 20 CONTINUE c write(6,*)i,a(3) I = I+1 IF (I.le.ITR) go to 10 !10,10,30 c 30 CONTINUE WRITE (6,3000) QN(J),QL(J)/2 C 40 CONTINUE ZE = A(3) C IF(L.EQ.0)RETURN C IF(K.LT.0)THEN ZE3=ZE K=L GO TO 5 ELSE ZE1=ZE ZE=(ZE1+TWO*ZE3)/THREE ENDIF c return c 50 ze=-one return C 3000 FORMAT (' WARNING in ZEFR : iteration limit exceeded for ',I2,I2) END C C ******************* C REAL*8 FUNCTION ZEFX(I,NI,LI,Z0,S,NSHELL,N,TUMEL,ALFA,R,MEXPOT) C C----------------------------------------------------------------------- C C FN.ZEFX EVALUATES THE SLATER-TYPE ORBITAL POTENTIAL AT A SINGLE PT. C USING OCCUPPATION NUMBERS DEFINED IN SR.STOPOT, WHICH CALLS IT C TO FILL-IN THE RADIAL ARRAY C C A. BURGESS - HARTREE C N. R. BADNELL - EXCHANGE C C Z0=NUCLEAR CHARGE (IN ELECTRON POTENTIAL UNITS) C NSHELL=NUMBER OF ELECTRON SHELLS C N(J),J=1, NSHELL, IS THE PRINCIPAL QUANTUM NUMBER OF SHELL J C TUMEL(J) IS THE NUMBER OF ELECTRONS IN SHELL J C R IS THE RADIAL DISTANCE COORDINATE IN UNITS OF A0 AND C ALFA(J) IS A RADIAL SCALING FACTOR FOR SHELL J. C IF I IS SET NEGATIVE, ZEFX IS SET TO THE JUCYS FIT TO THE C THOMAS-FERMI EFFECTIVE POTENTIAL. C IF I IS SET POSITIVE OR ZERO, SLATER-TYPE ORBITALS ARE USED, AND C ZEFX IS THE SHORT RANGE EFFECTIVE POTENTIAL, AS SEEN BY A (SPECTA C ELECTRON IN SHELL I, DUE TO THE NUCLEUS PLUS ALL THE OTHER ELECTR C IN SHELLS J=1,NSHELL. C N.B. I MAY BE SET GREATER THAN NSHELL (OR ZERO), IN WHICH C CASE THERE IS SCREENING BY ALL THE ELECTRONS IN SHELLS J=1,NSHELL C SINCE THE SPECTATOR ELECTRON IS NOT ONE OF THEM. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DTHREE=3.0D0) PARAMETER (DCON1=1.4D2) PARAMETER (DCON2=0.2075D0) PARAMETER (DCON3=1.19D0) PARAMETER (DCON4=0.4236D0) PARAMETER (D1M70=1.0D-70) C LOGICAL BMEX C DIMENSION N(NSHELL),TUMEL(NSHELL),ALFA(NSHELL) C SZ=ABS(S) T=DZERO VX=DZERO IF(NSHELL.LE.0)GO TO 5 IF(I.GE.0)GO TO 8 T2=(-Z0)**(DONE/DTHREE) C DO J=1,NSHELL T1=TUMEL(J) RHO=ALFA(J)*R*T2 T3=DCON2*RHO T4=DZERO IF(T3.LT.DCON1)T4=EXP(-T3) T=T+T1*T4/(DONE+DCON3*RHO) ENDDO GO TO 5 C 8 Z=-Z0 TI=DZERO TE=DZERO BMEX=MEXPOT.GT.0 IF(BMEX)THEN XK=DTWO/DTHREE IF(MEXPOT.EQ.2)XK=DONE ENDIF C DO J=1,NSHELL IF(TUMEL(J).NE.DZERO)THEN X=ALFA(J) X=X*R T1=TUMEL(J)-DONE Z=Z-T1*SZ/DTWO EN=N(J) RHO=DTWO*Z*X/EN IMAX=N(J)+N(J)-1 T2=EN+EN T3=DONE T4=DONE/T2 DO I1=1,IMAX T5=I1 T2=T2-DONE T4=T4*RHO/T5 T3=T3+T4*T2 ENDDO IF(I.NE.J)T1=TUMEL(J) T6=DZERO IF(RHO.LT.DCON1)T6=EXP(-RHO) T=T+T1*T3*T6 CX IF(BMEX)THEN TJ=T4*T6*RHO*RHO/R**3 TE=TUMEL(J)*TJ+TE IF(I.EQ.J)TI=TJ ENDIF CX T1=TUMEL(J)+DONE Z=Z-T1*SZ/DTWO ENDIF ENDDO CX IF(BMEX)THEN !LOCAL EXCHANGE IF(MEXPOT.LT.3)THEN !LINDGREN AND ROSEN XK=1 OR 2/3 IF(I.GT.0.AND.NI.LT.0)TE=TE+TI TI=TI+TI VX=XK*DCON4*(TE**(DONE/DTHREE)-TI**(DONE/DTHREE)) ELSE !COWAN TJ=TE-TI-TI IF(I.GT.0.AND.NI.LT.0)TJ=TJ+TI XK=DTWO/DTHREE FR=DONE EN=IABS(NI) EL=LI IF(TE.GT.D1M70)VX=XK*DCON4*TE**(DONE/DTHREE)*TJ/TE VX=VX*FR*(TJ/(TJ+DTWO*ACOS(-DONE)/(EN-EL))) ENDIF ENDIF C 5 ZEFX=-T/R-VX C RETURN END C C ******************* C REAL*8 FUNCTION ZEFXL(X,ZL,DX,I) C C----------------------------------------------------------------------- C C N.R.BADNELL D.A.M.T.P. CAMBRIDGE C FN.ZEFXL EVALUATES THE INPUT POTENTIAL AT NON-GRID POINT X USING C N-PT LAGRANGE INTERPOLATION, WHERE X LIES BETWEEN DX(I) AND DX(I+1). C IR REQUIRES I .GT. N/2 , I ALWAYS .GT. 8 WITH THE AS GRID. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) C LOGICAL BREL,BJUMPR,BMVD C DIMENSION ZL(*),DX(*) C COMMON /NRBDEN/MDEN,MP0,DEBYE,GAMQ,ZNP,DENE,TKAY,VSC(MAXB1) X ,XC1,XC2 COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit C N=4 IM=N/2 IM=I-IM V=DZERO C DO J1=1,N DD=DONE J=IM+J1 C DO K1=1,N IF(J1.NE.K1)THEN K=IM+K1 DD=DD*(X-DX(K)) DD=DD/(DX(J)-DX(K)) ENDIF ENDDO C V=V+DD*(ZL(J)+DTWO*VSC(J)) IF(BREL)V=V+DD*PMVDAR(J,DX(J)) C ENDDO C ZEFXL=V C RETURN END C C ******************* C SUBROUTINE ZERO C IMPLICIT REAL*8 (A-H,O-Z) C C----------------------------------------------------------------------- C C SR.ZERO PRINTS DETAILS OF THE PRIMARY DIMENSIONS FOR AUTOSTRUCTURE. C C----------------------------------------------------------------------- C INCLUDE './PARAM' C CHARACTER(LEN=5) KNM0,KNAM,local C COMMON /NRBDIM/MXUSED(MXDIM),KNAM(MXDIM) C DIMENSION KDIM(MXDIM),KNM0(MXDIM) C C C NOTES ON PRIMARY DIMENSIONS FOR AUTOSTRUCTURE. C SEE THE INCLUDE FILE 'PARAM' FOR THE ACTUAL VALUES TO BE USED. C C C MAXCF=MAXIMUM NUMBER OF CONFIGURATIONS. C C MAXGR=MAXIMUM NUMBER OF DISTINCT ORBITAL VALUES (N,L) -- C ADAPT SR.ALGEB1 (LIT, DO39 ETC) IF MAXGR.GT.60 REQUIRED. C ARRAY DIMENSION IS MAXGR*MAXB1. C C MXGRB=NO. OF NON-CORE (N,L) ORBITALS USED FOR BORN INTEGRALS. C C MAXCL=MAXIMUM NUMBER OF CORE ELECTRONS. C C MXEL0=MAXIMUM NUMBER OF VALENCE ELECTRONS. C C MAXSL=MAXIMUM NUMBER OF DISTINCT TERM VALUES SL (AND PARITY). C C MAXJG=MAXIMUM NUMBER OF DISTINCT LEVEL VALUES J (AND PARITY). C C MAXTM=MAXIMUM NUMBER OF TERMS T (.GE.MAXSL). C C MAXLV=MAXIMUM NUMBER OF LEVELS LV (.GE.MAXJG). C C MAXAD=MAXIMUM NUMBER OF DISTINCT MATRIX ELEMENTS ( T ! H ! TP ), C (N*(N+1))/2 FOR A N*N H-MATRIX SL (I.E. FOR ONE SL GROUP). C UP TO MAXTM ADDITIONAL LOCATIONS ARE NEEDED WHEN COMPUTING C RADIATIVE DATA (IF NOT THEN ONLY ONE MORE LOCATION). C C MXADJ=MAXIMUM NUMBER OF DISTINCT MATRIX ELEMENTS (LV ! H ! LVP). C (N*(N+1))/2 FOR A N*N H-MATRIX J (I.E. FOR ONE J GROUP). C C MXAJS=MXADJ FOR TWO-BODY FINE-STRUCTURE, =1 IF NONE. C C MXEST=SPECIFIES THE SIZE OF TWO DIMENSIONAL QUANTUM NUMBER ARRAYS C REPRESENTING SLATER STATES. PROVIDE AT LEAST (NUMBER MAXEL C OF VALENCE ELECTRONS)*(NUMBER MAXST OF SLATER STATES+1) C LOCATIONS. NOTE: ALTHOUGH MXEST CANNOT EXCEED MXEL0*MXST0, C ONE RARELY USES THE MAXIMUM DIMENSIONED MXEL0 & MXST0 AT C THE SAME TIME SO DIMENSIONING AS SUCH IS INEFFICIENT. C C MXST0=MAXIMUM NUMBER OF SLATER STATES, ALLOWING FOR ONE C ADDITIONAL BUFFER LOCATION. TO MAXIMISE EFFICIENT USE OF C MXEST SET MXST0=MXEST/2 IF POSSIBLE. C C MAXDC=MAXIMUM NUMBER OF VECTOR COUPLING COEFFICIENTS. C C MAXUC=MAXIMUM NUMBER OF CONFIGURATION MIXING COEFFICIENTS IN C SL COUPLING. REQUIRES AT LEAST C THE TOTAL NUMBER OF ELEMENTS IN THE REDUCED H-MATRIX. C APPROX=2*MAXAD TO CALCULATE RADIATIVE RATES. C IF NONE REQUIRED THEN ONLY MAXDI**2 IS NEEDED. C C MAXJU=MAXIMUM NUMBER OF CONFIGURATION MIXING COEFFICIENTS IN C INTERMEDIATE COUPLING. REQUIRES AT LEAST C THE TOTAL NUMBER OF ELEMENTS IN THE REDUCED H-MATRIX. C APPROX=2*MXADJ TO CALCULATE RADIATIVE RATES. C IF NONE REQUIRED THEN ONLY MAXDK**2 IS NEEDED. C C MAXRK=MAXIMUM NUMBER OF COEFFICIENTS TO SLATER INTEGRALS R. C EACH REDUCED ALGEBRAIC MATRIX ELEMENT FOR DIPOLE OR C QUADRUPOLE RADIATION REQUIRES ONE ADDITIONAL LOCATION. C TERM RESOLVED. C C MAXRL=MAXIMUM NUMBER OF SLATER INTEGRALS R, TERM RESOLVED. C C MAXMI=MAXIMUM NUMBER OF MAGNETIC INTEGRALS, N AND V. C C MXRSS=MAXIMUM NUMBER OF ALGEBRAIC COEFFICIENTS E AND D (TO N, V). C C MXSOI=MAXIMUM NUMBER OF DISTINCT SPIN-ORBIT COEFFICIENTS ZETA. C C MXSOC=MAXIMUM NUMBER OF ALGEBRAIC COEFFICIENTS C (TO ZETA). C C MAXLL=BIGGEST ORBITAL L INCLUDED IN INTERNAL TABLES OF ANGULAR C MOMENTUM FUNCTIONS-WHICH SAVE COMPUTING TIME FOR SUCH C ORBITALS, THOUGH AT THE EXPENSE OF 2*(MAXLL+1)**5 WORDS. C A VALUE OF 8 OR SO (DEPENDING UPON MAXGR OR MAXDF) C WILL IN GENERAL NOT INCREASE THE EFFECTIVE SIZE OF AUTO- C STRUCTURE-MAXLL AFFECTS THE BRANCHES ALGEB2 AND ALGEB3. C C MAXDF=MAXIMUM NUMBER OF TERMS SL IN A CONFIGURATION (ALGEB1). C ARRAY DIMENSION MAXDF**2. C C MAXDI=MAX. NUMBER OF TERMS IN A GROUP (WITH SAME SL) (DIAGON). C ARRAY DIMENSION MAXDI**2. C C MAXDK=MAX. NUMBER OF LEVELS IN A GROUP (WITH SAME J) (DIAGFS). C ARRAY DIMENSION MAXDK**2. C C MAXB1=MAXIMUM NUMBER OF INTEGRATION POINTS FOR RADIAL FUNCTIONS, C EFFECTIVE VALUE MAXQS REDUCES ACCORDING TO DEL IN SR.RADIAL C MAXB1 FURTHER RELATES TO THE NUMBER OF POINTS OF A USER- C SUPPLIED RADIAL FUNCTION P/Q -- POINTS IN EXCESS OF MAXB1 C (2*MAXB1 IN THE CASE OF PRECISION='DOUBLE') ARE IGNORED. C ARRAY DIMENSION MAXB1*MAXGR. C C MAXB2=MAXIMUM NUMBER OF INTEGRATION POINTS INVOLVING Q(NL). C SET .EQ. MAXB1. USED FOR USER SUPPLIED FUNCTIONS, SMALL C COMPONENT OF SEMI-RELATIVISTIC ORBITALS AND NL-DEPENDENT C POTENTIALS. C ARRAY DIMENSION MAXB1*MAXGR. C C MXVAR=MAXIMUM NUMBER OF VARIATIONAL PARAMETERS. SET .EQ. MAXGR C FOR V(NL) OR 1+MAX(L) FOR V(L), ORBITALS NL. SMALL. C C MXNOR=LOCATIONS (-1) AVAILABLE TO STORE NON-VANISHING ELECTRIC C DIPOLE TRANSITION PROBABILITIES (.GE.1.E-2/SEC) IN INTER- C MEDIATE COUPLING, USED FOR OPTIONAL CASCADE COEFFICIENTS. C SET .EQ. 1 FOR NONE. C C MAXTR=THE SIZE OF A BUFFER ARRAY TO HOLD TERM COUPLING COEFFI- C CIENTS, FOR BOTH PARITIES OF ANY VALUE J: .LE.2*MAXDK**2. C C MAXCA=MAXIMUM NUMBER OF CASCADE COEFFICIENTS. SET .EQ. 1 FOR NONE. C C MXDFS=SIZE OF FACTORIAL ARRAY IN SR.ALGEB2 AND SR.SOCC C IF SET .EQ. 150 THIS SHOULD SUFFICE. SMALL. C MXPOT=NUMBER OF DISTINCT L-DEPENDENT POTENTIALS STORED C READY FOR USE IN EVALUATION OF CONTINUUM FUNCTIONS IN C SR.RADCON. ARRAY DIMENSION MXPOT*MAXB1. C C MXENG=MAXIMUM NUMBER OF INTERPOLATION ENERGIES FOR EACH C CONTINUUM ORBITAL. AFFECTS TWO DIMENSIONAL ARRAYS BELOW. C C MXFSL=MAXIMUM NUMBER OF NON-ZERO BOUND-CONTINUUM SLATER INTEGRALS. C ARRAY DIMENSION IS MXENG*MXFSL. C C MXFSS=MAXIMUM NUMBER OF NON-ZERO BOUND-CONTINUUM FINE-STRUCTURE C INTEGRALS. ARRAY DIMENSION IS MXENG*MXFSS. C C MXFOO=MAXIMUM NUMBER OF NON-ZERO BOUND-CONTINUUM NON-FINE-STRUCTURE C INTEGRALS. ARRAY DIMENSION IS MXENG*MXFOO. C C MXAAI=MAXIMUM NUMBER OF BOUND-CONTINUUM INTERACTIONS IN A GROUP C (SAME SL) IN SR.DIAGON. EQUALS NO. OF BOUND TERMS*NO. OF C CONTINUUM TERMS=NO. OF AUTOIONIZATION RATES IF ALL C BOUND TERMS ARE ENERGETICALLY ACCESSIBLE. C SET MXAAI .LT. (MAXDI/2)**2 SINCE ONLY REACHES LIMIT IN SMALL C CASES. ARRAY DIMENSION IS MXENG*MXAAI. C C C MXAAK=MAXIMUM NUMBER OF BOUND-CONTINUUM INTERACTIONS IN A GROUP C (SAME J) IN SR.DIAGFS. EQUALS NO. OF BOUND TERMS*NO. OF C CONTINUUM TERMS=NO. OF AUTOIONIZATION RATES IF ALL C BOUND TERMS ARE ENERGETICALLY ACCESSIBLE. C SET MXAAK .LT. (MAXDK/2)**2 SINCE ONLY REACHES LIMIT IN SMALL C CASES. ARRAY DIMENSION IS MXENG*MXAAK. C C MXBLM=MAXIMUM BORN LAMBDA MULTIPOLE RETAINED (MIN 2). IN GENERAL, C NEED TWICE MAX ORBITAL L. C C MXBIF=MAXIMUM NUMBER OF BORN INTERACTIONS FOR ANY STATE (LS & IC). C I.E. IF THERE ARE N-STATES WHICH ALL BORN INTERACT THEN THERE C ARE (N*(N+1))/2 DISTINCT INTERACTIONS. C C MXRKO=MAXIMUM NUMBER OF COEFFICIENTS TO ORBIT-ORBIT INTEGRALS. C =1 FOR NO NON-FINE-STRCUTURE OR =MAXRK FOR NFS. C C MXRLO=MAXIMUM NUMBER OF ORBIT-ORBIT INTEGRALS. C =1 FOR NO NON-FINE-STRCUTURE OR =MAXRL FOR NFS. C C MXRKS=MAXIMUM NUMBER OF COEFFICIENTS TO SLATER INTEGRALS R. C SIMILAR TO MAXRK BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXRLS=MAXIMUM NUMBER OF SLATER INTEGRALS R. C SIMILAR TO MAXRL BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXROS=MAXIMUM NUMBER OF COEFFICIENTS TO ORBIT-ORBIT INTEGRALS. C SIMILAR TO MAXRO BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXS1C=MAXIMUM NUMBER OF COEFFICIENTS TO 1-BODY SPIN-ORBIT INTEGRALS C SIMILAR TO MXSOC BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXS1I=MAXIMUM NUMBER OF 1-BODY SPIN-ORBIT INTEGRALS C SIMILAR TO MXSOI BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXS2C=MAXIMUM NUMBER OF COEFFICIENTS TO 2-BODY FINE-STRUCTURE INTGRLS C SIMILAR TO MXRSS BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXS2I=MAXIMUM NUMBER OF 2-BODY FINE-STRUCTURE INTEGRALS C SIMILAR TO MAXMI BUT SLATER STATE RESOLVED, AND PER SYMMETRY. C C MXCHG=MAXIMUM NUMBER OF N-ELECTRON TARGET SLP GROUPS WHICH C CONTRIBUTE TO AN (N+1)-ELECETRON SLP SYMMETRY. C C MXSTX=MAXIMUM NUMBER OF N-ELECTRON TARGET SLATER STATE INTERACTIONS. C (OF ORDER (MXST0/2)**2) C C MXSYJ=MAXIMUM NUMBER OF (N+1)-ELECTRON SLP SYMMETRIES WHICH C CONTRIBUTE TO A JP SYMMETRY C C DATA IFIRST/0/ C DATA KNM0( 1),KNM0( 2),KNM0( 3) /'MXAAI','MXAAK','MAXAD'/ DATA KNM0( 4),KNM0( 5),KNM0( 6) /'MXADJ','MXAJS','MAXB1'/ DATA KNM0( 7),KNM0( 8),KNM0( 9) /'MAXB2','MXBIF','MXBLM'/ DATA KNM0(10),KNM0(11),KNM0(12) /'MAXCA','MAXCF','MAXCL'/ DATA KNM0(13),KNM0(14),KNM0(15) /'MAXCT','MAXDC','MAXDF'/ DATA KNM0(16),KNM0(17),KNM0(18) /'MXDFS','MAXDI','MAXDK'/ DATA KNM0(19),KNM0(20),KNM0(21) /'MXEL0','MXENG','MXEST'/ DATA KNM0(22),KNM0(23),KNM0(24) /'MXFSL','MXFSS','MXFOO'/ DATA KNM0(25),KNM0(26),KNM0(27) /'MAXGR','MXGRB','MAXJG'/ DATA KNM0(28),KNM0(29),KNM0(30) /'MAXJU','MAXLL','MAXLV'/ DATA KNM0(31),KNM0(32),KNM0(33) /'MAXMI','MXNOR','MXPOT'/ DATA KNM0(34),KNM0(35),KNM0(36) /'MAXRK','MXRKO','MXRKS'/ DATA KNM0(37),KNM0(38),KNM0(39) /'MAXRL','MXRLO','MXRLS'/ DATA KNM0(40),KNM0(41),KNM0(42) /'MXROS','MXRSS','MAXSL'/ DATA KNM0(43),KNM0(44),KNM0(45) /'MXSOC','MXSOI','MXST0'/ DATA KNM0(46),KNM0(47),KNM0(48) /'MXS1C','MXS1I','MXS2C'/ DATA KNM0(49),KNM0(50),KNM0(51) /'MXS2I','MAXTM','MAXTR'/ DATA KNM0(52),KNM0(53) /'MAXUC','MXVAR'/ DATA KNM0(54),KNM0(55),KNM0(56) /'MXCHG','MXSTX','MXSYJ'/ DATA KDIM( 1),KDIM( 2),KDIM( 3) /MXAAI,MXAAK,MAXAD/ DATA KDIM( 4),KDIM( 5),KDIM( 6) /MXADJ,MXAJS,MAXB1/ DATA KDIM( 7),KDIM( 8),KDIM( 9) /MAXB2,MXBIF,MXBLM/ DATA KDIM(10),KDIM(11),KDIM(12) /MAXCA,MAXCF,MAXCL/ DATA KDIM(13),KDIM(14),KDIM(15) /MAXCT,MAXDC,MAXDF/ DATA KDIM(16),KDIM(17),KDIM(18) /MXDFS,MAXDI,MAXDK/ DATA KDIM(19),KDIM(20),KDIM(21) /MXEL0,MXENG,MXEST/ DATA KDIM(22),KDIM(23),KDIM(24) /MXFSL,MXFSS,MXFOO/ DATA KDIM(25),KDIM(26),KDIM(27) /MAXGR,MXGRB,MAXJG/ DATA KDIM(28),KDIM(29),KDIM(30) /MAXJU,MAXLL,MAXLV/ DATA KDIM(31),KDIM(32),KDIM(33) /MAXMI,MXNOR,MXPOT/ DATA KDIM(34),KDIM(35),KDIM(36) /MAXRK,MXRKO,MXRKS/ DATA KDIM(37),KDIM(38),KDIM(39) /MAXRL,MXRLO,MXRLS/ DATA KDIM(40),KDIM(41),KDIM(42) /MXROS,MXRSS,MAXSL/ DATA KDIM(43),KDIM(44),KDIM(45) /MXSOC,MXSOI,MXST0/ DATA KDIM(46),KDIM(47),KDIM(48) /MXS1C,MXS1I,MXS2C/ DATA KDIM(49),KDIM(50),KDIM(51) /MXS2I,MAXTM,MAXTR/ DATA KDIM(52),KDIM(53) /MAXUC,MXVAR/ DATA KDIM(54),KDIM(55),KDIM(56) /MXCHG,MXSTX,MXSYJ/ C IF(IFIRST.EQ.0)THEN !PRINT MAX DIMENSIONS WRITE(6,1000) WRITE(6,1001) WRITE(6,1002) WRITE(6,1003) (KNM0(I),KDIM(I),I=1,MXDIM) IFIRST=1 DO I=1,MXDIM MXUSED(I)=0 C KNAM(I)=KNM0(I) !F95 SHOULD USE MODULE, BUT FOR F77... local=knm0(i) !for g77 as above does not transfer... knam(i)=local ENDDO ELSE !PRINT DIMENSION USED CTBD ENDIF C RETURN C 1000 FORMAT(///132('*')/132('*')// X/31X,' AAAAAAAA UU UU TTTTTTTTTT OOOOOOOO', X/31X,'AAAAAAAAAA UU UU TTTTTTTTTT OOOOOOOOOO', X/31X,'AA AA UU UU TT OO OO', X/31X,'AA AA UU UU TT OO OO', X/31X,'AA AA UU UU TT OO OO', X/31X,'AA AA UU UU TT OO OO', X/31X,'AAAAAAAAAA UU UU TT OO OO', X/31X,'AAAAAAAAAA UU UU TT OO OO', X/31X,'AA AA UU UU TT OO OO', X/31X,'AA AA UU UU TT OO OO', X/31X,'AA AA UUUUUUUUUU TT OOOOOOOOOO', X/31X,'AA AA UUUUUUUU TT OOOOOOOO') 1001 FORMAT(/ X/1X,' SSSSSSSS TTTTTTTTTT RRRRRRRRR UU UU', X' CCCCCCCC TTTTTTTTTT UU UU RRRRRRRRR ', X' EEEEEEEEEE' X/1X,'SSSSSSSSSS TTTTTTTTTT RRRRRRRRRR UU UU', X' CCCCCCCCCC TTTTTTTTTT UU UU RRRRRRRRRR ', X' EEEEEEEEEE' X/1X,'SS TT RR RR UU UU', X' CC CC TT UU UU RR RR ', X' EE' X/1X,'SS TT RR RR UU UU', X' CC TT UU UU RR RR ', X' EE' X/1X,'SS TT RR RR UU UU', X' CC TT UU UU RR RR ', X' EE' X/1X,'SSSSSSSSS TT RRRRRRRR UU UU', X' CC TT UU UU RRRRRRRR ', X' EEEEEEEEE') 1002 FORMAT( X 1X,' SSSSSSSSS TT RRRRRR UU UU', X' CC TT UU UU RRRRRR ', X' EEEEEEEEE' X/1X,' SS TT RR RR UU UU', X' CC TT UU UU RR RR ', X' EE' X/1X,' SS TT RR RR UU UU', X' CC TT UU UU RR RR ', X' EE' X/1X,' SS TT RR RR UU UU', X' CC CC TT UU UU RR RR ', X' EE' X/1X,'SSSSSSSSSS TT RR RR UUUUUUUUUU', X' CCCCCCCCC TT UUUUUUUUUU RR RR ', X' EEEEEEEEEE' X/1X,' SSSSSSSS TT RR RR UUUUUUUU ', X' CCCCCCC TT UUUUUUUU RR RR', X' EEEEEEEEEE'///132('*')/132('*')////) 1003 FORMAT(///' THIS VERSION OF AUTOSTRUCTURE (24.24.2) IS COMPILED' X,' WITH THE FOLLOWING ', X'STORAGE PARAMETERS-'///4(6X,'NAME',4X,'VALUE',10X)// X 4(5X,A5,I9,10X)) END C C ******************* C SUBROUTINE ZETA(K1,K3,DK) C C----------------------------------------------------------------------- C C SR.ZETA EVALUATES THE ORDINARY NUCLEAR SPIN-ORBIT ZETA INTEGRAL, C BUT OMITS Z. C C Q.NE.0 (BREL2) CASE IREL.GT.0 ONLY C BREL/2 USES SMALL R CORRECTION C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DFSC=7.2973525333D-03) PARAMETER (DALF=DFSC*DFSC) PARAMETER (DZERO=0.0D0) PARAMETER (DONE=1.0D0) PARAMETER (DTWO=2.0D0) PARAMETER (DFOUR=4.0D0) PARAMETER (C4=DALF/DFOUR) C LOGICAL BREL,BJUMPR,BMVD,BREL2 C COMMON /CHARY/DEY(MAXGR) COMMON /COM1/DP(MAXB1),TDUM,MDMM COMMON /COM6/DPA(MAXB1) COMMON /CRAD/DHNS(20),MNH(20),MJH,MAXRS,JDUM(MAXGR) c COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) COMMON /GENINF/DADJUS(MXVAR),DSCREE(MAXGR),MION,NZION,NPARAM X ,ITOL,INCLUD,JPRINT COMMON /RADF/DPNL(MAXB1,MAXGR),DUY(MAXGR,MAXGR),DX(MAXB1) X ,DORIG(MAXGR) COMMON /NRBDQE/DQNL(MAXB2,MAXGR) c COMMON /NRBPOT/POT(MAXB1,MXPOT) COMMON /NRBREL/BREL,BJUMPR,BMVD,IREL,KAPPA,IGAGR,irtard,ibreit common /nrbtmp/rnorm(maxgr),ncc0(maxgr),iorb(0:maxgr) C BREL2=IABS(IREL).EQ.2 C DZ=NZION DD=DONE D00=DZERO C DE1=DEY(K1)-DUY(K1,K1) !BREL K1=K3 CURRENTLY DE3=DEY(K3)-DUY(K3,K3) !BREL K1=K3 CURRENTLY C IF(BREL2)THEN T=C4*DTWO DO I=1,MAXRS DD1=DONE+T*(DE1+DZ/DX(I)) DD3=DONE+T*(DE3+DZ/DX(I)) C DD1=DONE+T*(DE1+POT(I,1)) C DD3=DONE+T*(DE3+POT(I,1)) DP(I)=DPNL(I,K1)*DPNL(I,K3) !+DQNL(I,K1)*DQNL(I,K3) DP(I)=DP(I)/(SQRT(DD1*DD3)*DX(I)*DX(I)*DX(I)) ENDDO ELSE C IF(IREL.LT.0)THEN DO I=1,MAXRS DP(I)=DQNL(I,K1)*DQNL(I,K3)/(DPNL(I,K1)*DPNL(I,K3)) DP(I)=SQRT(DP(I))/(DTWO*DZ) ENDDO CALL DIFF(DP,DPA,MNH,DHNS,MJH) !POTENTIAL DERIVATIVE ENDIF C DO I=1,MAXRS DP(I)=DPNL(I,K1)*DPNL(I,K3)/(DX(I)*DX(I)*DX(I)) ENDDO C IF(IREL.LT.0)THEN DO I=1,MAXRS DP(I)=DP(I)+DP(I)*DPA(I)*DX(I)*DX(I) c dpa(i)=dp(i)*dpa(i)*dx(i)*dx(i) ENDDO ENDIF C IF(BREL)THEN c write(0,*)k1,k3 c t=c4*dtwo DO I=1,MAXRS c write(6,*)i,dqnl(i,k1),dqnl(i,k3),dpnl(i,k1),dpnl(i,k3),dx(i) DD1=DONE+C4*(DQNL(I,K1)/DPNL(I,K1)+DTWO*DZ/DX(I)) DD3=DONE+C4*(DQNL(I,K3)/DPNL(I,K3)+DTWO*DZ/DX(I)) c dd1=done+t*(de1+dz/dx(i)) c dd3=done+t*(de3+dz/dx(i)) DP(I)=DP(I)/SQRT(DD1*DD3) c DP(I)=DP(I)*(1./DD1+1./DD3)*.5 !test k1.ne.k3 ENDDO dd=dd*rnorm(k1)*rnorm(k3) c write(0,*)rnorm(k1),rnorm(k3) ENDIF c c if(irel.lt.0)then c do i=1,maxrs c dp(i)=dp(i)+dpa(i) c enddo c endif c ENDIF C CALL WEDDLE(D00,DP,DKU,MNH,DHNS,MJH,MAXRS) C DK=DKU*DD*C4 C RETURN END C C ******************* C REAL*8 FUNCTION ZLAM(LAM,K1,K2,K3,K4) C C----------------------------------------------------------------------- C C FN.ZLAM EVALUATES THE Z-LAMDA INTEGRAL OF ORBIT-ORBIT INTERACTION. C C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-P,R-Z) IMPLICIT INTEGER (Q) C INCLUDE './PARAM' C PARAMETER (DZERO=0.0D0) C COMMON /DBD2/QCG(MXEL0,MAXCF),QL(MAXGR),QN(MAXGR) C Z=DZERO IF(LAM.EQ.0.or.k1.eq.k3.or.k2.eq.k4)GO TO 1 !apply anti-symmetry C LP=LAM+1 LM=LAM-1 LLP=LAM*LP LM2=LAM-2 L1=QL(K1)/2 L1P=L1*(L1+1) L2=QL(K2)/2 L2P=L2*(L2+1) L3=QL(K3)/2 L3P=L3*(L3+1) L4=QL(K4)/2 L4P=L4*(L4+1) T1=LLP L2=L1P-L3P-LLP T2=L2 L3=L2P-L4P-LLP T3=L3 L6=L2*L3 LAM2=LM2*L6 T6=L6 C JONES INCORRECT T6=SQRT(T6) C T=LAM+3 T7=(LAM+1)*(2*LAM+3) T7=-T/T7 T=LM2 T8=LAM*(2*LAM-1) T8=T/T8 TP=TLAM(LP,K1,K2,K3,K4) TM=TLAM(LM,K1,K2,K3,K4) UP1=DZERO IF(L2.NE.0)UP1=ULAM(LP,K1,K2,K3,K4) UM1=DZERO IF(L2.NE.0)UM1=ULAM(LM,K1,K2,K3,K4) UP2=DZERO IF(L3.NE.0)UP2=ULAM(LP,K2,K1,K4,K3) UM2=DZERO IF(L3.NE.0)UM2=ULAM(LM,K2,K1,K4,K3) V1=DZERO IF(L6.NE.0)V1=VLAM(LAM,K1,K2,K3,K4) V2=DZERO IF(LAM2.NE.0)V2=VLAM(LM2,K1,K2,K3,K4) Z=T1*(TP-TM)+T2*(UP1-UM1)+T3*(UP2-UM2)+T6*(T7*V1+T8*V2) C JONES INCORRECT, -T1 C 1 ZLAM=Z C C WRITE(6,100) K1, K2, K3, K4, 2*LAM, ZLAM C100 FORMAT(8X,2(I5,I4),I6,F14.7,' =ZLAM') C RETURN END