C c PSTGJK :: Parallel Version 1.8 of stgjk/recupd. CPB 12/02/13 c NRB 30/06/21 c C. P. Ballance c Version 1.1: Initial release. c Version 1.4: C C !!! WARNING I HAVE NOT ALLOCATED DIPOLES ANYWHERE IN THE CODE C SO YOU WILL HAVE SEVERE PROBLEMS WITH DIPOLE CALCULATIONS!!! C so the variables below are just placeholders C C but precupd_dip.f should be used at that point! C C 1/ There are several FLUSH statements throughout the code, that C can be removed without impacting the result. However, large C scale calculations can take 24/48 hrs and therefore it is a good C to know how far the calculations are progressing C C 2/ The direct access files now default to record length of 64 K C rather than 512 ... just a reflection of modern architectures C C 3/ Integer*8 variables in force to increase Hamiltonian C formation beyond sqrt(2**31) in size C C 4/ MXHLS (maximum LS Hamiltonian introduced as variable in PARAM C file ... known exactly from sizeH.dat file) c c Version 1.5: C 1) Uniform common block sizes fixed C 2) Re-ordering of Hamiltonian operations in LSCONT/SPINOR C 3) Verified Breit-Pauli RMPS calculations C c c N. R. Badnell c Version 1.2: Simplified MPI c Version 1.3: Allows multiple Jp symmetries per processor c Version 1.6: Port of TECs from serial code c Version 1.7: Port of KCUT from serial code c Version 1.8: Serial updates c C*********************************************************************** C C N. R. BADNELL UoS v2.28 - QUB v1.4 17/08/17 C C C*********************************************************************** C C Developed From Belfast Atomic R-matrix Codes C C*********************************************************************** C C THE RECOUPLING PART OF C C A GENERAL PROGRAM TO CALCULATE ATOMIC CONTINUUM C C PROCESSES USING THE R-MATRIX METHOD C C R E C U P D C C DISTRIBUTED BY C C QUEEN'S UNIVERSITY BELFAST C C*********************************************************************** C C THIS PROGRAM TRANSFORMS HAMILTONIAN MATRICES AND LONG RANGE C POTENTIAL COEFFICIENTS AND DIPOLE MATRICES CALCULATED IN STG2 C FROM THE LS-COUPLING SCHEME TO A PAIR COUPLING SCHEME. C THE SPIN-ORBIT INTERACTION MAY THEN BE ADDED INTO THE C HAMILTONIAN MATRIX IF REQUIRED. C C H AND/OR D OUTPUT FILES ARE SET UP TO BE READ AS INPUT C TO STG3. THIS ENABLES STGF,STGB,STGBB,STGBF TO INCORPORATE C RELATIVISTIC EFFECTS INTO THE CALCULATION OF CROSS-SECTIONS C BETWEEN FINE-STRUCTURE LEVELS -- PROVIDED THE LONG RANGE C SPIN-ORBIT CONTRIBUTION IS ADDED IN ARRAY CFJ - WE'90APRIL23 C C MERGED RECUP + RECUPD FROM THE BREIT-PAULI CODES OF C SCOTT AND TAYLOR, CPC 25 (1982) 347-387, C ADAPTED FOR COMPATIBILITY WITH OPACITY R-MATRIX CODES. C C THE DIMENSIONS ARE INCLUDED VIA A PARAM FILE. C C REQUIRES TO BE LINKED WITH STGLIB LIBRARY ROUTINES. C C C*********************************************************************** C C ROUTINES USED IN RECUPD. C C*********************************************************************** C C MNRECU C RECUPD DRIVER C BOUNDJ C BSPNO C COPYTP C DA2 C DAFILA C DEGEN C DFIND C DJZERO C DMES C DMOUT C FINBBR C FINBCR C FINCCR C HFIND C HJZERO C IRECUP C JLRC C LSCONT C LSJCUP C LSJTRI INTEGER FUNCTION C NDEGEN C NJCHAN C NUMSYM C ORDER C READS C RECUD C RECUPJ C RECOV2 C SETL C SETR C SPINBB C SPINBC C SPINCB C SPINCC C SPINOR C TCCOUT C WRITAP C WRIT3 C STGLIB LIBRARY ROUTINES USED: C DRACAH C FACTT C HSLDR C SETUPE C TENSOR C C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN RECUPD C C*********************************************************************** C C IREAD USER INPUT FILE (FILE dstgjk) C IWRITE OUTPUT TO LINE PRINTER (FILE routjk) C C IPUNCH OPTIONAL OUTPUT FILE OF TERM COUPLING COEFFICIENTS C = 0 FOR NO SUCH COEFFS. C C IDISC1 SCRATCH DA FILE OF CHANNEL RECOUPLING DATA; C - NOT USED IF NO SPIN-ORBIT OR DIPOLE MATRIX. C IDISC2 SCRATCH DA FILE OF RECOUPLED C-C MATRIX ELEMENTS. C C ITAPE1 INPUT FILE FROM STG2 OF LS DIPOLE MATRICES C ITAPE2 INPUT FILE FROM STG2 OF LS H-MATRICES C ITAPE3 OUTPUT FILE OF RECOUPLED H-MATRICES; C = 0 FOR NO H-MATRIX RECOUPLING. C ITAPE4 OUTPUT FILE OF RECOUPLED DIPOLE MATRICES; C = 0 FOR NO DIPOLE MATRIX RECOUPLING. C C IREAD (5) .. input data .. dstgjk C IWRITE (6) .. printed output .. routjk C C IPUNCH (7) .. term coupling coeff. .. TCC.DAT .. if IPUNCH>0 C C IDISC1 (11) .. scratch file (DA2) C IDISC2 (12) .. scratch file (DA2) C IDISC3 .. NOT USED C IDISC4 .. NOT USED C C ITAPE1 (1) .. dipole input .. STG2D.DAT .. if ITAPE1>0 C ITAPE2 (2) .. hamiltonian input .. STG2H.DAT .. always used C ITAPE3 (3) .. hamiltonian output .. RECUPH.DAT .. if ITAPE3>0 C ITAPE4 (4) .. dipole output .. RECUPD.DAT .. if ITAPE1>0 C C JDISC1 .. NOT USED C JDISC2 .. NOT USED C C*********************************************************************** C C DIMENSIONING PARAMETERS USED IN RECUPD C C*********************************************************************** C C INCLUDE PARAMETERS: C C CHF (75) HIGHEST NUMBER OF CHANNELS C CHL (75) NCHAN = NUMBER OF CHANNELS IN LS COUPLING C IPH (2) IPOLPH=1 FOR ELECTRON SCATTERING ONLY, =2 OTHERWISE C LMX (8) LAMAX = MULTIPOLES IN POTENTIAL C LR1 (5) LRANG1= HIGHEST L+1 FOR BOUND ORBITALS C LR2 (20) LRANG2= HIGHEST L+1 FOR CONTINUUM ORBITALS C MEG (1) MEGA-WORDS OF MEMORY, TO REDUCE I/O (CAN BE 0) C KIL (1) KILO-WORDS OF MEMORY, TO REDUCE I/O (CAN BE 0) C NC1 (50) TARGET N-ELECTRON CONFIGURATIONS FOR GIVEN SYMMETRY C NC2 (600) NCFGP = N+1 ELECTRON CONFIGS FOR GIVEN SYMMETRY C NR1 (5) MAXNHF(L)= HIGHEST N FOR BOUND ORBITALS C NR2 (40) NRANG2= NUMBER OF CONTINUUM ORBITALS FOR GIVEN L C OCC (15) OCCUPIED SHELLS IN A GIVEN CONFIGURATION C SLP (80) INAST = NUMBER OF DIFFERENT N+1 ELECTRON SYMMETRIES C TAR (63) NAST = TARGET STATES OR CONFIGURATIONS C C*********************************************************************** C C MODULES USED IN PSTGJK C C big1 C big11 C C*********************************************************************** module big1 C C allocated in BOUNDJ C integer :: iflagbig1=0; real*8,allocatable :: HJ(:),HJBC(:),HJBB(:,:) real*8,allocatable :: HLS(:,:),DUM1(:) integer :: MAXHLS end module big1 ************************************************************************ module big11 C C CPB 24/12/2010 C real*8, allocatable :: DJ(:,:),DJBC(:,:),DJCB(:,:),DJBB(:,:,:) real*8, allocatable :: DLS(:,:,:) real*8 :: DUM2 end module big11 C*********************************************************************** C PROGRAM MNRECU use big11 IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (MXFCT=500) PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) ! DO NOT INFLATE - NRB C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) ! DO NOT INFLATE - NRB C PARAMETER (MXDUM1=1+ (MZIPH-1)* (MXHJ+MXHBC+MZNC2*MZNC2+ C A MXHLS*MXHLS)+ MZIPH*MXHBC) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLSJ=20) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXNTRI=MXNCF*MXNCF/2+MXNCF) PARAMETER (MXOCC1=MZOCC+1) PARAMETER (MXOCC2=2*MZOCC+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXTCC=100*MXNCF+MXJC) PARAMETER (MXTDW=MZLR1*MXTCC) C C MXLPOT= SIZE OF /LRPOT/, USING MXLM3=MAX(MZLMX,4): C PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) C C MXORB = NUMBER OF BOUND ORBITALS: C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXORB3=2*MXORB+3) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB) PARAMETER (MX1BC=MZNR2*MXORB) PARAMETER (MX1CC=MZNR2*MZNR2/2+MZNR2) C C*********************************************************************** C C COMMON BLOCKS USED IN RECUPD C C*********************************************************************** C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LSTORE(MZSLP),LCFG(MZSLP) COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST 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 /BNDBOX/LCFBOX(MXLSJ),LOCCSH(MZNC2),LOCORB(MZOCC,MZNC2), A LELCSH(MZOCC,MZNC2),N1QNRD(MXOC21,3,MZNC2) 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(MXNCF,MXNCF),TEMP(MXTCC), A ITMP(MXTCC),NCTMP(MXNCF),LSTO(MXNCF,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 COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) COMMON /CHANI/LL2P(MZCHL),MSTARG(MZCHL) COMMON /CHBOX/L2PBOX(MZCHL,MXLSJ),LSTBOX(MZCHL,MXLSJ) COMMON /CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DIAGC/NDIAG COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DWTCC/X(MXNCF),EIG(MXNCF),LORD(MXNCF),LVEC(MZTAR), C AUX(MXNCF,9),JDW(MXTDW),LDW(MXTDW),TCC(MXTDW),MTCC COMMON /FACTS/GAM(MXFCT) 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 /JCHAN/LJP(MZCHF),KJ(MZCHF),JTARG(MZCHF) COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /LRPOT/C(MXLPOT) COMMON /MEDEFN/IHSH,NJ(MXORB2),LJ(MXORB2),NOSH(MXORB2,2), A J1QN(MXORB3,3,2),IJFUL(MXORB2) COMMON /MEMORY/ARRAY(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 /POTORB/PV(MXJC3),QV(MXJC3),ICHAN(MXJC3),IICHAN(MXJC3), A NTERM(MZCHF),MTERM(MZCHF) COMMON /RECOV/IPLACE COMMON /REDMEL/CGC(MZLR2),MAXM1 COMMON /REL/JRELOP(3) COMMON /SHELL/VSHELL(MXORB2) COMMON /SCRACH/DUMMY(MXJC3) COMMON /SPZETA/ZESP(MZLR1),IZESP 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 /TERMS/NROWS,ITAB(18),JTAB(18),NTAB(189) C c **** parallel **** include 'mpif.h' common /parablock/iam,nproc common /pdim/mnp1p(mzslp),nconhpp(mzslp),njchap(mzslp) x ,jrglp(mzslp),jnptyp(mzslp),nsym integer noch(mzslp),noconfig(mzslp),nhamsize(mzslp), A nojrgl(mzslp),nojnpty(mzslp) c call mpi_init(ierr) call mpi_comm_rank(mpi_comm_world,iam,ierr) call mpi_comm_size(mpi_comm_world,nproc,ierr) c call cpu_time(timei) c write(0,*) ' begin proc=:',iam c **** parallel **** C C C*********************************************************************** C C RECUPD MAIN PROGRAM C C*********************************************************************** C C MEM1 AND MREC1 ARE THE MEMORY AND DA FILE POINTERS C MEM1 = 0 MREC1 = -1 C CALL RECUPD C C c **** parallel **** c call cpu_time(timef) time=timef-timei time = time/60.0 if(iam.ne.0)write(iwrite,2999) time 2999 format(//1x,'CPU TIME=:',f9.3,' MIN.') if(iam.eq.0)write(iwrite,999) time,nproc 999 format(//1x,'CPU TIME=',f9.3,' MIN -- processors=:',i4) c nroot=0 call MPI_Reduce(mnp1p,nhamsize,mzslp,MPI_INTEGER,MPI_SUM,nroot, A MPI_COMM_WORLD,ierr) call MPI_Reduce(nconhpp,noconfig,mzslp,MPI_INTEGER,MPI_SUM,nroot, A MPI_COMM_WORLD,ierr) call MPI_Reduce(njchap,noch,mzslp,MPI_INTEGER,MPI_SUM,nroot, A MPI_COMM_WORLD,ierr) call MPI_Reduce(jrglp,nojrgl,mzslp,MPI_INTEGER,MPI_SUM,nroot, A MPI_COMM_WORLD,ierr) call MPI_Reduce(jnptyp,nojnpty,mzslp,MPI_INTEGER,MPI_SUM,nroot, A MPI_COMM_WORLD,ierr) CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) c if(iam.eq.0)then OPEN(73,file='sizeBP.dat',status='unknown',form='formatted') rewind(73) ijnastp=nsym*nproc do I=1,ijnastp write(73,*)noch(I),noconfig(I),nhamsize(I), A ' 2J= ',nojrgl(I),' PI ',nojnpty(I) enddo close(73) endif c 1000 call mpi_finalize(ierr) c c **** parallel **** c STOP END C C C SUBROUTINE BOUNDJ use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 IEIGHT,MXHBC8,MXDUM18 C----------------------------------------------------------------------- C C TO FIND ENERGIES AND CI COEFFICIENTS OF J TARGET STATES C BY RECOUPLING LS TARGET HAMILTONIANS AND DIAGONALISING. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXNCF=MZTAR) PARAMETER (MXNTRI=MXNCF*MXNCF/2+MXNCF) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXTCC=100*MXNCF+MXJC) C PARAMETER (MXTDW=MZLR1*MXTCC) C CHARACTER*4 PARITY(0:1) C COMMON /DWTCC/X(MXNCF),EIG(MXNCF),LORD(MXNCF),LVEC(MZTAR), C AUX(MXNCF,9),JDW(MXTDW),LDW(MXTDW),TCC(MXTDW),MTCC C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LSTORE(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /BOUND1/HSTORE(MXNTRI),A(MXNCF,MXNCF),TEMP(MXTCC), A ITMP(MXTCC),NCTMP(MXNCF),LSTO(MXNCF,5),LNAST COMMON /CASES/MORE,MSKIP,IPOLPH,INAST COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST 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 /NRBDEL/DELELS(MZTAR),ISHFTLS COMMON /NRBKUT/EAST(MZTAR),TOLB,NFK(MZTAR),KCUT COMMON /NRBSKP/ESKPL,ESKPH,ECORR,ISKIP(MZTAR) !NRB-SKIP C DIMENSION IORD(MZTAR),MSYM(MZTAR) C DATA PARITY/'EVEN',' ODD'/,EPSI/1.0D-9/ C----------------------------------------------------------------------- TINY = 1.0D-5 NSYM = 0 WRITE (IWRITE,3000) C C allocate BIG1 array here , since BOUNDJ is called once C if(iflagbig1.eq.0)then allocate(HJ(MXHJ),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HJ in BOUNDJ' allocate(HJBC(MXHBC),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HJBC in BOUNDJ' allocate(HJBB(MZNC2,MZNC2),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HJBB in BOUNDJ' allocate(HLS(MXHLS,MXHLS),stat=ierr) if(ierr.ne.0)stop 'failure to allocate HLS in BOUNDJ' c allocate(DUM1(MXDUM1),stat=ierr) c if(ierr.ne.0)stop 'failure to allocate DUM1 in BOUNDJ' iflagbig1=1 C write(IWRITE,*)'successfully allocated MXHJ HJBC HJBB HLS and DUM' write(IWRITE,555)'MXHJ =',MXHJ,' = ',MXHJ*8,'bytes' IEIGHT=8 MXHBC8=MXHBC write(IWRITE,555)'MXHBC =',MXHBC,' = ',MXHBC8*IEIGHT,'bytes' MXDUM18=MXHLS MXDUM18=MXDUM18*MXDUM18 write(IWRITE,555)'MXHLS**2 =',MXDUM18,'=',MXDUM18*IEIGHT,'bytes' MXDUM18=MXDUM1 write(IWRITE,555)'MXDUM1=',MXDUM1,' = ',MXDUM18*IEIGHT,'bytes' call flush(iwrite) C call flush_(iwrite) !IBM SP equivalent of flush C 555 FORMAT(A7,I12,A7,I16,A5) C endif C C READ TARGET STATES BY SYMMETRY, C OPTIONALLY INDEX FOR TCC/TEC OPERATION. C LPOS = 0 JUP = 0 INAST = LNAST WRITE (IWRITE,3001) INAST, NCFG IF (INAST.GT.MZSLP) CALL RECOV2('BOUNDJ',' MZSLP',MZSLP,INAST) C DO 60 I = 1,INAST NTC = LSTO(I,4) IF (NTC.GE.0) GOTO 50 C AS NO E-VECTORS FOR TCC/TEC CALCULATION WERE PASSED ON FROM STG2. NSYM = -NTC DO 40 J = 1,NSYM JLO = JUP + 1 C = TEMP(JLO) NSP = ITMP(JLO) NTC = NCTMP(JLO) IF(NTC.NE.NSYM)THEN !SHOULD NOT HAPPEN... WRITE(IWRITE,*)'SR.BOUNDJ TEC/C INDEX ERROR: NTC.NE.NSYM:' X ,NTC,NSYM STOP 'SR.BOUNDJ: TEC INDEX ERROR, NTC.NE.NSYM' ENDIF IF (JUP.EQ.0) GOTO 30 C LORD(N) = INDEX OF TERM N IN ENERGY ORDER: DO 20 K = 1,JUP N = ITMP(K) IF (C.GE.TEMP(K)) GOTO 20 JLO = MIN(LORD(N),JLO) LORD(N) = LORD(N) + 1 20 CONTINUE 30 CONTINUE JUP = JUP + 1 IF (IBUG8.EQ.0) WRITE (IWRITE,3003) NSP,C,JUP,JLO, A (A(K,NSP),K=1,NTC) LORD(NSP) = JLO ENATJ(NSP)=C !HOLD 40 CONTINUE 50 CONTINUE LCFG(I) = NTC WRITE (IWRITE,3004)LSTO(I,1),LSTO(I,2),PARITY(LSTO(I,3)),NTC L2(I) = LSTO(I,1)*2 LS(I) = LSTO(I,2) - 1 LP(I) = LSTO(I,3) LSTORE(I) = LPOS LPOS = LPOS + LSTO(I,5) 60 CONTINUE C IF(NSYM.EQ.0)GO TO 70 C DO I=1,NAST IORD(LORD(I))=I ENDDO C C NRB: ADJUST HSTORE FOR TEC OPERATION C IF(ISHFTLS.NE.0)THEN DO K=1,NAST DELELS(K)=0.0D0 ENDDO READ(80,*)NOBS,UNITS WRITE(IWRITE,3005)NOBS E00=ENATJ(IORD(1)) DO N=1,NOBS READ(80,*)I,DEM DELELS(I)=DEM/UNITS !RY L=IORD(I) T0=(ENATJ(L)-E00)*2.0D0 IF(ISHFTLS.LT.0)DELELS(I)=DELELS(I)-T0 !CONVERT CALC E TO DE WRITE(6,3006)I,L,T0,DELELS(I),(T0+DELELS(I)) DELELS(I)=DELELS(I)/2.0D0 !A.U. ENDDO JUP=0 LPOS=0 DO L=1,LNAST NTC=-LSTO(L,4) C LPOS=LSTORE(L) DO I=1,NTC DO J=I,NTC LPOS=LPOS+1 DO K=1,NTC KT=JUP+K KE=LORD(KT) HSTORE(LPOS)=HSTORE(LPOS)+A(I,KT)*A(J,KT)*DELELS(KE) ENDDO ENDDO ENDDO JUP=JUP+NTC ENDDO ENDIF C C LOOP OVER ALL J TARGET STATES; FOR EACH SYMMETRY LOOK AT FIRST ONE C 70 IF (JNTCON(1).GT.0) GOTO 350 C JMAX = 0 JCHEK=0 C DO 220 J = 1,JNAST C JRGL = JJ(J) JNPTY = JPTY(J) C C CHECK FOR OLD J, PARITY. C IF (J.GT.1) THEN DO 80 K = 1,J - 1 IF (JRGL.EQ.JJ(K) .AND. JNPTY.EQ.JPTY(K)) GOTO 220 80 CONTINUE ENDIF C JMAX = MAX(JRGL,JMAX) AJ = .5D0*JRGL IF (IBUG8.GT.0) WRITE (IWRITE,3020) AJ,PARITY(JNPTY) C C LOCATE LS TARGET STATES COUPLED TO CURRENT J SYMMETRY TO DEFINE C JNTCON AND LSVALU C K = 0 DO 90 I = 1,NAST IF (LSJTRI(2*LAT(I),ISAT(I)-1,LPTY(I),JRGL,JNPTY).EQ. A 0) GOTO 90 K = K + 1 LSVALU(J,K) = I 90 CONTINUE JNTCON(J) = K C C ZEROISE HJBB (J HAMILTONIAN MATRIX) C DO 110 K = 1,MZNC2 DO 100 I = 1,MZNC2 HJBB(I,K) = 0.0D0 100 CONTINUE 110 CONTINUE C C LOOP OVER LS SYMMETRIES WHICH COUPLE TO CURRENT J (JRGL,JNPTY) C AND FILL HJBB. C JNCFGP = COUNTER ON TOTAL NUMBER OF BOUND TERMS FOR CURRENT J. C JNCFGP = 0 DO 140 L = 1,INAST IF (LSJTRI(L2(L),LS(L),LP(L),JRGL,JNPTY).EQ.0) GOTO 140 INIT = JNCFGP + 1 LPOS = LSTORE(L) - JNCFGP JNCFGP = JNCFGP + LCFG(L) IF (JNCFGP.GT.MZNC2) X CALL RECOV2('BOUNDJ',' MZNC2',MZNC2,JNCFGP) DO 130 I = INIT,JNCFGP DO 120 K = I,JNCFGP HJBB(I,K) = HSTORE(K+LPOS) 120 CONTINUE LPOS = LPOS + JNCFGP - I 130 CONTINUE 140 CONTINUE C C IF SPIN-ORBIT INTERACTION REQUIRED, LOOP OVER PAIRS OF LS C SYMMETRIES. HLS IS USED AS TEMPORARY STORE FOR S-O CONTRIBUTION. C IF (JRELOP(3).NE.0) CALL BSPNO(JRGL,JNPTY) C C COPY J HAMILTONIAN MATRIX INTO LINEAR ARRAY HJ FOR HSLDR C LD = ((JNCFGP+1)*JNCFGP)/2 IF (LD.GT.MXHJ) CALL RECOV2('BOUNDJ','MXHJ ',MXHJ,LD) LPOS = 0 DO 160 I = 1,JNCFGP DO 150 K = I,JNCFGP HJ(K+LPOS) = HJBB(I,K) 150 CONTINUE LPOS = JNCFGP - I + LPOS 160 CONTINUE C C CHECK ALL OTHER STATES FOR SAME J, PARITY. C JSYM=1 MSYM(1)=J NSKIP=ISKIP(J) !NRB-SKIP IF (J.NE.JNAST) THEN DO 170 K = J + 1,JNAST IF (JRGL.NE.JJ(K) .OR. JNPTY.NE.JPTY(K)) GOTO 170 JSYM=JSYM+1 MSYM(JSYM)=K NSKIP=NSKIP+ISKIP(K) !NRB-SKIP 170 CONTINUE ENDIF C C DIAGONALISE HJ. DEFINE QUANTITIES IN /JSTATE/, EIGENVALUES INTO C ENATJ, VECTORS INTO B, IN ASCENDING ENERGY ORDER (NOTE THAT HSLDR C PRODUCES EIGENVALUES IN DESCENDING ORDER). C IF (JNCFGP.GT.MXNCF) CALL RECOV2('BOUNDJ','MXNCF ',MXNCF,JNCFGP) C ISKIP0=0 !NRB-SKIP NSKIP0=NSKIP !NRB-SKIP NSTORE=0 !NRB-SKIP IF(ESKPL.LE.ESKPH)NSTORE=JNCFGP-JSYM-NSKIP !NRB-SKIP C DO 210 I = 1,JNCFGP C CALL HSLDR(JNCFGP,HJ,LD,EPSI,EIG,X,I,AUX,MXNCF) C IF(I*J.EQ.1)E00=EIG(JNCFGP) !NRB-SKIP C C CHANGE OVERALL PHASE OF EIGENVECTORS SO THAT THE LARGEST C COMPONENT IS ALWAYS POSITIVE -- MCHF CONVENTION C C VMAX=0.0D0 C NMAX=0 C DO 115 N=1,NTC C ABSEIG=ABS(X(N)) C IF(ABSEIG.LT.VMAX) GO TO 115 C NMAX=N C VMAX=ABSEIG C 115 CONTINUE C IF(X(NMAX).LT.0.0) THEN C DO 117 N=1,NTC C X(N)=-X(N) C 117 CONTINUE C END IF C T=EIG(I)-E00 !NRB-SKIP IF(KCUT.GT.0)THEN JCHEK=JCHEK+1 DO K=1,JSYM JUP=MSYM(K) IF(ABS(T-EAST(JUP)).LT.TOLB)GO TO 175 !MATCHES SPEC ENDDO JCHEK=JCHEK-1 GO TO 210 !ASSUME CORR ENDIF C IF(ESKPL.GT.ESKPH.AND.JNCFGP-I.GE.JSYM+NSKIP)GOTO 210!NRB-SKIP IF(T.GE.ESKPL.AND.T.LE.ESKPH.OR.T.GT.ECORR)THEN !NRB-SKIP NSTORE=NSTORE-1 !NRB-SKIP GO TO 210 !NRB-SKIP ENDIF !NRB-SKIP IF(ISKP0.GT.0)GO TO 215 !NRB-SKIP JUP = MSYM(JNCFGP-I+1-NSKIP0-NSTORE) !NRB-SKIP ISKP0=ISKIP(JUP) !NRB-SKIP NSKIP0=NSKIP0-ISKIP0 !NRB-SKIP C 175 CONTINUE ENATJ(JUP) = EIG(I) DO 180 K = 1,JNCFGP B(JUP,K) = X(K) 180 CONTINUE DO 190 K = 1,JNTCON(J) LSVALU(JUP,K) = LSVALU(J,K) 190 CONTINUE LVEC(JUP) = JNCFGP JNTCON(JUP) = JNTCON(J) 200 CONTINUE GO TO 210 !NRB-SKIP 215 ISKP0=ISKP0-1 !NRB-SKIP C 210 CONTINUE !END LOOP OVER CI C 220 CONTINUE !END LOOP OVER NASTJ TARGETS C IF(JCHEK*JCHEK.NE.JCHEK*JNAST)THEN WRITE(IWRITE,3043)JNAST,JCHEK,2*TOLB STOP' ****SR.BOUNDJ: MIS-MATCH, CANNOT FIND JNAST LEVELS!' ENDIF C C TABULATE THE DATA DEFINING THE TARGET STATES C WRITE (IWRITE,3060) DO 230 I = 1,JNAST AJ = JJ(I)*0.5D0 C = (ENATJ(I)-ENATJ(1))*2.0D0 WRITE (IWRITE,3050) I,AJ,PARITY(JPTY(I)),ENATJ(I),C 230 CONTINUE WRITE (IWRITE,'(/" LEVEL: EIGENVECTOR")') DO 240 I = 1,JNAST K = LVEC(I) WRITE (IWRITE,'(I5,(T6,5F14.7))') I, (B(I,J),J=1,K) 240 CONTINUE WRITE (IWRITE,'(/'' LEVEL LVEC JNTCON: COMPONENT TERMS'')') DO 250 I = 1,JNAST K = JNTCON(I) WRITE (IWRITE,'(4I6,14I4)') I,LVEC(I),JNTCON(I), A (LSVALU(I,J),J=1,K) 250 CONTINUE C C COMPUTE TERM COUPLING COEFFS - H E SARAPH CPC 3(1972)256-68. C IF (IPUNCH.LE.0) GOTO 350 IF (NSYM.NE.0) GOTO 260 WRITE (IWRITE,"(' - NO DATA FROM STG2 - CANNOT COMPUTE TCCS -')" A ) GOTO 350 C 260 CONTINUE C WRITE (IWRITE,3010) (LORD(K),K=1,NAST) C C BEGIN TCC OUTPUT. WRITE TARGET TERMS IN ENERGY ORDER C WRITE (IPUNCH,"(I4,' TERMS:')") NAST DO 262 I=1,NAST K=IORD(I) WRITE (IPUNCH,'(I4,3I3)') I,ISAT(K),LAT(K),LPTY(K) 262 CONTINUE C C LOOP OVER TARGET J AND PARITY JNPTY C MTCC=0 !TCCOUT DO 340 J = MOD(JMAX,2),JMAX,2 M = 0 DO 331 JNPTY = 0,1 KP = 0 C C LOOP OVER LS TERMS IN ENERGY ORDER; FIND NSQ AS KP-TH LOWEST C DO 330 I = 1,JNAST IF (JJ(I).NE.J.OR.JPTY(I).NE.JNPTY) GO TO 330 KP = KP + 1 KOUNT=0 DO 282 II=1,NAST DO 281 LL=1,JNTCON(I) NSQ = LSVALU(I,LL) IF(LORD(NSQ).EQ.II) THEN KOUNT=KOUNT+1 IF(KOUNT.EQ.KP) GO TO 283 GO TO 282 ENDIF 281 CONTINUE 282 CONTINUE C C LOOP OVER LS TERMS IN ENERGY ORDER; FIND NSP AS L-TH LOWEST C 283 DO 320 L = 1,JNTCON(I) KOUNT=0 DO 285 II=1,NAST DO 284 LL=1,JNTCON(I) NSP = LSVALU(I,LL) IF(LORD(NSP).EQ.II) THEN KOUNT=KOUNT+1 IF(KOUNT.EQ.L) GO TO 286 GO TO 285 ENDIF 284 CONTINUE 285 CONTINUE C 286 LPOS = 0 DO 290 K = 1,INAST IF (LSJTRI(L2(K),LS(K),LP(K),J,JNPTY).EQ.0) GO TO 290 IF (2*LAT(NSP).EQ.L2(K) .AND. A ISAT(NSP)-1.EQ.LS(K)) GO TO 300 LPOS = LCFG(K) + LPOS 290 CONTINUE STOP C C MULTIPLY LEVEL EIGENVECTORS WITH TERM EIGENVECTORS FOR TCC C 300 C = 0.D0 DO 310 K = 1,NTCON(NSP) C = B(I,K+LPOS)*A(K,NSP) + C 310 CONTINUE IF (ABS(C).LT.TINY) GO TO 320 M = M + 1 C C STORE THE TERM COUPLING COEFFICIENTS FOR WRITING IN TCCOUT C MTCC=MTCC+1 !TCCOUT IF(MTCC.LT.MXTDW)THEN !TCCOUT JDW(MTCC)=I !TCCOUT LDW(MTCC)=NSP !TCCOUT TCC(MTCC)=C !TCCOUT ENDIF !TCCOUT C IF (M.GT.MXTCC) GO TO 320 TEMP(M) = C IF(NAST.LT.100) THEN ITMP(M) = 100*LORD(NSP) + LORD(NSQ) ELSE ITMP(M) = 1000*LORD(NSP) + LORD(NSQ) ENDIF 320 CONTINUE 330 CONTINUE 331 CONTINUE C C END OF LOOPS OVER TARGET TERMS COUPLED TO THIS J. OUTPUT TCCS. C IF (M.GT.MXTCC) CALL RECOV2('BOUND','MXTCC ',MXTCC,M) IF (M.EQ.0) GO TO 340 IF (IPUNCH.NE.IWRITE) WRITE (IWRITE,3030) J,M IF(NAST.LT.100) THEN WRITE (IPUNCH,3040) J,M,NZ,NELC, (ITMP(K),TEMP(K),K=1,M) ELSE WRITE (IPUNCH,3041) J,M,NZ,NELC, (ITMP(K),TEMP(K),K=1,M) ENDIF 340 CONTINUE C C END OF LOOP OVER J. TERMINATE OUTPUT. C WRITE (IPUNCH,'(9X,"0 0",5X,"TCC END")') C C ALTERNATE FORMAT OUTPUT OF TCC'S AND LEVEL ENERGIES FOR STGIC. C CALL TCCOUT !TCCOUT C 350 CONTINUE C 3000 FORMAT (//52X,'SUBROUTINE BOUNDJ'/52X,17 ('-')) 3001 FORMAT (/I5,' TARGET SYMMETRIES (LS)',I5, A ' TARGET CONFIGURATIONS (TOTAL)'/) 3003 FORMAT (' NSP =',I5,3X,'E =',F16.7,3X,'JUP, JLO =',2I5,5X,' EVEC:' A /(1X,10F10.6)) 3004 FORMAT (' L =',I3,' 2S+1 =',I3,2X,A4,I5,' CONFIGURATION(S)'/) 3005 FORMAT (/I5,2X,'TERM ENERGY CORRECTIONS (RY):') 3006 FORMAT (I5,I5,F14.6,F11.6,F14.6) 3010 FORMAT (/' TERM ENERGY ORDER', (T8,18I4)) 3020 FORMAT (/' TARGET SYMMETRY J =',F4.1,1X,A4/1X,28 ('-')) 3030 FORMAT (7X,I3,I5,13X,'HEADER CARD FOR TERM COUPLING COEFFICIENTS') 3040 FORMAT (7X,I3,I5,5X,'TCCS BASED ON FANO-BP: Z =',I3,', N =', A I3/ (5 (I5,F9.6))) 3041 FORMAT (7X,I3,I5,5X,'TCCS BASED ON FANO-BP: Z =',I3,', N =', A I3/ (5 (I7,F9.6))) 3043 FORMAT(/' ****SR.BOUNDJ: YOU HAVE REQUESTED JNAST=',I5, X' LEVELS, BUT ONLY ',I5,' FOUND'/' ****SR.BOUNDJ: CHECK AS vs RM', X' STRUCTURES AND/OR INCREASE TOLB TO',1PE9.1) 3050 FORMAT (I5,F6.1,3X,A4,2F16.7) 3060 FORMAT (/' LEVEL J PARITY ENERGY EI/2RY',6X,'(EI-E1)/RY') END C C C SUBROUTINE BSPNO(JRGL,JNPTY) use big1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C ADDS SPIN-ORBIT CONTRIBUTION INTO HJBB FOR J TARGET - QUB'92JN-JL C C JRGL,JNPTY = CURRENT 2J,PARITY FOR TARGET STATES. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) 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 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 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 ITWO/2/ C----------------------------------------------------------------------- C C ---- LOOP ROUND THE LOWER HALF OF THE LSJ-HAMILTONIAN MATRIX C ZERO = 0.0D0 IBNDL = 0 DO 150 MI = 1,INAST IBNDR = 0 LRGL = L2(MI) NSPN = LS(MI) NPTY = LP(MI) IF (LSJTRI(LRGL,NSPN,NPTY,JRGL,JNPTY).EQ.0) GOTO 150 C C FIND COEFFICIENTS FOR THIS LS SYMMETRY AND STORE IN /BNDCON/, C HAVING HIT THE FIRST TERM ASSOCIATED WITH THIS SYMMETRY C DO 10 I = 1,NAST IF (LRGL.NE.2*LAT(I) .OR. NSPN.NE.ISAT(I)-1 .OR. A NPTY.NE.LPTY(I)) GOTO 10 M = I GOTO 20 C 10 CONTINUE STOP C 20 CONTINUE NCFGP = LCFG(MI) DO 50 I = 1,NCFGP K = NTYP(M,I) L = NOCCSH(K) DO 30 J = 1,L IOCORB(J,I) = NOCORB(J,K) IELCSH(J,I) = NELCSH(J,K) 30 CONTINUE DO 40 J = 1,2*L + 1 I1QNRD(J,1,I) = J1QNRD(J,1,K) I1QNRD(J,2,I) = J1QNRD(J,2,K) I1QNRD(J,3,I) = J1QNRD(J,3,K) 40 CONTINUE IOCCSH(I) = L 50 CONTINUE C C ---- READ THE DATA DEFINING THE RIGHT HAND SIDE OF MATRIX ELEMENTS C DO 140 MJ = 1,MI LLRGL = L2(MJ) NNSPN = LS(MJ) NNPTY = LP(MJ) IF (LSJTRI(LLRGL,NNSPN,NNPTY,JRGL,JNPTY).EQ.0) GOTO 140 C C CHECK IF THE RACAH COEFFICIENT IS ZERO; C IF IT IS THERE IS NO SPIN-ORBIT CONTRIBUTION TO THIS BLOCK C C INTERCHANGE PRIME AND UNPRIME LRGL<->LLRGL AND NSPN<->NNSPN !KAB/PJS 12/01/07 CALL DRACAH(LRGL,LLRGL,NSPN,NNSPN,ITWO,JRGL,RAC) !KAB/PJS 12/01/07 RAC = (-1)** (ABS((LRGL+NNSPN-JRGL)/2)+2)*RAC !KAB/PJS 12/01/07 IF (IBUG8.GT.0) WRITE (IWRITE, A *) ' SPIN-ORBIT CONTRIBUTION FROM ',LRGL,NSPN,NPTY,' /', B LLRGL,NNSPN,NNPTY,' RAC = ',RAC MCFGP = LCFG(MJ) IF (RAC.EQ.ZERO) GOTO 130 C C FIND CONFIGURATIONS FOR THIS LS SYMMETRY AND STORE IN /BNDINI/ C DO 60 I = 1,NAST IF (LLRGL.NE.2*LAT(I) .OR. NNSPN.NE.ISAT(I)-1 .OR. A NNPTY.NE.LPTY(I)) GOTO 60 M = I GOTO 70 C 60 CONTINUE STOP C 70 CONTINUE DO 100 I = 1,MCFGP K = NTYP(M,I) L = NOCCSH(K) DO 80 J = 1,L JOCORB(J,I) = NOCORB(J,K) JELCSH(J,I) = NELCSH(J,K) 80 CONTINUE DO 90 J = 1,2*L - 1 L1QNRD(J,1,I) = J1QNRD(J,1,K) L1QNRD(J,2,I) = J1QNRD(J,2,K) L1QNRD(J,3,I) = J1QNRD(J,3,K) 90 CONTINUE JOCCSH(I) = L 100 CONTINUE C C CALCULATE THE SPIN-ORBIT INTERACTION FOR THE BOUND-BOUND C MATRIX BLOCKS (SPINBB NOW PROVIDES FULL MATRIX) C CALL SPINBB(MI,MJ) DO 120 I = 1,MCFGP DO 110 J = 1,NCFGP HJBB(I+IBNDR,J+IBNDL) = HLS(I,J)*RAC + A HJBB(I+IBNDR,J+IBNDL) 110 CONTINUE 120 CONTINUE C 130 CONTINUE IBNDR = IBNDR + MCFGP 140 CONTINUE IBNDL = IBNDL + NCFGP 150 CONTINUE C C PRINT THE J-HAMILTONIAN BLOCKS INCLUDING THE SPIN-ORBIT C INTERACTION. C IF (IBUG8.LE.0) GOTO 180 WRITE (IWRITE,3020) DO 160 I = 1,IBNDL WRITE (IWRITE,3010) I, (HJBB(I,J),J=I,IBNDL) 160 CONTINUE WRITE (IWRITE,3000) 180 CONTINUE C 3000 FORMAT (' SPIN-ORBIT INTERACTION INCLUDED') 3010 FORMAT (/6X, A'BOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM CONFIGURAT BION',I3/ (8F14.7)) 3020 FORMAT (/9X, A'TRANSFORMED HAMILTONIAN MATRICES INCLUDING THE SPIN- ORBIT INTER BACTION'/9X,69 ('-')) 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 (MXJC=MZCHF*MZCHL) PARAMETER (MXN21=MZNR2+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXNTRI=MXNCF*MXNCF/2+MXNCF) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB) PARAMETER (MX1BC=MZNR2*MXORB) PARAMETER (MX1CC=MZNR2*MZNR2/2+MZNR2) PARAMETER (MXTCC=100*MXNCF+MXJC) 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(MXNCF,MXNCF),TEMP(MXTCC), A NTMP(MXTCC),NTCTMP(MXNCF),LSTO(MXNCF,5),LNAST COMMON /BUTT/COEFF(3,MZLR2),EK2MAX,EK2MIN,MAXNCB(MZLR2),NELCOR COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /DIAGC/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/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/MAXLD,J2MAXD 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 MAXLD=999 READ (ITAPE,ERR=9) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM, A IZESP,(IRELOP(I),I=1,3),MAXLD 9 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,ERR=10) (ENDS(N,L),N=1,NRANG2+1) 10 CONTINUE READ (ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX IF (FIRST) WRITE (IWRITE,3060) RA,BSTO C 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 C OPTIONALLY READ LS TARGET E-VECTORS FOR TCCS AND TECS. 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 C READ THE LS TARGET HAMILTONIANS FOR EACH LL,LS,LP SYMMETRY, C AND PUT ALL OF THEM INTO HSTORE, USING LSTORE AS POINTERS. 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 C READ THE LS TARGET STATES, C IF (FIRST) WRITE (IWRITE,*) NAST,' TARGET TERMS' IF (NAST.GT.MZTAR) CALL RECOV2('COPYTP','MZTAR ',MZTAR,NAST) READ (ITAPE) (ENAT(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) WRITE (IWRITE,3055) (ENAT(I),I=1,NAST) ENDIF C C READ CONFIGURATIONS AND SPIN-ORBIT INTEGRALS 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.MZNC1) CALL RECOV2('COPYTP','MZNC1 ',MZNC1,NT) !NOT READ (ITAPE) (NTYP(I,J),J=1,NT), (AIJ(I,J),J=1,NT) !MXNCF 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 (//52X,'SUBROUTINE COPYTP'/52X,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)) 3055 FORMAT (' ENAT =', (10F14.5)) 3060 FORMAT (' RA =',F10.5,' BSTO =',F10.5) 3070 FORMAT (' MASS-CORRECTION(',I1,'),',' DARWIN-TERM(',I1,'),', A ' SPIN-ORBIT(',I2,')') END C C C SUBROUTINE DA2(KEY,IREC,JDISC,LENGTH,ARRAY) IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 IREC,I,I1,I2,ONE,LREC8,LENGTH8 CHARACTER*1 NUM(0:9) common /parablock/iam,nproc DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ 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=16384) c DIMENSION ARRAY(LENGTH) C----------------------------------------------------------------------- C ONE=1 IF (IREC.GT.0) GOTO 20 c ii1=iam/100 c ii2=(iam-100*(iam/100))/10 c ii3=iam-(100*(iam/100))-ii2*10 C IRECL = 8*LREC C IF (IREC.LT.0) THEN c IF(JDISC.eq.12)THEN c OPEN (JDISC,FILE='SCRATCHA'//NUM(ii1)//NUM(ii2)//NUM(ii3) c X ,ACCESS='DIRECT', c X RECL=IRECL) c ENDIF c IF(JDISC.eq.11)THEN c OPEN (JDISC,FILE='SCRATCHB'//NUM(ii1)//NUM(ii2)//NUM(ii3) c X ,ACCESS='DIRECT', c X RECL=IRECL) c ENDIF C CLUSTER: USE LOCAL SCRATCH FOR FASTER I/O (WE HAVE PLENTY) - NRB 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 OPEN (JDISC,STATUS='OLD',FILE='RK.DAT',ACCESS='DIRECT', A RECL=IRECL) ENDIF C 10 CONTINUE IREC = 1 C 20 CONTINUE IF (LENGTH.EQ.0) RETURN I2 = 0 30 CONTINUE I1 = I2 + ONE LREC8=LREC LENGTH8=LENGTH I2 = MIN(I2+LREC8,LENGTH8) IF (KEY.EQ.0) GOTO 40 C IF (KEY.EQ.2) THEN C if(iam.eq.0)write(0,*)'DA-w',LENGTH,I1,I2,IREC WRITE (JDISC,REC=IREC) (ARRAY(I),I=I1,I2) call flush(jdisc) ELSE C if(iam.eq.5)write(0,*)'Da-r',LENGTH,I1,I2,IREC READ (JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ENDIF C 40 CONTINUE IREC = IREC + ONE IF (I2.LT.LENGTH8) GOTO 30 C END SUBROUTINE DAFILA(KEY,LPOS,L2,J2,NJCHA,NTERM,NTERMI,ICHAN,PV) IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KREC C C C C----------------------------------------------------------------------- C C TO READ (KEY=1) OR WRITE (KEY=2) CHANNEL RECOUPLING DATA TO C MEMORY OR DA FILE (IDISC1). C LPOS = POSITION OF L-S-PI IN /ALPHA/ ARRAYS; C L2 = 2L; J2 = 2J; C NJCHA = NUMBER OF J CHANNELS, AND MUST BE DEFINED BEFORE ENTRY. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLSJ=20) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) C DIMENSION NTERM(NJCHA),ICHAN(MXJC3),PV(MXJC3) DIMENSION INTERM(MZSLP,MXLSJ),IRECA(MZSLP,MXLSJ) C COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /SCRACH/DUMMY(MXJC3) C SAVE INTERM,IRECA,MREC,MEM C DATA MREC/-1/,MEM/0/ C----------------------------------------------------------------------- MEM18=MEM1 C MJ = ABS(J2-L2) IF (J2.GE.L2) MJ = MJ + 1 IF (MJ.GT.MXLSJ) CALL RECOV2('DAFILA','MXLSJ ',MXLSJ,MJ) IF (NJCHA.GT.MXJC3) CALL RECOV2('DAFILA','MXJC3 ',MXJC3,NJCHA) C C IRECA= POSITION IN DA FILE (IF +VE) OR MEMORY (IF -VE). C MEM = MEMORY POINTER FOR WRITING. C DO NOT WRITE IN MEMORY BEYOND MEM1 - USE DA FILE INSTEAD. C IF (KEY.EQ.2) THEN IRECA(LPOS,MJ) = -MEM IF (MEM+NJCHA+2*NTERMI.GT.MEM1) IRECA(LPOS,MJ) = ABS(MREC) INTERM(LPOS,MJ) = NTERMI C ELSE NTERMI = INTERM(LPOS,MJ) ENDIF C IF (NTERMI.GT.MXJC3) CALL RECOV2('DAFILA','MXJC3 ',MXJC3,NTERMI) KREC = ABS(IRECA(LPOS,MJ)) IF (IRECA(LPOS,MJ).GT.0) GOTO 50 C C USING MEMORY. INCREMENT MEM IF WRITING. C M1 = KREC + NJCHA M2 = M1 + NTERMI IF (KEY.EQ.2) THEN MEM = MEM + NJCHA + 2*NTERMI DO 10 I = 1,NJCHA ARRAY(KREC+I) = NTERM(I) + 0.1D0 10 CONTINUE DO 20 I = 1,NTERMI ARRAY(M1+I) = ICHAN(I) + 0.1D0 ARRAY(M2+I) = PV(I) 20 CONTINUE C ELSE DO 30 I = 1,NJCHA NTERM(I) = INT(ARRAY(KREC+I)) 30 CONTINUE DO 40 I = 1,NTERMI ICHAN(I) = INT(ARRAY(M1+I)) PV(I) = ARRAY(M2+I) 40 CONTINUE ENDIF C RETURN C C USING DA FILE. INCREMENT MREC IF WRITING. C 50 CONTINUE IF (KEY.EQ.2) THEN KREC = MREC DO 60 I = 1,NJCHA DUMMY(I) = DBLE(NTERM(I)) + 0.1D0 60 CONTINUE ENDIF C CALL DA2(KEY,KREC,IDISC1,NJCHA,DUMMY) IF (KEY.EQ.1) THEN DO 70 I = 1,NJCHA NTERM(I) = INT(DUMMY(I)) 70 CONTINUE ENDIF C IF (KEY.EQ.2) THEN DO 80 I = 1,NTERMI DUMMY(I) = DBLE(ICHAN(I)) + 0.1D0 80 CONTINUE ENDIF C CALL DA2(KEY,KREC,IDISC1,NTERMI,DUMMY) IF (KEY.EQ.1) THEN DO 90 I = 1,NTERMI ICHAN(I) = INT(DUMMY(I)) 90 CONTINUE ENDIF C CALL DA2(KEY,KREC,IDISC1,NTERMI,PV) C IF (KEY.EQ.2) MREC = KREC C END C C C SUBROUTINE DEGEN(E,LSTARG,NCHAN) use big1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C ADJUSTS THE DIAGONAL ELEMENTS OF THE C CONTINUUM-CONTINUUM MATRIX BLOCKS TO MAKE THE TARGET LEVELS C DEGENERATE WITH THE GROUND STATE. THE DEGENERACY IS RESTORED C AGAIN IN SUBROUTINE NDEGEN. C C E = GROUND STATE ENERGY, C LSTARG(NCHAN) = LS TARGET STATE COUPLED TO EACH LS CHANNEL. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) C DIMENSION LSTARG(NCHAN) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST C----------------------------------------------------------------------- DO 20 K1 = 1,NCHAN C C FIND THE STATE THAT THIS CHANNEL IS COUPLED TO. C I1 = LSTARG(K1) DELTA = E - ENAT(I1) C C ADJUST THE DIAGONAL ELEMENTS. C KAB12 = (K1-1)*NRANG2 DO 10 J = 1,NRANG2 HLS(KAB12+J,KAB12+J) = HLS(KAB12+J,KAB12+J) + DELTA 10 CONTINUE 20 CONTINUE C END C C C SUBROUTINE DFIND(LI,LF) use big11 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS THE NEXT SET OF LS COUPLED DIPOLE C MATRIX ELEMENTS FROM THE STG2 OUTPUT TAPE ITAPE1. C C LI,LF = POSITIONS OF INITIAL,FINAL LS SYMMETRIES IN /ALPHA/. C C----------------------------------------------------------------------- INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUM3=MXLPOT-MZCHL*MZCHL*3-MZCHF*MZCHF*4) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) 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 /LRPOT/AC(MZCHL,MZCHL),BLVC(MZCHL,MZCHL,2), A AJC(MZCHF,MZCHF),BJLVC(MZCHF,MZCHF,3),DUMC(MXDUM3) COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /REDMEL/CGC(MZLR2),MAXM1 COMMON /SCRACH/DUMMY(MXJC3) C----------------------------------------------------------------------- MCHAN = LCH(LI) MCONHP = NRANG2*MCHAN IF (LAM.EQ.1) MCONHP = 0 MCFGP = LCFG(LI) NCHAN = LCH(LF) NCONHP = NRANG2*NCHAN IF (LAM.EQ.1) NCONHP = 0 NCFGP = LCFG(LF) MX = MAX(MCONHP+MCFGP,NCONHP+NCFGP) IF (MX.GT.MXHLS) CALL RECOV2('DFIND ','MXHLS ',MXHLS,MX) C IF (LAM.EQ.1) GOTO 50 JUP = 0 10 CONTINUE JLO = JUP + 1 JUP = JUP + NRANG2 IUP = 0 20 CONTINUE ILO = IUP + 1 IUP = IUP + NRANG2 C C BRING IN CONTINUUM-CONTINUUM BLOCKS C READ (ITAPE1) ((DLS(I,J,1),J=JLO,JUP),I=ILO,IUP) READ (ITAPE1) ((DLS(I,J,2),J=JLO,JUP),I=ILO,IUP) IF (IUP.LT.MCONHP) GOTO 20 IF (MCFGP.EQ.0) GOTO 30 C C BRING IN CONTINUUM-BOUND BLOCKS C READ (ITAPE1) ((DLS(I,J,1),J=JLO,JUP),I=MCONHP+1,MCONHP+MCFGP) READ (ITAPE1) ((DLS(I,J,2),J=JLO,JUP),I=MCONHP+1,MCONHP+MCFGP) 30 CONTINUE IF (MCONHP.GT.MXJC3) CALL RECOV2('DFIND ','MXJC3 ',MXJC3,MCONHP) READ (ITAPE1) (DUMMY(I),I=1,MCONHP) READ (ITAPE1) (DUMMY(I),I=1,MCONHP) IF (JUP.LT.NCONHP) GOTO 10 C IF (NCFGP.EQ.0) GOTO 70 IUP = 0 40 CONTINUE ILO = IUP + 1 IUP = IUP + NRANG2 C C BRING IN BOUND-CONTINUUM BLOCKS C READ (ITAPE1) ((DLS(I,J,1),J=NCONHP+1,NCONHP+NCFGP),I=ILO,IUP) READ (ITAPE1) ((DLS(I,J,2),J=NCONHP+1,NCONHP+NCFGP),I=ILO,IUP) IF (IUP.LT.MCONHP) GOTO 40 C 50 CONTINUE IF (MCFGP.EQ.0 .OR. NCFGP.EQ.0) GOTO 70 NDIMEN = NRANG2 NTIMES = (NCFGP-1)/NDIMEN + 1 I2 = 0 DO 60 II = 1,NTIMES II1 = I2 + 1 I2 = MIN(II*NDIMEN,NCFGP) C C BRING IN BOUND-BOUND BLOCKS C READ (ITAPE1) ((DLS(I,J,1),J=NCONHP+II1,NCONHP+I2),I=MCONHP+1, A MCONHP+MCFGP) READ (ITAPE1) ((DLS(I,J,2),J=NCONHP+II1,NCONHP+I2),I=MCONHP+1, A MCONHP+MCFGP) 60 CONTINUE 70 CONTINUE IF (LAM.EQ.1) GOTO 90 C C BRING IN BUTTLE MATRIX ELEMENTS C IF (NCFGP.GT.0) THEN NN = NCFGP*MCHAN IF (NN.GT.MXJC3) CALL RECOV2('DFIND ','MXJC3 ',MXJC3,NN) READ (ITAPE1) (DUMMY(I),I=1,NN) READ (ITAPE1) (DUMMY(I),I=1,NN) ENDIF C IF (NCONHP.GT.MXJC3) CALL RECOV2('DFIND ','MXJC3 ',MXJC3,NCONHP) DO 80 IB = 1,MCHAN READ (ITAPE1) (DUMMY(I),I=1,NCONHP) READ (ITAPE1) (DUMMY(I),I=1,NCONHP) 80 CONTINUE IF (MCFGP.GT.0) THEN MM = NCHAN*MCFGP IF (MM.GT.MXJC3) CALL RECOV2('DFIND ','MXJC3 ',MXJC3,MM) READ (ITAPE1) (DUMMY(I),I=1,MM) READ (ITAPE1) (DUMMY(I),I=1,MM) ENDIF C NN = NCHAN*MCHAN IF (NN.GT.MXJC3) CALL RECOV2('DFIND ','MXJC3 ',MXJC3,NN) READ (ITAPE1) (DUMMY(I),I=1,NN) READ (ITAPE1) (DUMMY(I),I=1,NN) READ (ITAPE1) MAXM1, (CGC(I),I=1,MAXM1) C C BRING IN A AND B COEFFICIENTS FOR EXTERNAL REGION CONTRIBUTION C READ (ITAPE1) ((AC(I,J),J=1,MCHAN),I=1,NCHAN) READ (ITAPE1) ((BLVC(I,J,1),J=1,MCHAN),I=1,NCHAN) READ (ITAPE1) ((BLVC(I,J,2),J=1,MCHAN),I=1,NCHAN) C 90 CONTINUE C END SUBROUTINE DJZERO(JI,JF) use big11 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KREC1 C C C C----------------------------------------------------------------------- C C INITIALISES TO ZERO VARIOUS ARRAYS FOR DIPOLE MATRIX ELEMENTS. C C JI,JF = POSITIONS OF INITIAL,FINAL J SYMMETRIES IN /ALPHAJ/. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUM3=MXLPOT-MZCHL*MZCHL*3-MZCHF*MZCHF*4) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST 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 /LRPOT/AC(MZCHL,MZCHL),BLVC(MZCHL,MZCHL,2), A AJC(MZCHF,MZCHF),BJLVC(MZCHF,MZCHF,3),DUMC(MXDUM3) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM C----------------------------------------------------------------------- MJCHA = JCH(JI) NJCHA = JCH(JF) KMCFGP = JCFG(JI) JNCFGP = JCFG(JF) IF (LAM.EQ.1) GOTO 50 C NJBLOC = NRANG2*NRANG2*MJCHA IF (NJBLOC.GT.MXHJ) CALL RECOV2('DJZERO','MXHJ ',MXHJ,NJBLOC) DO 10 K = 1,NJBLOC DJ(K,1) = 0.0D0 DJ(K,2) = 0.0D0 10 CONTINUE IF (MEM1.LT.MXMEM) THEN DO 20 I = MEM1 + 1,MXMEM ARRAY(I) = 0.0D0 20 CONTINUE ENDIF C KMEM = MEM1 KREC1 = MREC1 DO 30 K = 1,NJCHA IF (KMEM+2*NJBLOC.GT.MXMEM) THEN CALL DA2(2,KREC1,IDISC2,NJBLOC,DJ(1,1)) CALL DA2(2,KREC1,IDISC2,NJBLOC,DJ(1,2)) ENDIF C KMEM = KMEM + 2*NJBLOC 30 CONTINUE IF (KREC1.NE.MREC1) MREC1 = 1 C MCONHP = NRANG2*MJCHA NCONHP = NRANG2*NJCHA NBC = MAX(MCONHP,NCONHP)*MAX(KMCFGP,JNCFGP) IF (NBC.GT.MXHBC) CALL RECOV2('DJZERO','MXHBC ',MXHBC,NBC) DO 40 I = 1,NBC DJCB(I,1) = 0.0D0 DJCB(I,2) = 0.0D0 DJBC(I,1) = 0.0D0 DJBC(I,2) = 0.0D0 40 CONTINUE C 50 CONTINUE NBB = MAX(KMCFGP,JNCFGP) IF (NBB.GT.MZNC2) CALL RECOV2('DJZERO',' MZNC2',MZNC2,NBB) DO 70 I = 1,JNCFGP DO 60 J = 1,KMCFGP DJBB(J,I,1) = 0.0D0 DJBB(J,I,2) = 0.0D0 60 CONTINUE 70 CONTINUE C NC = MAX(MJCHA,NJCHA) IF (NC.GT.MZCHF) CALL RECOV2('DJZERO',' MZCHF',MZCHF,NC) DO K = 1,3 DO J = 1,MJCHA DO I = 1,NJCHA BJLVC(I,J,K) = 0.0D0 BJLVC(I,J,K) = 0.0D0 ENDDO ENDDO ENDDO DO J = 1,MJCHA DO I = 1,NJCHA AJC(I,J) = 0.0D0 ENDDO ENDDO C END C C C SUBROUTINE DMES(LPOSI,LPOSF,MJCHA,NJCHA,KMCFGP,JNCFGP,SWITCH,RAC) use big11 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KREC1,KREC2 C C C C----------------------------------------------------------------------- C C DETERMINES THE CONTRIBUTION FOR A LS COUPLED C SET OF DIPOLE MATRIX ELEMENTS TO A JL COUPLED SET C C LPOSI,LPOSF = POSITIONS OF INITIAL,FINAL LS SYMMETRIES IN /ALPHA/ C MJCHA,NJCHA = NUMBER OF J CHANNELS FOR INITIAL,FINAL SYMMETRIES C KMCFGP,JNCFGP = COUNTERS ON TOTAL NUMBER OF CONFIGURATIONS FOR C INITIAL,FINAL J SYMMETRIES. C SWITCH = .TRUE. IF LS MATRIX BLOCK IS TO BE TRANSPOSED; C RAC = RACAH AND ANGULAR FACTOR DEFINED IN RECUD. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUM3=MXLPOT-MZCHL*MZCHL*3-MZCHF*MZCHF*4) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) C LOGICAL SWITCH C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 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 /LRPOT/AC(MZCHL,MZCHL),BLVC(MZCHL,MZCHL,2), A AJC(MZCHF,MZCHF),BJLVC(MZCHF,MZCHF,3),DUMC(MXDUM3) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /POTORB/PV(MXJC3),QV(MXJC3),ICHAN(MXJC3),IICHAN(MXJC3), A NTERM(MZCHF),MTERM(MZCHF) C----------------------------------------------------------------------- IF (IBUG5.GT.0) WRITE (IWRITE,3000) LPOSI,LPOSF NCFGP = LCFG(LPOSF) MCFGP = LCFG(LPOSI) NCONHP = NRANG2*LCH(LPOSF) IF (LAM.EQ.1) NCONHP = 0 MCONHP = NRANG2*LCH(LPOSI) IF (LAM.EQ.1) MCONHP = 0 IGIN = KMCFGP + MCFGP IMIT = KMCFGP + 1 IF (IGIN.GT.MZNC2) CALL RECOV2('DMES ',' MZNC2',MZNC2,IGIN) IFIN = JNCFGP + NCFGP INIT = JNCFGP + 1 IF (IFIN.GT.MZNC2) CALL RECOV2('DMES ',' MZNC2',MZNC2,IFIN) IF = NCONHP - JNCFGP IG = MCONHP - KMCFGP IF (LAM.EQ.1) GOTO 210 KAB2 = NRANG2*NRANG2 C C BEGIN LOOP OVER CHANNELS COUPLED IN FINAL STATE C J1 = 0 KMEM = MEM1 KREC1 = 1 DO 140 J = 1,NJCHA KREC2 = KREC1 NTERMJ = NTERM(J) IF (NTERMJ.EQ.0) THEN IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN CALL DA2(0,KREC1,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(0,KREC1,IDISC2,KAB2*MJCHA,DJ(1,2)) ENDIF C GOTO 130 C ENDIF C IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,2)) ENDIF C DO 120 JM = 1,NTERMJ JPOS = ICHAN(JM+J1) JLO = (JPOS-1)*NRANG2 SUM1 = PV(JM+J1) C C BEGIN LOOP OVER CHANNELS COUPLED IN INITIAL STATE C I1 = 0 DO 80 I = 1,MJCHA MTERMI = MTERM(I) IF (MTERMI.EQ.0) GOTO 70 DO 60 IM = 1,MTERMI IPOS = IICHAN(IM+I1) ILO = (IPOS-1)*NRANG2 SUM = QV(IM+I1)*SUM1*RAC DO 50 IL = 1,NRANG2 ILL = ILO + IL KAB11 = ((I-1)*NRANG2+IL-1)*NRANG2 KMEM1 = KMEM + KAB11 KMEM2 = KMEM1 + KAB2*MJCHA IF (SWITCH) THEN IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN DO 10 JL = 1,NRANG2 DJ(KAB11+JL,1) = DJ(KAB11+JL,1) + A SUM*DLS(JLO+JL,ILL,1) DJ(KAB11+JL,2) = DJ(KAB11+JL,2) - !+/- A SUM*DLS(JLO+JL,ILL,2) 10 CONTINUE C ELSE DO 20 JL = 1,NRANG2 ARRAY(KMEM1+JL) = ARRAY(KMEM1+JL) + A SUM*DLS(JLO+JL,ILL,1) ARRAY(KMEM2+JL) = ARRAY(KMEM2+JL) - !+/- A SUM*DLS(JLO+JL,ILL,2) 20 CONTINUE ENDIF C ELSE IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN DO 30 JL = 1,NRANG2 DJ(KAB11+JL,1) = DJ(KAB11+JL,1) + A SUM*DLS(ILL,JLO+JL,1) DJ(KAB11+JL,2) = DJ(KAB11+JL,2) + A SUM*DLS(ILL,JLO+JL,2) 30 CONTINUE C ELSE DO 40 JL = 1,NRANG2 ARRAY(KMEM1+JL) = ARRAY(KMEM1+JL) + A SUM*DLS(ILL,JLO+JL,1) ARRAY(KMEM2+JL) = ARRAY(KMEM2+JL) + A SUM*DLS(ILL,JLO+JL,2) 40 CONTINUE ENDIF C ENDIF C 50 CONTINUE IF (SWITCH) THEN AJC(J,I) = AJC(J,I) + SUM*AC(IPOS,JPOS) BJLVC(J,I,3) = BJLVC(J,I,3) - SUM*AC(IPOS,JPOS) BJLVC(J,I,1) = BJLVC(J,I,1) + SUM*BLVC(IPOS,JPOS,1) BJLVC(J,I,2) = BJLVC(J,I,2) - SUM*BLVC(IPOS,JPOS,2) !+/- C ELSE AJC(J,I) = AJC(J,I) + SUM*AC(JPOS,IPOS) BJLVC(J,I,1) = BJLVC(J,I,1) + SUM*BLVC(JPOS,IPOS,1) BJLVC(J,I,2) = BJLVC(J,I,2) + SUM*BLVC(JPOS,IPOS,2) ENDIF C 60 CONTINUE 70 I1 = I1 + MTERMI 80 CONTINUE C C CONSIDER THE CONTINUUM-BOUND CONTRIBUTION C IMPLICITLY MAPPING AS DJCB(JL=1:NRANG2,J=1:NJCHA,IL=1:KMCFGP) C IF (MCFGP.EQ.0) GOTO 120 SUM = SUM1*RAC DO 110 IL = IMIT,IGIN KAB21 = ((IL-1)*NJCHA+J-1)*NRANG2 IF (SWITCH) THEN DO 90 JL = 1,NRANG2 DJCB(KAB21+JL,1) = DJCB(KAB21+JL,1) + A SUM*DLS(JLO+JL,IL+IG,1) DJCB(KAB21+JL,2) = DJCB(KAB21+JL,2) - !+/- A SUM*DLS(JLO+JL,IL+IG,2) 90 CONTINUE C ELSE DO 100 JL = 1,NRANG2 DJCB(KAB21+JL,1) = DJCB(KAB21+JL,1) + A SUM*DLS(IL+IG,JLO+JL,1) DJCB(KAB21+JL,2) = DJCB(KAB21+JL,2) + A SUM*DLS(IL+IG,JLO+JL,2) 100 CONTINUE ENDIF C 110 CONTINUE 120 CONTINUE IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN CALL DA2(2,KREC2,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(2,KREC2,IDISC2,KAB2*MJCHA,DJ(1,2)) ENDIF C 130 CONTINUE KMEM = KMEM + 2*KAB2*MJCHA J1 = J1 + NTERMJ 140 CONTINUE C C CONSIDER THE BOUND-CONTINUUM CONTRIBUTION C IMPLICITLY MAPPING AS DJBC(IL=1:NRANG2,I=1:MJCHA,JL=1:JNCFGP) C IF (NCFGP.EQ.0) GOTO 250 I1 = 0 DO 200 I = 1,MJCHA MTERMI = MTERM(I) IF (MTERMI.EQ.0) GOTO 190 DO 180 IM = 1,MTERMI IPOS = IICHAN(IM+I1) ILO = (IPOS-1)*NRANG2 SUM = QV(IM+I1)*RAC DO 170 JL = INIT,IFIN KAB21 = ((JL-1)*MJCHA+I-1)*NRANG2 IF (SWITCH) THEN DO 150 IL = 1,NRANG2 DJBC(KAB21+IL,1) = DJBC(KAB21+IL,1) + A SUM*DLS(JL+IF,ILO+IL,1) DJBC(KAB21+IL,2) = DJBC(KAB21+IL,2) - !+/- A SUM*DLS(JL+IF,ILO+IL,2) 150 CONTINUE C ELSE DO 160 IL = 1,NRANG2 DJBC(KAB21+IL,1) = DJBC(KAB21+IL,1) + A SUM*DLS(ILO+IL,JL+IF,1) DJBC(KAB21+IL,2) = DJBC(KAB21+IL,2) + A SUM*DLS(ILO+IL,JL+IF,2) 160 CONTINUE ENDIF C 170 CONTINUE 180 CONTINUE 190 I1 = I1 + MTERMI 200 CONTINUE C C CONSIDER BOUND BOUND CONTRIBUTION (DIRECT MAPPING) C 210 CONTINUE IF (MCFGP.EQ.0) GOTO 250 IF (NCFGP.EQ.0) GOTO 250 DO 240 JL = INIT,IFIN IF (SWITCH) THEN DO 220 IL = IMIT,IGIN DJBB(IL,JL,1) = DLS(JL+IF,IL+IG,1)*RAC DJBB(IL,JL,2) = -DLS(JL+IF,IL+IG,2)*RAC !+/- 220 CONTINUE C ELSE DO 230 IL = IMIT,IGIN DJBB(IL,JL,1) = DLS(IL+IG,JL+IF,1)*RAC DJBB(IL,JL,2) = DLS(IL+IG,JL+IF,2)*RAC 230 CONTINUE ENDIF C IF (IBUG5.GT.0) WRITE (IWRITE,3010) IMIT,JL, A (DJBB(I,JL,1),I=IMIT,IGIN) 240 CONTINUE C 250 CONTINUE C 3000 FORMAT (/42X,'SUBROUTINE DMES(LPOSI,LPOSF =',2I3,')'/42X,15 ('-')) 3010 FORMAT (' IMIT,JL, DJBB = ',2I3, (T26,5F10.5)) END C C C SUBROUTINE DMOUT(JI,JF) use big11 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KREC1 C C C C----------------------------------------------------------------------- C C PLACES RECOUPLED DIPOLE MATRIX ELEMENTS ON OUTPUT FILE ITAPE4 C C JI,JF = POSITIONS OF INITIAL,FINAL J SYMMETRIES IN /ALPHAJ/. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUM3=MXLPOT-MZCHL*MZCHL*3-MZCHF*MZCHF*4) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 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 /LRPOT/AC(MZCHL,MZCHL),BLVC(MZCHL,MZCHL,2), A AJC(MZCHF,MZCHF),BJLVC(MZCHF,MZCHF,3),DUMC(MXDUM3) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /REDMEL/CGC(MZLR2),MAXM1 COMMON /SCRACH/DUMMY(MXJC3) C----------------------------------------------------------------------- WRITE (IWRITE,3000) MJCHA = JCH(JI) NJCHA = JCH(JF) KMCFGP = JCFG(JI) JNCFGP = JCFG(JF) IF (LAM.EQ.1) GOTO 190 NCONHP = NRANG2*NJCHA MCONHP = NRANG2*MJCHA MX = NRANG2*MAX(NRANG2,KMCFGP,JNCFGP) IF (MX.GT.MXJC3) CALL RECOV2('DMOUT ','MXJC3 ',MXJC3,MX) KAB2 = NRANG2*NRANG2 KMEM = MEM1 KREC1 = 1 C DO 120 J = 1,NJCHA IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,2)) ENDIF C C PUT OUT CONTINUUM-CONTINUUM BLOCKS C MAP DJCC(JL=1:NRANG2,IL=1:NRANG2,I=1:MJCHA) ONTO DUMMY(JL,IL) C DO 30 I = 1,MJCHA KAB11 = (I-1)*KAB2 IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN WRITE (ITAPE4) (DJ(KAB11+K,1),K=1,KAB2) WRITE (ITAPE4) (DJ(KAB11+K,2),K=1,KAB2) C ELSE KMEM1 = KMEM + KAB11 KMEM2 = KMEM1 + KAB2*MJCHA WRITE (ITAPE4) (ARRAY(KMEM1+K),K=1,KAB2) WRITE (ITAPE4) (ARRAY(KMEM2+K),K=1,KAB2) ENDIF C IF (IBUG5.LE.0) GOTO 30 WRITE (IWRITE,3040) I,J WRITE (IWRITE,3050) DO 20 LV = 1,2 IF (LV.EQ.2) WRITE (IWRITE,3060) KAB11 = (I-1)*KAB2 DO 10 III = 1,NRANG2 IF (KMEM+2*KAB2*MJCHA.GT.MXMEM) THEN WRITE (IWRITE,3030) III, (DJ(K+KAB11,LV),K=1,NRANG2) C ELSE KMEM1 = KMEM + KAB11 + (LV-1)*KAB2*MJCHA WRITE (IWRITE,3030) III, (ARRAY(K+KMEM1),K=1,NRANG2) ENDIF C KAB11 = KAB11 + NRANG2 10 CONTINUE WRITE (IWRITE,3030) 20 CONTINUE 30 CONTINUE IF (KMCFGP.EQ.0) GOTO 90 C C PUT OUT CONTINUUM-BOUND BLOCKS C MAP DJCB(JL=1:NRANG2,J=1:NJCHA,IL=1:KMCFGP) ONTO DUMMY(JL,IL) C DO 60 LV = 1,2 DO 50 IL = 1,KMCFGP MAP = (IL-1)*NRANG2 K = ((IL-1)*NJCHA+J-1)*NRANG2 DO 40 JL = 1,NRANG2 DUMMY(JL+MAP) = DJCB(JL+K,LV) 40 CONTINUE 50 CONTINUE WRITE (ITAPE4) (DUMMY(K),K=1,NRANG2*KMCFGP) 60 CONTINUE IF (IBUG5.LE.0) GOTO 90 WRITE (IWRITE,*) ' FINAL CHANNEL ',J WRITE (IWRITE,3070) DO 80 LV = 1,2 IF (LV.EQ.2) WRITE (IWRITE,3080) DO 70 III = 1,KMCFGP MAP = ((III-1)*NJCHA+J-1)*NRANG2 WRITE (IWRITE,3030) III, (DJCB(K+MAP,LV),K=1,NRANG2) 70 CONTINUE WRITE (IWRITE,3030) 80 CONTINUE 90 CONTINUE IF (MCONHP.GT.MXJC3) CALL RECOV2('DMOUT ','MXJC3 ',MXJC3,MCONHP) DO 100 K = 1,MCONHP DUMMY(K) = .0D0 100 CONTINUE DO 110 LV = 1,2 WRITE (ITAPE4) (DUMMY(K),K=1,MCONHP) 110 CONTINUE KMEM = KMEM + 2*KAB2*MJCHA 120 CONTINUE IF (JNCFGP.EQ.0) GOTO 240 C C PUT OUT BOUND-CONTINUUM BLOCKS - OK MID-MAY 1992 CWE MAP DJBC(IL=1:NRANG2,I=1:MJCHA,JL=1:JNCFGP) ONTO DUMMY(JL,IL): C DO 180 I = 1,MJCHA DO 150 LV = 1,2 DO 140 IL = 1,NRANG2 MAP = (IL-1)*JNCFGP DO 130 JL = 1,JNCFGP K = ((JL-1)*MJCHA+I-1)*NRANG2 + IL DUMMY(JL+MAP) = DJBC(K,LV) 130 CONTINUE 140 CONTINUE WRITE (ITAPE4) (DUMMY(K),K=1,NRANG2*JNCFGP) 150 CONTINUE IF (IBUG5.LE.0) GOTO 180 WRITE (IWRITE,*) ' INITIAL CHANNEL ',I WRITE (IWRITE,3090) DO 170 LV = 1,2 IF (LV.EQ.2) WRITE (IWRITE,3100) DO 160 III = 1,NRANG2 KAB21 = (I-1)*NRANG2 + III - MCONHP WRITE (IWRITE,3030) III, (DJBC(KAB21+MCONHP*K,LV),K=1, A JNCFGP) 160 CONTINUE WRITE (IWRITE,3030) 170 CONTINUE 180 CONTINUE C C PUT OUT BOUND-BOUND BLOCKS (AS FOR BC JNCFGP IS INNER LOOP:) C 190 CONTINUE IF (KMCFGP.EQ.0 .OR. JNCFGP.EQ.0) GOTO 240 NDIMEN = NRANG2 NTIMES = (JNCFGP-1)/NDIMEN + 1 I2 = 0 DO 230 II = 1,NTIMES II1 = I2 + 1 I2 = MIN(II*NDIMEN,JNCFGP) DO 200 K = 1,2 WRITE (ITAPE4) ((DJBB(I,J,K),J=II1,I2),I=1,KMCFGP) 200 CONTINUE IF (IBUG5.LE.0) GOTO 230 WRITE (IWRITE,3110) (K,K=II1,I2) DO 220 LV = 1,2 IF (LV.EQ.2) WRITE (IWRITE,3120) DO 210 I = 1,KMCFGP WRITE (IWRITE,3030) I, (DJBB(I,J,LV),J=II1,I2) 210 CONTINUE WRITE (IWRITE,3030) 220 CONTINUE 230 CONTINUE C C PUT OUT BUTTLE MATRIX ELEMENTS (ZEROS) C 240 CONTINUE IF (LAM.EQ.1) GOTO 340 MX1 = MJCHA*MAX(JNCFGP,NJCHA) MX2 = NJCHA*MAX(KMCFGP,NRANG2) MX = MAX(MX1,MX2) IF (MX.GT.MXJC3) CALL RECOV2('DMOUT ','MXJC3 ',MXJC3,MX) DO 250 K = 1,MX DUMMY(K) = 0.0D0 250 CONTINUE IF (JNCFGP.GT.0) THEN DO 260 K = 1,2 WRITE (ITAPE4) (DUMMY(J),J=1,JNCFGP*MJCHA) 260 CONTINUE ENDIF C J = 2*MJCHA DO 270 I = 1,J WRITE (ITAPE4) (DUMMY(K),K=1,NCONHP) 270 CONTINUE IF (KMCFGP.GT.0) THEN DO 280 J = 1,2 WRITE (ITAPE4) (DUMMY(K),K=1,NJCHA*KMCFGP) 280 CONTINUE ENDIF C DO 290 J = 1,2 WRITE (ITAPE4) (DUMMY(K),K=1,NJCHA*MJCHA) 290 CONTINUE C C PUT OUT LONG RANGE COEFFS ETC C WRITE (ITAPE4) MAXM1, (CGC(M),M=1,MAXM1) WRITE (ITAPE4) ((AJC(I,J),J=1,MJCHA),I=1,NJCHA) DO 300 K = 1,3 WRITE (ITAPE4) ((BJLVC(I,J,K),J=1,MJCHA),I=1,NJCHA) 300 CONTINUE IF (IBUG5.LE.0) GOTO 340 WRITE (IWRITE,3020) MAXM1 DO 310 J = 1,MJCHA WRITE (IWRITE,3030) J, (AJC(I,J),I=1,NJCHA) 310 CONTINUE DO 330 K = 1,3 WRITE (IWRITE,3030) DO 320 J = 1,MJCHA WRITE (IWRITE,3030) J, (BJLVC(I,J,K),I=1,NJCHA) 320 CONTINUE 330 CONTINUE C 340 CONTINUE WRITE (IWRITE,*) ' DIPOLE MATRIX WRITTEN TO OUTPUT FILE' C 3000 FORMAT (/52X,'SUBROUTINE DMOUT'/52X,17 ('-')) 3020 FORMAT (/' MATRICES AJC AND BJLVCC (MAXM1 =',I4,')'/) 3030 FORMAT (I5, (T6,9F14.7)) 3040 FORMAT (/' INITIAL CHANNEL',I3,' FINAL CHANNEL',I3) 3050 FORMAT (//5X, A'CONTINUUM-CONTINUUM DIPOLE LENGTH MATRIX ELEMENTS W RITTEN TO RE BCUD TAPE'//) 3060 FORMAT (/5X, A'CONTINUUM-CONTINUUM DIPOLE VELOCITY MATRIX ELEMENTS WRITTEN TO BRECUD TAPE'//) 3070 FORMAT (//5X, A'CONTINUUM-BOUND DIPOLE LENGTH MATRIX ELEMENTS WRITT EN TO RECUD BTAPE'//) 3080 FORMAT (/5X, A'CONTINUUM-BOUND DIPOLE VELOCITY MATRIX ELEMENTS WRIT TEN TO RECU BD TAPE'//) 3090 FORMAT (//5X, A'BOUND-CONTINUUM DIPOLE LENGTH MATRIX ELEMENTS WRITT EN TO RECUD BTAPE'//) 3100 FORMAT (/5X, A'BOUND-CONTINUUM DIPOLE VELOCITY MATRIX ELEMENTS WRIT TEN TO RECU BD TAPE'//) 3110 FORMAT (//5X, A'BOUND-BOUND DIPOLE LENGTH MATRIX ELEMENTS WRITTEN T O RECUD TAPE B'// (T6,9I14)) 3120 FORMAT (/5X, A'BOUND-BOUND DIPOLE VELOCITY MATRIX ELEMENTS WRITTEN TO RECUD TA BPE'//) END C C C SUBROUTINE FINBBR(N1,N2,L,RAD) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS A BOUND-BOUND RADIAL SPIN-ORBIT INTEGRAL. C N1,N2 ARE THE PRINCIPAL QUANTUM NUMBERS C L IS THE ANGULAR MOMENTUM C RAD IS THE VALUE OF THE APPROPRIATE RADIAL INTEGRAL C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB) PARAMETER (MX1BC=MZNR2*MXORB) PARAMETER (MX1CC=MZNR2*MZNR2/2+MZNR2) C COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) C----------------------------------------------------------------------- L1 = L + 1 I1 = IST1(L1) IF (N1.GE.N2) THEN I2 = ((N1-L1+1)* (N1-L1))/2 + N2 - L1 + I1 C ELSE I2 = ((N2-L1+1)* (N2-L1))/2 + N1 - L1 + I1 ENDIF C RAD = RSPOR1(I2) C END C C C SUBROUTINE FINBCR(N1,NRANG2,L,RAD) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS BOUND CONTINUUM SPIN-ORBIT RADIAL INTEGRALS RAD(NRANG2). C N1,N2 ARE THE PRINCIPAL QUANTUM NUMBERS, WHERE N2 RUNS FROM C 1 TO NRANG2; C L IS THE ANGULAR MOMENTUM. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB) PARAMETER (MX1BC=MZNR2*MXORB) PARAMETER (MX1CC=MZNR2*MZNR2/2+MZNR2) C DIMENSION RAD(NRANG2) C COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) COMMON /INSTO8/IST1(MZLR1),IST2(MZLR1) C----------------------------------------------------------------------- L1 = L + 1 I2 = (N1-L1)*NRANG2 + IST2(L1) - 1 DO 10 N2 = 1,NRANG2 RAD(N2) = RSPOR2(I2+N2) 10 CONTINUE C END C C C SUBROUTINE FINCCR(N1,NUM,L,RAD) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS CONTINUUM-CONTINUUM SPIN-ORBIT RADIAL INTEGRALS RAD(NUM). C N1,N2 ARE THE PRINCIPAL QUANTUM NUMBERS, WHERE N2 RUNS FROM C N1-NUM+1 TO N1. ONLY TWO VALUES OF NUM ARE ALLOWED: C NUM=1 (THEN N2=N1), OR NUM=N1 (THEN N2=1,...,N1). C L IS THE ANGULAR MOMENTUM C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MX1BB=MXORB*MXORB/2+MXORB) PARAMETER (MX1BC=MZNR2*MXORB) PARAMETER (MX1CC=MZNR2*MZNR2/2+MZNR2) C DIMENSION RAD(NUM) C COMMON /INSTO6/RSPOR1(MX1BB),RSPOR2(MX1BC),RSPOR3(MX1CC,MZLR2) C----------------------------------------------------------------------- IF (NUM.GT.N1) STOP L1 = L + 1 I2 = (N1* (N1-1))/2 + N1 - NUM DO 10 N = 1,NUM RAD(N) = RSPOR3(I2+N,L1) 10 CONTINUE C END C C C SUBROUTINE HFIND(LPOS) use big1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C READS AN LS COUPLED HAMILTONIAN MATRIX AND C ASSOCIATED LONG RANGE POTENTIAL COEFFICIENTS FROM STG2 FILE. C LPOS = POSITION OF CURRENT S L PI SYMMETRY IN /ALPHA/ ARRAYS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUMC=MXLPOT-MZCHF*MZCHF*MZLMX-MZCHL*MZCHL*MZLMX) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C DIMENSION NCONAT(MXNCF) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /CASES/MORE,MSKIP,IPOLPH,INAST COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) 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 /LRPOT/CF(MZCHL,MZCHL,MZLMX), A CFJ(MZCHF,MZCHF,MZLMX),DUMC(MXDUMC) COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /REL/JRELOP(3) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST C----------------------------------------------------------------------- READ (ITAPE2,END=180) LRGL,NSPN,NPTY,NCFGP,IPOLPH IF (IBUG6.NE.0) WRITE (IWRITE,*) ' LS SYMMETRY ON INPUT FILE: ', A LRGL,NSPN,NPTY READ (ITAPE2) MNPI,NCONHP,NCHAN READ (ITAPE2) (NCONAT(I),I=1,NAST) IF (IPOLPH.EQ.1) ITAPE4 = 0 IF (MNPI.GT.MXHLS) CALL RECOV2('RECUPJ','MXHLS ',MXHLS,MNPI) IF (NCHAN.GT.MZCHL) CALL RECOV2('RECUPJ',' MZCHL',MZCHL,NCHAN) READ (ITAPE2) (L2P(I),I=1,NCHAN) READ (ITAPE2) MORE C C CHECK IF THE SPIN-ORBIT INTERACTION IS REQUIRED C IF (JRELOP(3).NE.0 .AND. NCFGP.GT.0) THEN IF (NCFGP.GT.MZNC2) CALL RECOV2('RECUPJ',' MZNC2',MZNC2,NCFGP) READ (ITAPE2) (IOCCSH(I),I=1,NCFGP) DO 10 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) 10 CONTINUE ENDIF C C DEFINE THE LSTARG ARRAY C IFIN = 0 DO 30 I = 1,NAST IF (NCONAT(I).EQ.0) GOTO 30 INIT = IFIN + 1 IFIN = IFIN + NCONAT(I) DO 20 J = INIT,IFIN LSTARG(J) = I 20 CONTINUE 30 CONTINUE C C IF THIS IS A NEW LS SYMMETRY, DEFINE THE ARRAYS IN /ALPHA/. C INAST = TOTAL NUMBER OF LS SYMMETRIES STORED. C LPOS = LPOS + 1 IF (LPOS.GT.INAST) THEN IF (LPOS.GT.MZSLP) CALL RECOV2('RECUPJ',' MZSLP',MZSLP,LPOS) L2(LPOS) = 2*LRGL LS(LPOS) = NSPN - 1 LP(LPOS) = NPTY LCH(LPOS) = NCHAN LCFG(LPOS) = NCFGP INAST = LPOS ENDIF C C READ IN AND WRITE OUT THE CONTINUUM-CONTINUUM HAMILTONIAN BLOCKS C DO 70 K1 = 1,NCHAN KAB12 = (K1-1)*NRANG2 DO 60 K2 = 1,K1 KAB13 = (K2-1)*NRANG2 READ (ITAPE2) ((HLS(KAB13+I,KAB12+J),J=1,NRANG2),I=1,NRANG2) IF (IBUG6.LT.3) GOTO 60 WRITE (IWRITE,3000) K1,K2 JUP = 0 40 CONTINUE JLO = JUP + 1 JUP = MIN(JUP+8,NRANG2) DO 50 I = 1,NRANG2 WRITE (IWRITE,3020) (HLS(KAB13+I,KAB12+J),J=JLO,JUP) 50 CONTINUE WRITE (IWRITE,3020) IF (JUP.LT.NRANG2) GOTO 40 60 CONTINUE 70 CONTINUE C IF (NCFGP.EQ.0) GOTO 110 IF (NCFGP.GT.MZNC2) CALL RECOV2('RECUPJ',' MZNC2',MZNC2,NCFGP) C C READ IN AND IF REQUIRED WRITE OUT THE BOUND-CONTINUUM C LS-HAMILTONIAN BLOCKS. C DO 90 K = 1,NCHAN KAB21 = NRANG2* (K-1) READ (ITAPE2) ((HLS(KAB21+I,NCONHP+J),J=1,NCFGP),I=1,NRANG2) IF (IBUG6.LT.2) GOTO 90 WRITE (IWRITE,3060) K DO 80 I = 1,NRANG2 WRITE (IWRITE,3010) I, (HLS(KAB21+I,NCONHP+J),J=1,NCFGP) 80 CONTINUE WRITE (IWRITE,3010) 90 CONTINUE C C READ IN AND IF REQUIRED WRITE OUT THE BOUND-BOUND C LS-HAMILTONIAN MATRICES. C DO 100 I = 1,NCFGP READ (ITAPE2) (HLS(NCONHP+I,NCONHP+J),J=I,NCFGP) IF (IBUG6.LT.1) GOTO 100 WRITE (IWRITE,3070) I WRITE (IWRITE,3020) (HLS(NCONHP+I,NCONHP+J),J=I,NCFGP) 100 CONTINUE C C READ IN AND IF REQUIRED WRITE OUT THE LS-LONG RANGE C POTENTIAL COEFFICIENTS. *** NOTE CHANGE IN INPUT OF CF *** C 110 CONTINUE IF (LAMAX.LE.0) GOTO 170 DO 140 I = 1,NCHAN READ (ITAPE2) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) DO 130 K = 1,LAMAX DO 120 J = I,NCHAN CF(J,I,K) = CF(I,J,K) 120 CONTINUE 130 CONTINUE 140 CONTINUE IF (IBUG6.LT.4) GOTO 170 WRITE (IWRITE,3050) DO 160 K = 1,LAMAX WRITE (IWRITE,3030) K DO 150 I = 1,NCHAN WRITE (IWRITE,3040) (CF(I,J,K),J=1,NCHAN) 150 CONTINUE 160 CONTINUE 170 CONTINUE RETURN C 180 CONTINUE LPOS = 0 C 3000 FORMAT (//6X,'CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3,' AND CHANNEL',I3/) 3010 FORMAT (I5, (T6,9F14.7)) 3020 FORMAT (8F15.7) 3030 FORMAT (//' K=',I1//) 3040 FORMAT (10X,6F15.8) 3050 FORMAT (/' COEFFICIENT MATRIX CF(I,J,K)') 3060 FORMAT (//5X,'BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3/) 3070 FORMAT (/6X,'BOUND-BOUND CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CONFIGURATION',I3) END SUBROUTINE HJZERO(JPOS) use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KREC1,KINDEXBIG,MXMEM8,KAB28,K8,MREC18 C C C C----------------------------------------------------------------------- C C TO ZEROISE THE HAMILTONIAN MATRIX BLOCKS IN J COUPLING IN /BIG1/, C THE ASYMPTOTIC COEFFICIENTS IN J COUPLING IN /LRPOT/, C AND THE DA SCRATCH FILE IDISC2. C C JPOS = POSITION OF CURRENT J SYMMETRY IN THE /ALPHAJ/ ARRAYS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUMC=MXLPOT-MZCHF*MZCHF*MZLMX-MZCHL*MZCHL*MZLMX) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /LRPOT/CF(MZCHL,MZCHL,MZLMX), A CFJ(MZCHF,MZCHF,MZLMX),DUMC(MXDUMC) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM C----------------------------------------------------------------------- C C INITIALISE THE J-HAMILTONIAN BLOCKS C MXMEM8=MXMEM C C NJCHA = JCH(JPOS) KAB2 = NRANG2*NRANG2 NJBLOC = KAB2*NJCHA IF (NJBLOC.GT.MXHJ) CALL RECOV2('HJZERO','MXHJ ',MXHJ,NJBLOC) DO 10 K = 1,NJBLOC HJ(K) = 0.0D0 10 CONTINUE IF (MEM1.LT.MXMEM) THEN DO 20 I = MEM1 + 1,MXMEM ARRAY(I) = 0.0D0 20 CONTINUE ENDIF C KMEM = MEM1 KREC1 = MREC1 DO 30 K = 1,NJCHA KAB28=KAB2 K8=K KINDEXBIG=KMEM+KAB28*K8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(2,KREC1,IDISC2,KAB2*K,HJ) KMEM = KMEM + KAB2*K 30 CONTINUE MREC18=MREC1 IF (KREC1.NE.MREC18) MREC1 = 1 C C INITIALISE THE BOUND-CONTINUUM J-HAMILTONIAN MATRIX BLOCKS C NUM = MZNC2 DO 40 K = 1,MXHBC HJBC(K) = 0.0D0 40 CONTINUE C C INITIALISE THE BOUND-BOUND J-HAMILTONIAN BLOCKS. C DO 60 J = 1,NUM DO 50 I = 1,NUM HJBB(I,J) = 0.0D0 50 CONTINUE 60 CONTINUE C C INITIALISE THE LONG-RANGE POTENTIAL COEFFICIENTS. C IF (LAMAX.GT.0) THEN IF (LAMAX.GT.MZLMX) CALL RECOV2('HJZERO',' MZLMX',MZLMX,LAMAX) DO 90 K = 1,LAMAX DO 80 J = 1,NJCHA DO 70 I = 1,NJCHA CFJ(I,J,K) = 0.0D0 70 CONTINUE 80 CONTINUE 90 CONTINUE ENDIF C END C C C SUBROUTINE IRECUP(NRANG2,JREL3) IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C SET UP FACTORIALS IN /FACTS/, AND ADJUST MEM1 IN /MEMORY/ C ALSO CHECK STGLIB DIMENSIONS IN /BPSIZE/ C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) C COMMON /BPSIZE/MXLR1,MXLR2,MXNC2,MXNR1,MXOCC COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 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 C ENDIF C C LOG OF FACTORIALS ... C CALL FACTT C C USE MEM1 TO DIVIDE MEMORY BETWEEN RECOUPLING DATA (DAFILA) C AND C-C MATRIX ELEMENTS (NEED=NUMBER OF ELEMENTS) C NEED = MXMEM IF (JREL3.NE.0) NEED = NRANG2**2* (MZCHF* (MZCHF+1))/2 IF (ITAPE4.NE.0) NEED = 2* (NRANG2*MZCHF)**2 IF (NEED.LT.MXMEM) THEN MEM1 = MXMEM - NEED C ELSE M = 1 + (NEED-1)/1000000 WRITE (IWRITE,*) ' TO REDUCE I/O, COULD INCREASE MZMEG TO ',M WRITE (IWRITE,*) ' FACTOR DOWN BY (ACTUAL CHF/MZCHF)**2 ' ENDIF C END C C C SUBROUTINE JLRC(JRGL,J1,J2,J3,J4,J5,J6,J7,COEF) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALCULATES THE RECOUPLING COEFFICIENT FOR THE TRANSFORMATION C FROM L-S TO J-L COUPLING (I.E. PAIR-COUPLING) BY EXPRESSING IT C AS THE PRODUCT PRODUCT OF THE TWO RACAH COEFFICIENTS. THE ANGULAR C MOMENTUM QUANTUM NUMBERS ARE TWICE THEIR ACTUAL VALUES. C C----------------------------------------------------------------------- COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH C----------------------------------------------------------------------- J8 = 1 J9 = JRGL IF (IBUG5.GT.0) WRITE (IWRITE,3000) JRGL,J1,J2,J3,J4,J5,J6,J7 C C CALCULATE THE MULTIPLICATIVE FACTOR. C COEF1 = SQRT(DBLE((J3+1)* (J6+1)* (J4+1)* (J7+1))) C C EVALUATE THE RECOUPLING COEFFICIENT C CALL DRACAH(J6,J5,J2,J3,J1,J4,R1) CALL DRACAH(J6,J9,J2,J8,J7,J4,R2) COEF = COEF1*R1*R2 IF (IBUG5.GT.0) THEN WRITE (IWRITE,3010) COEF1 WRITE (IWRITE,3020) R1 WRITE (IWRITE,3020) R2 WRITE (IWRITE,3010) COEF ENDIF C 3000 FORMAT (/,37X,'SUBROUTINE JLRC(',8I3,')'/38X,15 ('-')) 3010 FORMAT (' MULTIPLICATIVE FACTOR =',F12.7) 3020 FORMAT (' RACAH COEFFICIENT =',F12.7) END C C C SUBROUTINE LSCONT(LPOS,NJCHA,JNCFGP) use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KINDEXBIG,KINDEX2,KMEM,KREC1,KREC2,I8,MEM18,KAB28, A MXMEM8 C C C C----------------------------------------------------------------------- C C APPLIES THE CONTRIBUTION C FROM THIS LS-SYMMETRY TO THE J-HAMILTONIAN BLOCKS C AND LONG-RANGE POTENTIAL COEFFICIENTS UNDER CONSIDERATION. C C LPOS = POSITION OF LS SYMMETRY IN /ALPHA/ ARRAYS; C NJCHA = NUMBER OF J CHANNELS; C JNCFGP = COUNTER ON TOTAL NUMBER OF BOUND TERMS FOR J SYMMETRY. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUMC=MXLPOT-MZCHF*MZCHF*MZLMX-MZCHL*MZCHL*MZLMX) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) 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 /LRPOT/CF(MZCHL,MZCHL,MZLMX), A CFJ(MZCHF,MZCHF,MZLMX),DUMC(MXDUMC) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /POTORB/PV(MXJC3),PPV(MXJC3),ICHAN(MXJC3),MCHAN(MXJC3), A NTERM(MZCHF),NNTERM(MZCHF) C----------------------------------------------------------------------- NCFGP = LCFG(LPOS) NCONHP = NRANG2*LCH(LPOS) C C APPLY THE TRANSFORMATION TO THE CONTINUUM-CONTINUUM J-HAMILTONIAN C MATRIX BLOCKS AND TO THE LONG RANGE POTENTIAL COEFFICIENTS C MXMEM8=MXMEM C C C KAB2 = NRANG2*NRANG2 I2 = 0 KMEM = MEM1 KREC1 = 1 DO 130 I = 1,NJCHA KREC2 = KREC1 NTERMI = NTERM(I) IF (NTERMI.EQ.0) THEN KAB28=KAB2 I8=I KINDEXBIG=KMEM+kab28*I8 C IF (KMEM+KAB2*I.GT.MXMEM8) CALL DA2(0,KREC1,IDISC2,KAB2*I,HJ) IF (KINDEXBIG.GT.MXMEM8) CALL DA2(0,KREC1,IDISC2,KAB2*I,HJ) GOTO 120 C ENDIF C KAB28=KAB2 I8=I KINDEXBIG=KMEM+kab28*I8 C IF (KMEM+KAB2*I.GT.MXMEM) CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) C if(iam.eq.0)write(0,*)"1",KINDEXBIG,kab2,kab2*i,KREC1,KREC2 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) J1 = 0 DO 110 J = 1,I NTERMJ = NTERM(J) IF (NTERMJ.EQ.0) GOTO 100 DO 90 IM = 1,NTERMI DO 80 JM = 1,NTERMJ SUM = PV(JM+J1)*PV(IM+I2) KAB12 = (MIN(ICHAN(IM+I2),ICHAN(JM+J1))-1)*NRANG2 KAB13 = (MAX(ICHAN(IM+I2),ICHAN(JM+J1))-1)*NRANG2 C C ASKING FOR UPPER HALF BLOCK BUT WE HAVE ONLY CALCULATED C THE LOWER HALF, THEREFORE USE THE LOWER HALF. C DO 50 JL = 1,NRANG2 KAB11 = ((J-1)*NRANG2+JL-1)*NRANG2 KMEM1 = KMEM + KAB11 IF (ICHAN(IM+I2).LT.ICHAN(JM+J1)) THEN ICPB1=KAB13+JL IF (KMEM+KAB2*I.GT.MXMEM) THEN DO 10 IL = 1,NRANG2 HJ(KAB11+IL) = HJ(KAB11+IL) + A SUM*HLS(KAB12+IL,ICPB1) 10 CONTINUE C ELSE DO 20 IL = 1,NRANG2 ARRAY(KMEM1+IL) = ARRAY(KMEM1+IL) + A SUM*HLS(KAB12+IL,ICPB1) 20 CONTINUE ENDIF C ELSE ICPB2=KAB12+JL IF (KMEM+KAB2*I.GT.MXMEM) THEN DO 30 IL = 1,NRANG2 HJ(KAB11+IL) = HJ(KAB11+IL) + A SUM*HLS(ICPB2,KAB13+IL) 30 CONTINUE C ELSE DO 40 IL = 1,NRANG2 ARRAY(KMEM1+IL) = ARRAY(KMEM1+IL) + A SUM*HLS(ICPB2,KAB13+IL) 40 CONTINUE ENDIF C ENDIF C 50 CONTINUE IF (LAMAX.EQ.0) GOTO 80 DO 70 KL = 1,LAMAX CFJ(I,J,KL) = CFJ(I,J,KL) + A SUM*CF(ICHAN(JM+J1),ICHAN(IM+I2),KL) CFJ(J,I,KL) = CFJ(I,J,KL) 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 J1 = J1 + NTERMJ 110 CONTINUE KAB28=KAB2 I8=I KINDEXBIG=KMEM+kab28*I8 C IF (KMEM+KAB2*I.GT.MXMEM) CALL DA2(2,KREC2,IDISC2,KAB2*I,HJ) C if(iam.eq.0) WRITE(0,*)"2",KREC1,KREC2,KAB2*i IF (KINDEXBIG.GT.MXMEM8) CALL DA2(2,KREC2,IDISC2,KAB2*I,HJ) 120 CONTINUE KAB28=KAB2 I8=I KMEM = KMEM + KAB28*I8 I2 = I2 + NTERMI 130 CONTINUE C if(iam.eq.0)write(iwrite,*)'after HCC transformation' call flush(iwrite) C C APPLY THE TRANSFORMATION TO THE BOUND-CONTINUUM J-HAMILTONIAN C BLOCKS. C IF (NCFGP.EQ.0) GOTO 210 IFIN = JNCFGP + NCFGP I2 = 0 INIT = JNCFGP + 1 DO 180 K = 1,NJCHA NTERMI = NTERM(K) IF (NTERMI.EQ.0) GOTO 170 DO 160 J = 1,NCFGP KAB21 = ((J-1+JNCFGP)*NJCHA+K-1)*NRANG2 ICPB3=NCONHP+J DO 150 K1 = 1,NTERMI SUM = PV(K1+I2) KAB22 = (ICHAN(K1+I2)-1)*NRANG2 DO 140 I = 1,NRANG2 HJBC(KAB21+I) = HJBC(KAB21+I) + SUM*HLS(KAB22+I,ICPB3) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 I2 = I2 + NTERMI 180 CONTINUE C C APPLY THE TRANSFORMATION TO THE BOUND-BOUND J-HAMILTONIAN MATRIX C IPOS = NCONHP DO 200 I = INIT,IFIN IPOS = IPOS + 1 JPOS = IPOS - I DO 190 J = I,IFIN C HJBB(I,J) = HLS(JPOS+J,IPOS) HJBB(I,J) = HLS(IPOS,JPOS+J) C if(iam.eq.0)write(0,*)HLS(IPOS,JPOS+J),HLS(JPOS+J,IPOS) 190 CONTINUE 200 CONTINUE JNCFGP = IFIN C C PRINT OUT DEBUG INFORMATION IF REQUIRED C 210 CONTINUE IF (IBUG7.LE.0) GOTO 360 WRITE (IWRITE,3000) IF (IBUG7.LT.3) GOTO 260 C C WRITE OUT THE TRANSFORMED CONTINUUM-CONTINUUM J-HAMILTONIAN C MATRIX BLOCKS. C K = 0 KMEM = MEM1 KREC1 = 1 DO 250 I = 1,NJCHA KAB28=KAB2 I8=I KINDEXBIG=KMEM+kab28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) DO 240 J = 1,I K = K + 1 WRITE (IWRITE,3010) I,J JUP = 0 220 CONTINUE JLO = JUP + 1 JUP = MIN(JUP+8,NRANG2) DO 230 I1 = 1,NRANG2 KAB11 = ((J-1)*NRANG2+I1-1)*NRANG2 KAB28=KAB2 I8=I KINDEXBIG=KMEM+kab28*I8 IF (KINDEXBIG.GT.MXMEM8) THEN WRITE (IWRITE,3020) (HJ(KAB11+J1),J1=JLO,JUP) C ELSE WRITE (IWRITE,3020) (ARRAY(KMEM+KAB11+J),J1=JLO,JUP) ENDIF C 230 CONTINUE WRITE (IWRITE,3020) IF (JUP.LT.NRANG2) GOTO 220 240 CONTINUE KAB28=KAB2 I8=I KMEM = KMEM + KAB28*I8 250 CONTINUE C C WRITE OUT THE TRANSFORMED BOUND-CONTINUUM J-HAMILTONIAN MATRIX C BLOCKS. C 260 CONTINUE IF (IBUG7.LT.2) GOTO 300 IF (JNCFGP.EQ.0) GOTO 320 DO 290 K = 1,NJCHA WRITE (IWRITE,3060) K JUP = 0 270 CONTINUE JLO = JUP + 1 JUP = MIN(JUP+8,JNCFGP) DO 280 I = 1,NRANG2 KAB21 = (K-1-NJCHA)*NRANG2 + I WRITE (IWRITE,3020) (HJBC(KAB21+NRANG2*NJCHA*J),J=JLO,JUP) 280 CONTINUE WRITE (IWRITE,3020) IF (JUP.LT.JNCFGP) GOTO 270 290 CONTINUE C C WRITE OUT THE TRANSFORMED BOUND-BOUND MATRIX BLOCKS. C 300 CONTINUE IF (IBUG7.LT.1 .OR. JNCFGP.EQ.0) GOTO 320 DO 310 I = 1,JNCFGP WRITE (IWRITE,3070) I WRITE (IWRITE,3020) (HJBB(I,J),J=1,JNCFGP) 310 CONTINUE 320 CONTINUE IF (IBUG7.LT.4 .OR. LAMAX.EQ.0) GOTO 360 C C WRITE OUT THE TRANSFORMED LONG RANGE POTENTIAL COEFFICIENTS C WRITE (IWRITE,3030) DO 350 K = 1,LAMAX WRITE (IWRITE,3040) K JUP = 0 330 CONTINUE JLO = JUP + 1 JUP = MIN(JUP+6,NJCHA) DO 340 I1 = 1,NJCHA WRITE (IWRITE,3050) (CFJ(I1,J1,K),J1=JLO,JUP) 340 CONTINUE WRITE (IWRITE,3020) IF (JUP.LT.NJCHA) GOTO 330 350 CONTINUE 360 CONTINUE C 3000 FORMAT (/51X,'SUBROUTINE LSCONT'/52X,17 ('-')//41X, A 'TRANSFORMED HAMILTONIAN MATRICES'/42X,32 ('-')) 3010 FORMAT (//6X,'CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3,' AND CHANNEL',I3/) 3020 FORMAT ((8F15.7)) 3030 FORMAT (/49X,'TRANSFORMED COEFFICIENT MATRIX'/50X,30 ('-')) 3040 FORMAT (//' K=',I1//) 3050 FORMAT (10X,6F15.8) 3060 FORMAT (//5X,' BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3/) 3070 FORMAT (/6X,'BOUND-BOUND CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CONFIGURATION',I3) END C C C SUBROUTINE LSJCUP(JPOS,LPOS,NTERMI) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALCULATES THE CONTRIBUTION FROM THIS LS SYMMETRY C TO THE CURRENT J SYMMETRY. C C ON ENTRY: C JPOS = POSITION OF CURRENT J SYMMETRY IN /ALPHAJ/ ARRAYS; C LPOS = POSITION OF LS SYMMETRY IN /ALPHA/ ARRAYS. C ON RETURN: C NTERMI = AMOUNT OF DATA IN PV AND ICHAN; C PV,ICHAN,NTERM IN /POTORB/ CONTAIN CHANNEL RECOUPLING DATA. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXNCF=MZTAR) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /JCHAN/LJP(MZCHF),KJ(MZCHF),JTARG(MZCHF) COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /POTORB/PV(MXJC3),PPV(MXJC3),ICHAN(MXJC3),MCHAN(MXJC3), A NTERM(MZCHF),NNTERM(MZCHF) COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST C----------------------------------------------------------------------- ZERO = 0.0D0 JRGL = J2(JPOS) NJCHA = JCH(JPOS) LRGL = L2(LPOS) NSPN = LS(LPOS) NCHAN = LCH(LPOS) NTERMI = 0 C DO 40 I = 1,NJCHA C C DEFINE THE CHANNEL QUANTUM NUMBERS FOR THIS CHANNEL C II = JTARG(I) J1 = JJ(II) K1 = KJ(I) L1 = LJP(I) NUM = 0 C C SCAN THE L2P ARRAY TO FIND WHICH LS-TARGET STATES C CONTRIBUTE TO THE J-LEVEL MIXING. C DO 30 IP = 1,NCHAN IF (2*L2P(IP).NE.L1) GOTO 30 ITARG = LSTARG(IP) C C CHECK THE TRIANGULAR RELATIONS. C IX = 1 IF (LSJTRI(2*LAT(ITARG),ISAT(ITARG)-1,IX,J1,IX).EQ. A 0) GOTO 30 C C SCAN THE LSVALU ARRAY TO SEE IF THERE IS A CORRESPONDING C B COEFFICIENT FOR THIS STATE -- INCOMPLETE?! WE'92JUL4. C ITEST = 0 M = JNTCON(II) DO 20 J = 1,M IF (LSVALU(II,J).NE.ITARG) GOTO 20 ITEST = ITEST + 1 IF (ITEST.LE.1) GOTO 10 WRITE (IWRITE,3030) II STOP C C EVALUATE THE JL-RECOUPLING COEFFICIENT. C 10 CONTINUE CALL JLRC(JRGL,2*LAT(ITARG),ISAT(ITARG)-1,J1,K1,L1,LRGL, A NSPN,RC) IF (NTERMI.GT.MXJC) GOTO 20 C C IF THE RECOUPLING COEFFICIENT IS ZERO THERE IS NO NEED C TO APPLY THE TRANSFORMATION IN THIS CHANNEL. C IF (RC.EQ.ZERO) GOTO 20 NUM = NUM + 1 NTERMI = NTERMI + 1 PV(NTERMI) = B(II,J)*RC ICHAN(NTERMI) = IP 20 CONTINUE 30 CONTINUE NTERM(I) = NUM 40 CONTINUE C C DIMENSION CHECK C IF (NTERMI.GT.MXJC) CALL RECOV2('LSJCUP','MXJC ',MXJC,NTERMI) IF (IBUG5.EQ.0) GOTO 50 WRITE (IWRITE,3000) (NTERM(I),I=1,NJCHA) WRITE (IWRITE,3020) (ICHAN(I),I=1,NTERMI) WRITE (IWRITE,3010) (PV(I),I=1,NTERMI) 50 CONTINUE C 3000 FORMAT (' NTERMI=',20I5/ (8X,20I5)) 3010 FORMAT (' COEF =', (T10,8F14.7)) 3020 FORMAT (' ICHAN =',20I5/ (1X,20I5)) 3030 FORMAT (/'**ERROR** IN LSVALU ARRAY STATE',I4, A ' HAS MORE THAN ONE INDEX THE SAME') END C C C FUNCTION LSJTRI(L,IS,LP,J,JP) C----------------------------------------------------------------------- C C CHECKS THE TRIANGULAR RELATION THAT /L-IS/ IS LESS THAN OR EQUAL C TO J AND THAT /L+IS/ IS GREATER THAN OR EQUAL TO J C AND THAT THE PARITIES LP AND JP ARE EQUAL. C SETS LSJTRI=0 IF FALSE C LSJTRI=1 IF TRUE C L,IS,J ARE INPUT AS TWICE THEIR ACTUAL ANGULAR QUANTUM NUMBERS C C----------------------------------------------------------------------- LSJTRI = 0 IF (LP.NE.JP) RETURN IF ((J.GE.ABS(L-IS).AND.J.LE.L+IS) .AND. A MOD(L+IS+J,2).EQ.0) LSJTRI = 1 C END C C C SUBROUTINE NDEGEN(E,JTARG,NJCHA) use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KREC1,KREC2,KAB28,K18,MXMEM8,KMEM C C C C----------------------------------------------------------------------- C C ADJUSTS THE DIAGONAL ELEMENTS OF THE TRANSFORMED C CONTINUUM-CONTINUUM MATRIX BLOCKS TO GIVE THE CORRECT C (I.E. EXPERIMENTAL) TARGET SPLITTINGS. C C E = GROUND STATE ENERGY. C JTARG(NJCHA) = J TARGET STATES COUPLED TO EACH J CHANNEL. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXNCF=MZTAR) C DIMENSION JTARG(NJCHA) C COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 C----------------------------------------------------------------------- MXMEM8=MXMEM K = 0 KAB2 = NRANG2*NRANG2 KMEM = MEM1 KREC1 = 1 KREC2 = 1 DO 40 K1 = 1,NJCHA KAB28=KAB2 K18=K1 IF (KMEM+KAB28*K18.GT.MXMEM8) CALL DA2(1,KREC1,IDISC2,KAB2*K1,HJ) DO 30 K2 = 1,K1 K = K + 1 IF (K1.NE.K2) GOTO 30 C C LOCATE THE STATE THAT THIS CHANNEL IS COUPLED TO C I1 = JTARG(K1) DELTA = E - ENATJ(I1) C C RE-ADJUST THE DIAGONAL ELEMENTS. C KAB11 = (K2-1)*KAB2 - NRANG2 KAB28=KAB2 K18=K1 IF (KMEM+KAB28*K18.GT.MXMEM8) THEN DO 10 J = 1,NRANG2 HJ(KAB11+J* (NRANG2+1)) = HJ(KAB11+J* (NRANG2+1)) - DELTA 10 CONTINUE C ELSE KMEM1 = KMEM + KAB11 DO 20 J = 1,NRANG2 ARRAY(KMEM1+J* (NRANG2+1)) = ARRAY(KMEM1+J* (NRANG2+1)) - A DELTA 20 CONTINUE ENDIF C 30 CONTINUE C KAB28=KAB2 K18=K1 C IF (KMEM+KAB28*K18.GT.MXMEM8) CALL DA2(2,KREC2,IDISC2,KAB2*K1,HJ) K18=K1 KAB28=KAB2 KMEM = KMEM + KAB28*K18 40 CONTINUE C END C C C SUBROUTINE NJCHAN(JPOS) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C DETERMINES THE NUMBER AND DEFINITION OF THE CHANNELS IN THE C PAIR COUPLING SCHEME FOR THE SYMMETRY UNDER CONSIDERATION C C ON ENTRY: C JPOS = POSITION OF CURRENT J SYMMMETRY IN /ALPHAJ/ ARRAYS. C ON RETURN: C JCH(JPOS) IN /ALPHAJ/ = NUMBER OF J CHANNELS; C JCOUNT(JPOS) IN /ALPHAJ/ = NUMBER OF LS SYMMETRIES COUPLED TO J; C LJP,KJ,JTARG IN /JCHAN/ CONTAIN J CHANNEL INFORMATION. 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 INCLUDE 'PARAM' C PARAMETER (MXLSJ=20) PARAMETER (MXNCF=MZTAR) C CHARACTER*4 PARITY(0:1) C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /JCHAN/LJP(MZCHF),KJ(MZCHF),JTARG(MZCHF) COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST C DATA PARITY/'EVEN',' ODD'/ C----------------------------------------------------------------------- JRGL = J2(JPOS) JNPTY = JP(JPOS) AJ = JRGL/2.0D0 WRITE (IWRITE,3000) AJ,PARITY(JNPTY) NJCHA = 0 ID = MZCHF 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 JCONAT(I)=0 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 IF LMAX EXCEEDS LRANG2 SET ICHECK=1 C IF (LP.LE.LRANG2) GOTO 10 WRITE (IWRITE,3010) LP,LRANG2 C C STORE THE 2K VALUES IN KJ AND THE 2L(INCIDENT) VALUES C IN LJP. C JTARG(K)...CONTAINS THE POSITON IN ARRAY JJ AND JPTY C OF THE TARGET STATE THAT CHANNEL K IS COUPLED TO. C 10 CONTINUE LMIN = LMIN + 1 LMAX = LMAX + 1 DO 20 L = LMIN,LMAX,4 NJCHA = NJCHA + 1 C C DIMENSION CHECK C IF (NJCHA.GT.ID) GOTO 20 C JCONAT(I)=JCONAT(I)+1 LJP(NJCHA) = L - 1 KJ(NJCHA) = JK JTARG(NJCHA) = I 20 CONTINUE 30 CONTINUE 40 CONTINUE IF (NJCHA.GT.ID) CALL RECOV2('NJCHAN',' MZCHF',MZCHF,NJCHA) IF (NJCHA.EQ.0) GOTO 70 C C WRITE OUT THE DATA DEFINING THE CHANNELS FOR THIS SYMMETRY C IF (IBUG4.EQ.0) GOTO 70 WRITE (IWRITE,3020) NJCHA WRITE (IWRITE,3040) (LJP(N),N=1,NJCHA) WRITE (IWRITE,3050) (KJ(N),N=1,NJCHA) WRITE (IWRITE,3060) (JTARG(N),N=1,NJCHA) WRITE (IWRITE,3080) DO 60 I = 1,NJCHA N = JTARG(I) AJ1 = 0.5D0*JJ(N) J1 = JPTY(N) + 1 AJ2 = 0.5D0*LJP(I) AJ3 = 0.5D0*KJ(I) AJ4 = 0.5D0 WRITE (IWRITE,3090) AJ1,PARITY(J1),AJ2,AJ3,AJ4,AJ,PARITY(JNPTY) 60 CONTINUE C C DETERMINE THE NUMBER OF LS-SYMMETRIES REQUIRED TO GIVE C CONVERGENCE OF THE TRANSFORMATION FOR THIS J-SYMMETRY C 70 CONTINUE IF (NJCHA.EQ.0) WRITE (IWRITE,3070) JCH(JPOS) = NJCHA CALL NUMSYM(JRGL,JNPTY,JCOUNT(JPOS)) IF (JCOUNT(JPOS).GT.MXLSJ) CALL RECOV2('NJCHAN','MXLSJ ',MXLSJ, A JCOUNT(JPOS)) C 3000 FORMAT (/52X,'SUBROUTINE NJCHAN'/52X,17 ('-')//' J =',F10.5,6X,A4, A 6X,'SYMMETRY'/1X,37 ('-')) 3010 FORMAT (/25X, A '**WARNING** INCIDENT ANGULAR MOMENTA REQUIRED UP TO L =' B ,I3,' LRANG2 =',I3) 3020 FORMAT (' NJCHA =',I3) 3040 FORMAT (' LJP =',20I3/ (8X,20I3)) 3050 FORMAT (' KJ =',20I3/ (8X,20I3)) 3060 FORMAT (' JTARG =',20I3/ (8X,20I3)) 3070 FORMAT (/25X,'**WARNING** NO COUPLED CHANNELS FOR THIS SYMMETRY') 3080 FORMAT (//' TARGET'/4X,'STATE',8X,'PARITY',10X,'L',9X,'K',9X, A 'S',9X,'J',8X,'PARITY'//) 3090 FORMAT (1X,F10.5,6X,A4,6X,4F10.5,6X,A4) END C C C SUBROUTINE NUMSYM(JRGL,JNPTY,ICOUNT) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C DETERMINES THE NUMBER (ICOUNT) OF LS-SYMMETRIES REQUIRED FOR COM- C PLETENESS OF THE TRANSFORMATION FOR GIVEN J,PARITY (JRGL,JNPTY) C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C CHARACTER*4 PARITY(0:1) C 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 PARITY/'EVEN',' ODD'/ C----------------------------------------------------------------------- C C DETERMINE THE MINIMUM AND MAXIMUM SPINS IN THE TARGET C IMIN = ISAT(1) IMAX = ISAT(1) IF (NAST.EQ.1) GOTO 20 DO 10 I = 2,NAST IF (ISAT(I).LT.IMIN) IMIN = ISAT(I) IF (ISAT(I).GT.IMAX) IMAX = ISAT(I) 10 CONTINUE C C DETERMINE THE RANGE OF VALUES OF 2S(SYSTEM)+1 C 20 CONTINUE IMIN = ABS(IMIN-2) + 1 IMAX = IMAX + 1 ICOUNT = 0 IF (IBUG4.NE.0) WRITE (IWRITE,3010) DO 70 I = IMIN,IMAX,2 C C FIND THE MINIMUM 2L(SYSTEM) VALUE AND CHECK IF IT IS INTEGER C LMIN = ABS(JRGL-I+1) IF (MOD(LMIN,2).EQ.1) GOTO 80 LMIN = LMIN + 1 LMAX = JRGL + I C C LOOP OVER THE 2L(SYSTEM)+1 VALUES FOR THIS 2S(SYSTEM)+1 C VALUE TO MAKE SURE THAT THERE ARE SOME CHANNELS COUPLED TO IT C DO 60 L = LMIN,LMAX,2 DO 40 L1 = 1,NAST C C CHECK THAT THE TARGET SPIN IS CONSISTENT WITH THE TOTAL SPIN C IF (LSJTRI(ISAT(L1)-1,I-1,0,1,0).EQ.0) GOTO 40 LLMIN = ABS(2*LAT(L1)-L+1) + 1 LLMAX = 2*LAT(L1) + L LX = LPTY(L1) DO 30 M = LLMIN,LLMAX,2 L2 = (M-1)/2 + LX IF (MOD(L2,2).EQ.JNPTY) GOTO 50 30 CONTINUE 40 CONTINUE GOTO 60 C C ICOUNT CONTAINS THE NUMBER OF LS-SYMMETRIES REQUIRED FOR C CONVERGENCE C 50 CONTINUE ICOUNT = ICOUNT + 1 L1 = (L-1)/2 L2 = I IF (IBUG4.NE.0) WRITE (IWRITE,3000) L1,L2,PARITY(JNPTY) 60 CONTINUE 70 CONTINUE 80 CONTINUE IF (ICOUNT.EQ.0) WRITE (IWRITE,3020) C 3000 FORMAT (' LRGL =',I2,' NSPN =',I2,' PARITY = ',A4) 3010 FORMAT (' THE SYMMETRIES REQUIRED ARE') 3020 FORMAT (' NO SYMMETRIES CONTRIBUTE') END C C C SUBROUTINE ORDER(EN,NORDER,NDIM,IUP) IMPLICIT REAL*8 (A-H,O-Z) 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 READS IMPLICIT REAL*8 (A-H,O-Z) C C C C----------------------------------------------------------------------- C C READS IN THE BASIC DATA FROM THE USER INPUT FILE IREAD C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXLSJ=20) PARAMETER (MXNCF=MZTAR) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB4=MXORB+4) PARAMETER (MXTCC=100*MXNCF+MXJC) PARAMETER (MXTDW=MZLR1*MXTCC) C CHARACTER*1 NUM(0:9) CHARACTER*4 RAD,RELOP CHARACTER*13 REC,RECA !parallel CHARACTER*4 TITLE(18),PARITY(0:1) C LOGICAL EX C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST 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 /DW/IDWOUT COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /RECOV/IPLACE COMMON /NRBDEL/DELELS(MZTAR),ISHFTLS COMMON /NRBDIP/MAXLD,J2MAXD COMMON /NRBKUT/EAST(MZTAR),TOLB,NFK(MZTAR),KCUT COMMON /NRBSKP/ESKPL,ESKPH,ECORR,ISKIP(MZTAR) !NRB-SKIP c c * parallel * c include 'mpif.h' common /parablock/iam,nproc common /pdim/mnp1p(mzslp),nconhpp(mzslp),njchap(mzslp) x ,jrglp(mzslp),jnptyp(mzslp),nsym C NAMELIST/STGJA/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8 X,IBUG9,IPUNCH,IPHOT,RELOP,RAD,ITAPE3,IDWOUT,ISHFTLS NAMELIST/STGJB/ICHECK,JNAST,IJNAST,J2MIN,J2MAX,ESKPL,ESKPH,ECORR x,J2MAXD,KCUT,TOLB C DATA PARITY/'EVEN',' ODD'/ DATA KFLN,KFL2,KFLM/MZOCC,MXORB4,MZNC2/ DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ C----------------------------------------------------------------------- C C SET THE PARAMETER IPLACE USED UN THE DIMENSION CHECK ROUTINE C RECOV2; JNTCON(1) IS TESTED IN BOUNDJ. C IPLACE = 0 JNTCON(1) = 0 C C READ THE BASIC DATA FROM USER INPUT FILE C READ (IREAD,3120) TITLE C WRITE (IWRITE,3000) TITLE WRITE (IWRITE,3010) * MZCHF,MZCHL,MZLMX,MZLR1,MZLR2,MZMEG,MZKIL,MZNC2, * MZNR1,MZNR2,MZOCC,MZSLP,MZTAR, * MXNCF,MXJC,MXHLS,MXLSJ,MXTCC,MXTDW C C INITIALIZE NAMELIST STGJA C C IPUNCH .GT. 0 FOR TERM COUPLING COEFFICIENTS C IPHOT .GT. 0 FOR DIPOLE MATRICES I/O C ISHFTLS .EQ.+/-1 FOR TERM ENERGY CORRECTIONS C IBUG1=0 IBUG2=0 IBUG3=0 IBUG4=0 IBUG5=0 IBUG6=0 IBUG7=0 IBUG8=0 IBUG9=0 IPHOT=0 IPUNCH=0 RELOP='YES' RAD='NO' ITAPE3=3 IDWOUT=0 ISHFTLS=0 C READ(IREAD,STGJA) C IF(IPHOT.GT.0.OR.RAD.EQ.'YES')ITAPE1=1 C C----------------------------------------------------------------------- C C Set the I/O numbers and open files. C C IREAD (5) .. input data .. dstgjk C IWRITE (6) .. printed output .. routjk C C IPUNCH (7) .. term coupling coeff. .. TCC.DAT .. if IPUNCH>0 C C IDISC1 (11) .. scratch file (DA2) C IDISC2 (12) .. scratch file (DA2) C IDISC3 .. NOT USED C IDISC4 .. NOT USED C C ITAPE1 (1) .. dipole input .. STG2D.DAT .. if ITAPE1>0 C ITAPE2 (2) .. hamiltonian input .. STG2H.DAT .. always used C ITAPE3 (3) .. hamiltonian output .. RECUPH.DAT .. if ITAPE3>0 C ITAPE4 (4) .. dipole output .. RECUPD.DAT .. if ITAPE1>0 C C JDISC1 .. NOT USED C JDISC2 .. NOT USED C C----------------------------------------------------------------------- IWRITE = 6 C IF(RELOP.EQ.'TCCR')RELOP='TCC' IF (IPUNCH.GT.0.OR.RELOP.EQ.'TCC'.OR.IDWOUT.GT.0) THEN IPUNCH = 7 ELSE IPUNCH = 0 ENDIF C IDISC1 = 11 IDISC2 = 12 IDISC3 = 0 IDISC4 = 0 C IF (ITAPE1.GT.0) THEN ITAPE1 = 1 ITAPE4 = 4 ELSE ITAPE1 = 0 ITAPE4 = 0 ENDIF C ITAPE2 = 2 C IF (ITAPE3.GT.0) THEN ITAPE3 = 3 ELSE ITAPE3 = 0 ENDIF C JDISC1 = 0 JDISC1 = 0 C IF (IPUNCH.GT.0) THEN OPEN (UNIT=IPUNCH,FILE='TCC.DAT',STATUS='UNKNOWN', A FORM='FORMATTED') ENDIF C IF (ISHFTLS.NE.0) THEN IF(ISHFTLS.GT.1)THEN WRITE(IWRITE,*) X 'ITERATED TECS NOT CODED, USE FINAL ITERATION FROM AS INSTEAD' STOP 'ITERATED TECS NOT CODED!' ENDIF OPEN (UNIT=80,FILE='SHFTLS',STATUS='OLD', A FORM='FORMATTED') ENDIF C IF (ITAPE1.GT.0) THEN INQUIRE (FILE='STG2D.DAT',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7771) STOP 'STG2D.DAT DOES NOT EXIST!' ENDIF OPEN (UNIT=ITAPE1,FILE='STG2D.DAT',STATUS='OLD', A FORM='UNFORMATTED') ENDIF 7771 FORMAT ( A /' You have set ITAPE1>0 in the input data.' B /' The code expects a file containing dipole matrices.' C /' However file STG2D.DAT does not exist....stopping.') C c parallel INQUIRE (FILE='STG2HJ000',EXIST=EX) IF (.NOT.EX) THEN call mpi_finalize(ierr) WRITE (IWRITE,7772) 7772 FORMAT ( B /' The code expects a file containing hamiltonian matrices.' C /' However even a STG2HJ000 does not exist....stopping.') ENDIF C i1=iam/100 i2=(iam-100*(iam/100))/10 i3=iam-(100*(iam/100))-i2*10 RECA='STG2HJ'//NUM(i1)//NUM(i2)//NUM(i3) OPEN (UNIT=ITAPE2,FILE=RECA,STATUS='OLD', A FORM='UNFORMATTED') REWIND(ITAPE2) C IF (ITAPE3.GT.0) THEN c c .............. open multiple RECUPH files c i1=iam/100 i2=(iam-100*(iam/100))/10 i3=iam-(100*(iam/100))-i2*10 REC='RECUPH'//NUM(i1)//NUM(i2)//NUM(i3) OPEN (UNIT=ITAPE3,FILE=REC,STATUS='UNKNOWN', A FORM='UNFORMATTED') REWIND(ITAPE3) c c ENDIF C IF (ITAPE4.GT.0) THEN OPEN (UNIT=ITAPE4,FILE='RECUPD.DAT',STATUS='UNKNOWN', A FORM='UNFORMATTED') ENDIF C----------------------------------------------------------------------- WRITE (IWRITE,3020) A IREAD,IWRITE,IPUNCH, B IDISC1,IDISC2,IDISC3,IDISC4, C ITAPE1,ITAPE2,ITAPE3,ITAPE4, D JDISC1,JDISC2 C IF (MZOCC.NE.KFLN .OR. MXORB.NE.KFL2-4 .OR. A MZNC2.NE.KFLM) GOTO 80 C WRITE (IWRITE,3030) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7, A IBUG8,IBUG9 C C READ THE NUMBER OF TARGET STATES INTO 'JNAST' C C IF ICHECK=1, DO NOT READ J TARGET DATA (ENATJ,JNTCON,B,LSVALU), C CALCULATE THESE IN SUBROUTINE BOUNDJ BY RECOUPLING THE LS TARGET C HAMILTONIANS FROM STG2 AND DIAGONALISING. C C C INITIALIZE NAMELIST STGJB 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 ICHECK=1 JNAST=0 IJNAST=0 J2MIN=-1 J2MAX=-2 ESKPH=-9999999.D0 ESKPL=99999999.D0 ECORR=99999999.D0 J2MAXD=999 KCUT=0 TOLB=5.D-4 C READ(IREAD,STGJB) C IF(ESKPL.GE.ESKPH)ESKPL=99999999.D0 IF(KCUT.GT.0)THEN !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 WRITE (IWRITE,*) JNAST,' TARGET J LEVELS, ICHECK = ',ICHECK IF (JNAST.GT.MZTAR) CALL RECOV2('READS ',' MZTAR',MZTAR,JNAST) C C READ IN THE 2J VALUE OF THE TARGET STATES INTO 'JJ' C AND THE PARITY INTO 'JPTY'. IF PARITY IS NEGATIVE READ C LSKP, THE NUMBER OF ENERGY-ORDERED LEVELS TO BE SKIPPED C EVEN PARITY JPTY=0 OR 2 (LATTER NEEDED BY LSKP FOR 0 0!) - NRB C ODD PARITY JPTY=1 C DO I=1,JNAST LSKP=0 !NRB-SKIP IF(KCUT.GT.0)THEN READ (IREAD,*) JJ(I),JPTY(I),ISDUM,ILDUM,NFK(I),IDUM,EAST(I) EAST(I)=EAST(I)/2 !RYD->A.U. ELSE READ (IREAD,*) JJ(I),JPTY(I) ENDIF IF(JPTY(I).LT.0)THEN !NRB-SKIP JPTY(I)=-JPTY(I) !NRB-SKIP READ (IREAD,*)LSKP !NRB-SKIP IF(KCUT.GT.0)LSKP=0 !SINCE ONLY MATCH SPEC ENDIF !NRB-SKIP JPTY(I)=MOD(JPTY(I),2) !NRB-SKIP ISKIP(I)=LSKP !NRB-SKIP IF (ICHECK.EQ.1) WRITE(IWRITE,3100) JJ(I),JPTY(I) ENDDO IF(ICHECK.EQ.1)GO TO 60 C C READ IN THE EXPERIMENTAL ENERGIES INTO ARRAY 'ENATJ' C READ (IREAD,3110) (ENATJ(I),I=1,JNAST) READ (IREAD,3100) (JNTCON(I),I=1,JNAST) DO 10 I = 1,JNAST K = JNTCON(I) IF (K.GT.MXNCF) CALL RECOV2('READS ','MXNCF ',MXNCF,K) READ (IREAD,3110) (B(I,J),J=1,K) 10 CONTINUE DO 20 I = 1,JNAST K = JNTCON(I) READ (IREAD,3100) (LSVALU(I,J),J=1,K) 20 CONTINUE C C TABULATE THE DATA DEFINING THE TARGET STATES. C WRITE (IWRITE,3040) DO 30 I = 1,JNAST AJ = 0.5D0*JJ(I) WRITE (IWRITE,3050) AJ,PARITY(JPTY(I)),ENATJ(I) 30 CONTINUE WRITE (IWRITE,3060) DO 40 I = 1,JNAST K = JNTCON(I) WRITE (IWRITE,3110) (B(I,J),J=1,K) 40 CONTINUE WRITE (IWRITE,3070) DO 50 I = 1,JNAST K = JNTCON(I) WRITE (IWRITE,3100) K, (LSVALU(I,J),J=1,K) 50 CONTINUE WRITE (IWRITE,3090) C C 60 CONTINUE C IF(IDWOUT.EQ.2)RETURN C C READ THE NUMBER OF TOTAL ANGULAR MOMENTUM AND PARITY C SYMMETRIES INTO 'IJNAST'. C***** IF J2MIN .LE. JMAX (& BOTH .GE. 0) THESE ARE AUTOMATICALLY C GENERATED AND INPUT IJNAST IS IGNORED. C IF(J2MIN.LE.J2MAX.AND.J2MIN.GE.0)THEN IJNAST=J2MAX-J2MIN+2 nsym=ijnast/nproc !parallel ELSE NSYM=1 J2MIN=-1 IF(IJNAST.LE.0)THEN WRITE(IWRITE,*)'NO N+1 SYMMETRIES SPECIFIED...' STOP 'NO N+1 SYMMETRIES SPECIFIED' ENDIF ENDIF C c parallel IF(IJNAST.NE.NPROC*NSYM)THEN call mpi_finalize(ierr) if(iam.eq.0)then WRITE(IWRITE,*)'*******ERROR:' WRITE(IWRITE,*)'REQUIRE EQUAL NO.OF JP SYMS PER PROCESSOR' WRITE(IWRITE,*)'NO. OF SYMS=',IJNAST,' BUT NSYM*NPROC=' X ,NPROC*NSYM STOP 'ERROR: REQUIRE EQUAL NO.OF JP SYMS PER PROCESSOR' else stop endif ENDIF c parallel WRITE(IWRITE,*) IJNAST,' TOTAL 2J AND PARITY SYMMETRIES ...' IF (IJNAST.GT.MZSLP) CALL RECOV2('READS ',' MZSLP',MZSLP,IJNAST) C IF(J2MIN.GE.0)THEN J0=J2MIN DO J=1,IJNAST JP(J)=MOD(J,2) J2(J)=J0 WRITE(IWRITE,3100)J2(J),JP(J) J0=J2MIN+2*(J/2) ENDDO c parallel if(mod(nsym,2).eq.1)then iam2=mod(iam,2) J20=J2MIN+iam*nsym-iam2 do N=1,nsym J2(N)=J20+((N-1+MOD(iam,2))/2)*2 JP(N)=MOD(N+iam2,2) enddo else J20=J2MIN+iam*nsym do N=1,nsym J2(N)=J20+((N-1)/2)*2 JP(N)=MOD(N,2) enddo endif c parallel ELSE DO J = 1,IJNAST READ (IREAD,*) J2(J),JP(J) WRITE (IWRITE,3100) J2(J),JP(J) ENDDO c parallel j2(1)=j2(iam+1) jp(1)=jp(iam+1) c parallel ENDIF c ijnastorig=ijnast ijnast=nsym c IF (ITAPE2.EQ.0) GOTO 90 RETURN C 80 CONTINUE WRITE (IWRITE,3080) MZOCC,KFLN,MXORB,KFL2,MZNC2,KFLM 90 CONTINUE STOP C 3000 FORMAT (//8X,72 ('-')//8X,18A4//8X,72 ('-')////9X, A 'RRRRRRRRR EEEEEEEEEE CCCCCCCC UU UU ' B ,' PPPPPPPPP'/9X, C 'RRRRRRRRRR EEEEEEEEEE CCCCCCCCCC UU UU ' D ,' PPPPPPPPPP'/9X, E 'RR RR EE CC CC UU UU ' F ,' PP PP'/9X, G 'RR RR EE CC CC UU UU ' H ,' PP PP'/9X, I 'RRRRRRRRRR EE CC UU UU ' J ,' PPPPPPPPPP'/9X, K 'RRRRRRRRR EEEEEEE CC UU UU ' L ,' PPPPPPPPP'/9X, M 'RRRRR EEEEEEE CC UU UU ' N ,' PP'/9X, O 'RR RR EE CC UU UU ' P ,' PP'/9X, Q 'RR RR EE CC CC UU UU ' R ,' PP'/9X, S 'RR RR EE CC CC UU UU ' A ,' PP'/9X, B 'RR RR EEEEEEEEEE CCCCCCCCCC UUUUUUUUUU ' C ,' PP'/9X, D 'RR RR EEEEEEEEEE CCCCCCCC UUUUUUUU ' E ,' PP') 3010 FORMAT (//12X,'COMPILED FOR DIMENSIONS'//15X, A 'NUMBER OF J CHANNELS MZCHF = ',I6/15X, B 'NUMBER OF CHANNELS OF TOTAL LS MZCHL = ',I6/15X, C 'LAMAX - HIGHEST MULTIPOLARITY MZLMX = ',I6/15X, D 'LRANG1 - MAXIMUM TARGET ORBITAL L MZLR1 = ',I6/15X, E 'LRANG2 - MAXIMUM CONTINUUM L MZLR2 = ',I6/15X, F 'MEGAWORDS OF MEMORY FOR SCRATCH MZMEG = ',I6/15X, F 'KILOWORDS OF MEMORY FOR SCRATCH MZKIL = ',I6/15X, G 'N+1 ELECTRON BOUND CONFIGURATIONS MZNC2 = ',I6/15X, H 'HIGHEST N IN BOUND ORBITALS MZNR1 = ',I6/15X, I 'NRANG2 - SIZE OF CONTINUUM BASIS MZNR2 = ',I6/15X, J 'NUMBER OF OCCUPIED SHELLS MZOCC = ',I6/15X, K '(N+1)-ELECTRON SYMMETRIES MZSLP = ',I6/15X, L 'TARGET STATES MZTAR = ',I6/15X, M 'TARGET CONFIGURATIONS MXNCF = ',I6/15X, N 'RECOUPLING COEFFICIENTS MXJC = ',I6/15X, O 'LS MATRIX ORDER NRANG2*NCHAN+NCFGP MXHLS = ',I6/15X, P 'NUMBER OF SYMMETRIES SL IN ONE J MXLSJ = ',I6/15X, Q 'TERM COUPLING COEFFICIENTS MXTCC = ',I6/15X, R 'TERM COUPLING COEFFICIENTS MXTDW = ',I6) 3020 FORMAT ( A////52X,'SUBROUTINE READS' B /52X,16 ('-') C //' INPUT-OUTPUT CHANNEL NUMBERS' C//' IREAD (',I2,') .. input data .. dstgjk ' C /' IWRITE (',I2,') .. printed output .. routjk ' C /' IPUNCH (',I2,') .. term coupling coeff. .. TCC.DAT ' A ,'.. if IPUNCH>0' C /' IDISC1 (',I2,') .. scratch file (DA2)' C /' IDISC2 (',I2,') .. scratch file (DA2)' C /' IDISC3 (',I2,') .. NOT USED' C /' IDISC4 (',I2,') .. NOT USED' C /' ITAPE1 (',I2,') .. dipole input .. STG2D.DAT ' A ,'.. if ITAPE1>0' C /' ITAPE2 (',I2,') .. hamiltonian input .. STG2H.DAT ' A ,'.. always used' C /' ITAPE3 (',I2,') .. hamiltonian output .. RECUPH.DAT ' A ,'.. if ITAPE3>0' C /' ITAPE4 (',I2,') .. dipole output .. RECUPD.DAT ' A ,'.. if ITAPE1>0' C /' JDISC1 (',I2,') .. NOT USED' C /' JDISC2 (',I2,') .. NOT USED') 3030 FORMAT (/' DEBUG PARAMETERS'/9I5) 3040 FORMAT (/40X,'FINE STRUCTURE TARGET INPUT DATA'/40X,32 ('-')///5X, A 'J',8X,'PARITY',6X,'ENERGY'/) 3050 FORMAT (F14.7,1X,A4,F16.7) 3060 FORMAT (/' B ARRAY -- ALL TERMS MUST BE DECLARED SPECTROSCOPIC!'/ A ) 3070 FORMAT (/' JNTCON: LSVALU ARRAY'/) 3080 FORMAT (/' RECUPD ABORTING'/' (AMP)OCC=',I4,' MUST EQUAL KFLN=', A I4/' MXORB=',I4,' MUST EQUAL KFL2-4=',I4,'-4'/' (AMP)NC2=', B I4,' MUST EQUAL KFLM=',I4/' RECOMPILE RECUPD (OR STGLIB)!'/ C ) 3090 FORMAT (/1X,73 ('*')) 3100 FORMAT (12I5) 3110 FORMAT (5F14.7) 3120 FORMAT (18A4) 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 RECUD(JI,JF) IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C FINDS SUITABLE PAIRS OF SYMMETRIES IN LS COUPLING TO FORM C DIPOLE MATRIX ELEMENTS FOR A TRANSITION ARRAY (JI,JF) C IN INTERMEDIATE COUPLING. C C JI,JF = POSITIONS OF INITIAL,FINAL J SYMMETRIES IN /ALPHA/. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) C LOGICAL SWITCH,TII,TIF,TFI,TFF CTG X,TI,TF C CHARACTER*4 PARITY(0:1) C COMMON /ALPHA/LLRGL(MZSLP),NNSPN(MZSLP),NNPTY(MZSLP), A NNCHAN(MZSLP),NNCHGP(MZSLP) COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /CASES/MORE,MSKIP,IPOLPH,INAST 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 /POTORB/PV(MXJC3),QV(MXJC3),ICHAN(MXJC3),IICHAN(MXJC3), A NTERM(MZCHF),MTERM(MZCHF) COMMON /NRBDIP/MAXLD,J2MAXD C DIMENSION IPARTK(MZSLP) C DATA ZERO/0.0D0/,PARITY/'EVEN',' ODD'/ C----------------------------------------------------------------------- c write(6,*) 'test enter RECUD' JJRGL = J2(JI) JJNPTY = JP(JI) MJCHA = JCH(JI) JRGL = J2(JF) JNPTY = JP(JF) NJCHA = JCH(JF) AJ = JJRGL/2.0D0 CNJ = JRGL/2.0D0 WRITE (IWRITE,3000) AJ,PARITY(JJNPTY),CNJ,PARITY(JNPTY) CNJ = (JJRGL+1)* (JRGL+1) CNJ = SQRT(CNJ) ICNTF = 0 ICNTI = 0 LASTF = 0 LASTI = 0 C C REWIND STG2 DIPOLE MATRIX FILE C REWIND ITAPE1 C C ---- LOOP OVER ALL FINAL TOTAL S-L-PI STATES C C-KAB JNCFGP=0, KMCFGP=0 -- KAB CORR'S WE'91MAR19, MORE WE'92APR28-30: CW JFI = 0 JFF = 0 CTG KII=0 CTG LSWI = 0 IEVODD=0 DO 61 I=1,INAST C C INITIALIZE THE FLAG FOR EVEN SYMMETRIES WHICH PARTAKE C IPARTK(I)=0 C C FIND WHERE EVEN SYMMETRIES SWITCH TO ODD C IF(NNPTY(I).EQ.1.AND.IEVODD.EQ.0)IEVODD=I C IF(IEVODD.GT.0.AND.NNPTY(I).EQ.0)THEN WRITE(6,*)'ERROR, MUST HAVE ALL EVEN, THEN ALL ODD, PARITIES' WRITE(0,*)'ERROR, MUST HAVE ALL EVEN, THEN ALL ODD, PARITIES' STOP ENDIF 61 CONTINUE C C FIND WHICH EVEN PARITIES PARTAKE IN THE J->J' TRANSITION C DO 62 LF=IEVODD,INAST DO 62 LI=1,IEVODD-1 I1=LSJTRI(LLRGL(LF),NNSPN(LF),NNPTY(LF),JJRGL,JJNPTY) I2=LSJTRI(LLRGL(LF),NNSPN(LF),NNPTY(LF),JRGL,JNPTY) K1=LSJTRI(LLRGL(LI),NNSPN(LI),NNPTY(LI),JRGL,JNPTY) K2=LSJTRI(LLRGL(LI),NNSPN(LI),NNPTY(LI),JJRGL,JJNPTY) IF((I1*K1.NE.0.OR.I2*K2.NE.0) X .AND.LLRGL(LI).LE.2*MAXLD)IPARTK(LI)=1 !NRB 62 CONTINUE DO 60 LF = 1,INAST IF (ICNTF.GE.JCOUNT(JF) .AND. ICNTI.GE.JCOUNT(JI)) GOTO 70 TFI = LSJTRI(LLRGL(LF),NNSPN(LF),NNPTY(LF),JJRGL,JJNPTY) .NE. 0 TFF = LSJTRI(LLRGL(LF),NNSPN(LF),NNPTY(LF),JRGL,JNPTY) .NE. 0 IF (TFI) ICNTI = ICNTI + 1 IF (TFF) ICNTF = ICNTF + 1 CW IF(LF.EQ.1) GOTO 299 IF (LF.EQ.1) GOTO 60 C C ---- LOOP OVER ALL INITIAL TOTAL S-L-PI STATES C CTG KII = 0 CW KIF = 0 LPOSI = 0 DO 50 LI = 1,LF C C DETERMINE HOW MANY EVEN CFGS. SHOULD BE SKIPPED C KII=0 DO 51 LJK=1,LI-1 IF(IPARTK(LJK).EQ.1)KII=KII+NNCHGP(LJK) 51 CONTINUE C C CHECK THE PARITY AND TRIANGULAR RELATIONS TO SEE IF THIS C SYMMETRY CONTRIBUTES TO THE TRANSFORMATION, C THAT IS IF /L-S/JJRGL IF (SWITCH) RAC = -RAC !FANO DIPOLE LG = LRGL/2 NS = NSPN + 1 IF (RAC.EQ.ZERO) GOTO 40 WRITE (IWRITE,3080) LOP,NS,PARITY(NNPTY(LPOSI)),LG,NS, A PARITY(NNPTY(LPOSF)),RAC C C READ INITIAL AND FINAL CHANNEL RECOUPLING DATA FROM DA FILE. C IF (LPOSI.NE.LASTI) CALL DAFILA(1,LPOSI,LRGLP,JJRGL,MJCHA, A MTERM,MTERMI,IICHAN,QV) LASTI = LPOSI IF (IBUG5.GT.1) THEN WRITE (IWRITE,3060) WRITE (IWRITE,3040) (MTERM(I),I=1,MJCHA) WRITE (IWRITE,3040) MTERMI, (IICHAN(I),I=1,MTERMI) WRITE (IWRITE,3050) (QV(I),I=1,MTERMI) ENDIF C IF (LPOSF.NE.LASTF) CALL DAFILA(1,LPOSF,LRGL,JRGL,NJCHA,NTERM, A NTERMI,ICHAN,PV) LASTF = LPOSF IF (IBUG5.GT.1) THEN WRITE (IWRITE,3070) WRITE (IWRITE,3040) (NTERM(I),I=1,NJCHA) WRITE (IWRITE,3040) NTERMI, (ICHAN(I),I=1,NTERMI) WRITE (IWRITE,3050) (PV(I),I=1,NTERMI) ENDIF C C CALL DMES TO EVALUATE THE CONTRIBUTION FROM THE LS COUPLED C DIPOLE MATRIX ELEMENT TO THE JL COUPLED ONE C CALL DMES(LPOSI,LPOSF,MJCHA,NJCHA,KMCFGP,JNCFGP,SWITCH,RAC) 40 CONTINUE CTG KII = NNCHGP(LI) + KII CW199 IF(TII) KII=KII+NNCHGP(LPOSI), IF(TIF) KIF=KIF+NNCHGP(LPOSI) C-KAB KMCFGP=KMCFGP+NNCHGP(LPOSI), JNCFGP=JNCFGP+NNCHGP(LPOSF) CC IF(IBUG5.GT.0) PRINT *,' LI,KII,KMCFGP = ', LI,KII,KMCFGP 50 CONTINUE IF (LPOSI.NE.0) JFF = NNCHGP(LF) + JFF CC IF(IBUG5.GT.0) PRINT *,' LF,JFF,KMCFGP = ', LF,JFF,JNCFGP CW299 IF(TII) JFI=JFI+NNCHGP(LPOSI), IF(TFF) JFF=JFF+NNCHGP(LPOSI) 60 CONTINUE C 70 CONTINUE RETURN C 80 CONTINUE WRITE (IWRITE,3030) C STOP -- OR RESET OUTPUT POINTER ON FILE FOR STGH... C 3000 FORMAT (/51X,'SUBROUTINE RECUD'/51X,16 ('-')/' INITIAL STATE J =', A F5.1,6X,A4,6X,'SYMMETRY'/1X,46 ('-')/' FINAL STATE J =', B F5.1,6X,A4,6X,'SYMMETRY'/1X,46 ('-')) 3010 FORMAT (/' RECUD - REVERSE DIPOLE MATRIX NEEDED:') 3020 FORMAT (' READ D-MATRIX. INITIAL, FINAL LSPI =',2 (2X,3I3)) 3030 FORMAT (/ A ' RECUD REQUIRES INPUT FROM STG2 THAT GROUPS EVEN AND ODD'/ B 27X,'PARITY SYMMETRIES SL TOGETHER:'/60X,9 ('*')/60X, C '* ABORT *'/60X,9 ('*')) 3040 FORMAT (12I5) 3050 FORMAT (5F14.7) 3060 FORMAT (/' INITIAL STATE') 3070 FORMAT (/' FINAL STATE') 3080 FORMAT (' INITIAL, FINAL LSPI =',2(2X,2I3,1X,A4),' RAC =',F10.5) END C C C SUBROUTINE RECUPD IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*1 NUM(0:9) CHARACTER*9 RECA C----------------------------------------------------------------------- C C RECUPD DRIVER C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 COMMON /DIAGC/NDIAG COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /DW/IDWOUT COMMON /INFORM/IREAD,IWRITE,IPUNCH COMMON /REL/JRELOP(3) COMMON /NRBDIP/MAXLD,J2MAXD DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ c c * parallel * c include 'mpif.h' common /parablock/iam,nproc common /pdim/mnp1p(mzslp),nconhpp(mzslp),njchap(mzslp) x ,jrglp(mzslp),jnptyp(mzslp),nsym c c C LOGICAL EX C----------------------------------------------------------------------- IREAD = 5 IWRITE = 6 C i1=iam/100 i2=(iam-100*(iam/100))/10 i3=iam-(100*(iam/100))-i2*10 RECA='routjk'//NUM(i1)//NUM(i2)//NUM(i3) OPEN (UNIT=IWRITE,FILE=RECA,STATUS='UNKNOWN', A FORM='FORMATTED') C EX=.TRUE. INQUIRE (FILE='dstgjk',EXIST=EX) IF (.NOT.EX) THEN WRITE (IWRITE,7777) STOP ENDIF 7777 FORMAT (/' dstgjk does not exist....stopping.') C OPEN (UNIT=IREAD,FILE='dstgjk',STATUS='OLD',FORM='FORMATTED') C----------------------------------------------------------------------- C C READ INPUT FILE IREAD AND HEADER OF ITAPE2 C CALL READS CALL COPYTP(ITAPE2) C WRITE (IWRITE,3000) C C INITIALIZE: FACTORIALS IN /FACTS/ AND MEM1 IN /MEMORY/ C ALSO CHECK STGLIB DIMENSIONS IN /BPSIZE/ C CALL IRECUP(NRANG2,JRELOP(3)) C C DIAGONALIZE N-ELECTRON TARGET HAMILTONIAN, IF REQUESTED. C TERMINATE IF MERE TCC RUN. C IF (NDIAG.EQ.1) CALL BOUNDJ C CALL MPI_BARRIER(MPI_COMM_WORLD,IERR) IF (LRANG2.LE.0.OR.IDWOUT.EQ.2) GO TO 40 C C WRITE BASIC QUANTITIES AS A HEADER ON OUTPUT FILE ITAPE3 C IF (ITAPE3.GT.0) CALL WRITAP(23) WRITE (IWRITE,3000) c c parallel c ijnastp=nsym*nproc do i=1,ijnastp mnp1p(i)=0 nconhpp(i)=0 njchap(i)=0 jrglp(i)=0 jnptyp(i)=0 enddo C C ---- LOOP OVER THE TOTAL ANGULAR MOMENTUM AND PARITY SYMMETRIES. C DO 10 J = 1,IJNAST C C POSITION INPUT FILE FROM STG2 BY REWINDING AND READING HEADER. C IF (J.GT.1) CALL COPYTP(ITAPE2) C C DETERMINE THE NUMBER OF CHANNELS FOR THIS TOTAL ANGULAR C MOMENTUM AND PARITY SYMMETRY C CALL NJCHAN(J) C if(iam.eq.0)write(0,*)'after njchan' IF (JCH(J).EQ.0) GOTO 10 C C APPLY THE RECOUPLING TRANSFORMATION TO THE STG2 LS-HAMILTONIAN C MATRICES AND LONG RANGE POTENTIAL COEFFICIENTS C IF (ITAPE3.NE.0) CALL HJZERO(J) C if(iam.eq.0)write(0,*)'after hjzero' CALL RECUPJ(J) C if(iam.eq.0)write(0,*)'after recupj' IF (ITAPE3.EQ.0) GOTO 10 C C CALCULATE THE CONTRIBUTION TO THE HAMILTONIAN MATRIX FROM C THE SPIN-ORBIT INTERACTION IF REQUIRED C IF (JRELOP(3).NE.0) CALL SPINOR(J) C if(iam.eq.0)write(0,*)'after spinor' C C WRITE THE TRANSFORMED HAMILTONIAN MATRICES AND LONG-RANGE C POTENTIAL COEFFICIENTS TO THE PERMANENT OUTPUT FILE C CALL WRIT3(J) WRITE (IWRITE,3000) C 10 CONTINUE IF (ITAPE4.EQ.0 .OR. IJNAST.LE.1) GOTO 40 C C ---- LOOP OVER ALLOWED FINAL (JF) AND INITIAL (JI) TOTAL ANGULAR C MOMENTUM AND PARITY SYMMETRIES TO RECOUPLE DIPOLE MATRICES C DO 30 JF = 2,IJNAST IF (JCH(JF).EQ.0) GOTO 30 IF (J2(JF).GT.J2MAXD) GO TO 30 DO 20 JI = 1,JF - 1 IF (JCH(JI).EQ.0) GOTO 20 IF (J2(JI).GT.J2MAXD) GO TO 20 C C CHECK FOR DIPOLE TRANSITION C IF (JP(JI).EQ.JP(JF) .OR. ABS(J2(JI)-J2(JF)).GT.2) GOTO 20 IF (J2(JI).EQ.0 .AND. J2(JF).EQ.0) GOTO 20 C C RECOUPLE DIPOLE MATRICES C CALL DJZERO(JI,JF) CALL RECUD(JI,JF) C C WRITE OUT RECOUPLED DIPOLE MATRICES C CALL DMOUT(JI,JF) WRITE (IWRITE,3000) C 20 CONTINUE 30 CONTINUE C 40 CONTINUE WRITE (IWRITE,3010) RETURN C 3000 FORMAT (/10X,63 ('*')) 3010 FORMAT (/54X,'END OF RECUPD'/54X,13 ('-')) END C C C SUBROUTINE RECUPJ(JPOS) use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KMEM,KAB28,I8,KREC,MXMEM8,KREC1 C C C C----------------------------------------------------------------------- C C RECOUPLES THE HAMILTONIAN MATRICES AND LONG RANGE POTENTIAL C COEFFICIENTS FROM LS TO INTERMEDIATE J COUPLING. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUMC=MXLPOT-MZCHF*MZCHF*MZLMX-MZCHL*MZCHL*MZLMX) PARAMETER (MXLSJ=20) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOC21=2*MZOCC-1) C CHARACTER*4 PARITY(0:1) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /BNDBOX/LCFBOX(MXLSJ),LOCCSH(MZNC2),LOCORB(MZOCC,MZNC2), A LELCSH(MZOCC,MZNC2),N1QNRD(MXOC21,3,MZNC2) COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /CASES/MORE,MSKIP,IPOLPH,INAST COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) COMMON /CHBOX/L2PBOX(MZCHL,MXLSJ),LSTBOX(MZCHL,MXLSJ) 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 /JCHAN/LJP(MZCHF),KJ(MZCHF),JTARG(MZCHF) COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /LRPOT/CF(MZCHL,MZCHL,MZLMX), A CFJ(MZCHF,MZCHF,MZLMX),DUMC(MXDUMC) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /POTORB/PV(MXJC3),PPV(MXJC3),ICHAN(MXJC3),MCHAN(MXJC3), A NTERM(MZCHF),NNTERM(MZCHF) 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) C DATA ZERO,ONE/0.0D0,1.0D0/ DATA PARITY/'EVEN',' ODD'/ C----------------------------------------------------------------------- C C ON FIRST CALL, PERFORM SOME CHECKS, ZEROIZE INAST. C MXMEM8=MXMEM C C WRITE (IWRITE,3000) IF (JPOS.EQ.1) THEN INAST = 0 ENDIF C C CHECK THAT STG2 HAS BEEN RUN WITH EACH STATE REPRESENTED BY A C SINGLE CONFIGURATION (?) C IF (JRELOP(3).NE.0) THEN DO 30 I = 1,NAST ISUM = 0 DO 10 J = 1,NTCON(I) IF (AIJ(I,J).EQ.ZERO) GOTO 10 ISUM = ISUM + 1 IF (AIJ(I,J).NE.ONE) GOTO 20 NTYP(I,1) = NTYP(I,J) 10 CONTINUE IF (ISUM.EQ.1) GOTO 30 20 CONTINUE WRITE (IWRITE,3160) STOP C 30 CONTINUE ENDIF C C CHECK THE TRIANGULAR RELATIONS OF THE PARENT STATES OF THE TERM C COUPLING COEFFICIENTS TO MAKE SURE THEY ARE INPUT CORRECTLY C DO 50 I = 1,JNAST JP1 = JPTY(I) JJ1 = JJ(I) DO 40 J = 1,JNTCON(I) I2 = LSVALU(I,J) IF (LSJTRI(2*LAT(I2),ISAT(I2)-1,LPTY(I2),JJ1,JP1).NE. A 0) GOTO 40 WRITE (IWRITE,3150) I,J STOP C 40 CONTINUE 50 CONTINUE C C LPOS = COUNTER ON ALL LS SYMMETRIES ON STG2 FILE (TOTAL INAST); C IADD = COUNTER ON LS SYMMERIES WHICH COUPLE TO J. C LPOS = 0 IADD = 1 JCFG(JPOS) = 0 JRGL = J2(JPOS) JNPTY = JP(JPOS) NJCHA = JCH(JPOS) KAB1 = NRANG2*NJCHA KAB2 = NRANG2*NRANG2 C C ---- START OF LS SYMMETRY LOOP. READ THE STG2 OUTPUT FILE C 60 CONTINUE CALL HFIND(LPOS) IF (LPOS.EQ.0) GOTO 130 C C CHECK THE PARITY AND TRIANGULAR RELATIONS TO SEE IF THIS C SYMMETRY CONTRIBUTES TO THE TRANSFORMATION. C THAT IS IF /L-S/K KAB/PJS 12/01/07 ILL = IL*2 - 1 DO 10 J = 1,IL kOCORB(J,I) = JOCORB(J,I) kELCSH(J,I) = JELCSH(J,I) 10 CONTINUE DO 30 K = 1,3 DO 20 J = 1,ILL k1QNRD(J,K,I) = L1QNRD(J,K,I) 20 CONTINUE 30 CONTINUE 40 CONTINUE C DO 80 I = 1,NCFGP IL = IOCCSH(I) mOCCSH(I) = IL ! K->M KAB/PJS 12/01/07 ILL = 2*IL - 1 DO 50 J = 1,IL mOCORB(J,I) = IOCORB(J,I) mELCSH(J,I) = IELCSH(J,I) 50 CONTINUE DO 70 K = 1,3 DO 60 J = 1,ILL m1QNRD(J,K,I) = I1QNRD(J,K,I) 60 CONTINUE 70 CONTINUE 80 CONTINUE C MAXOR = MAXORB DO 130 MX = 1,MCFGP MY = 1 IF (SAME) MY = MX DO 120 MZ = MY,NCFGP IRHO = 0 ISIG = 0 SUM = 0.0D0 C C CALL SETUPE AND TENSOR TO DETERMINE THE ANGULAR CONTRIBUTION C CALL SETUPE(MZ,MX,NJCOMP,LJCOMP) ! MZ<->MX KAB/PJS 12/01/07 CALL TENSOR(KA,ISPIN,IRHO,ISIG,VSHELL) IF (IRHO.EQ.ISIG) GOTO 90 C C THE INTERACTING ELECTRONS ARE UNIQUELY DEFINED C IF (VSHELL(1).EQ.ZERO) GOTO 110 L1 = LJ(IRHO) L2 = LJ(ISIG) IF (L1.NE.L2) GOTO 110 IF (L1.EQ.0) GOTO 110 N1 = NJ(IRHO) N2 = NJ(ISIG) CALL FINBBR(N1,N2,L1,RAD) SUM = SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(1)*RAD GOTO 110 C C THE CONFIGURATIONS ARE IDENTICAL THEREFORE SUM OVER THE SUBSHELLS C IF IRHO=0 AND ISIG=0 THERE IS NO CONTRIBUTION C 90 CONTINUE IF (IRHO.EQ.0) GOTO 110 DO 100 I = 1,IHSH IF (VSHELL(I).EQ.ZERO) GOTO 100 L1 = LJ(I) IF (L1.EQ.0) GOTO 100 N1 = NJ(I) CALL FINBBR(N1,N1,L1,RAD) SUM = SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(I)*RAD + SUM 100 CONTINUE 110 CONTINUE IF (SAME) HLS(MZ,MX) = SUM HLS(MX,MZ) = SUM 120 CONTINUE 130 CONTINUE IF (IBUG9.LE.0) GOTO 150 MY = 1 DO 140 I = 1,MCFGP IF (SAME) MY = I WRITE (IWRITE,3000) I, (HLS(I,J),J=MY,NCFGP) 140 CONTINUE 150 CONTINUE C 3000 FORMAT (/6X, A'BOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM CONFIGURATI BON',I3/ (8F14.7)) END C C C SUBROUTINE SPINBC(MJ,RAC) use big1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALCULATES THE BOUND-CONTINUUM SPIN-ORBIT C INTERACTION WHERE THE CONTINUUM TERMS ARE ASSOCIATED C WITH (LLRGL,NNSPN) AND THE BOUND TERMS ARE ASSOCIATED C WITH (LRGL,NSPN). C MJ = POSITION OF LLRGL,NNSPN IN THE /ALPHA/ ARRAYS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXNCF=MZTAR) PARAMETER (MXOCC1=MZOCC+1) PARAMETER (MXOCC2=2*MZOCC+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXORB3=2*MXORB+3) C DIMENSION RAD(MZNR2) C COMMON /ALPHA/LL(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /BNDCON/NCFGP,IOCCSH(MZNC2),IOCORB(MZOCC,MZNC2), A IELCSH(MZOCC,MZNC2),I1QNRD(MXOC21,3,MZNC2) COMMON /CHANI/LL2P(MZCHL),MSTARG(MZCHL) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH 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 /SHELL/VSHELL(MXORB2) 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----------------------------------------------------------------------- ZERO = 0.0D0 LLRGL = LL(MJ) NNSPN = LS(MJ) NNCHAN = LCH(MJ) C C INITIALISE THE LSJ-HAMILTONIAN MATRIX C DO 20 J = 1,NCFGP DO 10 I = 1,NRANG2*NNCHAN HLS(I,J) = 0.0D0 10 CONTINUE 20 CONTINUE C C INITIALISE THE PARAMETERS USED IN TENSOR C KA = 1 ISPIN = 2 C C SETUP THE BOUND CONFIGURATIONS IN /MSTATE/ C DO 60 I = 1,NCFGP IL = IOCCSH(I) MOCCSH(I) = IL ILL = 2*IL - 1 DO 30 J = 1,IL MOCORB(J,I) = IOCORB(J,I) MELCSH(J,I) = IELCSH(J,I) 30 CONTINUE DO 50 K = 1,3 DO 40 J = 1,ILL M1QNRD(J,K,I) = I1QNRD(J,K,I) 40 CONTINUE 50 CONTINUE 60 CONTINUE DO 100 MX = 1,NNCHAN KAB11 = NRANG2* (MX-1) C C THE CONTINUUM ELECTRON MUST BE AN INTERACTING ELECTRON, C CHECK IF IT ITS ANGULAR MOMENTUM IS ZERO. IF IT IS C THERE IS NO SPIN-ORBIT INTERACTION C L4 = LL2P(MX) IF (L4.EQ.0) GOTO 100 I1 = MSTARG(MX) I4 = NTYP(I1,1) C C SETUP THE CONTINUUM CONFIGURATION ON THE R.H.S. C CALL SETR(LLRGL,NNSPN,I4,L4) MAXOR = MAXORB + 1 IOC = NOCCSH(I4) + 1 KOCORB(IOC,I4) = MAXOR NJCOMP(MAXOR) = 999 LJCOMP(MAXOR) = L4 DO 90 MY = 1,NCFGP IRHO = 0 ISIG = 0 C C CALL SETUPE AND TENSOR TO DETERMINE THE ANGULAR CONTRIBUTION C CALL SETUPE(MY,I4,NJCOMP,LJCOMP) CALL TENSOR(KA,ISPIN,IRHO,ISIG,VSHELL) C C IF IRHO=0 AND ISIG=0 THERE IS NO CONTRIBUTION C IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 90 N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) C C CHECK THAT N1 IS BOUND AND THAT N2 IS CONTINUUM C LX = L1 + 1 IF (N2.EQ.999 .AND. N1.LE.MAXNHF(LX)) GOTO 70 WRITE (IWRITE,3000) STOP C C IF L1.NE.L2 THERE IS NO CONTRIBUTION C 70 CONTINUE IF (L1.NE.L2 .OR. VSHELL(1).EQ.ZERO) GOTO 90 ANG = RAC*SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(1) CALL FINBCR(N1,NRANG2,L1,RAD) DO 80 MZ = 1,NRANG2 HLS(KAB11+MZ,MY) = ANG*RAD(MZ) 80 CONTINUE C WRITE(6,*) MY,MX,N1,L1,VSHELL(1),RAC,AND,RAD(NRANG2) 90 CONTINUE 100 CONTINUE IF (IBUG9.LT.2) GOTO 130 DO 120 K = 1,NNCHAN WRITE (IWRITE,3020) K KAB11 = NRANG2* (K-1) DO 110 I = 1,NRANG2 WRITE (IWRITE,3010) I, (HLS(KAB11+I,J),J=1,NCFGP) 110 CONTINUE WRITE (IWRITE,3010) 120 CONTINUE 130 CONTINUE C 3000 FORMAT ( A' **ERROR ONE INTERACTING ELECTRON SHOULD BE BOUND THE OT BHER SHOULD BE CONTINUUM**') 3010 FORMAT (I5, (T6,9F14.7)) 3020 FORMAT (//5X, A' BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN MATRIX FROM CHANNE BL',I3/) END C C C SUBROUTINE SPINCB(MI,RAC) use big1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALCULATES THE CONTINUUM-BOUND SPIN-ORBIT C INTERACTION WHERE THE CONTINUUM TERMS ARE ASSOCIATED WITH C (LRGL,NSPN) AND THE BOUND TERMS ARE ASSOCIATED WITH (LLRGL,NNSPN) C MI = POSITION OF LRGL,NSPN IN /ALPHA/ ARRAYS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXOCC1=MZOCC+1) PARAMETER (MXOCC2=2*MZOCC+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXORB3=2*MXORB+3) PARAMETER (MXNCF=MZTAR) C DIMENSION RAD(MZNR2) C COMMON /ALPHA/LL(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /BNDINI/MCFGP,JOCCSH(MZNC2),JOCORB(MZOCC,MZNC2), A JELCSH(MZOCC,MZNC2),L1QNRD(MXOC21,3,MZNC2) COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH 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 /SHELL/VSHELL(MXORB2) 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----------------------------------------------------------------------- ZERO = 0.0D0 LRGL = LL(MI) NSPN = LS(MI) NCHAN = LCH(MI) C C INITIALISE THE LSJ-HAMILTONIAN MATRIX BLOCKS C DO 20 J = 1,NRANG2*NCHAN DO 10 I = 1,MCFGP HLS(I,J) = 0.0D0 10 CONTINUE 20 CONTINUE C C INITIALISE THE PARAMETERS USED IN TENSOR C KA = 1 ISPIN = 2 C C SET UP THE BOUND CONFIGURATIONS IN /MSTATE/ C DO 60 I = 1,MCFGP IL = JOCCSH(I) KOCCSH(I) = IL ILL = 2*IL - 1 DO 30 J = 1,IL KOCORB(J,I) = JOCORB(J,I) KELCSH(J,I) = JELCSH(J,I) 30 CONTINUE DO 50 K = 1,3 DO 40 J = 1,ILL K1QNRD(J,K,I) = L1QNRD(J,K,I) 40 CONTINUE 50 CONTINUE 60 CONTINUE DO 100 MX = 1,NCHAN KAB11 = NRANG2* (MX-1) C C THE CONTINUUM ELECTRON MUST BE AN INTERACTING ELECTRON, C CHECK IF ITS ANGULAR MOMENTUM IS ZERO. IF IT IS THERE IS C NO SPIN-ORBIT CONTRIBUTION C L3 = L2P(MX) IF (L3.EQ.0) GOTO 100 I1 = LSTARG(MX) I3 = NTYP(I1,1) C C SET UP THE CONTINUUM CONFIGURATION ON THE L.H.S. C CALL SETL(LRGL,NSPN,I3,L3) DO 90 MY = 1,MCFGP IRHO = 0 ISIG = 0 C C CALL SETUPE AND TENSOR TO DETERMINE THE ANGULAR CONTRIBUTION C CALL SETUPE(I3,MY,NJCOMP,LJCOMP) CALL TENSOR(KA,ISPIN,IRHO,ISIG,VSHELL) C C IF IRHO=0 AND ISIG=0 THERE IS NO CONTRIBUTION C IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 90 N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) C C CHECK THAT N2 IS BOUND AND N1 IS CONTINUUM C LX = L2 + 1 IF (N1.EQ.998 .AND. N2.LE.MAXNHF(LX)) GOTO 70 WRITE (IWRITE,3000) STOP C C IF L1.NE.L2 THERE IS NO SPIN-ORBIT CONTRIBUTION C 70 CONTINUE IF (L1.NE.L2 .OR. VSHELL(1).EQ.ZERO) GOTO 90 ANG = RAC*SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(1) CALL FINBCR(N2,NRANG2,L1,RAD) DO 80 MZ = 1,NRANG2 HLS(MY,KAB11+MZ) = ANG*RAD(MZ) 80 CONTINUE C WRITE(6,*) MY,MX,N2,L1,VSHELL(1),RAC,ANG,RAD(NRANG2) 90 CONTINUE 100 CONTINUE IF (IBUG9.LT.2) GOTO 130 DO 120 K = 1,NCHAN KAB11 = NRANG2* (K-1) WRITE (IWRITE,3020) K DO 110 I = 1,NRANG2 WRITE (IWRITE,3010) I, (HLS(J,KAB11+I),J=1,MCFGP) 110 CONTINUE WRITE (IWRITE,3010) 120 CONTINUE 130 CONTINUE C 3000 FORMAT ( A' **ERROR ONE INTERACTING ELECTRON SHOULD BE BOUND THE OT BHER SHOULD BE CONTINUUM**') 3010 FORMAT (I5, (T6,9F14.7)) 3020 FORMAT (//6X, A'CONTINUUM-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM CHANNE BL',I3/) END C C C SUBROUTINE SPINCC(MI,MJ,RAC) use big1 IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C CALCULATES THE SPIN-ORBIT INTERACTION FOR A C CONTINUUM-CONTINUUM LSJ-HAMILTONIAN BLOCK BETWEEN TWO SYMMETRIES C (LRGL,NSPN) AND (LLRGL,NNSPN). C MI,MJ = POSITIONS OF (LRGL,NSPN),(LLRGL,NNSPN) IN /ALPHA/. C C NOTE THAT EACH SQUARE CHANNEL BLOCK IS SYMMETRIC I.E. C HLS(IL,JL,IBLOC)=HLS(JL,IL,IBLOC) C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXOCC1=MZOCC+1) PARAMETER (MXOCC2=2*MZOCC+1) PARAMETER (MXOC21=2*MZOCC-1) PARAMETER (MXORB=(MZLR1*(2*MZNR1-MZLR1+1))/2) PARAMETER (MXORB2=MXORB+2) PARAMETER (MXORB3=2*MXORB+3) PARAMETER (MXNCF=MZTAR) C LOGICAL SAME C DIMENSION RAD(MZNR2) C COMMON /ALPHA/LL(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) COMMON /CHANI/LL2P(MZCHL),MSTARG(MZCHL) COMMON /DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8, A IBUG9 COMMON /INFORM/IREAD,IWRITE,IPUNCH 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 /SHELL/VSHELL(MXORB2) 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----------------------------------------------------------------------- ZERO = 0.0D0 LRGL = LL(MI) NSPN = LS(MI) NCHAN = LCH(MI) LLRGL = LL(MJ) NNSPN = LS(MJ) NNCHAN = LCH(MJ) SAME = MI .EQ. MJ C C INITIALISE THE LSJ-HAMILTONIAN MATRIX BLOCKS. C DO 20 K2 = 1,NRANG2*NCHAN DO 10 K1 = 1,NRANG2*NNCHAN HLS(K1,K2) = 0.0D0 10 CONTINUE 20 CONTINUE C C INITIALISE THE PARAMETERS USED IN TENSOR. C KA = 1 ISPIN = 2 IBLOC = 0 C C LOOP OVER THE LOWER-HALF IF THIS IS A DIAGONAL BLOCK, C OTHERWISE LOOP OVER THE WHOLE BLOCK. C DO 150 MX = 1,NCHAN MY = NNCHAN L3 = L2P(MX) I1 = LSTARG(MX) I3 = NTYP(I1,1) C C SETUP THE CONFIGURATION ON THE L.H.S. C CALL SETL(LRGL,NSPN,I3,L3) C C IF MI=MJ THIS IS A DIAGONAL BLOCK I.E. LRGL=LLRGL, C NSPN=NNSPN ,THUS WE NEED ONLY CALCULATE THE LOWER-HALF. C IF (SAME) MY = MX DO 140 MZ = 1,MY IBLOC = IBLOC + 1 L4 = LL2P(MZ) C C IF(L3.NE.L4) THERE IS NO CONTRIBUTION FROM THE C SPIN-ORBIT INTERACTION C IF (L3.NE.L4) GOTO 140 I2 = MSTARG(MZ) I4 = NTYP(I2,1) KAB11 = NRANG2* (MZ-1) KAB12 = NRANG2* (MX-1) C C SETUP THE CONFIGURATION ON THE R.H.S. C CALL SETR(LLRGL,NNSPN,I4,L4) C C FIRST CONSIDER THE OFF DIAGONAL ELEMENTS. C CHECK IF ANGULAR MOMENTA OF THE INTERACTING ELECTRONS ARE ZERO C IF (L3.EQ.0) GOTO 60 C C SETUPE AND TENSOR ARE CALLED TO EVALUATE THE ANGULAR C COEFFICIENT. C IRHO = 0 ISIG = 0 CALL SETUPE(I3,I4,NJCOMP,LJCOMP) CALL TENSOR(KA,ISPIN,IRHO,ISIG,VSHELL) C C IF IRHO=0 AND ISIG=0 THERE IS NO CONTRIBUTION C IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 60 N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) C C CHECK THAT THE INTERACTING ELECTRONS ARE BOTH CONTINUUM C ELECTRONS. C IF ((N1.EQ.998.AND.N2.EQ.999) .AND. A (L1.EQ.L3.AND.L2.EQ.L4)) GOTO 30 WRITE (IWRITE,3000) STOP C 30 CONTINUE ANG = RAC*SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(1) IF (NRANG2.LE.1) GOTO 60 DO 50 N1 = 2,NRANG2 CALL FINCCR(N1,N1,L1,RAD) IF (IBUG9.GT.0) WRITE (IWRITE,3040) ANG,RAD(1),N1,N2,L1,L2, A ISPIN DO 40 N2 = 1,N1 - 1 HLS(KAB11+N1,KAB12+N2) = ANG*RAD(N2) HLS(KAB11+N2,KAB12+N1) = ANG*RAD(N2) 40 CONTINUE 50 CONTINUE C C NOW CONSIDER THE DIAGONAL CASE C 60 CONTINUE MAXOR = MAXORB + 1 IOC = NOCCSH(I4) + 1 KOCORB(IOC,I4) = MAXOR C C SETUPE AND TENSOR ARE CALLED TO EVALUATE THE ANGULAR COEFFICIENT C IRHO = 0 ISIG = 0 CALL SETUPE(I3,I4,NJCOMP,LJCOMP) CALL TENSOR(KA,ISPIN,IRHO,ISIG,VSHELL) C C IF IRHO=0 AND ISIG=0 THERE IS NO CONTRIBUTION C IF (IRHO.EQ.0 .AND. ISIG.EQ.0) GOTO 140 IF (IRHO.EQ.ISIG) GOTO 90 C C THE INTERACTING ELECTRONS ARE UNIQUELY DEFINED. C THE INTERACTING ELECTRONS MUST BE BOUND C N1 = NJ(IRHO) L1 = LJ(IRHO) N2 = NJ(ISIG) L2 = LJ(ISIG) IF (L1.NE.L2 .OR. L1.EQ.0) GOTO 140 C C CHECK THAT THE INTERACTING ELECTRONS ARE INDEED BOUND C LX = L1 + 1 IF (N1.LE.MAXNHF(LX) .AND. N2.LE.MAXNHF(LX)) GOTO 70 WRITE (IWRITE,3050) STOP C 70 CONTINUE ANG = RAC*SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(1) CALL FINBBR(N1,N2,L1,RAD(1)) IF (IBUG9.GT.0) WRITE (IWRITE,3040) ANG,RAD(1),N1,N2,LX,IRHO DO 80 N3 = 1,NRANG2 HLS(KAB11+N3,KAB12+N3) = ANG*RAD(1) 80 CONTINUE GOTO 140 C C CONFIGURATIONS ARE IDENTICAL. THEREFORE SUM OVER THE C INTERACTING SHELLS C 90 CONTINUE SUM = 0.0D0 DO 120 IL = 1,IHSH N1 = NJ(IL) L1 = LJ(IL) IF (L1.EQ.0 .OR. VSHELL(IL).EQ.ZERO) GOTO 120 ANG = RAC*SQRT(DBLE((3*L1* (L1+1)* (2*L1+1))/2)) A *VSHELL(IL) IF (N1.EQ.998) GOTO 100 C C INTERACTING SUBSHELL IS BOUND C CALL FINBBR(N1,N1,L1,RAD(1)) IF (IBUG9.GT.0) WRITE (IWRITE,3040) ANG,RAD(1),N1,N2,IL SUM = SUM + ANG*RAD(1) GOTO 120 C C INTERACTING SUBSHELL IS CONTINUUM C 100 CONTINUE DO 110 JL = 1,NRANG2 CALL FINCCR(JL,1,L1,RAD) HLS(KAB11+JL,KAB12+JL) = ANG*RAD(1) 110 CONTINUE 120 CONTINUE DO 130 IL = 1,NRANG2 HLS(KAB11+IL,KAB12+IL) = HLS(KAB11+IL,KAB12+IL) + SUM 130 CONTINUE C 140 CONTINUE 150 CONTINUE C C WRITE OUT THE CONTINUUM-CONTINUUM LSJ SPIN-ORBIT MATRIX BLOCKS. C MATRIX BLOCKS. C IBLOC = 0 KK1 = LRGL/2 KK2 = NSPN + 1 KK3 = LLRGL/2 KK4 = NNSPN + 1 IF (IBUG9.GT.0) WRITE (IWRITE,3010) KK1,KK2,KK3,KK4 IF (IBUG9.LT.3) GOTO 190 DO 180 MX = 1,NCHAN MY = NNCHAN IF (SAME) MY = MX KAB12 = (MX-1)*NRANG2 DO 170 MZ = 1,MY IBLOC = IBLOC + 1 WRITE (IWRITE,3020) MX,MZ KAB11 = (MZ-1)*NRANG2 DO 160 I1 = 1,NRANG2 WRITE (IWRITE,3030) I1, (HLS(KAB11+I1,KAB12+J1),J1=1,NRANG2) 160 CONTINUE WRITE (IWRITE,3030) 170 CONTINUE 180 CONTINUE 190 CONTINUE C 3000 FORMAT ( A ' **ERROR INTERACTING ELECTRONS ARE NOT CONTINUUM ELECTRONS**' B ) 3010 FORMAT (/10X,'SPIN-ORBIT MATRIX FOR LRGL =',I3,', NSPN =',I3, A ', LLRGL =',I3,', NNSPN =',I3/11X,21 ('-')) 3020 FORMAT (/' CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN MATRIX' A ,' FROM CHANNELS',I3,' AND',I3/) 3030 FORMAT (I5, (T6,9F14.7)) 3040 FORMAT (/' CONTRIBUTION',2E15.6,5I5) 3050 FORMAT (' **ERROR: INTERACTING ELECTRONS ARE NOT BOUND**') END C C C SUBROUTINE SPINOR(JPOS) use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KINDEXBIG,KINDEX2,KMEM,KREC1,KREC2,KAB28,I8,MXMEM8 C C C C----------------------------------------------------------------------- C C CALCULATES THE SPIN-ORBIT INTERACTION IN AN LSJ-COUPLING SCHEME C AND THEN RECOUPLES TO A PAIR COUPLING SCHEME. THE RESULTING C MATRIX IS ADDED TO THE PREVIOUSLY CALCULATED J-HAMILTONIAN MATRIX C C JPOS = POSITION OF CURRENT J SYMMETRY IN THE /ALPHAJ/ ARRAYS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLSJ=20) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXOC21=2*MZOCC-1) C COMMON /ALPHA/L2(MZSLP),LS(MZSLP),LP(MZSLP), A LCH(MZSLP),LCFG(MZSLP) COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /BNDBOX/LCFBOX(MXLSJ),LOCCSH(MZNC2),LOCORB(MZOCC,MZNC2), A LELCSH(MZOCC,MZNC2),N1QNRD(MXOC21,3,MZNC2) 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 COMMON /CHAN/L2P(MZCHL),LSTARG(MZCHL) COMMON /CHANI/LL2P(MZCHL),MSTARG(MZCHL) COMMON /CHBOX/L2PBOX(MZCHL,MXLSJ),LSTBOX(MZCHL,MXLSJ) 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 /JCHAN/LJP(MZCHF),KJ(MZCHF),JTARG(MZCHF) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /POTORB/PV(MXJC3),PPV(MXJC3),ICHAN(MXJC3),MCHAN(MXJC3), A NTERM(MZCHF),NNTERM(MZCHF) C DATA ZERO/0.0D0/,ITWO/2/ C----------------------------------------------------------------------- MXMEM8 = MXMEM WRITE (IWRITE,3000) JRGL = J2(JPOS) JNPTY = JP(JPOS) NJCHA = JCH(JPOS) ICOUNT = JCOUNT(JPOS) IBNDL = 0 IADD = 1 KAB1 = NRANG2*NJCHA KAB2 = NRANG2*NRANG2 C C LOOP ROUND THE LOWER HALF OF THE LSJ-HAMILTONIAN MATRIX C AND CALCULATE THE BLOCKS ONE AT A TIME. NOTE THAT THESE C BLOCKS ARE NOT DIAGONAL IN LS. C DO 510 MI = 1,INAST IBNDR = 0 LRGL = L2(MI) NSPN = LS(MI) NPTY = LP(MI) NCHAN = LCH(MI) NCFGP = LCFG(MI) IF (LSJTRI(LRGL,NSPN,NPTY,JRGL,JNPTY).EQ.0) GOTO 510 C C COPY LS CHANNEL AND CONFIGURATION DATA FROM /CHBOX/ AND /BNDBOX/ C AND RECOUPLING DATA FROM IDISC1 C DO 10 I = 1,NCHAN L2P(I) = L2PBOX(I,IADD) LSTARG(I) = LSTBOX(I,IADD) 10 CONTINUE IF (NCFGP.GT.0) THEN DO 40 I = 1,NCFGP II = LCFBOX(IADD) + I IOCCSH(I) = LOCCSH(II) DO 20 J = 1,LOCCSH(II) IOCORB(J,I) = LOCORB(J,II) IELCSH(J,I) = LELCSH(J,II) 20 CONTINUE ILL = 2*LOCCSH(II) - 1 DO 30 J = 1,ILL I1QNRD(J,1,I) = N1QNRD(J,1,II) I1QNRD(J,2,I) = N1QNRD(J,2,II) I1QNRD(J,3,I) = N1QNRD(J,3,II) 30 CONTINUE 40 CONTINUE ENDIF C CALL DAFILA(1,MI,LRGL,JRGL,NJCHA,NTERM,NTERMI,ICHAN,PV) JADD = 1 DO 500 MJ = 1,MI C C READ THE DATA DEFINING THE RIGHT HAND SIDE OF THE C MATRIX ELEMENTS C LLRGL = L2(MJ) NNSPN = LS(MJ) NNPTY = LP(MJ) NNCHAN = LCH(MJ) MCFGP = LCFG(MJ) IF (LSJTRI(LLRGL,NNSPN,NNPTY,JRGL,JNPTY).EQ.0) GOTO 500 C C CHECK IF THE RACAH COEFFICIENT IS ZERO: IF IT IS THERE C IS NO CONTRIBUTION FROM THE SPIN-ORBIT TO THIS BLOCK C CALL DRACAH(LRGL,LLRGL,NSPN,NNSPN,ITWO,JRGL,RAC) RAC = (-1)** (ABS((LRGL+NNSPN-JRGL)/2)+2)*RAC IF (IBUG8.GT.0) WRITE (IWRITE, A *) ' SPIN-ORBIT CONTRIBUTION FROM ',LRGL,NSPN,NPTY,'/', B LLRGL,NNSPN,NNPTY,' RAC = ',RAC IF (RAC.EQ.ZERO) GOTO 490 C C COPY LS CHANNEL AND CONFIGURATION DATA FROM /CHBOX/ AND /BNDBOX/ C AND RECOUPLING DATA FROM IDISC2 C DO 50 I = 1,NNCHAN LL2P(I) = L2PBOX(I,JADD) MSTARG(I) = LSTBOX(I,JADD) 50 CONTINUE IF (MCFGP.GT.0) THEN DO 80 I = 1,MCFGP II = LCFBOX(JADD) + I JOCCSH(I) = LOCCSH(II) DO 60 J = 1,LOCCSH(II) JOCORB(J,I) = LOCORB(J,II) JELCSH(J,I) = LELCSH(J,II) 60 CONTINUE ILL = 2*LOCCSH(II) - 1 DO 70 J = 1,ILL L1QNRD(J,1,I) = N1QNRD(J,1,II) L1QNRD(J,2,I) = N1QNRD(J,2,II) L1QNRD(J,3,I) = N1QNRD(J,3,II) 70 CONTINUE 80 CONTINUE ENDIF C CALL DAFILA(1,MJ,LLRGL,JRGL,NJCHA,NNTERM,NTERMI,MCHAN,PPV) C C CALCULATE THE SPIN-ORBIT INTERACTION FOR THE CONTINUUM-CONTINUUM C BLOCKS. C CALL SPINCC(MI,MJ,RAC) C C NOW RECOUPLE THE LSJ CONTINUUM-CONTINUUM BLOCKS TO PAIR-COULPING C C IF (MI.NE.MJ) GOTO 180 C C THIS IS A DIAGONAL BLOCK I.E. LRGL=LLRGL,NSPN=NNSPN C I2 = 0 KMEM = MEM1 KREC1 = 1 DO 170 I = 1,NJCHA KREC2 = KREC1 NTERM1 = NTERM(I) IF (NTERM1.EQ.0) THEN KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(0,KREC1,IDISC2,KAB2*I, A HJ) GOTO 160 C ENDIF C KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) J1 = 0 DO 150 J = 1,I NTERM2 = NNTERM(J) IF (NTERM2.EQ.0) GOTO 140 C C IF THE TWO CONTINUUM ELECTRONS DIFFER IN ANGULAR MOMENTA C THERE IS NO CONTRIBUTION FROM THE SPIN-ORBIT INTERACTION C IF (LJP(I).NE.LJP(J)) GOTO 140 DO 130 IM = 1,NTERM1 DO 120 JM = 1,NTERM2 KAB12 = (MIN(MCHAN(JM+J1),ICHAN(IM+I2))-1)*NRANG2 KAB13 = (MAX(MCHAN(JM+J1),ICHAN(IM+I2))-1)*NRANG2 SUM = PV(IM+I2)*PPV(JM+J1) DO 110 JL = 1,NRANG2 KAB11 = ((J-1)*NRANG2+JL-1)*NRANG2 KAB28=KAB2 I8=I ICPB1=KAB12+JL IF (KMEM+KAB28*I8.GT.MXMEM8) THEN DO 90 IL = 1,NRANG2 HJ(KAB11+IL) = HJ(KAB11+IL) + A SUM*HLS(ICPB1,KAB13+IL) 90 CONTINUE C ELSE KMEM1 = KMEM + KAB11 DO 100 IL = 1,NRANG2 ARRAY(KMEM1+IL) = ARRAY(KMEM1+IL) + A SUM*HLS(ICPB1,KAB13+IL) 100 CONTINUE ENDIF C 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 J1 = J1 + NTERM2 150 CONTINUE KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(2,KREC2,IDISC2,KAB2*I,HJ) 160 CONTINUE KMEM = KMEM + KAB2*I I2 = I2 + NTERM1 170 CONTINUE GOTO 340 C C THIS IS AN OFF DIAGONAL BLOC. C I.E. LRGL.NE.LLRGL, NSPN.NE.NNSPN C FIRST CONSIDER (LRGL,NSPN) ON THE L.H.S. AND (LLRGL,NNSPN) C ON THE R.H.S. C 180 CONTINUE I2 = 0 I22 = 0 KMEM = MEM1 KREC1 = 1 DO 330 I = 1,NJCHA KREC2 = KREC1 C IF(NTERM(I-1).EQ.0.AND.NNTERM(I-1).EQ.0) THEN C CORRECTED BY ADRIAN BOONE (<90MAY15 - TRIPLET FACTOR 3...!) TO IF (NTERM(I).EQ.0 .AND. NNTERM(I).EQ.0) THEN KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(0,KREC1,IDISC2,KAB2*I, A HJ) GOTO 320 C ENDIF C KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) J1 = 0 J11 = 0 DO 310 J = 1,I C C IF THE TWO CONTINUUM ELECTRONS DIFFER IN ANGULAR MOMENTA C THERE IS NO CONTRIBUTION FROM THE SPIN-ORBIT INTERACTION C IF (LJP(I).NE.LJP(J)) GOTO 300 IF (NTERM(I).EQ.0 .OR. NNTERM(J).EQ.0) GOTO 240 DO 230 IM = 1,NTERM(I) KAB13 = (ICHAN(IM+I2)-1)*NRANG2 DO 220 JM = 1,NNTERM(J) SUM = PV(IM+I2)*PPV(JM+J1) KAB12 = (MCHAN(JM+J1)-1)*NRANG2 DO 210 JL = 1,NRANG2 KAB11 = ((J-1)*NRANG2+JL-1)*NRANG2 KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 ICPB2=KAB12+JL IF (KINDEXBIG.GT.MXMEM8) THEN DO 190 IL = 1,NRANG2 HJ(KAB11+IL) = HJ(KAB11+IL) + A SUM*HLS(ICPB2,KAB13+IL) 190 CONTINUE C ELSE KMEM1 = KMEM + KAB11 DO 200 IL = 1,NRANG2 ARRAY(KMEM1+IL) = ARRAY(KMEM1+IL) + A SUM*HLS(ICPB2,KAB13+IL) 200 CONTINUE ENDIF C 210 CONTINUE 220 CONTINUE 230 CONTINUE C C NOW CONSIDER (LLRGL,NNSPN) ON THE L.H.S. AND (LRGL,NSPN) ON C THE R.H.S. C 240 CONTINUE IF (NNTERM(I).EQ.0 .OR. NTERM(J).EQ.0) GOTO 300 DO 290 IM = 1,NNTERM(I) KAB12 = (MCHAN(IM+I22)-1)*NRANG2 DO 280 JM = 1,NTERM(J) C C MUST USE TRANSPOSE OF MATRIX IN THIS CASE C BUT NOTE THAT HLS IS ACTUALLY SYMMETRIC C SUM = PPV(IM+I22)*PV(JM+J11) KAB13 = (ICHAN(JM+J11)-1)*NRANG2 DO 270 JL = 1,NRANG2 KAB11 = ((J-1)*NRANG2+JL-1)*NRANG2 KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 ICPB3=KAB13+JL IF (KINDEXBIG.GT.MXMEM8) THEN DO 250 IL = 1,NRANG2 HJ(KAB11+IL) = HJ(KAB11+IL) + A SUM*HLS(KAB12+IL,ICPB3) 250 CONTINUE C ELSE KMEM1 = KMEM + KAB11 DO 260 IL = 1,NRANG2 ARRAY(KMEM1+IL) = ARRAY(KMEM1+IL) + A SUM*HLS(KAB12+IL,ICPB3) 260 CONTINUE ENDIF C 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE J1 = J1 + NNTERM(J) J11 = J11 + NTERM(J) 310 CONTINUE KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(2,KREC2,IDISC2,KAB2*I,HJ) C 320 CONTINUE I2 = I2 + NTERM(I) KMEM = KMEM + KAB2*I I22 = I22 + NNTERM(I) 330 CONTINUE C C CALCULATE THE SPIN-ORBIT INTERACTION FOR THE BOUND-CONTINUUM C MATRIX BLOCKS C 340 CONTINUE IF (NCFGP.EQ.0) GOTO 400 CALL SPINBC(MJ,RAC) C C RECOUPLE THE BOUND-CONTINUUM LSJ SPIN-ORBIT MATRIX BLOCKS C IFIN = IBNDL + NCFGP I2 = 0 INIT = IBNDL + 1 DO 390 K = 1,NJCHA NTERM1 = NNTERM(K) C C CHECK IF THE INTERACTING CONTINUUM ELECTRON HAS ZERO ORBITAL C ANGULAR MOMENTUM C IF (NTERM1.EQ.0 .OR. LJP(K).EQ.0) GOTO 380 MPOS = 0 DO 370 J = INIT,IFIN MPOS = MPOS + 1 KAB21 = ((J-1)*NJCHA+K-1)*NRANG2 DO 360 K1 = 1,NTERM1 SUM = PPV(K1+I2) KAB11 = (MCHAN(K1+I2)-1)*NRANG2 DO 350 I = 1,NRANG2 HJBC(KAB21+I) = HJBC(KAB21+I) + SUM*HLS(KAB11+I,MPOS) 350 CONTINUE 360 CONTINUE 370 CONTINUE 380 I2 = I2 + NTERM1 390 CONTINUE C C CALCULATE THE SPIN-ORBIT INTERACTION FOR THE CONTINUUM-BOUND C MATRIX BLOCKS C IF (MI.EQ.MJ) GOTO 460 400 CONTINUE IF (MCFGP.EQ.0) GOTO 460 CALL SPINCB(MI,RAC) C C RECOUPLE THE CONTINUUM-BOUND LSJ SPIN-ORBIT MATRIX BLOCKS C IFIN = IBNDR + MCFGP I2 = 0 INIT = IBNDR + 1 DO 450 K = 1,NJCHA NTERM1 = NTERM(K) C C CHECK THAT THE INTERACTING CONTINUUM ELECTRON HAS ZERO ORBITAL C ANGULAR MOMENTUM C IF (NTERM1.EQ.0 .OR. LJP(K).EQ.0) GOTO 440 MPOS = 0 DO 430 J = INIT,IFIN MPOS = MPOS + 1 KAB21 = ((J-1)*NJCHA+K-1)*NRANG2 DO 420 K1 = 1,NTERM1 SUM = PV(K1+I2) KAB11 = NRANG2* (ICHAN(K1+I2)-1) DO 410 I = 1,NRANG2 HJBC(KAB21+I) = HJBC(KAB21+I) + SUM*HLS(MPOS,KAB11+I) 410 CONTINUE 420 CONTINUE 430 CONTINUE 440 I2 = I2 + NTERM1 450 CONTINUE C C CALCULATE THE SPIN-ORBIT INTERACTION FOR THE BOUND-BOUND C MATRIX BLOCKS C 460 CONTINUE IF (NCFGP.EQ.0 .OR. MCFGP.EQ.0) GOTO 490 CALL SPINBB(MI,MJ) DO 480 J = 1,NCFGP DO 470 I = 1,MCFGP HJBB(I+IBNDR,J+IBNDL) = HLS(I,J)*RAC + A HJBB(I+IBNDR,J+IBNDL) 470 CONTINUE 480 CONTINUE 490 CONTINUE IBNDR = IBNDR + MCFGP JADD = JADD + 1 500 CONTINUE C IBNDL = IBNDL + NCFGP IF (IADD.GE.ICOUNT) GOTO 520 IADD = IADD + 1 510 CONTINUE C C PRINT THE J-HAMILTONIAN BLOCKS INCLUDING THE SPIN-ORBIT C INTERACTION. C 520 CONTINUE IF (IBUG8.GT.0) WRITE (IWRITE,3050) IF (IBUG8.LT.3) GOTO 570 KMEM = MEM1 KREC1 = 1 DO 560 I = 1,NJCHA KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) DO 550 J = 1,I WRITE (IWRITE,3060) I,J JUP = 0 530 CONTINUE JLO = JUP + 1 JUP = MIN(JUP+8,NRANG2) DO 540 I1 = 1,NRANG2 KAB11 = ((J-1)*NRANG2+I1-1)*NRANG2 KAB28=KAB2 I8=I KINDEXBIG=KMEM+KAB28*I8 IF (KINDEXBIG.GT.MXMEM8) THEN WRITE (IWRITE,3070) (HJ(KAB11+J1),J1=JLO,JUP) C ELSE WRITE (IWRITE,3070) (ARRAY(KMEM+KAB11+J1),J1=JLO,JUP) ENDIF C 540 CONTINUE WRITE (IWRITE,3070) IF (JUP.LT.NRANG2) GOTO 530 550 CONTINUE KAB28=KAB2 I8=I KMEM = KMEM + KAB28*I8 560 CONTINUE 570 CONTINUE IF (IBUG8.LT.2) GOTO 610 IF (IBNDL.EQ.0) GOTO 630 DO 600 K = 1,NJCHA WRITE (IWRITE,3030) K JUP = 0 580 CONTINUE JLO = JUP + 1 JUP = MIN(JUP+8,IBNDL) DO 590 I = 1,NRANG2 KAB21 = (K-1-NJCHA)*NRANG2 + I WRITE (IWRITE,3070) (HJBC(KAB21+J*KAB1),J=JLO,JUP) 590 CONTINUE WRITE (IWRITE,3070) IF (JUP.LT.IBNDL) GOTO 580 600 CONTINUE 610 CONTINUE IF (IBUG8.LE.0 .OR. IBNDL.EQ.0) GOTO 630 DO 620 I = 1,IBNDL WRITE (IWRITE,3040) I, (HJBB(I,J),J=I,IBNDL) 620 CONTINUE 630 CONTINUE WRITE (IWRITE,3020) C 3000 FORMAT (/52X,'SUBROUTINE SPINOR'/52X,17 ('-')) 3020 FORMAT (/'SPIN-ORBIT INTERACTION INCLUDED') 3030 FORMAT (//6X,'BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3/) 3040 FORMAT (/6X,'BOUND-BOUND CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CONFIGURATION',I3/ (8F14.7)) 3050 FORMAT (/11X, A'TRANSFORMED HAMILTONIAN MATRICES INCLUDING THE SPIN -ORBIT INTER BACTION'/11X,69 ('-')) 3060 FORMAT (//6X,'CONTINUUM-CONTINUUM CONTRIBUTION TO HAMILTONIAN', A ' MATRIX FROM CHANNEL',I3,' AND CHANNEL',I3/) 3070 FORMAT (8F14.7) END C C C SUBROUTINE TCCOUT IMPLICIT REAL*8 (A-H,O-Z) C----------------------------------------------------------------------- C C TO PRINT OUT LS-TERMS AND ENERGIES, J-LEVELS AND ENERGIES, C AND TERM COUPLING COEFFICIENTS BETWEEN THE TWO C BOTH LS TERMS AND J-LEVELS ARE ENERGY ORDERED C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXJC=MZCHF*MZCHL) PARAMETER (MXNCF=MZTAR) PARAMETER (MXTCC=100*MXNCF+MXJC) PARAMETER (MXTDW=MZLR1*MXTCC) C COMMON /DWTCC/X(MXNCF),EIG(MXNCF),LORD(MXNCF),LVEC(MZTAR), C AUX(MXNCF,9),JDW(MXTDW),LDW(MXTDW),TCC(MXTDW),MTCC C COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /STATE/ENAT(MZTAR),LAT(MZTAR),ISAT(MZTAR),LPTY(MZTAR),NAST C DIMENSION LORD2(MXNCF),JORD(MZTAR),JORD2(MZTAR) DIMENSION LTCC(MXNCF),TCC2(MXNCF),EEE(MXNCF) C----------------------------------------------------------------------- C IF (MTCC.GT.MXTDW) CALL RECOV2('TCCOUT','MXTDW ',MXTDW,MTCC) C OPEN (UNIT=77,FILE='TCCDW.DAT',STATUS='UNKNOWN',FORM='FORMATTED') C CALL ORDER(ENAT,LORD2,NAST,1) C WRITE(77,100)NAST WRITE(77,*)' TERM 2S+1 L PI ENERGY(RYD)', X ' ORIG. TERM #' C DO 10 I=1,NAST J=LORD2(I) E=2.D0*(ENAT(J)-ENAT(LORD2(1))) WRITE(77,200)I,ISAT(J),LAT(J),LPTY(J),E,J 10 CONTINUE C CALL ORDER(ENATJ,JORD2,JNAST,1) C DO 11 I=1,JNAST JORD(JORD2(I))=I 11 CONTINUE C WRITE(77,300)JNAST WRITE(77,*)' LEVEL 2J PI ENERGY(RYD)', X ' ORIG. LEVEL #' C DO 20 I=1,JNAST J=JORD2(I) E=2.D0*(ENATJ(J)-ENATJ(JORD2(1))) WRITE(77,400)I,JJ(J),JPTY(J),E,J 20 CONTINUE C WRITE(77,*) WRITE(77,*)' RECOUPLING MATRIX: ROWS ARE J LEVELS, COLUMNS ARE', X ' LS TERMS' WRITE(77,*) WRITE(77,*)'LEVEL # LS TERM #S/COEFFICIENTS' C DO 30 I=1,JNAST M=0 DO 31 J=1,MTCC IF(JORD(JDW(J)).EQ.I)THEN M=M+1 LTCC(M)=LORD(LDW(J)) EEE(M)=LTCC(M) TCC2(M)=TCC(J) ENDIF 31 CONTINUE C CALL ORDER(EEE,JORD2,M,1) C IF(M.LE.4) THEN WRITE(77,500)I,M,(LTCC(JORD2(J)),TCC2(JORD2(J)),J=1,M) ELSE WRITE(77,500)I,M,(LTCC(JORD2(J)),TCC2(JORD2(J)),J=1,4) JMIN=1 28 JMIN=JMIN+4 JMAX=JMIN+3 IF(JMAX.GT.M) JMAX=M WRITE(77,501) (LTCC(JORD2(J)),TCC2(JORD2(J)),J=JMIN,JMAX) IF(JMAX.LT.M) GO TO 28 END IF C 30 CONTINUE C CLOSE(77) C 100 FORMAT(I5,' LS TERMS ',/) 200 FORMAT(4I7,F16.7,I15) 300 FORMAT(/,I5,' J LEVELS',/) 400 FORMAT(3I7,F16.7,I15) 500 FORMAT(/2I5,4(I5,F18.14)) 501 FORMAT(10X,4(I5,F18.14)) RETURN END C C C SUBROUTINE WRIT3(JPOS) use big1 IMPLICIT REAL*8 (A-H,O-Z) INTEGER*8 KINDEXBIG,KINDEX2,KMEM,KREC1,KREC2 C C C C----------------------------------------------------------------------- C C WRITES OUT THE TRANSFORMED HAMILTONIAN MATRICES AND LONG-RANGE C POTENTIAL COEFFICIENTS TO THE PERMANENT OUTPUT FILE ITAPE3. C C JPOS = POSITION OF CURRENT J SYMMETRY IN THE /ALPHAJ/ ARRAYS. C C----------------------------------------------------------------------- C INCLUDE 'PARAM' C PARAMETER (MXX1=MZCHF*MZNR2*MZNR2) PARAMETER (MXX2=(MZTAR*(MZTAR+1))/2) PARAMETER(MXD1=MXX1/MXX2,MXD2=MXX2/MXX1, A MXD3=MXD1+MXD2, B MXHJ=MXX1*MXD1/MXD3+MXX2*MXD2/MXD3+1) PARAMETER (MXHBC=MZCHF*MZNR2*MZNC2) C PARAMETER (MXHLS=MZCHL*MZNR2+MZNC3) PARAMETER (MXDUM1=1+ MZIPH*MXHBC) PARAMETER (MXJC3=10*MZCHF*MZCHL) PARAMETER (MXLM0=MZLMX/4) PARAMETER (MXLM1=4/MZLMX) PARAMETER (MXLM2=MXLM0+MXLM1) PARAMETER (MXLM3=MZLMX*MXLM0/MXLM2+4*MXLM1/MXLM2) PARAMETER (MXLPOT=MZCHF*MZCHF*MXLM3+MZCHL*MZCHL*MXLM3+1) PARAMETER (MXDUMC=MXLPOT-MZCHF*MZCHF*MZLMX-MZCHL*MZCHL*MZLMX) PARAMETER (MXMEM=MZMEG*1000000+MZKIL*1000+1) PARAMETER (MXNCF=MZTAR) C DIMENSION JCONAT(MZTAR) C COMMON /ALPHAJ/J2(MZSLP),JP(MZSLP),JCH(MZSLP),JCFG(MZSLP), A JCOUNT(MZSLP),IJNAST COMMON /BASIC1/BSTO,RA,NELC,NZ,LRANG2,NRANG2,MAXNHF(MZLR2), A MAXNLG(MZLR2),MAXNC(MZLR2),LRANG1 C COMMON /BIG1/HJ(MXHJ),HJBC(MXHBC),HJBB(MZNC2,MZNC2), C A HLS(MXHLS,MXHLS),DUM1(MXDUM1) COMMON /CASES/MORE,MSKIP,IPOLPH,INAST COMMON /DISTAP/IDISC1,IDISC2,IDISC3,IDISC4,ITAPE1,ITAPE2,ITAPE3, A ITAPE4,JDISC1,JDISC2 COMMON /JCHAN/LJP(MZCHF),KJ(MZCHF),JTARG(MZCHF) COMMON /JSTATE/ENATJ(MZTAR),B(MZTAR,MXNCF),LSVALU(MZTAR,MXNCF), A JNTCON(MZTAR),JJ(MZTAR),JPTY(MZTAR),JNAST COMMON /LRPOT/CF(MZCHL,MZCHL,MZLMX), A CFJ(MZCHF,MZCHF,MZLMX),DUMC(MXDUMC) COMMON /MEMORY/ARRAY(MXMEM),MEM1,MREC1 COMMON /MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON /SCRACH/DUMMY(MXJC3) c c * parallel * c include 'mpif.h' common /parablock/iam,nproc common /pdim/mnp1p(mzslp),nconhpp(mzslp),njchap(mzslp) x ,jrglp(mzslp),jnptyp(mzslp),nsym c c C DATA IZERO/0/ C----------------------------------------------------------------------- C C ON FIRST CALL, WRITE OUT TARGET STATES C IF (JPOS.EQ.1) THEN WRITE (ITAPE3) JNAST WRITE (ITAPE3) (ENATJ(N),N=1,JNAST), (JJ(N),N=1,JNAST), A (JPTY(N),N=1,JNAST), (JPTY(N),N=1,JNAST) ENDIF C JRGL = J2(JPOS) JNPTY = JP(JPOS) NJCHA = JCH(JPOS) JNCFGP = JCFG(JPOS) KAB2 = NRANG2*NRANG2 NCONHP = NRANG2*NJCHA MNP1 = NCONHP + JNCFGP DO 10 N = 1,JNAST JCONAT(N) = 0 10 CONTINUE DO 20 I = 1,NJCHA N = JTARG(I) JCONAT(N) = JCONAT(N) + 1 20 CONTINUE DO 30 I = 1,NJCHA LJP(I) = LJP(I)/2 30 CONTINUE C WRITE (ITAPE3) JRGL,IZERO,JNPTY,JNCFGP,IPOLPH WRITE (ITAPE3) MNP1,NCONHP,NJCHA c c *parallel* c i=iam*nsym+jpos mnp1p(i)=MNP1 nconhpp(i)=NCONHP njchap(i)=NJCHA jrglp(i)=JRGL jnptyp(i)=JNPTY c WRITE (ITAPE3) (JCONAT(N),N=1,JNAST) WRITE (ITAPE3) (LJP(N),N=1,NJCHA), (KJ(N),N=1,NJCHA) MORE = 1 IF (JPOS.GE.IJNAST) MORE = 0 WRITE (ITAPE3) MORE flush(itape3) C KMEM = MEM1 KREC1 = 1 DO 50 K1 = 1,NJCHA KINDEXBIG=KMEM+KAB2*K1 IF (KINDEXBIG.GT.MXMEM) CALL DA2(1,KREC1,IDISC2,KAB2*K1,HJ) DO 40 K2 = 1,K1 KAB11 = (K2-1)*KAB2 IF (KMEM+KAB2*K1.GT.MXMEM) THEN WRITE (ITAPE3) (HJ(KAB11+I),I=1,KAB2) C ELSE WRITE (ITAPE3) (ARRAY(KMEM+KAB11+I),I=1,KAB2) ENDIF C 40 CONTINUE KMEM = KMEM + KAB2*K1 50 CONTINUE c write(0,*)'get here' flush(itape3) IF (JNCFGP.EQ.0) GOTO 100 KAB3 = NRANG2*JNCFGP IF (KAB3.GT.MXJC3) CALL RECOV2('WRIT3 ','MXJC3 ',MXJC3,KAB3) DO 80 K = 1,NJCHA DO 70 J = 1,JNCFGP KAB21 = ((J-1)*NJCHA+K-1)*NRANG2 DO 60 I = 1,NRANG2 DUMMY(J+ (I-1)*JNCFGP) = HJBC(KAB21+I) 60 CONTINUE 70 CONTINUE WRITE (ITAPE3) (DUMMY(I),I=1,KAB3) 80 CONTINUE DO 90 I = 1,JNCFGP WRITE (ITAPE3) (HJBB(I,J),J=I,JNCFGP) 90 CONTINUE C C *** NOTE CHANGE IN OUTPUT OF THE CF *** 100 CONTINUE IF (LAMAX.GT.0) THEN DO 110 I = 1,NJCHA WRITE (ITAPE3) ((CFJ(I,J,K),K=1,LAMAX),J=I,NJCHA) 110 CONTINUE ENDIF C 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 /NRBDIP/MAXLD,J2MAXD c c * parallel * c include 'mpif.h' common /parablock/iam,nproc 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),J2MAXD,nproc+1 !parallel 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