C RECUP+RECUD - LAST UPDATES '88AUG KAB; '90-MAY...'95-NOV14WE,ZHL. C '01MAR30TH;'03FEB28;'04MAY05;'06MAY18 C C C R E C U P C C AND C C R E C U D C C BREIT-PAULI CODES FROM SCOTT & TAYLOR, CPC 25 (1982) 347-387 C ADAPTED FOR COMPATIBILITY WITH OPACITY R-MATRIX CODES. C C NB '90MAY15: INCLUDES ADRIAN BOONE'S CRUCIAL CORRECTION IN SPNORB. WE. C NB '92MAY17: NO LONGER TROUBLE WITH DMOUT/RECUD (INVERSIONS ETC). WE. C '92JUN14: NO LONGER S-L-PI GROUPING REQUIRED WITH NEW BOUND IN STG2 C '92JUN17: BSPNO NOW ACCEPTING CORRELATION TERMS EXPANSIONS C '92JUN20: BOUNDJ GIVING TCC'S IF PUNCH>0 (REQUIRES NEW BOUND IN "). C '92JUN23: NEW HSLDR WITH ARRAY AUX(5000,9) REQUIRED IN RSTGLIBN. C RUB'94FEB-MAR: (N+1)-EL. CASE CONVERTED TO TAKE C.I. TYPE TARGETS. C RUB'94PRE-LUND: CONVERSION TO PROCESS SL COUPLED CHANNEL INPUT. C '94DEC05: TCC'S NORMALIZED UNLESS ICHECK.LT.0 C '95JANFEB PAIR COUPLING EXTENDED TO J->J'=J IN SR LSCONT AND SPINCC C '95FEB/OC LONG-RANGE COEFF'S FOR BREIT-PAULI TERMS PROVIDED: SPNORB C '95APR13 KAB RAC PHASE CHANGES'94DEC-30 (RE)INSERTED: N.BADNELL'S! C '95SEP18 OLD PHASE RESTORED IN SPNORB - JOHN PELAN SEP06; C ICHECK=1 THE 'DEFAULT' AGAIN; =3 OUT '95SEP, BACK IN '96FEB19. C '95NOV6-13: S-O TERMS OF CORRELATION CONFIGURATIONS EXCLUDED: -NTYP C OR 96FEB20 AGAIN INCLUDE SUCH TARGET EFFECTS ON SETTING ICHECK GT 1 C '97JAN22: 2-DIM JCOUNT, RECUD: ANY SLP ORDER IN STG2 ACCEPTED, AND C FEB10: BJLVC(,,3), DMES: VELOCITY RESULTS FOR 'REVERSE' OK TOO. C '97FEB21/'99Jan19: E2-EXTENDED (ICODE,MPOL). C '97JUN-JUL9: OPTIONAL LEVEL INPUT FOR JAJOM; FULL JNAST.LE.0 OPTION C '03Feb23-4: RECUD corrected to primed Scott&Taylor (21-3)=LRGL. C '03Mar31-Apr6,June-July: magnetic 2-body terms, complete by '06July C '03Jul08 corr BOUNDJ KTMP( L14->L13), DO 83 KTMP(K->I) C '06APR-MAY: TCC VA04A-adjusted if ICHECK=-2 (new assignments!!) C '07Jan13: PJS-KAB-'3fix' in BSPNO, RECUD, and SPINBB (call SETUPE!) C PITFALLS: 1) DUPLICATE (N+1) ELECTRON SYMMETRIES S,L,PI -- '90MAY16. C 2) RISKY FOR N+1 ELECTRONS TO HAVE MERE CORRELATION TARGET TERMS! 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 H AND PERHAPS D OUTPUT FILES ARE SET UP TO BE READ AS INPUT C TO STGH. THIS ENABLES STGF,STGB,STGBB,STGBF TO INCORPORATE C RELATIVISTIC EFFECTS INTO THE CALCULATION OF CROSS-SECTIONS C BETWEEN FINE-STRUCTURE LEVELS. C C*********************************************************************** C C ROUTINES USED IN RECUPD C C*********************************************************************** C C RECUPD DIRECTING ROUTINE. C BOUNDJ C BSPNO - C DA2 C DAFILA C DEGEN C DFIND C DJZERO C DMES C DMOUT C FANOFS++ C FIN2BB + C FIN2BC + C FIN2CC + C FINCGX++ C FINBBR C HJZERO C INTECH C J23SP1++ C JLRC C LSCONT C LSJCUP C LSJTRI LOGICAL FUNCTION C MATANS++ C MKWTS ++ C NDEGEN C NJCHAN C NUMSYM C READS C READ2B++ C READTP - C RECUD C RECUPJ C RECOV1 C SETDIM C SETL C SETR C SPINBB - C SPINBC - C SPINCB - C SPINCC - C SPNORB - C WRITAP C C LIBRARY ROUTINES USED: C DRACAH C FACTT C HSLDR C NJGRAF (and associates for case +, i.e. with 2-body FS terms) C SETUPE C TENSOR C C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN RECUPD C C*********************************************************************** C C IREAD CARD-READER SET IN DIRECTING ROUTINE C IWRITE OUTPUT TO LINE-PRINTER C IPUNCH PERMANENT OUTPUT FILE OF TERM COUPLING COEFFICIENTS, C = 0 FOR NO SUCH COEFFS. C ITAPE1 PERMANENT INPUT FILE FROM STG2R OF LS DIPOLE MATRICES; C ITAPE2 PERMANENT INPUT FILE FROM STG2R OF LS H-MATRICES; C ITAPE3 PERMANENT OUTPUT FILE OF RECOUPLED H-MATRICES; C = 0 FOR NO H-MATRIX RECOUPLING. C ITAPE4 PERMANENT OUTPUT FILE OF RECOUPLED DIPOLE MATRICES. C = 0 FOR NO DIPOLE MATRIX RECOUPLING. C ITAP 5 = optional magnetic 2-body integral file MK_seq C IDISC1 SCRATCH DIRECT ACCESS FILE OF CHANNEL RECOUPLING DATA; C IDISC1 IS ONLY USED FOR SPIN-ORBIT OR DIPOLE MATRIX. C IDISC2 SCRATCH DA FILE OF RECOUPLED C-C MATRIX ELEMENTS. C C*********************************************************************** C C RECUPD DIRECTING ROUTINE C C*********************************************************************** C C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL COMPLT COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BASICT/NDIAG,IPOLPH, ICODE,JRELOP(3) COMMON/DAREC1/IRECA( 180, 16),MXREC COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/INFORM/IREAD,IWRITE,IPUNCH C 1000 FORMAT(/10X,64('*')) C open (5,file='recupd.inp',status='old') open (6,file='recupd.out',status='unknown') open (7,file='tcc',status='unknown') open (1,file='s2dip',status='old',form='unformatted') open (2,file='s2ham',status='old',form='unformatted') open (3,file='srham',status='unknown',form='unformatted') open (4,file='srdip',status='unknown',form='unformatted') c C SET THE CARD READER CHANNEL NUMBER C IREAD=5 C C SET THE ARRAY DIMENSIONS C CALL SETDIM C C SET UP FACTORIALS C CALL FACTT C C READ THE INPUT DATA, INCLUDING TOTAL 2J & PARITY (J2 & JP). C CALL READS C C OPEN DA FILES IDISC1 (MOVED TUE'96OCT25) AND IDISC2 C MXREC=-1 IREC=-1 CALL DA2(0,IREC,IDISC2,1,X) WRITE(IWRITE,1000) C C C ---- LOOP OVER THE TOTAL ANGULAR MOMENTUM AND PARITY SYMMETRIES C DO 2 J=MIN(1,IJNAST),IJNAST C STOPPING IN READTP IF IJNAST=0 SPECIFIED (FOR TCC ONLY) C CALL READTP(J) IF (MXREC.LT.0 .AND. (JRELOP(3).NE.0.OR.ITAPE4.NE.0)) * CALL DA2(0,MXREC,IDISC1,1,X) C C DETERMINE THE NUMBER OF CHANNELS FOR THIS TOTAL ANGULAR C MOMENTUM AND PARITY SYMMETRY C CALL NJCHAN(J) IF(JCH(J).EQ.0) GO TO 2 C C APPLY THE RECOUPLING TRANSFORMATION TO THE STG2R LS-HAMILTONIAN C MATRICES AND LONG RANGE POTENTIAL COEFFICIENTS C IF(ITAPE3.NE.0) CALL HJZERO(J) CALL RECUPJ(J,COMPLT) IF(ITAPE3.EQ.0) GO TO 2 C C CALCULATE THE CONTRIBUTION TO THE HAMILTONIAN MATRIX FROM C THE SPIN-ORBIT INTERACTION IF REQUIRED C IF(JRELOP(3).GT.0) CALL SPNORB(J) IF(JRELOP(3).LT.0) print *,' SPNORB bypassed!' C C WRITE THE TRANSFORMED HAMILTONIAN MATRICES AND LONG-RANGE C POTENTIAL COEFFICIENTS TO THE PERMANENT OUTPUT FILE C IF(COMPLT) CALL WRITAP(J) WRITE(IWRITE,1000) C 2 CONTINUE IF (ITAPE4.EQ.0 .OR. IJNAST.LE.1 .OR..NOT.COMPLT) GO TO 20 C C ---- LOOP OVER ALLOWED FINAL (JF) AND INITIAL (JI) TOTAL ANGULAR C MOMENTUM AND PARITY SYMMETRIES TO RECOUPLE DIPOLE MATRICES C DO 11 JF=1,IJNAST IF(JCH(JF).EQ.0) GO TO 11 DO 10 JI=1,JF IF(JCH(JI).EQ.0) GO TO 10 C C SELECT E1 OR E2+M1 TRANSITIONS C MPOL=2 IF(ICODE.GT.0) THEN IF(JP(JI).EQ.JP(JF)) GO TO 10 ELSE IF(JP(JI).EQ.JP(JF)) MPOL=4 ENDIF IF(J2(JI)+J2(JF).LT.MPOL) GO TO 10 IF(ABS(J2(JI)-J2(JF)).GT.MPOL) GO TO 10 C C RECOUPLE DIPOLE MATRICES C CALL DJZERO(JI,JF) CALL RECUD(JI,JF,MPOL,ICODE) C C WRITE OUT RECOUPLED DIPOLE MATRICES C CALL DMOUT(JI,JF) C 10 CONTINUE 11 CONTINUE C 20 WRITE(IWRITE,'(/55X,12HEND OF RECUP/55X,12(1H-))') STOP END C*********************************************************************** SUBROUTINE BOUNDJ C C TO FIND ENERGIES AND CI COEFFICIENTS OF J TARGET STATES C BY RECOUPLING LS TARGET HAMILTONIANS AND DIAGONALISING. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL LSJTRI,NORM,PRT CHARACTER*1 LLB(0:7),PTY(-1:1),PARITY(0:1)*4 PARAMETER(L21=(( 60+1)* 60)/2, LA14=(( 114+1)* 114)/2) PARAMETER (LL51= 15*2-1, LL75= 21+2) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) DIMENSION X( 350),EIG( 350),AUX( 350,9), JTMP(0: 350), * LBED( 114),MBED( 350),LVEC( 350),LORD( 350), ! L14 * KORD( 350),ITMP( 650),B( 408, 350),FN( 408), * KJTM( 408),ITYP( 114),JSTA(0: 114),NORD( 114) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LSTORE( 180),LCFG( 180), * INAST COMMON/BASICR/NELC,MAXNC( 45),MAXNHF( 45),MAXNLG( 45),LRANG1,NZ COMMON/BASICS/LRANG2,NRANG2 COMMON/BASICT/NDIAG,IPOLPH, ICODE,JRELOP(3) COMMON/BIG1/ HJ( 400000),HSTORE(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) COMMON/BNDCON/ NCFGP,IOCCSH(3000),IOCORB( 15,3000), * IELCSH( 15,3000),I1QNRD(LL51,3,3000) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/INSTO8/ IST1( 5),IST2( 5),IRK5,IRK6,IRK7 COMMON/INSTO9/ RSPOR1( 56),RSPOR2( 820),RSPOR3(L21,2: 45) COMMON/JSTATE/ENAT( 408),T( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK COMMON/RECOV / IPLACE,IDMTST(50) COMMON/STATE/ ETNR( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST, * /STATED/ A( 114, 114),NTCON( 114),NTYP( 114, 114) COMMON/STATES/ NCFG,NOCCSH(3000),NOCORB( 15,3000),NELCSH( 15, * 3000),J1QNRD(LL51,3,3000),MAXORB,NJCOMP(LL75),LJCOMP(LL75) C DATA PARITY/'EVEN',' ODD'/, EPSI/1.E-9/, MXTCC/ 650/, JTMP(0)/0/, * JSTA(0)/0/,PTY/'o','?','e'/,LLB/'S','P','D','F','G','H','I','X'/ C 1001 FORMAT(I3,A1,':', I5,' levels,',I5,' parameters, functional F =', * 1P,E11.4,' ===>',E11.4) 1002 FORMAT(//' TARGET SYMMETRY J =',F4.1,1X,A4/1X,28('-')) 1003 FORMAT(7X,I3,I5,13X,42HHEADER CARD FOR TERM COUPLING COEFFICIENTS) 1004 FORMAT(7X,I3,I5,5X,13HTCC-JRELOP = ,3I3, 6H; Z =,I3,', N =',I3, * ' CHECK=',I2/(5(I5,F9.6))) 1005 FORMAT(3I6,(T21,15I4)) 1006 FORMAT(2I5,I4,2A1,F4.1,2F16.7,F17.3,I7) 1007 FORMAT(/' LEVEL TERM SLP J ENERGY EI/2RY',6X,'(EI-E1)/RY', * 6X,'E*cm/hbar*c ORDER'/) 1008 FORMAT(/' TCC NORM (ICHECK =',I2,'):'/(5(I4,':',F10.7))) 1009 FORMAT(//' !!! WARNING: beware of |ICHECK|=1; moreover this code'/ * 14X,40Hdoes not mimic previous mismatches when/ * 14X,40H'correlation' levels are embedded !!!/) C LSPI(II) = SIGN((LS(II)+1)*100+L2(II)/2,1-LP(II)*2) C C CONTINUE READING ITAPE2 FOR S-O INTEGRALS AND TARGET HAMILTONIANS C WRITE(IWRITE,'(//52X,17HSUBROUTINE BOUNDJ/52X,17(1H-))') READ(ITAPE2,END=30) LRGL,NSPN,NPTY,NCFGP,IPOLPH READ(ITAPE2) MNPI,NCONHP,NCHAN READ(ITAPE2) NCONAT READ(ITAPE2) (L2P,I=1,NCHAN) READ(ITAPE2) MORE C C CHECK IF SPIN-ORBIT DATA FROM STG2 MUST BE READ C IF(JRELOP(3).EQ.0) GO TO 12 IF(NCFGP.GT.0) THEN IF(NCFGP.GT.IDMTST(13)) CALL RECOV1(13,NCFGP) READ(ITAPE2) (IOCCSH(I),I=1,NCFGP) DO 11 I=1,NCFGP L=IOCCSH(I) M=2*L-1 11 READ(ITAPE2) (IOCORB(J,I),J=1,L),(IELCSH(J,I),J=1,L), * ((I1QNRD(J,K,I),K=1,3),J=1,M) ENDIF C C READ THE SPIN-ORBIT ONE-BODY INTEGRALS FROM THE INPUT TAPE C READ(ITAPE2) IRK5 IF(LRANG1.GT.IDMTST(16)) CALL RECOV1(16,LRANG1) IF(IRK5.GT.IDMTST(19)) CALL RECOV1(19,IRK5) READ(ITAPE2) (IST1(I),I=1,LRANG1),(RSPOR1(I),I=1,IRK5) READ(ITAPE2) IRK6 IF(IRK6.GT.IDMTST(20)) CALL RECOV1(20,IRK6) READ(ITAPE2) (IST2(I),I=1,LRANG1),(RSPOR2(I),I=1,IRK6) DO I=2,LRANG2 READ(ITAPE2) IRK7 C IF(IRK7.GT.L21) STOP READ(ITAPE2) (RSPOR3(J,I),J=1,IRK7) C TST print "(' RSPOR3-test: L,VAL/2.6625E-5 ='/I4,1P,(T5,6E12.4))", C * I-1, (RSPOR3(J,I)/2.6625E-5,J=1,IRK7) ENDDO C 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 12 READ(ITAPE2) INAST WRITE(IWRITE,*) INAST,' TARGET SYMMETRIES LS ...' * ,' (NCFG = ',NCFG,')' IF(INAST.GT.IDMTST(44))CALL RECOV1(44,INAST) NBED= 114 NSYM=0 LPOS=0 LDIM=0 INIT=0 DO 19 I=1,INAST READ(ITAPE2) L,M,LP(I),NCUP,LD C NTC = f(LD) NSYM=ABS(NCUP) IF(NCUP.GE.0) GO TO 14 C AS NO EIGENVECTORS FOR TCC CALCULATION ARE PASSED ON. DO 13 J=1,NSYM READ(ITAPE2) NTC,N MBD=(N-1)/NAST NSP=N-MBD*NAST ! term index in energy order (.le. NAST) WITHIN J N = max(NTC,NSP) ! Lyngby'05Jul16: IF(N.GT.IDMTST(14)) CALL RECOV1(14,N) IF(MBD.NE.0) NBED=MIN(NBED,NSP) BACKSPACE ITAPE2 LORD(J)=NSP LBED(NSP)=MBD c LBED(J+INIT)=MBD ??? not really May 26 ITYP(NSP)=I ! replacing LSPI(NSP)=SIGN(M*100+L,1-LP(I)*2) READ(ITAPE2) NTC,N, C, (A(K,NSP),K=1,NTC) C tst print"(' I,J,NTC,N,NSP,MBD,C =',6I5,F12.5)",I,J,NTC,N,NSP,MBD,C ETNR(NSP)=C NORD(NSP)=J+INIT C tmp KORD(J+INIT)=NSP X(J+INIT)=C IF(IBUG8.NE.2) GO TO 13 PRINT*," BOUNDJ: NSP,MBD,EE,EVEC =",NSP,MBD,C,(A(K,NSP),K=1,NTC) 13 CONTINUE 14 LCFG(I)=NTC WRITE(IWRITE,*)' L = ',L,' 2S+1 = ',M,' ',PARITY(LP(I)),' ', * NTC,' CONFIGURATION(S)' INIT=NSYM+INIT ! ...NAST LDIM=LDIM+LD IF(LDIM.GT.IDMTST(46)) LPOS=0 READ(ITAPE2) (HSTORE(K+LPOS),K=1,LD) L2(I)=L*2 LS(I)=M-1 LSTORE(I)=LPOS * IF(ICHECK.NE.1) GO TO 19 DO 16 K=1,NTC ITMP(K)=0 EIG(K)=HSTORE(K+LPOS) C ltr IF(NCUP.GE.0) X(K+INIT-NSYM)=EIG(K) ! for stg2 case of no s-o DO 15 J=1,K M=J IF(EIG(J).LT.EIG(K)) M=K 15 ITMP(M)=ITMP(M)+1 16 LPOS=NTC-K+LPOS DO 18 K=1,NTC C PRINT *, ' K,IE,E = ',K,ITMP(K),EIG(K) C RUB'98OCT21: OPEN PRINT TO TRACE EMBEDDED CORRELATION TERMS! IF(ITMP(K).LE.NSYM) GO TO 18 C MARKING CORRELATION CONFIGURATIONS TO EXCLUDE S-O EFFECTS: IF(ICHECK.NE.1) GO TO 18 DO 17 J=1,NSYM L=LORD(J) 17 NTYP(L,K)=-NTYP(L,K) 18 CONTINUE C write(*,'(18H NSP,NTYP(NSP,I) =,15I4)') NSP,(NTYP(L,K),K=1,NTC) 19 LPOS=LSTORE(I)+LD if(NBED.gt.NAST) NBED = 0 C DO 22 K=1,INIT DO 21 J=1,K M=J IF(X(J).LT.X(K)) M=K 21 KORD(M)=KORD(M)+1 22 CONTINUE Ctst"(/9X,'I,KORD,ITYP =',(T24,5(I5,2I3)))",(K,KORD(K),ITYP(K),K=1,NAST) DO 23 I=1,INIT K=KORD(I) 23 NORD(K)=I print"(' N,NORD =',(T11,6(I6,':',I3)))", (I,NORD(I),I=1,NAST) C C C COMPUTE LEVELS C J = 0 DO 25 N=1,NAST I=ITYP(NORD(N)) ! scanning in term energy order J = MIN(L2(I),LS(I))+1 + J JSTA(N)=J M = L2(I)+LS(I)+1 DO 24 K=J,JSTA(N-1)+1,-1 KJTM(K) = LSPI(I)*100 + SIGN(M,LSPI(I)) 24 M=M-2 25 CONTINUE C IF (JNAST) 26,28,30 C 26 J=0 M=0 DO N=1,NAST K=ITYP(NORD(N)) DO I=ABS(LS(K)-L2(K)),LS(K)+L2(K),2 J=J+1 IF (J.GT.-JNAST) THEN M=M+1 IF (M.EQ.1 .AND. JSTA(N-1)+1.NE.J) THEN PRINT *,' STOPping: enlarge -JNAST to term boundary ',JSTA(N) STOP ENDIF JPTY(J)=LP(K) JJ(J)=I ENDIF ENDDO ENDDO 28 print "(/' JNAST =',I4,5X,'computed!'/(T8,8(I5,':',I2,A1)))", * J, (I,JJ(I),PTY(1-2*JPTY(I)),I=1,J) JNAST = J ! '06Mar27. C C C LOOP OVER ALL J TARGET STATES; FOR EACH SYMMETRY LOOK AT FIRST ONE C 30 IF(JNTCON(1).GT.0) GO TO 999 IF(LDIM.GT.IDMTST(46)) CALL RECOV1(46,LDIM) * COMMON/JSTATE/ENAT( 408),T( 408, 350),LSVALU( 408, 350): * do 29 K=1, 408 * do 29 I=1, 408 * 29 T(I,K)=0. * JMAX=0 NHES=0 DO 50 J=1,JNAST JRGL=JJ(J) JNPTY=JPTY(J) DO K=1,J-1 IF(JRGL.EQ.JJ(K).AND.JNPTY.EQ.JPTY(K)) GO TO 50 ENDDO JMAX=MAX(JRGL,JMAX) IF(IBUG8.EQ.2) WRITE(IWRITE,1002) .5*JRGL,PARITY(JNPTY) C C LOOP OVER LS SYMMETRIES WHICH COUPLE TO CURRENT J (JRGL,JNPTY) C AND FILL HJBB. C LOCATE LS TARGET STATES COUPLED TO CURRENT J SYMMETRY TO DEFINE C LSVALU,I=1,JNTCON -- NOW ALSO FOR CASE NAST I,J,K,L,LSPI,KJTM =',6I6)",I,J,K,L,LSPI(K),KJTM(J) *** STOP ! NHES = 0 3 WRITE(IWRITE,1006)I,LVEC(I), LS(K)+1,LLB(L),PTY(1-2*LP(K)), * JJ(I)/2.0, ENAT(I),C,C*109737.32,N C nol IF(NHES.LE.0) THEN; WRITE(IWRITE,'(/20X,18HGAPS IN MULTIPLETS/... IF(ABS(ICHECK).EQ.3) * print"(/28X,'|ICHECK|=3: unsafe neglect of correlation-TCC!')" C WRITE(IWRITE,"(/' LEVEL: EIGENVECTOR (printed along with LVEC-tab *le if IBUG8.gt.0)')") DO 5 I=1,JNAST K=JNTCON(I) if(IBUG8.gt.0) WRITE(IWRITE,'(I5,(T6,5F14.7))') I,(B(I,J),J=1,K) 5 LVEC(I)=K IF(IPUNCH.NE.0) GO TO 8 C OPTION FOR MAKING SPARSE MATRICES LSVALU AND T COMPACT, WE'94MAR11 DO 7 I=1,JNAST L=0 DO 6 K=1,LVEC(I) IF(LSVALU(I,K).EQ.0) GO TO 6 L=L+1 LSVALU(I,L)=LSVALU(I,K) 6 CONTINUE 7 JNTCON(I)=L 8 if(IBUG8.gt.0) then WRITE(IWRITE,'(/'' LEVEL, LVEC JNTCON: COMPONENT TERMS (AS DEFI *NED UNDER TERMS #)''/)') DO 9 I=1,JNAST K=JNTCON(I) 9 WRITE(IWRITE,1005) I, LVEC(I),K, (LSVALU(I,J),J=1,K) endif C C COMPUTE TERM COUPLING COEFFS - H E SARAPH CPC 3(1972)256-68. C IF(NSYM.NE.0) GO TO 61 WRITE(IWRITE,'(41H STOPPING FOR LACK OF TCC DATA FROM RSTG2)') STOP 61 DO 63 J=1,NAST C=ETNR(J) LORD(J)=0 DO 62 K=1,J M=K IF(ETNR(K).LE.C) M=J 62 LORD(M)=LORD(M)+1 63 CONTINUE C=ETNR(1) DO 64 I=1,NAST ETNR(I)=(ETNR(I)-C)*2. K=LORD(I) ! index in energy order, terms I arranged as in LAT etc 64 KORD(K)=I ! position " WRITE(IWRITE,'(/7H LORDER,(T8,18I4))') (LORD(K),K=1,NAST) IF(IPUNCH.GT.0) WRITE(IPUNCH,'(2I4,7H TERMS:/(I4,3I3,1P,E14.6))') * NAST,NHES, (LORD(I),ISAT(I)+1,LAT(I)/2,LPTY(I),ETNR(I),I=1,NAST) C NORM = ICHECK.GT.0 PRT = IBUG8.GE.0 J = JMAX 65 M=0 JNPTY=0 66 KP=0 M0=M LD=0 N=0 DO 68 L=1,NAST K=KORD(L) IF(.NOT.LSJTRI(LAT(K),ISAT(K),LPTY(K),J,JNPTY)) GO TO 68 LD=LD+1 JTMP(LORD(K))=LD if (L.GT.NHES) go to 68 N=N+1 DO 67 I=1,4821 67 HLS(I,N)=0. 68 CONTINUE C tst print "(/' K,JTMP(K) =',(T13,6(I6,I3)))",(K,JTMP(K),K=1,NAST) IF(N.EQ.0) GO TO 88 NVAR = 0 DO 77 I=1,JNAST IF(JJ(I).NE.J) GO TO 77 IF(JPTY(I).NE.JNPTY) GO TO 77 DO L=KP+1,NAST LD=L K=KORD(L) IF(LSJTRI(LAT(K),ISAT(K),LPTY(K),J,JNPTY)) GO TO 69 ENDDO PRINT *,' TCC TERMINATES: J-VALUES INCOMPATIBLE WITH NAST' GO TO 999 69 KP=LD IF(KP.LE.99) GO TO 70 C LTR NSYM=-ABS(NSYM) --- ETC ETC AFTER TCC FORMAT EXTENSION; NOW PRINT *,' > 99 PARENT TERMS: CHANGE TCC FORMAT FOR 2J = ',J IPUNCH = -ABS(IPUNCH) 70 S=0. DO 75 L=1,JNTCON(I) C=0. NSP=LSVALU(I,L) IF(NSP.EQ.0) GO TO 75 LPOS=0 DO 71 K=1,INAST IF(.NOT.LSJTRI(L2(K),LS(K),LP(K),J,JNPTY)) GO TO 71 LD=K IF(LAT(NSP).EQ.L2(K).AND.ISAT(NSP).EQ.LS(K)) GO TO 72 LPOS=LCFG(K)+LPOS 71 CONTINUE GO TO 999 ! (CODING) ERROR! 72 DO 73 K=1,LCFG(LD) 73 C=B(I,K+LPOS)*A(K,NSP)+C S=C*C+S K=LORD(NSP) ! tst print"(' I,L,K,KP,T =',4I5,F12.6)", I,L,K,KP,C I1=JTMP(K) I2=JTMP(KP) MBED((I1-1)*N+I2) = (I-1)*1024 + L C if (MIN(I1,I2).gt.NHES) GO TO 75 if (MIN(K,KP).gt.NHES) GO TO 75 HLS(I1,I2) = C IF(ABS(C).LT.2.E-6) GO TO 75 ! from 1.E-5 (2J=1: TCC 704 of O2) IF (KP.EQ.K) GO TO 74 ! and COL in CALCFX normalized instead NVAR=NVAR+1 LVEC(NVAR) = JTMP(K)*256 + JTMP(KP) AUX(NVAR,1)=0.002 ! 0.002... 0.01 X(NVAR)=1. C IF (KP.EQ.K .AND. ABS(ABS(C)-1.).LT.5.E-7) NVAR=NVAR-1 s.o! 74 M=M+1 IF(M.GT.MIN( 350,MXTCC)) IPUNCH=-ABS(IPUNCH) IF(IPUNCH.LE.0) GO TO 75 EIG(M)=C ITMP(M)= 100*K + KP 75 T(I,L)=C C=1./SQRT(S) FN(I)=C IF(.NOT.NORM) GO TO 77 DO 76 K=1,JNTCON(I) 76 T(I,K)=T(I,K)*C 77 CONTINUE if (ICHECK.ge.0) go to 88 C S = VARTCC(HLS,N,.FALSE.) IF (IBUG8.GT.0 .or. S.lt.1.E-7) THEN print"(/I3,A1,' = 2Jpi: VARTCC =',E12.5)", J,PTY(1-2*JNPTY), S if (S.lt.1.E-7) go to 88 S = VARTCC(HLS,N,.TRUE.) ENDIF C C tst CALL CALCFX(NVAR,LVEC,X,C,N,0) ! with modified X(1)=1.1 etc IF(NVAR.EQ.0) GO TO 88 MAXIT = NVAR CC SUBROUTINE VA04A (X,E,N,F,ESCALE,IPRINT,ICON,MAXIT, LVEC,NRANG): CALL VA04A(X,AUX,NVAR,C, 5., 0, 2,MAXIT, LVEC,N) ! '06Apr25-7 if (NVAR.le.0) then ! trap '06May07/09 print "(I3,A1,I5,' levels: F =',1P,E12.5,' not renormalizable'/ * ' X =',(T6,8F9.4))" ,J,PTY(1-2*JNPTY), N,S, (X(K),K=1,-NVAR) GO TO 88 endif IF(IBUG8.EQ.0) THEN call CALCFX(NVAR,LVEC,X,C,N,-1) ELSE call CALCFX(NVAR,LVEC,X,C,N,-2) print"(' CALCFX: F,NVAR,MAXIT =',E12.5,2I7/' X =',(T6,8F9.4))" * , C,NVAR,MAXIT, (X(K),K=1,NVAR) ENDIF print 1001, J,PTY(1-2*JNPTY), N,NVAR, S,C C C and insert those adjustments into T[CC] (and eventually EIG): DO 83 L=1,N S = 0. DO 82 K=1,N I = MBED((K-1)*N+L) I1=(I-1)/1024+1 I2=MOD(I,1024) IF(IBUG8.GT.0) * print"(' TCC-test:',3(2I5,F12.6))", K,L,HLS(K,L),I1,I2,T(I1,I2) S = HLS(K,L)*HLS(K,L) + S 82 T(I1,I2)=HLS(K,L) 83 FN(I1) = S C 88 JNPTY=JNPTY+1 IF(JNPTY.EQ.1) GO TO 66 IF(M.EQ.0) GO TO 78 IF(M.GT.MXTCC) CALL RECOV1(49,M) IF(IPUNCH.NE.IWRITE) WRITE(IWRITE,1003) J,SIGN(M,NSYM) C EVENTUALLY USE WIDER FORMAT IF M IS 'NEGATIVE' -- WE'94MAR15 IF(IPUNCH.LE.0) GO TO 78 WRITE(IPUNCH,1004)J,M,JRELOP,NZ,NELC,ICHECK,(ITMP(K),EIG(K),K=1,M) 78 J=J-2 IF(J.GE.0) GO TO 65 IF(IPUNCH.LE.0) GO TO 80 WRITE(IPUNCH,'(9X,6H0 0,5X,7HTCC END)') C C PUNCH OPTIONAL LEVEL LIST FOR JJOM DO 79 N=1,NHES I = ITYP(N) J=JSTA(N-1)+1 K=JSTA(N) M = SIGN(LS(I)+1,1-2*LP(I)) C WRITE(IPUNCH,'(I3,A1,3X,2I5)') M, LLB(L), LORD(N),K-J+1 -97NOV25: WRITE(IPUNCH,'(7X,2I5,I3,A1)') LORD(N),J-K-1, M,LLB(L2(I)/2) 79 WRITE(IPUNCH,'(4(F4.1,F11.6,I3))') * (REAL(L-K)+(L2(I)+LS(I))/2., AUX(L,2), KJTM(L), L=J,K) WRITE(IPUNCH,'(4H END,3X,2(4X,1H0))') C if(NORM) 80 WRITE(IWRITE,1008) ICHECK,(K,FN(K),K=1,JNAST) WRITE(IWRITE,'(/1X,73(1H*))') RETURN 999 STOP END C*********************************************************************** SUBROUTINE BSPNO(JRGL,JNPTY,LSKP) 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 IMPLICIT REAL*8(A-H,O-Z) LOGICAL LSJTRI PARAMETER(ITWO=2,IFOUR=4, LA14=(( 114+1)* 114)/2) PARAMETER (LL51= 15*2-1, LL75= 21+2) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) DIMENSION LSKP(*) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON /BIG1/ HJ( 400000),HSTORE(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) COMMON/BNDCON/ NCFGP,IOCCSH(3000),IOCORB( 15,3000), * IELCSH( 15,3000),I1QNRD(LL51,3,3000) COMMON/BNDINI/ MCFGP,JOCCSH(3000),JOCORB( 15,3000), * JELCSH( 15,3000),L1QNRD(LL51,3,3000) COMMON/C2BODY/ K2BDY,LRANG3,MMM(4) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON /FSTORE/FS0(LA14), FS1(LA14),FS2(LA14), ICI(3000),ICJ(3000) COMMON/STATES/ NCFG,NOCCSH(3000),NOCORB( 15,3000),NELCSH( 15, * 3000),J1QNRD(LL51,3,3000),MAXORB,NJCOMP(LL75),LJCOMP(LL75) C 1001 FORMAT(/32H SPIN-ORBIT INTERACTION INCLUDED) 1004 FORMAT(/6X, 65HBOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM * CONFIGURATION,I4/(6F13.7)) 1005 FORMAT(/9X,69HTRANSFORMED HAMILTONIAN MATRICES INCLUDING THE SPIN- *ORBIT INTERACTION/9X,69(1H-)) C C ---- LOOP ROUND THE LOWER HALF OF THE LSJ-HAMILTONIAN MATRIX C IBNDL=0 DO 43 MI=1,INAST LRGL=L2(MI) NSPN=LS(MI) NPTY=LP(MI) IF(.NOT.LSJTRI(LRGL,NSPN,NPTY,JRGL,JNPTY)) GO TO 43 C C FIND COEFFICIENTS FOR THIS LS SYMMETRY AND STORE IN /BNDCON/ C picking NTYP from LSKP (optionally dropping correlation TCCs) C 12 NCFGP=LCFG(MI) DO 19 I=1,NCFGP L=0 K = LSKP(I+IBNDL) ICI(I) = K IF (K.LT.0) GO TO 19 !"(' B-test: MI,I,K eq NTYP =',4I6)",MI,I,K L=NOCCSH(K) DO 14 J=1,L IOCORB(J,I)=NOCORB(J,K) 14 IELCSH(J,I)=NELCSH(J,K) DO 15 J=1,2*L+1 I1QNRD(J,1,I)=J1QNRD(J,1,K) I1QNRD(J,2,I)=J1QNRD(J,2,K) 15 I1QNRD(J,3,I)=J1QNRD(J,3,K) 19 IOCCSH(I)=L C C ---- READ THE DATA DEFINING THE RIGHT HAND SIDE OF MATRIX ELEMENTS C IBNDR=0 DO 40 MJ=1,MI LLRGL=L2(MJ) NNSPN=LS(MJ) NNPTY=LP(MJ) IF(.NOT.LSJTRI(LLRGL,NNSPN,NNPTY,JRGL,JNPTY)) GO TO 40 C C CHECK IF THE RACAH COEFFICIENT IS ZERO (GO TO 39 CORR'93MAR21); C IF IT IS THERE IS NO SPIN-ORBIT CONTRIBUTION TO THIS BLOCK C C 3fix PRAC = 1-MOD(ABS(LLRGL+NSPN-JRGL),4) ! '07Jan13: PRAC = 1-MOD(ABS(LRGL+NNSPN-JRGL),4) RAC2 = 0. IF (K2BDY.NE.0) THEN C 3fix CALL DRACAH(LLRGL,LRGL,NNSPN,NSPN,IFOUR,JRGL,RAC2) '07Jan13: CALL DRACAH(LRGL,LLRGL,NSPN,NNSPN,IFOUR,JRGL,RAC2) RAC2 = RAC2*PRAC ENDIF c C95APR CALL DRACAH(LRGL,LLRGL,NSPN,NNSPN,ITWO,JRGL,RAC) C95APR RAC= (1-MOD(ABS(LRGL+NNSPN-JRGL),4)) * RAC C NOT CALL DRACAH(LLRGL,LRGL,NNSPN,NSPN,ITWO,JRGL,RAC) C NOT RAC= (1-MOD(ABS(LLRGL+NSPN-JRGL),4)) * RAC - KAB94DEC20/31.APR29 C 3fix CALL DRACAH(LLRGL,LRGL,NNSPN,NSPN,ITWO,JRGL,RAC) ! '07Jan13: CALL DRACAH(LRGL,LLRGL,NSPN,NNSPN,ITWO,JRGL,RAC) RAC = RAC*PRAC IF(IBUG8.EQ.2) PRINT *, ' SPIN-ORBIT CONTRIBUTION', * ' FROM ',LRGL,NSPN,NPTY,' /',LLRGL,NNSPN,NNPTY,' RAC = ',RAC C C FIND CONFIGURATIONS FOR THIS LS SYMMETRY AND STORE IN /BNDINI/ C 22 MCFGP=LCFG(MJ) IF (RAC.EQ.0.0 .AND. RAC2.EQ.0.0) GO TO 39 DO 29 I=1,MCFGP L=0 K = LSKP(I+IBNDR) ICJ(I) = K IF(K.LT.0) GO TO 29 L=NOCCSH(K) DO 24 J=1,L JOCORB(J,I)=NOCORB(J,K) 24 JELCSH(J,I)=NELCSH(J,K) DO 25 J=1,2*L-1 L1QNRD(J,1,I)=J1QNRD(J,1,K) L1QNRD(J,2,I)=J1QNRD(J,2,K) 25 L1QNRD(J,3,I)=J1QNRD(J,3,K) 29 JOCCSH(I)=L C C CALCULATE THE SPIN-ORBIT INTERACTION FOR THE BOUND-BOUND C MATRIX BLOCKS (SPINBB NOW PROVIDES FULL MATRIX) C C IF(IBUG1.gt.0 .OR.IBUG2.GE.2) print "(//' BSPNO: 2Jp = ',2I2, * 12H S'L'-SL =,2(I3,I2),5X,'RAC1,RAC2 =',2F10.5)",jrgl,jnpty, * NNSPN+1,LLRGL/2,NSPN+1,LRGL/2,RAC,RAC2 CALL SPINBB(MI,MJ,RAC,RAC2,HLS) DO 38 I=1,MCFGP C alt IF (LSKP(I+IBNDR).LT.0) GO TO 38 ! no correlation Term Coupling DO 37 J=1,NCFGP C alt if (LSKP(J+IBNDL).LT.0) GO TO 37 ! ...if ICHCECK=3 '06Apr19-20 HJBB(I+IBNDR,J+IBNDL) = HJBB(I+IBNDR,J+IBNDL) + HLS(I,J) 37 CONTINUE 38 CONTINUE C 39 IBNDR=IBNDR+MCFGP 40 CONTINUE IBNDL=IBNDL+NCFGP 43 CONTINUE C C PRINT THE J-HAMILTONIAN BLOCKS INCLUDING SPIN-ORBIT INTERACTIONS C C IF(IBUG8.GT.0) print"(/' BSPNO test: IBNDL/DR =',2I5)",IBNDL,IBNDR IF(IBUG8.NE.2) GO TO 55 PRINT 1005 DO 53 I=1,IBNDR 53 PRINT 1004, I,(HJBB(I,J),J=I,IBNDL) PRINT 1001 55 RETURN END C*********************************************************************** SUBROUTINE CALCFX(NVAR,LVEC,X,F,N,IPRT) C C CALCFX HAS BEEN WRITTEN ACCORDING TO THE REQUIREMENTS OF SR.VA04A. C THE ROUTINE RETURNS THE VARIATIONAL FUNCTIONAL F; IT DEPENDS UPON C VARIATIONAL PARAMETERS X(1:NVAR), WHICH ARE INPUT. C LOGICAL PRT DIMENSION X(*), LVEC(*), HHH(4821,0:4821) C PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) COMMON /BIG1/ HJ( 400000),HSTORE(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) * EQUIVALENCE (HHH(1,1),HJ(1)) C 798 FORMAT(/116H SR.CALCFX: PARAMETERS IMAXIT AND NEXTRE ALLOW NO MORE C * ITERATIVE STEPS -- IT MAY NOT BE SENSIBLE TO RESUME ITERATING) C PRT = IPRT.GT.0 .or. IPRT.lt.-1 C if(IPRT.ne.0) go to 3 ! print"(' X =',(T6,8F9.4))",(X(K),K=1,NVAR) DO 2 J=1,NVAR IF(X(J).GT.-3.) GO TO 2 ! '06MAy09 for gt 0. NVAR = -NVAR RETURN 2 CONTINUE C 3 DO 4 K=1,N DO 4 I=1,N 4 HHH(I,K) = HLS(I,K) DO 5 J=1,NVAR I1 = LVEC(J)/256 I2 = LVEC(J)-I1*256 * I2 = MOD(LVEC(J)-1,256)+1 5 HHH(I1,I2) = HHH(I1,I2)*X(J) C DO 8 K=1,N S = 0. DO 6 I=1,N 6 S = HHH(I,K)**2 + S S = 1./SQRT(S) DO 7 I=1,N 7 HHH(I,K) = HHH(I,K)*S 8 CONTINUE F = VARTCC(HHH,N,PRT) IF (IPRT.GE.0) RETURN C DO 9 K=1,N DO 9 I=1,N 9 HLS(I,K) = HHH(I,K) C RETURN END C*********************************************************************** SUBROUTINE DA2(KEY,IREC,JDISC,LENGTH,ARRAY) C C - TO STORE A LARGE ARRAY IN A DA FILE C C KEY = 1 FOR READ, = 2 FOR WRITE, C = 0 FOR FINDING NUMBER OF DA RECORDS A GIVEN ARRAY TAKES. C IREC= (ON CALL) POINTER TO FIRST DA RECORD FOR ARRAY, CC = 0 FOR OPENING DA FILE (BY NAME), C =-1 FOR OPENING DA FILE (SCRATCH), C = (ON RETURN) POINTER TO NEXT AVAILABLE DA RECORD. C JDISC = DA FILE UNIT NUMBER. C ARRAY(LENGTH) = ARRAY TO READ OR WRITE. C C IMPLICIT REAL*8(A) PARAMETER (LREC=512, A0=1.,A1=1.E-9) DIMENSION ARRAY(LENGTH) C IF(IREC.GT.0) GO TO 10 IRECL=LREC*4 IF (A0+A1.NE.A0) IRECL=IRECL*2 IF(IREC.LT.0) GO TO 5 OPEN(JDISC,STATUS='OLD',FILE='MK_dir',ACCESS='DIRECT',RECL=IRECL) GO TO 90 5 OPEN(JDISC,STATUS='SCRATCH',ACCESS='DIRECT',RECL=IRECL) IREC=1 C 10 IF(LENGTH.EQ.0) GO TO 90 I2=0 20 I1=I2+1 I2=MIN(I2+LREC,LENGTH) IF(KEY.EQ.2) THEN WRITE(JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ELSE IF(KEY.EQ.1) THEN READ(JDISC,REC=IREC) (ARRAY(I),I=I1,I2) ENDIF IREC=IREC+1 IF(I2.LT.LENGTH) GO TO 20 90 RETURN END C********************************************************************** C SUBROUTINE DAFILA(KEY,LPOS,L2,J2,NJCHA,NTERM,NTERMI,ICHAN,PV) C C TO READ (KEY=1) OR WRITE (KEY=2) CHANNEL RECOUPLING DATA TO C 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 IMPLICIT REAL*8(A-H,O-Z) DIMENSION NTERM(NJCHA),ICHAN(9999),PV(9999) COMMON/DAREC1/IRECA( 180, 16),MXREC COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/SCRACH/DUMMY(1999900) C MJ=ABS(J2-L2) IF(J2.GE.L2) MJ=MJ+1 IF(MJ.GT.IDMTST(43)) CALL RECOV1(43,MJ) IF(NJCHA+1.GT.IDMTST(38)) CALL RECOV1(38,NJCHA+1) C IF(KEY.EQ.2) THEN DO 2 I=1,NJCHA 2 DUMMY(I)=NTERM(I)+0.1 DUMMY(NJCHA+1)=NTERMI+0.1 IRECA(LPOS,MJ)=MXREC ENDIF KREC=IRECA(LPOS,MJ) CALL DA2(KEY,KREC,IDISC1,NJCHA+1,DUMMY) IF(KEY.EQ.1) THEN DO 12 I=1,NJCHA 12 NTERM(I)=DUMMY(I) NTERMI=DUMMY(NJCHA+1) ENDIF C IF(NTERMI.GT.IDMTST(38)) CALL RECOV1(38,NTERMI) IF(KEY.EQ.2) THEN DO 22 I=1,NTERMI 22 DUMMY(I)=ICHAN(I)+0.1 ENDIF CALL DA2(KEY,KREC,IDISC1,NTERMI,DUMMY) IF(KEY.EQ.1) THEN DO 32 I=1,NTERMI 32 ICHAN(I)=DUMMY(I) ENDIF C CALL DA2(KEY,KREC,IDISC1,NTERMI,PV) C IF(KEY.EQ.2) MXREC=KREC RETURN END C*********************************************************************** SUBROUTINE DEGEN(E,LSTARG,NCHAN,HLS) C C -- ADJUSTS THE DIAGONAL ELEMENTS OF THE CONTINUUM-CONTINUUM MATRIX C BLOCKS TO MAKE THE TARGET LEVELS DEGENERATE WITH THE GROUND STATE. C THE DEGENERACY IS RESTORED IN SUBROUTINE NDEGEN. C C E = GROUND STATE ENERGY, C LSTARG(NCHAN) = LS TARGET STATE COUPLED TO EACH LS CHANNEL. C C IMPLICIT REAL*8(A-H,O-Z) DIMENSION LSTARG(NCHAN), HLS(4821,0:4821) COMMON/BASICS/LRANG2,NRANG2 COMMON/STATE/ ENER( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST C DO 3 K1=1,NCHAN C C FIND THE STATE THAT THIS CHANNEL IS COUPLED TO C I1=LSTARG(K1) DELTA=E-ENER(I1) C C ADJUST THE DIAGONAL ELEMENTS C KAB12=(K1-1)*NRANG2 DO 1 J=1,NRANG2 1 HLS(KAB12+J,KAB12+J)=HLS(KAB12+J,KAB12+J)+DELTA 3 CONTINUE RETURN END C*********************************************************************** SUBROUTINE DFIND(LI,LF) C C FINDS THE NEXT SET OF LS COUPLED DIPOLE C MATRIX ELEMENTS FROM THE STG2R OUTPUT TAPE ITAPE1. C C LI,LF = POSITIONS OF INITIAL, FINAL LS SYMMETRIES IN /ALPHA/ C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER(L18P= 8-1) PARAMETER (LL83L84= 400000/2, LL85L86=98000000/4) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=(LL83L84+LL85L86*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL82=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD2+1) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ DJ(LL83L84,2),DJBC(LL85L86,2),DJCB(LL85L86,2), * DJBB(5000,5000,2),DLS(5000,5000,2),DUM2(LL82) COMMON/CLEB/ CGC( 45),MAXM1 COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/LRPOT/ BLVC( 520, 520,0:L18P), BJLVC( 492, 492,0:L18P) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/RECOV / IPLACE,IDMTST(50) COMMON/SCRACH/DUMMY(1999900) 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.IDMTST(42)) CALL RECOV1(42,MX) C IF(LAM.EQ.1) GO TO 902 JUP=0 2 JLO=JUP+1 JUP=JUP+NRANG2 IUP=0 3 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) GO TO 3 IF(MCFGP.EQ.0) GO TO 41 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) 41 IF(MCONHP.GT.IDMTST(38)) CALL RECOV1(38,MCONHP) READ(ITAPE1) (DUMMY(I),I=1,MCONHP) READ(ITAPE1) (DUMMY(I),I=1,MCONHP) IF(JUP.LT.NCONHP) GO TO 2 C IF(NCFGP.EQ.0) GO TO 81 IUP=0 43 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) GO TO 43 C 902 IF(MCFGP.EQ.0.OR.NCFGP.EQ.0) GO TO 81 NDIMEN=NRANG2 NTIMES=(NCFGP-1)/NDIMEN+1 I2=0 DO 80 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,MCONHP+MCFGP) READ(ITAPE1) ((DLS(I,J,2),J=NCONHP+II1,NCONHP+I2), * I=MCONHP+1,MCONHP+MCFGP) 80 CONTINUE 81 IF(LAM.EQ.1) GO TO 90 C C BRING IN BUTTLE MATRIX ELEMENTS C IF(NCFGP.GT.0) THEN NN=NCFGP*MCHAN IF(NN.GT.IDMTST(38)) CALL RECOV1(38,NN) READ(ITAPE1) (DUMMY(I),I=1,NN) READ(ITAPE1) (DUMMY(I),I=1,NN) ENDIF IF(NCONHP.GT.IDMTST(38)) CALL RECOV1(38,NCONHP) DO 105 IB=1,MCHAN READ(ITAPE1) (DUMMY(I),I=1,NCONHP) 105 READ(ITAPE1) (DUMMY(I),I=1,NCONHP) IF(MCFGP.GT.0) THEN MM=NCHAN*MCFGP IF(MM.GT.IDMTST(38)) CALL RECOV1(38,MM) READ(ITAPE1) (DUMMY(I),I=1,MM) READ(ITAPE1) (DUMMY(I),I=1,MM) ENDIF NN=NCHAN*MCHAN IF(NN.GT.IDMTST(38)) CALL RECOV1(38,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 DO 88 K=0,2 88 READ(ITAPE1) ((BLVC(I,J,K),J=1,MCHAN),I=1,NCHAN) C 90 RETURN END C********************************************************************* SUBROUTINE DJZERO(JI,JF) 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 IMPLICIT REAL*8(A-H,O-Z) PARAMETER(L18P= 8-1) PARAMETER (LL83L84= 400000/2, LL85L86=98000000/4) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=(LL83L84+LL85L86*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL82=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD2+1) COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ DJ(LL83L84,2),DJBC(LL85L86,2),DJCB(LL85L86,2), * DJBB(5000,5000,2),DLS(5000,5000,2),DUM2(LL82) COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/LRPOT/ BLVC( 520, 520,0:L18P), BJLVC( 492, 492,0:L18P) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/RECOV / IPLACE,IDMTST(50) C MJCHA=JCH(JI) NJCHA=JCH(JF) KMCFGP=JCFG(JI) JNCFGP=JCFG(JF) IF(LAM.EQ.1) GO TO 300 C NJBLOC=NRANG2*NRANG2*MJCHA IF(2*NJBLOC.GT.IDMTST(40)) CALL RECOV1(40,2*NJBLOC) DO 1 K=1,NJBLOC DJ(K,1)=0.0 1 DJ(K,2)=0.0 KREC1=1 DO 3 K=1,NJCHA CALL DA2(2,KREC1,IDISC2,NJBLOC,DJ(1,1)) CALL DA2(2,KREC1,IDISC2,NJBLOC,DJ(1,2)) 3 CONTINUE C MCONHP=NRANG2*MJCHA NCONHP=NRANG2*NJCHA NBC=MAX(MCONHP,NCONHP)*MAX(KMCFGP,JNCFGP) IF(4*NBC.GT.IDMTST(46)) CALL RECOV1(46,4*NBC) DO 100 I=1,NBC DJCB(I,1)=0.0 DJCB(I,2)=0.0 DJBC(I,1)=0.0 100 DJBC(I,2)=0.0 C 300 NBB=MAX(KMCFGP,JNCFGP) IF(NBB.GT.IDMTST(39)) CALL RECOV1(39,NBB) DO 600 I=1,JNCFGP DO 400 J=1,KMCFGP DJBB(J,I,1)=0.0 400 DJBB(J,I,2)=0.0 600 CONTINUE C NC=MAX(MJCHA,NJCHA) IF(NC.GT.IDMTST(35)) CALL RECOV1(35,NC) DO 800 K=0,3 DO 800 J=1,MJCHA DO 800 I=1,NJCHA 800 BJLVC(I,J,K)=.0 RETURN END C*********************************************************************** SUBROUTINE DMES(LPOSI,LPOSF,MJCHA,NJCHA,KMCFGP,JNCFGP,SGN,RAC) 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 SGN.NE.0 PHASE IF LS MATRIX BLOCK IS TO BE TRANSPOSED (SWITCH=T) C RAC = RACAH AND ANGULAR FACTOR DEFINED IN RECUD. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL SWITCH PARAMETER(L18P= 8-1, LL83L84= 400000/2, LL85L86=98000000/4) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=(LL83L84+LL85L86*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL82=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD2+1) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ DJ(LL83L84,2),DJBC(LL85L86,2),DJCB(LL85L86,2), * DJBB(5000,5000,2),DLS(5000,5000,2),DUM2(LL82) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/LRPOT/ AC( 520, 520),BLVC( 520, 520,L18P), * AJC( 492, 492),BJLVC( 492, 492,L18P) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/POTORB/ PV(9999),QV(9999),ICHAN(9999),IICHAN(9999), * NTERM( 492),MTERM( 492) COMMON/RECOV / IPLACE,IDMTST(50) C 1000 FORMAT(/42X,'SUBROUTINE DMES(LPOSI,LPOSF =',2I3,')'/42X,15(1H-)) C IF(IBUG5.GT.0) PRINT 1000, LPOSI,LPOSF SWITCH = SGN.NE.0.0 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.IDMTST(39)) CALL RECOV1(39,IGIN) IFIN=JNCFGP+NCFGP INIT=JNCFGP+1 IF(IFIN.GT.IDMTST(39)) CALL RECOV1(39,IFIN) IF=NCONHP-JNCFGP IG=MCONHP-KMCFGP IF(LAM.EQ.1) GO TO 902 KAB2=NRANG2*NRANG2 C C BEGIN LOOP OVER CHANNELS COUPLED IN FINAL STATE C J1=0 KREC1=1 DO 17 J=1,NJCHA KREC2=KREC1 NTERMJ=NTERM(J) IF(NTERMJ.EQ.0) THEN CALL DA2(0,KREC1,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(0,KREC1,IDISC2,KAB2*MJCHA,DJ(1,2)) GO TO 17 ENDIF CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,2)) DO 16 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 15 I=1,MJCHA MTERMI=MTERM(I) IF(MTERMI.EQ.0) GO TO 15 DO 14 IM=1,MTERMI IPOS=IICHAN(IM+I1) ILO=(IPOS-1)*NRANG2 SUM = QV(IM+I1)*SUM1*RAC DO 8 IL=1,NRANG2 ILL=ILO+IL KAB11=((I-1)*NRANG2+IL-1)*NRANG2 IF(SWITCH) THEN DO 107 JL=1,NRANG2 DJ(KAB11+JL,1) = DJ(KAB11+JL,1) + DLS(JLO+JL,ILL,1)*SUM*SGN 107 DJ(KAB11+JL,2) = DJ(KAB11+JL,2) - DLS(JLO+JL,ILL,2)*SUM *SGN ELSE DO 7 JL=1,NRANG2 DJ(KAB11+JL,1)=DJ(KAB11+JL,1)+SUM*DLS(ILL,JLO+JL,1) 7 DJ(KAB11+JL,2)=DJ(KAB11+JL,2)+SUM*DLS(ILL,JLO+JL,2) ENDIF 8 CONTINUE IF(SWITCH) THEN AJC(J,I) = SUM*AC(IPOS,JPOS)*SGN + AJC(J,I) BJLVC(J,I,3) = BJLVC(J,I,3) - SUM*AC(IPOS,JPOS)*SGN BJLVC(J,I,1)=BJLVC(J,I,1)+SUM*BLVC(IPOS,JPOS,1)*SGN BJLVC(J,I,2)=BJLVC(J,I,2)-SUM*BLVC(IPOS,JPOS,2) *SGN 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 14 CONTINUE 15 I1=I1+MTERMI 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) GO TO 16 SUM=SUM1*RAC DO 10 IL=IMIT,IGIN KAB21=((IL-1)*NJCHA+J-1)*NRANG2 IF(SWITCH) THEN DO 109 JL=1,NRANG2 DJCB(KAB21+JL,1) = DJCB(KAB21+JL,1)+SUM*DLS(JLO+JL,IL+IG,1)*SGN 109 DJCB(KAB21+JL,2) = DJCB(KAB21+JL,2)-SUM*DLS(JLO+JL,IL+IG,2)*SGN ELSE DO 9 JL=1,NRANG2 DJCB(KAB21+JL,1)=DJCB(KAB21+JL,1)+SUM*DLS(IL+IG,JLO+JL,1) 9 DJCB(KAB21+JL,2)=DJCB(KAB21+JL,2)+SUM*DLS(IL+IG,JLO+JL,2) ENDIF 10 CONTINUE 16 CONTINUE CALL DA2(2,KREC2,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(2,KREC2,IDISC2,KAB2*MJCHA,DJ(1,2)) 17 J1=J1+NTERMJ 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) GO TO 40 I1=0 DO 26 I=1,MJCHA MTERMI=MTERM(I) IF(MTERMI.EQ.0) GO TO 26 DO 25 IM=1,MTERMI IPOS=IICHAN(IM+I1) ILO=(IPOS-1)*NRANG2 SUM = QV(IM+I1)*RAC DO 23 JL=INIT,IFIN KAB21=((JL-1)*MJCHA+I-1)*NRANG2 IF(SWITCH) THEN DO 22 IL=1,NRANG2 DJBC(KAB21+IL,1)=DJBC(KAB21+IL,1)+SUM*DLS(JL+IF,ILO+IL,1)*SGN 22 DJBC(KAB21+IL,2)=DJBC(KAB21+IL,2)-SUM*DLS(JL+IF,ILO+IL,2) *SGN ELSE DO 24 IL=1,NRANG2 DJBC(KAB21+IL,1)=DJBC(KAB21+IL,1)+SUM*DLS(ILO+IL,JL+IF,1) 24 DJBC(KAB21+IL,2)=DJBC(KAB21+IL,2)+SUM*DLS(ILO+IL,JL+IF,2) ENDIF 23 CONTINUE 25 CONTINUE 26 I1=I1+MTERMI C C CONSIDER BOUND BOUND CONTRIBUTION (DIRECT MAPPING) C 902 IF(MCFGP.EQ.0) GO TO 40 IF(NCFGP.EQ.0) GO TO 40 DO 30 JL=INIT,IFIN IF(SWITCH) THEN DO 28 IL=IMIT,IGIN DJBB(IL,JL,1) = DLS(JL+IF,IL+IG,1)*RAC*SGN 28 DJBB(IL,JL,2) = -DLS(JL+IF,IL+IG,2)*RAC *SGN ELSE DO 29 IL=IMIT,IGIN DJBB(IL,JL,1)=DLS(IL+IG,JL+IF,1)*RAC 29 DJBB(IL,JL,2)=DLS(IL+IG,JL+IF,2)*RAC ENDIF IF(IBUG5.GT.0) PRINT 99, IMIT,JL, (DJBB(I,JL,1),I=IMIT,IGIN) 99 FORMAT(' IMIT,JL, DJBB = ',2I3,(T26,5F10.5)) 30 CONTINUE C 40 RETURN END C*********************************************************************** SUBROUTINE DMOUT(JI,JF) 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 IMPLICIT REAL*8(A-H,O-Z) CHARACTER*8 TYPE C NEW PARAMETER(L18P=MAX( 8-1,2)) PARAMETER(L18P= 8-1, LL83L84= 400000/2, LL85L86=98000000/4) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=(LL83L84+LL85L86*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL82=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD2+1) COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ DJ(LL83L84,2),DJBC(LL85L86,2),DJCB(LL85L86,2), * DJBB(5000,5000,2),DLS(5000,5000,2),DUM2(LL82) COMMON/CLEB/ CGC( 45),MAXM1 COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/LRPOT/ BLVC( 520, 520,0:L18P), BJLVC( 492, 492,0:L18P) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/RECOV/ IPLACE,IDMTST(50) COMMON/SCRACH/DUMMY(1999900) C 1000 FORMAT(///22X,48(1H*)/22X, *48H*** DEBUGGING PRINTOUT FROM SUBROUTINE DMOUT ***/22X,48(1H*)/) 1001 FORMAT(/10X,64(1H*)/) 1002 FORMAT(//' MATRICES AJC AND BJLVCC (MAXM1 =',I4,')'/) 1003 FORMAT(I5,(T6,9F14.7)) 1005 FORMAT(/' INITIAL CHANNEL',I3,' FINAL CHANNEL',I3//5X,71HCONTINUU *M-CONTINUUM DIPOLE LENGTH MATRIX ELEMENTS WRITTEN TO RECUD TAPE//) 1006 FORMAT (/5X,73HCONTINUUM-CONTINUUM DIPOLE VELOCITY MATRIX ELEMENTS 1 WRITTEN TO RECUD TAPE//) 1007 FORMAT(/' FINAL CHANNEL',I4//5X,67HCONTINUUM-BOUND DIPOLE LENGTH M *ATRIX ELEMENTS WRITTEN TO RECUD TAPE//) 1008 FORMAT(/5X,69HCONTINUUM-BOUND DIPOLE VELOCITY MATRIX ELEMENTS WRIT *TEN TO RECUD TAPE//) 1009 FORMAT(/' INITIAL CHANNEL',I4 //5X,67HBOUND-CONTINUUM DIPOLE LENGT *H MATRIX ELEMENTS WRITTEN TO RECUD TAPE//) 1010 FORMAT(/5X,69HBOUND-CONTINUUM DIPOLE VELOCITY MATRIX ELEMENTS WRIT *TEN TO RECUD TAPE//) 1011 FORMAT(//5X, 'BOUND-BOUND DIPOLE ',A8,' MATRIX ELEMENTS WRITTEN TO * RECUD TAPE'//(T6,9I14)) C IF(IBUG5.GT.0) WRITE(IWRITE,1000) MJCHA=JCH(JI) NJCHA=JCH(JF) KMCFGP=JCFG(JI) JNCFGP=JCFG(JF) NCONHP=NRANG2*NJCHA IF(LAM.EQ.1) GO TO 902 C MCONHP=NRANG2*MJCHA MX=NRANG2*MAX(NRANG2,KMCFGP,JNCFGP) IF(MX.GT.IDMTST(38)) CALL RECOV1(38,MX) KAB2=NRANG2*NRANG2 KREC1=1 C DO 30 J=1,NJCHA CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,1)) CALL DA2(1,KREC1,IDISC2,KAB2*MJCHA,DJ(1,2)) 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 10 I=1,MJCHA KAB11=(I-1)*KAB2 DO 7 LV=1,2 7 WRITE(ITAPE4) (DJ(KAB11+K,LV),K=1,KAB2) IF(IBUG5.LE.0) GO TO 10 WRITE(IWRITE,1005) I,J DO 9 LV=1,2 IF(LV.EQ.2) WRITE(IWRITE,1006) KAB11=(I-1)*KAB2 DO 8 III=1,NRANG2 WRITE(IWRITE,1003) III,(DJ(K+KAB11,LV),K=1,NRANG2) 8 KAB11=KAB11+NRANG2 9 WRITE(IWRITE,1003) 10 CONTINUE IF(KMCFGP.EQ.0) GO TO 17 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 14 LV=1,2 DO 13 IL=1,KMCFGP MAP=(IL-1)*NRANG2 K=((IL-1)*NJCHA+J-1)*NRANG2 DO 12 JL=1,NRANG2 12 DUMMY(JL+MAP)=DJCB(JL+K,LV) 13 CONTINUE 14 WRITE(ITAPE4) (DUMMY(K),K=1,NRANG2*KMCFGP) IF(IBUG5.LE.0) GO TO 17 WRITE(IWRITE,1007) J DO 16 LV=1,2 IF(LV.EQ.2) WRITE(IWRITE,1008) DO 15 III=1,KMCFGP MAP=((III-1)*NJCHA+J-1)*NRANG2 15 WRITE(IWRITE,1003) III,(DJCB(K+MAP,LV),K=1,NRANG2) 16 WRITE(IWRITE,1003) 17 IF(MCONHP.GT.IDMTST(38)) CALL RECOV1(38,MCONHP) DO 18 K=1,MCONHP 18 DUMMY(K)=.0 DO 19 LV=1,2 19 WRITE(ITAPE4) (DUMMY(K),K=1,MCONHP) 30 CONTINUE IF(JNCFGP.EQ.0) GO TO 81 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 50 I=1,MJCHA DO 36 LV=1,2 DO 34 IL=1,NRANG2 MAP=(IL-1)*JNCFGP DO 32 JL=1,JNCFGP K=((JL-1)*MJCHA+I-1)*NRANG2+IL 32 DUMMY(JL+MAP)=DJBC(K,LV) 34 CONTINUE 36 WRITE(ITAPE4) (DUMMY(K),K=1,NRANG2*JNCFGP) IF(IBUG5.LE.0) GO TO 50 WRITE(IWRITE,1009) I DO 49 LV=1,2 IF(LV.EQ.2) WRITE(IWRITE,1010) DO 48 III=1,NRANG2 KAB21=(I-1)*NRANG2+III-MCONHP 48 WRITE(IWRITE,1003) III,(DJBC(KAB21+MCONHP*K,LV),K=1,JNCFGP) 49 WRITE(IWRITE,1003) 50 CONTINUE C C PUT OUT BOUND-BOUND BLOCKS (AS FOR BC JNCFGP IS INNER LOOP:) C 902 IF(KMCFGP.EQ.0.OR.JNCFGP.EQ.0) GO TO 81 NDIMEN=NRANG2 NTIMES=(JNCFGP-1)/NDIMEN+1 I2=0 DO 80 II=1,NTIMES II1=I2+1 I2=MIN(II*NDIMEN,JNCFGP) DO 61 K=1,2 61 WRITE(ITAPE4) ((DJBB(I,J,K),J=II1,I2),I=1,KMCFGP) IF(IBUG5.LE.0) GO TO 80 TYPE=' LENGTH ' DO 69 LV=1,2 WRITE(IWRITE,1011) TYPE, (K,K=II1,I2) TYPE='VELOCITY' DO 66 I=1,KMCFGP 66 WRITE(IWRITE,1003) I,(DJBB(I,J,LV),J=II1,I2) 69 WRITE(IWRITE,1003) 80 CONTINUE C C PUT OUT BUTTLE MATRIX ELEMENTS (ZEROS) C 81 IF(LAM.EQ.0) GO TO 90 MX1=MJCHA*MAX(JNCFGP,NJCHA) MX2=NJCHA*MAX(KMCFGP,NRANG2) MX=MAX(MX1,MX2) IF(MX.GT.IDMTST(38)) CALL RECOV1(38,MX) DO 82 K=1,MX 82 DUMMY(K)=0. IF(JNCFGP.GT.0) THEN DO 83 K=1,2 83 WRITE(ITAPE4) (DUMMY(J),J=1,JNCFGP*MJCHA) ENDIF J=2*MJCHA DO 84 I=1,J 84 WRITE(ITAPE4) (DUMMY(K),K=1,NCONHP) IF(KMCFGP.GT.0) THEN DO 85 J=1,2 85 WRITE(ITAPE4) (DUMMY(K),K=1,NJCHA*KMCFGP) ENDIF DO 86 J=1,2 86 WRITE(ITAPE4) (DUMMY(K),K=1,NJCHA*MJCHA) C C PUT OUT LONG RANGE COEFFS ETC C WRITE(ITAPE4) MAXM1,(CGC(M),M=1,MAXM1) DO 87 K=0,3 87 WRITE(ITAPE4) ((BJLVC(I,J,K),J=1,MJCHA),I=1,NJCHA) IF(IBUG5.LE.0) GO TO 90 WRITE(IWRITE,1002) MAXM1 DO 89 K=0,3 WRITE(IWRITE,1003) K DO 89 J=1,MJCHA 89 WRITE(IWRITE,1003) J,(BJLVC(I,J,K),I=1,NJCHA) C 90 RETURN END C*********************************************************************** SUBROUTINE FIN2BB(N1,L1,N2,L2,N3,L3,N4,L4,LAM,VAL) C C - FINDS A BOUND-BOUND RADIAL magnetic INTEGRAL Nlam or Vlam: C parameter (LL53= 5* 5,LL54= 5* 45, A2O4=.000013312) PARAMETER (LLBB=4250,LLBC=420000,LL03=504,LL04=912) CHARACTER*2 TYPE(-1:1) COMMON/BASICR/NELC,MAXNC( 45),MAXNHF( 45),MAXNLG( 45),LRANG1,NZ COMMON/INSTO0/STORBB(LLBB),STORBC(LLBC) COMMON/INSTO3/ICTBB( 5, 5,LL53) 2 ,ISTBB1(LL04),ISTBB2(LL04) * ,ICTBC( 5, 5,LL54),ISTBC1(LL03),ISTBC2(LL03) COMMON/INSTO7/NBUG,INK1,INK4,NCNT,NMIN(0: 5) DATA IRUN,TYPE/0,'-(','N(','V('/ NLG(n,l) = ((n-1)*n)/2+l+1 C C C OBSERVE SYMMETRIES OF N AND V AS EXPLOITED IN RSTG1 C M1 = N1 K1 = L1 M2 = N2 K2 = L2 M3 = N3 K3 = L3 M4 = N4 K4 = L4 K = MOD(K1+K3+LAM,2) IF(NLG(M4,K4).GT.NLG(M2,K2)) CALL INTECH(M2,K2,M4,K4,0) IF(K.EQ.0.AND.NLG(M3,K3).GT.NLG(M1,K1)) CALL INTECH(M1,K1,M3,K3,0) C C LOCATE MK INTEGRAL (VIA ISTBB1 AND ISTBB2 for LAM) C M = 0 C tmp VAL = 9.E+9 -- if(LAM.ge.0) VAL = 9.E+9 '03/Nov12/Dec5-7 VAL = 0.0 INK = ICTBB(K1+1,K2+1,K3*LRANG1+1+K4) IF(INK.EQ.0) GO TO 27 12 IF(ISTBB1(INK)-LAM) 13,15,27 13 INK=INK+1 GO TO 12 15 IRUN = ISTBB2(INK) C DO 25 J1=NMIN(K1),MAXNHF(K1+1) do 24 J2=NMIN(K2),maxnhf(K2+1) do 23 J3=NMIN(K3),maxnhf(K3+1) do 22 J4=NMIN(K4),maxnhf(K4+1) C IF(NLG(J2,K2).lt.NLG(J4,K4)) go to 22 IF (K.EQ.0 .AND. NLG(J1,K1).lt.NLG(J3,K3)) go to 22 IRUN=IRUN+1 IF (J4.NE.M4.OR.J3.NE.M3.OR.J2.NE.M2.OR.J1.NE.M1) GO TO 22 VAL = STORBB(IRUN)*A2O4 !:alpha^2/4 IF(NCNT.LE.0) GO TO 30 ! controlled by IBUG2 -- see READTP! M = IRUN GO TO 29 22 continue 23 continue 24 continue 25 continue C 27 print "(35X,'FIN2BB: MK integral not found, IRUN =',I6,':')", IRUN K = -1 M = -1 * go to 29 * 28 if(IRUN.gt.100) go to 30 ! for testing 29 print "(I9,4X,A2,4(I3,I2),I4,')',F12.5,F18.9)",IRUN,TYPE(K), * n1,l1,n2,l2, n3,l3,n4,l4, LAM, (STORBB(J),VAL,J=IRUN,M) C 30 RETURN END C*********************************************************************** SUBROUTINE FIN2BC(N1,L1,N2,L2,N3,L3,N4,L4,LAM,ARR) C C - PICKS SPECIFIC BOUND-CONTINUUM MAGNETIC INTEGRALS ARR(1:NRANG2) C FROM ARRAY STORBC (N.LE.0 INDICATES THE CONTINUUM ORBITAL) C parameter(LL53= 5* 5,LL54= 5* 45, A2O4=.000013312) PARAMETER (LLBB=4250,LLBC=420000,LL03=504,LL04=912) DIMENSION ARR( 60) COMMON/BASICR/NELC,MAXNC( 45),MAXNHF( 45),MAXNLG( 45),LRANG1,NZ COMMON/BASICS/LRANG2,NRANG2 COMMON/INSTO0/STORBB(LLBB),STORBC(LLBC) COMMON/INSTO3/ICTBB( 5, 5,LL53) 2 ,ISTBB1(LL04),ISTBB2(LL04) * ,ICTBC( 5, 5,LL54),ISTBC1(LL03),ISTBC2(LL03) COMMON/INSTO7/NBUG,INK1,INK4,NCNT,NMIN(0: 5) C C NLG(n,l) = ((n-1)*n)/2+l+1 C C C MOVE ARGUMENTS OF THE 3 B ORBITALS ACCORDING TO STG1 STORAGE ORDER C M1 = N1 K1 = L1 M2 = N2 K2 = L2 M3 = N3 K3 = L3 M4 = N4 K4 = L4 K = 1-2*MOD(L1+L3+LAM,2) I = 0 INK = -1 IF (N1.LE.0) THEN CALL INTECH(M1,K1,M4,K4,0) CALL INTECH(M2,K2,M3,K3,0) I=1 IF(K.GT.0) I=2 ENDIF IF (N2.LE.0) THEN IF(I.NE.0) GO TO 25 CALL INTECH(M2,K2,M4,K4,0) I=2 ENDIF IF (N3.LE.0) THEN IF(I.NE.0) GO TO 25 CALL INTECH(M3,K3,M4,K4,0) call INTECH(M1,K1,M2,K2,0) ! out and in again '04Jun25 I=2 ENDIF IF (N4.LE.0) THEN IF(I.NE.0) GO TO 25 I=1 ENDIF IF (I.EQ.0) GO TO 25 ! no C orbital C IF(K.GT.0.AND.NLG(M1,K1).LT.NLG(M3,K3)) CALL INTECH(M3,K3,M1,K1,0) C C LOCATE MK INTEGRAL (VIA ISTBC1 AND ISTBC2 for LAM) C INK = ICTBC(K1+1,K2+1,LRANG1*K4+K3+1) IF(INK.EQ.0) GO TO 25 12 IF(ISTBC1(INK)-LAM) 13,15,25 13 INK=INK+1 GO TO 12 15 INK0 = ISTBC2(INK) C DO 24 J1=NMIN(K1),MAXNHF(K1+1) do 23 J2=NMIN(K2),maxnhf(K2+1) DO 22 J3=NMIN(K3),MAXNHF(K3+1) IF (J3.NE.M3 .OR. J2.NE.M2 .OR. J1.NE.M1) GO TO 22 C IF (K.GT.0 .AND. NLG(J1,K1).LT.NLG(J3,K3)) GO TO 22 DO 21 J=1,NRANG2 C I=1: CALL RS(N1,L1+1,N2,L2+1,N3,L3+1,MAXNHF(L+1)+N,L+1,LAM,K,VAL1) C I=2: CALL RS(N2,L2+1,N1,L1+1,MAXNHF(L+1)+N,L+1,N3,L3+1,LAM,K,VAL2) 21 ARR(J) = STORBC((J-1)*2+INK0+I)*A2O4 GO TO 27 22 INK0=2*NRANG2+INK0 23 continue 24 CONTINUE C 25 M=0 C DO 26 J=1,NRANG2;C 26 ARR(J)=9.E+9 print "(/35X,'FIN2BC: MK integral not found, INK =',I6,':')", INK ** print "(46X,'K1:K4, ICTBC:',4I3,I7)", K1,K2,K3,K4, INK cc print "(46X,'ICTBC(2,2,7:8) =',2I5)",ICTBC(2,2,7),ICTBC(2,2,8)!Jl8 ** if(INK.ne.0) go to 29 ** print "(17X,'ISTBC1 =',12I4,' ...')", (ISTBC1(J),J=21,32) **OK! print "( 5X,'ISTBC2 =',12I5,' ...')", (ISTBC2(J),J=21,32) **OK! print "(' STORBC =',6F11.5,' ...')", (STORBC(J),J=1,6) go to 29 C 27 IF(NCNT.LE.0) GO TO 30 M=MIN(8,NRANG2) 29 print "(I8,' K=',I2,4(I4,I2),I5,(T44,4F9.5))", INK0,K, * N1,L1,N2,L2,N3,L3,N4,L4, LAM, (ARR(J)/A2O4,J=1,M) print "(6X,'ex I=',I2,4(I4,I2),I5)",I,M1,K1,M2,K2,M3,K3,M4,K4,LAM C 30 RETURN END C*********************************************************************** SUBROUTINE FIN2CC(N1,L1,N2,L2,N3,L3,N4,L4,LAM,ARR) C C - PICKS CONTINUUM-CONTINUUM MAGNETIC INTEGRALS ARR(1:NRANG2,1:NR2) C FROM ARRAY STORCC (N.LE.0 INDICATES THE CONTINUUM ORBITALS) -MUST C EXIST FOR SYMMETRY PAIR (L,LP)=(LL1,LL3) OR BE FETCHED FROM DISK! C '04Jun21 adding V-cases (AbC'd) and (Abc'D) C PARAMETER (LL55=2* 5-1,LL56= 45+ 5, A2O4=.000013312) CHARACTER*1 LIT LOGICAL CRS,INV DIMENSION ARR( 60, 60), STORCC(800000) COMMON/BASICR/NELC,MAXNC( 45),MAXNHF( 45),MAXNLG( 45),LRANG1,NZ COMMON/BASICS/LRANG2,NRANG2 COMMON/INSTO7/NBUG,INK1,INK4,NCNT,NMIN(0: 5) COMMON/INSTOX/KDSK,MPOS, LDIR(0:99,2),JDSK(99,2) * ,ICTCCD( 5, 5,0:LL55,99),ICTCCE( 5, 5,0:LL56,99) SAVE LPOS, STORCC C NLG(n,l) = ((n-1)*n)/2+l C M1 = N1 K1 = L1 M2 = N2 K2 = L2 M3 = N3 K3 = L3 M4 = N4 K4 = L4 IT = -1 INK0 = -1 IRUN = 0 K = K1+K2+K3+K4 M = K - MAX(K1,K2,K3,K4) IF (M.EQ.0) GO TO 25 ! at least 3 s-orbitals! IF (MOD(K,2).NE.0) GO TO 25 ! parity violation K = 1-2*MOD(K1+K3+LAM+2,2) C C MAP ONTO ICTCC LABELS (FROM GEN2CC in STG1) C IF (N1.GT.0) THEN ! a... IF (N2.GT.0) GO TO 25 ! both BB IAD=-1 LIT='<' if(K.lt.0) then ! tempmod '06Jul26 IAD=0 LIT='>' endif IF (N3.GT.0) THEN ! direct IT=0 ELSE ! CC exchange IT=1 CALL INTECH(M4,K4,M3,K3,0) ENDIF ELSE ! A... IF (N2.LE.0) GO TO 25 ! both CC IAD=0 LIT='>' if(K.lt.0) then ! tempmod '06Jul26 (Jul30: NOT 21st!) IAD=-1 LIT='<' endif CALL INTECH(M2,K2,M1,K1,0) IF (N4.GT.0) THEN ! direct IT=0 CALL INTECH(M4,K4,M3,K3,0) ELSE ! exchange IT=1 ENDIF ENDIF C INV=K2.GE.K4 IF (INV) THEN CALL INTECH(M2,K2,M4,K4,0) CALL INTECH(M1,K1,M3,K3,0) ENDIF c evt IF (IT.EQ.0 .AND. K.GT.0.AND.NLG(M3,K3).GT.NLG(M1,K1)) c * CALL INTECH(M3,K3,M1,K1,0) C C RELOAD STORCC IF NECESSARY C IF (LDIR(0,1).EQ.K2 .AND. LDIR(0,2).EQ.K4) GO TO 10 DO 5 J=1,MPOS IF (LDIR(J,1).NE.K2 .OR. LDIR(J,2).NE.K4) GO TO 5 LPOS = J GO TO 6 5 CONTINUE print "(/35X,'FIN2CC: symmetry pair not found')" GO TO 26 6 M = JDSK(LPOS,1) IF(NCNT.GT.0) print * "(/' FIN2CC: LPOS,REC,length =',I4,I7,I8)",LPOS,M,JDSK(LPOS,2) C and check size of STORCC! CALL DA2(1,M,KDSK,JDSK(LPOS,2),STORCC) LDIR(0,1) = K2 LDIR(0,2) = K4 C C LOCATE MK INTEGRAL (EXCHANGE INTEGRAL IF IT=1) C 10 IF (IT.EQ.0) THEN INK0 = ICTCCD(K1+1,K3+1,LAM+1,LPOS) M = K3 ELSE INK0 = ICTCCE(K1+1,K3+1,LAM+1,LPOS) M = K4 ENDIF IF(INK0.LT.0) GO TO 25 C M = 1-2*MOD(K1+M+LAM+2,2) IRUN = INK0 DO 24 J1=NMIN(K1),MAXNHF(K1+1) do 23 J3=NMIN(K3),maxnhf(K3+1) CRS = K2.EQ.K4 * evt if (NLG(J1,K1).ge.NLG(J3,K3).and.M.GT.0) CRS=.TRUE. 11 DO 22 J=1,NRANG2 DO 21 JP=1,NRANG2 IRUN=IRUN+2 IF(M1.NE.J1) GO TO 21 IF(M3.NE.J3) GO TO 21 IF (CRS) THEN IF(INV) GO TO 18 ELSE IF(.not.INV) GO TO 18 ENDIF GO TO 21 18 VAL = STORCC(IRUN+IAD)*A2O4 19 IF(INV) THEN c out ARR(J,JP) = VAL ARR(JP,J) = VAL ! '06Jun19 ELSE ARR(J,JP) = VAL ! " c out ARR(JP,J) = VAL ENDIF if(J.eq.NRANG2 .and. JP.eq.NRANG2) GO TO 28 21 CONTINUE 22 CONTINUE 20 CRS=.NOT.CRS IF(CRS) GO TO 11 23 continue 24 CONTINUE C 25 print "(/35X,'FIN2CC: MK integral not found, INK =',I6,':')",INK0 print "(43X,'K1:K4,ICTCC,IT=',4I3,I6,I3)", K1,K2,K3,K4, INK0,IT 26 M=0 C DO 27 JP=1,NRANG2; DO 27 J=1,NRANG2; 27 ARR(J,JP) = 1.E9 ARR(1,1) = 0. **OK! if(INK0.EQ.0) print"(' STORCC =',6F11.5,' ...')",(STORCC(J),J=1,6) go to 29 C 28 M=4 IF(NCNT.LE.0) GO TO 30 ! controlled by IBUG2 -- see READTP! 29 print "(I8,' K=',I2,4(I4,I2),I5,(T44,4F9.5))", INK0, K, * N1,L1,N2,L2,N3,L3,N4,L4, LAM, ((ARR(J,JP)/A2O4,J=1,M),JP=1,M) print"(' ex IT,LX=',I2,A1,L1,4(I4,I2),I5)", * IT,LIT,CRS, M1,K1,M2,K2,M3,K3,M4,K4,LAM C 30 RETURN END C*********************************************************************** SUBROUTINE FINBBR(N1,N2,L,RAD) C C FINDS A BOUND-BOUND RADIAL SPIN-ORBIT INTEGRAL: C N1,N2 ARE THE PRINCIPAL QUANTUM NUMBERS C L IS THE ANGULAR MOMENTUM QUANTUM NUMBER C RAD IS THE VALUE OF THE APPROPRIATE RADIAL INTEGRAL C C IMPLICIT REAL*8(A-H,O-Z) PARAMETER(L21=(( 60+1)* 60)/2) COMMON/INSTO8/ IST1( 5),IST2( 5),IRK5,IRK6,IRK7 COMMON/INSTO9/ RSPOR1( 56),RSPOR2( 820),RSPOR3(L21,2: 45) C J=L+1 IF(N1.GE.N2) THEN K=((N1-J+1)*(N1-J))/2+N2 ELSE K=((N2-J+1)*(N2-J))/2+N1 ENDIF K = K+IST1(J)-J RAD = RSPOR1(K) RETURN END C*********************************************************************** SUBROUTINE HJZERO(JPOS) 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 IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ HJ( 400000),HJBC(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/LRPOT/ CF( 520, 520, 8),CFJ( 492, 492, 8) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/RECOV / IPLACE,IDMTST(50) C C INITIALISE THE J-HAMILTONIAN BLOCKS C NJCHA=JCH(JPOS) KAB2=NRANG2*NRANG2 NJBLOC=KAB2*NJCHA IF(NJBLOC.GT.IDMTST(40)) CALL RECOV1(40,NJBLOC) DO 1 K=1,NJBLOC 1 HJ(K)=0.0 KREC1=1 DO 3 K=1,NJCHA CALL DA2(2,KREC1,IDISC2,KAB2*K,HJ) 3 CONTINUE C C INITIALISE THE BOUND-CONTINUUM J-HAMILTONIAN MATRIX BLOCKS C NUM=IDMTST(39) DO 6 K=1,IDMTST(46) 6 HJBC(K)=0.0 C C INITIALISE THE BOUND-BOUND J-HAMILTONIAN BLOCKS. C DO 8 J=1,NUM DO 7 I=1,NUM 7 HJBB(I,J)=0.0 8 CONTINUE C C INITIALISE THE LONG-RANGE POTENTIAL COEFFICIENTS C DO 9 K=1, 8 DO 9 J=1,NJCHA DO 9 I=1,NJCHA 9 CFJ(I,J,K)=0.0 12 RETURN END C*********************************************************************** SUBROUTINE INTECH(N1,L1,N2,L2,I) C C INTERCHANGE TWO SETS OF NUMBERS (N1,L1) AND (N2,L2) C I= 1 INTERCHANGE N1 AND N2 ONLY C I=-1 INTERCHANGE L1 AND L2 ONLY C I= 0 INTERCHANGE BOTH N1,N2 AND L1,L2 C IF(I.GE.0) THEN K=N1 N1=N2 N2=K ENDIF IF(I.LE.0) THEN K=L1 L1=L2 L2=K ENDIF C RETURN END C*********************************************************************** SUBROUTINE JLRC(JRGL,J1,J2,J3,J4,J5,J6,J7,COEF) 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 OF THE TWO RACAH COEFFICIENTS. THE ANGULAR C MOMENTUM QUANTUM NUMBERS ARE TWICE THEIR ACTUAL VALUES. C C IMPLICIT REAL*8(C,F,R,S) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 C 1000 FORMAT(/ 38X,16HSUBROUTINE JLRC(,8I3,')'/38X,15(1H-)/ * 25H MULTIPLICATIVE FACTOR =,F12.7/ * 2(25H RACAH COEFFICIENT =,F12.7/), * 25H RECOUPLING COEFFICIENT =,F12.7) C J8=1 J9=JRGL C C CALCULATE THE MULTIPLICATIVE FACTOR C COEF1=SQRT(REAL((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.1) PRINT 1000, JRGL,J1,J2,J3,J4,J5,J6,J7, * COEF1, R1,R2, COEF RETURN END C*********************************************************************** SUBROUTINE LSCONT(LPOS,NJCHA,JNCFGP) C C SUPPLIES 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 IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ HJ( 400000),HJBC(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/LRPOT / CF( 520, 520, 8),CFJ( 492, 492, 8) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/POTORB/ PV(9999),PPV(9999),ICHAN(9999),MCHAN(9999), * NTERM( 492),NNTERM( 492) C tst FOR HANDLING J->J'=J, RUB'95Jan13/15/25-28, redundant 2006May02-4: C tst COMMON /jstate/...ICHECK /jchan/ljp( 492),kj( 492),JTARG( 492) C 1000 FORMAT(//52X,17HSUBROUTINE LSCONT/52X,17(1H-)/ * /41X,32HTRANSFORMED HAMILTONIAN MATRICES/42X,32(1H-)) 1006 FORMAT(//6X,58HCONTINUUM-CONTINUUM CONTRIBUTION TO H MATRIX FROM C CHANNELS,I4,4H AND,I4/) 1007 FORMAT(I5,(T6,5F14.6)) 1009 FORMAT(//46X,30HTRANSFORMED COEFFICIENT MATRIX/46X,30(1H-)) 1010 FORMAT(/ 3H K=,I1/) 1011 FORMAT(I5,(T6,8F9.6)) 1012 FORMAT(/6X,63HBOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN MATRIX F FROM CHANNEL,I4/) 1013 FORMAT (/6X,65HBOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM * CONFIGURATION/) 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 KAB2=NRANG2*NRANG2 I2=0 KREC1=1 DO 17 I=1,NJCHA KREC2=KREC1 NTERMI=NTERM(I) IF(NTERMI.EQ.0) THEN CALL DA2(0,KREC1,IDISC2,KAB2*I,HJ) GO TO 17 ENDIF CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) J1=0 DO 16 J=1,I NTERMJ=NTERM(J) IF(NTERMJ.EQ.0) GO TO 16 C tst ORT = jj(jtarg(j)).eq.jj(K1).and.jtarg(j).ne.K1[=JTARG(I)] DO 15 IM=1,NTERMI IC=ICHAN(IM+I2) DO 14 JM=1,NTERMJ JC=ICHAN(JM+J1) SUM=PV(JM+J1)*PV(IM+I2) KAB12=(MIN(IC,JC)-1)*NRANG2 KAB13=(MAX(IC,JC)-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 11 JL=1,NRANG2 C tst TMP=HLS(JL+KAB12,JL+KAB13) KAB11=((J-1)*NRANG2+JL-1)*NRANG2 C tst IF(IC-JC) 6,8,9 ! trapping T[CC](,)-sensitive Jpi->J'pi'=Jpi IF (IC.LT.JC) THEN DO 7 IL=1,NRANG2 7 HJ(KAB11+IL)=HJ(KAB11+IL)+SUM*HLS(KAB12+IL,KAB13+JL) ELSE DO 10 IL=1,NRANG2 10 HJ(KAB11+IL)=HJ(KAB11+IL)+SUM*HLS(KAB12+JL,KAB13+IL) ENDIF C tst '06May04 after BOUNDJ DO 82: cancelling redundant tests like C IF( ICHECK.GT.3/1 .AND. ICHECK.LE.5) GO TO 14, ...=TMP 11 CONTINUE 12 IF (LAMAX.EQ.0) GO TO 14 DO 13 K=1,LAMAX 13 CFJ(I,J,K)=SUM*CF(IC,JC,K)+CFJ(I,J,K) C J,I,K NOW DEALT WITH IN DO 3 OF SR WRITAP '95FEB08 C PV AND THUS SUM NOW CORRECTLY USING TCC'S -- RUB'94MAR21-23W. 14 CONTINUE 15 CONTINUE 16 J1=J1+NTERMJ CALL DA2(2,KREC2,IDISC2,KAB2*I,HJ) IF (NCFGP.EQ.0) GO TO 17 C C APPLY THE TRANSFORMATION TO THE BOUND-CONTINUUM J-HAMILTONIAN C BLOCKS C DO 20 J=1,NCFGP KAB21=((J-1+JNCFGP)*NJCHA+I-1)*NRANG2 DO 19 K1=1,NTERMI KAB22=(ICHAN(K1+I2)-1)*NRANG2 DO 18 K=1,NRANG2 18 HJBC(KAB21+K)= HLS(KAB22+K,NCONHP+J)*PV(K1+I2) + HJBC(KAB21+K) 19 CONTINUE 20 CONTINUE 17 I2=I2+NTERMI C C APPLY THE TRANSFORMATION TO THE BOUND-BOUND J-HAMILTONIAN MATRIX C INIT=JNCFGP+1 IFIN=JNCFGP+NCFGP IF (NCFGP.EQ.0) GO TO 24 K=NCONHP-JNCFGP DO 23 I=INIT,IFIN DO 22 J=I,IFIN 22 HJBB(I,J)=HLS(I+K,J+K) 23 CONTINUE C C C PRINT OUT DEBUG INFORMATION IF REQUIRED C 24 IF(IBUG7.LE.0) GO TO 39 PRINT 1000 IF(IBUG7.LT.2) GO TO 35 C C WRITE OUT THE TRANSFORMED CONTINUUM-CONTINUUM J-HAMILTONIAN C MATRIX BLOCKS C KREC1=1 DO 28 I=1,NJCHA CALL DA2(1,KREC1,IDISC2,KAB2*I,HJ) JUP=NRANG2 DO 27 J=1,I PRINT 1006, I,J DO 26 K=1,NRANG2 IF(J.EQ.I) JUP=K KAB11=((J-1)*NRANG2+K-1)*NRANG2 26 PRINT 1007, K, (HJ(KAB11+J1),J1=1,JUP) 27 CONTINUE 28 CONTINUE C C WRITE OUT THE TRANSFORMED BOUND-CONTINUUM J-HAMILTONIAN MATRIX C BLOCKS C 29 IF(IFIN.LT.INIT) GO TO 35 IF(IBUG7.LT.3) GO TO 35 DO 32 K=1,NJCHA PRINT 1012, K JUP=JNCFGP 30 JLO=JUP+1 JUP=MIN(JUP+5,IFIN) DO 31 I=1,NRANG2 KAB21=(K-1-NJCHA)*NRANG2+I 31 PRINT 1007, I, (HJBC(KAB21+NRANG2*NJCHA*J),J=JLO,JUP) PRINT '()' IF(JUP.LT.IFIN) GO TO 30 32 CONTINUE C C WRITE OUT THE TRANSFORMED BOUND-BOUND MATRIX BLOCKS C 33 IF(IBUG7.LT.4) GO TO 35 PRINT 1013 DO 34 I=INIT,IFIN 34 PRINT 1007, I, (HJBB(I,J),J=INIT,IFIN) C C WRITE OUT THE TRANSFORMED LONG RANGE POTENTIAL COEFFICIENTS C 35 IF(LAMAX.EQ.0) GO TO 39 PRINT 1009 DO 38 K=1,LAMAX PRINT 1010, K DO 37 I=1,NJCHA 37 PRINT 1011, I, (CFJ(I,J,K),J=1,I) 38 CONTINUE 39 RETURN END C*********************************************************************** SUBROUTINE LSJCUP(JPOS,LPOS,NTERMI) 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 IMPLICIT REAL*8(A-H,O-Z) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/CHAN/ L2P( 520),LSTARG( 520) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/JCHAN /LJP( 492),KJ( 492),JTARG( 492) COMMON/JSTATE/ENAT( 408),T( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK COMMON/POTORB/ PV(9999),PPV(9999),ICHAN(9999),MCHAN(9999), * NTERM( 492),NNTERM( 492) COMMON/RECOV / IPLACE,IDMTST(50) COMMON/STATE/ ENER( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST C 1001 FORMAT(/9H NTERMI=,(T10,14I5)) 1003 FORMAT(' (ICHAN,COEF) =',(T16,4(I4,F11.7))) 1004 FORMAT(/32H **ERROR** IN LSVALU ARRAY STATE,I4, * 33H HAS MORE THAN ONE INDEX THE SAME) C JRGL=J2(JPOS) NJCHA=JCH(JPOS) LRGL=L2(LPOS) NSPN=LS(LPOS) NCHAN=LCH(LPOS) NTERMI=0 C DO 4 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 3 IP=1,NCHAN IF(L2P(IP).NE.L1) GO TO 3 ITARG=LSTARG(IP) C C CHECK THE TRIANGULAR RELATIONS C IF(ABS(LAT(ITARG)-ISAT(ITARG)).GT.J1) GO TO 3 IF(LAT(ITARG)+ISAT(ITARG).LT.J1) GO TO 3 C C SCAN THE LSVALU ARRAY TO SEE IF THERE IS A CORRESPONDING C TCC FOR THIS TERM C ITEST=0 DO 2 J=1,JNTCON(II) IF(LSVALU(II,J).NE.ITARG) GO TO 2 ITEST=ITEST+1 IF(ITEST.LE.1) GO TO 1 PRINT 1004, II STOP C C EVALUATE THE JL-RECOUPLING COEFFICIENT C 1 CALL JLRC(JRGL,LAT(ITARG),ISAT(ITARG),J1,K1,L1,LRGL,NSPN,RC) C C IF THE RECOUPLING COEFFICIENT IS ZERO THERE IS NO NEED C TO APPLY THE TRANSFORMATION IN THIS CHANNEL. C IF(RC.EQ.0.0) GO TO 2 NUM=NUM+1 NTERMI=NTERMI+1 IF(NTERMI.GT.IDMTST(38).OR.NTERMI.GT.IDMTST(37)) GO TO 2 c tst PPV(NTERMI)=RC PV(NTERMI)=T(II,J)*RC ICHAN(NTERMI)=IP 2 CONTINUE 3 CONTINUE 4 NTERM(I)=NUM C C SIZE CHECK C IF(NTERMI.GT.IDMTST(38)) CALL RECOV1(38,NTERMI) IF(NTERMI.GT.IDMTST(37)) CALL RECOV1(37,NTERMI) IF(IBUG5.LE.1) GO TO 5 PRINT 1001, (NTERM(I),I=1,NJCHA) PRINT 1003, (ICHAN(I),PV(I),I=1,NTERMI) 5 RETURN END C*********************************************************************** LOGICAL FUNCTION LSJTRI(L,IS,LP,J,JP) C C CHECKS WHETHER L, IS AND J CAN FORM A TRIANGLE C AND THAT THE PARITIES LP AND JP ARE EQUAL. C L,IS,J ARE INPUT AS TWICE THEIR ACTUAL ANGULAR QUANTUM NUMBERS C LSJTRI=.FALSE. IF(LP.NE.JP) RETURN LSJTRI = (J.GE.ABS(L-IS).AND.J.LE.L+IS).AND.MOD(L+IS+J,2).EQ.0 RETURN END C*********************************************************************** SUBROUTINE NDEGEN(E,JTARG,NJCHA) 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 IMPLICIT REAL*8(A-H,O-Z) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) DIMENSION JTARG(NJCHA) COMMON/BASICS/LRANG2,NRANG2 COMMON/BIG1/ HJ( 400000),HJBC(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/JSTATE/ENAT( 408),B( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK C K=0 KAB2=NRANG2*NRANG2 KREC1=1 KREC2=1 DO 3 K1=1,NJCHA CALL DA2(1,KREC1,IDISC2,KAB2*K1,HJ) DO 2 K2=1,K1 K=K+1 IF(K1.NE.K2) GO TO 2 C C LOCATE THE STATE THAT THIS CHANNEL IS COUPLED TO C I1=JTARG(K1) DELTA=E-ENAT(I1) C C RE-ADJUST THE DIAGONAL ELEMENTS. C KAB11=(K2-1)*KAB2-NRANG2 DO 1 J=1,NRANG2 1 HJ(KAB11+J*(NRANG2+1))=HJ(KAB11+J*(NRANG2+1))-DELTA 2 CONTINUE CALL DA2(2,KREC2,IDISC2,KAB2*K1,HJ) 3 CONTINUE RETURN END C*********************************************************************** SUBROUTINE NJCHAN(JPOS) 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 IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 PARITY(0:1) COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BASICS/LRANG2,NRANG2 COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/JCHAN /LJP( 492),KJ( 492),JTARG( 492) COMMON/JSTATE/ENAT( 408),B( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK COMMON/RECOV / IPLACE,IDMTST(50) COMMON/STATE/ ENER( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST DATA PARITY/'EVEN',' ODD'/, AJ4/0.5/ C 1000 FORMAT(/ 52X,17HSUBROUTINE NJCHAN/52X,17(1H-)/ * /' J =',F10.5,6X,A4,6X,'SYMMETRY'/1X,37(1H-)) 1002 FORMAT(/ 9X,55H**WARNING** INCIDENT ANGULAR MOMENTA REQUIRED UP TO * L =,I3,10H LRANG2 =,I3/) 1003 FORMAT(8H NJCHA =,I3) 1004 FORMAT(8H JCONAT=,(T9,20I3)) 1005 FORMAT(8H LJP =,(T9,20I3)) 1006 FORMAT(8H 2*KJ =,(T9,20I3)) 1007 FORMAT(8H JTARG =,(T9,20I3)) 1008 FORMAT(/25X,49H**WARNING** NO COUPLED CHANNELS FOR THIS SYMMETRY) 1009 FORMAT(//10H TARGET/4X,5HSTATE,7X,6HPARITY,11X,1HL,9X,1HK,9X, * 1HS,9X,1HJ,8X,6HPARITY//) 1010 FORMAT(1X,F10.5,6X,A4,6X,4F10.5,6X,A4) C JRGL=J2(JPOS) JNPTY=JP(JPOS) AJ=JRGL/2.0 WRITE(IWRITE,1000) AJ,PARITY(JNPTY) NJCHA=0 ID=IDMTST(35) C C DETERMINE THE L(INCIDENT) AND K CHANNEL NUMBERS C C LOOP OVER THE TARGET STATES C DO 4 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 3 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) GO TO 3 C C CHECK THE PARITY OF LMIN C IF(MOD(LMIN/2+JPTY(I),2).NE.JNPTY) LMIN=LMIN+2 LMAX = LMAX-MOD(LMIN+LMAX,4) IF(LMIN.GT.LMAX) GO TO 3 C C IF LMAX EXCEEDS LRANG2 SET ICHECK=1 - WHAT FOR? C LP=LMAX/2 IF (LP.LE.LRANG2) GO TO 1 WRITE(IWRITE,1002) LP,LRANG2 C WHY ICHECK=1 C C STORE THE 2K VALUES IN KJ AND THE 2L(INCIDENT) VALUES 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 1 DO 2 L=LMIN,LMAX,4 NJCHA=NJCHA+1 C C SIZE CHECK C IF(NJCHA.GT.ID) GO TO 2 C JCONAT(I)=JCONAT(I)+1 LJP(NJCHA) = L KJ(NJCHA)=JK JTARG(NJCHA)=I 2 CONTINUE 3 CONTINUE 4 CONTINUE IF(NJCHA.EQ.0) GO TO 8 C C C WRITE OUT THE DATA DEFINING THE CHANNELS FOR THIS SYMMETRY C WRITE(IWRITE,1003) NJCHA IF(NJCHA.GT.ID) CALL RECOV1(35,NJCHA) IF (IBUG5.GT.1) GO TO 5 WRITE(IWRITE,1005) (LJP(N)/2,N=1,NJCHA) WRITE(IWRITE,1006) (KJ(N),N=1,NJCHA) WRITE(IWRITE,1007) (JTARG(N),N=1,NJCHA) GO TO 7 5 WRITE(IWRITE,1009) DO 6 I=1,NJCHA N=JTARG(I) AJ1=JJ(N)/2.0 J1=JPTY(N) AJ2=LJP(I)/2 AJ3=KJ(I)/2.0 6 WRITE(IWRITE,1010) AJ1,PARITY(J1),AJ2,AJ3,AJ4,AJ,PARITY(JNPTY) C C DETERMINE THE NUMBER OF LS-SYMMETRIES REQUIRED TO GIVE C CONVERGENCE OF THE TRANSFORMATION FOR THIS J-SYMMETRY C 7 CALL NUMSYM(JRGL,JNPTY,JCOUNT(JPOS,0)) IF(JCOUNT(JPOS,0).GT.IDMTST(43)) CALL RECOV1(43,JCOUNT(JPOS,0)) GO TO 9 C 8 WRITE(IWRITE,1008) 9 JCH(JPOS)=NJCHA WRITE(IWRITE,'(/1X,78(1H-))') C RETURN END C*********************************************************************** SUBROUTINE NUMSYM(JRGL,JNPTY,ICOUNT) C C - DETERMINES THE NUMBER (ICOUNT) OF LS-SYMMETRIES REQUIRED FOR C COMPLETENESS OF THE TRANSFORMATION FOR GIVEN J,PARITY (JRGL,JNPTY) C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 PARITY(0:1) COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/STATE/ ENER( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST DATA PARITY/'EVEN',' ODD'/ C 1000 FORMAT(8H LRGL =,I2,7H NSPN =,I2,10H PARITY = ,A4) 1001 FORMAT(/28H THE SYMMETRIES REQUIRED ARE) 1002 FORMAT(/26H NO SYMMETRIES CONTRIBUTE) C C DETERMINE THE MINIMUM AND MAXIMUM SPINS IN THE TARGET C IMIN=ISAT(1) IMAX=ISAT(1) IF(NAST.EQ.1) GO TO 2 DO 1 I=2,NAST IF(ISAT(I).LT.IMIN) IMIN=ISAT(I) IF(ISAT(I).GT.IMAX) IMAX=ISAT(I) 1 CONTINUE C C DETERMINE THE RANGE OF VALUES OF 2S(SYSTEM)+1 C 2 IMIN=ABS(IMIN-1)+1 IMAX=IMAX+2 ICOUNT=0 WRITE(IWRITE,1001) DO 7 I=IMIN,IMAX,2 C C FIND THE MINIMUM 2L(SYSTEM) VALUE AND CHECK IF IT IS INTEGER C LMIN=ABS(JRGL-I+1)+1 IF(MOD(LMIN,2).EQ.0) GO TO 8 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 6 L=LMIN,LMAX,2 DO 4 K=1,NAST * * CHECK THAT THE TARGET SPIN IS CONSISTENT WITH THE TOTAL SPIN * IF (ABS(ISAT(K)-I+1).NE.1) GO TO 4 LLMIN=ABS(LAT(K)-L+1)+1 LLMAX=LAT(K)+L DO 3 M=LLMIN,LLMAX,2 IF(MOD((M-1)/2+LPTY(K),2).EQ.JNPTY) GO TO 5 3 CONTINUE 4 CONTINUE GO TO 6 C C RUNNING INDEX ICOUNT OF SYMMETRIES LS REQUIRED FOR CONVERGENCE C 5 ICOUNT=ICOUNT+1 WRITE(IWRITE,1000) (L-1)/2,I,PARITY(JNPTY) 6 CONTINUE 7 CONTINUE 8 IF(ICOUNT.EQ.0) WRITE(IWRITE,1002) C RETURN END C*********************************************************************** SUBROUTINE READS C C READS IN THE BASIC DATA FROM THE READ UNIT C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 TITLE(18),PARITY(0:1) COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BPSIZE/KFLN,KFL2,KFLM,KDUMMY(6) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/JSTATE/ENAT( 408),B( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK COMMON/RECOV / IPLACE,IDMTST(50) DATA PARITY/'EVEN',' ODD'/, L24,L50/ 21,2500/ C 1001 FORMAT(//7X,72(1H-)//7X,18A4//7X,72(1H-)////9X, 1'RRRRRRRRR EEEEEEEEEE CCCCCCCC UU UU PPPPP 2PPPP'/9X, 3'RRRRRRRRRR EEEEEEEEEE CCCCCCCCCC UU UU PPPPP 4PPPPP'/2(9X, 5'RR RR EE CC CC UU UU PP', 6' PP'/),9X, 9'RRRRRRRRRR EE CC UU UU', * 5X,'PPPPPPPPPP'/9X, *'RRRRRRRRR EEEEEEE CC UU UU', * 5X,'PPPPPPPPP'/9X, *'RRRRR EEEEEEE CC UU UU PP'/ * 9X, *'RR RR EE CC UU UU PP'/ * 9X, *'RR RR EE CC CC UU UU PP'/ * 9X, *'RR RR EE CC CC UU UU PP'/ * 9X, *'RR RR EEEEEEEEEE CCCCCCCCCC UUUUUUUUUU PP') 1002 FORMAT(9X,'RR RR EEEEEEEEEE CCCCCCCC UUUUUUUU' *,6X,'PP'//12X,'COMPILED FOR DIMENSIONS'/ +/15X,'NUMBER OF CHANNELS OF TOTAL LS (AMP)L05 = 520' +/15X,'SIZE NR(ANG)2 OF CONTINUUM BASIS (AMP)L07 = 60' +/15X,'NUMBER OF SHELLS NL (KFLN ==> (AMP)L11 = 15)' +/15X,'FULL (N,N+1) SET OF SYMMETRIES LS (AMP)L13 = 3000' +/15X,'TARGET TERMS OR ITS COMPONENTS LS (AMP)L14 = 114' +/15X,'LRANG2 -- MAXIMUM CONTINUUM L + 1 (AMP)L15 = 45' +/15X,'LRANG1 - SAME FOR TARGET ORBITALS (AMP)L16 = 5' +/15X,'LAMAX - MULTIPOLES MAX(2*LR1-2,4) (AMP)L18 = 8' +/15X,'BOUND-BOUND SPIN-ORBIT PARAMETERS (AMP)L19 = 56' +/15X,'BOUND-CONTINUUM " IN /INSTO9/ (AMP)L20 = 820' +/15X,'NO LONGER USED (AMP)L21 = 1830' +/15X,'SUBSHELS IN STGLIB (KFL2 -4 ==> (AMP)L24 = 21)' +/15X,'TARGET LEVELS IN INTERMEDIATE CPL (AMP)L34 = 408' +/15X,'NUMBER NJCHA OF CHANNELS IN " (AMP)L35 = 492' +/15X,'SYMMETRIES LS TO A TARGET LEVEL J (AMP)L36 = 350' +/15X,'... (AMP)L37 = 9999' +/15X,'SCRATCH SPACE (AMP)L38 = 1999900' +/15X,'BOUND (N+1) ELECTRON SYMMETRIES (AMP)L39 = 5000') 1003 FORMAT( + 15X,'ARRAY OF SIZE 2*(NJCHA*NRANG2)**2 (AMP)L40 = 400000' +/15X,'LS MATRIX OF ORDER NR2*NCHA+NCFGP (AMP)L42 = 5000' +/15X,'NUMBER OF SYMMETRIES SL IN ONE J (AMP)L43 = 16' +/15X,'(N+1)-ELECTRON SYMMETRIES S-L-PI (AMP)L44 = 180' +/15X,'TOTAL NUMBER OF J SYMMETRIES (AMP)L45 = 82' +/15X,'SIZE OF BIG J ARRAY (AMP)L46 =98000000' +/15X,'STORING WHOLE H MATRIX IN LS CPLG (AMP)L48 = 4821' +/15X,'TERM COUPLING COEFFS FOR ONE J (AMP)L49 = 650' +/15X,'.GT.MAX(L13,L14) FIXED: (KFLM ==> (AMP)L50 = 2500)' +/15X,5('='),' evtl for 2-body magnetic arrays: ',5('=') +/15X,'SIZE OF NOCCSH... IN /STATES/... (AMP)L12 = 580' +/15X,'POINTER ARRAY ICT IN /RKSAVE/ 100*(AMP)L22 = 140000' +/15X,'COMPONENTS FOR ONE SLP SYMMETRY (AMP)L25 = 129' +/15X,'KFL3 --- RATHER FOR RDAR1 repl (AMP)L31 = -1' +/15X,'KFL4 --- RATHER SIZE OF STORCC (AMP)L32 = 800000' * ////52X,16HSUBROUTINE READS/52X,16(1H-)/ + /29H INPUT-OUTPUT CHANNEL NUMBERS/10I5) 1004 FORMAT(17H DEBUG PARAMETERS/9I5) 1005 FORMAT(/' RECUPD ABORTING: (AMP)L18 GE 4 REQUIRED - RECOMPILE!') 1006 FORMAT(/40X,32HFINE STRUCTURE TARGET INPUT DATA/40X,32(1H-) * ///5X,1HJ,8X,6HPARITY,6X,6HENERGY//(F14.7,1X,A4,F16.7)) 1007 FORMAT(//3X,74('*')/3X,'* opt for ICHECK = -2 unless you have good * reasons for your choice of',I3,' *'/3X,74('*')/) 1008 FORMAT(/' LEVEL TERM: TCC...') 1009 FORMAT(I6,(T7,5(I5,':',F8.5))) 1010 FORMAT(/' RECUPD ABORTING'/' (AMP)L11=',I4,' MUST EQUAL KFLM=',I4/ *' (AMP)L24=',I4,10X,'KFL2-4=',I4,'-4'/' (AMP)L50=',I4,12X,'KFLM=', * I4/' RECOMPILE RECUPD (OR STGLIB)!'/) 1013 FORMAT(/ 1X,73(1H*)) 2000 FORMAT(12I5) 2001 FORMAT(5F14.7) C C SET THE PARAMETER IPLACE USED IN THE DIMENSION CHECK ROUTINE C RECOV1; JNTCON(1) IS TESTED IN BOUNDJ. C IPLACE=0 JNTCON(1)=0 C C READ THE BASIC DATA FROM CARDS C READ(IREAD,'(18A4)') TITLE READ(IREAD,*) IWRITE,IPUNCH,IDISC1,IDISC2,ITAPE1,ITAPE2,ITAPE3 *,ITAPE4,ITAPE5 WRITE(IWRITE,1001) TITLE WRITE(IWRITE,1002) WRITE(IWRITE,1003) IWRITE,IPUNCH,IDISC1,IDISC2, * ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 IF(IDMTST(11).NE.KFLN.OR.L24.NE.KFL2-4) GO TO 8 IF(L50.NE.KFLM) GO TO 8 IF(ITAPE1.EQ.0) ITAPE4=0 IF(ITAPE3.NE.0) WRITE(IWRITE,*)' H-MATRIX FILES: IN ',ITAPE2, * ', OUT ',ITAPE3 IF(ITAPE4.NE.0) WRITE(IWRITE,*)' DIPOLE MATRIX FILES: IN ',ITAPE1 * ,', OUT ',ITAPE4 IF(IPUNCH.NE.0) WRITE(IWRITE,*)' TC-COEFFS ONTO FILE ',IPUNCH READ(IREAD,*)IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 WRITE(IWRITE,1004) IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7, * IBUG8,IBUG9 C C SPECIFY |JNAST| TARGET LEVELS BY 2*J and parity (1 for odd) C C IF ICHECK.NE.0 DO NOT READ J TARGET DATA (ENAT,JNTCON,B,LSVALU), C CALCULATE THESE IN SUBROUTINE BOUNDJ BY RECOUPLING THE LS TARGET C HAMILTONIANS FROM STG2 AND DIAGONALISING. C C IPHOT IS NOT USED. C READ(IREAD,*) JNAST,ICHECK,IPHOT WRITE(IWRITE,"(I5,' TARGET J LEVELS, ICHECK =',I3)") JNAST,ICHECK J=ABS(JNAST) IF(J.GT.IDMTST(34)) CALL RECOV1(34,JNAST) ID=IDMTST(36) C READ(IREAD,*) (JJ(I),I=1,J) READ(IREAD,*) (JPTY(I),I=1,J) WRITE(IWRITE,2000) (JJ(I),I=1,J) WRITE(IWRITE,2000) (JPTY(I),I=1,J) IF(ICHECK.NE.-2) PRINT 1007, ICHECK C C READ IN ENERGIES AND ASSOCIATED TERM COUPLING COEFFICIENTS C IF(ICHECK.NE.0) GO TO 6 READ(IREAD,2001) (ENAT(I),I=1,JNAST) READ(IREAD,2000) (JNTCON(I),I=1,JNAST) DO 1 I=1,JNAST K=JNTCON(I) IF(K.GT.ID) CALL RECOV1(36,K) 1 READ(IREAD,2001) (B(I,J),J=1,K) DO 2 I=1,JNAST K=JNTCON(I) 2 READ(IREAD,2000) (LSVALU(I,J),J=1,K) C C TABULATE THE DATA DEFINING THE TARGET STATES C WRITE(IWRITE,1006) (JJ(I)/2.0,PARITY(JPTY(I)),ENAT(I),I=1,JNAST) WRITE(IWRITE,1008) DO 4 I=1,JNAST K=JNTCON(I) 4 WRITE(IWRITE,1009) I,(LSVALU(I,J),B(I,J),J=1,K) WRITE(IWRITE,1013) C C READ THE NUMBER OF TOTAL ANGULAR MOMENTUM AND PARITY C SYMMETRIES INTO 'IJNAST' C 6 IF (IPUNCH.GT.0 .AND. IPUNCH.NE.6) OPEN(UNIT=IPUNCH, * FILE='TCC.DAT',STATUS='UNKNOWN',FORM='FORMATTED') IJNAST=0 READ(IREAD,*,END=10) IJNAST WRITE(IWRITE,*) IJNAST,' TOTAL 2J AND PARITY SYMMETRIES ...' IF(IJNAST.GT.IDMTST(45)) CALL RECOV1(45,IJNAST) DO 7 J=1,IJNAST 7 READ(IREAD,*) J2(J),JP(J) WRITE(IWRITE,'((5X,10(I5,I2)))') (J2(J),JP(J),J=1,IJNAST) C IF(ITAPE2.EQ.0) GO TO 9 IF( 8.GE.4) GO TO 10 WRITE(IWRITE,1005) GO TO 9 10 RETURN 8 WRITE(IWRITE,1010) IDMTST(11),KFLN, L24,KFL2, L50,KFLM 9 STOP END C*********************************************************************** SUBROUTINE READTP(JPOS) C C READS THE BASIC DATA FROM THE STG2 FILE (ITAPE2) C AND THE FIRST TIME THROUGH (JPOS=1) WRITES OUT THE BASIC DATA TO C OUTPUT FILE (ITAPE3), DIAGONALISES TARGET J HAMILTONIANS IF NAST C IS -VE ON ITAPE2 AND SETS INAST=0 (NUMBER OF TOTAL LS SYMMETRIES) C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 FIN2 PARAMETER(LA14=(( 114+1)* 114)/2, LL53= 5* 5,LL54= 5* 45) C L(54) = MIN0(L(16) * L(15), L(16) * ((L(16) - 1) * 3 + 1)) PARAMETER (LL51= 15*2-1) PARAMETER (LL55=2* 5-1,LL56= 45+ 5, LL75= 21+2) PARAMETER (LLBB=4250,LLBC=420000,LL03=504,LL04=912,LL08=250) !250! LOGICAL OUTPUT,LSJTRI, FIRST, MDIR,MSEQ DIMENSION IHRX(1999900), AIJ( 114), KTYP( 114), AA( 60, 60) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON/BASICR/NELC,MAXNC( 45),MAXNHF( 45),MAXNLG( 45),LRANG1,NZ COMMON/BASICS/LRANG2,NRANG2 COMMON/BASICT/NDIAG,IPOLPH,ICODE,JRELOP(3) COMMON/C2BODY/ K2BDY,LRANG3,MMM(4) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 common /FACT/ GAMMA(LL08) COMMON /FSTORE/FS0(LA14), FS1(LA14),FS2(LA14), ICI(3000),ICJ(3000) COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/INSTO0/STORBB(LLBB),STORBC(LLBC) COMMON/INSTO3/ICTBB( 5, 5,LL53) 2 ,ISTBB1(LL04),ISTBB2(LL04) * ,ICTBC( 5, 5,LL54),ISTBC1(LL03),ISTBC2(LL03) COMMON/INSTO7/NBUG,INK1,INK4,NCNT,NMIN(0: 5) COMMON/INSTOX/KDSK,MPOS, LDIR(0:99,2),JDSK(99,2) * ,ICTCCD( 5, 5,0:LL55,99),ICTCCE( 5, 5,0:LL56,99) COMMON/JSTATE/ENAT( 408),B( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK COMMON /KRON/ IDEL(LL75,LL75) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/RECOV / IPLACE,IDMTST(50) COMMON/SCRACH/PV(1999900) COMMON/STATE/ ENER( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST COMMON/STATED/ A( 114, 114),NTCON( 114),NTYP( 114, 114) COMMON/STATES/ NCFG,NOCCSH(3000),NOCORB( 15,3000),NELCSH( 15, * 3000),J1QNRD(LL51,3,3000),MAXORB,NJCOMP(LL75),LJCOMP(LL75) EQUIVALENCE (IHRX(1),PV(1)) C 1000 FORMAT( /52X,17HSUBROUTINE READTP/52X,17(1H-)/ * /51H READ THE DATA TAPE FROM STG2 (AND STG1 IF IZESP<0)/) 1002 FORMAT(7H NELC =,I3,6H NZ =,I3,10H LRANG1 =,I3,10H LRANG2 =, * I3,10H NRANG2 =,I3,9H LAMAX =,I3,7H LAM =,I2/ * 17H MASS-CORRECTION(,I1,15H), DARWIN-TERM(,I1, * 14H), SPIN-ORBIT(,I2,2H);,8X,7HIZESP =,I3) 1003 FORMAT(9H MAXNHF =,20I3) 1004 FORMAT(9H MAXNLG =,20I3) 1005 FORMAT(5H RA =,F10.5,8H BSTO =,1P,E12.4//7H TERM #,(T8,18I4)) 1006 FORMAT(2(4X,I2),3X,A4,4X,F14.7) 1007 FORMAT(7H LAT =,(T8,18I4)) 1008 FORMAT(7H ISAT =,(T8,18I4)) 1009 FORMAT(/29H READ OF BASIC DATA COMPLETED/) 1010 FORMAT(/11X,49H**ERROR** CHECK TERM COUPLING COEFFICIENTS: STATE, * I3,8H CONFIG,I3) 1011 FORMAT(12I5) 1012 FORMAT(7H LPTY =,(T8,18I4)) C IF(ITAPE5.LE.9) ITAPE5=14 IDSC3=ITAPE5+1 !tempfix for magnetic direct access data from STG1 KDSK = IDSC3 C C READ THE INPUT TAPE FROM STG2 C MSKIP=JPOS 100 OUTPUT=MSKIP.EQ.1.AND.ITAPE3.NE.0 FIRST= IBUG5.NE.0 .OR. MSKIP.LE.1 IF(FIRST) WRITE(IWRITE,1000) REWIND ITAPE2 C IF(FIRST) REWIND ITAPE3 -- '97JAN20: CORR IBUG5.NE.0! READ(ITAPE2) * NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,L,LAM,IZESP,JRELOP IF(FIRST) WRITE(IWRITE,1002) * NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM, JRELOP,IZESP ICODE=SIGN(23,L) C RUB'96OCT1: MINUS SIGN USED TO FLAG INCLUSION OF E2+M1-DATA L = MAX(LAMAX,3) IF(OUTPUT) WRITE(ITAPE3) NELC,NZ,LRANG1,LRANG2,NRANG2, * L,ICODE,LAM,IZESP,JRELOP C C ARRAY SIZE CHECKS - LRANG2 (11)-->(15) 93FEB14 (KLAUS & WERNER) C IF(LRANG2.GT.IDMTST(15)) CALL RECOV1(15,LRANG2) IF(NRANG2.GT.IDMTST(7)) CALL RECOV1(7,NRANG2) IF(L.GT.IDMTST(18)) CALL RECOV1(18,L) READ(ITAPE2) (MAXNHF(L),L=1,LRANG1),(MAXNLG(L),L=1,LRANG1) *,(MAXNC(L),L=1,LRANG1) IF(OUTPUT) WRITE(ITAPE3) (MAXNHF(L),L=1,LRANG1), * (MAXNLG(L),L=1,LRANG1),(MAXNC(L),L=1,LRANG1) IF(FIRST) WRITE(IWRITE,1003) (MAXNHF(L),L=1,LRANG1) IF(FIRST) WRITE(IWRITE,1004) (MAXNLG(L),L=1,LRANG1) IF(NRANG2.GT.IDMTST(38)) CALL RECOV1(38,NRANG2) DO L=1,LRANG2*2 ! '05Aug15 READ(ITAPE2) (PV(I),I=1,NRANG2) IF(OUTPUT) WRITE(ITAPE3) (PV(I),I=1,NRANG2) ENDDO READ(ITAPE2) RA,BSTO,HINT,DELTA,ETA,NIX IF(OUTPUT) WRITE(ITAPE3) RA,BSTO,HINT,DELTA,ETA,NIX IF(NIX.LE.0) GO TO 11 C C PASS ON RADIAL INTERVALS, RADIAL MESH, AND BUTTLE COEFFS C L=2*NIX IF(L.GT.IDMTST(38)) CALL RECOV1(38,L) READ(ITAPE2) (IHRX(I),I=1,L) IF(OUTPUT) WRITE(ITAPE3) (IHRX(I),I=1,L) IPTS=IHRX(L)*2 IF(IPTS.GT.IDMTST(38)) CALL RECOV1(38,IPTS) C READ(ITAPE2) (PV(I),I=1,IPTS) IF(OUTPUT) WRITE(ITAPE3) (PV(I),I=1,IPTS) DO 2 L=1,LRANG1 L1=MAXNLG(L) IF(L.GT.L1) GO TO 2 DO 1 N=L,L1 READ(ITAPE2) (PV(I),I=1,IPTS) IF(OUTPUT) WRITE(ITAPE3) (PV(I),I=1,IPTS) 1 CONTINUE 2 CONTINUE C 11 L=3*LRANG2 IF(L.GT.IDMTST(38)) CALL RECOV1(38,L) READ(ITAPE2) (PV(I),I=1,L) ! COEFF(1:3,1:LRANG2) IF(OUTPUT) WRITE(ITAPE3) (PV(I),I=1,L) READ(ITAPE2) NAST NDIAG=0 IF(NAST.LT.0) NDIAG=1 NAST=ABS(NAST) IF(NAST.GT.IDMTST(14)) CALL RECOV1(14,NAST) READ(ITAPE2) (ENER(N),N=1,NAST),(LAT(N),N=1,NAST), * (ISAT(N),N=1,NAST),(LPTY(N),N=1,NAST) C C IF IZESP<0 PROCESS STG1 FILES ON MAGNETIC 2-BODY INTEGRALS C IF(.NOT.FIRST) GO TO 24 WRITE(IWRITE,1005) RA,BSTO, (I,I=1,NAST) WRITE(IWRITE,1007) (LAT(I),I=1,NAST) WRITE(IWRITE,1008) (ISAT(I),I=1,NAST) WRITE(IWRITE,1012) (LPTY(I),I=1,NAST) C IF(IZESP.LT.0) THEN INQUIRE (FILE='MK_seq',EXIST=MSEQ) IF(MSEQ) THEN K2BDY = 1 OPEN(UNIT=ITAPE5,FILE='MK_seq',STATUS='OLD', * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') C READ(ITAPE5) -IZESP,NELC,NZ,... c tst READ(ITAPE5) J, K, L, LRANG3 c tst print "(/' MK_seq test: -IZESP,NE,NZ,LRANG1-3 =',6I5)", J, c tst* K,L,LRANG1,LRANG2,LRANG3 c tst backspace ITAPE5 READ(ITAPE5) J, K, L, LRANG3, (NMIN(I),I=0,LRANG1-1) print "(/' reading MK_seq for -IZESP,NELC,NZ =',3I4)", J,K,L READ(ITAPE5) IRK1,IRK4 IF(IRK1.GT.LLBB) CALL RECOV1(-3,IRK1) ! STORBB(LLBB) IF(IRK4.GT.LL04) CALL RECOV1(-1,IRK4) ! ISTBBi(LL04) L=LRANG1*LRANG1 READ(ITAPE5)(((ICTBB(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,L), * (ISTBB1(I),I=1,IRK4), * (ISTBB2(I),I=1,IRK4), (STORBB(I),I=1,IRK1) DO 18 I=1,LL75 ! SET UP A KRONECKER ARRAY IDEL DO 17 J=1,LL75 17 IDEL(J,I)=0 18 IDEL(I,I)=1 GAMMA(1)=1 DO 19 I=2,55 ! temp!! 19 GAMMA(I) = (I-1)*GAMMA(I-1) INQUIRE (FILE='MK_dir',EXIST=MDIR,RECL=L) IF(MDIR) THEN K2BDY = -1 c print "(/' INQUIRE MK_dir yields IRECL =',I5)", L !failing c OPEN(IDSC3,FILE='MK_dir',STATUS='OLD',ACCESS='DIRECT',RECL=L): CALL DA2(0,0,IDSC3,0,STORBC) read(ITAPE5) IRK2,IRK3 IF(IRK3.GT.LL03) CALL RECOV1(-2,IRK3) ! arrays ISTBCi(LL03) print "(/' reading MK_dir for LRANG3,NOBC =',2I7)",LRANG3,IRK2 L = ABS(LRANG3)*LRANG1 ! not MIN(LRANG3,(LRANG1-1)*3+1)*LRANG1 read(ITAPE5) (((ICTBC(I,J,K),I=1,LRANG1),J=1,LRANG1),K=1,L), * (ISTBC1(I),I=1,IRK3),(ISTBC2(I),I=1,IRK3) IREC=1 MKBC= IRK2 IF(MKBC.GT.LLBC) CALL RECOV1(-5,MKBC) ! STORBC(LLBC) CALL DA2(1,IREC,IDSC3,MKBC,STORBC) IF(IBUG2.NE.0) print"(/' READTP: after reading STORBC IREC =' * ,I4/' LPOS RECL L LP irec')", IREC LDIR(0,1)=-1 LDIR(0,2)=-1 M = 0 20 READ(ITAPE5,END=21) L,I,J, K,I1,I2 M = M+1 IF(M.GT.99) CALL RECOV1(-4,199) JDSK(M,1)=K JDSK(M,2)=L LDIR(M,1)=I LDIR(M,2)=J IF(IBUG2.NE.0) print "(I6,I8,I6,I3,I6)", M,L,I,J,K C I1=MIN(2*LRANG1-1,I+J+1); I2=MIN(I,J)+LRANG1 IF(L.GT.IDMTST(32)) CALL RECOV1(32,L) if (L.eq.0) then ! '03Nov20 for Ne2 test: print "(' pos',I4,' empty!')", M go to 20 endif READ(ITAPE5) * (((ICTCCD(I,J,K,M),I=1,LRANG1),J=1,LRANG1),K=0,I1) * ,(((ICTCCE(I,J,K,M),I=1,LRANG1),J=1,LRANG1),K=0,I2) GO TO 20 21 MPOS = M print "(/' MK_dir/_seq have data for',I3,' symmetry-pairs'/// * ' optional test of FIN2BB, FIN2BC and FIN2CC (K=-1 for V)')",M C TEST cases (on IREAD!) IF(IBUG2.NE.1) GO TO 24 NCNT = 1 22 READ(IREAD,*,END=24,ERR=23)FIN2, N1,L1,N2,L ,N3,L3,N4,L4, LAM IF (FIN2.EQ.'2bb(') THEN CALL FIN2BB(N1,L1,N2,L ,N3,L3,N4,L4, LAM, AA) ! AA(1,1)=VAL ELSE IF (FIN2.EQ.'2bc(') THEN CALL FIN2BC(N1,L1,N2,L ,N3,L3,N4,L4, LAM, AA) ! AA(1:NR2,1) ELSE IF (FIN2.EQ.'2cc(') THEN CALL FIN2CC(N1,L1,N2,L ,N3,L3,N4,L4, LAM, AA) ! FULL AA ENDIF GO TO 22 23 PRINT "(/' now reading unsuitable test data'/)" ELSE print "(/' no MK_dir found: setting LRANG3=0')" LRANG3=0 K2BDY=0 ENDIF ELSE print "(/' no MK_seq found while IZESP.lt.0: stop')" STOP ENDIF ENDIF C C CHECK IF THE SPIN-ORBIT INTERACTION IS REQUIRED: IF IT IS, C READ THE CONFIGURATION DATA DEFINING THE N-ELECTRON TARGET C STATES INTO /STATES/ AND /STATED/ C 24 NCNT = 0 IF(IBUG2.GT.5) NCNT = IBUG2 IF(JRELOP(3).EQ.0) GO TO 4 READ(ITAPE2) NCFG C COR IF(NCFG.GT.IDMTST(14)) CALL RECOV1(14,NCFG) -- RUB'96JAN14: IF(NCFG.GT.IDMTST(13)) CALL RECOV1(13,NCFG) BACKSPACE ITAPE2 READ(ITAPE2) NCFG,(NOCCSH(I),I=1,NCFG) DO 3 I=1,NCFG IL=NOCCSH(I) ILL=2*IL-1 3 READ(ITAPE2) (NOCORB(J,I),J=1,IL),(NELCSH(J,I),J=1,IL), * ((J1QNRD(J,K,I),K=1,3),J=1,ILL) READ(ITAPE2) MAXORB,(NJCOMP(J),J=1,MAXORB),(LJCOMP(J),J=1,MAXORB) READ(ITAPE2) (NTCON(J),J=1,NAST) C C READ CONFIGURATION INPUT; COMPUTE LEVELS FROM TERMS IF NOT INPUT C (CHANGE THE L VAULE TO 2L AND THE 2S+1 VALUE TO 2S) C 4 K=0 C L=2 !-2 for level inversion no longer provided: JNAST=-1 as before DO 8 I=1,NAST LAT(I)=LAT(I)*2 ISAT(I)=ISAT(I)-1 N=NTCON(I) IF(N.GT.IDMTST(14)) CALL RECOV1(14,N) IF(JRELOP(3).NE.0) * READ(ITAPE2) (KTYP(J),J=1,N),(AIJ(J),J=1,N) CC N.B. AIJ(I,J) IS MERELY PLACED INTO A LOCAL ARRAY! CC AIJ OF NO USE: NOT YET ASSIGNED IN RSTG2 AT THIS POINT! WE'94MAR. CC print *,' ***** I,NTYP,AIJ = ',I,(KTYP(J),AIJ(J),J=1,N) IF(MSKIP.GT.1) GO TO 6 DO 5 J=1,N C EVT B(I,J)=AIJ(J) 5 NTYP(I,J)=KTYP(J) 6 IF(JNAST.GT.0) GO TO 8 L1=ISAT(I)+LAT(I) L0=ABS(LAT(I)-ISAT(I)) N=K K=(L1-L0)/2+N+1 IF(K.GT.IDMTST(34)) CALL RECOV1(34,K) IF(JNAST.NE.0) GO TO 8 DO 7 J=L0,L1,2 !,L N=N+1 JJ(N)=J 7 JPTY(N)=LPTY(I) 8 CONTINUE C C EXTEND THE MAXNHF ARRAY IF NECESSARY C IF(LRANG1.GE.LRANG2) GO TO 10 DO 9 L=LRANG1+1,LRANG2 9 MAXNHF(L)=L-1 C C RETURN IF THIS IS NOT THE FIRST CALL C 10 WRITE(IWRITE,1009) IF(MSKIP.GT.1) RETURN C C THIS IS THE FIRST CALL. IF NAST IS -VE CALL BOUNDJ TO READ THE C LS TARGET HAMILTONIANS AND CALCULATE BOUND ENERGIES AND VECTORS C OF J STATES. TERMINATE IF MERE TCC RUN. C IF(NDIAG.NE.1) GO TO 28 DO 27 I=1,LA14 FS2(I) = 0. FS1(I) = 0. 27 FS0(I) = 0. CALL BOUNDJ C 28 IF(MSKIP.LE.0) STOP DO 29 I=1,LA14 FS2(I) = 0. FS1(I) = 0. 29 FS0(I) = 0. IF (ABS(ICHECK).NE.4 .AND.JRELOP(3).LE.0) THEN ! ne 3 before PRINT*,'ICHECK=4 REQUIRED FOR RUN WITHOUT COLLISIONAL SPIN-ORBIT' STOP ENDIF IF (ABS(ICHECK).GT.3 .AND.JRELOP(3).GT.0) ! gt 1 before '06Apr20 * PRINT *, 'ICHECK>3 OPTION: JP -> JP WITHOUT ELASTIC PIECES!' INAST=0 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 13 I=1,JNAST DO 12 J=1,JNTCON(I) I2=LSVALU(I,J) IF(I2.EQ.0.AND.IPUNCH.NE.0) GO TO 12 C TST SO AS TO ALLOW NAST<(FULL RANGE) IF (LSJTRI(LAT(I2),ISAT(I2),LPTY(I2),JJ(I),JPTY(I))) GO TO 12 WRITE(IWRITE,1010)I,J STOP 12 CONTINUE 13 CONTINUE C C SET UP THE DATA DEFINING THE TARGET STATES FOR STG3R C IF(ITAPE3.EQ.0) GO TO 14 WRITE(ITAPE3) JNAST WRITE(ITAPE3) (ENAT(N),N=1,JNAST),(JJ(N),N=1,JNAST), * (JPTY(N),N=1,JNAST),(JPTY(N),N=1,JNAST) C C NEED TO REPOSITION INPUT FILE (ITAPE2) IF BOUNDJ HAS BEEN CALLED C WITH SPIN-ORBIT INTERACTION (AS RADIAL INTEGRALS HAD TO BE READ) C 14 MSKIP=999 IF(NDIAG.EQ.1) GO TO 100 RETURN END C*********************************************************************** SUBROUTINE RECOV1(I,ID) C C THIS ROUTINE IS CALLED ONLY IN THE CASE OF ARRAY OVERFLOW. C IF IPLACE=0 THE PROGRAM STOPS HERE, OTHERWISE THE PROGRAM RETURNS C TO THE CALLING ROUTINE AFTER SETTING IPLACE=I. C C I IS THE POSITION IN THE IDMTST ARRAY, WHICH HOLDS THE CURRENT C ARRAY DIMENSIONS C ID IS THE ARRAY SIZE REQUIRED BY THE DATA C CHARACTER ARR(5)*12 COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/RECOV / IPLACE,IDMTST(50) DATA ARR /'ISTBBi(LL04)','ISTBCi(LL03)','STORBB(LLBB)', * 'arrays(,99,)','STORBC(LLBC)'/ C 1000 FORMAT(/19H * ARRAY OVERFLOW */45H MUST INCREASE ARRAYS ASSOCIATED * WITH IDMTST(,I2,3H) =,I8/26X,19HTO AT LEAST IDMTST(,I2,3H) =,I8) 1001 FORMAT(/29H PROGRAM TERMINATES IN RECOV1/) 1002 FORMAT(/54H CHECK TO SEE IF OTHER ARRAYS ARE GOING TO BE EXCEEDED) 1003 FORMAT(/' stopping in READTP: secure ',A12,' of length',I8) C IF(I.GT.0) GO TO 4 WRITE(IWRITE,1003) ARR(-I),ID STOP C 4 WRITE(IWRITE,1000) I,IDMTST(I),I,ID IF(IPLACE) 2,1,3 1 WRITE(IWRITE,1001) STOP C 2 WRITE(IWRITE,1002) 3 IPLACE=I ID=IDMTST(I) RETURN END C*********************************************************************** SUBROUTINE RECUD(JI,JF,MPOL,ICODE) C C FINDS SUITABLE PAIRS OF SYMMETRIES IN LS COUPLING TO FORM DIPOLE C MATRIX ELEMENTS FOR A TRANSITION ARRAY (JI,JF) IN LS-J COUPLING. C SIMPLIFIED (2-DIM JCOUNT) AND EXTENDED '97JAN22-3. +E2'97FEB21-2 C C JI,JF = POSITIONS OF INITIAL,FINAL J SYMMETRIES IN /ALPHA/. C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 PARITY(0:1) COMMON /ALPHA/LLRGL( 180),NNSPN( 180),NNPTY( 180),NNCHAN( 180), * NNCHGP( 180),INAST ! '05FEB17 instead NNCHGP( 408),INAST COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,ITAPE5 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/POTORB/ PV(9999),QV(9999),ICHAN(9999),IICHAN(9999), * NTERM( 492),MTERM( 492) DATA PARITY/'EVEN',' ODD'/ C 1000 FORMAT(/51X,'SUBROUTINE RECUD'/51X,16('-')/ * /18H INITIAL STATE J =,F5.1,6X,A4,5X,8HSYMMETRY/1X,45(1H-)/ * /18H FINAL STATE J =,F5.1,6X,A4,5X,8HSYMMETRY/1X,45(1H-)) 1003 FORMAT(/' RECUD - REVERSE DIPOLE MATRIX NEEDED:') 1004 FORMAT(/' READ D-MATRIX: INITIAL, FINAL LSP =',2(2X,3I3)) 1007 FORMAT(/61H L-S COUPLED DIPOLE MATRIX ELEMENTS BETWEEN INITIAL STA 1TE L =,I3,2X,A4,9H SYMMETRY/ * 42X,19HAND FINAL STATE L =,I3,2X,A4,9H SYMMETRY/7X, 1 23HAND COMMON MULTIPLICITY,I3,23H CONTRIBUTE RAC,SGN =,2F10.5) 1008 FORMAT(I5,(T6,5(I4,F11.7))) 1010 FORMAT(/14H INITIAL STATE/(15I5)) 1011 FORMAT(/12H FINAL STATE/(15I5)) C JJRGL=J2(JI) MJCHA=JCH(JI) JRGL=J2(JF) JNPTY=JP(JF) NJCHA=JCH(JF) AJ=JJRGL/2.0 CNJ=JRGL/2.0 WRITE(IWRITE,1000) AJ,PARITY(JP(JI)), CNJ,PARITY(JNPTY) CNJ=SQRT(REAL((JJRGL+1)*(JRGL+1))) LASTF=0 LASTI=0 C C --- LOOP OVER ALL FINAL TOTAL S-L-PI STATES LF AND INITIAL STATES LI C JNCFGP=0 C-KAB KMCFGP=0 -- KAB CORR'S WE'91MAR19, MORE WE'92APR28-30,'97JAN22 MSUM=99999 DO 300 KF=1,JCOUNT(JF,0) LF = JCOUNT(JF,KF) LRGL=LLRGL(LF) NSPN=NNSPN(LF) KMCFGP=0 DO 200 KI=1,JCOUNT(JI,0) LI = JCOUNT(JI,KI) LRGLP=LLRGL(LI) C C CHECK IF SYMMETRY PAIR CONTRIBUTES TO THE TRANSFORMATION, IN C ANY CASE RESERVE BLANK SPACES IN MATRICES INVOLVING BOUND TERMS! C IF(IBUG5.NE.0) * PRINT *,' LF,LI, JNCFGP,KMCFGP = ', LF,LI,JNCFGP,KMCFGP IF(NNSPN(LI).NE.NSPN) GO TO 200 IF (ICODE.GT.0 .AND. MPOL.EQ.4) GO TO 200 IF(LRGLP+LRGL.LT.MPOL) GO TO 200 IF(ABS(LRGLP-LRGL).GT.MPOL) GO TO 200 C C READ NEXT DIPOLE MATRIX FROM STG2 FILE IF LS SELECTION RULES OK C IF(IBUG5.NE.0) WRITE(IWRITE,1004) * LRGLP,NSPN,NNPTY(LI), LRGL,NSPN,NNPTY(LF) NF = MAX(LI,LF) NI = MIN(LI,LF) MM = ((NF-1)*NF)/2+NI IF (MM.LT.MSUM) THEN REWIND ITAPE1 MI = 1 MF = 1 ENDIF DO 100 IF=MF,NF I=1 IF(IF.EQ.MF) I=MI LL=IF IF(IF.EQ.NF) LL=NI C NB: NO QUADRUPOLE MATRICES ON UNIT 1 IF ICODE.GT.0 DO 100 II=I,LL IF(IBUG5.NE.0) print *,' DFIND: II,IF =',ii,if IF (NNSPN(II).NE.NNSPN(IF)) GO TO 100 MK=2 IF (NNPTY(II).EQ.NNPTY(IF)) THEN IF(ICODE.GT.0) GO TO 100 MK=4 ENDIF IF(LLRGL(II)+LLRGL(IF).LT.MK) GO TO 100 IF(ABS(LLRGL(II)-LLRGL(IF)).GT.MK) GO TO 100 IF(IBUG5.NE.0) print *,' calling DFIND!' CALL DFIND(II,IF) 100 CONTINUE MSUM=MM MF = NF MI = NI+1 IF(MI.GT.MF) THEN MI=1 MF = NF+1 ENDIF C C FLAG REVERSE TRANSITION (NNPTY(NF).NE.JNPTY FOR E1 TRANSITION) C SGN = 0. ! C S-T LL=LRGLP IF (NF.NE.LF) THEN WRITE(IWRITE,1003) SGN = 1. ! C S-T LL=LRGL IF (LRGLP.NE.LRGL .AND. MPOL.EQ.2) SGN = -1. ENDIF C C EVALUATE RACAH COEFFICIENT & ANGULAR MOMENTUM PHASE FACTOR (RAC) C C 3fix CALL DRACAH(JJRGL,LRGLP,JRGL,LRGL,NSPN,MPOL,AJ) ! '07Jan13: C WE'92APR27 1ST ATTEMPT: (MAY2-4: SEE ROUTINES BSPNO OR SPNORB) CALL DRACAH(JRGL,LRGL,JJRGL,LRGLP,NSPN,MPOL,AJ) C RAC = (MOD(ABS(LL+NSPN-JRGL) ,4)-1)*AJ*CNJ -- '99JAN19/E1+E2: C+nrb Ne+ trouble: prime of Scott & Taylor (21-3)=LRGL!,<-LL '03Feb23 RAC = (1-MOD(ABS(LRGL+NSPN-JJRGL-MPOL),4))*AJ*CNJ !JRGL->JJRGL" IF (NNPTY(NF).NE.JNPTY) RAC = -RAC ! securing LS-swaps '03Feb28 WRITE(IWRITE,1007) LRGLP/2,PARITY(NNPTY(LI)), * LRGL/2,PARITY(NNPTY(LF)),NSPN+1,RAC,SGN IF(RAC.EQ.0.0) GO TO 200 C C READ INITIAL AND FINAL CHANNEL RECOUPLING DATA FROM DA FILE C IF(LI.NE.LASTI) * CALL DAFILA(1,LI,LRGLP,JJRGL,MJCHA,MTERM,MTERMI,IICHAN,QV) LASTI=LI IF(LF.NE.LASTF) * CALL DAFILA(1,LF,LRGL,JRGL,NJCHA,NTERM,NTERMI,ICHAN,PV) LASTF=LF IF(IBUG5.GT.1) THEN WRITE(IWRITE,1010) (MTERM(I),I=1,MJCHA) WRITE(IWRITE,1008) MTERMI, (IICHAN(I),QV(I),I=1,MTERMI) WRITE(IWRITE,1011) (NTERM(I),I=1,NJCHA) WRITE(IWRITE,1008) NTERMI, (ICHAN(I),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(LI,LF,MJCHA,NJCHA,KMCFGP,JNCFGP,SGN,RAC) C-KAB KMCFGP=KMCFGP+NNCHGP(LPOSI), JNCFGP=JNCFGP+NNCHGP(LPOSF) 200 KMCFGP=NNCHGP(LI)+KMCFGP 300 JNCFGP=NNCHGP(LF)+JNCFGP C RETURN END C*********************************************************************** SUBROUTINE RECUPJ(JPOS,COMPLT) C C - RECOUPLES THE HAMILTONIAN MATRICES AND LONG RANGE POTENTIAL C COEFFICIENTS FROM LS TO INTERMEDIATE J COUPLING. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL LSJTRI,COMPLT CHARACTER*4 PARITY(0:1) DIMENSION NCONAT( 114) PARAMETER(L21=(( 60+1)* 60)/2) PARAMETER (LL51= 15*2-1) PARAMETER (MXD1= 400000+98000000+5000*5000+(4821+1)*4821) PARAMETER (MXD2=( 400000/2+98000000/4*2+5000*5000+5000*5000)*2) PARAMETER (MXT1=MXD1/MXD2,MXT2=MXD2/MXD1,MXT0=MXT1+MXT2) PARAMETER (LL81=MXD1*MXT1/MXT0+MXD2*MXT2/MXT0-MXD1+1) COMMON/ALPHA/L2( 180),LS( 180),LP( 180),LCH( 180),LCFG( 180),INAST COMMON/ALPHAJ/J2( 82),JP( 82),JCH( 82),JCFG( 82), * JCOUNT( 82,0: 16),IJNAST COMMON/BASICR/NELC,MAXNC( 45),MAXNHF( 45),MAXNLG( 45),LRANG1,NZ COMMON/BASICS/LRANG2,NRANG2 COMMON/BASICT/NDIAG,IPOLPH,ICODE,JRELOP(3) COMMON/BIG1/ HJ( 400000),HJBC(98000000),HJBB(5000,5000), * HLS(4821,0:4821),DUM1(LL81) COMMON/BNDBOX/LCFBOX( 16),LOCCSH(5000),LOCORB( 15,5000), * LELCSH( 15,5000),N1QNRD(LL51,3,5000) COMMON/BNDCON/ NCFGP,IOCCSH(3000),IOCORB( 15,3000), * IELCSH( 15,3000),I1QNRD(LL51,3,3000) COMMON/CHAN/ L2P( 520),LSTARG( 520) COMMON/CHBOX/ L2PBOX( 520, 16),LSTBOX( 520, 16) COMMON/DEBUG/IBUG1,IBUG2,IBUG3,IBUG4,IBUG5,IBUG6,IBUG7,IBUG8,IBUG9 COMMON/DISTAP/IDISC1,IDISC2, ITAPE1,ITAPE2,ITAPE3,ITAPE4,INOTAP COMMON/INFORM/ IREAD,IWRITE,IPUNCH COMMON/INSTO8/ IST1( 5),IST2( 5),IRK5,IRK6,IRK7 COMMON/INSTO9/ RSPOR1( 56),RSPOR2( 820),RSPOR3(L21,2: 45) COMMON/JCHAN /LJP( 492),KJ( 492),JTARG( 492) COMMON/JSTATE/ENAT( 408),B( 408, 350),LSVALU( 408, 350), * JNTCON( 408),JJ( 408),JPTY( 408),JNAST,ICHECK COMMON/LRPOT / CF( 520, 520, 8),CFJ( 492, 492, 8) COMMON/MORDER/LAMAX,LAMBC,LAMCC,LAMIND,LAM COMMON/POTORB/ PV(9999),PPV(9999),ICHAN(9999),MCHAN(9999), * NTERM( 492),NNTERM( 492) COMMON/RECOV / IPLACE,IDMTST(50) COMMON/STATE/ ENER( 114),LAT( 114),ISAT( 114),LPTY( 114),NAST C DATA PARITY/'EVEN',' ODD'/ C 1001 FORMAT(/27X,39H** ERROR ** TRANSFORMATION NOT COMPLETE/28X,9(1H*)/ * /39X,'RERUN STG2 FOR A COMPLETE SET!') 1004 FORMAT(//6X,58HCONTINUUM-CONTINUUM CONTRIBUTION TO H MATRIX FROM C CHANNELS,I4,4H AND,I4/60X,2I8) 1005 FORMAT(I5,(T6,9F14.7)) 1006 FORMAT(8F15.7) 1007 FORMAT(/8H LRGL =,I2,7H NSPN =,I2,9H PARITY =,A4,8H NCFGP =, * I3,7H MORE =,I2,I8,' CHANNELS') 1010 FORMAT(/42X,32HTRANSFORMED HAMILTONIAN MATRICES/42X,32(1H-)) 1011 FORMAT(/36H READ OF STG2R OUTPUT TAPE COMPLETED/ * I5,' CHANNELS',I5,' BOUND TERMS',10X,'ORDER OF MATRIX =',I5/) 1012 FORMAT(/ 3H K=,I1) 1013 FORMAT(I5,(T8,8F9.5)) 1015 FORMAT(/44X,30HTRANSFORMED COEFFICIENT MATRIX/44X,30(1H-)) 1016 FORMAT(//5X,64H BOUND-CONTINUUM CONTRIBUTION TO HAMILTONIAN MATRIX * FROM CHANNEL,I4/) 1017 FORMAT(/ 6X,65HBOUND-BOUND CONTRIBUTION TO HAMILTONIAN MATRIX FROM * CONFIGURATION/I9,7X,'NCONHP,KAB1 = ',2I5) C C LPOS = COUNTER ON ALL LS SYMMETRIES ON STG2 FILE; C IADD = COUNTER ON LS SYMMERIES WHICH COUPLE TO J. C WRITE(IWRITE,'(/ 52X,17HSUBROUTINE RECUPJ/52X,17(1H-))') COMPLT=.FALSE. LPOS=0 IADD=0 JNCFGP = 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 STG2R OUTPUT FILE C 10 READ(ITAPE2,END=37) LRGL0,NSPN0,NPTY,NCFGP,IPOLPH if(IBUG4.ne.0) WRITE(IWRITE,"(/' LS SYMMETRY ON INPUT FILE: ',3I4) *") LRGL0,NSPN0,NPTY READ(ITAPE2) MNPI,NCONHP,NCHAN READ(ITAPE2) (NCONAT(I),I=1,NAST) IF(IPOLPH.EQ.1) ITAPE4=0 C C DIMENSION CHECKS C IF(MNPI.GT.IDMTST(48)) CALL RECOV1(48,MNPI) IF(NCHAN.GT.IDMTST(5)) CALL RECOV1(5,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).EQ.0) GO TO 13 IF(NCFGP.GT.0) THEN IF(NCFGP.GT.IDMTST(13)) CALL RECOV1(13,NCFGP) READ(ITAPE2) (IOCCSH(I),I=1,NCFGP) DO 11 I=1,NCFGP IL=IOCCSH(I) ILL=2*IL-1 11 READ(ITAPE2) (IOCORB(J,I),J=1,IL),(IELCSH(J,I),J=1,IL), * ((I1QNRD(J,K,I),K=1,3),J=1,ILL) ENDIF C C READ THE SPIN-ORBIT INTERACTION ONE-ELECTRON INTEGRALS FROM C THE INPUT TAPE. C IF(LPOS.GT.0) GO TO 16 READ(ITAPE2) IRK5 IF(LRANG1.GT.IDMTST(16)) CALL RECOV1(16,LRANG1) IF(IRK5.GT.IDMTST(19)) CALL RECOV1(19,IRK5) READ(ITAPE2) (IST1(I),I=1,LRANG1),(RSPOR1(I),I=1,IRK5) READ(ITAPE2) IRK6 IF(IRK6.GT.IDMTST(20)) CALL RECOV1(20,IRK6) READ(ITAPE2) (IST2(I),I=1,LRANG1),(RSPOR2(I),I=1,IRK6) DO 12 I=2,LRANG2 READ(ITAPE2) IRK7 IF(IRK7.GT.L21) STOP 12 READ(ITAPE2) (RSPOR3(J,I),J=1,IRK7) C C IF NAST IS -VE SKIP OVER THE LS TARGET DATA C 13 IF(NDIAG.EQ.1.AND.LPOS.EQ.0) THEN READ(ITAPE2) LNUM DO 15 I=1,LNUM READ(ITAPE2) IL,IS,IP,IN,LD IF(IN.GE.0) GO TO 15 IFIN=-IN DO 14 J=1,IFIN 14 READ(ITAPE2) INIT 15 READ(ITAPE2) H ENDIF C C DOUBLE THE ANGULAR MOMENTUM VALUES C 16 LRGL=LRGL0*2 NSPN=NSPN0-1 DO 17 I=1,NCHAN 17 L2P(I)=L2P(I)*2 C C DEFINE THE LSTARG ARRAY C IFIN=0 DO 19 I=1,NAST IF(NCONAT(I).EQ.0) GO TO 19 INIT=IFIN+1 IFIN=IFIN+NCONAT(I) DO 18 J=INIT,IFIN 18 LSTARG(J)=I 19 CONTINUE C C IF THIS IS A NEW LS SYMMETRY, DEFINE THE ARRAYS IN /ALPHA/. C INAST = TOTAL NUMBER OF LS SYMMETRIES STORED. C ALSO IF SPIN-ORBIT INTERACTION IS TO BE CALCULATED: /JRELOP(3)/=1 C LPOS=LPOS+1 IF(LPOS.GT.IDMTST(44)) CALL RECOV1(44,LPOS) ! '01MAR30 IF(LPOS.GT.INAST) THEN L2(LPOS)=LRGL LS(LPOS)=NSPN 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 23 K1=1,NCHAN KAB12=(K1-1)*NRANG2 DO 22 K2=1,K1 KAB13=(K2-1)*NRANG2 IF(IBUG4.GT.1) WRITE(IWRITE,1004) K1,K2, L2P(K1)/2,L2P(K2)/2 !'05N READ(ITAPE2) ((HLS(KAB13+I,KAB12+J),J=1,NRANG2),I=1,NRANG2) IF(IBUG4.LT.4) GO TO 22 JUP=0 20 JLO=JUP+1 JUP=MIN(JUP+8,NRANG2) DO 21 I=1,NRANG2 21 WRITE(IWRITE,1006) (HLS(KAB13+I,KAB12+J),J=JLO,JUP) WRITE(IWRITE,1006) IF (JUP.LT.NRANG2) GO TO 20 22 CONTINUE C IF(JRELOP(3).EQ.0) GO TO 23 C OUT IF(ABS(JRELOP(3)).LE.1) GO TO 23 C OUT READ(ITAPE2) (HLS(KAB12+I,0),I=1,NRANG2) 23 CONTINUE C C READ THE REMAINDER OF THE STG2R OUTPUT TAPE C IF(NCFGP.EQ.0) GO TO 28 IF(NCFGP.GT.IDMTST(13)) CALL RECOV1(13,NCFGP) C C READ IN AND IF REQUIRED WRITE OUT THE BOUND-CONTINUUM C LS-HAMILTONIAN BLOCKS. C DO 26 K=1,NCHAN KAB21=NRANG2*(K-1) READ(ITAPE2) ((HLS(KAB21+I,NCONHP+J),J=1,NCFGP),I=1,NRANG2) IF (IBUG4.LT.3) GO TO 26 WRITE(IWRITE,1016) K DO 25 I=1,NRANG2 25 WRITE(IWRITE,1005) I,(HLS(KAB21+I,NCONHP+J),J=1,NCFGP) WRITE(IWRITE,1005) 26 CONTINUE C C READ IN AND IF REQUIRED WRITE OUT THE BOUND-BOUND C LS-HAMILTONIAN MATRICES C DO 27 I=1,NCFGP READ(ITAPE2) (HLS(NCONHP+I,NCONHP+J),J=I,NCFGP) IF (IBUG4.LT.2) GO TO 27 WRITE(IWRITE,1017) I, NCONHP,KAB1 WRITE(IWRITE,1006) (HLS(NCONHP+I,NCONHP+J),J=I,NCFGP) 27 CONTINUE C C READ IN AND IF REQUIRED PRINT THE LS-LONG RANGE C POTENTIAL COEFFICIENTS. *** NOTE CHANGE IN INPUT OF CF *** C 28 IF(LAMAX.LE.0) GO TO 31 DO 292 I=1,NCHAN READ(ITAPE2) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) DO 291 K=1,LAMAX DO 291 J=I,NCHAN 291 CF(J,I,K)=CF(I,J,K) 292 CONTINUE IF(IBUG4.LT.1) GO TO 31 WRITE(IWRITE,"(/' COEFFICIENT MATRIX CF(I,J,K)) LPOS =',I3)")LPOS DO 30 K=1,LAMAX WRITE(IWRITE,1012) K DO 29 I=1,NCHAN 29 WRITE(IWRITE,1013) I,(CF(I,J,K),J=1,I) 30 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/