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