c PSTG2R :: Parallel Version 1.10 of stg2r. 30/06/21 c c Dario M. Mitnik c Version 1.1: c Read distributed Bound-Continuum integrals c Read distributed Continuum-Continuum integrals c c N. R. Badnell c Version 1.2: Extend and correct 1.1 c Version 1.3: Use single UNIT per proc. Split AMATUXXX.DAT c Version 1.4: Serial updates c Version 1.5: Serial updates for NX usage c Version 1.8: Serial updates c Version 1.9: Serial updates for KCUT usage c Version 1.10:Serial updates c c C. P. Ballance c Version 1.6: Replace COMMON by MODULE/ALLOCATE to reduce memory. c Version 1.7 RK integrals allocated and modularised c Asympotic potential coefficients minimised c Modified to implement scripting options c C*********************************************************************** C C N. R. BADNELL UoS v3.8 - QUB v1.4 29/06/21 C C C*********************************************************************** C C Developed From Belfast Atomic R-matrix Codes C C*********************************************************************** C C THE SECOND PART OF C C A GENERAL PROGRAM TO CALCULATE ATOMIC CONTINUUM C C PROCESSES USING THE R-MATRIX METHOD C C S T G 2 C C DISTRIBUTED BY C C QUEEN'S UNIVERSITY BELFAST C C*********************************************************************** C C THIS PROGRAM EVALUATES HAMILTONIAN AND MULTIPOLE MATRIX ELEMENTS C BETWEEN ARBITRARILY COUPLED L-S CONFIGURATIONS FOR ANY ATOMIC OR C IONIC SYSTEM. IT CALCULATES THE ANGULAR CONTRIBUTIONS TO THESE C MATRIX ELEMENTS FROM DATA READ IN BY THE SEGMENT STG2RD AND C OBTAINS THE RADIAL INTEGRALS FROM FILES CREATED BY C THE FIRST PART OF THE CODE, STG1. C C INCORPORATES RMATRX STG2 (CPC 14, 367 (1978)) WITH THE C BREIT-PAULI CODE RMATRX STG2R (CPC 25, 347-387 (1982)), C THE DIMENSIONS ARE INCLUDED VIA A PARAM FILE. C C REQUIRES TO BE LINKED WITH STGLIB LIBRARY ROUTINES. C C*********************************************************************** C C ROUTINES USED IN STG2 C C*********************************************************************** C C MNSTG2 C STG2 DRIVER C AIJS C ALDAIJ C AMOUT C BLOCK DATA C BOUND C CHEKTP C CONFIG C CONPED C CONQN C CONSH C CONSTO C CONTST C COPYTP C DA2 C DH0 C DMCON C DMEL C DMELBB C DMELBC C DMELCB C DMELCC C DMELBD C DMELCD C DMELDB C DMELDC C DMELDD C DWOUT1 C DWOUT2 C DWOUT3 C FINBB C FINBC C FINCC1 C FINCC2 C FINMNT C FIN1BB C FIN1BC C FIN1CC C INTECH C ISTG2 C MATANS C MATRX C NICCHAN C NJCHAN C NJLJOD C NOJTS C ODH0 C PNTBG2 C PRNTWT C RDINT C RECOV2 C REDRAD C RKWTS C SETCUP C SETFIN C SETINI C SETMX1 C SETMXR C SETUP C SHRIEK C SJ1QNT C SJ2QNT C SLATER C STG2RD C USEEAV C VIJOUT C WRINX2 C WRITAP C STGLIB LIBRARY ROUTINES USED: C BLOCK DATA C CFP C CG C CHOP C DRACAH C FACTT C FANO C GENSUM C H0WTS C HSLDR C INTACT C MEKEST C NJGRAF C NTAB1 C ORDER C ORTHOG C REDUCE C RME C SETM C SETUPE C TENSOR C TRITST C C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN STG2 C C*********************************************************************** C C IREAD USER INPUT FILE C IWRITE OUTPUT TO LINE PRINTER C C IPUNCH OPTIONAL OUTPUT FOR CONFIGURATION DATA C C IDISC1 SCRATCH DA FILE, USED IN DMCON FOR CHANNEL AND CON- C FIGURATION DATA, AND IN SETMX1 FOR H MATRIX BLOCKS C IDISC2 NOT USED C IDISC3 NOT USED C IDISC4 NOT USED C C ITAPE1 INPUT FILE OF STG1 INTEGRALS C ITAPE2 OPTIONAL INPUT FILE OF STG2 H-MATRICES (RESTART) C ITAPE3 OUTPUT FILE OF H-MATRICES C ITAPE4 OUTPUT FILE OF DIPOLE MATRIX ELEMENTS C C JREAD OPTIONAL INPUT FOR CONFIGURATION DATA C C JDISC1 INPUT DA FILE OF RK INTEGRALS FROM STG1 C JDISC2 NOT USED. C C C IREAD (5) .. input data .. dstg2 C IWRITE (6) .. printed output .. rout2r C C IPUNCH .. NOT USED C C IDISC1 (11) .. scratch C IDISC2 .. NOT USED C IDISC3 .. NOT USED C IDISC4 .. NOT USED C C ITAPE1 (1) .. STG1 dump .. STG1.DAT .. always used C ITAPE2 (2) .. old STG2 dump .. STG2.DMP .. if ICOPY>0 C C ITAPE3 (3) .. file for STG2 dump (hamiltonians) C .. STG2H.DAT/STG2HXXX.DAT C C ITAPE4 (4) .. STG2 dump (dipole matrix) .. STG2D.DAT .. if IPOLPH=2 C C JREAD (5) .. input config data C C JDISC1 (21) .. RK.DAT C JDISC2 .. NOT USED C C*********************************************************************** C C DIMENSIONING PARAMETERS USED IN STG2 C C*********************************************************************** C C INCLUDE PARAMETERS: C C CHF (75) NUMBER OF SCATTERING CHANNELS (NCHAN) C CHD (75) AS CHF: SET=CHF FOR CC AND =1 FOR DW ONLY. C FAC (32) LARGEST FACTORIAL AVAILABLE ON MACHINE C KIL (1) KILO-WORDS OF MEMORY, FOR INTEGRAL STORAGE C (CAN BE MADE BIGGER, TO REDUCE DISK I/O) C LMX (8) MULTIPOLES IN POTENTIAL (LAMAX) C LR1 (5) HIGHEST L+1 FOR BOUND ORBITALS (LRANG1) C LR2 (20) HIGHEST L+1 FOR CONTINUUM ORBITALS (LRANG2) C MEG (1) MEGA-WORDS OF MEMORY, FOR INTEGRAL STORAGE C (CAN BE MADE BIGGER, TO REDUCE DISK I/O) C NC0 (50) TARGET CONFIGURATIONS FOR GIVEN S L PI C NC1 (50) TARGET CONFIGURATIONS FOR GIVEN S L PI C NC2 (600) N+1 ELECTRON CONFIGURATIONS FOR GIVEN S L PI (NCFGP) C NR1 (5) HIGHEST N FOR BOUND ORBITALS (MAXNHF) C NR2 (40) NUMBER OF CONTINUUM ORBITALS FOR GIVEN L (NRANG2) C OCC (15) OCCUPIED SHELLS IN A GIVEN CONFIGURATION C OVL (15) OPEN SHELLS IN A GIVEN CONFIGURATION C SLP (80) NUMBER OF DIFFERENT S L PI (INAST) C TAR (200) TARGET STATES OR CONFIGURATIONS (NAST, NCFG) C C*********************************************************************** C C MODULE BASIC2 IMPLICIT REAL*8(A-H,O-Z) REAL*8,ALLOCATABLE :: CF(:,:,:) REAL*8,ALLOCATABLE :: ET(:) INTEGER,ALLOCATABLE :: L2P(:),LSTARG(:),NCONAT(:) INTEGER :: LRGL,NSPN,NPTY END MODULE BASIC2 C*********************************************************************** MODULE DIPMEL IMPLICIT REAL*8(A-H,O-Z) REAL*8,ALLOCATABLE :: DEL(:,:),DEV(:,:) REAL*8,allocatable :: HNP1(:,:) REAL*8,ALLOCATABLE :: HNPS(:) END MODULE DIPMEL C*********************************************************************** MODULE MEMORY IMPLICIT REAL*8(A-H,O-Z) REAL*8,ALLOCATABLE,TARGET :: RKSTO2(:) REAL*8,POINTER :: ARRAY(:) INTEGER :: MEM1,MREC1 END MODULE MEMORY C C*********************************************************************** c c PROGRAM MNSTG2 use basic2 use dipmel use memory IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXCTAB=MZLR2*MZLR2/2*MZLR2/2+MZLR2*MZLR2/2+MZLR2) PARAMETER (MXFCT=500) PARAMETER (MXICT=4*MZLR1*MZLR1*MZLR1*MZLR2*MZLR2) PARAMETER (MXL2=9) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXXNCF=1) C PARAMETER (MXXNCF=MXNCF) PARAMETER (MXNTRI=MXXNCF*MXXNCF/2+MXXNCF) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) PARAMETER (MXPOL= (MZLMX+1)/2) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C C MXORB = NUMBER OF BOUND ORBITALS: C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) PARAMETER (MXBBI=MXORB*MXORB/2*MZLMX+MXORB*MZLMX) C C FOR /INSTO2/ AND /INSTO3/ AND /INSTO6/: C PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ, A MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2, B MXCTCC=MZLR2+MZLR1-1) PARAMETER (MX2LR2=2*MZLR2) PARAMETER (NTOM1=MZCHD*MZNR1) C PARAMETER (NTOM2=MZNC2*NTOM1) !LARGE PARAMETER (NTOM2=1000000) PARAMETER (MXNC1=MZNC1*MZNC1/10+2*MZNC1) C C C*********************************************************************** C C COMMON BLOCKS USED IN STG2 C C*********************************************************************** C COMMON /ALPHA/LSP(MZSLP,3),LCHAN(MZSLP),LCFG(MZSLP) COMMON /AMATST/AFACT(NTOM2),NDIML,NDIMR,NONZER,ICHL(NTOM1), C IORB(NTOM1),ILEFT(NTOM2),IRIGHT(NTOM2) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /BNDINI/MCFGP,JOCCSH(MZNC2),JOCORB(MZOCC,MZNC2), A JELCSH(MZOCC,MZNC2),L1QNRD(MXOC21,3,MZNC2) COMMON /BOUND1/HSTORE(MXNTRI),A(MXXNCF,MXXNCF),TEMP(MXXNCF), A NTMP(MXXNCF),NTCTMP(MXXNCF),LSTO(MXXNCF,5),LNAST COMMON /BPSIZE/MXLR1,MXLR2,MXNC2,MXNR1,MXOCC COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /CONACT/MACT(MXORB),MNT(MXORB),JACT,J1QN(MXORB,3) COMMON /CONMX/H0MAT(MZNR2,MZNR2),VMAT(MZNR2,MZNR2) COMMON /CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN, A TINY COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CSTORE/CTABLE(MXCTAB),KPOINT(MZLR2,MZLR2),LRANG3 COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /CUPMAT/NCONOB(MXNCF),LCONOB(MXL2,MXNCF),LCONAT(MXL2,MZTAR) COMMON /CUPPLE/NOPTN,MNAL(MXORB),MXAL(MXORB),IBASSH(MZNC2,MXORB), A NXCITE(MZNC2),JREAD,LOCSH(MZNC2) COMMON /CUT/NCUT,IKIP(MZNC2,2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DIAG/NDIAG COMMON /DIAGNL/IDIAG,JA,JB COMMON /DIMEN/KFL1,KFL2,KFL3,KFL4,KFL5,KFL6,KFL7 C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DISTIB/NNELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON /DW/ISTL,ISTR,NCHNL,NCHNR,ICL,ICR,IE,IG,ISYM(MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /DWMETA/NTARG(MZCHF),IMETA(MZTAR),NMETAS COMMON /DWNEW/KKDDW(MZOVL,MZOVL,2),KKEDW(MZOVL,MZOVL,2) X,KDPDW(MZNC1,MZNC1,MZOVL,MZOVL),KEPDW(MZNC1,MZNC1,MZOVL,MZOVL) X,KDPOS,KEPOS,TERMD(MXNC1,MZLR1),TERME(MXNC1,MZLR1) COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /ENAV/COEFCT(5),NINTS,KVALUE(5) COMMON /FACT/GAMMA(MZFAC) COMMON /FACTS/GAM(MXFCT) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /INSTO5/BBINT(MXBBI),IBBI COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /KRON/IDEL(MXORB2,MXORB2) COMMON /MEDEFN/IHSH,NL(MXORB2,2),NOSH(MXORB2,2),J1QN2(MXORB3,3,2), A IJFUL(MXORB2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, A M16,M17,M18,M19,M20 COMMON /NJLJ/NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON /RECOV/IPLACE COMMON /REDMEL/CGC(MZLR2),MAXM1 COMMON /REL/IRELOP(3) COMMON /REMOVE/ICHOP(MXORB2) COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /RKSAVE/IRKBC,IRKCC(MZLR2,MZLR2,2),ICHUNK,ICT(MXICT),ITAPBC COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /SYMTX/NSTO(200) COMMON /TERMS/NROWS,L(18),J(18),N(189) COMMON /TYPE/ITYP(MZNC2) COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX COMMON /NRBSLP/ISLP(MZSLP),IAUTO,IELC,MINST,MAXST,MINLT,MAXLT, B NOICC COMMON /NRBSKP/ESKPL,ESKPH,ECORR,BCUT,ISKIP(MZTAR) C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc common /chanpblock/nchp(mzslp),ncnp(mzslp),mnpp(mzslp) common /lspiblock/nspna(mzslp),lrgla(mzslp),nptya(mzslp) integer nchpt(mzslp),ncnpt(mzslp),mnppt(mzslp) integer nspnt(mzslp),lrglt(mzslp),nptyt(mzslp) call mpi_init(ierr) call mpi_comm_rank(mpi_comm_world,iam,ierr) call mpi_comm_size(mpi_comm_world,nproc,ierr) call cpu_time(timei) c write(0,*) ' begin proc=:',iam c **** parallel **** C C C*********************************************************************** C C STG2 MAIN PROGRAM C C*********************************************************************** C C MEM1 AND MREC1 ARE THE MEMORY AND DA FILE POINTERS C MEM1 = 0 MREC1 = -1 C C BASIC2 COMMON BLOCK C C ********************************************************************* C C CPB 2009 C C allocate(CF(MZCHF,MZCHF,MZLMX)) ! READ LAMAX from rout1r allocate(ET(MZCHF),stat=ierr) if(ierr.ne.0)stop 'failure to allocate ET' allocate(L2P(MZCHF),stat=ierr) if(ierr.ne.0)stop 'failure to allocate L2P' allocate(LSTARG(MZCHF),stat=ierr) if(ierr.ne.0)stop 'failure to allocate LSTARG' allocate(NCONAT(MZTAR),stat=ierr) if(ierr.ne.0)stop 'failure to allocate NCONAT' C C MEMORY COMMON BLOCK C allocate(rksto2(mxmem),stat=ierr) ! MZMEG=100 if you have a choice if(ierr.ne.0)stop 'failure to allocate rksto2' array=>rksto2 ! array points to rksto2,see module above C C C DIPMEL COMMON BLOCK C allocate(DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2)) !only needed for dipole C allocate(HNP1(MXDM2,MXDM1),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HNP1' C C ********************************************************************* C CALL STG2 C nullify(array) ! give up memory for processes still running deallocate(rksto2) ! " deallocate(hnp1) ! " C C c **** parallel **** c call mpi_reduce(nchp,nchpt,mzslp,mpi_integer,mpi_sum,0, 1 mpi_comm_world,ierr) call mpi_reduce(ncnp,ncnpt,mzslp,mpi_integer,mpi_sum,0, 1 mpi_comm_world,ierr) call mpi_reduce(mnpp,mnppt,mzslp,mpi_integer,mpi_sum,0, 1 mpi_comm_world,ierr) call mpi_reduce(nspna,nspnt,mzslp,mpi_integer,mpi_sum,0, 1 mpi_comm_world,ierr) call mpi_reduce(lrgla,lrglt,mzslp,mpi_integer,mpi_sum,0, 1 mpi_comm_world,ierr) call mpi_reduce(nptya,nptyt,mzslp,mpi_integer,mpi_sum,0, 1 mpi_comm_world,ierr) CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) c if(iam.eq.0)then open(unit=10,file='sizeH.dat',status='unknown') do i=1,inast write(10,3010) nchpt(i),ncnpt(i),mnppt(i), 1 nspnt(i),lrglt(i),nptyt(i) 3010 FORMAT (' NCHAN =',I5,' NCONHP =',I7,' MNP1 =',I7,3I7) enddo close(10) endif c call cpu_time(timef) time=timef-timei time = time/60.0 WRITE(IWRITE,999) TIME,nproc 999 FORMAT(//1X,'CPU TIME=',F9.3,' MIN -- processors=:',i4) c 1000 call mpi_finalize(ierr) c c **** parallel **** C STOP END SUBROUTINE AIJS use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C THE CONTROLLING ROUTINE FOR THE EVALUATION OF THE LONG-RANGE- C FORCE COEFFICIENTS. THESE ARE WRITTEN ONTO THE STG2 PERMANENT C OUTPUT FILE (ITAPE2) FROM THIS ROUTINE, AFTER BEING CALCULATED C IN THE ROUTINE ALDAIJ AND STORED IN THE CF-ARRAY. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNC0=MZNC1*(MZCHD-1)/(MZCHF-1) X +(MZCHF-MZCHD)/(MZCHF-1)) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXBBI=MXORB*MXORB/2*MZLMX+MXORB*MZLMX) C DIMENSION VSHELL(MXORB2),RESULT(MXNC0,MXNC0,MZLMX) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO5/BBINT(MXBBI),IBBI COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- C C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF SETUP. C WRITE (IWRITE,3000) IF (LAMAX.EQ.0 .OR. NCHAN.EQ.0) GOTO 310 IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 230 C C INITIALISE THE CF ARRAY C IF(ALLOCATED(CF))DEALLOCATE(CF) allocate(cf(NCHAN,NCHAN,LAMAX),stat=ierr) if(ierr.ne.0)stop 'failure to allocate CF in AIJS' C DO 30 K = 1,LAMAX DO 20 J = 1,NCHAN DO 10 I = 1,NCHAN CF(I,J,K) = 0.0D0 10 CONTINUE 20 CONTINUE 30 CONTINUE IF (IBBI.LE.0) GOTO 270 ISPIN = 0 IF (IBUG6.EQ.1) WRITE (IWRITE,3060) KK = 0 M1 = 0 ME1 = 0 ITYP = 0 kpols=0 C C LOOP OVER THE ATOMIC STATES ON THE L.H.S. OF THE MATRIX ELEMENT C DO 220 IY = 1,NAST IF (NCONAT(IY).LE.0) GOTO 210 KN = KK + 1 KK = KK + NCONAT(IY) MCFG = NTCON(IY) DO 70 J = 1,MCFG NNG = NTYP(IY,J) MOCCSH(J) = NOCCSH(NNG) IG = NOCCSH(NNG) IG1 = 2*IG - 1 DO 50 KG = 1,IG1 DO 40 L = 1,3 M1QNRD(KG,L,J) = J1QNRD(KG,L,NNG) 40 CONTINUE 50 CONTINUE DO 60 K = 1,IG MOCORB(K,J) = NOCORB(K,NNG) MELCSH(K,J) = NELCSH(K,NNG) IF (M1.LT.MOCORB(K,J)) M1 = MOCORB(K,J) 60 CONTINUE 70 CONTINUE KL = KN - 1 JTYP = 0 C C LOOP OVER THE ATOMIC STATES ON THE R.H.S. OF THE MATRIX ELEMENT C DO 200 JY = IY,NAST IF (NCONAT(JY).LE.0) GOTO 190 KM = KL + 1 KL = KL + NCONAT(JY) IF (ISAT(IY).NE.ISAT(JY)) GOTO 190 IF (IBUG6.EQ.1) WRITE (IWRITE,3010) IY,JY NCFGE = NTCON(JY) DO 110 I = 1,NCFGE NNE = NTYP(JY,I) KOCCSH(I) = NOCCSH(NNE) IE = NOCCSH(NNE) IE1 = 2*IE - 1 DO 90 KE = 1,IE1 DO 80 L = 1,3 K1QNRD(KE,L,I) = J1QNRD(KE,L,NNE) 80 CONTINUE 90 CONTINUE DO 100 K = 1,IE KOCORB(K,I) = NOCORB(K,NNE) KELCSH(K,I) = NELCSH(K,NNE) IF (ME1.LT.KOCORB(K,I)) ME1 = KOCORB(K,I) 100 CONTINUE 110 CONTINUE MAXOR = MAX(M1,ME1) C C LOOP OVER LAMBDA C DO 180 LAMBDA = 1,LAMAX IF (LAMBDA.GT. (LAT(IY)+LAT(JY)) .OR. A LAMBDA.LT.ABS(LAT(IY)-LAT(JY))) GOTO 180 IF (IBUG6.EQ.1) WRITE (IWRITE,3020) LAMBDA LDA = LAMBDA CFADD = 0.0D0 C C LOOP OVER THE CONFIGURATIONS OF THE TWO ATOMIC STATES C IF (NTYP(IY,1).EQ.ITYP .AND. NTYP(JY,1).EQ.JTYP) GOTO 150 DO 140 JA = 1,MCFG DO 130 JAE = 1,NCFGE IRHO = 0 ISIG = 0 CALL SETUPE(JA,JAE,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) RESULT(JAE,JA,LAMBDA) = 0.D0 IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 130 IF (IRHO.NE.ISIG) THEN CALL REDRAD(LDA,IRHO,ISIG,RR) RESULT(JAE,JA,LAMBDA) = VSHELL(1)*RR C ELSE DO 120 IS = 1,IHSH CALL REDRAD(LDA,IS,IS,RR) RESULT(JAE,JA,LAMBDA) = RESULT(JAE,JA,LAMBDA) + A RR*VSHELL(IS) 120 CONTINUE ENDIF C 130 CONTINUE 140 CONTINUE C 150 CONTINUE DO 170 JA = 1,MCFG IF (AIJ(IY,JA).EQ.ZERO) GOTO 170 DO 160 JAE = 1,NCFGE CFADD = CFADD + RESULT(JAE,JA,LAMBDA)*AIJ(JY,JAE)* A AIJ(IY,JA) 160 CONTINUE 170 CONTINUE C c To print gf values and polarizabilities for LS coupled target states in STG2 (KAB). c The code is activitated by setting IBUG5=-1 for gf-value printout, c or IBUG5=-slp for gf and polarizabilities, ie. IBUG5=-100 for polarizability c from a singlet S even state. c Note for polarizabilities: the lowest state (num1=1) is assumed as the initial state, c and its symmetry must be specified before the final states in the STG2 input data. c if(LAMBDA.eq.1.and.IBUG5.lt.0) then de=(enat(IY)-enat(JY))*2.D0 gf=isat(IY)*0.3333333D0*abs(de)*CFADD**2 islp=isat(IY)*100+lat(IY)*10+lpty(IY) jslp=isat(JY)*100+lat(JY)*10+lpty(JY) num1=1 num2=1 do kab=1,max(IY,JY)-1 kslp=isat(kab)*100+lat(kab)*10+lpty(kab) if(kab.lt.IY.and.kslp.eq.islp) num1=num1+1 if(kab.lt.JY.and.kslp.eq.jslp) num2=num2+1 enddo if(enat(IY).ne.enat(JY)) then if( jslp.ne.kpols .and. islp.eq.-ibug5 )print*,' ' print*, 'islp,jslp=',islp,jslp, * ' n1,n2=',num1,num2,' dE(Ry)=',de,' gf=',gf if( islp.eq.-ibug5 .and. num1.eq.1 )then pol = gf/((2*lat(IY)+1)*isat(IY)*0.25*de*de) if( jslp.ne.kpols ) polsum = 0. polsum = polsum + pol print*, 'polarizability=',pol,polsum endif kpols= jslp endif endif C C LOOP TO PRODUCE ALL MATRIX ELEMENTS COUPLED TO A GIVEN PAIR OF C ATOMIC STATES C CALL ALDAIJ(LAMBDA,KM,KN,IY,JY,CFADD) 180 CONTINUE 190 JTYP = NTYP(JY,1) 200 CONTINUE 210 ITYP = NTYP(IY,1) 220 CONTINUE GOTO 270 C C WRITE OUT THE COEFFICIENTS C 230 CONTINUE DO 260 I = 1,NCHAN READ (ITAPE2) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) IF (I.EQ.NCHAN) GOTO 260 DO 250 K = 1,LAMAX DO 240 J = I + 1,NCHAN CF(J,I,K) = CF(I,J,K) 240 CONTINUE 250 CONTINUE 260 CONTINUE 270 CONTINUE DO 280 I = 1,NCHAN WRITE (ITAPE3) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) 280 CONTINUE IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 310 IF (IBUG6.EQ.0 .AND. IBUG9.EQ.0) GOTO 310 WRITE (IWRITE,3030) DO 300 K = 1,LAMAX WRITE (IWRITE,3040) K DO 290 I = 1,NCHAN WRITE (IWRITE,3050) (CF(I,J,K),J=1,NCHAN) 290 CONTINUE 300 CONTINUE 310 CONTINUE WRITE (IWRITE,3070) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 320 ICOUNT = ICOUNT + 1 GOTO 330 C C WRITE TO ITAPE3 COMPLETED C 320 CONTINUE IF (ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE (IWRITE,3080) C 330 CONTINUE MCFG = 0 C 3000 FORMAT (/30X,'SUBROUTINE AIJS'/30X,15 ('-')) 3010 FORMAT (//30X,' ATOMIC STATE',I4,' ATOMIC STATE',I4) 3020 FORMAT (/40X,' LAMBDA=',I2) 3030 FORMAT (' COEFFICIENT MATRIX CF(I,J,K)') 3040 FORMAT (//' K=',I1//) 3050 FORMAT (10X,6F15.8) 3060 FORMAT (//' **DEBUG PRINT IN AIJS**'/) 3070 FORMAT (' FILE POSITION',I4,' HAS BEEN REACHED') 3080 FORMAT (//' WRITE TO ITAPE3 COMPLETED') END SUBROUTINE ALDAIJ(LDA,KM,KN,IY,JY,CFADD) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C EVALUATES THE CLEBSCH-GORDAN AND RACAH COEFFICIENTS, AND HENCE C THE ASYMPTOTIC COEFFICIENT OF ORDER LDA, CF(IZ,JZ,LDA), FOR ALL C CHANNELS IZ AND JZ ASSOCIATED WITH THE TWO ATOMIC STATES IY,JY. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST C DATA TENTH/0.1D0/ C----------------------------------------------------------------------- IS = ISAT(IY) JS = NSPN AS = TRITST(IS,2,JS) C IF (ABS(AS).GT.TENTH) THEN WRITE (IWRITE,3000) RETURN ENDIF C DO 30 JZ = KM,KM + NCONAT(JY) - 1 DO 20 IZ = KN,KN + NCONAT(IY) - 1 CF(IZ,JZ,LDA) = 0.D0 LJ = L2P(JZ) LI = L2P(IZ) IF (LDA.GT. (LI+LJ) .OR. LDA.LT.ABS(LI-LJ) .OR. A MOD(LDA+LI+LJ,2).NE.0) GOTO 10 CLEB = RME(LI,LJ,LDA) LATJ = LAT(JY) LATI = LAT(IY) C C MULTIPLY RACAH INPUT PARAMETERS BY 2 C LD1 = 2*LATJ LD2 = 2*LDA LD3 = 2*LRGL LD4 = 2*LI LD5 = 2*LATI LD6 = 2*LJ CALL DRACAH(LD1,LD2,LD3,LD4,LD5,LD6,RAC) IF (IBUG6.EQ.1) WRITE (IWRITE,3010) LATJ,LDA,LRGL,LI,LATI,LJ, A RAC,CLEB,CFADD CF(IZ,JZ,LDA) = 2*CFADD*CLEB*RAC 10 CF(JZ,IZ,LDA) = CF(IZ,JZ,LDA) 20 CONTINUE 30 CONTINUE C 3000 FORMAT (/' TRIANGLE RELATION NOT SATISFIED IN ALDAIJ'/) 3010 FORMAT (6I5,' RACAH=',F14.7,' CLEBSCH=',F14.7,' CFADD=',F14.7) END C C C C*********************************************************************** SUBROUTINE AMOUT use basic2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C WRITE-OUT BOUND-CONTINUUM OVERLAP MATRIX FOR PSEUDO-RESONANCE C REMOVAL - TWG AND NRB C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (NTOM1=MZCHD*MZNR1) C PARAMETER (NTOM2=MZNC2*NTOM1) !LARGE PARAMETER (NTOM2=1000000) COMMON /AMATST/AFACT(NTOM2),NDIML,NDIMR,NONZER,ICHL(NTOM1), C IORB(NTOM1),ILEFT(NTOM2),IRIGHT(NTOM2) c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) NDIMR=NCFGP WRITE(66)NSPN,LRGL,NPTY,NDIML,NDIMR,NONZER DO I=1,NONZER WRITE(66)ILEFT(I),IRIGHT(I),AFACT(I) ENDDO RETURN END SUBROUTINE BOUND IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALCULATES THE ENERGIES AND EIGENVECTORS OF THE TARGET C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXHNP1=MZNC1*MZNC1/2+MZNC1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C DIMENSION IA1(MZOCC),IA2(MZOCC),IB1(MZOCC),IB2(MZOCC),MSYM(MZTAR) DIMENSION HNP1(MXHNP1),EN(MZNC1),X(MZNC1),AUX(MZNC1,9) C COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /REL/JRELOP(3) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /NRBKUT/EAST(MZTAR),TOLB,NFK(MZTAR),KCUT COMMON /NRBSKP/ESKPL,ESKPH,ECORR,BCUT,ISKIP(MZTAR) !NRB-SKIP C DATA ONE/1.0D0/,EPSI/1.0D-9/ C----------------------------------------------------------------------- C WRITE (IWRITE,3000) C C DEFINE NUMBER JSYM OF TARGET SYMMETRIES C IF (JRELOP(3).NE.0) THEN JSYM = 1 IF (NAST.EQ.1) GOTO 30 DO 20 I = 2,NAST DO 10 J = 1,I - 1 IF (NTYP(J,1).EQ.NTYP(I,1)) GOTO 20 10 CONTINUE JSYM = JSYM + 1 20 CONTINUE 30 WRITE (ITAPE3) - JSYM ENDIF C C LOOP OVER TARGET STATES - C TWICE IF JRELOP(3)=-1, WHEN TERM COUPLING COEFFS ARE REQUESTED C WHICH REQUIRE EIGENVECTORS OF THE LS-COUPLING HAMILTONIAN C 35 JREL1 = JRELOP(1) JREL2 = JRELOP(2) JREL3 = JRELOP(3) C ICHEK=0 C DO 160 NS = 1,NAST C JRELOP(1) = JREL1 JRELOP(2) = JREL2 JRELOP(3) = JREL3 NTC = NTCON(NS) NTC0 = NTC NSYM = 0 N = -1 NSKIP=0 !NRB-SKIP C C CHECK ALL OTHER STATES FOR SAME L, S, PARITY. C DO 50 NSP = 1,NAST IF (NS.EQ.NSP) GOTO 40 IF (LAT(NS).NE.LAT(NSP)) GOTO 50 IF (ISAT(NS).NE.ISAT(NSP)) GOTO 50 IF (LPTY(NS).NE.LPTY(NSP)) GOTO 50 IF (NSP.LT.NS) GOTO 150 40 CONTINUE NSYM = NSYM + 1 MSYM(NSYM) = NSP NSKIP=NSKIP+ISKIP(NSP) !NRB-SKIP 50 CONTINUE IF (JREL3.GE.0) GOTO 60 NTC0 = -NSYM C C LOOP OVER PAIRS OF TARGET CONFIGURATIONS C 60 CONTINUE N = 0 IF (IBUG7.GE.3) WRITE (IWRITE,3020) NSYM DO 100 IT = 1,NTC I = NTYP(NS,IT) N1 = N + 1 DO 90 JT = IT,NTC J = NTYP(NS,JT) N = N + 1 I4 = NOCCSH(I) I5 = NOCCSH(J) DO 70 I8 = 1,I4 IA1(I8) = NOCORB(I8,I) IB1(I8) = NELCSH(I8,I) 70 CONTINUE DO 80 I8 = 1,I5 IA2(I8) = NOCORB(I8,J) IB2(I8) = NELCSH(I8,J) 80 CONTINUE C CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C C SET J1QN C IB = NOCCSH(I) + 1 CALL SJ2QNT(I,IB,I3,1,1) IB = NOCCSH(J) + 1 CALL SJ2QNT(J,IB,I3,1,2) C C SET THE REMAINING QUANTITIES FOR MATRIX C IHSH = I3 NDCT(1) = 0 NDCT(2) = 0 IF (IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(1) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C HNP1(N) = AME(1,1) 90 CONTINUE IF (IBUG7.GE.3) WRITE (IWRITE,3010) (HNP1(J),J=N1,N) 100 CONTINUE C C JUST OUTPUT THE HAMILTONIAN MATRICES IF RECOUPLING TARGET C IF (JREL3.EQ.0) GOTO 110 IF (NTC0.NE.0) WRITE (ITAPE3) LAT(NS),ISAT(NS),LPTY(NS),NTC0,N IF (JRELOP(3).LE.0) GOTO 110 WRITE (ITAPE3) (HNP1(J),J=1,N) CTST PRINT *,' BOUND-TEST: HNP1 WRITTEN' GOTO 160 110 CONTINUE C C DIAGONALIZE HAMILTONIAN C ISKIP0=0 !NRB-SKIP NSKIP0=NSKIP !NRB-SKIP NSTORE=0 !NRB-SKIP IF(ESKPL.LE.ESKPH)NSTORE=NTC-NSYM-NSKIP !NRB-SKIP C DO 140 NO = 1,NTC C EN(1) = HNP1(1) X(1) = ONE NSP = NS IF(NS*NO.EQ.1)E00=EN(1) !NRB-SKIP IF (NTC.EQ.1) GOTO 120 C CALL HSLDR(NTC,HNP1,N,EPSI,EN,X,NO,AUX,MZNC1) C IF(NS*NO.EQ.1)E00=EN(NTC) !NRB-SKIP C C CHANGE OVERALL PHASE OF EIGENVECTORS SO THAT THE LARGEST C COMPONENT IS ALWAYS POSITIVE -- MCHF CONVENTION C VMAX=0.0D0 JMAX=0 DO 115 J=1,NTC ABSEIG=ABS(X(J)) IF(ABSEIG.LT.VMAX) GO TO 115 JMAX=J VMAX=ABSEIG 115 CONTINUE IF(X(JMAX).LT.0.0) THEN DO 117 J=1,NTC X(J)=-X(J) 117 CONTINUE END IF C T=EN(NO)-E00 !NRB-SKIP IF(KCUT.GT.0)THEN !MATCH TO AS SPEC ICHEK=ICHEK+1 DO NN=1,NSYM NSP=MSYM(NN) IF(ABS(T-EAST(NSP)).LT.TOLB)GO TO 120 !MATCHES SPEC ENDDO ICHEK=ICHEK-1 GO TO 140 !ASSUME CORR ENDIF C IF(ESKPL.GT.ESKPH.AND.NTC-NO.GE.NSYM+NSKIP)GOTO 140 !NRB-SKIP IF(T.GE.ESKPL.AND.T.LE.ESKPH.OR.T.GT.ECORR)THEN !NRB-SKIP NSTORE=NSTORE-1 !NRB-SKIP GO TO 140 !NRB-SKIP ENDIF !NRB-SKIP IF(ISKIP0.GT.0)GO TO 145 !NRB-SKIP NSP = MSYM(NTC-NO+1-NSKIP0-NSTORE) !NRB-SKIP ISKIP0=ISKIP(NSP) !NRB-SKIP NSKIP0=NSKIP0-ISKIP0 !NRB-SKIP C 120 CONTINUE ENAT(NSP) = EN(NO) IF (JREL3.LT.0) WRITE (ITAPE3) NTC,NSP,EN(NO), (X(J),J=1,NTC) IF (JREL3.NE.0) GOTO 140 DO 130 J = 1,NTC AIJ(NSP,J) = X(J) 130 CONTINUE GO TO 140 !NRB-SKIP 145 ISKIP0=ISKIP0-1 !NRB-SKIP C 140 CONTINUE !END LOOP OVER CI C C WRITE E-ENERGIES AND E-VECTORS C 150 CONTINUE IF (JREL3.GT.0) GOTO 160 WRITE (IWRITE,3050) (NTYP(NS,J),J=1,NTC) WRITE (IWRITE,3030) (AIJ(NS,J),J=1,NTC) T=ENAT(NS)-ENAT(1) WRITE (IWRITE,3040) ENAT(NS), T+T IF (N.LT.0) GOTO 160 IF (JREL3.GE.0) GOTO 160 JRELOP(1) = 1 JRELOP(2) = 1 JRELOP(3) = 1 NTC0 = 0 C SO AS TO AVOID DUPLICATING THE HEADER RECORD. GOTO 60 C 160 CONTINUE !END LOOP OVER NAST TARGETS C IF(ICHEK*ICHEK.NE.ICHEK*NAST)THEN WRITE(IWRITE,3043)NAST,ICHEK,2*TOLB STOP' ****SR.BOUND: MIS-MATCH, CANNOT FIND NAST TERMS!' ENDIF C JRELOP(1) = JREL1 JRELOP(2) = JREL2 JRELOP(3) = JREL3 C C WRITE OUT A LIST OF BOUND STATE ENERGIES C IF(JREL3.LE.0) THEN CALL ORDER(ENAT,MSYM,NAST,1) E00=ENAT(MSYM(1)) WRITE(IWRITE,3045) WRITE(IWRITE,3046) (2*(ENAT(MSYM(NS))-E00),NS=1,NAST) WRITE(IWRITE,3047) END IF C----------------------------------------------------------------------- C C KAB'S ELIMINATION OF WEAKLY MIXING TERMS: RUN ONCE WITH BCUT.GT.0 C TO WRITE LS DATA TO FILE CONFIG, THEN A SECOND TIME WITH NKEY=2 TO C READ IT BACK-IN, EITHER IN LS OR BP MODE. C C----------------------------------------------------------------------- IF(BCUT.LT.0.0)RETURN IF(BCUT.GT.0.0)THEN KOUNT=0 DO NC=1,NCFG KUT=-1 DO NS=1,NAST DO J=1,NTCON(NS) IF(NTYP(NS,J).EQ.NC) THEN IF(KUT.EQ.-1) KUT=0 IF(ABS(AIJ(NS,J)).GT.BCUT) KUT=1 ENDIF ENDDO ENDDO IF(KUT.EQ.0) THEN KOUNT=KOUNT+1 DO NS=1,NAST JUT=NTCON(NS)+1 DO J=1,NTCON(NS) IF(J.LE.JUT) THEN IF(NTYP(NS,J).EQ.NC) JUT=J ELSE NTYP(NS,J-1)=NTYP(NS,J) AIJ(NS,J-1)=AIJ(NS,J) ENDIF ENDDO IF(JUT.LE.NTCON(NS)) NTCON(NS)=NTCON(NS)-1 ENDDO ENDIF ENDDO WRITE(IWRITE,3070)BCUT,KOUNT BCUT=0.0D0 IF(NSKIP.EQ.0)THEN WRITE (IWRITE,3000) GO TO 35 ENDIF ENDIF C WRITE(8,*)NCFG-KOUNT,' CONFIGURATIONS' LAST=9999 DO NS=1,NAST IF(NTYP(NS,1).NE.LAST) THEN LAST=NTYP(NS,1) WRITE(8,*)(NOCCSH(NTYP(NS,J)),J=1,NTCON(NS)) ENDIF ENDDO LAST=9999 DO NS=1,NAST IF(NTYP(NS,1).NE.LAST) THEN LAST=NTYP(NS,1) DO J=1,NTCON(NS) I=NTYP(NS,J) I4 = NOCCSH(I) WRITE(8,*)(NOCORB(I8,I),I8=1,I4) WRITE(8,*)(NELCSH(I8,I),I8=1,I4) WRITE(8,*)((J1QNRD(I8,K,I),K=1,3),I8=1,I4*2-1) ENDDO ENDIF ENDDO C C NRB: IF WE ARE SKIPPING THEN THE NEW LIST HAS YET TO BE RE-ASSIGNED C IF(NSKIP.EQ.0)THEN CALL ORDER(ENAT,MSYM,NAST,1) DO NS=1,NAST J=MSYM(NS) WRITE(6,3060)NS,LAT(J),ISAT(J),LPTY(J),ENAT(J) X ,2*(ENAT(J)-ENAT(1)) ENDDO ENDIF C RETURN C 3000 FORMAT (//30X,'SUBROUTINE BOUND'/30X,16 ('-')//' CALCULATION OF', A ' BOUND STATE ENERGIES AND CONFIGURATION COEFFICIENTS') 3010 FORMAT (1X,10F11.5) 3020 FORMAT (/' HAMILTONIAN MATRIX (',I2,' STATE(S) REQUIRED)') 3030 FORMAT (' AIJ =', (T7,10F11.7)) 3040 FORMAT (' ENAT =',2F15.6) 3043 FORMAT(/' ****SR.BOUND: YOU HAVE REQUESTED NAST=',I5, X' TERMS, BUT ONLY ',I5,' FOUND'/' ****SR.BOUND: CHECK AS vs RM', X' STRUCTURES AND/OR INCREASE TOLB TO',1PE9.1) 3045 FORMAT (//'LIST OF BOUND-STATE ENERGIES') 3046 FORMAT (10F11.6) 3047 FORMAT (//) 3050 FORMAT (/' NTYP =', (T8,I3,9I11)) 3060 FORMAT (2I4,2I1,E15.7,F12.6) 3070 FORMAT (//'*** BCUT=',F10.5,' CONFIGURATIONS DELETED:',I5) END SUBROUTINE CHEKTP(ITAPEN) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C READS THE PERMANENT STG1 BINARY INPUT OR OUTPUT FILE, ITAPE. C C WHEN ITAPE=ITAPE1, THE INPUT FILE IS RESTORED INTO COMMON BLOCKS. C AND DATA IN /INSTO3/ AND /RKSAVE/ ARE DEFINED: C ITAPST(L,LP)= POINTER TO C-C RK INTEGRALS FOR L,LP IN DA FILE C (0 IF INTEGRALS ARE ALL STORED IN MEMORY). C IRKBC = NUMBER OF B-C RK INTEGRALS C IRKCC(L,LP,1)= NUMBER OF C-C RK INTEGRALS FOR L,LP C IRKCC(L,LP,2)= POINTER TO ICTCCD AND ICTCCE ARRAYS IN ICT C ICHUNK= MAXIMUM SIZE OF SUBSET ON DA FILE OF INTEGRALS FOR L,LP C ITAPBC = POINTER TO B-C RK INTEGRALS IN DA FILE (0 FOR MEMORY) C C WHEN ITAPE=ITAPE2, THE INPUT FILE IS POSITIONED IN PREPARATION C FOR COPYING INTEGRAL BLOCKS FROM ITAPE2 TO ITAPE3 IN GENINT. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXICT=4*MZLR1*MZLR1*MZLR1*MZLR2*MZLR2) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXN21=MZNR2+1) PARAMETER (MXPOL= (MZLMX+1)/2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) PARAMETER (MX2LR2=2*MZLR2) PARAMETER (MXBBI=MXORB*MXORB/2*MZLMX+MXORB*MZLMX) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /INSTO5/BBINT(MXBBI),IBBI COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /RKSAVE/IRKBC,IRKCC(MZLR2,MZLR2,2),ICHUNK,ICT(MXICT),ITAPBC COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX COMMON /NRBDIP/LRANGD,MAXLD C DIMENSION MEMCC(MZLR2,MZLR2) c **** parallel **** c....... delete on final version include 'mpif.h' common /parablock/iam,nproc c....... delete common /pstg1block/nprocstg1 common /recbcblock/irecbc common /recccblock/ITAPSTp parameter (mxproc1=64) integer irecp(0:mxproc1-1) integer irecbc(0:mxproc1-1) integer ITAPSTp(MZLR2,MZLR2,0:mxproc1-1) allocatable RKSTp(:) PARAMETER (LREC=512) IRECL = 8*LREC c **** parallel **** C----------------------------------------------------------------------- C C NRB: C REPOSITION MEM1 FOR RE-READ OF MULTIPOLE DATA BY DMEL C ITAPE=ABS(ITAPEN) IF(ITAPEN.LT.0)MEM1=0 C C ICOUNT IS A COUNT ON THE INTEGRAL BLOCKS ON FILE C C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM FILE, CALL RECOV2 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C IF (ITAPE.NE.ITAPE1) THEN ICOUNT = 0 IF (ITOTAL.LE.0) RETURN ENDIF C WRITE (IWRITE,3000) IPLACE = 0 KEY = 1 IREC = 0 JDISC = JDISC1 IF (ITAPE.EQ.ITAPE2) THEN JDISC = JDISC2 KEY = 0 ENDIF C WRITE (IWRITE,3100) REWIND ITAPE MSTOR = MEM1 C LRANGD = 999 C C ---- READ THE BASIC DATA FROM FILE C c **** parallel **** if(nprocstg1.gt.0)then READ (ITAPE,END=10) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE, A LAM,NPOT, (IRELOP(I),I=1,3),KCOR,LRANGD else READ (ITAPE,END=10) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE, A LAM,NPOT, (IRELOP(I),I=1,3),KCOR,LRANGD,nprc1 nprocstg1=nprc1 if (nprocstg1.gt.mxproc1) stop 'increase mxproc1 parameter' endif c do i=0,nprocstg1-1 irecp(i)=0 enddo c **** parallel **** C 10 CONTINUE C IF(LAM.GE.1000)THEN !GET STG1 LNOEX LNOEX1=MOD(LAM,1000)-1 LAM=LAM/1000 IF(LNOEX1.LT.LNOEX)THEN IF(LNOEX.LT.999)THEN WRITE(6,3129) WRITE(0,*)'** REDUCING LNOEX TO MATCH STG1' ENDIF LNOEX=LNOEX1 ENDIF ENDIF C WRITE (IWRITE,3130) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM,LNOEX WRITE (IWRITE,3160) (IRELOP(I),I=1,3) C IF (LRANG1.GT.MZLR1) CALL RECOV2('CHEKTP',' MZLR1',MZLR1,LRANG1) IF (LRANG2.GT.MZLR2) CALL RECOV2('CHEKTP',' MZLR2',MZLR2,LRANG2) IF(IDWOUT.EQ.2.AND.LRNGDW.GT.MZLR2) C CALL RECOV2('CHEKTP',' MZLR2',MZLR2,LRNGDW) IF (NRANG2.GT.MZNR2) CALL RECOV2('CHEKTP',' MZNR2',MZNR2,NRANG2) IF (LAMAX .GT.MZLMX) CALL RECOV2('CHEKTP',' MZLMX',MZLMX,LAMAX) C READ (ITAPE,END=15) (MAXNHF(L),L=1,LRANG1), A (MAXNLG(L),L=1,LRANG1), (MAXNC(L),L=1,LRANG1) GO TO 20 C 15 CONTINUE WRITE (IWRITE,*) ' *** NO DATA ON UNIT',ITAPE RETURN C 20 CONTINUE WRITE (IWRITE,3110) (MAXNHF(L),L=1,LRANG1) WRITE (IWRITE,3120) (MAXNLG(L),L=1,LRANG1) C DO 30 L = 1,LRANG2 IF (L.GT.LRANG1) MAXNHF(L) = L - 1 READ (ITAPE) (EIGENS(N,L),N=1,NRANG2) READ (ITAPE) (ENDS(N,L),N=1,NRANG2+1) 30 CONTINUE C NRB IF(IDWOUT.EQ.2.AND.LRNGDW.GT.LRANG1)THEN LPP=LRANG1+1 DO 35 L=LPP,LRNGDW MAXNHF(L) = L - 1 35 CONTINUE ENDIF C NRB C READ (ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX WRITE (IWRITE,3150) RA,BSTO C IF (LRANG2.GT.0) READ (ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) C WRITE (IWRITE,3140) IF (ITAPE.NE.ITAPE1) THEN IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH THE MULTIPOLE INTEGRALS C WRITE (IWRITE,3010) READ (ITAPE) IRK8,JRK8 MAXRK = IRK8 COUNT = IRK8 IF (IRK8.GT.0) THEN IF (MEM1+IRK8.GT.MXMEM) THEN KNEED=1+IRK8/1000000 CALL RECOV2('CHEKTP',' MZMEG',MZMEG,KNEED) ENDIF LAMIND = (LAMAX+1)/2 READ (ITAPE) (((IBBPOL(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1, A LAMIND), (((IBCPOL(I,J,K),I=1,LRANG1),J=1,LRANG2),K=1,LAMIND), B (((ICCPOL(I,J,K),I=1,LRANG2),J=1,LRANG2),K=1,LAMIND), C (RKSTO2(I),I=MEM1+1,MEM1+IRK8) IF (ITAPE.EQ.ITAPE1) MEM1 = MEM1 + IRK8 C C COPY BOUND-BOUND MULTIPOLE INTEGRALS TO BBINT C DO 70 K = 1,LAMIND DO 60 J = 1,LRANG2 DO 40 I = 1,LRANG1 IP = IBCPOL(I,J,K) IF (IP.GT.0) GOTO 80 40 CONTINUE DO 50 I = 1,LRANG2 IP = ICCPOL(I,J,K) IF (IP.GT.0) GOTO 80 50 CONTINUE 60 CONTINUE 70 CONTINUE IP = IRK8 + 1 80 CONTINUE IBBI = IP - 1 IF (IBBI.GT.MXBBI) CALL RECOV2('CHEKTP','MXBBI ',MXBBI,IBBI) DO 90 I = 1,IBBI BBINT(I) = RKSTO2(I) 90 CONTINUE ENDIF C IF(ITAPEN.LT.0)RETURN !NRB C IF (ITAPE.NE.ITAPE1) WRITE (IWRITE,3080) ICOUNT C C READ QUANTITIES FOR BUTTLE CORRECTIONS C IF (JRK8.GT.0) THEN IF (JRK8.GT.MXSK2) CALL RECOV2('CHEKTP','MXSK2 ',MXSK2,JRK8) READ (ITAPE) ((JBCPOL(I,J),I=1,LRANG1),J=1,LRANG2), A ((JCCPOL(I,J),I=1,LRANG2),J=1,LRANG2), (SKSTO2(J),J=1,JRK8), B (BNORM(J),J=1,LRANG2) ENDIF C IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,*) ' JRK8 = ',JRK8 WRITE (IWRITE,*) ' FILE POSITION 1+1/2 HAS BEEN REACHED' IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH THE BOUND-BOUND ONE C ELECTRON INTEGRALS C WRITE (IWRITE,3020) READ (ITAPE) IRK5 IF (IRK5.GT.MX1BB) CALL RECOV2('CHEKTP','MX1BB ',MX1BB,IRK5) READ (ITAPE) (IST1(I),I=1,LRANG1), (ONEST1(I),I=1,IRK5) IF (IRELOP(1).GT.0) READ (ITAPE) (RMASS1(I),I=1,IRK5) IF (IRELOP(3).GT.0) READ (ITAPE) (RSPOR1(I),I=1,IRK5) IF (IRELOP(2).GT.0) THEN READ (ITAPE) IRK9 IF (IRK9.GT.MX1BB) CALL RECOV2('CHEKTP','MX1BB ',MX1BB,IRK9) READ (ITAPE) (RDAR1(I),I=1,IRK9) ENDIF C IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,3080) ICOUNT IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH THE BOUND-CONTINUUM C ONE ELECTRON INTEGRALS C WRITE (IWRITE,3030) READ (ITAPE) IRK6 IF (IRK6.GT.MX1BC) CALL RECOV2('CHEKTP','MX1BC ',MX1BC,IRK6) READ (ITAPE) (IST2(I),I=1,LRANG1), (ONEST2(I),I=1,IRK6) IF (IRELOP(1).GT.0) READ (ITAPE) (RMASS2(I),I=1,IRK6) IF (IRELOP(3).GT.0) READ (ITAPE) (RSPOR2(I),I=1,IRK6) IF (IRELOP(2).GT.0) THEN READ (ITAPE) IRK10 IF (IRK10.GT.MX1BC) CALL RECOV2('CHEKTP','MX1BC ',MX1BC,IRK10) READ (ITAPE) (RDAR2(I),I=1,IRK10) ENDIF C IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,3080) ICOUNT IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH THE CONTINUUM-CONTINUUM C ONE ELECTRON INTEGRALS C WRITE (IWRITE,3040) DO 100 L = 1,LRANG2 L1 = L - 1 READ (ITAPE) IRK7 IF (IRK7.GT.MX1CC) CALL RECOV2('CHEKTP','MX1CC ',MX1CC,IRK7) READ (ITAPE) (ONEST3(I,L),I=1,IRK7) IF (IRELOP(1).GT.0) READ (ITAPE) (RMASS3(I,L),I=1,IRK7) IF (IRELOP(3).GT.0 .AND. L1.NE.0) READ (ITAPE) (RSPOR3(I,L),I=1, A IRK7) IF (IRELOP(2).GT.0 .AND. L1.EQ.0) READ (ITAPE) (RDAR3(I),I=1, A IRK7) 100 CONTINUE IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,3080) ICOUNT IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH THE BOUND-BOUND RK INTEGRALS C WRITE (IWRITE,3050) READ (ITAPE) IRK1,IRK4 IF (IRK1.GT.MXRKBB) CALL RECOV2('CHEKTP','MXRKBB',MXRKBB,IRK1) IF (IRK4.GT.MXIRK4) CALL RECOV2('CHEKTP','MXIRK4',MXIRK4,IRK4) I1 = LRANG1*LRANG1 READ (ITAPE) (((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), A (ISTBB1(I),I=1,IRK4), (ISTBB2(I),I=1,IRK4), (RKSTO1(I),I=1,IRK1) IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,3080) ICOUNT IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH BOUND-CONTINUUM RK INTEGRALS C IF (LRANG2.EQ.0) RETURN WRITE (IWRITE,3060) READ (ITAPE) IRK2,IRK3 MAXRK = MAX(MAXRK,IRK2) COUNT = COUNT + IRK2 IRKBC = IRK2 ITAPBC = MAX(1,IREC) c **** parallel **** do iamstg1=0,nprocstg1-1 irecbc(iamstg1)=max(1,irecp(iamstg1)) enddo c **** parallel **** MEMBC = MEM1 IF (ITAPE.EQ.ITAPE1 .AND. MEM1+IRK2.GT.MXMEM) KEY = 0 IF (IRK3.GT.MXIRK3) CALL RECOV2('CHEKTP','MXIRK3',MXIRK3,IRK3) I1 = MIN(LRANG1*LRANG2,LRANG1* ((LRANG1-1)*3+1)) READ (ITAPE) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,I1), A (ISTBC1(I),I=1,IRK3), (ISTBC2(I),I=1,IRK3) c **** parallel **** c....... STG1 was SERIAL if (nprocstg1.eq.1) then CALL DA2(KEY,IREC,JDISC,IRK2,RKSTO2(MEM1+1)) else c....... STG1 was PARALLEL c....... first, move irec forward irec = irec+irk2/lrec do 8888 iamstg1=0,nprocstg1-1 c....... skip if length is zero if (irk2.le.iamstg1) go to 8888 itapeRK = 120+iamstg1 c...... calculate size of chunks writed per processor irk2st = (irk2 - (iamstg1+1) )/nprocstg1 + 1 c..... allocate temporary reading storage allocate(RKSTp(IRK2st),stat=ierr) if (ierr.ne.0) stop 'allocation fails for RKSTp' c....... read integrals on RKxx.DAT CALL DA2(KEY,IRECp(iamstg1),itapeRK,IRK2st,RKSTp) c...... copy temporary data on global array if (key.ne.0) then do i=1,irk2st indxglob = (i-1)*nprocstg1 + (iamstg1+1) + MEM1 RKSTO2(indxglob) = RKSTp(i) enddo endif c...... deallocate temporary arrays deallocate(RKSTp) 8888 continue endif c **** parallel **** IF (ITAPE.EQ.ITAPE1 .AND. KEY.EQ.1) MEM1 = MEM1 + IRK2 IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,3080) ICOUNT IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C C ---- READ QUANTITIES ASSOCIATED WITH THE CONTINUUM-CONTINUUM RK C INTEGRALS C C SET CONTINUUM-CONTINUUM RK INTEGRAL POINTERS C I3 = 0 DO 120 J = 1,LRANG2 DO 110 I = 1,LRANG2 ITAPST(I,J) = 0 c **** parallel **** do iamstg1=0,nprocstg1-1 ITAPSTp(I,J,iamstg1) = 0 enddo c **** parallel **** IRKCC(I,J,1) = 0 IRKCC(I,J,2) = 0 MEMCC(I,J) = 0 110 CONTINUE 120 CONTINUE C WRITE (IWRITE,3070) ICHUNK = 1 LAST = -1 LASTP = -1 130 CONTINUE READ (ITAPE) JRK2,L,LP IRK2 = ABS(JRK2) IF (IRK2.EQ.0) GOTO 140 COUNT = COUNT + IRK2 IF (ITAPE.EQ.ITAPE1 .AND. MEM1+IRK2.GT.MXMEM) KEY = 0 C C STORE ICTCCD AND ICTCCE IN ICT, WITH IRKCC(,,2) AS POINTERS C IF (L.NE.LAST .OR. LP.NE.LASTP) THEN ITAPST(L+1,LP+1) = IREC ITAPST(LP+1,L+1) = IREC c **** parallel **** do iamstg1=0,nprocstg1-1 ITAPSTp(L+1,LP+1,iamstg1) = IRECp(iamstg1) ITAPSTp(LP+1,L+1,iamstg1) = IRECp(iamstg1) enddo c **** parallel **** LAST = L LASTP = LP IRKCC(L+1,LP+1,2) = I3 IRKCC(LP+1,L+1,2) = I3 I1 = MIN(2*LRANG1-1,L+LP+1) I2 = MIN(LRANG1+L,LRANG1+LP) I12 = I3 + (I1+I2)*LRANG1*LRANG1 IF (I12.GT.MXICT) CALL RECOV2('CHEKTP','MXICT ',MXICT,I12) IF (ITAPE.NE.ITAPE1)THEN !THIS READS AFTER FIRST HEADER... READ (ITAPE) (ICT(K),K=I3+1,I12) I3 = I12 ENDIF MEMCC(L+1,LP+1) = MEM1 MEMCC(LP+1,L+1) = MEM1 ENDIF C ICHUNK = MAX(ICHUNK,IRK2) IRKCC(L+1,LP+1,1) = IRKCC(L+1,LP+1,1) + IRK2 IRKCC(LP+1,L+1,1) = IRKCC(L+1,LP+1,1) c **** parallel **** c....... STG1 was SERIAL if (nprocstg1.eq.1) then CALL DA2(KEY,IREC,JDISC1,IRK2,RKSTO2(MEM1+1)) else c....... STG1 was PARALLEL c....... first, move irec forward irec = irec+irk2/lrec do 8889 iamstg1=0,nprocstg1-1 c....... skip if length is zero if (irk2.le.iamstg1) go to 8889 itapeRK = 120+iamstg1 c...... calculate size of chunks writed per processor irk2st = (irk2 - (iamstg1+1) )/nprocstg1 + 1 c..... allocate temporary reading storage allocate(RKSTp(IRK2st),stat=ierr) if (ierr.ne.0) stop 'allocation fails for RKSTp' c....... read integrals on RKxx.DAT CALL DA2(KEY,IRECp(iamstg1),itapeRK,IRK2st,RKSTp) c...... copy temporary data on global array if (key.ne.0) then do i=1,irk2st indxglob = (i-1)*nprocstg1 + (iamstg1+1) + MEM1 RKSTO2(indxglob) = RKSTp(i) enddo endif c...... deallocate temporary arrays deallocate(RKSTp) 8889 continue endif c **** parallel **** IF (ITAPE.EQ.ITAPE1 .AND. KEY.EQ.1) MEM1 = MEM1 + IRK2 IF (JRK2.LT.0) GOTO 130 C C NRB: MUST READ ALL HEADERS FIRST, IF STG1.DAT C IF (ITAPE.EQ.ITAPE1)THEN READ (ITAPE) (ICT(K),K=I3+1,I12) I3 = I12 ENDIF C MAXRK = MAX(MAXRK,IRKCC(L+1,LP+1,1)) IF (ITAPE.NE.ITAPE1) THEN WRITE (IWRITE,3080) ICOUNT IF (ICOUNT.GE.ICOPY1-1 .OR. ICOUNT.GE.ITOTAL) RETURN ICOUNT = ICOUNT + 1 ENDIF C 140 CONTINUE IF (L.LT.LRANG2-1 .OR. LP.LT.LRANG2-1) GOTO 130 C NEED = 1 + (NINT(COUNT)-1)/1000 WRITE (IWRITE,*) ' MINIMUM SPACE FOR ONE BLOCK OF INTEGRALS =', A MAXRK WRITE (IWRITE,*) ' MAXIMUM SPACE FOR RK FILE =',NEED,' KWORDS' IF (MAXRK.GT.MXMEM) CALL RECOV2('CHEKTP','MXMEM ',MXMEM,MAXRK) C IF (ITAPE.NE.ITAPE1) RETURN C C THE FOLLOWING CODING IS ONLY ACTIVATED IN STG2 ... C IF ALL INTEGRALS IN MEMORY INCREMENT MEMORY POINTERS (ISTBC2,ICT) C ZEROIZE FILE POINTERS (ITAPBC,ITAPST) AND SET IRK8 -VE. C IF (KEY.EQ.0) THEN MEM1 = MSTOR + MAXRK WRITE (IWRITE,*) ' RADIAL INTEGRALS ARE STORED IN RK FILE' MMM=1+NEED/1000 WRITE (IWRITE,*) ' *** TO IMPROVE EFFICIENCY, INCREASE ', A 'MZMEG TO ',MMM C ELSE WRITE (IWRITE,*) ' RADIAL INTEGRALS ARE STORED IN MEMORY' IRK8 = -IRK8 DO 150 I = 1,IRK3 ISTBC2(I) = ISTBC2(I) + MEMBC 150 CONTINUE ITAPBC = 0 c **** parallel **** do iamstg1=0,nprocstg1-1 irecbc(iamstg1)=0 enddo c **** parallel **** DO 180 L = 0,LRANG2 - 1 DO 170 LP = L,LRANG2 - 1 I3 = IRKCC(LP+1,L+1,2) MEMC = MEMCC(LP+1,L+1) I1 = MIN(2*LRANG1-1,L+LP+1) I2 = MIN(LRANG1+L,LRANG1+LP) I12 = I3 + (I1+I2)*LRANG1*LRANG1 DO 160 K = I3 + 1,I12 ICT(K) = ICT(K) + MEMC 160 CONTINUE ITAPST(L+1,LP+1) = 0 ITAPST(LP+1,L+1) = 0 c **** parallel **** do iamstg1=0,nprocstg1-1 ITAPSTp(L+1,LP+1,iamstg1) = 0 ITAPSTp(LP+1,L+1,iamstg1) = 0 enddo c **** parallel **** 170 CONTINUE 180 CONTINUE ENDIF C 3000 FORMAT (//30X,'SUBROUTINE CHEKTP'/30X,17 ('-')) 3010 FORMAT (' THE MULTIPOLE INTEGRALS') 3020 FORMAT (' THE BOUND-BOUND ONE ELECTRON INTEGRALS') 3030 FORMAT (' THE BOUND-CONTINUUM ONE ELECTRON INTEGRALS') 3040 FORMAT (' THE CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS') 3050 FORMAT (' THE BOUND-BOUND RK INTEGRALS') 3060 FORMAT (' THE BOUND-CONTINUUM RK INTEGRALS') 3070 FORMAT (' THE CONTINUUM-CONTINUUM RK INTEGRALS') 3080 FORMAT (' FILE POSITION',I3,' HAS BEEN REACHED') 3100 FORMAT (/' READ THE DATA FILE FROM STG1'/) 3110 FORMAT (' MAXNHF =',20I3) 3120 FORMAT (' MAXNLG =',20I3) 3129 FORMAT ('** REDUCING LNOEX TO MATCH STG1:'/) 3130 FORMAT (' NELC =',I3,' NZ =',I3,' LRANG1 =',I3,' LRANG2 =',I3, A ' NRANG2 =',I3,' LAMAX =',I3,' LAM =',I3,' LNOEX =',I3) 3140 FORMAT (' READ OF BASIC DATA COMPLETED') 3150 FORMAT (' RA =',F10.5,' BSTO =',F10.5) 3160 FORMAT (' MASS-CORRECTION(',I1,'),',' DARWIN-TERM(',I1,'),', A ' SPIN-ORBIT(',I1,')') END C C C SUBROUTINE CONFIG(LRGL,NSPN,NPTY,MAXORB,NJCOMP,LJCOMP,IELC,IBUG, A NCFGT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO GENERATE OR READ CONFIGURATION DATA FOR A STATE WITH TOTAL C ANGULAR MOMENTUM, SPIN, PARITY OF LRGL, NSPN, NPTY. C C MAXORB IS THE TOTAL NUMBER OF SHELLS. C NJCOMP AND LJCOMP ARE THE N AND L VALUES FOR THE SHELLS. C IELC IS THE TOTAL NUMBER OF ELECTRONS. C IBUG IS GREATER THAN ZERO FOR A PRINTOUT OF THE CONFIGURATIONS. C C CONFIG CAN BE CALLED A NUMBER OF TIMES FOR A SERIES OF STATES, C AND THE CONFIGURATION DATA CORRESPONDING TO EACH STATE CAN BE C STORED SEQUENTIALLY IN /BNDCON/. C THE READING OF CONFIGURATION DATA FROM JREAD ONLY OCCURS ON THE C FIRST CALL TO CONFIG FOR A SERIES OF STATES. C THE PUNCHING OF CONFIGURATION DATA TO IPUNCH ONLY OCCURS ON THE C LAST CALL TO CONFIG FOR A SERIES OF STATES. C C NCFGT = -1 FOR THE FIRST OF A SERIES OF STATES, C = -2 FOR THE LAST OF A SERIES OF STATES. C = -3 IF THERE IS ONLY ONE STATE. C C ON RETURN, NCFGT CONTAINS THE NUMBER OF CONFIGURATIONS STORED C FOR THE CURRENT STATE. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C LOGICAL FIRST C DIMENSION NJCOMP(MAXORB),LJCOMP(MAXORB) DIMENSION NI(MXORB),NTOTI(MXORB) C COMMON /CUPPLE/NOPTN,MNAL(MXORB),MXAL(MXORB),IBASSH(MZNC2,MXORB), A NXCITE(MZNC2),JREAD,LOCSH(MZNC2) COMMON /DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON /INFORM/IREAD,IWRITE,IPUNCH C COMMON /RECOV/IPLACE C----------------------------------------------------------------------- NREAD = 0 NWRITE = 0 IF (IBUG.GT.0) NWRITE = IWRITE NPUNCH = 0 ICFGT = 0 C C IF NCFGT = -1 OR -3, THIS IS THE FIRST OR ONLY CALL TO CONFIG. C IF JREAD.GT.0, CALL CONSTO TO READ CONFIGURATION DATA FROM JREAD. C FIRST = .FALSE. IF (NCFGT.NE.-1 .AND. NCFGT.NE.-3) GOTO 10 FIRST = .TRUE. NCUP = 0 ICFG = 0 NCON = 0 IF (JREAD.EQ.0) GOTO 10 NREAD = JREAD CALL CONSTO NREAD = 0 NOPTN = -2 ICFGT = 0 FIRST = .FALSE. C C SET AND CHECK THE INPUT DATA C 10 CONTINUE ITOTL = LRGL ITOTS = NSPN IPTY = NPTY NSHELL = MAXORB NELC = IELC IF (ITOTL.LT.0 .OR. ITOTS.LT.1) GOTO 20 IF (IPTY.EQ.0 .OR. IPTY.EQ.1) GOTO 30 20 CONTINUE WRITE (IWRITE,3030) ITOTL,ITOTS,IPTY STOP C 30 CONTINUE NSPARE = NELC DO 50 I = 1,NSHELL NJ(I) = NJCOMP(I) L = LJCOMP(I) LJ(I) = L IF (L.GE.0 .AND. L.LT.NJ(I)) GOTO 40 WRITE (IWRITE,3040) I,NJ(I),L STOP C 40 CONTINUE IF (NOPTN.EQ. (-2)) GOTO 50 NSPARE = NSPARE - MNAL(I) IF (NSPARE.GE.0) GOTO 50 WRITE (IWRITE,3050) NELC STOP C 50 CONTINUE C C CHECK TO SEE IF CONFIGURATIONS CORRESPONDING TO THE CURRENT L,S, C AND PARITY HAVE ALREADY BEEN STORED. C IOPTN = -2 IF (.NOT.FIRST) CALL CONSTO IF (ICFGT.GT.0 .OR. JREAD.GT.0) GOTO 140 IOPTN = NOPTN C C ONLY 2 ELECTRONS ALLOWED IN SHELLS WITH L.GE.3 C IF (IOPTN.EQ. (-2)) GOTO 140 DO 70 I = 1,NSHELL L = LJ(I) NE = MXAL(I) NE = MIN(NE,4*L+2) NE = MIN(NE,MNAL(I)+NSPARE) IF (L.LT.3) GOTO 60 IF (NE.GT.2) WRITE (IWRITE,3020) I,L NE = MIN(NE,2) 60 CONTINUE MXAL(I) = NE MXN(I) = NE + 1 70 CONTINUE C C STORE LAST OCCUPIED SHELL FOR EACH BASIC CONFIGURATION C IF (IOPTN.LE.0) GOTO 100 DO 90 M = 1,IOPTN DO 80 I = 1,MAXORB J = MAXORB - I + 1 IF (IBASSH(M,J).EQ.0) GOTO 80 LOCSH(M) = J GOTO 90 C 80 CONTINUE 90 CONTINUE C C TO GENERATE THE CONFIGURATIONS, CALL CONPED. C C LOOP OVER ALL POSSIBLE ELECTRON DISTRIBUTIONS C 100 CONTINUE I = 0 110 CONTINUE I = I + 1 NI(I) = 0 120 CONTINUE NI(I) = NI(I) + 1 NSTOP = I MI = MXN(I) - NI(I) IF (MI.LT.MNAL(NSTOP)) GOTO 130 NTOT = MI IF (I.GT.1) NTOT = NTOT + NTOTI(I-1) NTOTI(I) = NTOT MN(I) = MI IF (NTOT.GT.NELC) GOTO 130 IF (NTOT.EQ.NELC) CALL CONPED IF (I.LT.NSHELL) GOTO 110 IF (I.GT.NSHELL) GOTO 140 130 CONTINUE IF (NI(I).LT.MXN(I)) GOTO 120 I = I - 1 IF (I.GT.0) GOTO 130 C C IF NCFGT = -2 OR -3, THIS IS THE LAST OR ONLY CALL TO CONFIG. C CHECK DIMENSIONS. C IF IPUNCH.GT.0, CALL CONSTO TO PUNCH CONFIGURATION DATA TO IPUNCH C 140 CONTINUE WRITE (IWRITE,3080) ICFGT IF (NCFGT.NE. (-2) .AND. NCFGT.NE. (-3)) GOTO 150 C IF (IPLACE.EQ.0) IPLACE = -1 IF (NCUP.GT.MZNC2) CALL RECOV2('CONFIG',' MZNC2',MZNC2,NCUP) IF (ICFG.GT.MZNC2) CALL RECOV2('CONFIG',' MZNC2',MZNC2,ICFG) C IF (IPLACE.EQ.-1) IPLACE = 0 IF (IPUNCH.LE.0) GOTO 150 NPUNCH = IPUNCH CALL CONSTO WRITE (IWRITE,3090) C 150 CONTINUE NCFGT = ICFGT C 3020 FORMAT (/' * WARNING * ONLY TWO ELECTRONS ALLOWED IN SHELL',I3, A ' WITH L =',I3) 3030 FORMAT (//' * PROGRAM STOPS IN CONFIG * L =',I5,' 2S+1 =',I5, A ' PARITY =',I5/) 3040 FORMAT (//' * PROGRAM STOPS IN CONFIG * SHELL',I5,' HAS N =',I5, A ' L =',I5/) 3050 FORMAT (//' * PROGRAM STOPS IN CONFIG * MXN(I) IS NOT SUFFICIENT', A ' FOR IELC =',I5/) 3080 FORMAT (' NUMBER OF CONFIGURATIONS STORED FOR THIS STATE =',I5) 3090 FORMAT (/' CARD PUNCHING COMPLETED'/) END C C C SUBROUTINE CONPED IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO DETERMINE THE POSSIBLE ELECTRON DISTRIBUTIONS CONSISTENT WITH C PARITY ETC. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C COMMON /CONACT/MACT(MXORB),MNT(MXORB),JACT,J1QN(MXORB,3) COMMON /CUPPLE/NOPTN,MNAL(MXORB),MXAL(MXORB),IBASSH(MZNC2,MXORB), A NXCITE(MZNC2),JREAD,LOCSH(MZNC2) COMMON /DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON /INFORM/IREAD,IWRITE,IPUNCH C----------------------------------------------------------------------- LPTY = 0 JACT = 0 C C TEST FOR EMPTY EXCITED SHELLS AND PARITY C DO 10 I = 1,NSTOP L = LJ(I) M = MN(I) LPTY = LPTY + L*M IF (M.LT.MNAL(I)) GOTO 60 IF (M.LE.0) GOTO 10 JACT = JACT + 1 MACT(JACT) = I MNT(JACT) = M 10 CONTINUE IF (MOD(LPTY,2).NE.IPTY .OR. MN(NSTOP).EQ.0) GOTO 60 C C TEST FOR EXCITATION ALLOWED FROM THE BASIC CONFIGURATIONS C IF (NOPTN.LE.0) GOTO 40 DO 30 M = 1,NOPTN NEX = 0 DO 20 I = 1,LOCSH(M) IF (I.GT.NSTOP) THEN NEX = NEX + IBASSH(M,I) GOTO 20 C ENDIF C MB = IBASSH(M,I) MA = MN(I) IF (MA.LT.MB) NEX = NEX + MB - MA 20 CONTINUE IF (NEX.LE.NXCITE(M)) GOTO 40 30 CONTINUE GOTO 60 C C LIMIT SET ON NCON TO AVOID POSSIBLE RUN-AWAY C 40 CONTINUE NCON = NCON + 1 IF (NCON.LE.MZNC2) GOTO 50 WRITE (IWRITE,3000) NCON STOP C 50 CONTINUE CALL CONQN 60 CONTINUE C 3000 FORMAT (//' *** PROGRAM STOP IN SUBROUTINE CONPED - NCON =',I10, A ' ***'//) END C C C SUBROUTINE CONQN IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO DETERMINE THE QUANTUM NUMBERS FOR EACH SHELL C C--------------------------------------------------------------------- C C EXTENDED TO COPE WITH 2 ELECTRONS IN L>2 SHELLS. C C (NO NEED TO EXTEND THE /TERMS/ ARRAYS, SINCE THESE ARE USED IN THE C FANO PACKAGE BY FUNCTION NTAB1, WHERE ONLY PARENTS ARE CONSIDERED, C AND PARENTS WILL STILL HAVE NO MORE THAN 1 ELECTRON IN L>2 SHELLS. C C---------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C DIMENSION IFSH(MXORB),MXS(MXORB),MCS(MXORB),NI(MXORB) C COMMON /CONACT/MACT(MXORB),MNT(MXORB),JACT,J1QN(MXORB,3) COMMON /DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON /TERMS/NROWS,L(18),J(18),N(189) C DIMENSION LS(11) C DATA LS(1),LS(2),LS(3),LS(4),LS(5)/1,3,6,11,12/ DATA LS(6),LS(7),LS(8),LS(9),LS(10),LS(11)/13,14,15,16,17,18/ C----------------------------------------------------------------------- DO 30 I = 1,JACT NN = MACT(I) LL = LJ(NN) LL1 = LL + LL + 1 LK1 = LL + 1 M = MNT(I) K = M IF (M.GT.LL1) K = 2*LL1 - M IF (K.EQ.0) GOTO 10 C-------------------------------------------------------------------- IF (LL.GE.3 .AND. K.EQ.2) THEN MXS(I) = LL1 MCS(I) = -1 GOTO 30 C ENDIF C------------------------------------------------------------------- IFSH(I) = LS(LK1) + K - 1 GOTO 20 C 10 CONTINUE IFSH(I) = 2 20 CONTINUE KI = IFSH(I) MXS(I) = L(KI) MCS(I) = J(KI) 30 CONTINUE C C LOOP OVER THE ALLOWED QUANTUM NUMBERS FOR EACH SHELL C I = 0 40 CONTINUE I = I + 1 NI(I) = 0 50 CONTINUE NI(I) = NI(I) + 1 C------------------------------------------------------------------ IF (MCS(I).EQ.-1) THEN J1QN(I,1) = 2 IF (NI(I).EQ.1) J1QN(I,1) = 0 J1QN(I,2) = 2*NI(I) - 1 J1QN(I,3) = 1 IF (MOD(NI(I),2).EQ.0) J1QN(I,3) = 3 GOTO 60 C ENDIF C---------------------------------------------------------------- MI = MCS(I) + (NI(I)-1)*3 J1QN(I,1) = N(MI+1) J1QN(I,2) = N(MI+2) J1QN(I,3) = N(MI+3) 60 CONTINUE IF (I.LT.JACT) GOTO 40 IF (I.GT.JACT) GOTO 80 CALL CONSH 70 CONTINUE IF (NI(I).LT.MXS(I)) GOTO 50 I = I - 1 IF (I.GT.0) GOTO 70 C 80 CONTINUE C END C C C SUBROUTINE CONSH IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO DETERMINE THE COUPLING BETWEEN THE SHELLS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C LOGICAL OK C DIMENSION LI(MXORB),LLL(MXORB),LLH(MXORB),LSP(MXORB),LSL(MXORB), A LSH(MXORB) C COMMON /CONACT/MACT(MXORB),MNT(MXORB),JACT,J1QN(MXORB,3) COMMON /DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C----------------------------------------------------------------------- JACTM1 = JACT - 1 IF (JACTM1.GT.0) GOTO 10 CALL CONTST(OK) IF (OK) CALL CONSTO RETURN C 10 CONTINUE DO 20 I = 1,JACTM1 J1QN1(I,1) = 0 20 CONTINUE LS0 = J1QN(1,3) - 1 LL0 = (J1QN(1,2)-1)/2 LLL(1) = ABS(LL0- (J1QN(2,2)-1)/2) LLH(1) = LL0 + (J1QN(2,2)-1)/2 + 1 LSL(1) = ABS(LS0-J1QN(2,3)+1) - 1 LSH(1) = LS0 + J1QN(2,3) C C LOOP OVER ALL POSSIBLE COUPLINGS BETWEEN THE SHELLS C I = 0 30 CONTINUE I = I + 1 LI(I) = LLL(I) 40 CONTINUE LI(I) = LI(I) + 1 LLI = LI(I) - 1 J1QN1(I,2) = 2*LLI + 1 IF (I.LT.JACTM1) THEN LLL(I+1) = ABS(LLI- (J1QN(I+2,2)-1)/2) LLH(I+1) = LLI + (J1QN(I+2,2)-1)/2 + 1 ENDIF C LSP(I) = LSL(I) 50 CONTINUE LSP(I) = LSP(I) + 2 LSI = LSP(I) - 1 J1QN1(I,3) = LSI + 1 IF (I.GT.JACTM1) GOTO 70 IF (I.EQ.JACTM1) THEN CALL CONTST(OK) IF (OK) CALL CONSTO C ELSE LSL(I+1) = ABS(LSI-J1QN(I+2,3)+1) - 1 LSH(I+1) = LSI + J1QN(I+2,3) GOTO 30 C ENDIF C 60 CONTINUE IF (LSP(I).LT.LSH(I)) GOTO 50 IF (LI(I).LT.LLH(I)) GOTO 40 I = I - 1 IF (I.GT.0) GOTO 60 C 70 CONTINUE C END C C C SUBROUTINE CONSTO IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO READ/WRITE/STORE/PUNCH THE CONFIGURATION DATA. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C LOGICAL OK,OMIT,AGREE C COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /CONACT/MACT(MXORB),MNT(MXORB),JACT,J1QN(MXORB,3) COMMON /CUT/NCUT,IKIP(MZNC2),JOCCSH(MZNC2) COMMON /DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON /TYPE/ITYP(MZNC2) C----------------------------------------------------------------------- C C IF NREAD.GT.0 READ THE COUPLING SCHEME DATA FROM NREAD C IF (NPUNCH.GT.0) GOTO 160 IF (NREAD.EQ.0) GOTO 20 READ (NREAD,*) JCFG IF (JCFG.LE.0) GOTO 140 IF (JCFG.GT.MZNC2) CALL RECOV2('CONSTO',' MZNC2',MZNC2,JCFG) READ (NREAD,*) (JOCCSH(I),I=1,JCFG) 10 CONTINUE IF (NCUP.GE.JCFG) GOTO 210 NCUP = NCUP + 1 JACT = JOCCSH(NCUP) IF (JACT.GT.MZOCC) CALL RECOV2('CONSTO',' MZOCC',MZOCC,JACT) JACTM1 = JACT - 1 READ (NREAD,*) (MACT(J),J=1,JACT) READ (NREAD,*) (MNT(J),J=1,JACT) IF (JACTM1.LE.0) THEN READ (NREAD,*) ((J1QN(J,K),K=1,3),J=1,JACT) C ELSE READ (NREAD,*) ((J1QN(J,K),K=1,3),J=1,JACT), A ((J1QN1(J,K),K=1,3),J=1,JACTM1) ENDIF C GOTO 30 C C IF NCUT.GT.0 STORE ONLY THOSE CONFIGURATIONS WITH IKIP(NCUP)=1 C 20 CONTINUE IF (IOPTN.EQ. (-2)) GOTO 160 NCUP = NCUP + 1 30 CONTINUE IF (NCUT.LE.0) GOTO 60 IF (NCUP.GT.NCUT) GOTO 50 IF (IKIP(NCUP).EQ.1) GOTO 60 50 CONTINUE OMIT = .TRUE. GOTO 70 C 60 CONTINUE OMIT = .FALSE. ICFG = ICFG + 1 ICFGT = ICFGT + 1 C C IF NWRITE.GT.0 PRINT THE COUPLING SCHEME DATA C 70 CONTINUE IF (NWRITE.LE.0) GOTO 110 IF (OMIT) GOTO 90 WRITE (NWRITE,3000) ICFG GOTO 100 C 90 CONTINUE WRITE (NWRITE,3060) 100 CONTINUE WRITE (NWRITE,3010) (MACT(J),J=1,JACT) WRITE (NWRITE,3020) (MNT(J),J=1,JACT) JACTM1 = JACT - 1 WRITE (NWRITE,3030) WRITE (NWRITE,3040) ((J1QN(J,K),K=1,3),J=1,JACT) IF (JACTM1.GT.0) WRITE (NWRITE,3050) ((J1QN1(J,K),K=1,3),J=1, A JACTM1) C C IF OMIT=.FALSE. STORE THE COUPLING SCHEME DATA IN /BNDCON/ C 110 CONTINUE IF (OMIT) GOTO 140 IF (ICFG.LE.MZNC2) JOCCSH(ICFG) = JACT IF (ICFG.GT.MZNC2) GOTO 140 ITYP(ICFGT) = ICFG IOCCSH(ICFG) = JACT IF (JACT.GT.MZOCC) CALL RECOV2('CONSTO',' MZOCC',MZOCC,JACT) IF (JACT.GT.MZOCC) GOTO 140 DO 130 J = 1,JACT IOCORB(J,ICFG) = MACT(J) IELCSH(J,ICFG) = MNT(J) J1 = JACT + J DO 120 K = 1,3 I1QNRD(J,K,ICFG) = J1QN(J,K) IF (J.LT.JACT) I1QNRD(J1,K,ICFG) = J1QN1(J,K) 120 CONTINUE 130 CONTINUE C C Option for removing weak N+1 configurations (KAB 03/03/04) C if(NREAD.le.0.and.NCUT.lt.0) then NCFGP = ICFG if(ICONWC(NCUT,NELC,IPTY,ITOTL,ITOTS).eq.0) then c if iconwc returns 0 then reject this config, otherwise continue NCUP = NCUP - 1 ICFG = ICFG - 1 ICFGT = ICFGT - 1 endif endif C 140 CONTINUE NCFGP = ICFG IF (NREAD.LE.0) GOTO 210 GOTO 10 C C IF NPUNCH.GT.0 OR IOPTN=-2, FIND COUPLING SCHEME DATA IN /BNDCON/ C 160 CONTINUE IF (NPUNCH.GT.0) WRITE (NPUNCH,3070) ICFG IF (ICFG.LE.0) GOTO 210 IF (ICFG.GT.MZNC2) CALL RECOV2('CONSTO',' MZNC2',MZNC2,ICFG) IF (NPUNCH.GT.0) WRITE (NPUNCH,3070) (JOCCSH(I),I=1,ICFG) DO 200 I = 1,ICFG JACT = IOCCSH(I) JACTM1 = JACT - 1 LP = 0 DO 180 J = 1,JACT MACT(J) = IOCORB(J,I) MNT(J) = IELCSH(J,I) J1 = JACT + J DO 170 K = 1,3 J1QN(J,K) = I1QNRD(J,K,I) IF (J.LT.JACT) J1QN1(J,K) = I1QNRD(J1,K,I) 170 CONTINUE M = MACT(J) LP = LP + LJ(M)*MNT(J) 180 CONTINUE C IF (NPUNCH.GT.0) GOTO 190 CALL CONTST(OK) AGREE = OK .AND. (MOD(LP,2).EQ.IPTY) IF (AGREE) ICFGT = ICFGT + 1 IF (AGREE) ITYP(ICFGT) = I GOTO 200 C 190 CONTINUE WRITE (NPUNCH,3070) (MACT(J),J=1,JACT) WRITE (NPUNCH,3070) (MNT(J),J=1,JACT) IF (JACTM1.LE.0) THEN WRITE (NPUNCH,3070) ((J1QN(J,K),K=1,3),J=1,JACT) C ELSE WRITE (NPUNCH,3070) ((J1QN(J,K),K=1,3),J=1,JACT), A ((J1QN1(J,K),K=1,3),J=1,JACTM1) ENDIF C 200 CONTINUE C 210 CONTINUE C 3000 FORMAT (/' CONFIGURATION',I5) 3010 FORMAT (6X,'OCCUPIED ORBITALS ARE',32X,20I3) 3020 FORMAT (6X,'NUMBER OF ELECTRONS IN RESPECTIVE OCCUPIED SHELLS',4X, A 20I3) 3030 FORMAT (6X,'COUPLING SCHEME') 3040 FORMAT (1X,9 (3X,3I3)) 3050 FORMAT (7X,8 (3X,3I3)) 3060 FORMAT (/' CONFIGURATION NOT STORED') 3070 FORMAT (12I5) END C C C SUBROUTINE CONTST(OK) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C OK IS SET .TRUE. ONLY IF THE CONFIGURATION HAS THE TOTAL C ANGULAR MOMENTUM AND SPIN OF THE GIVEN STATE. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C LOGICAL OK C COMMON /CONACT/MACT(MXORB),MNT(MXORB),JACT,J1QN(MXORB,3) COMMON /DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, A NJ(MXORB),LJ(MXORB),MN(MXORB),MXN(MXORB),LA(MXORB), B J1QN1(MXORB,3),NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C----------------------------------------------------------------------- JACTM1 = JACT - 1 C IF (JACTM1.LE.0) THEN LL = (J1QN(JACT,2)-1)/2 LS = J1QN(JACT,3) ELSE LL = (J1QN1(JACTM1,2)-1)/2 LS = J1QN1(JACTM1,3) ENDIF C OK = (LL.EQ.ITOTL .AND. LS.EQ.ITOTS) C END SUBROUTINE CONWC1(NRANG2,NAST,ENAT,NCONAT,L2P) c Calculate the diagonal continuum-continuum matrix elements c Note this is take approximately as the sum of the target and continuum energy IMPLICIT REAL*8 (A-H,O-Z) INCLUDE 'PARAM' c PARAMETER (MXN21=MZNR2+1) PARAMETER (mxdiag=MZNR2*MZCHF+MZNC2) c COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA common/cconwc/hcorr(mxdiag),hdiag(mxdiag),iidiag c dimension ENAT(NAST),NCONAT(NAST),L2P(MZCHF) c NCF = 0 iidiag= 0 DO 210 NS1 = 1,NAST IF (NCONAT(NS1).LE.0) GOTO 210 NCS = NCF + 1 NCF = NCF + NCONAT(NS1) DO 200 NCH1 = NCS,NCF LOT1 = L2P(NCH1) + 1 DO ip = iidiag+1, iidiag+NRANG2 hdiag(ip) = ENAT(NS1)+0.5*EIGENS(ip-iidiag,LOT1) c print*,ip,hdiag(ip) ENDDO iidiag = iidiag + NRANG2 200 CONTINUE 210 CONTINUE return end SUBROUTINE CONWC2(I,J,NCH1) use basic2 c Calculate bound(J)-continuum(I) matrix element IMPLICIT REAL*8 (A-H,O-Z) INCLUDE 'PARAM' c PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) c COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHF,MZCHF,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) c DIMENSION IA1(MZOCC),IA2(MZOCC),IB1(MZOCC),IB2(MZOCC) C C SET THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ, THEN SET J1QN C I4 = IOCCSH(J) I5 = NOCCSH(I) DO 260 I8 = 1,I4 IA1(I8) = IOCORB(I8,J) IB1(I8) = IELCSH(I8,J) 260 CONTINUE DO 270 I8 = 1,I5 IA2(I8) = NOCORB(I8,I) IB2(I8) = NELCSH(I8,I) 270 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) IB = IOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,2,1) IB = NOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,2,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITAL C IHSH = I3 + 1 I31 = I3 + 1 I1M = 2*I3 + 1 LJ(I31) = L2P(NCH1) NOSH(I31,1) = 0 NOSH(I31,2) = 1 J1QN(I31,1,1) = 0 J1QN(I31,2,1) = 1 J1QN(I31,3,1) = 1 J1QN(I1M,1,1) = 0 J1QN(I1M,2,1) = 2*LRGL + 1 J1QN(I1M,3,1) = NSPN J1QN(I31,1,2) = 1 J1QN(I31,2,2) = 2*LJ(I31) + 1 J1QN(I31,3,2) = 2 J1QN(I1M,1,2) = 0 J1QN(I1M,2,2) = 2*LRGL + 1 J1QN(I1M,3,2) = NSPN NJ(I31) = 999 NDCT(1) = 0 NDCT(2) = NRANG2 ND(1,1) = 0 L6 = L2P(NCH1) + 1 NRANG1 = MAXNHF(L6) DO 280 I5 = 1,NRANG2 ND(2,I5) = NRANG1 + I5 280 CONTINUE CALL MATANS(2) return end REAL*8 FUNCTION CONWC3(I,J) c Calculate a bound-bound Hamiltonian matrix element IMPLICIT REAL*8 (A-H,O-Z) INCLUDE 'PARAM' c PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXOC21=2*MZOCC-1) c COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) c DIMENSION IA1(MZOCC),IA2(MZOCC),IB1(MZOCC),IB2(MZOCC) C C SET NJ AND LJ, THEN SET J1QN C I4 = IOCCSH(I) I5 = IOCCSH(J) DO 660 I8 = 1,I4 IA1(I8) = IOCORB(I8,I) IB1(I8) = IELCSH(I8,I) 660 CONTINUE DO 670 I8 = 1,I5 IA2(I8) = IOCORB(I8,J) IB2(I8) = IELCSH(I8,J) 670 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) IB = IOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,1,1) IB = IOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,1,2) C C SET REMAINING QUANTITIES FOR MATRIX C IHSH = I3 NDCT(1) = 0 NDCT(2) = 0 CALL MATANS(1) conwc3 = AME(1,1) return end C C C SUBROUTINE COPYTP(ITAPE) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C READ THE HEADER OF THE STG2 BINARY INPUT FILE ITAPE. C AND POSITION FILE AT START OF PARTIAL WAVE DATA. C USED IN STG2 FOR RESTART. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXXNCF=1) C PARAMETER (MXXNCF=MXNCF) PARAMETER (MXNTRI=MXXNCF*MXXNCF/2+MXXNCF) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA COMMON /BOUND1/HSTORE(MXNTRI),A(MXXNCF,MXXNCF),TEMP(MXXNCF), A NTMP(MXXNCF),NTCTMP(MXXNCF),LSTO(MXXNCF,5),LNAST COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /DIAG/NDIAG COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /STATE/ENATJ(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C LOGICAL FIRST C SAVE FIRST C DATA FIRST/.TRUE./ C----------------------------------------------------------------------- C C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM ITAPE, CALL RECOV2 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C IPLACE = 0 WRITE (IWRITE,3000) REWIND ITAPE C C READ THE BASIC DATA FROM TAPE C READ (ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,IZESP, A (IRELOP(I),I=1,3) IF (FIRST) WRITE (IWRITE,3020) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX, A LAM IF (FIRST) WRITE (IWRITE,3070) (IRELOP(I),I=1,3) IF (LRANG1.GT.MZLR1) CALL RECOV2('COPYTP',' MZLR1',MZLR1,LRANG1) IF (LRANG2.GT.MZLR2) CALL RECOV2('COPYTP',' MZLR2',MZLR2,LRANG2) IF (NRANG2.GT.MZNR2) CALL RECOV2('COPYTP',' MZNR2',MZNR2,NRANG2) IF (LAMAX.GT.MZLMX) CALL RECOV2('COPYTP',' MZLMX',MZLMX,LAMAX) READ (ITAPE) (MAXNHF(L),L=1,LRANG1), (MAXNLG(L),L=1,LRANG1), A (MAXNC(L),L=1,LRANG1) IF (FIRST) WRITE (IWRITE,*) ' MAXNHF = ', (MAXNHF(L),L=1,LRANG1) IF (FIRST) WRITE (IWRITE,*) ' MAXNLG = ', (MAXNLG(L),L=1,LRANG1) DO 10 L = 1,LRANG2 IF (L.GT.LRANG1) MAXNHF(L) = L - 1 READ (ITAPE) (EIGENS(N,L),N=1,NRANG2) READ (ITAPE) (ENDS(N,L),N=1,NRANG2+1) 10 CONTINUE READ (ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX IF (FIRST) WRITE (IWRITE,3060) RA,BSTO IF(NIX.GT.0) THEN READ(ITAPE) (IHX,I=1,NIX),(IRX,I=1,NIX) IPTS=2*IRX READ(ITAPE) (PV,I=1,IPTS) DO 3 LP=1,LRANG1 NBT=MAXNLG(LP)-LP+1 IF(NBT.GT.0) THEN DO 2 K=1,NBT READ(ITAPE) (PV,I=1,IPTS) 2 CONTINUE ENDIF 3 CONTINUE ENDIF IF (LRANG2.GT.0) READ (ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) IF (FIRST) WRITE (IWRITE,3010) C READ (ITAPE) NAST IF (NAST.LT.0) THEN NDIAG = 1 LNAST = ABS(NAST) IF (FIRST) WRITE (IWRITE,*) LNAST,' TARGET SYMMETRIES' IF (LNAST.GT.MXNCF) CALL RECOV2('COPYTP','MXNCF ',MXNCF,LNAST) LPOS = 0 LDIM = 0 JUP = 0 DO 30 I = 1,LNAST READ (ITAPE) (LSTO(I,K),K=1,5) N = LSTO(I,5) NSYM = LSTO(I,4) IF (NSYM.LT.0) THEN DO 20 NO = 1,ABS(NSYM) JUP = JUP + 1 READ (ITAPE) NTC,NSP,E, (A(K,NSP),K=1,NTC) IF (NTC.GT.MXNCF) CALL RECOV2('COPYTP','MXNCF ',MXNCF,NTC) NTCTMP(JUP) = NTC NTMP(JUP) = NSP TEMP(JUP) = E 20 CONTINUE ENDIF C LDIM = LDIM + N IF (LDIM.GT.MXNTRI) LPOS = 0 READ (ITAPE) (HSTORE(K+LPOS),K=1,N) LPOS = LPOS + N 30 CONTINUE IF (LDIM.GT.MXNTRI) CALL RECOV2('COPYTP','MXNTRI',MXNTRI,LDIM) READ (ITAPE) NAST ENDIF C IF (FIRST) WRITE (IWRITE,*) NAST,' TARGET TERMS' IF (NAST.GT.MZTAR) CALL RECOV2('COPYTP','MZTAR ',MZTAR,NAST) READ (ITAPE) (ENATJ(I),I=1,NAST), (LAT(I),I=1,NAST), A (ISAT(I),I=1,NAST), (LPTY(I),I=1,NAST) IF (FIRST) THEN WRITE (IWRITE,3030) (LAT(I),I=1,NAST) WRITE (IWRITE,3040) (ISAT(I),I=1,NAST) WRITE (IWRITE,3050) (LPTY(I),I=1,NAST) ENDIF C IF (IRELOP(3).NE.0) THEN READ (ITAPE) NCFG, (NOCCSH(I),I=1,NCFG) DO 40 I = 1,NCFG IL = NOCCSH(I) ILL = 2*IL - 1 READ (ITAPE) (NOCORB(J,I),J=1,IL), (NELCSH(J,I),J=1,IL), A ((J1QNRD(J,K,I),K=1,3),J=1,ILL) 40 CONTINUE READ (ITAPE) MAXORB, (NJCOMP(J),J=1,MAXORB), A (LJCOMP(J),J=1,MAXORB) READ (ITAPE) (NTCON(J),J=1,NAST) DO 50 I = 1,NAST NT = NTCON(I) IF (NT.GT.MXNCF) CALL RECOV2('COPYTP','MXNCF ',MXNCF,NT) READ (ITAPE) (NTYP(I,J),J=1,NT), (AIJ(I,J),J=1,NT) 50 CONTINUE READ (ITAPE) IRK5 IF (IRK5.GT.MX1BB) CALL RECOV2('COPYTP','MX1BB ',MX1BB,IRK5) READ (ITAPE) (IST1(I),I=1,LRANG1), (RSPOR1(I),I=1,IRK5) READ (ITAPE) IRK6 IF (IRK6.GT.MX1BC) CALL RECOV2('COPYTP','MX1BC ',MX1BC,IRK6) READ (ITAPE) (IST2(I),I=1,LRANG1), (RSPOR2(I),I=1,IRK6) IF (LRANG2.GE.2) THEN DO 60 L = 2,LRANG2 READ (ITAPE) IRK7 IF (IRK7.GT.MX1CC) CALL RECOV2('COPYTP','MX1CC ',MX1CC,IRK7) READ (ITAPE) (RSPOR3(I,L),I=1,IRK7) 60 CONTINUE ENDIF C ENDIF C WRITE (IWRITE,*) ' READ OF STG2 FILE HEADER COMPLETED' FIRST = .FALSE. C 3000 FORMAT (//30X,'SUBROUTINE COPYTP'/30X,17 ('-')) 3010 FORMAT (' READ OF BASIC DATA COMPLETED') 3020 FORMAT (' NELC =',I3,' NZ =',I3,' LRANG1 =',I3,' LRANG2 =',I3, A ' NRANG2 =',I3,' LAMAX =',I3,' LAM =',I2) 3030 FORMAT (' LAT =', (10I2,1X,10I2,1X,10I2)) 3040 FORMAT (' ISAT =', (10I2,1X,10I2,1X,10I2)) 3050 FORMAT (' LPTY =', (10I2,1X,10I2,1X,10I2)) 3060 FORMAT (' RA =',F10.5,' BSTO =',F10.5) 3070 FORMAT (' MASS-CORRECTION(',I1,'),',' DARWIN-TERM(',I1,'),', A ' SPIN-ORBIT(',I1,')') END C C C SUBROUTINE DA2(KEY,IREC,JDISC,LENGTH,ARRAY) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO STORE A LARGE ARRAY IN A DA FILE OF RECORD LENGTH 8*LREC BYTES. C C KEY = 1 FOR READ, C = 2 FOR WRITE, C = 0 FOR FINDING NUMBER OF DA RECORDS A GIVEN ARRAY TAKES. C C IREC= (ON CALL) POINTER TO FIRST DA RECORD FOR ARRAY, C = 0 FOR OPENING DA FILE (BY NAME), C =-1 FOR OPENING DA FILE (SCRATCH), C = (ON RETURN) POINTER TO NEXT AVAILABLE DA RECORD. C C JDISC = DA FILE UNIT NUMBER. C C ARRAY(LENGTH) = ARRAY TO READ OR WRITE. C C----------------------------------------------------------------------- PARAMETER (LREC=512) !MUST SYC WITH STG1! C DIMENSION ARRAY(LENGTH) c **** parallel **** common /pstg1block/nprocstg1 character*1 filec,filed,fileu c **** parallel **** C----------------------------------------------------------------------- IF (IREC.GT.0) GOTO 20 C IRECL = 8*LREC C IF (IREC.LT.0) THEN OPEN (JDISC,STATUS='SCRATCH',ACCESS='DIRECT',RECL=IRECL) GOTO 10 ENDIF C IF (KEY.EQ.2) THEN OPEN (JDISC,STATUS='UNKNOWN',FILE='RK.DAT',ACCESS='DIRECT', A RECL=IRECL) ELSE c **** parallel **** if (nprocstg1.eq.1) then OPEN (JDISC,STATUS='OLD',FILE='RK.DAT',ACCESS='DIRECT', A RECL=IRECL) else iamstg1 = jdisc-120 ich0 = ichar('0') ic = iamstg1/100 id = (iamstg1 - 100*ic)/10 iu = (iamstg1 - 100*ic - 10*id) ic = ic + ich0 id = id + ich0 iu = iu + ich0 filec = char(ic) filed = char(id) fileu = char(iu) OPEN (jdisc,STATUS='old', + FILE='RK'//filec//filed//fileu//'.DAT',ACCESS='DIRECT', + RECL=IRECL) endif c **** parallel **** ENDIF C 10 CONTINUE IREC = 1 C 20 CONTINUE IF (LENGTH.EQ.0) RETURN I2 = 0 30 CONTINUE I1 = I2 + 1 I2 = MIN(I2+LREC,LENGTH) IF (KEY.EQ.0) GOTO 40 C IF (KEY.EQ.2) THEN WRITE (JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ELSE READ (JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ENDIF C 40 CONTINUE IREC = IREC + 1 IF (I2.LT.LENGTH) GOTO 30 C END C C C SUBROUTINE DH0 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C THERE ARE SEVERAL VERSIONS OF THIS SUBROUTINE C THIS VERSION IS FOR THE R-MATRIX PROGRAM C C EVALUATES THE ONE-ELECTRON INTEGRALS WHEN THE CONFIGURATIONS C ARE IDENTICAL C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /CONMX/H0MAT(MZNR2,MZNR2),VMAT(MZNR2,MZNR2) C COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, C A IBUG9 C COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT C DIMENSION A(MZNR2) C----------------------------------------------------------------------- IHSHM1 = IHSH - 1 H0SUM = 0.0D0 IF (IHSH.EQ.1) GOTO 20 C IF(IBUG4.GT.5)WRITE (IWRITE,3000) C C FINDS AND SUMS ALL INTEGRALS TO THE BOUND ORBITALS IF ANY C DO 10 J = 1,IHSHM1 NOSHIJ = NOSH1(J) IF (NOSHIJ.EQ.0) GOTO 10 N1 = NJ(J) L1 = LJ(J) + 1 CALL FIN1BB(N1,N1,L1,ALBVAL) TIMES = NOSHIJ H0SUM = H0SUM + ALBVAL*TIMES C IF(IBUG4.GT.5)WRITE (IWRITE,3010)H0SUM,ALBVAL,TIMES 10 CONTINUE C C NOW CALCULATE THE INTEGRAL FOR THE LAST ORBITAL C 20 CONTINUE N1 = NJ(IHSH) L1 = LJ(IHSH) + 1 TIMES = NOSH1(IHSH) IF (N1.NE.999) THEN C C THE LAST ORBITAL IS BOUND C CALL FIN1BB(N1,N1,L1,ALBVAL) H0MAT(1,1) = H0SUM + ALBVAL*TIMES C IF(IBUG4.GT.5)WRITE (IWRITE,3010)H0MAT(1,1),ALBVAL,TIMES RETURN C ENDIF C C THE LAST ORBITAL IS CONTINUUM. FORM THE DIAGONAL ELEMENTS OF C HOMAT C CALL FIN1CC(0,ILIMIT,L1,A) DO 30 I = 1,ILIMIT H0MAT(I,I) = H0SUM + A(I)*TIMES 30 CONTINUE C C 3000 FORMAT (//' H0MAT FROM DH0') C 3010 FORMAT (10F12.6) END SUBROUTINE DMCON(KEY,M,NCFGP,NAST,NCONAT,LCONAT,IOCCSH,IOCORB, A IELCSH,I1QNRD) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C STORE (KEY=2) OR RETRIEVE (KEY=1) CHANNEL AND CONFIGURATION DATA. C STORAGE CAN BE EITHER ON DISC (IDISC4) OR IN MEMORY. C C M = PARTIAL WAVE NUMBER C NCFGP = (N+1)-ELECTRON CONFIGURATIONS FOR CURRENT PARTIAL WAVE C NAST = TARGET STATES C THE REMAINING ARGUMENTS ARE TO BE STORED OR RETRIEVED. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER ( A MXBUF=MZTAR+MXL2*MZTAR+MZNC2+2*MZOCC*MZNC2+MXOC21*3*MZNC2+1) C DIMENSION IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2),IELCSH(MZOCC,MZNC2), A I1QNRD(MXOC21,3,MZNC2) DIMENSION NCONAT(NAST),LCONAT(MXL2,NAST) DIMENSION LPOINT(MZSLP),LENGTH(MZSLP),BUFFER(MXBUF) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH C COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /REL/IRELOP(3) C SAVE LPOINT,LENGTH,LAST,NEED,BUFFER C DATA LAST/0/,NEED/-1/ C----------------------------------------------------------------------- C C LAST = PARTIAL WAVE IN BUFFER. C LPOINT(M)= LOCATION OF DATA FOR M-TH PARTIAL WAVE, C (+VE FOR DA FILE BLOCK, -VE FOR MEMORY LOCATION). C LENGTH(M)= SIZE OF CHANNEL AND CONFIGURATION DATA. C NEED = MEMORY BEYOND MEM1 NEEDED IN SETMX1 C C READ DATA FROM MEMORY OR DISK TO BUFFER C IF (KEY.EQ.2) GOTO 20 IF (M.EQ.LAST) GOTO 20 MM = ABS(LPOINT(M)) IF (LPOINT(M).GT.0) THEN CALL DA2(1,MM,IDISC1,LENGTH(M),BUFFER) C ELSE DO 10 K = 1,LENGTH(M) BUFFER(K) = ARRAY(MM+K) 10 CONTINUE ENDIF C C COPY DATA TO/FROM BUFFER C 20 CONTINUE JP = 1 DO 60 I = 1,NAST IF (KEY.EQ.2) BUFFER(JP) = DBLE(NCONAT(I)) + 0.1D0 NCONAT(I) = INT(BUFFER(JP)) IF (NCONAT(I).EQ.0) GOTO 50 IF (KEY.EQ.2) THEN DO 30 J = 1,NCONAT(I) BUFFER(JP+J) = DBLE(LCONAT(J,I)) + 0.1D0 30 CONTINUE C ELSE DO 40 J = 1,NCONAT(I) LCONAT(J,I) = INT(BUFFER(JP+J)) 40 CONTINUE ENDIF C 50 JP = JP + NCONAT(I) + 1 60 CONTINUE C IF (NCFGP.EQ.0) GOTO 140 DO 130 I = 1,NCFGP IF (KEY.EQ.2) BUFFER(JP) = DBLE(IOCCSH(I)) + 0.1D0 IOCCSH(I) = INT(BUFFER(JP)) JQ = JP + IOCCSH(I) ILL = 2*IOCCSH(I) - 1 IF (KEY.EQ.2) THEN DO 70 J = 1,IOCCSH(I) BUFFER(JP+J) = DBLE(IOCORB(J,I)) + 0.1D0 BUFFER(JQ+J) = DBLE(IELCSH(J,I)) + 0.1D0 70 CONTINUE JP = JQ + IOCCSH(I) DO 90 K = 1,3 DO 80 J = 1,ILL BUFFER(JP+J) = DBLE(I1QNRD(J,K,I)) + 0.1D0 80 CONTINUE JP = JP + ILL 90 CONTINUE C ELSE DO 100 J = 1,IOCCSH(I) IOCORB(J,I) = INT(BUFFER(JP+J)) IELCSH(J,I) = INT(BUFFER(JQ+J)) 100 CONTINUE JP = JQ + IOCCSH(I) DO 120 K = 1,3 DO 110 J = 1,ILL I1QNRD(J,K,I) = INT(BUFFER(JP+J)) 110 CONTINUE JP = JP + ILL 120 CONTINUE ENDIF C JP = JP + 1 130 CONTINUE C C WRITE DATA FROM BUFFER TO MEMORY OR DISK, C INCREMENTING MEM1 OR MREC1 RESPECTIVELY C (FORCE DATA ONTO DISK IF MEMORY NEEDED IN SETMX1) C 140 CONTINUE IF (KEY.EQ.1) GOTO 160 BUFFER(JP) = DBLE(M) + 0.1D0 LENGTH(M) = JP IF (NEED.EQ.-1) THEN NEED = 0 IF (IRELOP(3).EQ.0) NEED = NRANG2* A MAX(NRANG2* (MZCHF* (MZCHF+1))/2, B MZNC2*MZCHF) ENDIF C IF (MEM1+NEED+JP.GT.MXMEM) THEN LPOINT(M) = ABS(MREC1) CALL DA2(2,MREC1,IDISC1,LENGTH(M),BUFFER) C ELSE LPOINT(M) = -MEM1 DO 150 K = 1,LENGTH(M) ARRAY(MEM1+K) = BUFFER(K) 150 CONTINUE MEM1 = MEM1 + LENGTH(M) ENDIF C 160 CONTINUE LAST = M MM = INT(BUFFER(JP)) IF (MM.EQ.M) RETURN WRITE (IWRITE,*) ' * ERROR IN DMCON, SLPI NUMBER =',M,MM STOP C END SUBROUTINE DMEL use basic2 use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE DIPOLE MATRIX ELEMENTS IN LENGTH FORM AND VELOCITY C FORM BETWEEN AN INITIAL AND FINAL STATE BOTH EXPRESSED IN TERMS C OF A CONTINUUM BASIS PLUS BOUND TERMS. THESE ARE WRITTEN TO C FILE IN BLOCKS DML AND DMV RESPECTIVELY, BEING REQUIRED IN C POLARIZABILITY AND PHOTOIONISATION CALCULATIONS IN STGH. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C DIMENSION AC(MZCHD,MZCHD),BLC(MZCHD,MZCHD),BVC(MZCHD,MZCHD) C COMMON /ALPHA/LSP(MZSLP,3),LCHAN(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /BNDINI/MCFGP,JOCCSH(MZNC2),JOCORB(MZOCC,MZNC2), A JELCSH(MZOCC,MZNC2),L1QNRD(MXOC21,3,MZNC2) COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /CUPMAT/NCONOB(MXNCF),LCONOB(MXL2,MXNCF),LCONAT(MXL2,MZTAR) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /REDMEL/CGC(MZLR2),MAXM1 COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /NRBDIP/LRANGD,MAXLD C----------------------------------------------------------------------- C C INITIALIZE C WRITE (IWRITE,3000) WRITE (IWRITE,3120) IF (IRK8.GT.0) CALL CHEKTP(-ITAPE1) DO 20 I = 1,NAST DO 10 J = 1,NTCON(I) MTYP(I,J) = NTYP(I,J) BIJ(I,J) = AIJ(I,J) 10 CONTINUE MTCON(I) = NTCON(I) 20 CONTINUE MAST = NAST C C ---- LOOP OVER DIFFERENT TRANSITIONS C E1 (MPOLE=2), M1 (MPOLE=3), E2 (MPOLE=4) C LDA= CHANGE IN L, ISPIN = CHANGE IN SPIN, IPAR = CHANGE IN PARITY C C DO 51 MPOLE=2,IPOLPH,2 MPOLE = 2 LDA = MPOLE/2 ISPIN = MOD(MPOLE,2)*LDA IPAR = MOD(LDA,2) C C ---- LOOP OVER FINAL S L PI SYMMETRIES C DO 530 MJ = 2,MSKIP LRGL = LSP(MJ,1) IF(LRGL.GT.MAXLD)GO TO 530 !NRB NSPN = LSP(MJ,2) NPTY = LSP(MJ,3) NCHAM = LCHAN(MJ) IF(NCHAM.EQ.0)GO TO 530 NCFGP = LCFG(MJ) CALL DMCON(1,MJ,NCFGP,NAST,NCONAT,LCONAT,IOCCSH,IOCORB,IELCSH, A I1QNRD) C C ---- LOOP OVER INITIAL S L PI SYMMETRIES C DO 520 MI = 1,MJ - 1 LLRGL = LSP(MI,1) IF(LLRGL.GT.MAXLD)GO TO 520 !NRB NNSPN = LSP(MI,2) MPTY = LSP(MI,3) MCHAN = LCHAN(MI) IF(MCHAN.EQ.0)GO TO 520 MCFGP = LCFG(MI) C C CHECK THE SELECTION RULES ARE SATISFIED. C IF (ABS(LRGL-LLRGL).GT.LDA .OR. A (LRGL+LLRGL).LT.LDA) GOTO 520 IF (ABS(NSPN-NNSPN).GT.ISPIN*2) GOTO 520 IF (ABS(NPTY-MPTY).NE.IPAR) GOTO 520 WRITE (IWRITE,3140) LRGL,NSPN,NPTY,LLRGL,NNSPN,MPTY CALL DMCON(1,MI,MCFGP,NAST,MCONAT,KCONAT,JOCCSH,JOCORB,JELCSH, A L1QNRD) IF (LAM.EQ.1) GOTO 220 C C EACH CHANNEL COUPLED TO A SPECIFIC IONIC OR ATOMIC STATE TO GIVE C A FINAL STATE CONTRIBUTION IS CONSIDERED IN TURN. C LCS = 0 DO 210 IA = 1,NAST IF (NCONAT(IA).EQ.0) GOTO 200 DO 190 IAA = 1,NCONAT(IA) LCH = LCS + IAA C C SIMILARLY EACH COUPLED CHANNEL GIVING AN INITIAL STATE C CONTRIBUTION IS LOOPED. C KCS = 0 DO 90 IB = 1,MAST IF (MCONAT(IB).EQ.0) GOTO 80 DO 70 IBB = 1,MCONAT(IB) KCH = KCS + IBB C C MATRIX ELEMENTS BETWEEN THE CONTINUUM BASIS COFIGURATIONS FOR THE C INITIAL AND FINAL STATES ARE CALCULATED. C CALL DMELCC(LDA,ISPIN,IA,IAA,IB,IBB,IVSH,ACOEF,BLCOEF, A BVCOEF) C C PLACE THE A AND B COEFFICIENTS IN APPROPRIATE PLACES IN THE AC C BLC AND BVC ARRAYS C AC(LCH,KCH) = ACOEF BLC(LCH,KCH) = BLCOEF BVC(LCH,KCH) = BVCOEF C C THE BLOCKS OF MATRIX ELEMENTS ARE WRITTEN TO FILE AND PRINTED OUT C WRITE (ITAPE4) ((DEL(I,J),J=1,NRANG2),I=1,NRANG2) WRITE (ITAPE4) ((DEV(I,J),J=1,NRANG2),I=1,NRANG2) IF (IBUG8.EQ.0) GOTO 70 IF (IVSH.EQ.0) THEN WRITE (IWRITE,3110) LCH,KCH GOTO 70 C ENDIF C WRITE (IWRITE,3030) LCH,KCH JLO = 1 IMA = 8 30 CONTINUE JUP = NRANG2 IF (NRANG2.GT.IMA) JUP = IMA DO 40 III = 1,NRANG2 WRITE (IWRITE,3010) (DEL(III,JJJ),JJJ=JLO,JUP) 40 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.NRANG2) GOTO 30 WRITE (IWRITE,3040) LCH,KCH JLO = 1 IMA = 8 50 CONTINUE JUP = MIN(IMA,NRANG2) DO 60 III = 1,NRANG2 WRITE (IWRITE,3010) (DEV(III,JJJ),JJJ=JLO,JUP) 60 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.NRANG2) GOTO 50 70 CONTINUE 80 KCS = KCS + MCONAT(IB) 90 CONTINUE C C MCHAN EQUALS TOTAL NUMBER OF CHANNELS IN THE INITIAL STATE C IF (MCHAN.NE.KCS) X WRITE(6,*)' ????','MCHAN(YY)=',MCHAN,'KCS(KTT)=',KCS MCHAN = KCS C C MATRIX ELEMENTS BETWEEN THE CONTINUUM BASIS CONFIGURATIONS FOR C THE FINAL STATE AND BOUND CONFIGURATIONS FOR THE INITIAL STATE C ARE CONSIDERED. FIRST, ARRAYS FOR THE BOUND CONFIGURATIONS ARE C SET UP. C IF (MCFGP.EQ.0) GOTO 180 DO 130 IM = 1,MCFGP MOCCSH(IM) = JOCCSH(IM) IG = JOCCSH(IM) IG1 = 2*IG - 1 DO 110 L = 1,3 DO 100 K = 1,IG1 M1QNRD(K,L,IM) = L1QNRD(K,L,IM) 100 CONTINUE 110 CONTINUE DO 120 K = 1,IG MOCORB(K,IM) = JOCORB(K,IM) MELCSH(K,IM) = JELCSH(K,IM) 120 CONTINUE 130 CONTINUE C C THE CONTINUUM-BOUND MATRIX ELEMENTS ARE CALCULATED. C CALL DMELCB(LDA,ISPIN,IA,IAA) C C THE CONTINUUM-BOUND BLOCKS ARE WRITTEN TO FILE AND PRINTED OUT. C WRITE (ITAPE4) ((DEL(I,J),J=1,NRANG2),I=1,MCFGP) WRITE (ITAPE4) ((DEV(I,J),J=1,NRANG2),I=1,MCFGP) IF (IBUG8.EQ.0) GOTO 180 WRITE (IWRITE,3050) LCH JLO = 1 IMA = 8 140 CONTINUE IF (NRANG2.LE.IMA) THEN JUP = NRANG2 C ELSE JUP = IMA ENDIF C DO 150 III = 1,MCFGP WRITE (IWRITE,3010) (DEL(III,JJJ),JJJ=JLO,JUP) 150 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.NRANG2) GOTO 140 WRITE (IWRITE,3060) LCH JLO = 1 IMA = 8 160 CONTINUE JUP = MIN(IMA,NRANG2) DO 170 III = 1,MCFGP WRITE (IWRITE,3010) (DEV(III,JJJ),JJJ=JLO,JUP) 170 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.NRANG2) GOTO 160 C C THE CONTINUUM-BUTTLE MATRIX ELEMENTS ARE CALCULATED. C 180 CONTINUE CALL DMELCD(LDA,ISPIN,IA,IAA) WRITE (ITAPE4) ((DEL(I,J),I=1,NRANG2),J=1,MCHAN) WRITE (ITAPE4) ((DEV(I,J),I=1,NRANG2),J=1,MCHAN) C 190 CONTINUE 200 LCS = LCS + NCONAT(IA) 210 CONTINUE C C NCHAN EQUALS THE TOTAL NUMBER OF CHANNELS IN THE FINAL STATE C IF (NCHAM.NE.LCS) X WRITE(6,*)' ????','NCHAM(YY)=',NCHAM,'LCS(KTT)=',LCS NCHAN = LCS C C MATRIX ELEMENTS BETWEEN THE BOUND CONFIGURATIONS FOR THE FINAL C STATE AND THE CONTINUUM BASIS CONFIGURATIONS FOR THE INITIAL C STATE ARE CONSIDERED. FIRST, SET UP ARRAYS FOR THE BOUND C CONFIGURATIONS. C 220 CONTINUE IF (NCFGP.EQ.0) GOTO 450 DO 260 IK = 1,NCFGP KOCCSH(IK) = IOCCSH(IK) IE = IOCCSH(IK) IE1 = 2*IE - 1 DO 240 L = 1,3 DO 230 KE = 1,IE1 K1QNRD(KE,L,IK) = I1QNRD(KE,L,IK) 230 CONTINUE 240 CONTINUE DO 250 K = 1,IE KOCORB(K,IK) = IOCORB(K,IK) KELCSH(K,IK) = IELCSH(K,IK) 250 CONTINUE 260 CONTINUE IF (LAM.EQ.1) GOTO 340 C C THE BOUND-CONTINUUM MATRIX ELEMENTS ARE CALCULATED. C KCS = 0 DO 330 IB = 1,MAST IF (MCONAT(IB).EQ.0) GOTO 320 DO 310 IBB = 1,MCONAT(IB) KCH = KCS + IBB CALL DMELBC(LDA,ISPIN,IB,IBB) C C THE BOUND-CONTINUUM BLOCKS ARE WRITTEN TO FILE AND PRINTED OUT. C WRITE (ITAPE4) ((DEL(J,I),J=1,NCFGP),I=1,NRANG2) WRITE (ITAPE4) ((DEV(J,I),J=1,NCFGP),I=1,NRANG2) IF (IBUG8.EQ.0) GOTO 310 WRITE (IWRITE,3070) KCH JLO = 1 IMA = 8 270 CONTINUE JUP = MIN(IMA,NCFGP) DO 280 III = 1,NRANG2 WRITE (IWRITE,3010) (DEL(JJJ,III),JJJ=JLO,JUP) 280 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.NCFGP) GOTO 270 WRITE (IWRITE,3080) KCH JLO = 1 IMA = 8 290 CONTINUE IF (NCFGP.LE.IMA) THEN JUP = NCFGP C ELSE JUP = IMA ENDIF C DO 300 III = 1,NRANG2 WRITE (IWRITE,3010) (DEV(JJJ,III),JJJ=JLO,JUP) 300 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.NCFGP) GOTO 290 310 CONTINUE 320 KCS = KCS + MCONAT(IB) 330 CONTINUE C C ARRAYS FOR THE BOUND CONFIGURATIONS OF THE INITIAL STATE ARE SET C UP AND THE BOUND-BOUND MATRIX ELEMENTS CALCULATED. C 340 CONTINUE IF (MCFGP.EQ.0) GOTO 440 DO 380 IM = 1,MCFGP MOCCSH(IM) = JOCCSH(IM) IG = JOCCSH(IM) IG1 = 2*IG - 1 DO 360 L = 1,3 DO 350 K = 1,IG1 M1QNRD(K,L,IM) = L1QNRD(K,L,IM) 350 CONTINUE 360 CONTINUE DO 370 K = 1,IG MOCORB(K,IM) = JOCORB(K,IM) MELCSH(K,IM) = JELCSH(K,IM) 370 CONTINUE 380 CONTINUE MAXOR = MAXORB C C IF NCFGP EXCEEDS THE VALUE OF NRANG2, THE SECOND DIMENSION OF C THE DEL AND DEV ARRAYS, CALCULATE AND STORE THE MATRIX ELEMENTS C IN BLOCKS. C NDIMEN = NRANG2 NTIMES = 1 + (NCFGP-1)/NDIMEN I2 = 0 DO 430 II = 1,NTIMES I1 = I2 + 1 I2 = MIN(II*NDIMEN,NCFGP) CALL DMELBB(LDA,ISPIN,I1,I2) C C THE BOUND-BOUND BLOCKS ARE WRITTEN TO FILE AND PRINTED OUT. C I3 = I2 - I1 + 1 WRITE (ITAPE4) ((DEL(I,J),J=1,I3),I=1,MCFGP) WRITE (ITAPE4) ((DEV(I,J),J=1,I3),I=1,MCFGP) IF (IBUG8.EQ.0) GOTO 430 WRITE (IWRITE,3090) JLO = 1 IMA = 8 390 CONTINUE JUP = MIN(IMA,I3) DO 400 III = 1,MCFGP WRITE (IWRITE,3010) (DEL(III,JJJ),JJJ=JLO,JUP) 400 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.I3) GOTO 390 WRITE (IWRITE,3100) JLO = 1 IMA = 8 410 CONTINUE IF (I3.LE.IMA) THEN JUP = I3 C ELSE JUP = IMA ENDIF C DO 420 III = 1,MCFGP WRITE (IWRITE,3010) (DEV(III,JJJ),JJJ=JLO,JUP) 420 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3020) IF (JLO.LE.I3) GOTO 410 430 CONTINUE C C THE BOUND-BUTTLE MATRIX ELEMENTS ARE CALCULATED. C 440 CONTINUE IF (LAM.EQ.1) GOTO 520 CALL DMELBD(LDA,ISPIN) WRITE (ITAPE4) ((DEL(I,J),I=1,NCFGP),J=1,MCHAN) WRITE (ITAPE4) ((DEV(I,J),I=1,NCFGP),J=1,MCHAN) C C THE BUTTLE-CONTINUUM MATRIX ELEMENTS ARE CALCULATED. C 450 CONTINUE IF (LAM.EQ.1) GOTO 520 DO 470 IB = 1,MAST IF(MCONAT(IB).EQ.0)GO TO 470 DO 460 IBB = 1,MCONAT(IB) CALL DMELDC(LDA,ISPIN,IB,IBB) WRITE (ITAPE4) ((DEL(I,J),I=1,NCHAM),J=1,NRANG2) WRITE (ITAPE4) ((DEV(I,J),I=1,NCHAM),J=1,NRANG2) 460 CONTINUE 470 CONTINUE C C THE BUTTLE-BOUND MATRIX ELEMENTS ARE CALCULATED. THIS BLOCK C IS TRANSPOSED IN DEL AND DEV TO AVOID DIMENSION OVERFLOWS. C IF (MCFGP.GT.0) THEN CALL DMELDB(LDA,ISPIN) WRITE (ITAPE4) ((DEL(J,I),I=1,NCHAM),J=1,MCFGP) WRITE (ITAPE4) ((DEV(J,I),I=1,NCHAM),J=1,MCFGP) ENDIF C C THE BUTTLE-BUTTLE MATRIX ELEMENTS ARE CALCULATED. C CALL DMELDD(LDA,ISPIN) WRITE (ITAPE4) ((DEL(I,J),I=1,NCHAM),J=1,MCHAN) WRITE (ITAPE4) ((DEV(I,J),I=1,NCHAM),J=1,MCHAN) C C EVALUATE THE CLEBSCH GORDAN COEFFICIENTS REQUIRED IN THE C POLARIZABILITY CALCULATION IN STGH. C MAXM1 = MIN(LRGL,LLRGL) + 1 DO 480 M = 1,MAXM1 M1 = M - 1 FACTOR = DBLE(LRGL+LRGL+1) CGC(M) = CG(LLRGL,1,LRGL,M1,0,M1)/SQRT(FACTOR) 480 CONTINUE C C WRITE OUT THE CLEBSCH-GORDAN COEFFICIENTS FOR THE DIPOLE MATRIX C ELEMENTS TO TAPE. C WRITE (ITAPE4) MAXM1, (CGC(M),M=1,MAXM1) IF (IBUG8.GT.0) WRITE (IWRITE,3160) MAXM1 IF (IBUG8.GT.0) WRITE (IWRITE,3010) (CGC(M),M=1,MAXM1) C C WRITE TO ITAPE4 THE ARRAYS OF A AND B COEFFICIENTS NECESSARY C FOR THE EVALUATION OF THE DIPOLE MATRIX ELEMENT CONTRIBUTION C FROM OUTSIDE THE R-MATRIX BOUNDARY C WRITE (ITAPE4) ((AC(I,J),J=1,MCHAN),I=1,NCHAN) WRITE (ITAPE4) ((BLC(I,J),J=1,MCHAN),I=1,NCHAN) WRITE (ITAPE4) ((BVC(I,J),J=1,MCHAN),I=1,NCHAN) IF (IBUG8.EQ.0) GOTO 520 WRITE (6,3170) DO 490 I = 1,NCHAN WRITE (6,3010) (AC(I,J),J=1,MCHAN) 490 CONTINUE WRITE (6,3180) DO 500 I = 1,NCHAN WRITE (6,3010) (BLC(I,J),J=1,MCHAN) 500 CONTINUE WRITE (6,3190) DO 510 I = 1,NCHAN WRITE (6,3010) (BVC(I,J),J=1,MCHAN) 510 CONTINUE C C ---- END OF LOOPS C 520 CONTINUE 530 CONTINUE WRITE (IWRITE,3130) C 3000 FORMAT (//30X,'SUBROUTINE DMEL'/30X,15 ('-')) 3010 FORMAT (8F15.7) 3020 FORMAT (//) 3030 FORMAT (//' CONTINUUM-CONTINUUM DIPOLE LENGTH M.E. FROM FINAL', A ' STATE CHANNEL',I3,' AND INITIAL STATE CHANNEL',I3/) 3040 FORMAT (//' CONTINUUM-CONTINUUM DIPOLE VELOCITY M.E. FROM FINAL', A ' STATE CHANNEL',I3,' AND INITIAL STATE CHANNEL',I3/) 3050 FORMAT (//' CONTINUUM-BOUND DIPOLE LENGTH M.E. FROM FINAL', A ' STATE CHANNEL',I3/) 3060 FORMAT (//' CONTINUUM-BOUND DIPOLE VELOCITY M.E. FROM FINAL', A ' STATE CHANNEL',I3/) 3070 FORMAT (//' BOUND-CONTINUUM DIPOLE LENGTH M.E. FROM INITIAL', A ' STATE CHANNEL',I3/) 3080 FORMAT (//' BOUND-CONTINUUM DIPOLE VELOCITY M.E. FROM INITIAL', A ' STATE CHANNEL',I3/) 3090 FORMAT (//' BOUND-BOUND DIPOLE LENGTH MATRIX ELEMENTS'/) 3100 FORMAT (//' BOUND-BOUND DIPOLE VELOCITY MATRIX ELEMENTS'/) 3110 FORMAT (//' CONTINUUM-CONTINUUM DIPOLE M.E. FROM FINAL STATE', A ' CHANNEL',I3,' AND INITIAL STATE CHANNEL',I3, B ' ARE ZERO'//) 3120 FORMAT (//' CALCULATE AND STORE (ON THE OUTPUT DATA TAPE)', A ' THE DIPOLE MATRIX ELEMENTS') 3130 FORMAT (//' DIPOLE MATRIX ELEMENTS NOW STORED ON OUTPUT DATA TAPE' A ) 3140 FORMAT (//24X,'FINAL STATE',23X,'INITIAL STATE'/4X,'LRGL =',I3, A ' NSPN =',I3,' NPTY =',I3,4X,'LLRGL =',I3,' NNSPN =', B I3,' MPTY =',I3) 3160 FORMAT (//' MAXM1 =',I2,' CGC ='/) 3170 FORMAT (/' THE A COEFFICIENTS'/) 3180 FORMAT (/' THE B LENGTH COEFFICIENTS'/) 3190 FORMAT (/' THE B VELOCITY COEFFICIENTS'/) END SUBROUTINE DMELBB(LDA,ISPIN,I1,I2) use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE BOUND-BOUND DIPOLE MATRIX ELEMENTS C C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN. C I1 AND I2 ARE THE FIRST AND LAST ELEMENTS IN THE CURRENT BLOCK. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C C MXDM=MAX(MZNC2,MZNR2): C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C DIMENSION VSHELL(MXORB2) C COMMON /BNDINI/MCFGP,JOCCSH(MZNC2),JOCORB(MZOCC,MZNC2), A JELCSH(MZOCC,MZNC2),L1QNRD(MXOC21,3,MZNC2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C----------------------------------------------------------------------- IF (IBUG8.EQ.2) WRITE (IWRITE,3000) I3 = 0 C DO 20 IK = I1,I2 I3 = I3 + 1 DO 10 IM = 1,MCFGP DEL(IM,I3) = 0.0D0 DEV(IM,I3) = 0.0D0 IRHO = 0 ISIG = 0 CALL SETUPE(IM,IK,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 10 CANG = VSHELL(1) IF (IBUG8.EQ.2) WRITE (IWRITE,3010) IK,IM,CANG N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) LM = L1 + 1 LN = L2 + 1 IF (LDA.GT. (L1+L2) .OR. LDA.LT.ABS(L1-L2) .OR. A MOD(LDA+L1+L2,2).NE.0) GOTO 10 RMANG = RME(L1,L2,LDA) COEF = CANG*RMANG CALL FINMNT(N1,LM,N2,LN,LDA,XL,XV) IF (IBUG8.EQ.2) WRITE (IWRITE,3020) XL,XV DEL(IM,I3) = COEF*XL DEV(IM,I3) = COEF*XV 10 CONTINUE 20 CONTINUE C 3000 FORMAT (//40X,' DEBUGGING PRINT OUT FROM DMELBB'/) 3010 FORMAT (I5,'-TH FINAL BOUND CONFIGURATION',I5, A '-TH INITIAL BOUND CONFIGURATION VSHELL=',F14.7) 3020 FORMAT (' THE RELEVANT B-B RADIAL DIPOLE INTEGRALS ARE',2F14.7) END SUBROUTINE DMELBC(LDA,ISPIN,IB,IBB) use dipmel use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE BOUND-CONTINUUM DIPOLE MATRIX ELEMENTS; C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN, C IB AND IBB DEFINE THE IONIC STATE AND COUPLED CHANNEL. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXPOL= (MZLMX+1)/2) C DIMENSION AXL(MZNR2),AXV(MZNR2) DIMENSION VSHELL(MXORB2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- C C INITIALIZE THE DIPOLE MATRIX ELEMENTS TO ZERO. C IF (IBUG8.EQ.2) WRITE (IWRITE,3000) DO 20 IK = 1,NCFGP DO 10 I = 1,NRANG2 DEL(IK,I) = 0.0D0 DEV(IK,I) = 0.0D0 10 CONTINUE 20 CONTINUE C DO 70 IM = 1,MTCON(IB) IF (AIJ(IB,IM).EQ.ZERO) GOTO 70 I4 = MTYP(IB,IM) C C SETINI IS CALLED. L4 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETINI(IB,I4,IBB,L4) MAXOR = MAXORB + 1 IOD = NOCCSH(I4) + 1 MOCORB(IOD,I4) = MAXOR NJCOMP(MAXOR) = 999 LJCOMP(MAXOR) = L4 C DO 60 IK = 1,NCFGP IRHO = 0 ISIG = 0 CALL SETUPE(I4,IK,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 60 N2 = NJ(ISIG) L2 = LJ(ISIG) CANG = VSHELL(1) IF (LDA.GT. (L4+L2) .OR. LDA.LT.ABS(L4-L2) .OR. A MOD(LDA+L4+L2,2).NE.0) GOTO 60 RMANG = RME(L4,L2,LDA) IF (IBUG8.EQ.2) WRITE (IWRITE,3010) IK,I4,CANG COEF = CANG*RMANG*AIJ(IB,IM) C C LOCATE THE BOUND CONTINUUM RADIAL INTEGRALS IN RKSTO2. C LM = L2 + 1 LN = L4 + 1 LCT = IBCPOL(LM,LN,LDA) + 2* (N2-LM)*NRANG2 DO 30 IC = 1,NRANG2 II = LCT + 2* (IC-1) II1 = II + 1 AXL(IC) = RKSTO2(II) AXV(IC) = -RKSTO2(II1) 30 CONTINUE IF (IBUG8.NE.2) GOTO 40 WRITE (IWRITE,3020) WRITE (IWRITE,3030) (AXL(IC),AXV(IC),IC=1,NRANG2) 40 CONTINUE DO 50 IC = 1,NRANG2 DEL(IK,IC) = DEL(IK,IC) + COEF*AXL(IC) DEV(IK,IC) = DEV(IK,IC) + COEF*AXV(IC) 50 CONTINUE 60 CONTINUE 70 CONTINUE C 3000 FORMAT (//40X,' DEBUGGING PRINT OUT FROM DMELBC'/) 3010 FORMAT (I5, A '-TH FINAL BOUND CONFIGURATION INITIAL CONFIGURATION IS', B I5,'-TH IN THE CONFIGURATION ARRAY VSHELL =',F14.7) 3020 FORMAT (' THE RELEVANT B-C RADIAL DIPOLE INTEGRALS ARE'/) 3030 FORMAT (8F14.7) END SUBROUTINE DMELBD(LDA,ISPIN) use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE BOUND-BUTTLE DIPOLE MATRIX ELEMENTS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) C DIMENSION VSHELL(MXORB2) C COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- C C INITIALIZE ARRAYS C I = 0 DO 30 I1 = 1,MAST DO 20 I2 = 1,MCONAT(I1) I = I + 1 DO 10 J = 1,NCFGP DEL(J,I) = 0.0D0 DEV(J,I) = 0.0D0 10 CONTINUE 20 CONTINUE 30 CONTINUE C KCH = 0 DO 70 IB = 1,MAST DO 60 IBB = 1,MCONAT(IB) KCH = KCH + 1 C DO 50 IM = 1,MTCON(IB) IF (BIJ(IB,IM).EQ.ZERO) GOTO 50 I4 = MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) MAXOR = MAXORB + 1 IOD = NOCCSH(I4) + 1 MOCORB(IOD,I4) = MAXOR NJCOMP(MAXOR) = 999 LJCOMP(MAXOR) = L4 C DO 40 IK = 1,NCFGP IRHO = 0 ISIG = 0 CALL SETUPE(I4,IK,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 40 N2 = NJ(ISIG) L2 = LJ(ISIG) CANG = VSHELL(1) IF (LDA.GT. (L4+L2) .OR. LDA.LT.ABS(L4-L2) .OR. A MOD(LDA+L4+L2,2).NE.0) GOTO 40 RMANG = RME(L4,L2,LDA) COEF = CANG*RMANG*BIJ(IB,IM) C LCT = JBCPOL(L2+1,L4+1) + 2* (N2-L2-1) RNTL = SKSTO2(LCT) RNTV = -SKSTO2(LCT+1) DEL(IK,KCH) = DEL(IK,KCH) + COEF*RNTL DEV(IK,KCH) = DEV(IK,KCH) + COEF*RNTV C 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C END SUBROUTINE DMELCB(LDA,ISPIN,IA,IAA) use dipmel use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE CONTINUUM-BOUND DIPOLE MATRIX ELEMENTS; C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN, C IA AND IAA DEFINE THE IONIC STATE AND COUPLED CHANNEL. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXPOL= (MZLMX+1)/2) C DIMENSION AXL(MZNR2),AXV(MZNR2) DIMENSION VSHELL(MXORB2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BNDINI/MCFGP,JOCCSH(MZNC2),JOCORB(MZOCC,MZNC2), A JELCSH(MZOCC,MZNC2),L1QNRD(MXOC21,3,MZNC2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- C C INITIALIZE THE DIPOLE MATRIX ELEMENTS TO ZERO. C IF (IBUG8.EQ.2) WRITE (IWRITE,3000) DO 20 IM = 1,MCFGP DO 10 J = 1,NRANG2 DEL(IM,J) = 0.0D0 DEV(IM,J) = 0.0D0 10 CONTINUE 20 CONTINUE C DO 70 IK = 1,NTCON(IA) IF (AIJ(IA,IK).EQ.ZERO) GOTO 70 I3 = NTYP(IA,IK) C C SETFIN IS CALLED. L3 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETFIN(IA,I3,IAA,L3) C DO 60 IM = 1,MCFGP C C SETUPE, TENSOR AND RME ARE CALLED TO EVALUATE THE ANGULAR C COEFFICIENT. C IRHO = 0 ISIG = 0 CALL SETUPE(IM,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 60 N1 = NJ(IRHO) L1 = LJ(IRHO) CANG = VSHELL(1) IF (LDA.GT. (L1+L3) .OR. LDA.LT.ABS(L1-L3) .OR. A MOD(LDA+L1+L3,2).NE.0) GOTO 60 RMANG = RME(L1,L3,LDA) IF (IBUG8.EQ.2) WRITE (IWRITE,3010) I3,IM,CANG COEF = CANG*RMANG*AIJ(IA,IK) C C LOCATE THE BOUND CONTINUUM RADIAL INTEGRALS IN RKSTO2. C LM = L1 + 1 LN = L3 + 1 LCT = IBCPOL(LM,LN,LDA) + 2* (N1-LM)*NRANG2 DO 30 IC = 1,NRANG2 II = LCT + 2* (IC-1) II1 = II + 1 AXL(IC) = RKSTO2(II) AXV(IC) = RKSTO2(II1) 30 CONTINUE IF (IBUG8.NE.2) GOTO 40 WRITE (IWRITE,3020) WRITE (IWRITE,3030) (AXL(IC),AXV(IC),IC=1,NRANG2) 40 CONTINUE DO 50 IC = 1,NRANG2 DEL(IM,IC) = DEL(IM,IC) + COEF*AXL(IC) DEV(IM,IC) = DEV(IM,IC) + COEF*AXV(IC) 50 CONTINUE 60 CONTINUE 70 CONTINUE C 3000 FORMAT (//40X,' DEBUGGING PRINT OUT FROM DMELCB'/) 3010 FORMAT (' FINAL CONFIGURATION IS',I5,'-TH IN THE CONFIGURATION', A ' ARRAY',I5,'-TH INITIAL BOUND CONFIGURATION VSHELL =', B F14.7) 3020 FORMAT (' THE RELEVANT C-B RADIAL DIPOLE INTEGRALS ARE'/) 3030 FORMAT (8F14.7) END SUBROUTINE DMELCC(LDA,ISPIN,IA,IAA,IB,IBB,IVSH,ACOEF,BLCOEF, A BVCOEF) use dipmel use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE CONTINUUM-CONTINUUM DIPOLE MATRIX ELEMENTS; C LDA AND ISPIN ARE THE MULTIPOLE ORDER AND SPIN, C IA AND IAA, IB AND IBB DEFINE THE IONIC STATES AND COUPLED C CHANNELS. C IVSH IS SET ZERO IF THE ANGULAR AND SPIN INTEGRAL IS ZERO. C C THE A AND B COEFFICIENTS NECESSARY TO THE CALCULATION OF THE C OUTER REGION CONTRIBUTION TO DIPOLE MATRIX ELEMENTS ARE ALSO C OBTAINED. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXPOL= (MZLMX+1)/2) C DIMENSION VSHELL(MXORB2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- C C INITIALIZE THE DIPOLE MATRIX ELEMENTS TO ZERO. C IVSH = 0 IF (IBUG8.EQ.2) WRITE (IWRITE,3000) NTCON(IA),MTCON(IB) DO 20 I = 1,NRANG2 DO 10 J = 1,NRANG2 DEL(I,J) = 0.0D0 DEV(I,J) = 0.0D0 10 CONTINUE 20 CONTINUE C C INITIALIZE THE A AND B COEFFICIENTS TO ZERO C ACOEF = 0.0D0 BLCOEF = 0.0D0 BVCOEF = 0.0D0 C DO 120 IK = 1,NTCON(IA) IF (AIJ(IA,IK).EQ.ZERO) GOTO 120 I3 = NTYP(IA,IK) C C SETFIN IS CALLED TO SET UP THE COUPLING ARRAYS FOR THE FINAL C STATE CONFIGURATION. L3 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETFIN(IA,I3,IAA,L3) C DO 110 IM = 1,MTCON(IB) IF (AIJ(IB,IM).EQ.ZERO) GOTO 110 I4 = MTYP(IB,IM) C C SETINI IS CALLED TO SET UP THE COUPLING ARRAYS FOR THE INITIAL C STATE CONFIGURATION. L4 IS THE ANGULAR MOMENTUM OF THE CONTINUUM C ELECTRON. C CALL SETINI(IB,I4,IBB,L4) C C THE CASE OF THE CONTINUUM ELECTRONS HAVING EQUAL ANGULAR C MOMENTA IS CONSIDERED. C IF (L3.NE.L4) GOTO 30 IOD = NOCCSH(I4) + 1 MAXOR = MAXORB + 1 MOCORB(IOD,I4) = MAXOR C C SETUPE TENSOR AND RME ARE CALLED TO EVALUATE THE ANGULAR C COEFFICIENT. C 30 CONTINUE IRHO = 0 ISIG = 0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG = VSHELL(1) IF (CANG.NE.ZERO) IVSH = 1 IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 110 IF (IBUG8.EQ.2) THEN WRITE (IWRITE,3010) ISIG,IRHO WRITE (IWRITE,3020) I3,I4,CANG ENDIF C N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) IF (LDA.GT. (L1+L2) .OR. LDA.LT.ABS(L1-L2) .OR. A MOD(LDA+L1+L2,2).NE.0) GOTO 110 RMANG = RME(L1,L2,LDA) COEF = RMANG*CANG*AIJ(IA,IK)*AIJ(IB,IM) C C IF THE CONTINUUM ELECTRON HAS THE SAME ANGULAR MOMENTUM IN BOTH C THE INITIAL AND FINAL STATE CHANNELS TREAT L1 AND L2 AS THE C ORBITAL ANGULAR MOMENTA OF BOUND ELECTRONS. C LR = L1 + 1 LS = L2 + 1 IF (L3.NE.L4) GOTO 50 C C TWO BOUND-BOUND RADIAL INTEGRALS(LENGTH AND VELOCITY) ARE C EXTRACTED FROM THE RKSTO2 ARRAY. C CALL FINMNT(N1,LR,N2,LS,LDA,XL,XV) IF (IBUG8.EQ.2) WRITE (IWRITE,3030) XL,XV DO 40 I = 1,NRANG2 DEL(I,I) = DEL(I,I) + COEF*XL DEV(I,I) = DEV(I,I) + COEF*XV 40 CONTINUE BLCOEF = DEL(1,1) BVCOEF = DEV(1,1) GOTO 110 C C DEFINE LR AND LS IN A STANDARD ORDER. C 50 CONTINUE IF (LR.LT.LS) GOTO 60 LAN = LR LR = LS LS = LAN C C THE POSITION OF THE FIRST RELEVANT DIPOLE LENGTH C-C INTEGRAL C IN THE RKSTO2 ARRAY IS STORED IN INP. C 60 CONTINUE INP = ICCPOL(LR,LS,1) IF (IBUG8.NE.2) GOTO 70 WRITE (IWRITE,3040) L2,L1 WRITE (IWRITE,3050) INP C C THE RELEVANT DIPOLE LENGTH AND VELOCITY RADIAL INTEGRALS ARE C MULTIPLIED BY THE COMMON ANGULAR CONTRIBUTION. ACCOUNT IS TAKEN C OF POSSIBLE INTERCHANGE OF LR AND LS. C 70 CONTINUE DO 100 I = 1,NRANG2 LL = INP + 2* (I-1)*NRANG2 IF (L1.LT.L2) THEN DO 80 J = 1,NRANG2 JL = LL + 2* (J-1) RNTL = RKSTO2(JL) RNTV = RKSTO2(JL+1) DEL(I,J) = DEL(I,J) + COEF*RNTL DEV(I,J) = DEV(I,J) + COEF*RNTV 80 CONTINUE C ELSE DO 90 J = 1,NRANG2 JL = LL + 2* (J-1) RNTL = RKSTO2(JL) RNTV = ENDS(J,LS)*ENDS(I,LR) - RKSTO2(JL+1) DEL(J,I) = DEL(J,I) + COEF*RNTL DEV(J,I) = DEV(J,I) + COEF*RNTV 90 CONTINUE ENDIF C 100 CONTINUE ACOEF = ACOEF + COEF 110 CONTINUE 120 CONTINUE C 3000 FORMAT (//41X,'DEBUGGING PRINT OUT FROM DMELCC'/ A ' THE NUMBERS OF CONFIGURATIONS IN THE FINAL STATE CHANNEL=' B ,I5,11X,'IN THE INITIAL STATE CHANNEL=',I5/) 3010 FORMAT (' INTERACTING SHELLS-(FINAL CONFIGURATION) ISIG=',I5,5X, A '(INITIAL CONFIGURATION) IRHO=',I5) 3020 FORMAT (' FINAL CONFIGURATION IS',I5, A '-TH, INITIAL CONFIGURATION',' IS',I5, B '-TH IN THE CONFIGURATION ARRAY VSHELL =',F14.7) 3030 FORMAT (' THE FINAL AND INITIAL CONFIGURATION CONTINUUM ELECTRON', A ' HAVE THE SAME ANGULAR MOMENTUM'/ B ' THE RELEVANT B-B RADIAL INTEGRALS ARE',2F14.7) 3040 FORMAT (' ORBITAL ANGULAR MOMENTA OF INTERACTING ELECTRONS- IN', A ' FINAL CONFIGURATION=',I5,5X,' IN INITIAL CONFIGURATION=', B I5) 3050 FORMAT (' THE FIRST RELEVANT DIPOLE LENGTH CONTINUUM-CONTINUUM', A ' RADIAL INTEGRAL IS IN POSITION',I5, B ' IN THE RKSTO2 ARRAY') END SUBROUTINE DMELCD(LDA,ISPIN,IA,IAA) use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE CONTINUUM-BUTTLE DIPOLE MATRIX ELEMENT C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) C DIMENSION VSHELL(MXORB2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA C COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- KCH = 0 DO 60 IB = 1,MAST DO 50 IBB = 1,MCONAT(IB) KCH = KCH + 1 C DO 10 I = 1,NRANG2 DEL(I,KCH) = 0.0D0 DEV(I,KCH) = 0.0D0 10 CONTINUE C DO 40 IK = 1,NTCON(IA) IF (AIJ(IA,IK).EQ.ZERO) GOTO 40 I3 = NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 30 IM = 1,MTCON(IB) IF (BIJ(IB,IM).EQ.ZERO) GOTO 30 I4 = MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) IF (L3.EQ.L4) GOTO 30 C IRHO = 0 ISIG = 0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG = VSHELL(1) IF (LDA.GT. (L4+L3) .OR. LDA.LT.ABS(L4-L3) .OR. A MOD(LDA+L4+L3,2).NE.0) GOTO 30 RMANG = RME(L4,L3,LDA) COEF = CANG*RMANG*AIJ(IA,IK)*BIJ(IB,IM) C INP = JCCPOL(L3+1,L4+1) DO 20 I = 1,NRANG2 RNTL = SKSTO2(INP) RNTV = SKSTO2(INP+1) RNTV = ENDS(I,L3+1)*ENDS(NRANG2+1,L4+1) - RNTV DEL(I,KCH) = DEL(I,KCH) + COEF*RNTL DEV(I,KCH) = DEV(I,KCH) + COEF*RNTV INP = INP + 2 20 CONTINUE C 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE C END SUBROUTINE DMELDB(LDA,ISPIN) use basic2 use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE BUTTLE-BOUND DIPOLE MATRIX ELEMENTS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) C DIMENSION VSHELL(MXORB2) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDINI/MCFGP,JOCCSH(MZNC2),JOCORB(MZOCC,MZNC2), A JELCSH(MZOCC,MZNC2),L1QNRD(MXOC21,3,MZNC2) c COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- C C INITIALIZE ARRAYS C I = 0 DO 30 I1 = 1,NAST DO 20 I2 = 1,NCONAT(I1) I = I + 1 DO 10 J = 1,MCFGP DEL(J,I) = 0.0D0 DEV(J,I) = 0.0D0 10 CONTINUE 20 CONTINUE 30 CONTINUE C LCH = 0 DO 70 IA = 1,NAST DO 60 IAA = 1,NCONAT(IA) LCH = LCH + 1 C DO 50 IK = 1,NTCON(IA) IF (AIJ(IA,IK).EQ.ZERO) GOTO 50 I3 = NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 40 IM = 1,MCFGP IRHO = 0 ISIG = 0 CALL SETUPE(IM,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 40 N1 = NJ(IRHO) L1 = LJ(IRHO) CANG = VSHELL(1) IF (LDA.GT. (L1+L3) .OR. LDA.LT.ABS(L1-L3) .OR. A MOD(LDA+L1+L3,2).NE.0) GOTO 40 RMANG = RME(L1,L3,LDA) COEF = CANG*RMANG*AIJ(IA,IK) C LCT = JBCPOL(L1+1,L3+1) + 2* (N1-L1-1) RNTL = SKSTO2(LCT) RNTV = SKSTO2(LCT+1) DEL(IM,LCH) = DEL(IM,LCH) + COEF*RNTL DEV(IM,LCH) = DEV(IM,LCH) + COEF*RNTV C 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C END SUBROUTINE DMELDC(LDA,ISPIN,IB,IBB) use basic2 use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C CALCULATES THE BUTTLE-CONTINUUM DIPOLE MATRIX ELEMENTS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) C DIMENSION VSHELL(MXORB2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY c COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- LCH = 0 DO 60 IA = 1,NAST DO 50 IAA = 1,NCONAT(IA) LCH = LCH + 1 C DO 10 I = 1,NRANG2 DEL(LCH,I) = 0.0D0 DEV(LCH,I) = 0.0D0 10 CONTINUE C DO 40 IK = 1,NTCON(IA) IF (AIJ(IA,IK).EQ.ZERO) GOTO 40 I3 = NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 30 IM = 1,MTCON(IB) IF (BIJ(IB,IM).EQ.ZERO) GOTO 30 I4 = MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) IF (L3.EQ.L4) GOTO 30 C IRHO = 0 ISIG = 0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG = VSHELL(1) IF (LDA.GT. (L4+L3) .OR. LDA.LT.ABS(L4-L3) .OR. A MOD(LDA+L4+L3,2).NE.0) GOTO 30 RMANG = RME(L4,L3,LDA) COEF = CANG*RMANG*AIJ(IA,IK)*BIJ(IB,IM) C INP = JCCPOL(L4+1,L3+1) DO 20 I = 1,NRANG2 RNTL = SKSTO2(INP) RNTV = SKSTO2(INP+1) DEL(LCH,I) = DEL(LCH,I) + COEF*RNTL DEV(LCH,I) = DEV(LCH,I) + COEF*RNTV INP = INP + 2 20 CONTINUE C 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE C END SUBROUTINE DMELDD(LDA,ISPIN) use basic2 use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C THIS SUBROUTINE CALCULATES THE BUTTLE-BUTTLE DIPOLE MATRIX C ELEMENTS. SPECIAL CASE OF DIPOLE TRANSITION TAKING PLACE IN C THE TARGET IS CONSIDERED. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXORBS=MZNR2*MZLR2+MXORB,MXSK2=4*MXORBS) C DIMENSION VSHELL(MXORB2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA c COMMON /DIPMEL/DEL(MXDM1,MXDM2),DEV(MXDM1,MXDM2) COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /JNSTO/SKSTO2(MXSK2),BNORM(MZLR2),JRK8,JBCPOL(MZLR1,MZLR2), A JCCPOL(MZLR2,MZLR2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- LCH = 0 DO 60 IA = 1,NAST DO 50 IAA = 1,NCONAT(IA) LCH = LCH + 1 C KCH = 0 DO 40 IB = 1,MAST DO 30 IBB = 1,MCONAT(IB) KCH = KCH + 1 DEL(LCH,KCH) = 0.0D0 DEV(LCH,KCH) = 0.0D0 C DO 20 IK = 1,NTCON(IA) IF (AIJ(IA,IK).EQ.ZERO) GOTO 20 I3 = NTYP(IA,IK) CALL SETFIN(IA,I3,IAA,L3) C DO 10 IM = 1,MTCON(IB) IF (BIJ(IB,IM).EQ.ZERO) GOTO 10 I4 = MTYP(IB,IM) CALL SETINI(IB,I4,IBB,L4) IF (L3.EQ.L4) THEN IOD = NOCCSH(I4) + 1 MAXOR = MAXORB + 1 MOCORB(IOD,I4) = MAXOR ENDIF C IRHO = 0 ISIG = 0 CALL SETUPE(I4,I3,NJCOMP,LJCOMP) CALL TENSOR(LDA,ISPIN,IRHO,ISIG,VSHELL) CANG = VSHELL(1) IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 10 N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) IF (LDA.GT. (L1+L2) .OR. LDA.LT.ABS(L1-L2) .OR. A MOD(LDA+L1+L2,2).NE.0) GOTO 10 RMANG = RME(L1,L2,LDA) COEF = CANG*RMANG*AIJ(IA,IK)*BIJ(IB,IM) C IF (L3.EQ.L4) THEN CALL FINMNT(N1,L1+1,N2,L2+1,LDA,XL,XV) RNTL = XL*BNORM(L3+1) RNTV = XV*BNORM(L3+1) C ELSE LH = MAX(L3,L4) + 1 LL = MIN(L3,L4) + 1 INP = JCCPOL(LH,LL) - 2 RNTL = SKSTO2(INP) INP = INP + 1 RNTV = SKSTO2(INP) IF (L4+1.EQ.LH) RNTV = ENDS(NRANG2+1,LL)* A ENDS(NRANG2+1,LH) - RNTV ENDIF C DEL(LCH,KCH) = DEL(LCH,KCH) + COEF*RNTL DEV(LCH,KCH) = DEV(LCH,KCH) + COEF*RNTV C 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE C END C C*********************************************************************** SUBROUTINE DWOUT1 use basic2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FIRST DISTORTED-WAVE ROUTINE - TWG & NRB C WRITE TARGET INFO (FIRST PASS ONLY) C WRITE CHANNEL INFO (EACH PASS) C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MX2LR2=2*MZLR2) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /DWMETA/NTARG(MZCHF),IMETA(MZTAR),NMETAS COMMON /DWORB/NORIG(MXORB),LORIG(MXORB) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX DIMENSION IX(MXORB) C C WRITE TARGET INFO TO DISC (FIRST PASS THROUGH ONLY) C IF(MSKIP.EQ.1) THEN WRITE(21)INAST IF(IDWBUG.NE.0)WRITE(20,103)INAST C WRITE(22,103)NAST,MAXORB,KCOR WRITE(22,105)(NORIG(I),LORIG(I),I=1,MAXORB) 105 FORMAT(16(I3,I2)) C DO 30 I=1,NAST NQSPN=ISAT(I) IF(NDWPTY(I).EQ.1)NQSPN=-NQSPN ERYD=2.D0*(ENAT(I)-ENAT(1)) WRITE(22,103)NQSPN,LAT(I),NTCON(I),ERYD,IMETA(I) 103 FORMAT(3I5,F12.6,I5) DO 40 J=1,NTCON(I) NCONF=NTYP(I,J) L=1 DO 50 K=1,MAXORB IF(NOCORB(L,NCONF).EQ.K) THEN IX(K)=NELCSH(L,NCONF) L=L+1 ELSE IX(K)=0 ENDIF 50 CONTINUE WRITE(22,104)AIJ(I,J),(IX(K),K=1,MAXORB) 104 FORMAT(F10.6,(20I3)) 40 CONTINUE 30 CONTINUE ENDIF C C WRITE OUT CHANNEL INFO TO DISC C NQSPN=NSPN IF(LRGL.GT.LNOEX)NQSPN=99 IF(NPTY.EQ.1)NQSPN=-NQSPN J=0 DO 20 I=1,NAST DO 21 ICH=1,NCONAT(I) J=J+1 NTARG(J)=I 21 CONTINUE 20 CONTINUE WRITE(21)NQSPN,LRGL,NCHAN IF(IDWBUG.NE.0)WRITE(20,100)NQSPN,LRGL,NCHAN 100 FORMAT(3I5) DO 10 I=1,NCHAN WRITE(21)NTARG(I),L2P(I),IMETA(NTARG(I)) IF(IDWBUG.NE.0)WRITE(20,100)NTARG(I),L2P(I),IMETA(NTARG(I)) 10 CONTINUE C RETURN END C*********************************************************************** SUBROUTINE DWOUT2(IRHO,ISIG,IRHOP,ISIGP) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C SECOND DISTORTED-WAVE ROUTINE - TWG & NRB C STORE DIRECT AND EXCHANGE MATRIX ELEMENTS AND THEIR POINTERS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MX2LR2=2*MZLR2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXNC1=MZNC1*MZNC1/10+2*MZNC1) C COMMON /DW/ISTL,ISTR,NCHNL,NCHNR,ICL,ICR,IE,IG,ISYM(MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /DWNEW/KKDDW(MZOVL,MZOVL,2),KKEDW(MZOVL,MZOVL,2) X,KDPDW(MZNC1,MZNC1,MZOVL,MZOVL),KEPDW(MZNC1,MZNC1,MZOVL,MZOVL) X,KDPOS,KEPOS,TERMD(MXNC1,MZLR1),TERME(MXNC1,MZLR1) COMMON /MEDEFN/IHSH,NL(MXORB2,2),NOSH(MXORB2,2),J1QN2(MXORB3,3,2), A IJFUL(MXORB2) COMMON/NJLJ/ NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX C IF(ISAMEK.EQ.1)RETURN IF(ISAMEK.EQ.2)RETURN IF(ISIG.EQ.ISIGP)RETURN C C IF(IDWBUG.GT.1) THEN C WRITE(20,100)IRHO,ISIG,IRHOP,ISIGP C 100 FORMAT(3X,4I8) C WRITE(20,101)NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP C 101 FORMAT(5X,4(2I3,2X)) C ENDIF C IF(NSIG.LT.100)RETURN IF(NSIGP.LT.100)RETURN NORBL=IJFUL(IRHO) IF(NORBL.LE.KCOR) RETURN NORBR=IJFUL(IRHOP) IF(NORBR.LE.KCOR) RETURN IORBL=NORBL-KCOR IORBR=NORBR-KCOR C IF(MULTD.GT.0) THEN KDPOS=KDPOS+1 KDPDW(ICL,ICR,IORBL,IORBR)=KDPOS KKDDW(IORBL,IORBR,1)=KD1 KKDDW(IORBL,IORBR,2)=KD2 K=0 DO 10 JK1=KD1,KD2,2 K=K+1 TERMD(KDPOS,K)=AMULT(JK1) 10 CONTINUE ENDIF C IF(MULTE.GT.0) THEN KEPOS=KEPOS+1 KEPDW(ICL,ICR,IORBL,IORBR)=KEPOS KKEDW(IORBL,IORBR,1)=KE1 KKEDW(IORBL,IORBR,2)=KE2 K=0 DO 20 JK1=KE1,KE2,2 K=K+1 TERME(KEPOS,K)=BMULT(JK1) 20 CONTINUE ENDIF C RETURN END C*********************************************************************** SUBROUTINE DWOUT3 use basic2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C THIRD DISTORTED-WAVE ROUTINE - TWG & NRB C SUM LIKE COEFFICIENTS BEFORE WRITING MATRIX ELEMENTS AND C DROP ANY NOT REQUIRED C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNC1=MZNC1*MZNC1/10+2*MZNC1) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /DW/ISTL,ISTR,NCHNL,NCHNR,ICL,ICR,IE,IG,ISYM(MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /DWMETA/NTARG(MZCHF),IMETA(MZTAR),NMETAS COMMON /DWNEW/KKDDW(MZOVL,MZOVL,2),KKEDW(MZOVL,MZOVL,2) X,KDPDW(MZNC1,MZNC1,MZOVL,MZOVL),KEPDW(MZNC1,MZNC1,MZOVL,MZOVL) X,KDPOS,KEPOS,TERMD(MXNC1,MZLR1),TERME(MXNC1,MZLR1) COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) DIMENSION SUMD(MZLR1),SUME(MZLR1),KD(MZLR1),KE(MZLR1) C IF(KDPOS.GT.MXNC1)CALL RECOV2('DWOUT3','MXNC1 ',MXNC1,KDPOS) IF(KEPOS.GT.MXNC1)CALL RECOV2('DWOUT3','MXNC1 ',MXNC1,KEPOS) C C FOR FIXED LEFT (ISTL) AND FIXED RIGHT (ISTR) SYMMETRY GROUPS: C FOR FIXED LEFT (NCHNL) AND FIXED RIGHT (NCHNR) GROUP CHANNEL: C IONE=1 ITWO=2 C C LOOP OVER LEFT AND RIGHT TARGET SYMMETRIES C ISYML=ISYM(ISTL) ISYMR=ISYM(ISTR) DO 41 IL=1,ISYML NCHL=NCHNL+(IL-ISYML)*NCONAT(IE) DO 40 IR=1,ISYMR NCHR=NCHNR+(IR-ISYMR)*NCONAT(IG) IF(NCHL.LT.NCHR.AND.NCHNL.EQ.NCHNR) GO TO 40 C C DROP TRANSITIONS NOT INVOLVING A METASTABLE C NTL=NTARG(NCHL) NTR=NTARG(NCHR) IF(IMETA(NTL)+IMETA(NTR).EQ.0)GO TO 40 C C EXCLUDE ELASTIC TRANSITIONS C CELAS IF(NTL.EQ.NTR) GO TO 40 C C AVOID DOUBLE COUNTING IF PREVIOUS ELASTIC TEST SKIPPED C IF(NCHL.EQ.NCHR) GO TO 40 C C LOOP OVER ORBITAL PAIRS C DO 9 IORBL=1,MZOVL NORBL=IORBL+KCOR DO 11 IORBR=1,MZOVL NORBR=IORBR+KCOR C KD1=KKDDW(IORBL,IORBR,1) KD2=KKDDW(IORBL,IORBR,2) KE1=KKEDW(IORBL,IORBR,1) KE2=KKEDW(IORBL,IORBR,2) IF(KD1+KE1.EQ.0)GO TO 11 C LD=KD1-1 LE=KE1-1 DO 13 K=1,MZLR1 SUMD(K)=0.0D0 SUME(K)=0.0D0 KD(K)=LD KE(K)=LE LD=LD+2 LE=LE+2 13 CONTINUE C C LOOP OVER LEFT AND RIGHT CONFIGURATIONS WITH SAME SYMMETRY C DO 10 ICL=1,NTCON(IE) CMIXL=AIJ(IE+IL-1,ICL) DO 12 ICR=1,NTCON(IG) CMIXR=AIJ(IG+IR-1,ICR) C C LOOP OVER DIRECT MULTIPOLES C KDPOS=KDPDW(ICL,ICR,IORBL,IORBR) IF(KDPOS.GT.0)THEN K=0 DO 15 JK1=KD1,KD2,2 K=K+1 ATERM=CMIXL*CMIXR*TERMD(KDPOS,K) SUMD(K)=SUMD(K)+ATERM 15 CONTINUE ENDIF C C LOOP OVER EXCHANGE MULTIPOLES C KEPOS=KEPDW(ICL,ICR,IORBL,IORBR) IF(KEPOS.GT.0)THEN K=0 DO 20 JK1=KE1,KE2,2 K=K+1 BTERM=CMIXL*CMIXR*TERME(KEPOS,K) SUME(K)=SUME(K)+BTERM 20 CONTINUE ENDIF C 12 CONTINUE 10 CONTINUE C C WRITE MATRIX ELEMENTS C DO 14 K=1,MZLR1 SD=SUMD(K) IF(ABS(SD).GT.1.E-7)THEN WRITE(21)IONE,NCHL,NORBL,NCHR,NORBR,KD(K),SD IF(IDWBUG.NE.0)WRITE(20,102)IONE,NCHL,NORBL,NCHR,NORBR,KD(K),SD ENDIF C SE=SUME(K) IF(ABS(SE).GT.1.E-7)THEN WRITE(21)ITWO,NCHL,NORBL,NCHR,NORBR,KE(K),SE IF(IDWBUG.NE.0)WRITE(20,102)ITWO,NCHL,NORBL,NCHR,NORBR,KE(K),SE ENDIF 14 CONTINUE C 11 CONTINUE 9 CONTINUE C 40 CONTINUE 41 CONTINUE C 102 FORMAT(6I5,F12.8) RETURN END C C*********************************************************************** C SUBROUTINE FIN1BB(N1,N2,L1,ALBVAL) IMPLICIT REAL*8 (A-H,O-Z) C C C----------------------------------------------------------------------- C C FINDS A BOUND-BOUND ONE ELECTRON INTEGRAL C C N1,N2 ARE THE PRINCIPAL QUANTUUM NUMBERS C L1 IS THE ANGULAR MOMENTUM PLUS ONE C ALBVAL CONTAINS THE INTEGRAL ON RETURN C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) C COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /REL/JRELOP(3) COMMON /SYMTX/NSTO(200) C----------------------------------------------------------------------- I1 = IST1(L1) IF (N1.GE.N2) THEN I2 = I1 + NSTO(N1-L1+1) + N2 - L1 C ELSE I2 = I1 + NSTO(N2-L1+1) + N1 - L1 ENDIF C ALBVAL = ONEST1(I2) C C ADD IN THE RELATIVISTIC CORRECTIONS IF REQUIRED C IF (JRELOP(1).GT.0) ALBVAL = ALBVAL + RMASS1(I2) IF (JRELOP(2).GT.0 .AND. L1.EQ.1) ALBVAL = ALBVAL + RDAR1(I2) C END C C C SUBROUTINE FIN1BC(N1,N2,L1,ALBVAL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS A BOUND-CONTINUUM ONE ELECTRON INTEGRAL C C N1,N2 ARE THE PRINCIPAL QUANTUUM NUMBERS C L1 IS THE ANGULAR MOMENTUM PLUS ONE C ALBVAL CONTAINS THE INTEGRAL ON RETURN C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /REL/JRELOP(3) C----------------------------------------------------------------------- I1 = IST2(L1) I2 = I1 + (N1-L1)*NRANG2 + N2 - MAXNHF(L1) - 1 ALBVAL = ONEST2(I2) C C ADD IN THE RELATIVISTIC CORRECTIONS IF REQUIRED C IF (JRELOP(1).GT.0) ALBVAL = ALBVAL + RMASS2(I2) IF (JRELOP(2).GT.0 .AND. L1.EQ.1) ALBVAL = ALBVAL + RDAR2(I2) C END C C C SUBROUTINE FIN1CC(J,ILIMIT,L1,A) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS CONTINUUM-CONTINUUM ONE ELECTRON INTEGRALS C N1,N2 ARE THE PRINCIPAL QUANTUUM NUMBERS C L1 IS THE ANGULAR MOMENTUM PLUS ONE C A(ILIMIT) CONTAINS THE INTEGRALS ON RETURN C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /REL/JRELOP(3) COMMON /SYMTX/NSTO(200) C DIMENSION A(ILIMIT) C----------------------------------------------------------------------- IF (J.GT.0) THEN N2 = ND(2,J) A(J) = 0.D0 ENDIF C DO 10 I = 1,ILIMIT IF (I.EQ.J) GOTO 10 N1 = ND(1,I) IF (J.EQ.0) N2 = N1 IF (N1.LT.N2) THEN I1 = N2 - MAXNHF(L1) I2 = NSTO(I1) + N1 - MAXNHF(L1) C ELSE I1 = N1 - MAXNHF(L1) I2 = NSTO(I1) + N2 - MAXNHF(L1) ENDIF C A(I) = ONEST3(I2,L1) C C ADD IN THE RELATIVISTIC CORRECTIONS IF REQUIRED C IF (JRELOP(1).GT.0) A(I) = A(I) + RMASS3(I2,L1) IF (JRELOP(2).GT.0 .AND. L1.EQ.1) A(I) = A(I) + RDAR3(I2) 10 CONTINUE C END C C C SUBROUTINE FINBB(IDORIE,LAM) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS A BOUND-BOUND RK INTEGRAL FROM THE RKSTO1 ARRAY C AND STORES IN RKMAT(1,1). C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXRKBB=MX1BB*MXL1SQ*MXL1SQ*2) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO2/RKSTO1(MXRKBB),ONEST1(MX1BB),ONEST2(MX1BC), A ONEST3(MX1CC,MZLR2),RMASS1(MX1BB),RMASS2(MX1BC), B RMASS3(MX1CC,MZLR2),RDAR1(MX1BB),RDAR2(MX1BC),RDAR3(MX1CC) COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) COMMON /NJLJ/NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT C----------------------------------------------------------------------- C C THE BOUND-BOUND RK INTEGRAL CORRESPONDING TO THE FOLLOWING N L C VALUES IS FOUND C N1 = NQ1 N2 = NQ2 N3 = NQ3 N4 = NQ4 LRHO = LQ1 LSIG = LQ2 LRHOP = LQ3 LSIGP = LQ4 C C FIRST INTERCHANGE (N1,LRHO) AND (N2,LSIG) FOR EXCHANGE INTEGRAL C THEN PLACE N1,N2,N3,N4,LRHO,LSIG,LRHOP,LSIGP IN THE ORDER C REQUIRED BY SYMMETRY CONDITIONS, I.E. LSIG GE LRHO,LRHOP GE LRHO C LSIGP GE LSIG. WHEN LRHO=LSIG, N1 GE N2, WHEN LRHOP=LRHO, C N1 GE N3 AND WHEN LSIG = LSIGP, N2 GE N4 C IF (IDORIE.EQ.2) CALL INTECH(N1,LRHO,N2,LSIG,3) C C PUT THE SMALLEST ANGULAR MOMENTUM IN LRHO AND ENSURE THAT C LSIGP.GE.LSIG C I = 1 L = LRHO IF (L.GT.LSIG) THEN I = 2 L = LSIG ENDIF C IF (L.GT.LRHOP) THEN I = 3 L = LRHOP ENDIF C IF (L.GT.LSIGP) THEN I = 4 L = LSIGP ENDIF C IF (I.EQ.2) THEN CALL INTECH(N1,LRHO,N2,LSIG,3) CALL INTECH(N3,LRHOP,N4,LSIGP,3) C ELSE IF (I.EQ.3) THEN CALL INTECH(N1,LRHO,N3,LRHOP,3) C ELSE IF (I.EQ.4) THEN CALL INTECH(N1,LRHO,N4,LSIGP,3) CALL INTECH(N2,LSIG,N3,LRHOP,3) ENDIF C IF (LSIGP.LT.LSIG) CALL INTECH(N2,LSIG,N4,LSIGP,3) C C THE ANGULAR MOMENTUM CONDITIONS ARE SATISFIED.NOW ENSURE C THAT THE PRINCIPAL QUANTUM NUMBERS SATISFY THE REQUIRED C CONDITIONS C IF (LSIG.EQ.LSIGP .AND. N2.LT.N4) CALL INTECH(N2,LSIG,N4,LSIGP,1) IF (LRHO.EQ.LRHOP .AND. N1.LT.N3) CALL INTECH(N1,LRHO,N3,LRHOP,1) IF (LRHO.EQ.LSIG .AND. N1.LT.N2) THEN CALL INTECH(N1,LRHO,N2,LSIG,1) CALL INTECH(N3,LRHOP,N4,LSIGP,3) ENDIF C C NOW CALCULATE THE LOCATION OF THE BOUND INTEGRAL C LP = LRHOP*LRANG1 + LSIGP + 1 IRK4 = ICTBB(LRHO+1,LSIG+1,LP) - 1 10 CONTINUE IRK4 = IRK4 + 1 IF (ISTBB1(IRK4).NE.LAM) GOTO 10 IRK1 = ISTBB2(IRK4) - 1 N3M = MAXNHF(LRHOP+1) N4M = MAXNHF(LSIGP+1) IF (LSIG.NE.LRHO) N2M = MAXNHF(LSIG+1) C DO 40 NP1 = LRHO + 1,MAXNHF(LRHO+1) IF (LSIG.EQ.LRHO) N2M = NP1 IF (LRHOP.EQ.LRHO) N3M = NP1 IF (LSIGP.EQ.LSIG) THEN DO 30 NP2 = LSIG + 1,N2M N4M = NP2 IF (NP1.EQ.N1 .AND. NP2.EQ.N2) GOTO 60 IRK1 = IRK1 + (N3M-LRHOP)* (N4M-LSIGP) 30 CONTINUE C ELSE IF (NP1.EQ.N1) THEN IF (N2.GT.LSIG+1) IRK1 = IRK1 + A (N3M-LRHOP)* (N4M-LSIGP)* (N2-1- B LSIG) GOTO 60 C ELSE IRK1 = IRK1 + (N3M-LRHOP)* (N4M-LSIGP)* (N2M-LSIG) ENDIF C ENDIF C 40 CONTINUE C C IF THE INTEGRAL CANNOT BE FOUND PRINT OUT AN ERROR MESSAGE C WRITE (IWRITE,3000) LAM,N1,LRHO,N2,LSIG,N3,LRHOP,N4,LSIGP STOP C 60 CONTINUE IRK1 = IRK1 + (N3-LRHOP-1)* (N4M-LSIGP) + (N4-LSIGP) RKMAT(1,1) = RKSTO1(IRK1) C 3000 FORMAT (' THE BOUND-BOUND RK INTEGRAL CANNOT BE FOUND FOR LAM=', A I3/' N1,L1=',2I2,' N2,L2=',2I2,' N3,L3=',2I2,' N4,L4=', B 2I2) END SUBROUTINE FINBC(IDORIE,LAM) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C FINDS THE BOUND-CONTINUUM RK INTEGRALS FROM THE RKSTO2 ARRAY C AND STORES IN RKMAT(1,I),I=1,JLIMIT C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /NJLJ/NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /SYMTX/NSTO(200) C----------------------------------------------------------------------- N1 = NQ1 N2 = NQ2 N3 = NQ3 LRHO = LQ1 LSIG = LQ2 LRHOP = LQ3 LSIGP = LQ4 C C FIRST INTERCHANGE (N1,LRHO) AND (N2,LSIG) FOR EXCHANGE INTEGRAL C THEN PLACE N1,N3 AND LRHO,LRHOP IN THE ORDER REQUIRED BY C SYMMETRY CONDITIONS,I.E. LRHOP GE LRHO,WHEN LRHO= LRHOP,N1 GE N3 C IF (IDORIE.EQ.2) CALL INTECH(N1,LRHO,N2,LSIG,3) IF (LRHO.GT.LRHOP) CALL INTECH(N1,LRHO,N3,LRHOP,3) IF (LRHO.EQ.LRHOP .AND. N3.GT.N1) CALL INTECH(N1,LRHO,N3,LRHOP,1) C C NOW CALCULATE THE LOCATION OF THE BOUND-CONTINUUM INTEGRALS C LP = LRANG1*LSIGP + LRHOP + 1 I1 = ICTBC(LRHO+1,LSIG+1,LP) - 1 10 CONTINUE I1 = I1 + 1 IF (ISTBC1(I1).NE.LAM) GOTO 10 IF (LRHO.NE.LRHOP) THEN I2 = (N1-LRHO-1)* (MAXNHF(LSIG+1)-LSIG) + N2 - LSIG - 1 I3 = (I2* (MAXNHF(LRHOP+1)-LRHOP)+N3-LRHOP-1)*NRANG2 C ELSE I3 = (NSTO(N1-LRHO)* (MAXNHF(LSIG+1)-LSIG)+ A (N2-LSIG-1)* (N1-LRHO)+N3-LRHOP-1)*NRANG2 ENDIF C I4 = I3 + ISTBC2(I1) - 1 DO 20 I5 = 1,JLIMIT RKMAT(1,I5) = RKSTO2(I4+I5) 20 CONTINUE C END SUBROUTINE FINCC1(IDORIE,LAM,JUMP) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C FINDS THE CONTINUUM-CONTINUUM RK INTEGRALS FROM THE RKSTO2 ARRAY. C THIS CASE CORRESPONDS TO THE DIAGONAL ELEMENTS (KI=KJ) BUT THE C CONTINUUM L VALUES MAY BE DIFFERENT. WHEN THEY ARE THE SAME THE C CASE MAY JUST INVOLVE BOUND ORBITALS WHEN FINBB IS CALLED. THE C RESULT IS STORED IN RKMAT(I,I),I=1,ILIMIT C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C JUMP =1 IF ENTRY IS DIRECT C JUMP =2 IF ENTRY IS FROM FINCC2. IN THIS CASE JUMP IS SET ON C RETURN EQUAL TO THE LOCATION OF THE CONTINUUM-CONTINUUM C INTEGRALS IN THE RKSTO2 ARRAY C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /NJLJ/NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /SYMTX/NSTO(200) C----------------------------------------------------------------------- N1 = NQ1 N3 = NQ3 N4 = NQ4 LRHO = LQ1 LSIG = LQ2 LRHOP = LQ3 LSIGP = LQ4 C C CHECK N4 TO SEE IF A PROPER CONTINUUM-CONTINUUM CASE OR IF IT C CORRESPONDS TO A BOUND-BOUND INTEGRAL WHICH CAN ONLY OCCUR C WHEN THE CONTINUUM L VALUES ARE THE SAME C IF (N4.NE.999) THEN C C THIS CASE IS A BOUND-BOUND INTEGRAL SO CALL FINBB C CALL FINBB(IDORIE,LAM) IF (ILIMIT.EQ.1) RETURN DO 10 I5 = 2,ILIMIT RKMAT(I5,I5) = RKMAT(1,1) 10 CONTINUE RETURN C ENDIF C C THIS IS A PROPER CONTINUUM-CONTINUUM INTEGRAL C IF (IDORIE.EQ.1) THEN IF (LRHO.EQ.LRHOP) THEN IF (N3.GT.N1) CALL INTECH(N1,LRHO,N3,LRHOP,3) I1 = ICTCCD(LRHO+1,LRHOP+1,LAM+1) I2 = NSTO(N1-LRHO) + N3 - LRHOP - 1 GOTO 20 C ENDIF C IF (LRHO.GT.LRHOP) CALL INTECH(N1,LRHO,N3,LRHOP,3) I1 = ICTCCD(LRHO+1,LRHOP+1,LAM+1) C ELSE IF (LSIG.GT.LSIGP) CALL INTECH(N1,LRHO,N3,LRHOP,3) I1 = ICTCCE(LRHO+1,LRHOP+1,LAM+1) ENDIF C I2 = (N1-LRHO-1)* (MAXNHF(LRHOP+1)-LRHOP) + N3 - LRHOP - 1 20 CONTINUE IF (LSIG.EQ.LSIGP) THEN I2 = (I2*NRANG2* (NRANG2+1))/2 C ELSE I2 = I2*NRANG2*NRANG2 ENDIF C C RETURN TO SUBROUTINE FINCC2 WITH LOCATION OF CONTINUUM ORBITAL C IN JUMP C IF (JUMP.GE.2) THEN JUMP = I1 + I2 RETURN C ENDIF C I4 = I1 + I2 - 1 IF (LSIG.NE.LSIGP) THEN DO 30 I5 = 1,ILIMIT RKMAT(I5,I5) = RKSTO2(I4+I5) I4 = I4 + NRANG2 30 CONTINUE C ELSE DO 40 I5 = 1,ILIMIT RKMAT(I5,I5) = RKSTO2(I4+I5) I4 = I4 + I5 40 CONTINUE ENDIF C END SUBROUTINE FINCC2(IDORIE,LAM) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C FINDS THE CONTINUUM-CONTINUUM RK INTEGRALS FROM THE RKSTO2 ARRAY. C THIS CASE CORRESPONDS TO THE OFF-DIAGONAL ELEMENTS (KI NE KJ) C THE RESULT IS STORED IN RKMAT(I,J),I=1,ILIMIT,J=1,JLIMIT C WHERE I IS NOT EQUAL TO J. C C IDORIE=1 FOR DIRECT INTEGRALS, =2 FOR EXCHANGE INTEGRALS C LAM IS THE LAMBDA VALUE OF THE INTEGRAL C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /NJLJ/NQ1,LQ1,NQ2,LQ2,NQ3,LQ3,NQ4,LQ4 COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /SYMTX/NSTO(200) C----------------------------------------------------------------------- N1 = NQ1 N3 = NQ3 LRHO = LQ1 LSIG = LQ2 LRHOP = LQ3 LSIGP = LQ4 C C FIRST CALCULATE THE CASE WHEN THE CONTINUUM ORBITALS HAVE C DIFFERENT ANGULAR MOMENTA C C JUMP IS SET READY TO ENTER SUBROUTINE FINCC1 IF REQUIRED C JUMP = 2 IF (LSIG.NE.LSIGP) THEN C C THE CONTINUUM ANGULAR MOMENTA ARE DIFFERENT SO SUBROUTINE FINCC1 C CAN BE USED TO DETERMINE THE POSITION IN THE RKSTO2 ARRAY WHERE C THE CONTINUUM INTEGRALS ARE FOUND C CALL FINCC1(IDORIE,LAM,JUMP) I4 = JUMP - 1 DO 30 I5 = 1,ILIMIT IF (LSIG.LE.LSIGP) THEN DO 10 J5 = 1,JLIMIT RKMAT(J5,I5) = RKSTO2(I4+J5) 10 CONTINUE C ELSE DO 20 J5 = 1,JLIMIT RKMAT(I5,J5) = RKSTO2(I4+J5) 20 CONTINUE ENDIF C RKMAT(I5,I5) = 0.D0 I4 = I4 + NRANG2 30 CONTINUE RETURN C ENDIF C C THE CONTINUUM ORBITALS HAVE THE SAME ANGULAR MOMENTA. IN THIS C CASE ONLY THE LOWER TRIANGLE OF THE CONTINUUM ORBITALS FOR ANY C PAIR OF BOUND-STATE ORBITALS IS STORED SO TWO ENTRIES TO THE C RKMAT MATRIX MUST BE MADE C IF (IDORIE.EQ.2) THEN I1 = ICTCCE(LRHO+1,LRHOP+1,LAM+1) C ELSE IF (LRHO.EQ.LRHOP) THEN IF (N3.GT.N1) CALL INTECH(N1,LRHO,N3,LRHOP,1) I1 = ICTCCD(LRHO+1,LRHOP+1,LAM+1) I2 = (NSTO(N1-LRHO)+N3-LRHOP-1)* (NRANG2* (NRANG2+1))/2 GOTO 40 C ENDIF C IF (LRHO.GT.LRHOP) CALL INTECH(N1,LRHO,N3,LRHOP,3) I1 = ICTCCD(LRHO+1,LRHOP+1,LAM+1) ENDIF C I2 = ((N1-LRHO-1)* (MAXNHF(LRHOP+1)-LRHOP)+N3-LRHOP-1)* A (NRANG2* (NRANG2+1))/2 C 40 CONTINUE RKMAT(1,1) = 0.D0 IF (ILIMIT.LE.1) GOTO 100 DO 70 I5 = 2,ILIMIT RKMAT(I5,I5) = 0.D0 I51 = I5 - 1 I4 = I1 + I2 + NSTO(I5) - 1 DO 50 I6 = 1,I51 RKMAT(I5,I6) = RKSTO2(I4+I6) 50 CONTINUE IF (IDORIE.EQ.2) GOTO 70 DO 60 I6 = 1,I51 RKMAT(I6,I5) = RKMAT(I5,I6) 60 CONTINUE 70 CONTINUE IF (IDORIE.EQ.1) GOTO 100 I1 = ICTCCE(LRHOP+1,LRHO+1,LAM+1) I2 = ((N3-LRHOP-1)* (MAXNHF(LRHO+1)-LRHO)+N1-LRHO-1)* A (NRANG2* (NRANG2+1))/2 DO 90 I5 = 2,ILIMIT I55 = I5 - 1 I4 = I1 + I2 + NSTO(I5) - 1 DO 80 I6 = 1,I55 RKMAT(I6,I5) = RKSTO2(I4+I6) 80 CONTINUE 90 CONTINUE 100 CONTINUE C END SUBROUTINE FINMNT(N1,L1,N2,L2,K,X,Y) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C FINDS THE MULTIPOLE INTEGRALS IN THE RKSTO2 ARRAY C N.B. THE BOUND-BOUND INTEGRALS ARE IN THE BBINT ARRAY. C C N1,N2 ARE THE PRINCIPAL QUANTUM NUMBERS C L1,L2 ARE THE ANGULAR MOMENTA PLUS ONE C K IS THE MULTIPOLE ORDER C IF K.EQ.1 X CONTAINS THE DIPOLE LENGTH AND Y THE DIPOLE VELOCITY C INTEGRALS ON EXIT C IF K.GT.1 X CONTAINS THE KTH POLE LENGTH INTEGRAL ON EXIT C AND Y IS SET EQUAL TO ZERO C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXBBI=MXORB*MXORB/2*MZLMX+MXORB*MZLMX) PARAMETER (MXPOL= (MZLMX+1)/2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INSTO4/IBBPOL(MZLR1,MZLR1,MXPOL), 1 IBCPOL(MZLR1,MZLR2,MXPOL), A ICCPOL(MZLR2,MZLR2,MXPOL) COMMON /INSTO5/BBINT(MXBBI),IBBI C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /SYMTX/NSTO(200) C----------------------------------------------------------------------- C C TEST THAT THE TRIANGULAR RELATIONS ARE SATISFIED C X = 0.0D0 Y = 0.0D0 IF (K.LT.ABS(L1-L2) .OR. K.GT. (L1+L2-2) .OR. A MOD(L1+L2+K,2).NE.0) RETURN C LK = (K-ABS(L1-L2)+2)/2 IF (L1.EQ.L2) LK = K/2 I1 = 1 IF (K.EQ.1) I1 = 2 I2 = 1 IF (N1.LE.MAXNHF(L1)) I2 = I2 + 1 IF (N2.LE.MAXNHF(L2)) I2 = I2 + 1 C C DEFINE N3,L3,N4,L4 IN A STANDARD ORDER C IF (I2.EQ.2) GOTO 40 IF (L1.EQ.L2) GOTO 30 IF (L1.LT.L2) GOTO 20 10 CONTINUE N3 = N2 L3 = L2 N4 = N1 L4 = L1 GOTO 50 C 20 CONTINUE N3 = N1 L3 = L1 N4 = N2 L4 = L2 GOTO 50 C 30 CONTINUE IF (N1.GE.N2) GOTO 20 GOTO 10 C 40 CONTINUE IF (N1.LE.MAXNHF(L1)) GOTO 20 GOTO 10 C C FIND THE LOCATION IN RKSTO2 WHERE THE INTEGRALS ARE STORED C 50 CONTINUE IF (I2.EQ.3) GOTO 80 IF (I2.EQ.2) GOTO 60 C C THE CONTINUUM-CONTINUUM INTEGRALS C I3 = N3 - MAXNHF(L3) - 1 I4 = N4 - MAXNHF(L4) - 1 IF (L3.NE.L4) THEN M1 = ICCPOL(L3,L4,LK) + I1* (I3*NRANG2+I4) C ELSE M1 = ICCPOL(L3,L4,LK) + I1* (NSTO(I3+1)+I4) ENDIF C GOTO 70 C C THE BOUND-CONTINUUM INTEGRALS C 60 CONTINUE M1 = IBCPOL(L3,L4,LK) + I1* ((N3-L3)*NRANG2+N4-MAXNHF(L4)-1) C C PICK OUT THE INTEGRALS FROM RKSTO2 C 70 CONTINUE X = RKSTO2(M1) IF (K.EQ.1) THEN Y = RKSTO2(M1+1) IF (L1.GT.L2) Y = -Y ENDIF C RETURN C C THE BOUND-BOUND INTEGRALS C 80 CONTINUE I3 = N3 - L3 I4 = N4 - L4 IF (L3.NE.L4) THEN M1 = IBBPOL(L3,L4,LK) + I1* (I3* (MAXNHF(L4)-L4+1)+I4) C ELSE M1 = IBBPOL(L3,L4,LK) + I1* (NSTO(I3+1)+I4) ENDIF C C PICK OUT THE INTEGRALS FROM RKSTO2 C X = BBINT(M1) IF (K.EQ.1) THEN Y = BBINT(M1+1) IF (L1.GT.L2) Y = -Y ENDIF C END INTEGER FUNCTION ICONWC(ICUT,IELC,IPTY,ITOTL,ITOTS) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C c Keith Berrington, July 25, 2004. c c Plug-in to program STG2R (see also STG3R) to remove weakly coupled c N+1 electron configurations as they are generated in the 'CONFIG' package, c so that they do not need to be provided for in the array dimensioning. c The method provides an approximate correction for the retained diagional c elements. c c The criterion for removing an N+1 configuration is the smallness (alimit) of: c (1) the bound-continuum Hamiltonian matrix elements, c ie. weak coupling to all target channels; c (2) the bound-bound Hamiltonian matrix elements with the lowest c (as specified by abs(NCUT)) N+1 configurations, c ie. weak coupling to negative ion states. c The method used is based on infinitesimal Jacobi rotations giving c diagonal element corrections, which are transfered from STG2 to STG3 c in a formatted file fort.31 c c Returns iconwc=0 to reject this configuration, =1 to keep c Input: c ICUT < 0 to test for weak coupling: c abs(ICUT) = first N+1 configuration in list to start testing c (ie. if ICUT=-1 all configs are tested for weak coupling; c if ICUT=-2 the first config is assumed NOT weakly coupled) c IELC = number of electrons in configurations (ie. N+1) c IPTY,ITOTL,ITOTS = parity, L, 2S+1 of configurations c c alimit = maximum magnitude of matrix element to reject, c this may be case dependent and is set below. c C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXN21=MZNR2+1) PARAMETER (mxdiag=MZNR2*MZCHF+MZNC2) c COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHF,MZCHF,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) c common/cconwc/hcorr(mxdiag),hdiag(mxdiag),iidiag C dimension hnp(MZNR2),hdif(MZNR2),htest(MZNR2),hsq(MXDIAG) dimension kbasic(MXORB2),nsh(MZNC2) c c alimit = maximum magnitude of matrix element to reject c small = smallest target CI coefficient considered in bound-continuum test c Set thresh (in Ryd units) to skip higher target states c (set thresh very large to avoid this) data alimit/1.0d-6/, small/1.0d-2/, keeep/0/ c boron special... data thresh/0.68d0/, zero/0.0d0/ save keep,keeep,alimit,small,kbasic,jbound,thresh,nsh iconwc = 1 if( IELC.eq.NELC )return c------------------- c Initialization for new symmetry if( keeep.eq.0.or. *(ITOTL.ne.LRGL.or.ITOTS.ne.NSPN.or.IPTY.ne.NPTY ))then NPTY = IPTY LRGL = ITOTL NSPN = ITOTS keeep = 0 keep = 0 jbound= abs(ICUT) write(IWRITE,*) x 'weakly coupled configs cut at ',alimit,jbound,thresh C EVALUATE AND WRITE OUT THE COUPLED CHANNELS CALL SETCUP c Calculate the diagonal continuum-continuum matrix elements, hdiag call conwc1(NRANG2,NAST,ENAT,NCONAT,L2P) do k = 1, MXDIAG hcorr(k) = zero enddo C READ IN THE BOUND-CONTINUUM INTEGRALS FROM FILE JDISC1 CALL RDINT(1,0,0) endif c------------------- c Calculate the diagonal bound-bound Hamiltonian matrix element, aqq J = NCFGP aqq = conwc3(J,J) c Set nsh=0 if N+1 config is to be tested against, c otherwise nsh=number of electrons different from all electrons in the lowest shells nsh(NCFGP) = IELC if( NCFGP.lt.jbound .and. jbound.lt.1000 )then nsh(NCFGP) = 0 else kk = 1 kkk = 0 nsh(NCFGP) = IELC do k = 1, MAXORB ktest = min(4*LJCOMP(k)+2,IELC-kkk) kkk = kkk + ktest if( k.eq.IOCORB(kk,NCFGP) )then ktest = ktest - IELCSH(kk,NCFGP) nsh(NCFGP) = nsh(NCFGP) - IELCSH(kk,NCFGP) kk = kk + 1 endif if( kkk.ge.IELC )goto 311 nsh(NCFGP) = nsh(NCFGP) + ktest enddo 311 continue c print*,aqq,NCFGP,nsh(NCFGP),' new diag' cc Special cases, jbound=1001 or 1002 for 1 or 2 electron difference if( jbound.eq.1001.and.nsh(NCFGP).le.1 )nsh(NCFGP)=0 if( jbound.eq.1002.and.nsh(NCFGP).le.2 )nsh(NCFGP)=0 endif c Accept config unconditionally if nsh=0 or if minimal electron difference if( nsh(NCFGP).le.1 )goto 399 c Calculate bound-continuum elements for test do k = 1, iidiag+keep hsq(k) = zero enddo NS1 = 1 iconwc = 0 jdiag = 0 NCF = 0 DO 370 NS1 = 1,NAST IF (NCONAT(NS1).LE.0) GOTO 370 NTC = NTCON(NS1) NCS = NCF + 1 NCF = NCF + NCONAT(NS1) c Skip if target state is too high (set thresh very large to avoid this) c print*,NS1,LAT(NS1),ISAT(NS1),LPTY(NS1),(ENAT(NS1)-ENAT(1))*2. if(ENAT(NS1)-ENAT(1).gt.0.5*thresh)goto 370 DO 360 NCH1 = NCS,NCF LOT1 = L2P(NCH1) + 1 DO I6 = 1,NRANG2 hnp(I6) = zero ip = jdiag + I6 hdif(I6) = aqq - hdiag(ip) htest(I6) = alimit*abs(hdiag(ip)*hdif(I6)) ENDDO DO 310 IC1 = 1,NTC IF (abs(AIJ(NS1,IC1)).le.small) GOTO 310 I = NTYP(NS1,IC1) J = NCFGP c Calculate bound(J)-continuum(I) matrix element call conwc2(I,J,NCH1) C C MATRIX ELEMENTS IN AME(1,NRANG2) NOW STORED IN HNP MATRIX C DO I6 = 1,NRANG2 HNP(I6) = HNP(I6) + AME(1,I6)*AIJ(NS1,IC1) ip = jdiag + I6 hsq(ip) = hnp(I6)*hnp(I6) c if(hsq(ip).gt.htest(I6))print*,'state=',NS1,NCH1 c * ,hsq(jdiag+1),hsq(jdiag+nrang2),hdif(1),hdif(nrang2) if(hsq(ip).gt.htest(I6))goto 399 ENDDO 310 CONTINUE DO I6 = 1, NRANG2 hsq(jdiag+I6) = hsq(jdiag+I6)/hdif(I6) ENDDO c print*,'state=',NS1,NCH1,hsq(jdiag+1),hsq(jdiag+nrang2) c *,hdif(1),hdif(nrang2) jdiag = jdiag + NRANG2 360 CONTINUE 370 CONTINUE c print*,'bound-bound ',keep,NCFGP,aqq c bound-bound option kkk = ((NCFGP-1)*(NCFGP-2))/2 do I = 1, keep if(nsh(I).le.0)then J = NCFGP apq = conwc3(I,J) ip = iidiag + I htemp = apq/(aqq-hdiag(ip)) hsq(ip) = apq*htemp c print*,i,ip,j,apq,' -bb ',hsq(ip),hdiag(ip) c off-diagonal correction not used c dimension aiq(MXNC2),aip(90) c if(I.gt.1.and.I.lt.10)then c kk = ((I-1)*(I-2))/2 c do ii = 1, I-1 c if( abs(aiq(ii)*htemp).gt.alimit*abs(aip(kk+ii)) )goto 399 c enddo c aiq(I) = apq c if(J.lt.10) aip(kkk+I) = apq c endif if( abs(hsq(ip)).gt.alimit*abs(hdiag(ip)) )goto 399 endif enddo c------------------- c Chop this configuration. Retain info for correcting later. do i = 1, iidiag + keep hcorr(i) = hcorr(i) + hsq(i) enddo c print*,'z',keep,NCFGP,keeep,hcorr(1),hcorr(iidiag+1) c *,hsq(iidiag+1),hdiag(iidiag+1) goto 400 c------------------- c We want to keep the configuration, so set iconwc=1 399 iconwc = 1 keep = keep + 1 J = NCFGP c Store the diagonal matrix element hdiag(iidiag+keep) = aqq c write out in the form of a unique base configuration in STG2 input format if(keep.eq.1)write(iwrite,*)'configurations kept, count,orig:' do i8 = 1, IOCCSH(J) k8 = IOCORB(i8,J) if( keep.eq.1. or. kbasic(k8).ne.IELCSH(i8,J) )then do k8 = 1, MAXORB kbasic(k8) = 0 enddo do i9 = 1, IOCCSH(J) k8 = IOCORB(i9,J) kbasic(k8) = IELCSH(i9,J) enddo write(iwrite,*)(kbasic(k8),k8=1,MAXORB) x ,' ',nsh(NCFGP),keep,keeep+1 goto 400 endif enddo c print*,IOCCSH(j) c print*,(IOCORB(I8,j),I8 =1,IOCCSH(j)) c print*,(IELCSH(I8,j),I8 =1,IOCCSH(j)) c print*,((I1QNRD(I8,kkk,j),kkk=1,3),I8=1,2*IOCCSH(j)-1) 400 keeep = keeep+1 return end C C C SUBROUTINE INTECH(N1,L1,N2,L2,I) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C INTERCHANGE TWO SETS OF NUMBERS (N1,L1) AND (N2,L2) C C I=1 INTERCHANGE N1 AND N2 ONLY C I=2 INTERCHANGE L1 AND L2 ONLY C I=3 INTERCHANGE BOTH N1,N2 AND L1,L2 C C----------------------------------------------------------------------- IF (I.EQ.1) THEN N = N1 N1 = N2 N2 = N C ELSE IF (I.EQ.2) THEN L = L1 L1 = L2 L2 = L C ELSE IF (I.EQ.3) THEN N = N1 L = L1 N1 = N2 L1 = L2 N2 = N L2 = L ENDIF C END C C C SUBROUTINE ISTG2(LRANG1,LRANG2,LAMAX,NRANG2) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C DEFINE FACTORIAL ARRAYS IN /FACT/ AND /FACTS/; C KRONECKER DELTA FUNCTION IN /KRON/; C /SYMTX/ ARRAY TO STORE SYMMETRIC MATRIX AS A SINGLE ARRAY; C COEFFICIENTS (L//C(K)//LP) FOR ALL L,LP,K IN /CSTORE/ C WITH POINTERS IN KPOINT. C ALSO CHECK STGLIB DIMENSIONS IN /BPSIZE/ C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXCTAB=MZLR2*MZLR2/2*MZLR2/2+MZLR2*MZLR2/2+MZLR2) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C COMMON /BPSIZE/MXLR1,MXLR2,MXNC2,MXNR1,MXOCC COMMON /CSTORE/CTABLE(MXCTAB),KPOINT(MZLR2,MZLR2),LRANG3 COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /KRON/IDEL(MXORB2,MXORB2) COMMON /SYMTX/NSTO(200) C----------------------------------------------------------------------- C C CHECK STGLIB DIMENSIONS C IF (MXLR1.NE.MZLR1 .OR. MXLR2.NE.MZLR2 .OR. MXNC2.NE.MZNC2 .OR. A MXNR1.NE.MZNR1 .OR. MXOCC.NE.MZOCC) THEN WRITE (IWRITE,*) ' DIMENSIONS IN STGLIB NOT COMPATIBLE:',' &', A 'LR1,LR2,NC2,NR1,OCC = ',MZLR1,MZLR2,MZNC2,MZNR1,MZOCC STOP ENDIF C C CALCULATE FACTORIALS IN /FACT/, CHECKING DIMENSIONS C CALCULATE LOG FACTORIALS IN /FACTT/ C LTEST=LRANG2 IF(IDWOUT.EQ.2)LTEST=LRNGDW LRANG3 = MAX(LRANG1,LTEST) L = LRANG3 - 1 NFACT = L + L + MAX(L+L,LAMAX) + 2 C IF (NFACT.GT.MZFAC) CALL RECOV2('ISTG2 ',' MZFAC',MZFAC,NFACT) NFACT=MIN(NFACT,MZFAC) CALL SHRIEK(NFACT) CALL FACTT C C DELTA FUNCTION C DO 20 I = 1,MXORB2 DO 10 J = 1,MXORB2 IDEL(J,I) = 0 10 CONTINUE IDEL(I,I) = 1 20 CONTINUE C C SET UP ARRAY TO STORE SYMMETRIC MATRIX AS A LINEAR ARRAY C SET=200, SHOULD REALLY CODE FOR MAX(NRANG2,MAXNHF) - NRB 19/12/96 C J = 0 DO 30 I = 1,200 NSTO(I) = J J = J + I 30 CONTINUE C C COEFFICIENTS (L//C(K)//LP) C LPOINT = 0 DO 60 L1P = 1,LRANG3 L1 = L1P - 1 DO 50 L2Q = L1P,LRANG3 L2 = L2Q - 1 KD1 = ABS(L1-L2) + 1 KD2 = L1 + L2 + 1 KLIM = (KD2-KD1)/2 + 1 IF (LPOINT+KLIM.GT.MXCTAB .OR. LRANG3.GT.MZLR2) THEN LPOINT = LPOINT + KLIM GOTO 50 C ENDIF C KPOINT(L1+1,L2+1) = LPOINT KPOINT(L2+1,L1+1) = LPOINT IF (L2.EQ.0) THEN LPOINT = LPOINT + 1 CTABLE(LPOINT) = 1 GOTO 50 C ENDIF C DO 40 JK1 = KD1,KD2,2 LPOINT = LPOINT + 1 K = JK1 - 1 CTABLE(LPOINT) = RME(L1,L2,K) 40 CONTINUE 50 CONTINUE 60 CONTINUE IF (LPOINT.GT.MXCTAB) CALL RECOV2('ISTG2 ','MXCTAB',MXCTAB,LPOINT) C END C C C SUBROUTINE MATANS(IMATX) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C SETS UP THE CALL TO MATRX FOR THE BOUND-BOUND C (IMATX=1), BOUND-CONTINUUM (IMATX=2), AND CONTINUUM-CONTINUUM C DIAGONAL AND OFF-DIAGONAL (IMAIX=3) MATRIX ELEMENTS. C DIAGONAL AND OFF-DIAGONAL (IMATX=3) MATRIX ELEMENTS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT C----------------------------------------------------------------------- C C BOUND-BOUND C IF (IMATX.EQ.1) THEN ISAMEK = 1 ILIMIT = 1 JLIMIT = 1 CALL MATRX C C BOUND-CONTINUUM C ELSE IF (IMATX.EQ.2) THEN ISAMEK = 2 ILIMIT = 1 JLIMIT = NDCT(2) CALL MATRX C C CONTINUUM-CONTINUUM. OFF DIAGONAL I.E. KI.NE.KJ C ELSE IF (IMATX.EQ.3) THEN ILIMIT = NDCT(1) JLIMIT = NDCT(2) IF (LJ(IHSH).EQ.LJ(IHSH-1)) GOTO 10 C C CONTINUUM-CONTINUUM. DIAGONAL I.E. KI= KJ IF L.NE.LP (I.E.LJ(IHSH C -1).NE.LJ(IHSH)). CALL MATRX AGAIN WITH SAME COUPLING SCHEMES C ISAMEK = 0 CALL MATRX ENDIF C RETURN C C CONTINUUM-CONTINUUM. DIAGONAL I.E. KI=KJ BUT NOW L=LP. HENCE C CONTRACTION OF COUPLING SCHEMES SINCE THE TWO CONTINUUM ORBITALS C ARE IDENTICAL C 10 CONTINUE ISAMEK = 4 CALL MATRX ISAMEK = 3 ILIMIT = MIN(NDCT(1),NDCT(2)) JLIMIT = ILIMIT I10 = IHSH IHSH = IHSH - 1 I11 = 2*IHSH - 2 I12 = I11 + 1 NOSH2(IHSH) = 1 J1QN2(IHSH,1) = 1 J1QN2(IHSH,2) = 2*LJ(IHSH) + 1 J1QN2(IHSH,3) = 2 IF (I11.LT.I10) I11 = I10 DO 30 J = I10,I11 J1 = J + 1 DO 20 K = 1,3 J1QN1(J,K) = J1QN1(J1,K) J1QN2(J,K) = J1QN2(J1,K) 20 CONTINUE 30 CONTINUE C J1QN1(I12,1) = 0 J1QN1(I12,2) = 2*LRGL + 1 J1QN1(I12,3) = NSPN J1QN2(I12,1) = 0 J1QN2(I12,2) = 2*LRGL + 1 J1QN2(I12,3) = NSPN C C NOW CALL MATRX WITH CONTRACTED COUPLING SCHEMES C CALL MATRX C END C C C SUBROUTINE MATRX IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALLS THE ROUTINES H0WTS AND RKWTS FOR EACH TYPE OF R-MATRIX C ELEMENT I.E. BOUND-BOUND, BOUND-CONTINUUM AND CONTINUUM-CONTINUUM C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /CONMX/H0MAT(MZNR2,MZNR2),VMAT(MZNR2,MZNR2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DIAGNL/IDIAG,JA,JB COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT C----------------------------------------------------------------------- C C INITIALISE H0MAT AND VMAT - THE ARRAYS WHICH HOLD THE ONE - C ELECTRON AND TWO-ELECTRON CONTRIBUTIONS TO THE MATRIX ELEMENTS C DO 20 J = 1,JLIMIT DO 10 I = 1,ILIMIT VMAT(I,J) = 0.0D0 H0MAT(I,J) = 0.0D0 RKMAT(I,J) = 0.0D0 10 CONTINUE 20 CONTINUE C C TEST FOR SIMPLE POSSIBILITIES OF ZERO MATRIX ELEMENT C CALL ORTHOG(LET) IF (LET.EQ.0) GOTO 150 C C TEST TO SEE IF THE CONFIGURATIONS OF THE (N+1)-ELECTRONS ARE C IDENTICAL I.E. THE SAME NUMBER OF ELECTRONS IN EACH SHELL AND C THE SAME COUPLING SCHEMES C N1 = IHSH + IHSH - 1 DO 30 I = 1,IHSH IF (NOSH1(I).NE.NOSH2(I)) GOTO 40 30 CONTINUE GOTO 50 C 40 CONTINUE IDIAG = 0 GOTO 80 C 50 CONTINUE DO 70 J = 1,N1 DO 60 K = 1,3 IF (J1QN1(J,K).NE.J1QN2(J,K)) GOTO 40 60 CONTINUE 70 CONTINUE IDIAG = 1 C C EVALUATE THE TWO-ELECTRON CONTRIBUTIONS TO THE MATRIX ELEMENTS C 80 CONTINUE CALL CHOP CALL RKWTS C C EVALUATE THE ONE-ELECTRON CONTRIBUTIONS TO THE MATRIX ELEMENTS C IF (IDIAG.NE.0) THEN CALL DH0 C ELSE CALL H0WTS(ISIG,ISIGP,Y,ICAL) CALL ODH0(ISIG,ISIGP,Y,ICAL) ENDIF C C FILL THE AME ARRAY WHICH HOLDS THE HAMILTONIAN MATRIX ELEMENTS C FOR TWO N-ELECTRON CONFIGURATIONS C IF (ISAMEK.EQ.4) GOTO 120 IF (ISAMEK.LE.2) THEN DO 100 J = 1,JLIMIT DO 90 I = 1,ILIMIT AME(I,J) = H0MAT(I,J) + VMAT(I,J) 90 CONTINUE 100 CONTINUE C ELSE DO 110 I = 1,ILIMIT AME(I,I) = H0MAT(I,I) + VMAT(I,I) 110 CONTINUE ENDIF C GOTO 180 C 120 CONTINUE DO 140 J = 1,JLIMIT DO 130 I = 1,ILIMIT C IF(I.EQ.J) GOTO 154 (THE DIAGONAL WILL BE REDEFINED NEXT CALL) AME(I,J) = H0MAT(I,J) + VMAT(I,J) 130 CONTINUE AME(J,J) = 0.0D0 140 CONTINUE GOTO 180 C C AME IS ZEROISED BECAUSE OF SIMPLE ORTHOGONALITY C 150 CONTINUE DO 170 J = 1,JLIMIT DO 160 I = 1,ILIMIT AME(I,J) = 0.0D0 160 CONTINUE 170 CONTINUE 180 CONTINUE IF (IBUG9.LT.4) RETURN WRITE (IWRITE,3000) DO 190 I = 1,ILIMIT WRITE (IWRITE,3010) (AME(I,J),J=1,JLIMIT) 190 CONTINUE C 3000 FORMAT (//' AME FROM MATRIX') 3010 FORMAT (10F12.6) END SUBROUTINE NICCHAN IMPLICIT REAL*8 (A-H,O-Z) C C----------------------------------------------------------------------- C AN INDICATION OF THE NUMBER OF INTERMEDIATE COUPLING CHANNELS C REQUIRED IF DOING A LARGE SCALE CORE EXCITED (OR OTHERWISE) RUN C TO BE ACTIVATED THROUGH THE NAMELIST OPTION NOICC C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJTAR=4*MZTAR) PARAMETER (MXJP=MZSLP+10) PARAMETER (MXJP2=MXJP/2) C C COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),IPTY(MZTAR),NAST COMMON /NRBSLP/ISLP(MZSLP),IAUTO,IELC,MINST,MAXST,MINLT,MAXLT, B NOICC C DIMENSION JJ(MXJTAR),JPTY(MXJTAR),J2(MXJP),JP(MXJP) DIMENSION L2JET(MXJP2),L2JOT(MXJP2) DIMENSION L2JECT(MXJP2),L2JOCT(MXJP2) DIMENSION TLSPSZ(MZSLP),LSP(MZSLP,3),LCHAN(MZSLP),NCONF(MZSLP) C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc c **** parallel **** C IF(NOICC.EQ.0)RETURN REWIND (841) C C MAX2J=INT(2.0*(MAXLT+((MAXST-1.0)/2.0))) MIN2J=INT(ABS(2.0*(MINLT-((MINST-1.0)/2.0)))) C C C THE NEXT FEW LINES SETS UP THE ARRAYS J2 AND JP C FOR USE OF THE SUBROUTINE NJCHAN (MODIFIED VERSION) C LATER ON C K=0 II=0 DO I=MIN2J,MAX2J,2 K=K+1 II=II+1 IF(K.LE.MXJP)THEN J2(K)=I JP(K)=0 L2JET(II)=0 L2JOT(II)=0 L2JECT(II)=0 L2JOCT(II)=0 ENDIF K=K+1 IF(K.LE.MXJP)THEN J2(K)=I JP(K)=1 ENDIF END DO C IF(K.GT.MXJP)THEN K=K-10 WRITE(6,*)'NOICC OPTION REQUIRES MZSLP AT LEAST: ',K STOP 'INCREASE MZSLP' ENDIF C C if (iam.eq.0) OPEN (UNIT=726,FILE='ICCOUT',FORM='FORMATTED') C C C CALCULATE THE NUMBER OF N+1 LS SYMMETRIES THAT HAVE TO BE READ C NOSLPS=INT((MAXLT-MINLT+1)*(((MAXST-MINST)/2.0)+1.0)*2.0) C C DO I=1,NOSLPS READ (841)(LSP(I,J),J=1,3),LCHAN(I),NCONF(I) END DO C C WRITE(726,*)'**************************************************' WRITE(726,*)' ' WRITE(726,*)'TOTAL NOS. OF LS TERMS =',NAST WRITE(726,*)' ' C C GIVEN A LIST OF ALL THE LS N ELECTRON TERMS THE FOLLOWING C SUBROUTINE GENERATE THE 2J STATES GIVING C C JNAST,JJ,JPTY C CALL NOJTS(JNAST,JJ,JPTY) C WRITE(726,*)'TOTAL NOS. OF IC LEVELS =',JNAST WRITE(726,*)' ' WRITE(726,*)'MZCHF =',MZCHF,' MZCHL=',MZCHL,' MZNC2=',MZNC2 WRITE(726,*)' ' WRITE(726,*)'**************************************************' C WRITE(726,*)'**************************************************' WRITE(726,*)' ' WRITE(726,300)MIN2J,MAX2J WRITE(726,*)' ' WRITE(726,*)'**************************************************' WRITE(726,*)' ' C DO I=1,NOSLPS TLSPSZ(I)=(DBLE(LSP(I,2))-1.0D0)/2.0D0 END DO C C M=0 II=0 C DO I=MIN2J,MAX2J,2 II=II+1 TL=DBLE(I)/2.0D0 WRITE(726,*)' FOR 2J VALUE = ',I WRITE(726,*)' ' DO J=1,NOSLPS IF (LSP(J,3).EQ.0) THEN A=ABS(DBLE(LSP(J,1))-TLSPSZ(J)) B=ABS(DBLE(LSP(J,1))+TLSPSZ(J)) IF((INT(2.0D0*TL).GE.INT(2.0D0*A)).AND. 1 (INT(2.0D0*TL).LE.INT(2.0D0*B))) THEN L2JET(II)=L2JET(II)+LCHAN(J) L2JECT(II)=L2JECT(II)+NCONF(J) WRITE(726,302)LSP(J,1),LSP(J,2),LSP(J,3),LCHAN(J) 1 ,NCONF(J) ENDIF ENDIF IF (LSP(J,3).EQ.1) THEN A=ABS(DBLE(LSP(J,1))-TLSPSZ(J)) B=ABS(DBLE(LSP(J,1))+TLSPSZ(J)) IF((INT(2.0D0*TL).GE.INT(2.0D0*A)).AND. 1 (INT(2.0D0*TL).LE.INT(2.0D0*B))) THEN L2JOT(II)=L2JOT(II)+LCHAN(J) L2JOCT(II)=L2JOCT(II)+NCONF(J) WRITE(726,302)LSP(J,1),LSP(J,2),LSP(J,3),LCHAN(J) 1 ,NCONF(J) ENDIF ENDIF ENDDO C C M=M+1 C C C CALL NJCHAN(M,J2,JP,JNAST,JJ,JPTY,NJCHA) C NJCHAE=NJCHA C WRITE(726,*)' ' WRITE(726,*)'CHECK : NJCHAN EVEN',NJCHAE WRITE(726,*)' ' C C C M=M+1 C CALL NJCHAN(M,J2,JP,JNAST,JJ,JPTY,NJCHA) C NJCHAO=NJCHA C WRITE(726,*)' ' WRITE(726,*)'CHECK : NJCHAN ODD',NJCHAO WRITE(726,*)' ' C C C C C C WRITE(726,*)' ' WRITE(726,*)'**************************************************' WRITE(726,*)' ' WRITE(726,*)' ' WRITE(726,*)'TOTAL NO. LS CHANNELS: 2J=',I,' EVEN = ',L2JET(II) WRITE(726,*)'TOTAL NO. LS CHANNELS: 2J=',I,' ODD = ',L2JOT(II) WRITE(726,*)' ' WRITE(726,*)' ' WRITE(726,*)'TOTAL NO. OF N+1 CONFIGS: 2J=',I,' EVEN =',L2JECT(II) WRITE(726,*)'TOTAL NO. OF N+1 CONFIGS: 2J=',I,' ODD =',L2JOCT(II) WRITE(726,*)' ' WRITE(726,*)'**************************************************' IF((NJCHAO.NE.L2JOT(II)).OR.(NJCHAE.NE.L2JET(II))) THEN WRITE(726,*)' ' WRITE(726,*)' ' WRITE(726,*)'WARNING NJCHAN INDICATES THAT LS (N+1) SYMMETRIES ' WRITE(726,*)'ARE MISSING FOR THIS 2J ' WRITE(726,*)' ' WRITE(726,*)'**************************************************' END IF C C ENDDO C C WRITE(726,*)' ' WRITE(726,*)'**************************************************' WRITE(726,*)' ' WRITE(726,309)'OVERVIEW OF EACH IC SYMMETRY AND VERDICT' WRITE(726,*)' ' WRITE(726,*)'**************************************************' C C II=0 DO I=MIN2J,MAX2J,2 II=II+1 IF(L2JET(II).GT.MZCHF) THEN WRITE(726,*)' ' WRITE(726,*)'EVEN SYMMETRY FOR 2J=',I,' HAS PROBLEMS' WRITE(726,*)' ' WRITE(726,*)'TOTAL NO. COUPLING CHANNELS MUST > ',L2JET(II) WRITE(726,*)' ' WRITE(726,*)'INCREASE MZCHF APPROPRIATELY' WRITE(726,*)' ' ELSE WRITE(726,*)'EVEN SYMMETRY FOR 2J=',I,' IS FINE ' END IF IF(L2JOT(II).GT.MZCHF) THEN WRITE(726,*)' ' WRITE(726,*)' ODD SYMMETRY FOR 2J=',I,' HAS PROBLEMS' WRITE(726,*)' ' WRITE(726,*)'TOTAL LS COUPLING CHANNELS MUST > ',L2JOT(II) WRITE(726,*)' ' WRITE(726,*)'INCREASE MZCHF AND MZCHD APPROPRIATELY' WRITE(726,*)' ' ELSE WRITE(726,*)' ODD SYMMETRY FOR 2J=',I,' IS FINE ' END IF ENDDO C C C C II=0 DO I=MIN2J,MAX2J,2 II=II+1 IF(L2JECT(II).GT.MZNC2) THEN WRITE(726,*)' ' WRITE(726,*)'EVEN SYMMETRY CONFIGS FOR 2J=',I,' TOO SMALL' WRITE(726,*)' ' WRITE(726,*)'TOTAL NO. OF N+1 CONFIGS =',L2JECT(II) WRITE(726,*)' ' WRITE(726,*)'CURRENT LIMIT SET AT ',MZNC2 WRITE(726,*)' ' WRITE(726,*)'SET MZCN2 APPROPRIATELY ' WRITE(726,*)' ' ELSE WRITE(726,*)'NO. OF EVEN SYMMETRY CONFIGS FOR 2J=',I,' IS FINE' END IF IF(L2JOCT(II).GT.MZNC2) THEN WRITE(726,*)' ' WRITE(726,*)' ODD SYMMETRY CONFIGS FOR 2J=',I,' TOO SMALL' WRITE(726,*)' ' WRITE(726,*)'TOTAL NOS. OF N+1 CONFIGS =',L2JOCT(II) WRITE(726,*)' ' WRITE(726,*)'CURRENT LIMIT SET AT ',MZNC2 WRITE(726,*)' ' WRITE(726,*)'SET MZCN2 APPROPRIATELY ' WRITE(726,*)' ' ELSE WRITE(726,*)'NO. OF ODD SYMMETRY CONFIGS FOR 2J=',I,' IS FINE' END IF ENDDO C C 300 FORMAT(10X,"FROM MIN 2J =",I3," TO MAX 2J=",I3) 302 FORMAT(10X,"LVAL= ",I3," SPN= ",I3," PARITY=",I3," NCHAN=",I4 A," NCONF=",I4) 309 FORMAT(5X,A42) CLOSE(726) END SUBROUTINE NJCHAN(M,J2,JP,JNAST,JJ,JPTY,NJCHA) IMPLICIT REAL*8 (A-H,O-Z) C C----------------------------------------------------------------------- C C DETERMINES THE NUMBER AND DEFINITION OF THE CHANNELS IN THE C PAIR COUPLING SCHEME FOR THE SYMMETRY UNDER CONSIDERATION C C WHERE, J(TARGET)+L(INCIDENT)=K C K +S(INCIDENT)=J(SYSTEM) C S=1/2 C J(TARGET)=L(TARGET)+S(TARGET) C C C connor ballance 1999 C C My apologies to the author for hacking njchan to my purposes C but at least those common blocks are gone C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJTAR=4*MZTAR) PARAMETER (MXJP=MZSLP+10) C C DIMENSION J2(MXJP),JP(MXJP) DIMENSION JJ(MXJTAR),JPTY(MXJTAR) C C----------------------------------------------------------------------- C C JRGL = J2(M) JNPTY = JP(M) NJCHA = 0 C C DETERMINE THE L(INCIDENT) AND K CHANNEL NUMBERS. C C LOOP OVER THE TARGET STATES. C DO 40 I = 1,JNAST C C LOOP OVER THE ONLY TWO POSSIBLE 2K VALUES, THAT IS JRGL-1,JRGL+1 C IFIN = 3 IF (JRGL.EQ.0) IFIN = 1 DO 30 K = 1,IFIN,2 JK = ABS(JRGL-2+K) C C DETERMINE THE RANGE OF L(INCIDENT) VALUES. C LMIN = ABS(JJ(I)-JK) LMAX = JJ(I) + JK C C CHECK IF LMIN IS AN INTEGER. C IF (MOD(LMIN,2).NE.0) GOTO 30 C C CHECK THE PARITY OF LMIN. C LP = LMIN/2 + JPTY(I) IF (MOD(LP,2).NE.JNPTY) LMIN = LMIN + 2 IF (LMIN.GT.LMAX) GOTO 30 C C CHECK IF LMAX EXCEEDS LRANG2. C LP = (LMIN+LMAX)/2 IF (MOD(LP,2).EQ.1) LMAX = LMAX - 2 LP = LMAX/2 C C 10 CONTINUE LMIN = LMIN + 1 LMAX = LMAX + 1 DO 20 L = LMIN,LMAX,4 NJCHA = NJCHA + 1 C 20 CONTINUE 30 CONTINUE 40 CONTINUE C END C C C SUBROUTINE NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C ORDERS ALL THE OCCUPIED SHELLS OF THE TWO CONFIGURATIONS C APPEARING IN A GIVEN MATRIX ELEMENT. C C I4,IA1,IB1 ARE, RESPECTIVELY, THE NUMBER OF OCCUPIED SHELLS, C THE NUMBERS INDICATING WHICH SHELLS ARE OCCUPIED, AND THE NUMBERS C OF ELECTRONS IN EACH OCCUPIED SHELL, FOR THE CONFIGURATION ON THE C L.H.S OF THE MATRIX ELEMENT. C I5,IA2,IB2 ARE THE EQUIVALENT NUMBERS FOR THE R.H.S OF THE MATRIX C ELEMENT. C C I3 CONTAINS ON RETURN THE TOTAL NUMBER OF OCCUPIED SHELLS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C DIMENSION IA1(MZOCC),IA2(MZOCC),IB1(MZOCC),IB2(MZOCC) C COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C----------------------------------------------------------------------- C C DEFINE THE NJ AND LJ ARRAYS AS THE N,L VALUES OF EACH SHELL, C AND I3 AS THE HIGHEST OCCUPIED SHELL. C I6 = 0 I9 = 0 DO 30 I2 = 1,I4 I7 = IA1(I2) 10 CONTINUE I6 = I6 + 1 IF (I6.GT.I5) GOTO 20 I8 = IA2(I6) IF (I8.GT.I7) GOTO 20 I9 = I9 + 1 NJ(I9) = NJCOMP(I8) LJ(I9) = LJCOMP(I8) IJFUL(I9)=I8 IF (I8.LT.I7) GOTO 10 GOTO 30 C 20 CONTINUE I9 = I9 + 1 NJ(I9) = NJCOMP(I7) LJ(I9) = LJCOMP(I7) IJFUL(I9)=I7 I6 = I6 - 1 30 CONTINUE C IF (I6.GE.I5) GOTO 50 I7 = I6 + 1 DO 40 I2 = I7,I5 I9 = I9 + 1 I8 = IA2(I2) NJ(I9) = NJCOMP(I8) LJ(I9) = LJCOMP(I8) IJFUL(I9)=I8 40 CONTINUE C C DEFINE THE NOSH ARRAYS AS THE NUMBER OF ELECTRONS IN EACH SHELL C FOR EACH OF THE TWO CONFIGURATIONS. C 50 CONTINUE I3 = I9 I6 = I4 DO 100 I1 = 1,2 DO 60 I2 = 1,I3 NOSH(I2,I1) = 0 60 CONTINUE DO 90 I7 = 1,I6 IF (I1.EQ.1) THEN I8 = IA1(I7) C ELSE I8 = IA2(I7) ENDIF C DO 70 I9 = 1,I3 I91 = I9 IF (NJ(I9).EQ.NJCOMP(I8) .AND. A LJ(I9).EQ.LJCOMP(I8)) GOTO 80 70 CONTINUE 80 CONTINUE IF (I1.LE.1) THEN NOSH(I91,I1) = IB1(I7) C ELSE NOSH(I91,I1) = IB2(I7) ENDIF C 90 CONTINUE I6 = I5 100 CONTINUE C END SUBROUTINE NOJTS(JNAST,JJ,JPTY) IMPLICIT REAL*8 (A-H,O-Z) C C----------------------------------------------------------------------- C C NUMBER OF IC N ELECTRON TARGET STATES C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJTAR=4*MZTAR) C C COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),IPTY(MZTAR),NAST C DIMENSION JJ(MXJTAR),JPTY(MXJTAR) DIMENSION SATSZ(MZTAR) C DO I=1,NAST SATSZ(I)=(DBLE(ISAT(I))-1.0D0)/2.0D0 END DO C JNAST=0 DO I=1,NAST IA=INT(2.0D0*(ABS(DBLE(LAT(I))-SATSZ(I)))) IB=INT(2.0D0*(ABS(DBLE(LAT(I))+SATSZ(I)))) DO J=IA,IB,2 JNAST=JNAST+1 IF(JNAST.LE.MXJTAR)THEN JJ(JNAST)=J IF(IPTY(I).EQ.0) THEN JPTY(JNAST)=0 ELSE JPTY(JNAST)=1 END IF ENDIF ENDDO ENDDO C IF(JNAST.GT.MXJTAR)THEN JNAST=(JNAST+3)/4 WRITE(6,*)'NOICC OPTION REQUIRES MZTAR AT LEAST: ',JNAST STOP 'INCREASE MZTAR' ENDIF C END C C C SUBROUTINE ODH0(ISIG,ISIGP,TIMES,ICAL) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES THE ONE-ELECTRON INTEGRALS WHERE THE CONFIGURATIONS C DIFFER BY ONE ORBITAL C ALSO, DETERMINE BOUND-CONTINUUM OVERLAP MATRIX FOR PSEUDO-RESONANCE C REMOVAL - TWG & NRB C C ISIG,ISIGP DEFINE THE DIFFERENT ORBITALS C TIMES CONTAINS THE ANGULAR AND SPIN FACTORS C ICAL=0 IF TIMES HAS NOT BEEN CALCULATED C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXL2=9) C PARAMETER (NTOM1=MZCHD*MZNR1) C PARAMETER (NTOM2=MZNC2*NTOM1) !LARGE PARAMETER (NTOM2=1000000) C DIMENSION A(MZNR2) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /CONMX/H0MAT(MZNR2,MZNR2),VMAT(MZNR2,MZNR2) COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /NJLJ/ NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON /DW/ISTL,ISTR,NCHNL,NCHNR,ICL,ICR,IE,IG,ISYM(MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /AMATST/AFACT(NTOM2),NDIML,NDIMR,NONZER,ICHL(NTOM1), C IORB(NTOM1),ILEFT(NTOM2),IRIGHT(NTOM2) COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /CUPMAT/NCONOB(MXNCF),LCONOB(MXL2,MXNCF),LCONAT(MXL2,MZTAR) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /NRBTOL/TOLER C----------------------------------------------------------------------- IF (ICAL.EQ.0) RETURN N1 = NJ(ISIG) N2 = NJ(ISIGP) L1 = LJ(ISIG) + 1 C C ISAMEK = 1 BOUND-BOUND C IF (ISAMEK.EQ.1) THEN CALL FIN1BB(N1,N2,L1,ALBVAL) H0MAT(1,1) = TIMES*ALBVAL RETURN C ENDIF C C ISAMEK = 2 BOUND-CONTINUUM C IF (ISAMEK.EQ.2) THEN DO 10 J = 1,JLIMIT N3 = ND(2,J) CALL FIN1BC(N1,N3,L1,ALBVAL) H0MAT(1,J) = TIMES*ALBVAL 10 CONTINUE C C DETERMINE THE OVERLAP MATRIX C ROWS SPECIFIED BY CONTINUUM CHANNEL (NCHL) AND BOUND ORBITAL (N1) C COLUMNS SPECIFIED BY BOUND CONFIGURATION (ICR) C IF(IDWOUT.NE.2.AND.ISTL.GT.0.AND.TOLER.GE.1.D-19)THEN ISYML=ISYM(ISTL) DO 41 IL=1,ISYML NCHL=NCHNL+(IL-ISYML)*NCONAT(IE) CMIXL=AIJ(IE+IL-1,ICL) DO 11 I=1,NDIML IF(NCHL.EQ.ICHL(I).AND.N1.EQ.IORB(I))THEN NONZER=NONZER+1 IF(NONZER.GT.NTOM2)THEN WRITE(IWRITE,*)'INCREASE PARAMETER NTOM2' STOP 'NONZER .GT. NTOM2' ENDIF ILEFT(NONZER)=I IRIGHT(NONZER)=ICR AFACT(NONZER)=CMIXL*TIMES GO TO 21 ENDIF 11 CONTINUE NDIML=NDIML+1 IF(NDIML.GT.NTOM1)THEN WRITE(IWRITE,*)'INCREASE PARAMETER NTOM1' STOP 'NDIML.GT.NTOM1' ENDIF ICHL(NDIML)=NCHL IORB(NDIML)=N1 NONZER=NONZER+1 IF(NONZER.GT.NTOM2)THEN WRITE(IWRITE,*)'INCREASE PARAMETER NTOM2' STOP 'NONZER .GT. NTOM2' ENDIF ILEFT(NONZER)=NDIML IRIGHT(NONZER)=ICR AFACT(NONZER)=CMIXL*TIMES 21 CONTINUE IF(IBUG5.GT.0) CWRITE(67,100)ISTL,NCHL,ICL,ICR,NSIG,LSIG,CMIXL,TIMES, C N1,LJ(ISIG),N2,LJ(ISIGP),N3 41 CONTINUE 100 FORMAT(6I4,2E13.6,5i4) ENDIF C RETURN C ENDIF C C ISAMEK = 3 CONTINUUM-CONTINUUM. DIAGONAL MATRIX ELEMENTS C THIS ONLY OCCURS WHEN TWO BOUND ORBITALS DIFFER C IF (ISAMEK.EQ.3) THEN CALL FIN1BB(N1,N2,L1,ALBVAL) DO 20 I = 1,ILIMIT H0MAT(I,I) = TIMES*ALBVAL 20 CONTINUE C ELSE C C ISAMEK = 4 CONTINUUM-CONTINUUM . OFF DIAGONAL MATRIX ELEMENTS C DO 40 J = 1,JLIMIT CALL FIN1CC(J,ILIMIT,L1,A) HSAVE = H0MAT(J,J) DO 30 I = 1,ILIMIT H0MAT(I,J) = TIMES*A(I) 30 CONTINUE H0MAT(J,J) = HSAVE 40 CONTINUE ENDIF C END SUBROUTINE ORDER(EN,NORDER,NDIM,IUP) IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C RETURNS NORDER(I)=POINTER TO I-TH ENERGY IN EN ARRAY, C IUP=1 FOR ASCENDING ENERGIES, IUP=-1 FOR DESCENDING ENERGIES C C----------------------------------------------------------------------- DIMENSION EN(NDIM),NORDER(NDIM) C----------------------------------------------------------------------- DO 40 K = 1,NDIM J = K J1 = J - 1 IF (J1.EQ.0) GOTO 30 E = EN(J) + IUP*1.0D-7 DO 20 I = 1,J1 IF (J.LT.K) GOTO 10 N = NORDER(I) IF (IUP.GT.0 .AND. E.GT.EN(N)) GOTO 20 IF (IUP.LT.0 .AND. E.LT.EN(N)) GOTO 20 10 CONTINUE NORDER(J) = NORDER(J-1) J = J - 1 20 CONTINUE 30 NORDER(J) = K 40 CONTINUE C END C C C SUBROUTINE PNTBG2(I,J) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C PRINTS OUT THE ANGULAR MOMENTUM COUPLING IN EACH STAGE OF SETMX1 C C I AND J SPECIFY THE TWO INTERACTING CONFIGURATIONS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INFORM/IREAD,IWRITE,IPUNCH C----------------------------------------------------------------------- I1 = NDCT(1) IF (I1.LE.0) I1 = 1 J1 = NDCT(2) IF (J1.LE.0) J1 = 1 CALL VIJOUT(I,J) WRITE (IWRITE,3000) I1,J1 DO 10 I4 = 1,2 I5 = NDCT(I4) IF (I5.LE.0) GOTO 10 WRITE (IWRITE,3010) (ND(I4,I6),I6=1,I5) 10 CONTINUE C 3000 FORMAT (/' DIMENSION OF AME IN THIS MATRIX ELEMENT IS',I5,I8) 3010 FORMAT (20I5) END SUBROUTINE PRNTWT(IRHO,ISIG,IRHOP,ISIGP) IMPLICIT REAL*8 (A-H,O-Z) C C C----------------------------------------------------------------------- C C THIS VERSION OF SLATER FINDS THE REQUIRED RK INTEGRALS FROM THE C ARRAYS HELD IN CORE BY CALLING THE FIN ROUTINES C IRHO AND ISIG SPECIFY THE TWO ORBITALS ON THE L.H.S. OF THE RK C INTEGRALS C IRHOP AND ISIGP SPECIFY THE TWO ORBITALS ON THE R.H.S. OF THE RK C INTEGRALS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MX2LR2=2*MZLR2) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) C LOGICAL DTEST,ETEST,MTEST1,MTEST2 C COMMON /CONMX/H0MAT(MZNR2,MZNR2),VMAT(MZNR2,MZNR2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, A M16,M17,M18,M19,M20 COMMON /RKMATX/RKMAT(MZNR2,MZNR2),ISAMEK,ILIMIT,JLIMIT COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX C----------------------------------------------------------------------- C C DEFINITION OF ISAMEK C ISAMEK = 0 C-C ELEMENTS OF RKMAT WITH L.NE.LP C ISAMEK = 1 BOUND-BOUND RK INTEGRALS C ISAMEK = 2 BOUND-CONTINUUM. THE CONTINUUM ORBITAL IS ALWAYS C IN N4 C ISAMEK = 3 CONTINUUM-CONTINUUM DIAGONAL ELEMENTS OF RKMAT C ISAMEK = 4 CONTINUUM-CONTINUUM OFF-DIAGONAL ELEMENTS OF RKMAT C C PRINTS OUT THE COEFFICIENTS OF SLATER INTEGRALS C DEFINITION OF IBUG2 - INITIALLY,IBUG2 IS SET EQUAL TO 2 IN RKWTS. C THE FIRST TIME THE PRESENT SUBROUTINE IS ENTERED FOR EACH MATRIX C ELEMENTS,IBUG2 HAS THIS VALUE. ONCE FORMAT 1001 HAS BEEN WRITTEN, C IBUG2 ASSUMES THE VALUE OF IBUG1. IF IBUG1=0, THERE WILL BE NO C PRINT-OUT AT ALL. IF IBUG1=1,FORMAT 1001 IS OUTPUT ONLY FOR THE C FIRST ENTRY OF PRNTWT,AND THUS THE ONLY PRINT-OUT FOR THE MATRIX C ELEMENT AFTER THE FIRST FORMAT 1001 IS A LIST OF COEFFICIENTS,AND C THE APPROPRIATE SLATER INTEGRALS-FK,GK,RK. IF IBUG1.GT.1, C FORMAT 1001 IS OUTPUT FOR EACH SET OF IRHO,ISIG,IRHOP,ISIGP C IF(IDWOUT.GT.0)CALL DWOUT2(IRHO,ISIG,IRHOP,ISIGP) C NRB IF(IDWOUT.EQ.2.AND.ISAMEK.NE.1)RETURN C NRB IF (IBUG1.LT.2) GOTO 10 WRITE (IWRITE,3000) IRHO,ISIG,IRHOP,ISIGP IF (IBUG1.NE.0) WRITE (IWRITE,3010) IBUG2 = IBUG1 C 10 CONTINUE DTEST = MULTD .EQ. 0 ETEST = MULTE .EQ. 0 MTEST1 = .FALSE. MTEST2 = .FALSE. IF ((M1+M2).NE.0) MTEST1 = .TRUE. IF (M19.NE.0 .OR. M20.NE.0) MTEST2 = .TRUE. C C DIRECT INTEGRALS C MULTD=0 MEANS NO NON-ZERO =DIRECT =COEFFICIENTS C IF (DTEST) GOTO 120 DO 110 JK1 = KD1,KD2,2 K = JK1 - 1 ID = 1 IF (ISAMEK.EQ.1) CALL FINBB(ID,K) IF (ISAMEK.EQ.2) CALL FINBC(ID,K) IF (ISAMEK.EQ.3) THEN JUMP = 1 CALL FINCC1(ID,K,JUMP) C ELSE IF (ISAMEK.EQ.0 .OR. ISAMEK.EQ.4) THEN CALL FINCC2(ID,K) ENDIF C IF (IBUG1.EQ.0) GOTO 50 IF (.NOT.MTEST2) THEN WRITE (IWRITE,3020) K,AMULT(JK1),IRHO,ISIG WRITE (IWRITE,3030) DO 20 I = 1,ILIMIT WRITE (IWRITE,3040) (RKMAT(I,J),J=1,JLIMIT) 20 CONTINUE C ELSE IF (.NOT.MTEST1) THEN WRITE (IWRITE,3050) K,AMULT(JK1),IRHO,IRHOP WRITE (IWRITE,3030) DO 30 I = 1,ILIMIT WRITE (IWRITE,3040) (RKMAT(I,J),J=1,JLIMIT) 30 CONTINUE C ELSE WRITE (IWRITE,3060) K,AMULT(JK1),IRHO,ISIG,IRHOP,ISIGP WRITE (IWRITE,3030) DO 40 I = 1,ILIMIT WRITE (IWRITE,3040) (RKMAT(I,J),J=1,JLIMIT) 40 CONTINUE ENDIF C ENDIF C 50 CONTINUE A = AMULT(JK1) IF (ISAMEK.NE.0) THEN DO 70 J = 1,JLIMIT DO 60 I = 1,ILIMIT VMAT(I,J) = VMAT(I,J) + RKMAT(I,J)*A 60 CONTINUE 70 CONTINUE C ELSE DO 90 J = 1,JLIMIT VMATJJ = VMAT(J,J) DO 80 I = 1,ILIMIT C IF(I.EQ.J) GOTO 142 VMAT(I,J) = VMAT(I,J) + RKMAT(I,J)*A 80 CONTINUE VMAT(J,J) = VMATJJ 90 CONTINUE JUMP = 1 CALL FINCC1(ID,K,JUMP) DO 100 I = 1,ILIMIT VMAT(I,I) = VMAT(I,I) + RKMAT(I,I)*A 100 CONTINUE ENDIF C 110 CONTINUE C C EXCHANGE INTEGRALS C MULTE=0 MEANS NO NON- ZERO =EXCHANGE =COEFFICIENTS C 120 CONTINUE IF (ETEST) GOTO 220 DO 210 JK1 = KE1,KE2,2 K = JK1 - 1 IE = 2 IF (ISAMEK.EQ.1) CALL FINBB(IE,K) IF (ISAMEK.EQ.2) CALL FINBC(IE,K) IF (ISAMEK.EQ.3) THEN JUMP = 1 CALL FINCC1(IE,K,JUMP) C ELSE IF (ISAMEK.EQ.0 .OR. ISAMEK.EQ.4) THEN CALL FINCC2(IE,K) ENDIF C IF (IBUG1.EQ.0) GOTO 150 IF (.NOT.MTEST2) THEN WRITE (IWRITE,3050) K,BMULT(JK1),IRHO,ISIG WRITE (IWRITE,3030) DO 130 I = 1,ILIMIT WRITE (IWRITE,3040) (RKMAT(I,J),J=1,JLIMIT) 130 CONTINUE C ELSE WRITE (IWRITE,3060) K,BMULT(JK1),IRHO,ISIG,ISIGP,IRHOP WRITE (IWRITE,3030) DO 140 I = 1,ILIMIT WRITE (IWRITE,3040) (RKMAT(I,J),J=1,JLIMIT) 140 CONTINUE ENDIF C 150 CONTINUE B = BMULT(JK1) IF (ISAMEK.NE.0) THEN DO 170 J = 1,JLIMIT DO 160 I = 1,ILIMIT VMAT(I,J) = VMAT(I,J) + RKMAT(I,J)*B 160 CONTINUE 170 CONTINUE C ELSE DO 190 J = 1,JLIMIT VMATJJ = VMAT(J,J) DO 180 I = 1,ILIMIT C IF(I.EQ.J) GOTO 272 VMAT(I,J) = VMAT(I,J) + RKMAT(I,J)*B 180 CONTINUE VMAT(J,J) = VMATJJ 190 CONTINUE JUMP = 1 CALL FINCC1(IE,K,JUMP) DO 200 I = 1,ILIMIT VMAT(I,I) = VMAT(I,I) + RKMAT(I,I)*B 200 CONTINUE ENDIF C 210 CONTINUE C 220 CONTINUE C 3000 FORMAT (//' INTERACTING SHELLS ARE',6X,' RHO =',I3,6X,' SIG =',I3, A 6X,' RHOP =',I3,6X,' SIGP =',I3//) 3010 FORMAT (//15X,' EVALUATION OF SLATER INTEGRALS'//) 3020 FORMAT (11X,'K =',I2,' MULTIPLIER =',F11.6,' INTEGRAL IS FK(',I2, A ',',I2,')') 3030 FORMAT (/5X,' RKMAT'/) 3040 FORMAT (10F12.6) 3050 FORMAT (10X,' K =',I2,' MULTIPLIER =',F11.6,' INTEGRAL IS GK(', A I2,',',I2,')') 3060 FORMAT (10X,' K =',I2,' MULTIPLIER =',F11.6,' INTEGRAL IS RK(', A I2,',',I2,'/',I2,',',I2,')') END SUBROUTINE RDINT(IJUMP,LOT1,LOT2) use memory IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C***** NEW CODING FOR IMPROVING I/O ***** FEB 1986, KAB. C READING RK INTEGRALS DIRECT FROM A NEW STG1 DA FILE. C C IF IJUMP=1, READ BOUND-CONTINUUM RK INTEGRALS INTO RKSTO2. C IF IJUMP=2, READ CONTINUUM-CONTINUUM RK INTEGRALS INTO RKSTO2. C C LOT1 AND LOT2 ARE THE ANGULAR MOMENTUM VALUES PLUS ONE FOR C THE CONTINUUM-CONTINUUM INTEGRALS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXL1SQ=MZLR1*MZLR1/2+MZLR1) PARAMETER (MXCTBB=MZLR1*MZLR1,MXIRK4=MXL1SQ*MXL1SQ/2+MXL1SQ) PARAMETER (MXCTBC=3*MZLR1*MZLR1-2*MZLR1,MXIRK3=MXIRK4*MZLR1*2) PARAMETER (MXCTCC=MZLR2+MZLR1-1) PARAMETER (MXICT=4*MZLR1*MZLR1*MZLR1*MZLR2*MZLR2) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO3/ICTBB(MZLR1,MZLR1,MXCTBB), 1 ICTBC(MZLR1,MZLR1,MXCTBC), A ICTCCD(MZLR1,MZLR1,MXCTCC),ICTCCE(MZLR1,MZLR1,MXCTCC), B ISTBB1(MXIRK4),ISTBB2(MXIRK4),ISTBC1(MXIRK3), C ISTBC2(MXIRK3),ITAPST(MZLR2,MZLR2) C COMMON /MEMORY/RKSTO2(MXMEM),MEM1,MREC1 COMMON /RKSAVE/IRKBC,IRKCC(MZLR2,MZLR2,2),ICHUNK,ICT(MXICT),ITAPBC c **** parallel **** c...... delete in final code: include 'mpif.h' common /parablock/iam,nproc c....... delete common /pstg1block/nprocstg1 common /recbcblock/irecbc common /recccblock/ITAPSTp parameter (mxproc1=64) integer irecp(0:mxproc1-1) integer irecbc(0:mxproc1-1) integer ITAPSTp(MZLR2,MZLR2,0:mxproc1-1) allocatable RKSTp(:) PARAMETER (LREC=512) IRECL = 8*LREC c **** parallel **** C----------------------------------------------------------------------- IF (IJUMP.EQ.2) GOTO 10 C C READ THE BOUND-CONTINUUM INTEGRALS C IRK2 = IRKBC IREC = ITAPBC c **** parallel **** do iamstg1=0,nprocstg1-1 irecp(iamstg1)=irecbc(iamstg1) enddo c **** parallel **** IF (IRK2.EQ.0 .OR. IREC.LE.0) RETURN c **** parallel **** c....... STG1 was SERIAL if (nprocstg1.eq.1) then CALL DA2(1,IREC,JDISC1,IRKBC,RKSTO2(1)) else c....... STG1 was PARALLEL c....... first, move irec forward irec = irec+irkbc/lrec do 8888 iamstg1=0,nprocstg1-1 c....... skip if length is zero if (irkbc.le.iamstg1.or.irecp(iamstg1).le.0) go to 8888 itapeRK = 120+iamstg1 c...... calculate size of chunks writed per processor irk2st = (irkbc - (iamstg1+1) )/nprocstg1 + 1 c..... allocate temporary reading storage allocate(RKSTp(IRK2st),stat=ierr) if (ierr.ne.0) stop 'allocation fails for RKSTp' c....... read integrals on RKxx.DAT CALL DA2(1,IRECp(iamstg1),itapeRK,IRK2st,RKSTp) c...... copy temporary data on global array do i=1,irk2st indxglob = (i-1)*nprocstg1 + (iamstg1+1) RKSTO2(indxglob) = RKSTp(i) enddo c...... deallocate temporary arrays deallocate(RKSTp) 8888 continue endif c **** parallel **** RETURN C C READ THE CONTINUUM-CONTINUUM INTEGRALS C 10 CONTINUE IRK2 = IRKCC(LOT1,LOT2,1) IF (IRK2.EQ.0) RETURN IREC = ITAPST(LOT1,LOT2) c **** parallel **** do iamstg1=0,nprocstg1-1 irecp(iamstg1) = ITAPSTp(LOT1,LOT2,iamstg1) enddo c **** parallel **** IF (IREC.LE.0) GOTO 30 c **** parallel **** c...... STG1 was SERIAL if (nprocstg1.eq.1) then LOOPCC = 1 + IRK2/ICHUNK JSTART = 1 JRK2 = ICHUNK DO 20 L = 1,LOOPCC IF (L.EQ.LOOPCC) JRK2 = MOD(IRK2,ICHUNK) IF (JRK2.EQ.0) GOTO 20 CALL DA2(1,IREC,JDISC1,JRK2,RKSTO2(JSTART)) JSTART = JSTART + JRK2 20 CONTINUE else c....... STG1 was PARALLEL do 8889 iamstg1=0,nprocstg1-1 c....... skip if length is zero if (irk2.le.iamstg1.or.ichunk.le.iamstg1 + .or.irecp(iamstg1).le.0) go to 8889 itapeRK = 120+iamstg1 c....... calculate size of chunks writed per processor irk2st = (irk2 - (iamstg1+1) )/nprocstg1 + 1 ichunkp = (ichunk - (iamstg1+1) )/nprocstg1 + 1 c..... allocate temporary reading storage allocate(RKSTp(IRK2st),stat=ierr) if (ierr.ne.0) stop 'allocation fails for RKSTp' LOOPCC = 1 + IRK2st/ICHUNKp JSTART = 1 JRK2 = ICHUNKp DO 9920 L = 1,LOOPCC IF (L.EQ.LOOPCC) JRK2 = MOD(IRK2st,ICHUNKp) IF (JRK2.EQ.0) GOTO 9920 c....... read integrals on RKxx.DAT CALL DA2(1,IRECp(iamstg1),itapeRK,JRK2,RKSTp) c...... copy temporary data on global array do i=1,jrk2 indxglob = (i-1)*nprocstg1 + (iamstg1+1) + JSTART - 1 RKSTO2(indxglob) = RKSTp(i) enddo JSTART = JSTART + JRK2 9920 continue c...... deallocate temporary arrays deallocate(RKSTp) 8889 continue endif c **** parallel **** C 30 CONTINUE I1 = MIN(2*LRANG1-1,LOT1+LOT2-1) I2 = MIN(LRANG1+LOT1,LRANG1+LOT2) - 1 IC = IRKCC(LOT1,LOT2,2) DO 60 K = 1,I1 DO 50 J = 1,LRANG1 DO 40 I = 1,LRANG1 ICTCCD(I,J,K) = ICT(IC+I) 40 CONTINUE IC = IC + LRANG1 50 CONTINUE 60 CONTINUE DO 90 K = 1,I2 DO 80 J = 1,LRANG1 DO 70 I = 1,LRANG1 ICTCCE(I,J,K) = ICT(IC+I) 70 CONTINUE IC = IC + LRANG1 80 CONTINUE 90 CONTINUE C END C C C SUBROUTINE RECOV2(SUBNAM,PARNAM,IDIM,NEED) C----------------------------------------------------------------------- C C THIS ROUTINE IS CALLED ONLY FOR ARRAY OVERFLOW C C SUBNAM = SUBROUTINE NAME C PARNAM = PARAMETER NAME C IDIM = CURRENT DIMENSION C NEED = REQUIRED DIMENSION, RETURN NEED=IDIM C IPLACE = 0 TO STOP PROGRAM, C OTHERWISE RETURN IPLACE=NEED TO THE CALLING ROUTINE. C C----------------------------------------------------------------------- CHARACTER*6 SUBNAM,PARNAM,PREPRO C COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RECOV/IPLACE C----------------------------------------------------------------------- PREPRO = PARNAM IF (PREPRO(1:3).EQ.' MZ') PREPRO(1:3) = ' MZ' WRITE (IWRITE,3000) SUBNAM,PREPRO,IDIM,PREPRO,NEED C IF (IPLACE.EQ.0) THEN WRITE (IWRITE,3010) STOP ENDIF C IF (IPLACE.LT.0) WRITE (IWRITE,3020) IPLACE = NEED NEED = IDIM C 3000 FORMAT (/' * ARRAY OVERFLOW IN ', A A6/' MUST INCREASE DIMENSION GIVEN BY ',A6,' =',I7, B ' TO AT LEAST ',A6,' =',I9) 3010 FORMAT (/' PROGRAM TERMINATES IN RECOV2'/) 3020 FORMAT (/' CHECK TO SEE IF OTHER ARRAYS ARE GOING TO BE EXCEEDED') END C C C SUBROUTINE REDRAD(KA,IRHO,ISIG,RL) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES THE PRODUCT OF THE REDUCED MATRIX ELEMENT AND THE C RADIAL MULTIPOLE INTEGRAL BETWEEN TWO ORBITALS. C C KA IS THE MULTIPOLE ORDER OF THE RADIAL INTEGRAL C IRHO AND ISIG SPECIFY THE TWO INTERACTING ORBITALS C RL CONTAINS THE RESULT ON RETURN C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) C----------------------------------------------------------------------- RL = 0.0D0 LJR = LJ(IRHO) LJS = LJ(ISIG) IF (KA.GT. (LJR+LJS) .OR. KA.LT.ABS(LJR-LJS) .OR. A MOD(KA+LJR+LJS,2).NE.0) RETURN N1 = NJ(IRHO) N2 = NJ(ISIG) L1 = LJR + 1 L2 = LJS + 1 CALL FINMNT(N1,L1,N2,L2,KA,R,RV) RL = RME(LJR,LJS,KA)*R C END C C C SUBROUTINE RKWTS IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C THE MATRIX ELEMENT OF THE TWO-ELECTRON POTENTIAL BETWEEN TWO C STATES (LABELLED 1 AND 2) MAY BE EXPRESSED AS A SUM OF WEIGHTED C RK (SLATER) INTEGRALS. THIS SUBROUTINE, TOGETHER WITH THOSE C CALLED BY IT, DETERMINES THESE WEIGHTS, WHICH ARISE FROM AN C INTEGRATION OVER THE ANGULAR AND SPIN CO-ORDINATES C FOR DETAILS, SEE U. FANO, PHYS. REV.,140,A67,(1965) C C THE =INTERACTING= SHELLS ARE DESIGNATED IRHO,ISIG,IRHOP,ISIGP. C THE FIRST TWO REFER TO THE L.H.S. OF (PSI/V/PSIP) , WHILE C THE SECOND TWO REFER TO THE R.H.S. FOR DIAGONAL AND CERTAIN OFF- C DIAGONAL MATRIX ELEMENTS, THESE MAY NOT BE UNIQUE, AND EACH C POSSIBILITY MUST BE CONSIDERED IN TURN C THE CONDITION =IRHO .LE. ISIG , IRHOP .LE. ISIGP= IS TO BE C SATISFIED C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /REMOVE/ICHOP(MXORB2) C----------------------------------------------------------------------- C C === DETERMINE THE INTERACTING SHELLS AS FAR AS POSSIBLE BY C CONSIDERING THE DIFFERENCES BETWEEN PSI AND PSIP C IBUG2 = 2 IX = 0 IRHO = 0 ISIG = 0 IRHOP = 0 ISIGP = 0 DO 10 J = 1,IHSH N = NOSH1(J) - NOSH2(J) IF (ABS(N).GT.2) GOTO 80 IF (N.EQ.0) GOTO 10 C C --- TO SATISFY =IRHO.LE.ISIG= IRHO IS SET FIRST, ETC. C IF (N.EQ.1) THEN IF (IRHO.LE.0) THEN IRHO = J C ELSE ISIG = J ENDIF C IX = IX + 1 C ELSE IF (N.GT.1) THEN IRHO = J IX = IX + 2 C ELSE IF (N.EQ.-1) THEN IF (IRHOP.LE.0) THEN IRHOP = J C ELSE ISIGP = J ENDIF C IX = IX + 1 C ELSE IF (N.LT.-1) THEN IRHOP = J IX = IX + 2 ENDIF C 10 CONTINUE C C IX MEASURES THE TOTAL NUMBER OF ELECTRONS IN EITHER CONFIGURATION C WHICH DO NOT OCCUR IN THE OTHER. THEN IF IX IS GREATER THAN 4, C ORTHOGONALITY OF THE ORBITALS PREVENTS A NON-ZERO MATRIX ELEMENT. C IF IX IS LESS THAN 4, THEN WE DIVIDE IX BY 2 AND NOW IX MEASURES C THE NUMBER OF ELECTRONS WHICH HAVE BEEN CHANGED IN GOING FROM PSI C TO PSIP. IF NOW IX=0, WE HAVE A DIAGONAL MATRIX ELEMENT. RHO AND C SIG MAY TAKE ON ANY VALUES LESS THAN IHSH. IF IX=1, ONE INTER- C ACTING SHELL ON EACH SIDE IS FIXED, WHILE THE OTHER MAY VARY. IF C IX=2, ALL INTERACTING SHELLS ARE DETERMINED C IF (IX.GT.4) GOTO 80 IX = IX/2 IF (IX.LT.1) GOTO 30 IF (IX.GT.1) THEN C C === UNIQUE SPECIFICATION OF INTERACTING SHELLS C IF (ISIG.EQ.0) ISIG = IRHO IF (ISIGP.EQ.0) ISIGP = IRHOP IF (IBUG1.GT.1) WRITE (IWRITE,3000) IRHO,ISIG,IRHOP,ISIGP C C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS C CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) CALL SETM CALL FANO(IRHO,ISIG,IRHOP,ISIGP) IF (LESSEN.NE.0) CALL MEKEST(1,IRHO,ISIG,IRHOP,ISIGP) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) RETURN C ENDIF C C === ONE INTERACTING SHELL SPECIFIED ON EACH SIDE. SUMMATION OVER OTHER C IRSTO = IRHO IRPSTO = IRHOP DO 20 K1 = 1,IHSH IF (NOSH1(K1).EQ.0) GOTO 20 ISIG = K1 IF (NOSH2(K1).EQ.0) GOTO 20 ISIGP = K1 IRHO = IRSTO IRHOP = IRPSTO C C ORTHOGONALITY OF THE ORBITALS REQUIRES THAT THE VARYING INTER- C ACTING SHELL BE THE SAME ON BOTH SIDES OF THE MATRIX ELEMENT C C --- IRHO.LE.ISIG, IRHOP.LE.ISIGP C IF (IRHO.EQ.ISIG .AND. NOSH1(ISIG).LE.1) GOTO 20 IF (IRHO.GT.ISIG) THEN ISTO = IRHO IRHO = ISIG ISIG = ISTO ENDIF C IF (IRHOP.EQ.ISIGP .AND. NOSH2(ISIGP).LE.1) GOTO 20 IF (IRHOP.GT.ISIGP) THEN ISTO = IRHOP IRHOP = ISIGP ISIGP = ISTO ENDIF C IF (IBUG1.GT.1) WRITE (IWRITE,3000) IRHO,ISIG,IRHOP,ISIGP C C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS C CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) CALL SETM CALL FANO(IRHO,ISIG,IRHOP,ISIGP) IF (LESSEN.NE.0) CALL MEKEST(1,IRHO,ISIG,IRHOP,ISIGP) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) 20 CONTINUE RETURN C C === NO INTERACTING SHELLS SPECIFIED C SUMMATION OVER ALL POSSIBLE COMBINATIONS C IN THIS CASE, ORTHOGONALITY OF ORBITALS PRECLUDES ALL CASES C EXCEPT IRHO=IRHOP AND ISIG=ISIGP C 30 CONTINUE DO 70 K1 = 1,IHSH IF (NOSH1(K1).EQ.0) GOTO 70 ISIG = K1 DO 60 K2 = 1,K1 IF (NOSH1(K2).EQ.0) GOTO 60 IRHO = K2 IF (IRHO.EQ.ISIG .AND. NOSH1(ISIG).LE.1) GOTO 60 IRHOP = IRHO ISIGP = ISIG IF (IBUG1.GT.1) WRITE (IWRITE,3000) IRHO,ISIG,IRHOP,ISIGP C C --- CALCULATE COEFFICIENTS OF SLATER INTEGRALS C IF (LJ(IRHO).GT.4 .OR. LJ(ISIG).GT.4 .OR. LJ(IRHOP).GT.4 .OR. A LJ(ISIGP).GT.4) GOTO 40 IF (ICHOP(K1).EQ.1 .OR. ICHOP(K2).EQ.1) GOTO 50 40 CONTINUE CALL REDUCE(IRHO,ISIG,IRHOP,ISIGP,LESSEN) CALL SETM CALL FANO(IRHO,ISIG,IRHOP,ISIGP) IF (LESSEN.NE.0) CALL MEKEST(1,IRHO,ISIG,IRHOP,ISIGP) CALL PRNTWT(IRHO,ISIG,IRHOP,ISIGP) GOTO 60 C 50 CONTINUE CALL USEEAV(IRHO,ISIG) 60 CONTINUE 70 CONTINUE 80 CONTINUE C 3000 FORMAT (//11X,'IRHO =',I3,5X,'ISIG =',I3,5X,'IRHOP =',I3,4X, A 'SIGP =',I3) END SUBROUTINE SETCUP use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C THIS ROUTINE EVALUATES COUPLING MATRICES NCONOB,LCONOB,NCONAT C AND LCONAT. IT ALSO DETERMINES THE NUMBER OF COUPLED EQUATIONS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MX2LR2=2*MZLR2) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /CUPMAT/NCONOB(MXNCF),LCONOB(MXL2,MXNCF),LCONAT(MXL2,MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /REL/JRELOP(3) COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX C----------------------------------------------------------------------- LMAX = -1 C NRB LTEST=LRANG2 IF(IDWOUT.EQ.2)LTEST=LRNGDW C NRB DO 30 I1 = 1,NCFG NCONOB(I1) = 0 I2 = 2*NOCCSH(I1) - 1 L1 = (J1QNRD(I2,2,I1)-1)/2 IS1 = J1QNRD(I2,3,I1) IF (ABS(NSPN-IS1).NE.1) GOTO 30 IF(JRELOP(3).EQ.0.AND.LRGL.GT.LNOEX.AND.NSPN.LT.IS1)GO TO 30 NPTAT = 0 C C DETERMINE THE PARITY OF THE ATOMIC CONFIGURATION C I3 = NOCCSH(I1) DO 10 J = 1,I3 I4 = NOCORB(J,I1) L2 = LJCOMP(I4) I5 = NELCSH(J,I1) NPTAT = NPTAT + L2*I5 10 CONTINUE NPTAT = MOD(NPTAT,2) C C DETERMINE THE ANGULAR MOMENTA OF INCIDENT ELECTRON COUPLED TO C THE ATOMIC CONFIGURATIONS C L1MIN = ABS(LRGL-L1) IF (NPTY.NE.MOD(NPTAT+L1MIN,2)) L1MIN = L1MIN + 1 20 CONTINUE IF (L1MIN.GT.LRGL+L1) GOTO 30 LMAX = MAX(LMAX,L1MIN) IF (L1MIN.LE.LTEST-1) THEN NCONOB(I1) = NCONOB(I1) + 1 I6 = NCONOB(I1) IF (I6.GT.MXL2) CALL RECOV2('SETCUP','MXL2 ',MXL2,I6) LCONOB(I6,I1) = L1MIN ENDIF C L1MIN = L1MIN + 2 GOTO 20 C 30 CONTINUE NCHAN = 0 C C DETERMINE THE NUMBER OF COUPLED CHANNELS FOR EACH ATOMIC STATE C NCONAT(I) AND ALSO THE TOTAL NUMBER OF COUPLED CHANNELS NCHAN C J2 = 0 DO 50 I = 1,NAST I1 = NTYP(I,1) I2 = 2*NOCCSH(I1) - 1 NCONAT(I) = NCONOB(I1) IF (JRELOP(3).NE.0) NCONAT(I) = NCONOB(I) I2 = NCONAT(I) NCHAN = NCHAN + I2 IF (I2.LE.0) GOTO 50 IF (NCHAN.GT.MZCHF) CALL RECOV2('SETCUP',' MZCHF',MZCHF,NCHAN) DO 40 J = 1,I2 LCONAT(J,I) = LCONOB(J,I1) IF (JRELOP(3).NE.0) LCONAT(J,I) = LCONOB(J,I) J1 = J + J2 L2P(J1) = LCONAT(J,I) 40 CONTINUE J2 = J2 + I2 50 CONTINUE C C WRITE OUT THE COUPLING MATRICES C IF (LMAX.GT.LTEST-1) THEN WRITE (IWRITE,3010) LMAX STOP 'LRANG2 TOO SMALL, CHECK MAXLA IN STG1' ENDIF WRITE (IWRITE,3030) (NCONAT(I),I=1,NAST) WRITE (IWRITE,3080) NCHAN IF (NCHAN.EQ.0) WRITE (IWRITE,3100) IF (NCHAN.EQ.0) RETURN IF (NCHAN.GT.MZCHF) CALL RECOV2('SETCUP',' MZCHF',MZCHF,NCHAN) WRITE (IWRITE,3060) (L2P(I),I=1,NCHAN) C 3010 FORMAT(' ***WARNING -', A ' CHANNELS TRUNCATED BECAUSE LRANG2 TOO SMALL:'/ B ' HIGHEST POSSIBLE CHANNEL L =',I4/' **** CHECK MAXLA IN STG1') 3030 FORMAT (/' NCONAT =', (T10,20I3)) 3060 FORMAT (/' L2P =', (T8,20I3)) 3080 FORMAT (' NUMBER OF COUPLED CHANNELS =',I5) 3100 FORMAT (/' *** WARNING *** NO COUPLED CHANNELS FOR THIS SYMMETRY') END SUBROUTINE SETFIN(IA,I3,IAA,L3) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C SETS UP THE COUPLING ARRAYS TO INCLUDE A C CONTINUUM ELECTRON, LEADING TO A FINAL STATE CONFIGURATION. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /CUPMAT/NCONOB(MXNCF),LCONOB(MXL2,MXNCF),LCONAT(MXL2,MZTAR) COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C----------------------------------------------------------------------- IE = NOCCSH(I3) IE1 = 2*IE - 1 C C THE NUMBER OF OCCUPIED SHELLS IS INCREASED BY ONE TO ACCOMODATE C THE CONTINUUM STATE. C IOC = IE + 1 IOC1 = 2*IOC - 1 KOCCSH(I3) = IOC DO 20 J = 1,IE DO 10 K = 1,3 K1QNRD(J,K,I3) = J1QNRD(J,K,I3) 10 CONTINUE 20 CONTINUE C C IF IE1 EQUALS ONE THERE ARE NO COUPLED ANGULAR MOMENTA TO BE C SHIFTED. C IF (IE1.EQ.1) GOTO 50 DO 40 J = IOC,IE1 J1 = J + 1 DO 30 K = 1,3 C C SHIFT THE POSITIONS OF THE COUPLED ANGULAR MOMENTA TO THE C PROPER PLACES. C K1QNRD(J1,K,I3) = J1QNRD(J,K,I3) 30 CONTINUE 40 CONTINUE C C PUT THE TOTAL (N+1)-ELECTRON ORBITAL AND SPIN ANGULAR MOMENTA C INTO THE PROPER PLACES. C 50 CONTINUE K1QNRD(IOC1,1,I3) = 0 K1QNRD(IOC1,2,I3) = 2*LRGL + 1 K1QNRD(IOC1,3,I3) = NSPN DO 60 K = 1,IE KOCORB(K,I3) = NOCORB(K,I3) KELCSH(K,I3) = NELCSH(K,I3) 60 CONTINUE C C THE LAST SHELL HAS ONE ELECTRON. C KELCSH(IOC,I3) = 1 MAXOR = MAXORB + 1 KOCORB(IOC,I3) = MAXOR NJCOMP(MAXOR) = 999 C C THE CORRECT CHANNEL ANGULAR MOMENTUM IS FOUND. C L3 = LCONAT(IAA,IA) LJCOMP(MAXOR) = L3 C C THE ORBITAL AND SPIN ANGULAR MOMENTA OF THE LAST CONTINUUM C OCCUPIED SHELL ARE PUT IN APPROPRIATE PLACES. C K1QNRD(IOC,1,I3) = 1 K1QNRD(IOC,2,I3) = 2*L3 + 1 K1QNRD(IOC,3,I3) = 2 C END SUBROUTINE SETINI(IB,I4,IBB,L4) IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C PERFORMS ANALOGOUS OPERATIONS TO THOSE IN SUBROUTINE SETFIN C BUT LEADING TO AN INITIAL STATE CONFIGURATION. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXOCC1=MZOCC+1,MXOCC2=2*MZOCC+1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C COMMON /INITI/BIJ(MZTAR,MZNC1),MTCON(MZTAR), 1 MTYP(MZTAR,MZNC1),MAST, A MCONAT(MZTAR),KCONAT(MXL2,MZTAR),LLRGL,NNSPN,MPTY COMMON /MSTATE/MCFG,MOCCSH(MZNC2),MOCORB(MXOCC1,MZNC2), A MELCSH(MXOCC1,MZNC2),M1QNRD(MXOCC2,3,MZNC2),KCFG, B KOCCSH(MZNC2),KOCORB(MXOCC1,MZNC2),KELCSH(MXOCC1,MZNC2), C K1QNRD(MXOCC2,3,MZNC2),MAXOR COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C----------------------------------------------------------------------- IG = NOCCSH(I4) IG1 = 2*IG - 1 C C THE NUMBER OF OCCUPIED SHELLS IS INCREASED BY ONE TO ACCOMODATE C THE CONTINUUM STATE. C IOD = IG + 1 IOD1 = 2*IOD - 1 MOCCSH(I4) = IOD DO 20 J = 1,IG DO 10 K = 1,3 M1QNRD(J,K,I4) = J1QNRD(J,K,I4) 10 CONTINUE 20 CONTINUE C C IF IE1 EQUALS ONE THERE ARE NO COUPLED ANGULAR MOMENTA TO BE C SHIFTED. C IF (IG1.EQ.1) GOTO 50 DO 40 J = IOD,IG1 J1 = J + 1 DO 30 K = 1,3 C C SHIFT THE POSITIONS OF THE COUPLED ANGULAR MOMENTA TO THE C PROPER PLACES. C M1QNRD(J1,K,I4) = J1QNRD(J,K,I4) 30 CONTINUE 40 CONTINUE C C PUT THE TOTAL (N+1)-ELECTRON ORBITAL AND SPIN ANGULAR MOMENTA C INTO THE PROPER PLACES. C 50 CONTINUE M1QNRD(IOD1,1,I4) = 0 M1QNRD(IOD1,2,I4) = 2*LLRGL + 1 M1QNRD(IOD1,3,I4) = NNSPN DO 60 K = 1,IG MOCORB(K,I4) = NOCORB(K,I4) MELCSH(K,I4) = NELCSH(K,I4) 60 CONTINUE C C THE LAST SHELL HAS ONE ELECTRON. C MELCSH(IOD,I4) = 1 MAXOR = MAXORB + 2 MOCORB(IOD,I4) = MAXOR NJCOMP(MAXOR) = 999 C C THE CORRECT CHANNEL ANGULAR MOMENTUM IS FOUND. C L4 = KCONAT(IBB,IB) LJCOMP(MAXOR) = L4 C C THE ORBITAL AND SPIN ANGULAR MOMENTA OF THE LAST CONTINUUM C OCCUPIED SHELL ARE PUT IN APPROPRIATE PLACES. C M1QNRD(IOD,1,I4) = 1 M1QNRD(IOD,2,I4) = 2*L4 + 1 M1QNRD(IOD,3,I4) = 2 C END SUBROUTINE SETMX1 use basic2 use dipmel use memory IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 IM C C C C----------------------------------------------------------------------- C C EVALUATES THE (N+1)-ELECTRON HAMILTONIAN MATRIX HNP1 C C ALLOWS FOR ORDERING STATES ACCORDING TO SYMMETRY FOR EFFICIENCY C SKIPS REDUNDANT CODE FOR DW OPERATION ONLY AND EVALUATES ONLY C NMETA BY NAST INTERACTIONS FOR EFFICIENCY - NRB C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXICT=4*MZLR1*MZLR1*MZLR1*MZLR2*MZLR2) PARAMETER (MXKPOS=MZCHD+MZNC2/MZNR2) ! ARRAY BOUND FIX PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C PARAMETER (MXHNPS=MXDM1*MXDM2) !RETAIN AS BOUND ON ALLOCATE PARAMETER (MXNC1=MZNC1*MZNC1/10+2*MZNC1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), C 1 L2P(MZCHF),LSTARG(MZCHF), C A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/HNP1(MXDM2,MXDM1),HNPS(MXHNPS) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DW/ISTL,ISTR,NCHNL,NCHNR,ICL,ICR,IE,IG,ISYM(MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /DWMETA/NTARG(MZCHF),IMETA(MZTAR),NMETAS COMMON /DWNEW/KKDDW(MZOVL,MZOVL,2),KKEDW(MZOVL,MZOVL,2) X,KDPDW(MZNC1,MZNC1,MZOVL,MZOVL),KEPDW(MZNC1,MZNC1,MZOVL,MZOVL) X,KDPOS,KEPOS,TERMD(MXNC1,MZLR1),TERME(MXNC1,MZLR1) COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) C COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /RKSAVE/IRKBC,IRKCC(MZLR2,MZLR2,2),ICHUNK,ICT(MXICT),ITAPBC COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DIMENSION IA1(MZOCC),IA2(MZOCC),IB1(MZOCC),IB2(MZOCC) DIMENSION KPOS(MZCHD,MXKPOS) C SAVE ITSYM C DATA ITSYM/0/,ZERO/0.0D0/ C NRG2SQ=NRANG2**2 C----------------------------------------------------------------------- C C MAXN = MAXIMUM NUMBER OF RHS MATRIX ELEMENTS GENERATED INSIDE C THE LOOP OVER TARGET SYMMETRIES ON LHS. C THIS IS USED TO ESTIMATE THE MAX MEMORY NEEDED, BUT IS C ONLY THE ACTUAL UPPER LIMIT WHEN MAXN OCCURS FOR THE LAST C LHS TARGET SYMMTERY. IF MAXN .GT. MXMEM THEN C MAXSYM= MAXIMUM NUMBER OF TARGET STATES WHICH CAN BE PUT C INTO EACH SYMMETRY GROUP IN HNPS. THIS TAKES NO ACCOUNT C OF PARTIAL STORAGE IN MEMORY. C N.B. WE COULD ALLOW CODE TO ALLOCATE HNPS AS NEEDED, BUT C IT COULD GET UNEXPECTEDLY LARGE AND SINCE IT IS NOT C NECESSARY, WE RETAIN MXHNPS TO BOUND THE ALLOCATE. C BEST PRACTICE IS TO SET MXMEM AS LARGE AS POSSIBLE (VIA MZMEG). C C----------------------------------------------------------------------- c WRITE (IWRITE,3000) MAXN = 0 MAXSYM = 1 NPOSI = 0 DO 10 I = 1,NAST NLAST = NPOSI NPOSI = NTYP(I,1) IF (NPOSI.EQ.NLAST) THEN NCOUNT = NCOUNT + 1 MAXSYM = MAX(MAXSYM,NCOUNT) ELSE NCOUNT = 1 ENDIF MAXN = MAX(MAXN,NCOUNT*NCONAT(I)) 10 CONTINUE IF(IDWOUT.NE.2)THEN MAXN = MAXN*NRANG2*MAX(NCHAN*NRANG2,NCFGP) !MAXIMAL NEED=MEM1+MAXN !"NEED" TO AVOID POSS MAXSYM REDEF IF (NEED.GT.MXMEM) THEN WRITE (IWRITE,3160)1+NEED/1000000 IF(ITAPBC.GT.0)WRITE (IWRITE,3170) MXSYM0=MAXSYM MAXSYM = INT(SQRT(DBLE(MXHNPS)+0.1D0)/NRANG2) IF(MAXSYM.LT.MXSYM0)WRITE (IWRITE,3130) MAXSYM c write(iwrite,*)mrec1,mem1,maxn ENDIF ENDIF c need=0 !initial for actual da usage nuse=-mem1 !initial for memory usage C C ISYM(ITSYM)= NUMBER OF TARGET STATES FOR EACH SYMMETRY GROUP. C J = 0 NPOSI = 0 DO 20 I = 1,NAST NLAST = NPOSI NPOSI = NTYP(I,1) IF (NPOSI.EQ.NLAST) THEN IF (ISYM(J).LT.MAXSYM) THEN ISYM(J) = ISYM(J) + 1 GOTO 20 C ENDIF C ENDIF C J = J + 1 ISYM(J) = 1 20 CONTINUE IF (J.NE.ITSYM) WRITE (IWRITE,3120) J, (ISYM(I),I=1,J) ITSYM = J C C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF SETUP. C POSITION THE SCRATCH DISCS CONTAINING THE RADIAL INTEGRALS. C IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE. (ICOPY2-2)) GOTO 30 WRITE (IWRITE,3080) LTT1 = 0 LTT2 = 0 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EVALUATE THE CONTINUUM-CONTINUUM CONTRIBUTIONS TO HNP1 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 30 CONTINUE WRITE (IWRITE,3090) NROW = 0 NCF = 0 IF = 0 C C ---- OUTER LOOP OVER TARGET SYMMETRIES ON LHS OF MATRIX ELEMENT ---- C DO 400 IS = 1,ITSYM ISTL=IS !DW ONLY IE = IF + 1 IF = IF + ISYM(IS) IF (NCONAT(IE).LE.0) GOTO 400 NCS = NCF + 1 + (ISYM(IS)-1)*NCONAT(IE) NCF = NCS + NCONAT(IE) - 1 NTC = NTCON(IE) IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 200 C C INITIALIZE MEMORY (IM) AND DA FILE (NBLOCK) C IM = MEM1 NBLOCK = MREC1 LAST = 0 C C ---- LOOP OVER CHANNELS COUPLED TO CURRENT SYMMETRY ON LHS. C DO 190 NCH1 = NCS,NCF NCHNL=NCH1 !DW ONLY LOT1 = L2P(NCH1) + 1 MCF = 0 IH = 0 NCOL = 0 C C ---- LOOP OVER TARGET SYMMETRIES ON RHS. C ---- THE METASTABLES BELONG TO THE FIRST NMETAS SYMMETRY GROUPS. C DO 180 IT = 1,IS IF(IT.GT.NMETAS)GO TO 190 !DW ONLY ISTR=IT IG = IH + 1 IH = IH + ISYM(IT) IF (NCONAT(IG).LE.0) GOTO 180 MCS = MCF + 1 + (ISYM(IT)-1)*NCONAT(IG) MCF = MCS + NCONAT(IG) - 1 MTC = NTCON(IG) IF (IS.EQ.IT) MCF = NCH1 C C ---- LOOP OVER CHANNELS COUPLED TO CURRENT SYMMETRY ON RHS. C READ THE RK INTEGRALS FROM JDISC1 IF NECESSARY, AND SET POINTERS. C DO 170 NCH2 = MCS,MCF NCHNR=NCH2 LOT2 = L2P(NCH2) + 1 IF (LOT1.NE.LTT1 .OR. LOT2.NE.LTT2) CALL RDINT(2,LOT1, A LOT2) LTT1 = LOT1 LTT2 = LOT2 C IF(IDWOUT.EQ.2)GO TO 175 !DW ONLY C C LENGTH = NUMBER OF ELEMENTS IN MATRIX BLOCKS. INITIALIZE HERE C LENGTH = ISYM(IS)*ISYM(IT)*NRG2SQ IF (IM+LENGTH.GT.MXMEM) THEN if(allocated(hnps))deallocate(hnps) allocate(hnps(length),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HNPS' C DO 40 KK = 1,LENGTH HNPS(KK) = 0.D0 40 CONTINUE need=max(need,im+length) !actual C ELSE nuse=max(nuse,im+length) !actual DO 50 KK = IM + 1,IM + LENGTH ARRAY(KK) = 0.D0 50 CONTINUE ENDIF 175 IF(IDWOUT.GT.0)THEN !DW ONLY KDPOS=0 KEPOS=0 DO IJK4=1,MZOVL DO IJK3=1,MZOVL DO IJK2=1,MTC DO IJK1=1,NTC KDPDW(IJK1,IJK2,IJK3,IJK4)=0 KEPDW(IJK1,IJK2,IJK3,IJK4)=0 ENDDO ENDDO ENDDO ENDDO ENDIF C C ---- LOOP OVER CONFIGURATIONS WITH SAME SYMMETRY ON LHS, THEN RHS. C DO 160 IC1 = 1,NTC ICL=IC1 I = NTYP(IE,IC1) C CMIXL=AIJ(IE,IC1) DO 150 IC2 = 1,MTC ICR=IC2 C CMIXR=AIJ(IG,IC2) C IF(IDWBUG.GT.1)WRITE(20,777)IS,NCH1,IT,NCH2,IC1,IC2,IE,IG C 777 FORMAT(8I3) J = NTYP(IG,IC2) C C SET UP THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ, THEN SET J1QN C I4 = NOCCSH(I) I5 = NOCCSH(J) DO 60 I8 = 1,I4 IA1(I8) = NOCORB(I8,I) IB1(I8) = NELCSH(I8,I) 60 CONTINUE DO 70 I8 = 1,I5 IA2(I8) = NOCORB(I8,J) IB2(I8) = NELCSH(I8,J) 70 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C IB = NOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,3,1) IB = NOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,3,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITALS C IHSH = I3 + 2 I31 = I3 + 1 I32 = I3 + 2 I2M = 2*I3 + 2 I3M = 2*I3 + 3 LJ(I31) = L2P(NCH1) LJ(I32) = L2P(NCH2) NOSH(I31,1) = 1 NOSH(I32,1) = 0 NOSH(I31,2) = 0 NOSH(I32,2) = 1 J1QN(I31,1,1) = 1 J1QN(I31,2,1) = 2*LJ(I31) + 1 J1QN(I31,3,1) = 2 J1QN(I32,1,1) = 0 J1QN(I32,2,1) = 1 J1QN(I32,3,1) = 1 J1QN(I2M,1,1) = 0 J1QN(I2M,2,1) = 2*LRGL + 1 J1QN(I2M,3,1) = NSPN J1QN(I3M,1,1) = 0 J1QN(I3M,2,1) = 2*LRGL + 1 J1QN(I3M,3,1) = NSPN J1QN(I31,1,2) = 0 J1QN(I31,2,2) = 1 J1QN(I31,3,2) = 1 J1QN(I32,1,2) = 1 J1QN(I32,2,2) = 2*LJ(I32) + 1 J1QN(I32,3,2) = 2 IF (I3.LE.1) THEN J1QN(I2M,1,2) = 0 J1QN(I2M,2,2) = J1QN(1,2,2) J1QN(I2M,3,2) = J1QN(1,3,2) C ELSE J1QN(I2M,1,2) = 0 J1QN(I2M,2,2) = J1QN(2*I3+1,2,2) J1QN(I2M,3,2) = J1QN(2*I3+1,3,2) ENDIF C J1QN(I3M,1,2) = 0 J1QN(I3M,2,2) = 2*LRGL + 1 J1QN(I3M,3,2) = NSPN NJ(I31) = 999 NJ(I32) = 999 NDCT(1) = NRANG2 NDCT(2) = NRANG2 L6 = L2P(NCH1) + 1 DO 90 I4 = 1,2 NRANG1 = MAXNHF(L6) DO 80 I5 = 1,NRANG2 ND(I4,I5) = NRANG1 + I5 80 CONTINUE L6 = L2P(NCH2) + 1 90 CONTINUE IF (IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(3) C IF(IDWOUT.EQ.2)GO TO 150 !DW ONLY C C ---- LOOP OVER TARGET STATES WITH SAME SYMMETRY ON LHS, THEN RHS. C RESULT IN AME IS ADDED TO ALL RELEVENT HAMILTONIAN BLOCKS C DO 140 NS1 = IE,IF DO 130 NS2 = IG,IH A = AIJ(NS1,IC1)*AIJ(NS2,IC2) IF (A.EQ.ZERO) GOTO 130 K = NS1 - IE + 1 + ISYM(IS)* (NS2-IG) KK = (K-1)*NRG2SQ IF (IM+LENGTH.LE.MXMEM) KK = KK + IM C DO 120 J6 = 1,NRANG2 IF (IM+LENGTH.GT.MXMEM) THEN DO 100 I6 = 1,NRANG2 HNPS(KK+I6) = HNPS(KK+I6) + AME(I6,J6)*A 100 CONTINUE C ELSE DO 110 I6 = 1,NRANG2 ARRAY(KK+I6) = ARRAY(KK+I6) + AME(I6,J6)*A 110 CONTINUE ENDIF C KK = KK + NRANG2 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE C IF(IDWOUT.GT.0)CALL DWOUT3 !DW ONLY C IF(IDWOUT.EQ.2)GO TO 170 !DW ONLY C C WRITE HAMILTONIAN BLOCKS TO DA FILE IF NO SPACE IN MEMORY C KPOS = DA RECORD NUMBER, OR -VE FOR MEMORY LOCATION. C IF (IM+LENGTH.GT.MXMEM) THEN KPOS(NCH1,NCH2) = ABS(NBLOCK) LAST = KPOS(NCH1,NCH2) CALL DA2(2,NBLOCK,IDISC1,LENGTH,HNPS) IF (MREC1.EQ.-1) MREC1 = 1 C ELSE KPOS(NCH1,NCH2) = -IM IM = IM + LENGTH ENDIF C 170 CONTINUE 180 CONTINUE 190 CONTINUE C IF(IDWOUT.EQ.2) GO TO 400 !DW ONLY C C ---- END OF LOOPS FOR WRITING TO DIRECT ACCESS FILE. C C READ THE HAMILTONIAN BLOCKS FROM DIRECT ACCESS FILE AND ORDER C ON SEQUENTIAL OUTPUT TAPE C C ---- LOOP OVER STATES, THEN CHANNELS, WITH SAME TARGET SYMMETRY ON LHS C 200 CONTINUE DO 390 NS1 = IE,IF DO 380 NCH1 = NCS,NCF NROW = NROW + 1 NCOL = 0 MCF = 0 IH = 0 C C ---- LOOP OVER TARGET SYMMETRIES ON RHS. C DO 370 IT = 1,IS IG = IH + 1 IH = IH + ISYM(IT) IF (NCONAT(IG).LE.0) GOTO 370 MCS = MCF + 1 + (ISYM(IT)-1)*NCONAT(IG) MCF = MCS + NCONAT(IG) - 1 IF (IS.EQ.IT) IH = NS1 C C ---- LOOP OVER STATES, THEN CHANNELS, WITH SAME TARGET SYMMETRY ON RHS C DO 360 NS2 = IG,IH IF (NS1.EQ.NS2) MCF = NCH1 DO 350 NCH2 = MCS,MCF NCOL = NCOL + 1 IF (ICOUNT.GE.ICOPY1 .AND. A ICOUNT.LE.ICOPY2) GOTO 310 ITRANS = NCH1 - NCH2 IF (ITRANS.GE.0) THEN K = NS1 - IE + 1 + ISYM(IS)* (NS2-IG) KOUNT = KPOS(NCH1,NCH2) C ELSE C WHEN BOTH SIDES OF THE MATRIX ELEMENT HAVE STATES OF SAME SYMMETRY C BUT DIFFERENT CHANNEL ANGULAR MOMENTA, THE MATRIX ELEMENTS ARE C CALCULATED ABOVE WITH LHS CHANNEL L .GE. RHS CHANNEL L. C BUT THE ORDERING BELOW ON THE OUTPUT FILE ASSUMES THAT THE LHS C STATE .GE. RHS STATE. C SO CASES WILL OCCUR WHEN THE CHANNEL COUPLED TO THE LHS STATE C HAS A LOWER L THAN THE CHANNEL COUPLED TO THE RHS STATE C (IE. NCH1.LT.NCH2). C IN THIS CASE JUST RETRIEVE THE REVERSE OF THE MATRIX ELEMENT, C IE. SWAP NS1/NS2 AND NCH1/NCH2 AND TRANSPOSE THE H-MATRIX BLOCK. C THIS LOOKS "INEFFICIENT" AS LOOPING IS ALONG MATRIX ROWS, BUT C THE MATRIX IS SMALL - RANK NRANG2 - AND THIS SITUATION OCCURS C RARELY SINCE IT IS ON DIAGONAL BLOCKS ONLY. NRB K = NS2 - IE + 1 + ISYM(IS)* (NS1-IG) KOUNT = KPOS(NCH2,NCH1) ENDIF C C READ APPROPRIATE BLOCK FROM DA FILE OR MEMORY INTO HNPS, C THEN COPY INTO HNP1 AND WRITE OUT. C IF (KOUNT.GT.0 .AND. KOUNT.NE.LAST) THEN LENGTH = ISYM(IS)*ISYM(IT)*NRG2SQ if(allocated(hnps))deallocate(hnps) allocate(hnps(length),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HNPS' C LAST = KOUNT CALL DA2(1,KOUNT,IDISC1,LENGTH,HNPS) ENDIF C KK = (K-1)*NRG2SQ IF (KOUNT.LE.0) KK = KK - KOUNT IF (L2P(NCH1).EQ.L2P(NCH2) .AND. A NROW.NE.NCOL) GOTO 270 IF (ITRANS.GE.0) THEN DO 230 I6 = 1,NRANG2 IF (KOUNT.GT.0) THEN DO 210 J6 = 1,NRANG2 HNP1(J6,I6) = HNPS(KK+J6) 210 CONTINUE C ELSE DO 220 J6 = 1,NRANG2 HNP1(J6,I6) = ARRAY(KK+J6) 220 CONTINUE ENDIF C KK = KK + NRANG2 230 CONTINUE C ELSE DO 260 I6 = 1,NRANG2 IF (KOUNT.GT.0) THEN DO 240 J6 = 1,NRANG2 HNP1(I6,J6) = HNPS(KK+J6) 240 CONTINUE C ELSE DO 250 J6 = 1,NRANG2 HNP1(I6,J6) = ARRAY(KK+J6) 250 CONTINUE ENDIF C KK = KK + NRANG2 260 CONTINUE ENDIF C GOTO 320 C 270 CONTINUE DO 300 I6 = 1,NRANG2 IF (KOUNT.GT.0) THEN C **** IN THE NEXT STATEMENTS, HNP1(J6,I6) CORRESPONDS TO THE 1974 AND C 1978 CPC VERSIONS. BUT THESE CPC VERSIONS CONTAIN A 'TRANSPOSING' C ERROR IN STG2 WHICH WAS CORRECTED BY A FIX IN SUBROUTINE TAPERD C IN THE CORRESPONDING CPC VERSIONS OF STG3. C SINCE THE ERROR IS ACTUALLY IN STG2, IT WOULD BE MORE CONSISTENT C TO ALTER THE NEXT STATEMENTS TO HNP1(I6,J6) AND TO REMOVE THE FIX C IN STGH. DO 280 J6 = 1,NRANG2 HNP1(J6,I6) = HNPS(KK+J6) 280 CONTINUE C ELSE DO 290 J6 = 1,NRANG2 HNP1(J6,I6) = ARRAY(KK+J6) 290 CONTINUE ENDIF C KK = KK + NRANG2 300 CONTINUE GOTO 320 C 310 CONTINUE READ (ITAPE2) ((HNP1(I6,J6),J6=1,NRANG2),I6=1,NRANG2) 320 CONTINUE WRITE (ITAPE3) ((HNP1(I6,J6),J6=1,NRANG2),I6=1,NRANG2) IF (IBUG9.LT.3) GOTO 350 WRITE (IWRITE,3010) NROW,NCOL JLO = 1 IMA = 8 330 CONTINUE JUP = MIN(IMA,NRANG2) DO 340 III = 1,NRANG2 WRITE (IWRITE,3020) (HNP1(III,JJJ),JJJ=JLO,JUP) 340 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3030) IF (JLO.LE.NRANG2) GOTO 330 350 CONTINUE 360 CONTINUE 370 CONTINUE 380 CONTINUE 390 CONTINUE 400 CONTINUE C IF(IDWOUT.EQ.2) GO TO 730 !DW ONLY C C ---- END OF OUTER LOOP OVER TARGET SYMMETRIES ON LHS ---- C LTT1 = 0 WRITE (IWRITE,3100) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 720 ICOUNT = ICOUNT + 1 C CBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCB C C NOW EVALUATE THE CONTINUUM-BOUND CONTRIBUTION TO HNP1 C CBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCB C IF (NCFGP.LE.0 .OR. NCHAN.LE.0) GOTO 650 WRITE (IWRITE,3040) C C READ IN THE BOUND-CONTINUUM INTEGRALS FROM FILE JDISC1. C CALL RDINT(1,0,0) NROW = 0 NCF = 0 IF = 0 C C ---- OUTER LOOP OVER TARGET SYMMETRIES ON LHS OF MATRIX ELEMENT ---- C DO 640 IS = 1,ITSYM ISTL=IS IE = IF + 1 IF = IF + ISYM(IS) IF (NCONAT(IE).LE.0) GOTO 640 NCS = NCF + 1 + (ISYM(IS)-1)*NCONAT(IE) NCF = NCS + NCONAT(IE) - 1 NTC = NTCON(IE) IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 530 C C INITIALIZE MEMORY (IM) AND DA FILE (NBLOCK) C IM = MEM1 NBLOCK = MREC1 LAST = 0 C C ---- LOOP OVER CHANNELS COUPLED TO CURRENT SYMMETRY ON LHS. C DO 520 NCH1 = NCS,NCF NCHNL=NCH1 LOT1 = L2P(NCH1) + 1 I2 = 0 C C HNPS CAN IN GENERAL ONLY CARRY PART OF THE B-C SECTION C OF THE MATRIX (SINCE THE NUMBER OF BOUND TERMS MAY EXCEED THE C NUMBER OF CONTINUUM TERMS). THE MATRIX IS THEN FILLED AND C EMPTIED INTO THE DA FILE SEVERAL TIMES. C ---- LOOP OVER NTIMES, THE NUMBER OF TIMES THIS HAS TO BE DONE. C NTIMES = 1 + (NCFGP-1)/NRANG2 DO 510 II = 1,NTIMES I1 = I2 + 1 I2 = MIN(II*NRANG2,NCFGP) C C LENGTH = NUMBER OF ELEMENTS IN MATRIX BLOCKS, INITIALIZE HERE C LENGTH = ISYM(IS)* (I2-I1+1)*NRANG2 IF (IM+LENGTH.GT.MXMEM) THEN if(allocated(hnps))deallocate(hnps) allocate(hnps(length),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HNPS' C DO 410 KK = 1,LENGTH HNPS(KK) = 0.D0 410 CONTINUE need=max(need,im+length) !actual C ELSE nuse=max(nuse,im+length) !actual DO 420 KK = IM + 1,IM + LENGTH ARRAY(KK) = 0.D0 420 CONTINUE ENDIF C C ---- LOOP OVER BOUND TERMS FOR THIS LOOP OF II. C DO 500 J = I1,I2 ICR=J J9 = J - I1 + 1 C C ---- LOOP OVER CONFIGURATIONS WITH SAME SYMMETRY ON LHS. C DO 490 IC1 = 1,NTC ICL=IC1 C CMIXL=AIJ(IE,ICL) I = NTYP(IE,IC1) C C SET THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ, AND SET J1QN C I4 = IOCCSH(J) I5 = NOCCSH(I) DO 430 I8 = 1,I4 IA1(I8) = IOCORB(I8,J) IB1(I8) = IELCSH(I8,J) 430 CONTINUE DO 440 I8 = 1,I5 IA2(I8) = NOCORB(I8,I) IB2(I8) = NELCSH(I8,I) 440 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C IB = IOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,2,1) IB = NOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,2,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITAL C IHSH = I3 + 1 I31 = I3 + 1 I1M = 2*I3 + 1 LJ(I31) = L2P(NCH1) NOSH(I31,1) = 0 NOSH(I31,2) = 1 J1QN(I31,1,1) = 0 J1QN(I31,2,1) = 1 J1QN(I31,3,1) = 1 J1QN(I1M,1,1) = 0 J1QN(I1M,2,1) = 2*LRGL + 1 J1QN(I1M,3,1) = NSPN J1QN(I31,1,2) = 1 J1QN(I31,2,2) = 2*LJ(I31) + 1 J1QN(I31,3,2) = 2 J1QN(I1M,1,2) = 0 J1QN(I1M,2,2) = 2*LRGL + 1 J1QN(I1M,3,2) = NSPN NJ(I31) = 999 NDCT(1) = 0 NDCT(2) = NRANG2 ND(1,1) = 0 L6 = L2P(NCH1) + 1 NRANG1 = MAXNHF(L6) DO 450 I5 = 1,NRANG2 ND(2,I5) = NRANG1 + I5 450 CONTINUE IF (IBUG9.GE.4) CALL PNTBG2(J,I) CALL MATANS(2) C C ---- LOOP OVER TARGET STATES WITH SAME SYMMETRY ON LHS. C RESULT IN AME IS ADDED TO ALL RELEVENT HAMILTONIAN BLOCKS C DO 480 NS1 = IE,IF A = AIJ(NS1,IC1) IF (A.EQ.ZERO) GOTO 480 K = NS1 - IE + 1 KK = (K-1)* (I2-I1+1)*NRANG2 + (J9-1)*NRANG2 C IF (IM+LENGTH.GT.MXMEM) THEN DO 460 I6 = 1,NRANG2 HNPS(KK+I6) = HNPS(KK+I6) + AME(1,I6)*A 460 CONTINUE C ELSE KK = KK + IM DO 470 I6 = 1,NRANG2 ARRAY(KK+I6) = ARRAY(KK+I6) + AME(1,I6)*A 470 CONTINUE ENDIF C 480 CONTINUE 490 CONTINUE 500 CONTINUE C C WRITE HAMILTONIAN BLOCKS TO DA FILE IF NO SPACE IN MEMORY C IF (IM+LENGTH.GT.MXMEM) THEN KPOS(NCH1,II) = ABS(NBLOCK) LAST = KPOS(NCH1,II) CALL DA2(2,NBLOCK,IDISC1,LENGTH,HNPS) IF (MREC1.EQ.-1) MREC1 = 1 C ELSE KPOS(NCH1,II) = -IM IM = IM + LENGTH ENDIF C 510 CONTINUE 520 CONTINUE C C ---- END OF LOOPS FOR WRITING TO DIRECT ACCESS FILE. C C READ THE HAMILTONIAN BLOCKS FROM DIRECT ACCESS FILE AND ORDER C ON SEQUENTIAL OUTPUT TAPE C C ---- LOOP OVER STATES, THEN CHANNELS, FOR SAME TAGET SYMMETRY ON LHS C 530 CONTINUE DO 630 NS1 = IE,IF DO 620 NCH1 = NCS,NCF NROW = NROW + 1 I2 = 0 IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 580 C C ---- LOOP OVER NTIMES, AND THEN THE NUMBER OF BOUND TERMS. C DO 570 II = 1,NTIMES I1 = I2 + 1 I2 = MIN(II*NRANG2,NCFGP) DO 560 J = I1,I2 J9 = J - I1 + 1 K = NS1 - IE + 1 KOUNT = KPOS(NCH1,II) C C READ APPROPRIATE BLOCKS FROM DA FILE OR MEMORY INTO HNPS, C THEN COPY INTO HNP1 AND WRITE OUT. C IF (KOUNT.GT.0 .AND. KOUNT.NE.LAST) THEN LENGTH = ISYM(IS)* (I2-I1+1)*NRANG2 if(allocated(hnps))deallocate(hnps) allocate(hnps(length),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HNPS' C LAST = KOUNT CALL DA2(1,KOUNT,IDISC1,LENGTH,HNPS) ENDIF C KK = (K-1)* (I2-I1+1)*NRANG2 + (J9-1)*NRANG2 IF (KOUNT.GT.0) THEN DO 540 I6 = 1,NRANG2 HNP1(I6,J) = HNPS(KK+I6) 540 CONTINUE C ELSE KK = KK - KOUNT DO 550 I6 = 1,NRANG2 HNP1(I6,J) = ARRAY(KK+I6) 550 CONTINUE ENDIF C 560 CONTINUE 570 CONTINUE GOTO 590 C 580 CONTINUE READ (ITAPE2) ((HNP1(I6,J),J=1,NCFGP),I6=1,NRANG2) 590 CONTINUE WRITE (ITAPE3) ((HNP1(I6,J),J=1,NCFGP),I6=1,NRANG2) C IF (IBUG9.LT.2 .OR. (ICOUNT.GE.ICOPY1.AND. A ICOUNT.LE.ICOPY2)) GOTO 620 WRITE (IWRITE,3050) NROW JLO = 1 IMA = 8 600 CONTINUE JUP = MIN(IMA,NCFGP) DO 610 III = 1,NRANG2 WRITE (IWRITE,3020) (HNP1(III,JJJ),JJJ=JLO,JUP) 610 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3030) IF (JLO.LE.NCFGP) GOTO 600 620 CONTINUE 630 CONTINUE 640 CONTINUE C C ---- END OF OUTER LOOP OVER TARGET SYMMETRIES ON LHS ---- C 650 CONTINUE C WRITE (IWRITE,3100) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 730 ICOUNT = ICOUNT + 1 C CBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB C C NOW EVALUATE THE BOUND-BOUND CONTRIBUTION TO HNP1 C CBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB C IF (NCFGP.LE.0 .OR. NCHAN.LE.0) GOTO 720 WRITE (IWRITE,3060) DO 710 I = 1,NCFGP IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 690 I1 = NCONHP + I DO 680 J = I,NCFGP C C SET NJ AND LJ, THEN SET J1QN C I4 = IOCCSH(I) I5 = IOCCSH(J) DO 660 I8 = 1,I4 IA1(I8) = IOCORB(I8,I) IB1(I8) = IELCSH(I8,I) 660 CONTINUE DO 670 I8 = 1,I5 IA2(I8) = IOCORB(I8,J) IB2(I8) = IELCSH(I8,J) 670 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C IB = IOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,1,1) IB = IOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,1,2) C C SET REMAINING QUANTITIES FOR MATRIX C IHSH = I3 NDCT(1) = 0 NDCT(2) = 0 IF (IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(1) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C HNP1(1,J) = AME(1,1) 680 CONTINUE GOTO 700 C 690 CONTINUE READ (ITAPE2) (HNP1(1,J),J=I,NCFGP) 700 CONTINUE WRITE (ITAPE3) (HNP1(1,J),J=I,NCFGP) IF (IBUG9.LT.1 .OR. (ICOUNT.GE.ICOPY1.AND. A ICOUNT.LE.ICOPY2)) GOTO 710 WRITE (IWRITE,3070) I WRITE (IWRITE,3020) (HNP1(1,J),J=I,NCFGP) 710 CONTINUE 720 CONTINUE WRITE (IWRITE,3100) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 730 ICOUNT = ICOUNT + 1 GO TO 740 C C WRITE TO ITAPE3 COMPLETED C 730 CONTINUE IF (ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE (IWRITE,3110) C 740 CONTINUE if(allocated(hnps))deallocate(hnps) c c this is the actual "need" but if user sets mzmeg to this, mxhnps may c still trigger reduction of maxsym, so set to initial NEED - NRB. c if(need.gt.0)then c write(iwrite,*)'actual da need=',need !includes mem1 c write(0,*)need,1+need/1000000 c endif c if(nuse.gt.0)then !excludes mem1 nuse=min(1+nuse/1000000,mzmeg) if(itapbc.gt.0)then write(IWRITE,3140)nuse else write(IWRITE,3150)nuse endif endif c RETURN C 3000 FORMAT (//30X,'SUBROUTINE SETMX1'/30X,17 ('-')) 3010 FORMAT (//5X,' CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I4,' AND CHANNEL',I4/) 3020 FORMAT (10F13.7) 3030 FORMAT (//) 3040 FORMAT (/' ENTER CONTINUUM BOUND LOOP OF SETMX1') 3050 FORMAT (//5X,' BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I4/) 3060 FORMAT (/' ENTER BOUND BOUND LOOP OF SETMX1') 3070 FORMAT (/5X,' BOUND-BOUND CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CONFIGURATION',I4) 3080 FORMAT (//' CALCULATE AND STORE ON THE OUTPUT FILE THE', A ' HAMILTONIAN MATRIX') 3090 FORMAT (/' ENTER CONTINUUM-CONTINUUM LOOP OF SETMX1') 3100 FORMAT (' FILE POSITION',I4,' HAS BEEN REACHED') 3110 FORMAT (//' WRITE TO ITAPE3 COMPLETED') 3120 FORMAT (/' THERE ARE',I5,' TARGET SYMMETRIES WITH', A ' THE FOLLOWING NUMBER OF STATES IN EACH SYMMETRY'/ (20I4)) 3130 FORMAT (/' COMMENT - DIMENSIONS WILL ALLOW ONLY UP TO',I3, A ' STATES IN EACH SYMMETRY GROUP') 3140 FORMAT (' HAMILTIONIAN STORAGE IN MEMORY USAGE =',I5,' MWORDS') 3150 FORMAT (' RK.DAT + HAMILTIONIAN STORAGE IN MEMORY USAGE =',I5, X ' MWORDS') 3160 FORMAT (/' *** TO IMPROVE I/O EFFICIENCY, INCREASE MZMEG TO',I5) 3170 FORMAT (' (N.B. IF THIS CAUSES RK.DAT TO BE STORED IN MEMORY,', X ' THEN ADD THAT MEMORY TO THE ABOVE)') END SUBROUTINE SETMXR use basic2 use dipmel IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C EVALUATES THE (N+1)-ELECTRON HAMILTONIAN MATRIX HNP1 C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C C MXDM2 = MAX(MZCHF,MZNR2) C PARAMETER(MXD1=MZCHD/MZNR2,MXD2=MZNR2/MZCHD, A MXD3=MXD1+MXD2, B MXDM2=MZCHD*MXD1/MXD3+MZNR2*MXD2/MXD3+1) C C MXDM1 = MAX(MXDM2,MZNC2) C PARAMETER(MXD4=MZNC2/MXDM2,MXD5=MXDM2/MZNC2, A MXD6=MXD4+MXD5, B MXDM1=MZNC2*MXD4/MXD6+MXDM2*MXD5/MXD6) C C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 C COMMON /DIPMEL/HNP1(MXDM2,MXDM1),DUMMY(MXDM2,MXDM1) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DW/ISTL,ISTR,NCHNL,NCHNR,ICL,ICR,IE,IG,ISYM(MZTAR) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /ELEMS/AME(MZNR2,MZNR2),ND(2,MZNR2),NDCT(2) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C DIMENSION IA1(MZOCC),IA2(MZOCC),IB1(MZOCC),IB2(MZOCC) C DATA ZERO/0.0D0/ C----------------------------------------------------------------------- WRITE (IWRITE,3000) C C AVOID EVALUATING A-MX AGAIN IN ODH0 C ISTL = 0 C C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF SETUP. C POSITION THE SCRATCH DISCS CONTAINING THE RADIAL INTEGRALS. C IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE. (ICOPY2-2)) GOTO 10 WRITE (IWRITE,3080) LTT1 = 0 LTT2 = 0 C C EVALUATE THE CONTINUUM-CONTINUUM CONTRIBUTIONS TO HNP1 C 10 CONTINUE WRITE (IWRITE,3090) NCF = 0 DO 210 NS1 = 1,NAST IF (NCONAT(NS1).LE.0) GOTO 210 NTC = NTCON(NS1) NCS = NCF + 1 NCF = NCF + NCONAT(NS1) DO 200 NCH1 = NCS,NCF LOT1 = L2P(NCH1) + 1 MCF = 0 DO 190 NS2 = 1,NS1 IF (NCONAT(NS2).LE.0) GOTO 190 MCS = MCF + 1 MCF = MCF + NCONAT(NS2) IF (NS1.EQ.NS2) MCF = NCH1 MTC = NTCON(NS2) DO 180 NCH2 = MCS,MCF IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 120 LOT2 = L2P(NCH2) + 1 C C READ THE RK INTEGRALS FROM FILE JDISC1. C IF (LOT1.NE.LTT1 .OR. LOT2.NE.LTT2) CALL RDINT(2,LOT1, A LOT2) LTT1 = LOT1 LTT2 = LOT2 DO 30 IK = 1,NRANG2 DO 20 JK = 1,NRANG2 HNP1(IK,JK) = 0.0D0 20 CONTINUE 30 CONTINUE DO 110 IC1 = 1,NTC IF (AIJ(NS1,IC1).EQ.ZERO) GOTO 110 I = NTYP(NS1,IC1) DO 100 IC2 = 1,MTC IF (AIJ(NS2,IC2).EQ.ZERO) GOTO 100 J = NTYP(NS2,IC2) C C SET UP THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ, THEN SET J1QN C I4 = NOCCSH(I) I5 = NOCCSH(J) DO 40 I8 = 1,I4 IA1(I8) = NOCORB(I8,I) IB1(I8) = NELCSH(I8,I) 40 CONTINUE DO 50 I8 = 1,I5 IA2(I8) = NOCORB(I8,J) IB2(I8) = NELCSH(I8,J) 50 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C IB = NOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,3,1) IB = NOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,3,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITALS C IHSH = I3 + 2 I31 = I3 + 1 I32 = I3 + 2 I2M = 2*I3 + 2 I3M = 2*I3 + 3 LJ(I31) = L2P(NCH1) LJ(I32) = L2P(NCH2) NOSH(I31,1) = 1 NOSH(I32,1) = 0 NOSH(I31,2) = 0 NOSH(I32,2) = 1 J1QN(I31,1,1) = 1 J1QN(I31,2,1) = 2*LJ(I31) + 1 J1QN(I31,3,1) = 2 J1QN(I32,1,1) = 0 J1QN(I32,2,1) = 1 J1QN(I32,3,1) = 1 J1QN(I2M,1,1) = 0 J1QN(I2M,2,1) = 2*LRGL + 1 J1QN(I2M,3,1) = NSPN J1QN(I3M,1,1) = 0 J1QN(I3M,2,1) = 2*LRGL + 1 J1QN(I3M,3,1) = NSPN J1QN(I31,1,2) = 0 J1QN(I31,2,2) = 1 J1QN(I31,3,2) = 1 J1QN(I32,1,2) = 1 J1QN(I32,2,2) = 2*LJ(I32) + 1 J1QN(I32,3,2) = 2 IF (I3.LE.1) THEN J1QN(I2M,1,2) = 0 J1QN(I2M,2,2) = J1QN(1,2,2) J1QN(I2M,3,2) = J1QN(1,3,2) C ELSE J1QN(I2M,1,2) = 0 J1QN(I2M,2,2) = J1QN(2*I3+1,2,2) J1QN(I2M,3,2) = J1QN(2*I3+1,3,2) ENDIF C J1QN(I3M,1,2) = 0 J1QN(I3M,2,2) = 2*LRGL + 1 J1QN(I3M,3,2) = NSPN NJ(I31) = 999 NJ(I32) = 999 NDCT(1) = NRANG2 NDCT(2) = NRANG2 L6 = L2P(NCH1) + 1 DO 70 I4 = 1,2 NRANG1 = MAXNHF(L6) DO 60 I5 = 1,NRANG2 ND(I4,I5) = NRANG1 + I5 60 CONTINUE L6 = L2P(NCH2) + 1 70 CONTINUE IF (IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(3) C IF(IDWOUT.EQ.2)GO TO 100 !B.P. C C RESULT IN AME IS STORED IN HNP1 MATRIX C A = AIJ(NS1,IC1)*AIJ(NS2,IC2) DO 90 I6 = 1,NRANG2 DO 80 J6 = 1,NRANG2 HNP1(I6,J6) = HNP1(I6,J6) + A*AME(I6,J6) 80 CONTINUE 90 CONTINUE C C RETURN TO SET UP THE NEXT MATRIX ELEMENT C 100 CONTINUE 110 CONTINUE C IF(IDWOUT.EQ.2)GO TO 180 !B.P. C C DUE TO ERROR IN STG2R THIS LOWER HALF BLOCK HAS BEEN CALCULATED C AS ITS TRANSPOSE. TO BE CONSISTENT WITH THE OTHER BLOCKS C WE WRITE OUT ITS TRANSPOSE. C IF (L2P(NCH1).EQ.L2P(NCH2)) GOTO 130 WRITE (ITAPE3) ((HNP1(J6,I6),J6=1,NRANG2),I6=1,NRANG2) GOTO 140 C 120 CONTINUE READ (ITAPE2) ((HNP1(I6,J6),J6=1,NRANG2),I6=1,NRANG2) 130 CONTINUE WRITE (ITAPE3) ((HNP1(I6,J6),J6=1,NRANG2),I6=1,NRANG2) 140 CONTINUE IF (IBUG9.LT.3 .OR. (ICOUNT.GE.ICOPY1.AND. A ICOUNT.LE.ICOPY2)) GOTO 180 WRITE (IWRITE,3010) NCH1,NCH2 JLO = 1 IMA = 8 150 CONTINUE JUP = MIN(IMA,NRANG2) DO 160 III = 1,NRANG2 IF (L2P(NCH1).EQ.L2P(NCH2)) WRITE (IWRITE, A 3020) (HNP1(III,JJJ),JJJ=JLO,JUP) IF (L2P(NCH1).NE.L2P(NCH2)) WRITE (IWRITE, A 3020) (HNP1(JJJ,III),JJJ=JLO,JUP) 160 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3030) IF (JLO.LE.NRANG2) GOTO 150 180 CONTINUE 190 CONTINUE 200 CONTINUE 210 CONTINUE C IF(IDWOUT.EQ.2)GO TO 470 !B.P. C LTT1 = 0 WRITE (IWRITE,3100) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 470 ICOUNT = ICOUNT + 1 C C NOW EVALUATE THE CONTINUUM-BOUND CONTRIBUTION TO HNP1 C IF (NCFGP.LE.0 .OR. NCHAN.LE.0) GOTO 380 WRITE (IWRITE,3040) C C READ IN THE BOUND-CONTINUUM INTEGRALS FROM FILE JDISC1 C CALL RDINT(1,0,0) NCF = 0 DO 370 NS1 = 1,NAST IF (NCONAT(NS1).LE.0) GOTO 370 NTC = NTCON(NS1) NCS = NCF + 1 NCF = NCF + NCONAT(NS1) DO 360 NCH1 = NCS,NCF IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 320 LOT1 = L2P(NCH1) + 1 DO 250 IK = 1,NRANG2 DO 240 JK = 1,NCFGP HNP1(IK,JK) = 0.0D0 240 CONTINUE 250 CONTINUE DO 310 IC1 = 1,NTC IF (AIJ(NS1,IC1).EQ.ZERO) GOTO 310 I = NTYP(NS1,IC1) DO 300 J = 1,NCFGP C C SET THE BOUND ORBITAL CONTRIBUTION TO NJ AND LJ, THEN SET J1QN C I4 = IOCCSH(J) I5 = NOCCSH(I) DO 260 I8 = 1,I4 IA1(I8) = IOCORB(I8,J) IB1(I8) = IELCSH(I8,J) 260 CONTINUE DO 270 I8 = 1,I5 IA2(I8) = NOCORB(I8,I) IB2(I8) = NELCSH(I8,I) 270 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C IB = IOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,2,1) IB = NOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,2,2) C C AUGMENT NJ,LJ,NOSH AND J1QN TO INCLUDE CONTINUUM ORBITAL C IHSH = I3 + 1 I31 = I3 + 1 I1M = 2*I3 + 1 LJ(I31) = L2P(NCH1) NOSH(I31,1) = 0 NOSH(I31,2) = 1 J1QN(I31,1,1) = 0 J1QN(I31,2,1) = 1 J1QN(I31,3,1) = 1 J1QN(I1M,1,1) = 0 J1QN(I1M,2,1) = 2*LRGL + 1 J1QN(I1M,3,1) = NSPN J1QN(I31,1,2) = 1 J1QN(I31,2,2) = 2*LJ(I31) + 1 J1QN(I31,3,2) = 2 J1QN(I1M,1,2) = 0 J1QN(I1M,2,2) = 2*LRGL + 1 J1QN(I1M,3,2) = NSPN NJ(I31) = 999 NDCT(1) = 0 NDCT(2) = NRANG2 ND(1,1) = 0 L6 = L2P(NCH1) + 1 NRANG1 = MAXNHF(L6) DO 280 I5 = 1,NRANG2 ND(2,I5) = NRANG1 + I5 280 CONTINUE IF (IBUG9.GE.4) CALL PNTBG2(J,I) CALL MATANS(2) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C DO 290 I6 = 1,NRANG2 HNP1(I6,J) = HNP1(I6,J) + AME(1,I6)*AIJ(NS1,IC1) 290 CONTINUE 300 CONTINUE 310 CONTINUE GOTO 330 C 320 CONTINUE READ (ITAPE2) ((HNP1(I6,J),J=1,NCFGP),I6=1,NRANG2) 330 CONTINUE WRITE (ITAPE3) ((HNP1(I6,J),J=1,NCFGP),I6=1,NRANG2) IF (IBUG9.LT.2 .OR. (ICOUNT.GE.ICOPY1.AND. A ICOUNT.LE.ICOPY2)) GOTO 360 WRITE (IWRITE,3050) NCH1 JLO = 1 IMA = 8 340 CONTINUE JUP = MIN(IMA,NCFGP) DO 350 III = 1,NRANG2 WRITE (IWRITE,3020) (HNP1(III,JJJ),JJJ=JLO,JUP) 350 CONTINUE JLO = JLO + 8 IMA = IMA + 8 WRITE (IWRITE,3030) IF (JLO.LE.NCFGP) GOTO 340 360 CONTINUE 370 CONTINUE 380 CONTINUE WRITE (IWRITE,3100) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 470 ICOUNT = ICOUNT + 1 C C NOW EVALUATE THE BOUND-BOUND CONTRIBUTION TO HNP1 C IF (NCFGP.LE.0 .OR. NCHAN.LE.0) GOTO 460 WRITE (IWRITE,3060) DO 450 I = 1,NCFGP IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) GOTO 430 DO 420 J = I,NCFGP C C SET NJ AND LJ, THEN SET J1QN C I4 = IOCCSH(I) I5 = IOCCSH(J) DO 400 I8 = 1,I4 IA1(I8) = IOCORB(I8,I) IB1(I8) = IELCSH(I8,I) 400 CONTINUE DO 410 I8 = 1,I5 IA2(I8) = IOCORB(I8,J) IB2(I8) = IELCSH(I8,J) 410 CONTINUE CALL NJLJOD(I3,I4,I5,IA1,IA2,IB1,IB2) C IB = IOCCSH(I) + 1 CALL SJ1QNT(I,IB,I3,1,1) IB = IOCCSH(J) + 1 CALL SJ1QNT(J,IB,I3,1,2) C C SET REMAINING QUANTITIES FOR MATRIX C IHSH = I3 NDCT(1) = 0 NDCT(2) = 0 IF (IBUG9.GE.4) CALL PNTBG2(I,J) CALL MATANS(1) C C MATRIX ELEMENTS IN AME NOW STORED IN HNP1 MATRIX C HNP1(1,J) = AME(1,1) 420 CONTINUE GOTO 440 C 430 CONTINUE READ (ITAPE2) (HNP1(1,J),J=I,NCFGP) 440 CONTINUE WRITE (ITAPE3) (HNP1(1,J),J=I,NCFGP) IF (IBUG9.LT.1 .OR. (ICOUNT.GE.ICOPY1.AND. A ICOUNT.LE.ICOPY2)) GOTO 450 WRITE (IWRITE,3070) I WRITE (IWRITE,3020) (HNP1(1,J),J=I,NCFGP) 450 CONTINUE 460 CONTINUE WRITE (IWRITE,3100) ICOUNT IF (ICOUNT.GE.ITOTAL) GOTO 470 ICOUNT = ICOUNT + 1 GOTO 480 C C WRITE TO ITAPE3 COMPLETED C 470 CONTINUE IF (ICOPY2.GT.0) REWIND ITAPE2 REWIND ITAPE3 WRITE (IWRITE,3110) 480 CONTINUE C 3000 FORMAT (/30X,'SUBROUTINE SETMXR'/30X,17 ('-')) 3010 FORMAT (//5X,' CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3,' AND CHANNEL',I3/) 3020 FORMAT (8F15.7) 3030 FORMAT (//) 3040 FORMAT (/' ENTER CONTINUUM BOUND LOOP OF SETMX1') 3050 FORMAT (//5X,' BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3/) 3060 FORMAT (/' ENTER BOUND BOUND LOOP OF SETMX1') 3070 FORMAT (/5X,' BOUND-BOUND CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CONFIGURATION',I3) 3080 FORMAT (//' CALCULATE AND STORE ON THE OUTPUT FILE THE', A ' HAMILTONIAN MATRIX') 3090 FORMAT (/' ENTER CONTINUUM-CONTINUUM LOOP OF SETMX1') 3100 FORMAT (' FILE POSITION',I4,' HAS BEEN REACHED') 3110 FORMAT (//' WRITE TO ITAPE3 COMPLETED') END SUBROUTINE SETUP use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C DETERMINE CHANNEL INFORMATION IN /CHAN/ AND /CUPMAT/ C CONTINUE WRITING TO ITAPE3. USE RESTART FILE ITAPE2 IF PRESENT. C FOR PHOTOIONIZATION RUNS, STORE CHANNEL AND CONFIGURATION DATA. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXL2=9) C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MX2LR2=2*MZLR2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB,MX1BC=MZNR2*MXORB, A MX1CC=MZNR2*MZNR2/2+MZNR2) C LOGICAL FIRST C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), 1 LCHAN(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /CUPMAT/NCONOB(MXNCF),LCONOB(MXL2,MXNCF),LCONAT(MXL2,MZTAR) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /INSTO1/IRK1,IRK2,IRK3,IRK4,IRK5,IRK6,IRK7,IRK8,IRK9,IRK10 COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) COMMON /REL/IRELOP(3) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX COMMON /NRBSLP/ISLP(MZSLP),IAUTO,IELC,MINST,MAXST,MINLT,MAXLT, B NOICC c **** parallel **** common /chanpblock/nchp(mzslp),ncnp(mzslp),mnpp(mzslp) common /lspiblock/nspna(mzslp),lrgla(mzslp),nptya(mzslp) c **** parallel **** C----------------------------------------------------------------------- C C ICOPY1 = POSITION OF FIRST BLOCK OF DATA TO BE COPIED FROM ITAPE2 C TO ITAPE3. C ICOPY2 = POSITION OF LAST BLOCK OF DATA TO BE COPIED FROM ITAPE2 C TO ITAPE3. C ITOTAL = TOTAL NUMBER OF DATA BLOCKS REQUIRED ON ITAPE3. C C IF ITOTAL=0, THE PARTIAL-WAVE SYMMETRIES ARE C LOOPED WITHOUT CALCULATING ANY H-MATRICES ... C THUS ONLY DIPOLE MATRICES ARE CALCULATED. C C ICOUNT IS A COUNT ON THE DATA BLOCKS ON FILE. C NCHAN = 0 FIRST = IABS(MSKIP) .EQ. 1 WRITE (IWRITE,3000) IF (FIRST .AND. ITOTAL.GT.0) THEN C C WRITE OUT THE TARGET STATES AT THIS POINT C WRITE (ITAPE3) NAST WRITE (ITAPE3) (ENAT(I),I=1,NAST), (LAT(I),I=1,NAST), A (ISAT(I),I=1,NAST), (LPTY(I),I=1,NAST) IF (IRELOP(3).NE.0) THEN WRITE (ITAPE3) NCFG, (NOCCSH(I),I=1,NCFG) DO 10 I = 1,NCFG IL = NOCCSH(I) ILL = 2*IL - 1 WRITE (ITAPE3) (NOCORB(J,I),J=1,IL), (NELCSH(J,I),J=1,IL), A ((J1QNRD(J,K,I),K=1,3),J=1,ILL) 10 CONTINUE WRITE (ITAPE3) MAXORB, (NJCOMP(J),J=1,MAXORB), A (LJCOMP(J),J=1,MAXORB) WRITE (ITAPE3) (NTCON(J),J=1,NAST) DO 20 I = 1,NAST NT = NTCON(I) WRITE (ITAPE3) (NTYP(I,J),J=1,NT), (AIJ(I,J),J=1,NT) 20 CONTINUE C C WRITE OUT THE SPIN-ORBIT INTEGRALS AT THIS POINT C WRITE (ITAPE3) IRK5 WRITE (ITAPE3) (IST1(I),I=1,LRANG1), (RSPOR1(I),I=1,IRK5) WRITE (ITAPE3) IRK6 WRITE (ITAPE3) (IST2(I),I=1,LRANG1), (RSPOR2(I),I=1,IRK6) IF (LRANG2.GE.2) THEN DO 30 L = 2,LRANG2 WRITE (ITAPE3) IRK7 WRITE (ITAPE3) (RSPOR3(I,L),I=1,IRK7) 30 CONTINUE ENDIF C ENDIF C WRITE (IWRITE,*) ' WRITE OF BASIC DATA COMPLETED' ENDIF C C RETURN IF JUST BASIC DATA REQUIRED C IF(MSKIP.LT.0)RETURN C C C USE RESTART FILE IF PRESENT C IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) THEN READ (ITAPE2) LRGL,NSPN,NPTY,NCFGP,IPOLPH READ (ITAPE2) MNP1,NCONHP,NCHAN IF (NCHAN.GT.MZCHF) CALL RECOV2('SETUP ',' MZCHF',MZCHF,NCHAN) READ (ITAPE2) (NCONAT(I),I=1,NAST) READ (ITAPE2) (L2P(I),I=1,NCHAN) READ (ITAPE2) MORE IF (MORE.EQ.0) ICOPY2 = MIN(ICOPY2,ICOUNT+3) IF (IRELOP(3).NE.0 .AND. NCFGP.GT.0 .AND. LRANG2.GT.0) THEN READ (ITAPE2) (IOCCSH(I),I=1,NCFGP) DO 40 I = 1,NCFGP IL = IOCCSH(I) ILL = 2*IL - 1 READ (ITAPE2) (IOCORB(J,I),J=1,IL), (IELCSH(J,I),J=1,IL), A ((I1QNRD(J,K,I),K=1,3),J=1,ILL) 40 CONTINUE ENDIF C IF (IPOLPH.EQ.1 .AND. ICOUNT.LT.ICOPY2-3) GOTO 50 ENDIF C C EVALUATE AND WRITE OUT THE COUPLED CHANNELS C CALL SETCUP NCONHP = NRANG2*NCHAN MNP1 = NCONHP + NCFGP 50 CONTINUE MORE2 = 1 IF (MSKIP.GE.INAST .OR. ICOUNT.GE.ITOTAL-3) MORE2 = 0 WRITE (IWRITE,3010) NCHAN,NCONHP,MNP1 c **** parallel **** nchp(mskip) = nchan ncnp(mskip) = nconhp mnpp(mskip) = mnp1 nspna(mskip) = nspn lrgla(mskip) = lrgl nptya(mskip) = npty c **** parallel **** IF (ITOTAL.EQ.0 .OR. NCHAN.EQ.0) GOTO 70 C NWT=NSPN IF(LRGL.GT.LNOEX.AND.IRELOP(3).EQ.0)NWT=-NWT+1 C WRITE (ITAPE3) LRGL,NWT,NPTY,NCFGP,IPOLPH C C WRITE CHANNEL INFO FOR NICCHAN - CPB 02/02/00 C IF(NOICC.NE.0)WRITE(841)LRGL,NWT,NPTY,NCHAN,NCFGP C WRITE (ITAPE3) MNP1,NCONHP,NCHAN WRITE (ITAPE3) (NCONAT(I),I=1,NAST) WRITE (ITAPE3) (L2P(I),I=1,NCHAN) WRITE (ITAPE3) MORE2 IF (IRELOP(3).NE.0 .AND. NCFGP.GT.0) THEN WRITE (ITAPE3) (IOCCSH(I),I=1,NCFGP) DO 60 I = 1,NCFGP IL = IOCCSH(I) ILL = 2*IL - 1 WRITE (ITAPE3) (IOCORB(J,I),J=1,IL), (IELCSH(J,I),J=1,IL), A ((I1QNRD(J,K,I),K=1,3),J=1,ILL) 60 CONTINUE ENDIF C 70 CONTINUE IF (IPOLPH.LE.1) RETURN C C FOR PHOTOIONIZATION STORE N+1 ELECTRON DATA FOR LATER USE IN DMEL C L2(MSKIP) = LRGL LS(MSKIP) = NSPN LP(MSKIP) = NPTY LCHAN(MSKIP) = NCHAN LCFG(MSKIP) = NCFGP CALL DMCON(2,MSKIP,NCFGP,NAST,NCONAT,LCONAT,IOCCSH,IOCORB,IELCSH, A I1QNRD) C 3000 FORMAT (//30X,'SUBROUTINE SETUP'/30X,17 ('-')) 3010 FORMAT (/' NCHAN =',I5,' NCONHP =',I7,' MNP1 =',I7/) END C C C SUBROUTINE SHRIEK(NFACT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C EVALUATES FACTORIALS FROM 1 TO NFACT-1 C C GAMMA(I+1) = FACTORIAL I C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C COMMON /FACT/GAMMA(MZFAC) C----------------------------------------------------------------------- GAMMA(1) = DBLE(1) IF (NFACT.LT.2) GOTO 20 C DO 10 I = 2,NFACT GAMMA(I) = DBLE(I-1)*GAMMA(I-1) 10 CONTINUE C 20 CONTINUE END C C C SUBROUTINE SJ1QNT(IA,IB,IC,ID,IE) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C A ROUTINE TO SET UP THE COUPLING OF THE ATOMIC SHELLS LEAVING C SPACES FOR THE CONTINUUM ELECTRON SHELLS WHERE APPROPRIATE C C IA = THE N OR N+1 ELECTRON CONFIGURATION BEING CONSIDERED C C IB = THE STARTING POINT FOR THE INTERMEDIATE COUPLING IN C THE I1QNRD OR J1QNRD ARRAYS C C IC = THE HIGHEST OCCUPIED SHELL NUMBER BETWEEN BOTH COUPLING C SCHEMES C C ID = 1 FOR BOUND-BOUND, = 2 FOR BOUND-CONTINUUM, = 3 FOR C CONTINUUM-CONTINUUM C C IE = 1 FOR THE BRA COUPLING, = 2 FOR THE KET COUPLING C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C----------------------------------------------------------------------- C C I6= GIVES THE POSITION OF THE CURRENT INTERMEDIATE COUPLING IN C J1QN C C I7=IS INCREMENTED FROM 1 AS EACH OCCUPIED ORBITAL IS ENCOUNTERED C C I8=IS INCREMENTED EVERY TIME A DUMMY SHELL IS ENCOUNTERED C I1 = IA I2 = IB I3 = IC I4 = ID I5 = IE I6 = IC + ID I7 = 1 I8 = 1 C C LOOP OVER SHELLS C DO 80 I9 = 1,I3 I10 = I8 C C TEST IF SHELL IS DUMMY C IF (NOSH(I9,I5).NE.0) THEN C C FILL UP J1QN ARRAY FROM J1QNRD OR I1QNRD C IF ((I4.NE.2.OR.I5.EQ.1) .AND. I4.NE.3) THEN DO 10 K = 1,3 J1QN(I9,K,I5) = I1QNRD(I7,K,I1) 10 CONTINUE C C SIGNIFY THAT AN OCCUPIED SHELL HAS BEEN MET C ELSE DO 20 K = 1,3 J1QN(I9,K,I5) = J1QNRD(I7,K,I1) 20 CONTINUE ENDIF C I7 = I7 + 1 C ELSE C C FILL J1QN FOR THE DUMMY SHELL C J1QN(I9,1,I5) = 0 J1QN(I9,2,I5) = 1 J1QN(I9,3,I5) = 1 C C SIGNIFY THAT A DUMMY SHELL HAS JUST BEEN ENCOUNTERED C I8 = I8 + 1 ENDIF C C TEST IF FIRST,SECOND OR OTHER SHELL C IF (I9.LT.2) GOTO 80 IF (I9.GT.2) THEN C C FILL INTERMEDIATE J1QN FOR AN OCCUPIED SHELL C IF (I10.EQ.I8 .AND. I7.NE.2) GOTO 40 I11 = I6 - 1 C ELSE C C THE SECOND SHELL HAS BEEN FILLED,NOW FILL FIRST INTERMEDIATE C COUPLING C IF (I8.EQ.1) GOTO 40 I11 = I9 - 1 ENDIF C C ONE OR BOTH OF SHELLS WERE DUMMY C IF (I10.EQ.I8) I11 = I9 DO 30 K = 1,3 J1QN(I6,K,I5) = J1QN(I11,K,I5) 30 CONTINUE GOTO 70 C C NEITHER OF FIRST TWO SHELLS WAS A DUMMY C 40 CONTINUE IF ((I4.NE.2.OR.I5.EQ.1) .AND. I4.NE.3) THEN DO 50 K = 1,3 J1QN(I6,K,I5) = I1QNRD(I2,K,I1) 50 CONTINUE C ELSE DO 60 K = 1,3 J1QN(I6,K,I5) = J1QNRD(I2,K,I1) 60 CONTINUE ENDIF C I2 = I2 + 1 70 CONTINUE I6 = I6 + 1 80 CONTINUE C END C C C SUBROUTINE SJ2QNT(IA,IB,IC,ID,IE) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C A ROUTINE TO SET UP THE COUPLING OF THE ATOMIC SHELLS FOR C THE N-ELECTRON TARGET CONFIGURATIONS. (BASED ON SUB. SJ1QNT) C C IA = THE N ELECTRON CONFIGURATION BEING CONSIDERED C C IB = THE STARTING POINT FOR THE INTERMEDIATE COUPLING IN C THE J1QNRD ARRAYS C C IC = THE HIGHEST OCCUPIED SHELL NUMBER BETWEEN BOTH COUPLING C SCHEMES C C ID = 1 FOR BOUND-BOUND C C IE = 1 FOR THE BRA COUPLING, = 2 FOR THE KET COUPLING C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C----------------------------------------------------------------------- C C I6= GIVES THE POSITION OF THE CURRENT INTERMEDIATE COUPLING IN C J1QN C C I7=IS INCREMENTED FROM 1 AS EACH OCCUPIED ORBITAL IS ENCOUNTERED C C I8=IS INCREMENTED EVERY TIME A DUMMY SHELL IS ENCOUNTERED C I1 = IA I2 = IB I3 = IC I5 = IE I6 = IC + ID I7 = 1 I8 = 1 C C LOOP OVER SHELLS C DO 60 I9 = 1,I3 I10 = I8 C C TEST IF SHELL IS DUMMY C IF (NOSH(I9,I5).NE.0) THEN C C FILL UP J1QN ARRAY FROM J1QNRD C DO 10 K = 1,3 J1QN(I9,K,I5) = J1QNRD(I7,K,I1) 10 CONTINUE C C SIGNIFY THAT AN OCCUPIED SHELL HAS BEEN MET C I7 = I7 + 1 C ELSE C C FILL J1QN FOR THE DUMMY SHELL C J1QN(I9,1,I5) = 0 J1QN(I9,2,I5) = 1 J1QN(I9,3,I5) = 1 C C SIGNIFY THAT A DUMMY SHELL HAS JUST BEEN ENCOUNTERED C I8 = I8 + 1 ENDIF C C TEST IF FIRST,SECOND OR OTHER SHELL C IF (I9.LT.2) GOTO 60 IF (I9.GT.2) THEN C C FILL INTERMEDIATE J1QN FOR AN OCCUPIED SHELL C IF (I10.EQ.I8 .AND. I7.NE.2) GOTO 30 I11 = I6 - 1 C ELSE C C THE SECOND SHELL HAS BEEN FILLED,NOW FILL FIRST INTERMEDIATE C COUPLING C IF (I8.EQ.1) GOTO 30 I11 = I9 - 1 ENDIF C C ONE OR BOTH OF SHELLS WERE DUMMY C IF (I10.EQ.I8) I11 = I9 DO 20 K = 1,3 J1QN(I6,K,I5) = J1QN(I11,K,I5) 20 CONTINUE GOTO 50 C C NEITHER OF FIRST TWO SHELLS WAS A DUMMY C 30 CONTINUE DO 40 K = 1,3 J1QN(I6,K,I5) = J1QNRD(I2,K,I1) 40 CONTINUE I2 = I2 + 1 50 CONTINUE I6 = I6 + 1 60 CONTINUE C END C C C SUBROUTINE STG2 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (NTOM1=MZCHD*MZNR1) C PARAMETER (NTOM2=MZNC2*NTOM1) !LARGE PARAMETER (NTOM2=1000000) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CUPINT/MNP1,NCONHP,NCHAN COMMON /CUT/NCUT,IKIP(MZNC2),JOCCSH(MZNC2) COMMON /DIAG/NDIAG COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /AMATST/AFACT(NTOM2),NDIML,NDIMR,NONZER,ICHL(NTOM1), C IORB(NTOM1),ILEFT(NTOM2),IRIGHT(NTOM2) COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /NRBSKP/ESKPL,ESKPH,ECORR,BCUT,ISKIP(MZTAR) COMMON /NRBTOL/TOLER C LOGICAL EX CHARACTER*1 IFNM(10) CHARACTER*12 IFLNM DATA IFNM/'0','1','2','3','4','5','6','7','8','9'/ c **** parallel **** include 'mpif.h' parameter (mxproc2=96) common /parablock/iam,nproc character*1 filec,filed,fileu character*10 filerout common /chanpblock/nchp(mzslp),ncnp(mzslp),mnpp(mzslp) dimension npw2h(mxproc2) do i=1,mzslp nchp(i) = 0 ncnp(i) = 0 mnpp(i) = 0 enddo c **** parallel **** C----------------------------------------------------------------------- C C IREAD IS THE USER INPUT CHANNEL NUMBER C C----------------------------------------------------------------------- IREAD = 5 IWRITE = 6 C EX=.TRUE. INQUIRE (FILE='dstg2',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7777) STOP ENDIF OPEN (UNIT=IREAD,FILE='dstg2',STATUS='OLD',FORM='FORMATTED') 7777 FORMAT (/' dstg2 does not exist....stopping.') C c **** parallel **** ich0 = ichar('0') ic = iam/100 id = (iam - 100*ic)/10 iu = (iam - 100*ic - 10*id) ic = ic + ich0 id = id + ich0 iu = iu + ich0 filec = char(ic) filed = char(id) fileu = char(iu) filerout = 'rout2r'//filec//filed//fileu OPEN (UNIT=IWRITE,FILE=filerout, + STATUS='UNKNOWN',FORM='FORMATTED') c **** parallel **** C----------------------------------------------------------------------- C C MSKIP = PARTIAL WAVE COUNTER C MSKIP = 0 C C READ IN ANY INPUT FILES (IREAD, ITAPE1, ITAPE2) ... C START READING USER INPUT DATA, TO SPECIFY N-ELECTRON STATES C CALL STG2RD(-1) WRITE (IWRITE,3000) C C ICOUNT= COUNTER ON OUTPUT FILE ITAPE3 C ICOUNT = 1 C IF (IPLACE.GT.0) GOTO 10 C C INITIALIZE: /CSTORE/, /FACT/, /FACTS/, /KRON/, /SYMTX/ C ALSO CHECK STGLIB DIMENSIONS IN /BPSIZE/ C CALL ISTG2(LRANG1,LRANG2,LAMAX,NRANG2) C C WRITE BASIC QUANTITIES AS A HEADER ON OUTPUT FILE ITAPE3 C IF (ITOTAL.GT.0.and.iam.eq.0) CALL WRITAP(21) C C DIAGONALIZE N-ELECTRON TARGET HAMILTONIAN IF NDIAG=1 SPECIFIED, C STORE IN /STATE/ AND /STATED/ AND ON OUTPUT FILE ITAPE3. C IF (NDIAG.GE.1) CALL BOUND WRITE (IWRITE,3000) C IF(BCUT.GE.0.)THEN CLOSE(8) RETURN ENDIF C C WRITE DATA FOR NX CODE NRB 25/10/94 C IF(IRELOP(3).EQ.0)CALL WRINX2 C C TERMINATE IF MERE TCC RUN, AFTER COMPLETING BASIC WRITES C IF(IRELOP(3).NE.0.AND.IDWOUT.EQ.2)THEN MSKIP=-1 CALL SETUP RETURN ENDIF C C C C ---- LOOP OVER S L PI SYMMETRIES; C CONTINUE READING USER INPUT DATA TO SPECIFY (N+1)-ELECTRON STATES C 10 CONTINUE C C DETERMINE HOW MANY PARTIAL WAVES WILL BE WRITTEN TO EACH C STGH2#.DAT FILE C NPWFL=INAST/N2HDAT if(n2hdat.gt.mxproc2)then write(iwrite,*)'increase mxproc2 to',n2hdat if(iam.eq.0)write(0,*)'increase mxproc2 to',n2hdat stop endif do n=1,n2hdat npw2h(n)=npwfl enddo nrest=MOD(INAST,N2HDAT) do n=1,nrest npw2h(n)=npw2h(n)+1 enddo nsum=0 n=0 IFL0=0 DO 20 MSKIP = 1,INAST if(mskip.gt.nsum)then n=n+1 nsum=nsum+npw2h(n) endif IFL=n-1 c if(iam.eq.0)write(0,*)'mskip=',mskip,'ifl=',ifl IF(IFL.GT.IFL0.and.nproc.eq.1)THEN !OPEN NEW FILE STG2HXXX.DAT IFLNM='STG2H00'//IFNM(IFL+1)//'.DAT' CLOSE(ITAPE3) OPEN (UNIT=ITAPE3,FILE=IFLNM,STATUS='UNKNOWN' X ,FORM='UNFORMATTED') WRITE(IWRITE,3210) IFLNM 3210 FORMAT(/' OPENING FILE ',A12) IFL0=IFL IF(NCUT.LT.0)THEN IFLNM='HDCORR00'//IFNM(IFL+1) CLOSE(31) OPEN (UNIT=31,FILE=IFLNM,STATUS='UNKNOWN' X ,FORM='FORMATTED') WRITE(IWRITE,3210) IFLNM ENDIF IF(TOLER.GE.1.D-19)THEN IFLNM='AMATU00'//IFNM(IFL+1)//'.DAT' CLOSE(66) OPEN (UNIT=66,FILE=IFLNM,STATUS='UNKNOWN' X ,FORM='UNFORMATTED') WRITE(IWRITE,3210) IFLNM ENDIF ENDIF if(ifl.eq.iam.or.nproc.eq.1)WRITE (IWRITE,3010) CALL STG2RD(IFL) IF (IPLACE.GT.0) GOTO 20 c **** parallel **** if (ifl.ne.iam.and.nproc.ne.1) go to 20 c write(0,*) 'MSKIP=:',mskip,' proc=:',iam c **** parallel **** C C DETERMINE CHANNEL INFORMATION IN /CHAN/ AND /CUPMAT/ C CONTINUE WRITING TO ITAPE3. USE RESTART FILE ITAPE2 IF PRESENT C CALL SETUP WRITE (IWRITE,3000) IF (ICOUNT.GT.ITOTAL) GOTO 20 C C EVALUATE AND STORE THE HAMILTONIAN MATRIX ON OUTPUT FILE ITAPE3 C NDIML=0 NONZER=0 IF (IRELOP(3).EQ.0) THEN IF(IDWOUT.GT.0) THEN if (iam.eq.0) then IF(MSKIP.EQ.1) THEN IF(IDWBUG.NE.0)OPEN (20,FILE='ALGDW.DAT',FORM='FORMATTED' X ,STATUS='UNKNOWN') OPEN (21,FILE='ALGDWU.DAT',FORM='UNFORMATTED' X ,STATUS='UNKNOWN') OPEN (22,FILE='MIXDW.DAT',STATUS='UNKNOWN') ENDIF endif C C WRITE INITIAL CHANNEL INFO AND, FOR MSKIP.EQ.1, TARGET INFO C CALL DWOUT1 C ENDIF C CALL SETMX1 C C OUTPUT A-MATRIX FOR PSEUDO-RESONANCE REMOVAL C IF(IDWOUT.NE.2.AND.TOLER.GE.1.D-19.AND.NCHAN.NE.0)CALL AMOUT C C TERMINATE DW OUTPUT C IF(IDWOUT.GT.0) THEN ISIX=6 ZERO=0.0D0 WRITE(21)ISIX,ISIX,ISIX,ISIX,ISIX,ISIX,ZERO IF(IDWBUG.NE.0)WRITE(20,1987) 1987 FORMAT(' 6') ENDIF ELSE CALL SETMXR ENDIF C IF(IDWOUT.EQ.2) GO TO 20 C IF (ICOUNT.GT.ITOTAL) GOTO 30 C C EVALUATE THE MULTIPOLE MATRIX ELEMENTS FOR THE R.H.S. OF THE C ASYMPTOTIC EQUATIONS FOR USE IN THE SCATTERING CALCULATION. C STORE IN /CHAN/ AND ON OUTPUT FILE ITAPE3. C CALL AIJS WRITE (IWRITE,3000) IF (ICOUNT.GE.ITOTAL) GOTO 30 20 CONTINUE MSKIP = INAST C C ---- END OF S L PI LOOP. C C IF IPOLPH.GE.2 CALCULATE THE DIPOLE MATRIX ELEMENTS FOR USE IN C POLARIZABILITY AND PHOTOIONISATION CALCULATIONS. C STORE ON OUTPUT FILE ITAPE4. C 30 CONTINUE IF (IPOLPH.GE.2 .AND. INAST.GT.1) CALL DMEL IF (IPOLPH.GE.2) WRITE (IWRITE,3000) C C WRITE INFO ON IC CHANNELS C CALL NICCHAN C C WRITE OUT ERROR MESSAGE IF A DIMENSION HAS BEEN EXCEEDED C IF (IPLACE.GT.0) WRITE (IWRITE,3030) IF (IPLACE.LE.0) WRITE (IWRITE,3020) C 3000 FORMAT (/10X,63 ('*')) 3010 FORMAT (/' READ NEW DATA DEFINING AN N+1 ELECTRON STATE') 3020 FORMAT (/55X,'END OF STG2'/55X,11 ('-')) 3030 FORMAT (/' DIMENSIONS EXCEEDED IN STG2'/) END SUBROUTINE STG2RD(IFL) use basic2 IMPLICIT REAL*8 (A-H,O-Z) C C C----------------------------------------------------------------------- C C Reads in and writes out the input data. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MX2LR2=2*MZLR2) PARAMETER (MXLCNT=MZNR1) PARAMETER (mxdiag=MZNR2*MZCHF+MZNC2) C CHARACTER*1 LVALUE(0:8),PAR(0:1) CHARACTER*4 RELOP,RAD ! NRB CHARACTER*4 TITLE(18),PARITY(2) CHARACTER*8 SPIN(8)*8 CHARACTER*12 IFLNM LOGICAL EX C DIMENSION NORDER(MXORB),NTAPE(4),JRELOP(3),LCOUNT(MXLCNT) X ,ITMPS(MZSLP) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 c COMMON /BASIC2/CF(MZCHD,MZCHD,MZLMX),ET(MZCHF), c 1 L2P(MZCHF),LSTARG(MZCHF), c A NCONAT(MZTAR),LRGL,NSPN,NPTY COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /COPY/ICOPY1,ICOPY2,ITOTAL,ICOUNT COMMON /CUPPLE/NOPTN,MNAL(MXORB),MXAL(MXORB),IBASSH(MZNC2,MXORB), A NXCITE(MZNC2),JREAD,LOCSH(MZNC2) COMMON /CUT/NCUT,IKIP(MZNC2),JOCCSH(MZNC2) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DIAG/NDIAG COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DWKEEP/NDWPTY(MZTAR),IDWOUT,LRNGDW,IDWBUG,KCOR COMMON /DWMETA/NTARG(MZCHF),IMETA(MZTAR),NMETAS COMMON /DWORB/NORIG(MXORB),LORIG(MXORB) COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /RECOV/IPLACE COMMON /REL/IRELOP(3) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),IPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) COMMON /TYPE/ITYP(MZNC2) COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX COMMON /NRBDIP/LRANGD,MAXLD COMMON /NRBKUT/EAST(MZTAR),TOLB,NFK(MZTAR),KCUT COMMON /NRBSLP/ISLP(MZSLP),IAUTO,IELC,MINST,MAXST,MINLT,MAXLT, B NOICC COMMON /NRBSKP/ESKPL,ESKPH,ECORR,BCUT,ISKIP(MZTAR) COMMON /NRBTOL/TOLER c common/cconwc/hcorr(mxdiag),hdiag(mxdiag),iidiag C C NRB 25/10/94 NAMELIST/STG2A/IPUNCH,JREAD,IBUG1,IBUG3,IBUG4,IBUG6,IBUG7,IBUG8 A,IBUG9,ISORT,ICOPY,IPOLPH,JRELOP,RELOP,RAD,IDWOUT,IDWBUG,N2HDAT B,ISHFTLS,nprocstg1 NAMELIST/STG2B/MAXORB,NELC,NAST,NKEY,NCUT,INAST,IKEY,ICUT,NDIAG A,KAB1,LNOEX,MINLT,MAXLT,MINST,MAXST,NMETA,IMETA,LRNGDW,NOICC B,ESKPL,ESKPH,ECORR,BCUT,MAXLD,TOLER,KCUT,TOLB C SAVE NORDER,NKEY,IKEY,ICUT,MELC,MAXLA,TITLE ! MELC FOR MODEL POTL C DATA NTAPE(1),NTAPE(2),NTAPE(3),NTAPE(4)/1,2,3,4/ DATA LVALUE/'S','P','D','F','G','H','I','J','K'/ DATA PARITY/'EVEN',' ODD'/,PAR/'E','O'/ DATA SPIN/' SINGLET',' DOUBLET',' TRIPLET',' QUARTET',' QUINTET', A ' SEXTET ',' SEPTET',' OCTET'/ c **** parallel **** include 'mpif.h' common /pstg1block/nprocstg1 common /parablock/iam,nproc parameter (mxproc1=64) character*1 filec,filed,fileu c **** parallel **** C----------------------------------------------------------------------- C C IF ANY DIMENSION IS EXCEEDED WHEN READING THE DATA, CALL RECOV2 C WITH IPLACE=0 TO TERMINATE THE PROGRAM. C C----------------------------------------------------------------------- IPLACE = 0 C----------------------------------------------------------------------- C C IF MSKIP.GT.1, STG2 IS BEING REPEATED FOR NEW (N+1)-ELECTRON DATA C SO IT IS NOT NECESSARY TO READ IN THIS FIRST SET OF DATA AGAIN. C IF (MSKIP.GT.0) GOTO 230 C----------------------------------------------------------------------- READ (IREAD,3300) (TITLE(I),I=1,18) C----------------------------------------------------------------------- WRITE (IWRITE,3020) TITLE WRITE (IWRITE,3010) WRITE (IWRITE,3290) A MZCHF,MZFAC,MZLMX,MZLR1,MZLR2,MZMEG,MZKIL,MZNC1,MZNC2, B MZNR1,MZNR2,MZOCC,MZOVL,MZSLP,MZTAR,MXORB C----------------------------------------------------------------------- C C INITIALISE SOME STG2 PARAMETERS C ITOTAL=999 IBUG2=0 IBUG5=0 C C----------------------------------------------------------------------- C C INITIALSE NAMELIST STG2A C IPUNCH=0 JREAD=0 IBUG1=0 IBUG3=0 IBUG4=0 IBUG6=0 IBUG7=0 IBUG8=0 IBUG9=0 ICOPY=0 IPOLPH=1 JRELOP(1)=0 JRELOP(2)=0 JRELOP(3)=0 RELOP='NO' RAD='NO' IDWOUT=0 IDWBUG=0 ISORT=0 BCUT=-1.D0 N2HDAT=1 ISHFTLS=0 c **** parallel **** nprocstg1=-1 !! number of processors used in STG1 ! Default read from STG1.DAT c **** parallel **** C C----------------------------------------------------------------------- C NRB & TWG C IDWOUT =0 (DEFAULT) FOR NO OUTPUT REQUIRED FOR DISTORTED WAVE CODE C =1 CREATE OUTPUT FILES "MIXDW.DAT", WHICH LISTS CI STUFF, & C "ALGDWU.DAT", WHICH HAS THE ANGULAR COEFFICIENTS. THESE C TWO FILES ARE REQUIRED AS INPUT TO THE PROGRAM STGDW. C =2 CREATES OUTPUT FOR DISTORTED WAVE ONLY. THE CONTINUUM- C BOUND AND (N+1)-BOUND-BOUND ALGEBRA IS THUS AVOIDED. C C IDWBUG = 0 (DEFAULT) MINIMUM OUTPUT (UNFORMATTED) C =-1 MINIMUM DEBUGGING OUTPUT (FORMATTED) C = 1 MAXIMUM DEBUGGING OUTPUT (FORMATTED) C C ISORT = 1 ENFORCES SYMMETRY ORDER AND NAST=NCFG. C N2HDAT NUMBER OF STG2H.DAT FILES - IF N2HDAT.EQ.1 THEN ONE C FILE STG2H.DAT WILL BE OPENED. IF N2HDAT.GT.1 THEN C N2HDAT FILES WILL BE OPENED AND NUMBERED STG2H000.DAT, C STG2H001.DAT, STG2H002.DAT, ETC. CAN BE ANY NUMBER FROM C 1 TO 10 (for serial code) -- THIS MAY BE USED TO KEEP C EACH STG2Hx.DAT UNDER 2 GB, WHICH WAS A RESTRICTION C SYSTEMS. UNTIL THIS IS ALSO IMPLEMENTED IN STGJK, C N2HDAT IS RESTRICTED TO 1 FOR A BREIT-PAULI RUN. C C ISHFTLS.NE.0 ENSURES E-VECTORS WRITTEN FOR TECS IN STGJK, C I.E. JRELOP(3)=-1, BUT ISHFTLS MIRRORS AS & STGJK USE. C C----------------------------------------------------------------------- C READ(IREAD,STG2A) C c **** parallel **** if (nprocstg1.gt.mxproc1) stop 'increase mxproc1 parameter' if (nproc.ne.1) n2hdat = nproc c **** parallel **** c IF(N2HDAT.GT.10.and.nproc.eq.1) THEN WRITE(IWRITE,7770) N2HDAT 7770 FORMAT(/'WARNING! THE NUMBER OF STG2H.DAT FILES CANNOT BE',/ X ' GREATER THAN 10 - RESET TO 10, INPUT:',I3/) N2HDAT=10 END IF C IF(JREAD.NE.0)JREAD=8 C IF(RAD.EQ.'YES')IPOLPH=2 IF(IDWOUT.EQ.2)THEN IPOLPH=1 ELSE NEED=MZCHF IF(MZCHD.LT.MZCHF)CALL RECOV2('STG2RD',' MZCHD',MZCHD,NEED) ENDIF C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C C READ IN WHICH RELATIVISTIC OPERATORS ARE TO BE INCLUDED: C C JRELOP(1)=1 FOR MASS-CORRECTION, C JRELOP(2)=1 FOR DARWIN-TERM, C /JRELOP(3)/=1 FOR SPIN-ORBIT. C C----------------------------------------------------------------------- IF(RELOP.EQ.'MVD')THEN JRELOP(1)=1 JRELOP(2)=1 JRELOP(3)=0 ENDIF IF(RELOP.EQ.'TCCR')JRELOP(3)=-1 !JRELOP(1)=0=JRELOP(2) HERE IF(RELOP.EQ.'YES'.OR.RELOP.EQ.'TCC')THEN JRELOP(1)=1 JRELOP(2)=1 IF(JRELOP(3).EQ.0)JRELOP(3)=1 !ALLOW FOR USER JRELOP(3)=-1 IF(RELOP.EQ.'TCC')THEN JRELOP(3)=-1 ELSE IDWOUT=0 ENDIF ENDIF IF(ISHFTLS.NE.0)JRELOP(3)=-ABS(JRELOP(3)) !E-VECTORS FOR TEC COLD IF(ABS(JRELOP(3)).EQ.1) N2HDAT=1 !SINCE WE NOW HAVE PSTGJK C ICOPY1 = 1 ICOPY2 = ICOPY C----------------------------------------------------------------------- C C Set the I/O numbers and open files. C C IREAD (5) .. input data .. dstg2 C IWRITE (6) .. printed output .. rout2r C C IPUNCH (8) .. output config data C C IDISC1 (11) .. scratch C IDISC2 .. NOT USED C IDISC3 .. NOT USED C IDISC4 .. NOT USED C C ITAPE1 (1) .. STG1 dump .. STG1.DAT .. always used C ITAPE2 (2) .. old STG2 dump .. STG2.DMP .. if ICOPY>0 C C ITAPE3 (3) .. file for STG2 dump (hamiltonians) C .. STG2H.DAT/STG2HXXX.DAT C C ITAPE4 (4) .. STG2 dump (dipole matrix) .. STG2D.DAT .. if IPOLPH=2 C C JREAD (8) .. input config data C C JDISC1 (21) .. RK.DAT C JDISC2 .. NOT USED C C----------------------------------------------------------------------- IWRITE = 6 IF(IPUNCH.GT.0)IPUNCH=8 C IDISC1 = 11 IDISC2 = 0 IDISC3 = 0 IDISC4 = 0 C ITAPE1 = 1 IF (ICOPY.GT.0) THEN ITAPE2 = 2 ELSE ITAPE2 = 0 ENDIF ITAPE3 = 3 IF (IPOLPH.EQ.2) THEN ITAPE4 = 4 ELSE ITAPE4 = 0 ENDIF C C JREAD = 5 C JDISC1 = 21 JDISC2 = 0 C INQUIRE (FILE='STG1.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7771) STOP ENDIF OPEN (UNIT=ITAPE1,FILE='STG1.DAT',STATUS='OLD', A FORM='UNFORMATTED') 7771 FORMAT (/' STG1.DAT does not exist....stopping.') C IF (ITAPE2.GT.0) THEN INQUIRE (FILE='STG2.DMP',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7772) STOP ENDIF OPEN (UNIT=ITAPE2,FILE='STG2.DMP',STATUS='OLD', A FORM='UNFORMATTED') ENDIF 7772 FORMAT (/' STG2.DMP does not exist....stopping.') IF (ITAPE4.GT.0) THEN if (iam.eq.0) then OPEN (UNIT=ITAPE4,FILE='STG2D.DAT',STATUS='UNKNOWN', A FORM='UNFORMATTED') endif ENDIF C----------------------------------------------------------------------- WRITE (IWRITE,3000) C WRITE (IWRITE,3140) A IREAD,IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3,IDISC4, A ITAPE1,ITAPE2,ITAPE3,ITAPE4,JREAD,JDISC1,JDISC2 C IF(N2HDAT.EQ.1) THEN OPEN (UNIT=ITAPE3,FILE='STG2H.DAT',STATUS='UNKNOWN', A FORM='UNFORMATTED') ELSE WRITE(IWRITE,3142) N2HDAT 3142 FORMAT('STG2 dump of hamiltonians in ',I3,' files:') c **** parallel **** ich0 = ichar('0') ic = iam/100 id = (iam - 100*ic)/10 iu = (iam - 100*ic - 10*id) ic = ic + ich0 id = id + ich0 iu = iu + ich0 filec = char(ic) filed = char(id) fileu = char(iu) IFLNM='STG2H'//filec//filed//fileu//'.DAT' OPEN (UNIT=ITAPE3,FILE=IFLNM, + STATUS='UNKNOWN',FORM='UNFORMATTED') WRITE(IWRITE,3212) IFLNM c **** parallel **** END IF C WRITE (IWRITE,3030) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7, A IBUG8,IBUG9 C WRITE (IWRITE,3150) NTAPE(1),ITAPE1 IF (N2HDAT.EQ.1) WRITE (IWRITE,3160) NTAPE(3),ITAPE3 IF (ITAPE4.GT.0) WRITE (IWRITE,3160) NTAPE(4),ITAPE4 C WRITE (IWRITE,3170) ICOPY,ITOTAL,IPOLPH,JRELOP C----------------------------------------------------------------------- C C POSITION THE INPUT FILE FOR COPYING, IF NECESSARY. C FOR DEFINITION OF THE ICOPY PARAMETERS, SEE LISTING OF SETUP. C ICOUNT IS A COUNT ON THE DATA BLOCKS ON FILE. C C----------------------------------------------------------------------- IF (ICOPY2.GT.0) THEN WRITE (IWRITE,3150) NTAPE(2),ITAPE2 WRITE (IWRITE,3180) IF (ITOTAL.GT.0) CALL COPYTP(ITAPE2) WRITE (IWRITE,3000) ENDIF C----------------------------------------------------------------------- C C READ AND WRITE BASIC DATA. C C MAXORB ..... THE TOTAL NUMBER OF POSSIBLE SHELLS. C NELC ....... THE TOTAL NUMBER OF ELECTRONS. C NAST ....... THE TOTAL NUMBER OF ATOMIC OR IONIC STATES. C NKEY ....... =-1 FOR MINIMUM CARD INPUT DATA. AS FOR NKEY=0, C BUT THE VALUE OF NOPTN IS NOT READ IN. C = 0 FOR AUTOMATIC GENERATION OF THE CONFIGURATION C DATA, USING THE SAME CRITERIA FOR EACH STATE. C = 1 FOR AUTOMATIC GENERATION OF THE CONFIGURATION C DATA, USING DIFFERENT CRITERIA FOR EACH STATE. C = 2 FOR READING THE CONFIGURATION DATA FROM JREAD. C NCUT ....... THE TOTAL NUMBER OF CONFIGURATIONS GENERATED OR READ C IF NOT ALL OF THEM ARE TO BE STORED, C = 0 IF ALL THE CONFIGURATIONS ARE TO BE STORED. C C INAST ...... AS FOR NAST, BUT FOR THE (N+1)-ELECTRON STATES. C IKEY ....... AS FOR NKEY, BUT FOR THE (N+1)-ELECTRON STATES. C ICUT ....... AS FOR NCUT, BUT FOR THE (N+1)-ELECTRON STATES. C C NDIAG ...... = 0 (DEFAULT) IF TARGET CONFIGURATION COEFFICIENTS C ARE TO BE READ IN, AS IN CPC VERSION; C = 1 IF COEFFICIENTS & ENERGIES ARE TO BE CALCULATED C BY DIAGONALIZING THE TARGET HAMILTONIAN. C (NDIAG STILL HAS TO BE SET APPROPRIATELY EVEN IF C SPIN-ORBIT IS INCLUDED (/JRELOP(3)/=1), IN WHICH C CASE THE COEFFICIENTS AND ENERGIES ARE READ OR C CALCULATED IN RECUP). C C KAB1 ....... = 0 (DEFAULT) NO ACTION ON STORING ANGULAR INTEGRALS C .GT.0 CHANNEL NUMBER FOR WRITING ANGULAR INTEGRALS, C SEQUENTIALLY AS THEY ARE GENERATED; C .LT.0 CHANNEL NUMBER FOR READING ANGULAR INTEGRALS C FROM PREVIOUS ISO-ELECTRONIC RUN. C C C NRB C C ESKPL,ESKPH.. TARGET TERMS WITH ENERGIES BETWEEN ESKPL,ESKPH TAKEN C TO BE CORRELATION (NOT CC), NO NEED TO ISKP THEM. C ECORR ....... ALL TERMS ABOVE ECORR RYD TAKEN TO BE CORRELATION C C KCUT ........ >0 FLAGS AS CFS AND ENERGIES FROM TERMS FILE PRESENT C ENERGIES WHICH DO NOT MATCH ARE TAKEN AS CORR. C C TOLB ........ TOLERANCE (RYD) FOR MATCHING RM AND AS ENERGIES C C C NRB & TWG C C LNOEX ....... MEANS NEGLECT EXCHANGE FOR TOT L > LNOEX. C STGDW DETECTS THIS AND ASSUMES ONLY EVERY OTHER C TOTAL SPIN HAS BEEN USED. INAST=0 DOES THIS C AUTOMATICALLY. IF YOU USE INAST>0 THEN ONLY C USE TRIPLET,SEPTET... OR DOUBLET,SEXTET,.... C TOTAL SPINS FOR L>LNOEX. C *** TO THIS END, EXCHANGE MULTIPOLES > LNOEX ARE C NEGLECTED. IT IS DONE BY MULTIPOLE BECAUSE FANO C ONLY KNOWS ABOUT THE FOUR NL ORBITALS, NOT TOT L. C STGDW IGNORES ANY EXCHANGE MULTIPOLES THAT MAY BE C PRESENT FOR L > LNOEX. ALSO, ANY THAT ARE MISSING C SHOULD BE SMALL! C *** IF SET FOR CC (IDWOUT=0,1) THEN IT IS JUST THE C MULTIPOLE NEGLECT THAT IS RELEVANT FOR CC. C C NMETA ....... = NUMBER OF METASTABLE STATES (.LE.NAST). CASE OF C IDWOUT=2 ONLY. C C IMETA(N)..... = 1 TARGET TERM N IS METASTABLE. IDWOUT=2 ONLY. C IF ISORT=0 THE FIRST NMETA TERMS IN THE C TERM LIST ARE TAKEN TO BE METASTABLE. C IF ISORT=-1 SPECIFY NMETA IMETA(N)'S WHERE N C IS THE POSITION IN THE TERM LIST. C IF ISORT=1, THE FIRST TERM OF THE FIRST C NMETA SYMMETRY GROUPS WILL BE METASTABLE. C IF YOU WANT 2 (OR MORE) METASTABLES OF THE C SAME SYMMETRY THEN SET IMETA(N)=1 WHERE N IS C THE SYMMETRY ORDERED POSITION OF THE C SECOND OR SUBSEQUENT METASTABLE OF A GIVEN C SYMMETRY. C C MAXLD....... MAX TOTAL L FOR WHICH DIPOLE DATA CALCULATED. C DEFAULT: ALL ALLOWED BY STG1'S LRANGD. C C CPB NOICC..... .NE. 0 WRITE CHANNEL INFO IN IC. C .EQ. 0 (DEFAULT) NO ACTION. C C C IF INAST.LE.0, MINLT,MAXLT,MINST,MAXST SPECIFY RANGE OF N+1 SL's C (BOTH PARITIES) TO BE LOOPED OVER. C .LT.0 READ -INAST LSP TO BE SKIPPED *DIRECTLY* AFTER STG2B C C IF IDWOUT.EQ.2, LRNGDW SUBSTITUTES FOR THE DUMMY LRANG2. C LRNGDW NEED NOT BE INPUT IF INAST=0. IF INAST.GT.0 EXECUTION MAY C BE FASTER IF YOU SET LRNGDW EQUAL TO YOUR MAX(L)+MAX(LAT)+1 C C----------------------------------------------------------------------- C WRITE (IWRITE,3040) C C INITIALISE STG2B C MAXORB=-1 NKEY=0 NCUT=0 IKEY=0 ICUT=0 NDIAG=1 KAB1 = 0 LNOEX=999 LRNGDW=MZLR2 MINLT=-1 MAXLT=-1 MINST=-1 MAXST=-1 INAST=0 NMETA=0 DO 5 N=1,MZTAR IMETA(N)=0 5 CONTINUE NOICC=0 ESKPH=-9999999.D0 ESKPL=99999999.D0 ECORR=99999999.D0 MAXLD=999 TOLER=-1.D-19 KCUT=0 TOLB=5.D-4 C READ(IREAD,STG2B) C INAST0=INAST IF(INAST.LT.0)THEN !READ N+1 LSP SKIP DO I=1,-INAST READ(IREAD,*)NSB,NLB,NPB ITMPS(I)=10000*NLB+100*NSB+NPB c if(iam.eq.0)write(0,*) i, itmps(i) ENDDO ENDIF C IF(LNOEX.LT.0)LNOEX=-1 IF(LNOEX.GT.999)LNOEX=999 C IF(ICUT.LT.0)THEN IF(JREAD.GT.0)THEN WRITE(IWRITE,*)' JREAD .GT. 0 AND ICUT .LT. 0, INCOMPATIBLE?' STOP ' JREAD .GT. 0 AND ICUT .LT. 0, INCOMPATIBLE?' ELSE c **** parallel **** if(n2hdat.eq.1)then OPEN (31,FILE='HDCORR.DAT',FORM='FORMATTED',STATUS='UNKNOWN') else IFLNM='HDCORR'//filec//filed//fileu OPEN (31,FILE=IFLNM,FORM='FORMATTED',STATUS='UNKNOWN') WRITE(IWRITE,3212) IFLNM endif c **** parallel **** ENDIF ENDIF C IF(TOLER.GE.1.D-19)THEN c **** parallel **** if(n2hdat.eq.1)then OPEN (66,FILE='AMATU.DAT',FORM='UNFORMATTED',STATUS='UNKNOWN') else IFLNM='AMATU'//filec//filed//fileu//'.DAT' OPEN (66,FILE=IFLNM,FORM='UNFORMATTED',STATUS='UNKNOWN') WRITE(IWRITE,3212) IFLNM endif c **** parallel **** ENDIF C IF(ESKPL.GE.ESKPH)ESKPL=99999999.D0 IF(JRELOP(3).NE.0.OR.KCUT.GT.0)THEN !NEED ALL TERMS OR MATCH BY E ESKPH=-9999999.D0 ESKPL=99999999.D0 ECORR=99999999.D0 ENDIF ESKPL=0.5D0*ESKPL !RYD->A.U. ESKPH=0.5D0*ESKPH !RYD->A.U. ECORR=0.5D0*ECORR !RYD->A.U. C IF(BCUT.GE.0..AND.NKEY.EQ.2)THEN WRITE(IWRITE,*)'BCUT.GE.0 AND NKEY.EQ.2, ARE YOU TRYING TO READ' X,' OR WRITE A CONFIG FILE?' STOP 'BCUT.GE.0 AND NKEY.EQ.2, ARE YOU TRYING TO READ OR WRITE?' ENDIF C IF(NKEY.EQ.2)JREAD=8 IF(INAST.LT.0)INAST=0 !INAST.LT.0 NOT USED IF(INAST.GT.0)NOICC=0 IF(NOICC.NE.0)OPEN (UNIT=841,STATUS='SCRATCH',FORM='UNFORMATTED') C IF(IDWOUT.EQ.2)THEN IF(NMETA.LE.0.OR.NMETA.GT.NAST)NMETA=1 IF(LNOEX.EQ.999)LNOEX=10 ELSE NMETA=NAST ENDIF C IAUTO=0 IF(INAST.EQ.0)THEN IAUTO=1 IF(MINLT.LT.0.OR.MINLT.GT.MAXLT)THEN WRITE(IWRITE,*)' INAST=0 AND MINLT,MAXLT NOT SET MEANINGFULLY' STOP ' INAST=0 AND MINLT,MAXLT NOT SET MEANINGFULLY' ENDIF IF(LNOEX.LT.999.AND.LNOEX.GE.MINLT.AND.LNOEX.LT.MAXLT)THEN WRITE(IWRITE,*) X ' *** WARNING: MIXED EXCHANGE & NON-EXCHANGE RUN!' WRITE(0,*) X ' *** WARNING: MIXED EXCHANGE & NON-EXCHANGE RUN!' ENDIF IF(MINST.LE.0.OR.MINST.GT.MAXST)THEN WRITE(IWRITE,*)' INAST=0 AND MINST,MAXST NOT SET MEANINGFULLY' STOP ' INAST=0 AND MINST,MAXST NOT SET MEANINGFULLY' ENDIF LDIM=2*((MAXST-MINST)/2+1)*(MAXLT-MINLT+1) IF(LDIM.GT.MZSLP)CALL RECOV2('STG2RD',' MZSLP',MZSLP,LDIM) IF(LRNGDW.EQ.MZLR2)LRNGDW=MAXLT+8+1 C IS1=MINST IS2=MAXST IS3=2 IF(IPOLPH.EQ.1)THEN J1=1 J2=2 ELSE J1=2 J2=1 ENDIF DO 116 JPOL=1,J1 DO 113 L=MINLT,MAXLT IF(L.GT.LNOEX.AND.IRELOP(3).EQ.0)THEN IF(IDWOUT.EQ.2)IS3=4 IF(MINST.EQ.1)THEN IS1=3 IS2=MAX(3,MAXST) ENDIF ENDIF DO 114 IS=IS1,IS2,IS3 DO 115 JEX=1,J2 JP=MAX(JPOL,JEX) ITST=10000*L+100*IS+JP-1 DO I=1,-INAST0 IF(ITST.EQ.ITMPS(I))GO TO 115 ENDDO INAST=INAST+1 ISLP(INAST)=ITST CTEST WRITE(*,*)IS,L,JP-1 115 CONTINUE 114 CONTINUE 113 CONTINUE 116 CONTINUE ENDIF C WRITE (IWRITE,3050) MAXORB,NELC,NAST,NKEY,NCUT,INAST,IKEY,ICUT, A NDIAG,LNOEX,IDWOUT,IDWBUG,NMETA C IF (KAB1.GT.0) WRITE (IWRITE,3310) KAB1 IF (KAB1.LT.0) WRITE (IWRITE,3320) ABS(KAB1) KAB2 = ABS(KAB1) IF (KAB1.NE.0) REWIND KAB2 IF (IABS(MAXORB).GT.MXORB) X CALL RECOV2('STG2RD','MXORB ',MXORB,MAXORB) IF (NKEY.LT.2 .AND. IKEY.LT.2) JREAD = 0 C IF (IPUNCH.GT.0.OR.JREAD.GT.0.OR.BCUT.GE.0.) THEN OPEN (UNIT=8,FILE='CONFIG',STATUS='UNKNOWN', A FORM='FORMATTED') ENDIF C C IF MAXORB.LT.0 THE N,L VALUES FOR THE (-MAXORB) SHELLS ARE C AUTOMATICALLY ORDERED AS 1S,2S,2P,3S,...... C IF MAXORB.GT.0 THE N,L VALUES FOR THE (MAXORB) SHELLS ARE READ IN C C NJCOMP(I),LJCOMP(I) ..... THE N,L VALUES FOR THE I-TH SHELL. C IF (MAXORB.LE.0) THEN MAXORB = -MAXORB N = 1 L = 0 DO 10 I = 1,MAXORB NJCOMP(I) = N LJCOMP(I) = L L = L + 1 IF (L.LT.N) GOTO 10 N = N + 1 L = 0 10 CONTINUE C ELSE READ (IREAD,*) (NJCOMP(I),LJCOMP(I),I=1,MAXORB) ENDIF C NRB DO 15 I = 1,MXLCNT LCOUNT(I)=I-1 15 CONTINUE C NRB DO 20 I = 1,MAXORB NORIG(I)=NJCOMP(I) LORIG(I)=LJCOMP(I) L1=LJCOMP(I)+1 IF(L1.GT.MXLCNT)CALL RECOV2('STG2RD','MXLCNT',MXLCNT,L1) LCOUNT(L1)=LCOUNT(L1)+1 IF(LJCOMP(I).LE.8)THEN WRITE (IWRITE,3060) I,NJCOMP(I),LVALUE(LJCOMP(I)) ELSE WRITE (IWRITE,3061) I,NJCOMP(I),LJCOMP(I) ENDIF NJCOMP(I)=LCOUNT(L1) NORDER(I) = I 20 CONTINUE C C DEFINE THE N-ELECTRON STATES. C IELC = NELC WRITE (IWRITE,3220) C C IF(NCUT.GT.0 READ IN THE ARRAY IKIP(I),I=1,NCUT. C C IKIP(I) .... = 0 IF THE I-TH CONFIGURATION IS NOT TO BE STORED, C = 1 IF THE I-TH CONFIGURATION IS TO BE STORED. C IF (NCUT.GT.0) THEN IF (NCUT.GT.MZNC2) CALL RECOV2('STG2RD',' MZNC2',MZNC2,NCUT) READ (IREAD,*) (IKIP(I),I=1,NCUT) WRITE (IWRITE,3070) (IKIP(I),I=1,NCUT) ENDIF C N = 0 NCFGP = 0 MAXLA = 0 !NRB C C LOOP OVER N, THE ATOMIC OR IONIC STATES. C FOR THE DEFINITION OF NCFGT, SEE THE DESCRIPTION OF CONFIG. C 30 CONTINUE N = N + 1 IF (N.GT.MZTAR) CALL RECOV2('STG2RD',' MZTAR',MZTAR,NAST) IF (N.EQ.1) NCFGT = -1 IF (N.EQ.NAST) NCFGT = -2 IF (NAST.EQ.1) NCFGT = -3 IBUG = IBUG7 IF (NKEY.EQ.2) GOTO 80 IF (NKEY.GT.0) GOTO 40 IF (NKEY.LT.0) NOPTN = -1 IF (N.GT.1) GOTO 80 IF (NKEY.LT.0) GOTO 50 C C READ DATA INTO THE COMMON BLOCK /CUPPLE/. C C NOPTN ...... =-2 FOR NO CONFIGURATIONS FOR THIS STATE. C =-1 FOR MINIMUM CARD INPUT DATA. AS FOR NOPTN=0 C BUT THE ARRAY MXAL(I) IS NOT READ IN. C = 0 FOR NO RESTRICTION ON THE NUMBER OF ELECTRONS C EXCITED. C .GT.0 FOR A RESTRICTION ON THE NUMBER OF ELECTRONS C EXCITED FROM GIVEN BASIC CONFIGURATIONS. C THE VALUE OF IOPTN IS THE TOTAL NUMBER OF SUCH C BASIC CONFIGURATIONS. C MNAL(I) .... THE MINIMUM NUMBER OF ELECTRONS IN THE I-TH SHELL. C MNAL(I) .... THE MAXIMUM NUMBER OF ELECTRONS IN THE I-TH SHELL. C IBASSH(M,I) .... THE NUMBER OF ELECTRONS IN THE I-TH SHELL OF THE C M-TH BASIC CONFIGURATION. C NXCITE(M) .. THE MAXIMUM NUMBER OF ELECTRONS TO BE EXCITED FROM C THE M-TH BASIC CONFIGURATION. C 40 CONTINUE READ (IREAD,*) NOPTN 50 CONTINUE WRITE (IWRITE,3080) NOPTN IF (NOPTN.EQ.-2) GOTO 80 WRITE (IWRITE,3270) IELC, (NORDER(I),I=1,MAXORB) READ (IREAD,*) (MNAL(I),I=1,MAXORB) WRITE (IWRITE,3090) (MNAL(I),I=1,MAXORB) DO 60 I = 1,MAXORB MXAL(I) = 999 60 CONTINUE IF (NOPTN.EQ.-1) GOTO 80 READ (IREAD,*) (MXAL(I),I=1,MAXORB) WRITE (IWRITE,3100) (MXAL(I),I=1,MAXORB) IF (NOPTN.EQ.0) GOTO 80 C IF (NOPTN.GT.MZNC1) CALL RECOV2('STG2RD',' MZNC1',MZNC1,NOPTN) IF (NOPTN.GT.MZNC2) CALL RECOV2('STG2RD',' MZNC2',MZNC2,NOPTN) DO 70 M = 1,NOPTN READ (IREAD,*) (IBASSH(M,I),I=1,MAXORB),NXCITE(M) WRITE (IWRITE,3110) M, (IBASSH(M,I),I=1,MAXORB) WRITE (IWRITE,3120) NXCITE(M) 70 CONTINUE C C LL ........ THE TOTAL ANGULAR MOMENTUM OF THE STATE. C LSPN ...... = 2S+1, WHERE S IS THE TOTAL SPIN. C LPTY ...... THE PARITY, = 0 IF EVEN, = 1 IF ODD. C LSKP ...... SKIP LSKP ENERGY-ORDERED TERMS FOR THIS LL,LSPN,LPTY. C READ AFTER TERM IF SPIN IS NEGATIVE (SPIN THEN SET POSITIVE). C 80 CONTINUE C NRB LSKP=0 !NRB-SKIP IF(IELC.GT.NELC.AND.IAUTO.GT.0)THEN LPTY=MOD(ISLP(IAUTO),2) ISLP(IAUTO)=ISLP(IAUTO)-LPTY LL=ISLP(IAUTO)/10000 LSPN=(ISLP(IAUTO)-LL*10000)/100 IAUTO=IAUTO+1 ELSE C IF(TITLE(1).EQ.'S.S.')THEN IF(IELC.EQ.NELC.AND.KCUT.GT.0)THEN READ (IREAD,*) LSPN,LL,LPTY, ICF,IDUM,EAS ELSE READ (IREAD,*) LSPN,LL,LPTY ENDIF ELSEIF(TITLE(1).EQ.'STO-')THEN READ (IREAD,*) LL,LSPN,LPTY ENDIF C IF(LSPN.LT.0)READ(IREAD,*)LSKP !NRB-SKIP LSPN=IABS(LSPN) !NRB-SKIP IF(KCUT.GT.0)LSKP=0 !SINCE ONLY MATCH SPEC IF(IDWOUT.EQ.2.AND.IELC.GT.NELC.AND.LRNGDW.LT.LL+MAXLA+1)THEN LRNGDW=LL+MAXLA+1 WRITE(IWRITE,*)' STG2RD: INCREASE LRNGDW TO AT LEAST',LRNGDW STOP ' STG2RD: INCREASE LRNGDW' ENDIF C ENDIF C NRB c***parallel if(ifl.ge.0.and.iam.ne.ifl.and.nproc.ne.1)return c***parallel NWT=LSPN IF(IELC.GT.NELC.AND.LL.GT.LNOEX.AND.IRELOP(3).EQ.0)NWT=-NWT+1 C IF (LL.LT.0 .OR. LL.GT.8 .OR. LSPN.LT.1 .OR. LSPN.GT.8 .OR. A LPTY.LT.0 .OR. LPTY.GT.1 .OR. NWT.LT.0) THEN WRITE (IWRITE,*) ' 2S+1,L,PARITY =',NWT,LL,LPTY IF (LL.GT.8 .OR. LSPN.GT.8 .OR. NWT.LT.0) GOTO 90 WRITE (IWRITE,*) 'ERROR IN ABOVE LSPN,LL,LPTY SPECIFICATION' STOP 'ERROR IN LSPN,LL,LPTY SPECIFICATION' C ENDIF C IF (IELC.EQ.NELC) WRITE (IWRITE,3280) LSPN,PAR(LPTY),LVALUE(LL) IF (IELC.GT.NELC) WRITE (IWRITE,3130) LL,SPIN(LSPN),PARITY(LPTY+1) 90 CONTINUE C NRB IF(IELC.GT.NELC.AND.IDWOUT.EQ.2)GO TO 240 C NRB CALL CONFIG(LL,LSPN,LPTY,MAXORB,NJCOMP,LJCOMP,IELC,IBUG,NCFGT) IF (IELC.EQ. (NELC+1)) GOTO 240 IF (NAST.GT.MZTAR) CALL RECOV2('STG2RD',' MZTAR',MZTAR,NAST) IF (NCFGT.GT.MXNCF) CALL RECOV2('STG2RD','MXNCF ',MXNCF,NCFGT) IF (NCFGT.GT.MZNC1) CALL RECOV2('STG2RD','MZNC1 ',MZNC1,NCFGT) IF (NCFGT.GT.MZNC2) CALL RECOV2('STG2RD','MZNC2 ',MZNC2,NCFGT) NTCON(N) = NCFGT DO 100 I2 = 1,NCFGT NTYP(N,I2) = ITYP(I2) 100 CONTINUE LAT(N) = LL ISAT(N) = LSPN IPTY(N) = LPTY ISKIP(N)=LSKP !NRB-SKIP NDWPTY(N)=LPTY IF(IMETA(N).NE.0.OR.NMETA.GE.NAST)IMETA(N)=1 C C FIRST NMETA TERMS ARE METASTABLE IF ISORT=0 IF(ISORT.EQ.0)THEN IMETA(N)=0 IF(N.LE.NMETA)IMETA(N)=N ENDIF C MAXLA=MAX(MAXLA,LL) !NRB C IF(KCUT.GT.0)THEN !NRB STORE AS CORR INFO EAST(N)=EAS/2 !RYD->A.U. NFK(N)=ICF !NOT USED ENDIF C IF (N.LT.NAST) GOTO 30 C C STORE THE N-ELECTRON CONFIGURATION DATA IN /STATES/. C NCFG = NCFGP WRITE (IWRITE,3250) NCFG IF (NCFG.GT.MXNCF) CALL RECOV2('STG2RD','MXNCF ',MXNCF,NCFG) DO 130 I = 1,NCFG JACT = IOCCSH(I) NOCCSH(I) = JACT NP = 0 DO 120 J = 1,JACT NOCORB(J,I) = IOCORB(J,I) NELCSH(J,I) = IELCSH(J,I) J1 = JACT + J DO 110 K = 1,3 J1QNRD(J,K,I) = I1QNRD(J,K,I) IF (J.LT.JACT) J1QNRD(J1,K,I) = I1QNRD(J1,K,I) 110 CONTINUE N = NOCORB(J,I) NP = NP + NELCSH(J,I)*LJCOMP(N) 120 CONTINUE 130 CONTINUE C C SET METASTABLE INDEX EXPLICITLY C NMETAS=NMETA IF(ISORT.LT.0)THEN NMETAS=0 IS0=-1 IL0=-1 IP0=-1 I0=0 DO 128 N=1,NAST IF(IS0.NE.ISAT(N).OR.IL0.NE.LAT(N).OR.IP0.NE.IPTY(N))THEN NMETAS=NMETAS+1 IS0=ISAT(N) IL0=LAT(N) IP0=IPTY(N) ENDIF I0=I0+IMETA(N) IF(IMETA(N).GT.0)IMETA(N)=I0 IF(I0.EQ.NMETA)GO TO 129 128 CONTINUE ENDIF C C C RECUPD REQUIRES TARGET STATES = CONFIGURATIONS, IN SYMMETRY ORDER C 129 IF (JRELOP(3).NE.0 .OR. ISORT.GT.0) THEN C KCUT=0 !AS MATCHING WOULD BE INCOMPLETE C LAST1 = 0 LAST2 = 0 LAST3 = 0 I0=0 C DO 134 I = 1,NCFG C ILL = 2*NOCCSH(I) - 1 L1 = (J1QNRD(ILL,2,I)-1)/2 L2 = J1QNRD(ILL,3,I) C NRB NP=0 JACT=NOCCSH(I) DO 139 J=1,JACT N=NOCORB(J,I) NP=NP+NELCSH(J,I)*LJCOMP(N) 139 CONTINUE C NRB L3 = MOD(NP,2) LAT(I) = L1 ISAT(I) = L2 IPTY(I) = L3 NDWPTY(I) = L3 NTCON(I) = 0 ISKIP(I)=0 !NRB-SKIP C C FIRST TERM OF FIRST NMETA GROUPS IS METASTABLE IF ( L1.NE.LAST1 .OR. L2.NE.LAST2 .OR. A L3.NE.LAST3) THEN I1 = I I0=I0+1 IF(I0.LE.NMETA)IMETA(I)=1 ENDIF C LAST1 = L1 LAST2 = L2 LAST3 = L3 C NTCON(I1) = NTCON(I1)+1 134 CONTINUE C C OVERRIDE DEFAULT ASSIGNMENT OF METASTABLES. I0=0 DO 131 I=1,NCFG I0=I0+IMETA(I) IF(IMETA(I).GT.0)IMETA(I)=I0 IF(I0.GT.NMETA)THEN DO 132 J=I,NCFG IMETA(J)=0 132 CONTINUE GO TO 133 ENDIF 131 CONTINUE C 133 I1 = 1 C 135 DO 138 N = I1,I1-1+NTCON(I1) NTCON(N) = NTCON(I1) DO 136 I2 = 1,NTCON(I1) NTYP(N,I2) = I1-1+I2 136 CONTINUE 138 CONTINUE C I1 = I1 + NTCON(I1) IF (I1.LE.NCFG) GOTO 135 C WRITE (IWRITE,*) A 'NOTE ... TARGET STATES ARE PUT IN SYMMETRY ORDER', B ' AND NAST=NCFG' NAST = NCFG C ENDIF C C READ IN THE CONFIGURATION COEFFICIENTS AND ENERGIES. C IF (JRELOP(3).NE.0 .AND. NDIAG.GE.0) THEN NPOSI = 0 DO 150 I = 1,NAST DO 140 J = 1,NTCON(I) AIJ(I,J) = 0.0D0 140 CONTINUE IF (NTYP(I,1).NE.NPOSI) JSYM = 1 AIJ(I,JSYM) = 1.0D0 JSYM = JSYM + 1 NPOSI = NTYP(I,1) ENAT(I) = -1.0D0 150 CONTINUE GOTO 200 C ENDIF C IF (NDIAG.EQ.0) READ (IREAD,*) (NTCON(I),I=1,NAST) WRITE (IWRITE,3240) (NTCON(I),I=1,NAST) IF (NDIAG.GE.1) GOTO 200 SMALL = 1.0D-4 DO 190 I = 1,NAST I1 = NTCON(I) IF (I1.GT.MZNC1) CALL RECOV2('STG2RD',' MZNC1',MZNC1,I1) WRITE (IWRITE,3260) (NTYP(I,I2),I2=1,I1) READ (IREAD,*) (AIJ(I,I2),I2=1,I1),ENAT(I) WRITE (IWRITE,3190) (AIJ(I,I2),I2=1,I1) ANORM = 0.0D0 DO 160 I2 = 1,I1 ANORM = ANORM + AIJ(I,I2)**2 160 CONTINUE IF (ABS(ANORM-1.0D0).LT.SMALL) GOTO 180 WRITE (IWRITE,3210) ANORM DO 170 I2 = 1,I1 AIJ(I,I2) = AIJ(I,I2)/SQRT(ANORM) 170 CONTINUE WRITE (IWRITE,3190) (AIJ(I,I2),I2=1,I1) 180 WRITE (IWRITE,3200) ENAT(I) 190 CONTINUE C C READ INPUT FILE FROM STG1 - CHECK DATA FOR CONSISTENCY C 200 CONTINUE C C NEXT STATEMENT/TEST IS UNUSABLE, AS MODEL POTENTIAL MEANS NELC C FROM STG1 CAN DIFFER FROM THAT IN STG2 & ALSO MUST BE RE-INSTATED C BELOW - NRB C MELC = NELC C CALL CHEKTP(ITAPE1) C MAXLD=MIN(MAXLD,LRANGD-MAXLA-1) !NRB C NEED=MAXORB-KCOR IF(JRELOP(3).EQ.0.AND.IDWOUT.GT.0.AND.NEED.GT.MZOVL) X CALL RECOV2('STG2RD',' MZOVL',MZOVL,NEED) DO 220 I = 1,3 IF (ABS(JRELOP(I)).LE.IRELOP(I)) GOTO 210 C???? IF (MELC.EQ.NELC .AND. ABS(JRELOP(I)).LE.IRELOP(I)) GOTO 210 WRITE (IWRITE,*) A ' *** RELATIVISTIC OPTIONS NOT CONSISTENT' C A ' *** NELC OR RELATIVISTIC OPTIONS NOT CONSISTENT' STOP C 210 IRELOP(I) = JRELOP(I) 220 CONTINUE RETURN C C ---- DEFINE THE (N+1)-ELECTRON STATE. C 230 CONTINUE c***parallel if(ifl.lt.0.or.iam.eq.ifl.or.nproc.eq.1)then WRITE (IWRITE,3000) WRITE (IWRITE,3230) endif c***parallel NELC = MELC ! MODEL POTL -NRB IELC = NELC + 1 C C IF ICUT.GT.0 READ IN THE ARRAY IKIP(I),I=1,ICUT. C IF (ICUT.GT.0) THEN IF (MSKIP.GT.1) READ (IREAD,*) ICUT IF (ICUT.GT.MZNC2) CALL RECOV2('STG2RD',' MZNC2',MZNC2,ICUT) READ (IREAD,*) (IKIP(I),I=1,ICUT) WRITE (IWRITE,3070) (IKIP(I),I=1,ICUT) ENDIF C NCUT = ICUT NCFGP = 0 NCFGT = -3 IBUG = IBUG7 - 1 IF (ICOUNT.GE.ICOPY1 .AND. ICOUNT.LE.ICOPY2) IBUG = 0 IF (IKEY.EQ.2) GOTO 80 JREAD = 0 IF (IKEY.GT.0) GOTO 40 IF (IKEY.LT.0) NOPTN = -1 IF (MSKIP.GT.1) GOTO 80 IF(IDWOUT.EQ.2)GO TO 80 IF (IKEY.LT.0) GOTO 50 GOTO 40 C 240 CONTINUE LRGL = LL NSPN = LSPN NPTY = LPTY c IF(ICUT.LT.0.and.ncfgp.gt.0)THEN WRITE(IWRITE,3245)iidiag,ncfgp !iidiag=NCONHP write(31,3246)LRGL,NSPN,NPTY,iidiag + ncfgp !=MNP1 do i = 1, iidiag + ncfgp write(31,3247)i,hcorr(i) !,hdiag(i),hdiag(i)-hcorr(i) c write(IWRITE,3247)i,hcorr(i),hdiag(i),hdiag(i)-hcorr(i) enddo ENDIF C 3000 FORMAT (//30X,'SUBROUTINE STG2RD'/30X,17 ('-')) 3010 FORMAT (15X, A ' SSSSSSSS TTTTTTTTTT GGGGGGGG 22222222 '/ B 15X, C 'SSSSSSSSSS TTTTTTTTTT GGGGGGGGGG 2222222222'/ D 15X, E 'SS TT GG GG 22 22'/ F 15X, G 'SS TT GG 22'/ H 15X, I 'SS TT GG 22 '/ J 15X, K 'SSSSSSSSS TT GG 22 '/ L 15X, M ' SSSSSSSSS TT GG GGGG 22 '/ N 15X, O ' SS TT GG GGGG 22 '/ P 15X, Q ' SS TT GG GG 22 '/ R 15X, S ' SS TT GG GG 22 '/ A 15X, B 'SSSSSSSSSS TT GGGGGGGGGG 2222222222'/ C 15X, D ' SSSSSSSS TT GGGGGGGG 22222222 ') 3020 FORMAT (//1X,72 ('-')//1X,18A4//1X,72 ('-')////) 3030 FORMAT (/' DEBUG PARAMETERS'/12I5) 3040 FORMAT (' BASIC DATA') 3050 FORMAT (/' MAXORB =',I3,' NELC =',I3,' NAST =',I3,' NKEY =', A I3,' NCUT =',I4/25X,' INAST =',I3,' IKEY =',I3, B ' ICUT =',I4,' NDIAG =',I3//25X,' LNOEX =',I3, C ' IDWOUT =',I3,' IDWBUG =',I3,' NMETA =',I3) 3060 FORMAT (' ORBITAL',I3,' =',I2,A1) 3061 FORMAT (' ORBITAL',I3,' =',I2,I2) 3070 FORMAT (' IKIP ARRAY'/ (60I2)) 3080 FORMAT (/6X,'OPTION CHOSEN, NOPTN =',I3) 3090 FORMAT ( A ' THE MINIMUM NUMBER OF ELECTRONS ALLOWED IN EACH SHELL IS' B ,2X, (20I3)) 3100 FORMAT ( A ' THE MAXIMUM NUMBER OF ELECTRONS ALLOWED IN EACH SHELL IS' B ,2X, (20I3)) 3110 FORMAT (' BASIC CONFIGURATION',I4,37X, (20I3)) 3120 FORMAT (' THE MAXIMUM NUMBER OF ELECTRON EXCITATIONS REQUIRED=', A I3) 3130 FORMAT (/' L =',I3,3X,A8,3X,A4/1X,24 ('-')) 3140 FORMAT ( A /' INPUT-OUTPUT CHANNEL NUMBERS' B /' ----------------------------' C//' IREAD (',I2,') .. input data .. dstg2' C /' IWRITE (',I2,') .. printed output .. rout2r' C /' IPUNCH (',I2,') .. NOT USED' C /' IDISC1 (',I2,') .. scratch' C /' IDISC2 (',I2,') .. NOT USED' C /' IDISC3 (',I2,') .. NOT USED' C /' IDISC4 (',I2,') .. NOT USED' C /' ITAPE1 (',I2,') .. STG1 dump ', C ' .. STG1.DAT .. always used' C /' ITAPE2 (',I2,') .. old STG2 dump ', C ' .. STG2.DMP .. if ICOPY>0' C /' ITAPE3 (',I2,') .. STG2 dump (hamiltonians) ', C ' .. STG2H.DAT .. always used' C /' ITAPE4 (',I2,') .. STG2 dump (dipole matrix)', C ' .. STG2D.DAT .. if IPOLPH=2' C /' JREAD (',I2,') .. input config data' C /' JDISC1 (',I2,') .. RK.DAT' C /' JDISC2 (',I2,') .. NOT USED') 3150 FORMAT (38X,' INPUT CHANNEL ITAPE',I1,' =',I5) 3160 FORMAT (38X,'OUTPUT CHANNEL ITAPE',I1,' =',I5) 3170 FORMAT (' ICOPY =',I3,' ITOTAL =',I3,' IPOLPH =', A I2/' MASS-CORRECTION(',I1,'), DARWIN-TERM(',I1, B ') SPIN-ORBIT(',I2,')') 3180 FORMAT (/' POSITION THE INPUT FILE FOR COPYING SINCE ICOPY.GT.0') 3190 FORMAT (' AIJ =', (T7,8F14.7)) 3200 FORMAT (' ENAT=',8F14.7) 3210 FORMAT (' WARNING - THE NORMALIZATION OF THE STATE IS',F14.7, A ' THE STATE IS BEING RENORMALIZED') 3212 FORMAT (/' OPENING FILE ',A12) 3220 FORMAT (/10X,64 ('*')//43X,'TARGET OR CORE STATE INPUT DATA'//10X, A 64 ('*')) 3230 FORMAT (/10X,64 ('*')//49X,'SCATTERED ELECTRON DATA'//10X, A 64 ('*')) 3240 FORMAT (' NTCON=',12I5/ (7X,12I5)) 3245 FORMAT (' MATRIX DIAGONAL AND CORRECTION: ',2I7) 3246 FORMAT (3I5,I7) 3247 FORMAT (I7,1P,3D20.10) 3250 FORMAT (/' TOTAL NUMBER OF CONFIGURATIONS =',I5) 3260 FORMAT (/' NTYP=',I6,7I14/ (6X,I6,7I14)) 3270 FORMAT (' TOTAL NUMBER OF ELECTRONS =',I3,14X,'ORBITALS ARE', A (20I3)) 3280 FORMAT (/I3,1X,A1/3X,A1) 3290 FORMAT (//10X,'COMPILED FOR DIMENSIONS'//15X, A 'SCATTERING CHANNELS, NCHAN MZCHF =',I6/15X, B 'FACTORIAL VALUES IN /FACT/ MZFAC =',I6/15X, C 'MULTIPOLE ORDER IN POTENTIAL,LAMAX MZLMX =',I6/15X, D 'NO. BOUND ANGULAR MOMENTA, LRANG1 MZLR1 =',I6/15X, E 'NO. CONTINUUM ANGULAR MOM, LRANG2 MZLR2 =',I6/15X, F 'MWORDS OF RK INTEGRALS IN /MEMORY/ MZMEG =',I6/15X, F 'KWORDS OF RK INTEGRALS IN /MEMORY/ MZKIL =',I6/15X, G 'TARGET CONFIGURATIONS FOR S L PI MZNC1 =',I6/15X, H 'N+1 ELECTRON CONFIGURATIONS, NCFGP MZNC2 =',I6/15X, I 'MAXIMUM N FOR BOUND ORBITALS MZNR1 =',I6/15X, J 'MAXIMUM VALUE OF NRANG2 MZNR2 =',I6/15X, K 'OCCUPIED SHELLS MZOCC =',I6/15X, K 'OCCUPIED VALENCE SHELLS (DW) MZOVL =',I6/15X, L 'NO. OF DIFFERENT S L PI, INAST MZSLP =',I6/15X, M 'TARGET STATES TOTAL, NAST,NCFG MZTAR =',I6/15X, N 'MAXIMUM NO. OF BOUND ORBITALS MXORB =',I6//) 3300 FORMAT (18A4) 3310 FORMAT (' SEQUENTIAL OUTPUT CHANNEL FOR ANGULAR INTEGRALS =',I3) 3320 FORMAT (' SEQUENTIAL INPUT CHANNEL FOR ANGULAR INTEGRALS =',I3) END SUBROUTINE USEEAV(IRHO,ISIG) IMPLICIT REAL*8 (A-H,O-Z) C C C----------------------------------------------------------------------- C C VERSION FOR R-MATRIX CODE C C PERFORMS THE SAME FUNCTION AS FANO FOR CASES IN WHICH C THE TWO-ELECTRON PART OF THE HAMILTONIAN MATRIX ELEMENT IS C DETERMINED PURELY BY AVERAGE ENERGY EXPRESSIONS C C IRHO AND ISIG SPECIFY THE TWO INTERACTING SHELLS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MX2LR2=2*MZLR2) C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /ENAV/COEFCT(5),NINTS,KVALUE(5) COMMON /MVALUE/M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,M12,M13,M14,M15, A M16,M17,M18,M19,M20 COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) COMMON /NJLJ/NRHO,LRHO,NSIG,LSIG,NRHOP,LRHOP,NSIGP,LSIGP COMMON /XATION/AMULT(MX2LR2),BMULT(MX2LR2),KD1,KD2,KE1,KE2,MULTD, A MULTE,LNOEX C----------------------------------------------------------------------- C C DETERMINE THE INTERACTION ENERGY C N1 = NOSH1(IRHO) N2 = NOSH2(ISIG) M1 = ISIG - IRHO C IF (M1.NE.0) THEN IEQUIV = 2 AC2 = DBLE(N1*N2) ELSE IEQUIV = 1 AC2 = DBLE(N1* (N1-1)/2) ENDIF C LRHO = LJ(IRHO) LSIG = LJ(ISIG) C IF (LRHO.LE.4 .AND. LSIG.LE.4) THEN CALL INTACT(LRHO,LSIG,IEQUIV) ELSE CALL FANO(IRHO,ISIG,IRHO,ISIG) GOTO 60 ENDIF C M2 = M1 M19 = 0 M20 = 0 NRHO = NJ(IRHO) NSIG = NJ(ISIG) NRHOP = NRHO NSIGP = NSIG LRHOP = LRHO LSIGP = LSIG KD1 = 1 MULTD = 1 AMULT(1) = AC2 IF (NINTS.EQ.0) GOTO 40 IF (IEQUIV.EQ.1) GOTO 20 KD2 = 1 KE1 = KVALUE(1) + 1 KE2 = KVALUE(NINTS) + 1 IF(NSIG.EQ.999)KE2=MIN(KE2,LNOEX+1) IF(KE1.GT.KE2)THEN MULTE=0 AC2=0 ELSE MULTE = 1 ENDIF DO 10 N = 1,NINTS K = KVALUE(N) + 1 BMULT(K) = AC2*COEFCT(N) 10 CONTINUE GOTO 60 C 20 CONTINUE DO 30 N = 1,NINTS K = KVALUE(N) + 1 AMULT(K) = AC2*COEFCT(N) 30 CONTINUE KD2 = KVALUE(NINTS) + 1 GOTO 50 C 40 CONTINUE KD2 = 1 50 CONTINUE MULTE = 0 KE1 = 1 KE2 = 1 60 CONTINUE CALL PRNTWT(IRHO,ISIG,IRHO,ISIG) C END C C C SUBROUTINE VIJOUT(JA,JB) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C THIS ROUTINE PRINTS OUT THE QUANTUM NUMBERS AND COUPLING SCHEMES C FOR EACH MATRIX ELEMENT DEFINED BY SETUP. IT IS ENTERED ONLY IF C IBUG9 IS GREATER THAN ZERO. C C JA AND JB SPECIFY THE TWO INTERACTING CONFIGURATIONS C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2,MXORB3=2*MXORB+3) C COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH1(MXORB2), A NOSH2(MXORB2),J1QN1(MXORB3,3),J1QN2(MXORB3,3),IJFUL(MXORB2) C----------------------------------------------------------------------- I2HSH = 2*IHSH - 1 WRITE (IWRITE,3000) JA,JB WRITE (IWRITE,3010) (NJ(I),LJ(I),I=1,IHSH) WRITE (IWRITE,3020) WRITE (IWRITE,3030) (NOSH1(J),J=1,IHSH) I2HSH = 2*IHSH - 1 WRITE (IWRITE,3040) ((J1QN1(J,K),K=1,3),J=1,I2HSH) WRITE (IWRITE,3050) WRITE (IWRITE,3030) (NOSH2(J),J=1,IHSH) WRITE (IWRITE,3040) ((J1QN2(J,K),K=1,3),J=1,I2HSH) C 3000 FORMAT (' (CONFIG ',I2,'/V/CONFIG ',I2,')') 3010 FORMAT (/' NJ,LJ ',12 (I6,I3)) 3020 FORMAT (//' L.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY') 3030 FORMAT (/' NOSH ',10I4) 3040 FORMAT (' J1QN ',10 (I5,2I3)) 3050 FORMAT (//' R.H.S. OF HAMILTONIAN MATRIX ELEMENT DEFINED BY') END C*********************************************************************** SUBROUTINE WRINX2 IMPLICIT REAL*8 (A-H,O-Z) C C WRITES A FILE TO BE READ BY THE NOEXCHANGE PROGRAM C TO BE INSERTED IN STG2 WITH MATCHING DIMENSIONS. C FILE NAMED NX2.DAT SHOULD BE SAVED IN THE JCL IF A RUN C OF NOEX IS TO FOLLOW FOR HIGHER L AT SOME TIME. C C INCLUDE 'PARAM' C PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C COMMON /REL/JRELOP(3) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST COMMON /STATED/AIJ(MZTAR,MZNC1),NTCON(MZTAR),NTYP(MZTAR,MZNC1) COMMON /STATES/NCFG,NOCCSH(MXNCF),NOCORB(MZOCC,MXNCF), A NELCSH(MZOCC,MXNCF),J1QNRD(MXOC21,3,MXNCF),MAXORB, B NJCOMP(MXORB2),LJCOMP(MXORB2) C C ALL THE FOLLOWING DIMENSIONS ARE THE SAME AS FOR ENAT C DIMENSION LSET(MZTAR),ISPSET(MZTAR),IPISET(MZTAR), 1 IPTY(MZTAR),NSTAT(MZTAR),NCHS(0:1,MZTAR) C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc c **** parallel **** INX2=36 C C WRITE A FILE FOR THE NOEXCHANGE PROGRAM ON UNIT NUMBER C INX2 C if (iam.eq.0) then OPEN (INX2,FILE='NX2.DAT',STATUS='UNKNOWN',FORM='UNFORMATTED') else OPEN (INX2,FILE='NX2g.DAT',STATUS='UNKNOWN',FORM='UNFORMATTED') endif C C CALCULATE DIMENSIONS REQUIRED FOR NX PROGRAM AND C WRITE THEM TO THE BEGINNING OF THE NX2 DATA FILE C C CALCULATE LARGEST BOUND ORBITAL N MAXN C LARGEST TARGET L LRANG3 C LARGEST TARGET S ISRAN3 C NO. TARGET SYMMETRIES NSETS C MAX. NO. TARGET STATES WITH SAME SYMMETRY MAXNST C MAX. NO. OF TARGET CONFIGURATIONS IN A STATE MAXNCF C MAX. NO. CHANNELS FOR GIVEN LRGL,PI NCHSUM C MAX. NO. CHANNELS FOR GIVEN LRGL,PI,S MAXNCH C C INITIALISE PARAMETERS C MAXN=1 LRANG3=0 ISRAN3=1 NSETS=0 MAXNST=1 MAXNCF=1 NCHSUM=0 MAXNCH=1 C C FIRST CALCULATE THE PARITY OF EACH STATE BY CALCULATING THE C PARITY OF ONE CONFIGURATION OF EACH SINCE THIS INFORMATION C HAS NOT BEEN PASSED THROUGH A COMMON BLOCK C DO 10 IST=1,NAST IC=NTYP(IST,1) NSH=NOCCSH(IC) IPARTY=0 DO 11 ISH=1,NSH IORB=NOCORB(ISH,IC) IPARTY=IPARTY+LJCOMP(IORB)*NELCSH(ISH,IC) 11 CONTINUE IPTY(IST)=MOD(IPARTY,2) 10 CONTINUE C DO 1 I=1,MAXORB MAXN=MAX(NJCOMP(I),MAXN) 1 CONTINUE C DO 2 IST=1,NAST IPARTY=IPTY(IST) LCFG=LAT(IST) ISPIN=ISAT(IST) DO 3 IS=1,NSETS IF (LCFG .EQ. LSET(IS) .AND. 1 ISPIN .EQ. ISPSET(IS) .AND. 2 IPARTY .EQ. IPISET(IS)) THEN NSTAT(IS)=NSTAT(IS)+1 MAXNST=MAX(MAXNST,NSTAT(IS)) GO TO 2 END IF 3 CONTINUE NSETS=NSETS+1 LSET(NSETS)=LCFG ISPSET(NSETS)=ISPIN IPISET(NSETS)=IPARTY NSTAT(NSETS)=1 LRANG3=MAX(LRANG3,LCFG+1) ISRAN3=MAX(ISRAN3,ISPIN) MAXNCF=MAX(MAXNCF,NTCON(IST)) 2 CONTINUE C DO 4 ISP=1,ISRAN3 DO 41 IPI=0,1 NCHS(IPI,ISP)=0 41 CONTINUE 4 CONTINUE C C CALCULATE THE NUMBER OF CHANNELS FOR EACH TARGET SPIN C AND TOTAL PARITY C DO 5 IS=1,NSETS LCFG=LSET(IS) ISPIN=ISPSET(IS) IPARTY=IPISET(IS) DO 51 IPI=0,1 IF(MOD(IPARTY+IPI,2) .EQ. MOD(LCFG,2)) THEN NCHS(IPI,ISPIN)=NCHS(IPI,ISPIN)+(LCFG+1)*NSTAT(IS) ELSE NCHS(IPI,ISPIN)=NCHS(IPI,ISPIN)+LCFG*NSTAT(IS) END IF 51 CONTINUE 5 CONTINUE C DO 6 IPI=0,1 NCHPI=0 DO 61 ISP=ISRAN3,1,-2 NCHANS=NCHS(IPI,ISP) NCHPI=NCHPI+NCHANS MAXNCH=MAX(MAXNCH,NCHANS) 61 CONTINUE NCHSUM=MAX(NCHSUM,NCHPI) 6 CONTINUE C WRITE(INX2)MAXN,MAXORB,LRANG3,NSETS,MAXNCF,NAST,MAXNST,NCHSUM, 1 MAXNCH,ISRAN3,NCFG,JRELOP(1) C WRITE (INX2) (NOCCSH(I),I=1,NCFG) DO 7 I=1,NCFG N=NOCCSH(I) WRITE (INX2) (NOCORB(J,I),J=1,N),(NELCSH(J,I),J=1,N) M=N+N-1 WRITE (INX2) ((J1QNRD(J,K,I),K=1,3),J=1,M) 7 CONTINUE C WRITE (INX2) (NJCOMP(I),LJCOMP(I),I=1,MAXORB) WRITE (INX2) (LAT(I),ISAT(I),IPTY(I),I=1,NAST) WRITE (INX2) (NTCON(I),I=1,NAST) DO 8 I=1,NAST I1=NTCON(I) WRITE (INX2) (AIJ(I,I2),I2=1,I1),ENAT(I) 8 CONTINUE C ENDFILE INX2 REWIND INX2 CLOSE (INX2) C RETURN END C C C SUBROUTINE WRITAP(ICODE) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C WRITES THE BASIC INFORMATION ONTO THE OUTPUT FILE ITAPE3 C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXN21=MZNR2+1) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /BASIN/EIGENS(MZNR2,MZLR2),ENDS(MXN21,MZLR2),DELTA,ETA COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /REL/IRELOP(3) COMMON /SPZETA/ZESP(MZLR1),IZESP COMMON /CASES/MORE,MSKIP,IPOLPH,INAST,N2HDAT COMMON /NRBDIP/LRANGD,MAXLD C DIMENSION MAXPN(MZLR2) C----------------------------------------------------------------------- ITAPE = ITAPE3 REWIND ITAPE C WRITE (ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,IZESP, A (IRELOP(I),I=1,3),MAXLD,N2HDAT C IF (ICODE.EQ.13) THEN DO 10 L = 1,LRANG1 MAXPN(L) = MAXNHF(L) - MAXNC(L) + L - 1 10 CONTINUE ELSE DO 20 L = 1,LRANG1 MAXPN(L) = MAXNHF(L) 20 CONTINUE ENDIF C WRITE (ITAPE) (MAXPN(L),L=1,LRANG1), (MAXNLG(L),L=1,LRANG1), A (MAXNC(L),L=1,LRANG1) C DO 30 L = 1,LRANG2 WRITE (ITAPE) (EIGENS(N,L),N=1,NRANG2) WRITE (ITAPE) (ENDS(N,L),N=1,NRANG2+1) 30 CONTINUE C H = 0.0D0 WRITE (ITAPE) RA,BSTO,H,DELTA,ETA,0 C IF (LRANG2.GT.0) WRITE (ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) C END