C N. R. BADNELL UoS v1.11 - QUB vx.x 13/08/09 C C PROGRAM NXANG/STG1NX C C *** THIS IS THE ANGULAR STAGE OF RMATRX NX C PROGRAM MAIN IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C SUN REAL*4 TARRY(2),TIME C C C C PARAMETER(MACDIM=MZMAC) C PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) PARAMETER(ILDIM1=MZLR3,ILDIM3=MZLR4) PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) PARAMETER(LBUFFV=MZBUF) !,LBUFFZ=MZBUF) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) PARAMETER(ILDIM2=ILDIM1+ILDIM1-1) PARAMETER(ILDIM4=ILDIM3+ILDIM3) C PARAMETER(ILDIM6=2*ILDIM3 + 4*ILDIM1 - 4) PARAMETER(ISDIM3=(ISDIM1*(ISDIM1+1))/2 +1) C C ILDIM1 - MAX. TARGET ANGULAR MOMENTUM +1 (LRANG3) C ILDIM3 - MAXIMUM VALUE OF LRGL+1 (LRANG4) C ISDIM1 - NO. OF SETS C ISDIM2 - MAX. NO. OF CONFIGURATIONS BELONGING TO A SET C ICDIM1 - NO. OF CONFIGURATIONS (NCFG) C ICDIM2 - NO. OF SHELLS C LBUFF1 - LENGTH OF BUFFER FOR R INTEGRALS C LBUFFV - THE LENGTH OF THE BUFFERS FOR THE C VSH AND IRHSGL ARRAYS C LBUFFZ - THE LENGTH OF BUFFZ C COMMON/ANGBUF/BUFV1(LBUFFV),BUFV2(LBUFFV), 1 IBUFV1(LBUFFV),IBUFV2(LBUFFV) COMMON/ANGPNT/LAMIJ(ISDIM1,ISDIM1),IVCONT(ISDIM3),KRECZ(0:ILDIM4) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/DISC/JBUFF1,JBUFF2,JBUFIR,JBUFFV,JBUFFZ,JBUFD COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/SETL/LRGL,NPTY,LTOT,LVAL(ILDIM2),NSCOL(ILDIM2), 1 NSETL(ISDIM1,ILDIM2) COMMON/SETS/NSET,LSET(ISDIM1),ISPSET(ISDIM1),IPISET(ISDIM1), 1 NCSET(ISDIM1),NCFGSE(ISDIM1,ISDIM2) COMMON/STATES/NCFG,NOCCSH(ICDIM1),NOCORB(ICDIM2,ICDIM1), 1 NELCSH(ICDIM2,ICDIM1),J1QNRD(ICDIM3,3,ICDIM1), 2 MAXORB,NJCOMP(ICDIM2),LJCOMP(ICDIM2) C COMMON/NRBPTY/NPTYMN,NPTYMX,NPTYIN C 1000 FORMAT(/TR31,'END OF NXANG'/TR31,'------------'///) C C CALL STGARD(LRGLLO,LRGLUP) C C FORM THE CONFIGURATIONS INTO SETS WITH DIFFERENT L,S,PI C CALL CONSET C CALL FACTT C C CALCULATE DIRECT ANGULAR INTEGRALS INVOLVING ONLY THE TARGET C CALL DIRANG C C CALCULATE DIRECT ANGULAR TERMS INVOLVING RACAH COEFFICIENTS C FOR EACH REQUIRED TOTAL ANGULAR MOMENTUM C DO 1 LRGL=LRGLLO,LRGLUP DO 2 NPTY0=NPTYMN,NPTYMX IF(NPTYIN.LT.0)THEN NPTY=NPTY0 ELSE NPTY=MOD(LRGL,2)+NPTY0 NPTY=MOD(NPTY,2) ENDIF C C CONSTRUCT THE COUPLING OF THE TARGET CONFIGURATION SETS C WITH THE ALLOWED CONTINUUM ANGULAR MOMENTA FOR THIS LRGL,NPTY C CALL CUSETL C C GENERATE THE Z-COEFFICIENTS, I.E. TERM INVOLVING A RACAH C COEFFICIENT MULTIPLIED BY A PARITY COEFFICIENT C CALL GENCCZ(LRGLLO) 2 CONTINUE 1 CONTINUE C C WRITE Z-COEFFICIENT POINTER ARRAY TO BLOCK 2 C WRITE (JBUFFZ, REC=2) LRGLUP,KRECZ C WRITE(IWRITE,1000) C C C SUN DUM=DTIME(TARRY) TIME=TARRY(1) C CRAY CRAY CALL SECOND(TIME) C TIME=TIME/60.0 WRITE(IWRITE,999) TIME 999 FORMAT(//1X,9HCPU TIME=,F9.3,4H MIN) C C STOP END ********************************************************************** SUBROUTINE CUPSET(IS,JS,LAM1,LAM2,ICOUNT,NB,NRECV) C C COUPLES THE CONFIGURATIONS IN SET IS WITH THOSE IN JS C LAM1,LAM2 ARE THE LIMITS ON LAMBDA IMPOSED BY THE C CONFIGURATION ANGULAR MOMENTUM. THEY ARE RESET TO C THE LIMITS REQUIRED FOR THE SHELL INTERACTIONS. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(ICDIM2=MZORB) PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) C COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/SETS/NSET,LSET(ISDIM1),ISPSET(ISDIM1),IPISET(ISDIM1), 1 NCSET(ISDIM1),NCFGSE(ISDIM1,ISDIM2) C C COMMON/MEDEFN/IHSH,NJ(ICDIM2),LJ(ICDIM2),NOSH1(ICDIM2), 1 NOSH2(ICDIM2),J1QN1(ICDIM3,3),J1QN2(ICDIM3,3) C DIMENSION ICOMP(ICDIM2),VSHELL(ICDIM2),ISHL(ICDIM2) C 1000 FORMAT(/,28X,'SUBROUTINE CUPSET'/28X,'-----------------'/) 1001 FORMAT(' ICOUNT IRHSGL VSH') C IF (NBUG7 .GE. 1) THEN WRITE(IWRITE,1000) WRITE(IWRITE,1001) END IF C 1002 FORMAT(2I5,2(5X,I8),5X,E13.5) C C LAMMIN,LAMMAX ARE INITIALLY SET TO 999 AND ZERO RESPECTIVELY. C THEY THEN RECORD THE MINIMUM LOWER LIMIT AND THE C MAXIMUM UPPER LIMIT OF LAMBDA FOR ALL SHELL C INTERACTIONS IN THE SETS IS,JS. C LAMMIN=999 LAMMAX=0 C C CALCULATE FACTOR TO ENSURE VSH IS SYMMETRIC FOR INTERCHANGE C OF IS WITH JS C MINUS=(-1)**(LSET(IS)+IPISET(IS)) C C LOOP OVER CONFIGURATIONS IN IS AND JS C DO 1 ICS=1,NCSET(IS) IC=NCFGSE(IS,ICS) C C ALLOW FOR SYMMETRY IN LIMITS IF IS=JS C IF(IS .EQ. JS) THEN JCSLO = ICS ELSE JCSLO = 1 END IF C DO 2 JCS=JCSLO,NCSET(JS) JC=NCFGSE(JS,JCS) C C PREPARE COMMON BLOCK /MEDEFN/ TO COUPLE SHELLS C CALL SETUPD(IC,JC,ICOMP) C KRHO=0 KSIG=0 IF(IC .NE. JC) THEN C C TEST WHETHER CONFIGS IC,JC CAN INTERACT C IF THERE IS MORE THAN TWO ELECTRON DIFFERENCE THEY CANNOT C NOSHUM =0 DO 201 K=1,IHSH NOSHUM=NOSHUM + ABS(NOSH1(K) - NOSH2(K)) 201 CONTINUE IF(NOSHUM .GT. 2) THEN IF(NBUG7.GE.1)WRITE(IWRITE,1002)IS,JS,ICOUNT,9999,ZERO CALL STOREV(9999,ZERO,ICOUNT,NB,NRECV) GO TO 2 END IF C C FIND INTERACTING SHELLS KRHO AND KSIG C DO 202 K=1,IHSH IF(NOSH1(K) .GT. NOSH2(K)) THEN KRHO=K ELSE IF (NOSH1(K) .LT. NOSH2(K)) THEN KSIG=K END IF 202 CONTINUE C C IF CONFIGURATIONS HAVE SAME SHELLS FILLED C JUMP TO CASE WHEN IC=JC C END IF C IF (KRHO .NE. 0) THEN C C FIND ANGULAR MOMENTUM OF THE SHELLS C LRHO=LJ(KRHO) LSIG=LJ(KSIG) C C RESET LAMBDA TO OBEY TRIANGULAR RELATION WITH LRHO,LSIG C LAMLO=MAX(LAM1,ABS(LRHO-LSIG)) LAMUP=MIN(LAM2,LRHO+LSIG) C C IF NOT POSSIBLE SHELLS WILL NOT INTERACT C IF(LAMLO .GT. LAMUP) THEN IF(NBUG7.GE.1)WRITE(IWRITE,1002)IS,JS,ICOUNT,9999,ZERO CALL STOREV(9999,ZERO,ICOUNT,NB,NRECV) GO TO 2 END IF C C RECORD SHELL NUMBERS WITH REFERENCE TO LJCOMP WHICH IS IN THE C PERMANENT BLOCK /STATES/ C IRHO=ICOMP(KRHO) ISIG=ICOMP(KSIG) IRS=10000*IRHO + 100*ISIG C C LOOP OVER LAMBDA FOR INTERACTION OF IC AND JC C DO 3 LAM=LAMLO,LAMUP,2 C C CALCULATE THE COUPLING IN TENSOR C CALL TENSOR(LAM,0,IKRHO,IKSIG,VSHELL) C C IKRHO AND IKSIG ARE DUMMY ARGUMENTS AS SHELLS WERE C CALCULATED OUTSIDE THE ROUTINE C C STORE THE SHELL INTEGRAL IN VSH C AND RHO,SIG,LAM IN IRHSGL C IRHVAL=IRS+LAM VSHVAL=RME(LRHO,LSIG,LAM) * VSHELL(1) * MINUS IF (NBUG7 .GE. 1) THEN WRITE(IWRITE,1002)IS,JS,ICOUNT,IRHVAL,VSHVAL END IF CALL STOREV(IRHVAL,VSHVAL,ICOUNT,NB,NRECV) 3 CONTINUE C C NOW TREAT THE CASE IC = JC AND KRHO=KSIG C ALL SHELLS MAY CONTRIBUTE C LAMBDA LIMITS ARE THOSE IMPOSED BY CONFIGURATION C ANGULAR MOMENTUM C FOR A PARTICULAR LAMBDA SOME SHELLS NOT ALLOWED THROUGH C TRIANGULAR RULE C ELSE C 203 LAMLO=LAM1 LAMUP=LAM2 DO 4 LAM=LAMLO,LAMUP,2 C C STORE SHELL NUMBERS WHICH OBEY TRIANGLE RULE IN ARRAY ISHL C NSH=0 DO 401 ISHEL=1,IHSH LSIG=LJ(ISHEL) IF(LAM .GT. LSIG+LSIG) GO TO 401 NSH=NSH+1 ISHL(NSH)=ISHEL 401 CONTINUE C C IF NO SHELLS OBEY FOR THIS LAMBDA IGNORE HIGHER VALUES C OF LAMBDA AND STORE LAM IN IRHSGL C IF(NSH .EQ. 0) THEN LAMUP=LAM IRHVAL=LAM IF(NBUG7.GE.1)WRITE(IWRITE,1002)IS,JS,ICOUNT,-LAM,ZERO CALL STOREV(-LAM,ZERO,ICOUNT,NB,NRECV) GO TO 204 END IF C NSHL=NSH*10000 + LAM C C CALCULATE INTEGRAL OVER EACH PAIR OF SHELLS C STORE THOSE FOR SHELLS OBEYING TRIANGLE RULE C CALL TENSOR(LAM,0,IKRHO,IKSIG,VSHELL) 1003 FORMAT(' VSHELL=',6E13.5) IF (NBUG7 .GE. 2) THEN WRITE(IWRITE,1003)(VSHELL(I),I=1,IHSH) END IF C C IKRHO IS A DUMMY ARGUMENT C DO 5 ISN=1,NSH ISHEL=ISHL(ISN) LSIG=LJ(ISHEL) ISIG=ICOMP(ISHEL) C VSHVAL=RME(LSIG,LSIG,LAM) * VSHELL(ISHEL) * MINUS C C NOTE THAT ARRAY IRHSGL STORES NSH,ISIG AND LAMBDA C IN THIS CASE. IRHO=ISIG C IRHVAL=NSHL + 100*ISIG IF (NBUG7 .GE. 1) THEN WRITE(IWRITE,1002)IS,JS,ICOUNT,-IRHVAL,VSHVAL END IF CALL STOREV(-IRHVAL,VSHVAL,ICOUNT,NB,NRECV) 5 CONTINUE C 4 CONTINUE C C THIS CONCLUDES SPECIAL TREATMENT FOR KRHO=KSIG C END IF C C RECORD MINIMUM VALUE OF LAMLO AND MAXIMUM LAMUP C 204 LAMMIN=MIN(LAMMIN,LAMLO) LAMMAX=MAX(LAMMAX,LAMUP) C C C 2 CONTINUE C 1 CONTINUE C LAM1=LAMMIN LAM2=LAMMAX RETURN END ********************************************************************** SUBROUTINE CONSET C C CONSTRUCTS COMMON/SETS/ C ARRANGES CONFIGURATIONS INTO SETS HAVING THE SAME L,S,PI C THE CONFIGURATIONS ARE ASSUMED TO BE READ IN ALREADY C GROUPED ACCORDING TO L,S,PI C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) PARAMETER(ILDIM1=MZLR3) PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) PARAMETER(LBUFFV=MZBUF) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) C COMMON/SETS/NSET,LSET(ISDIM1),ISPSET(ISDIM1),IPISET(ISDIM1), 1 NCSET(ISDIM1),NCFGSE(ISDIM1,ISDIM2) COMMON/STATES/NCFG,NOCCSH(ICDIM1),NOCORB(ICDIM2,ICDIM1), 1 NELCSH(ICDIM2,ICDIM1),J1QNRD(ICDIM3,3,ICDIM1), 2 MAXORB,NJCOMP(ICDIM2),LJCOMP(ICDIM2) C C IS WILL COUNT THE SETS C LRANG3 WILL CONTAIN MAX. CONFIGURATION ANGULAR MOMENTUM + 1 C IS=0 LRANG3=0 C C LOOP OVER ALL CONFIGURATIONS READ C DO 1 IC=1,NCFG ISH=NOCCSH(IC) ISH2=ISH+ISH-1 IPARTY=0 C C LOOP OVER THE SHELLS OF THIS CONFIG. TO FIND THE PARITY C DO 2 ISHEL=1,ISH IL=NOCORB(ISHEL,IC) IPARTY=IPARTY+LJCOMP(IL)*NELCSH(ISHEL,IC) 2 CONTINUE C IPARTY=MOD(IPARTY,2) LCFG=(J1QNRD(ISH2,2,IC)-1)/2 ISPIN= J1QNRD(ISH2,3,IC) C IF(IS .NE. 0 ) THEN IF (LCFG .EQ. LSET(IS) .AND. 1 ISPIN .EQ. ISPSET(IS) .AND. 2 IPARTY .EQ. IPISET(IS)) THEN C C FILL CURRENT SET C ICS=ICS+1 IF (ISDIM2 .LT. ICS) CALL RECOV1(18,ICS,ISDIM2) NCSET(IS)=ICS NCFGSE(IS,ICS)=IC GO TO 1 END IF END IF C C START NEW SET C IS=IS+1 IF (ISDIM1 .LT. IS) CALL RECOV1(17,IS,ISDIM1) ICS=1 LSET(IS)=LCFG LRANG3=MAX(LRANG3,LCFG) ISPSET(IS)=ISPIN IPISET(IS)=IPARTY NCSET(IS)=1 NCFGSE(IS,ICS)=IC C 1 CONTINUE C NSET=IS LRANG3=LRANG3+1 IF (ILDIM1 .LT. LRANG3) CALL RECOV1(15,LRANG3,ILDIM1) LBLIM=1+NSET**2 + (NSET*(NSET+1))/2 IF (LBUFFV .LT. LBLIM) CALL RECOV1(27,LBLIM,LBUFFV) C RETURN END ********************************************************************** SUBROUTINE CUSETL C C TO DETERMINE WHICH SETS COUPLE WITH EACH VALUE OF THE C CONTINUUM ANGULAR MOMENTUM WITHIN THE RANGE ALLOWED C BY LRGL. THE INFORMATION IS STORED IN /SETL/. C THE COMMON BLOCK /SETL/ WILL BE STORED ON DISC FOR C EACH LRGL,NPTY COMBINATION. IT IS INDEPENDENT OF THE C TOTAL SPIN IN THE DIRECT CASE. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) PARAMETER(ILDIM1=MZLR3) PARAMETER(ILDIM2=ILDIM1+ILDIM1-1) C COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/SETL/LRGL,NPTY,LTOT,LVAL(ILDIM2),NSCOL(ILDIM2), 1 NSETL(ISDIM1,ILDIM2) COMMON/SETS/NSET,LSET(ISDIM1),ISPSET(ISDIM1),IPISET(ISDIM1), 1 NCSET(ISDIM1),NCFGSE(ISDIM1,ISDIM2) C C ARRAYS INTERMEDIATE TO /SETL/ ARRAYS C DIMENSION ILVAL(ILDIM2),INSCOL(ILDIM2),INSETL(ISDIM1,ILDIM2) C 1000 FORMAT(////2X,' TOTAL ANGULAR MOMENTUM ',I3,' PARITY ',I3) 1001 FORMAT(' KL L SETS COUPLED TO L') 1002 FORMAT(2X,15I6) 1003 FORMAT(//' ****** CONTINUUM ANGULAR MOMENTUM ******'/ 1 ' L TAKES VALUES BETWEEN ',I3,' AND ',I3) C IF (NBUG8 .EQ. 1) THEN WRITE(IWRITE,1000) LRGL,NPTY WRITE(IWRITE,1001) END IF C C FIND RANGE OF CONTINUUM ANGULAR MOMENTUM AND C SET UP ILVAL(KL) - THE POSSIBLE VALUES OF CONTINUUM C ANGULAR MOMENTUM C LMIN=999 LMAX=0 C DO 1 IS=1,NSET LCFG=LSET(IS) LMIN=MIN(LMIN,ABS(LCFG-LRGL)) LMAX=MAX(LMAX, LCFG) 1 CONTINUE LMAX=LMAX+LRGL ILTOT=LMAX-LMIN+1 C DO 2 KL=1,ILTOT ILVAL(KL)=LMIN+KL-1 2 CONTINUE C C LOOP OVER THIS RANGE OF CONTINUUM L C DO 3 KL=1,ILTOT L=ILVAL(KL) NL=0 C DO 4 IS=1,NSET LCFG=LSET(IS) IPI=IPISET(IS) C C PARITY TEST C IF(MOD(IPI+L+NPTY,2) .NE. 0) GO TO 4 C C TRIANGLE RULE C IF(LRGL .GT. LCFG+L .OR. 1 LRGL .LT. ABS(LCFG-L)) GO TO 4 C NL=NL+1 INSETL(NL,KL)=IS 4 CONTINUE C INSCOL(KL)=NL 3 CONTINUE C C NOW DELETE VALUES OF THE CONTINUUM ANGULAR MOMENTUM WHICH C CANNOT COUPLE WITH ANY SET AND CONSTRUCT /SETL/ C KL=0 DO 5 IKL=1,ILTOT IF (INSCOL(IKL) .NE. 0) THEN KL=KL+1 NSCOL(KL)=INSCOL(IKL) LVAL(KL)=ILVAL(IKL) DO 51 NL=1,NSCOL(KL) NSETL(NL,KL)=INSETL(NL,IKL) 51 CONTINUE END IF 5 CONTINUE LTOT=KL IF (LTOT .EQ. 0) RETURN LMIN=LVAL(1) LMAX=LVAL(LTOT) IF (NBUG8 .EQ. 1) THEN DO 6 KL=1,LTOT WRITE(IWRITE,1002)KL,LVAL(KL),(NSETL(NL,KL),NL=1,NSCOL(KL)) 6 CONTINUE WRITE (IWRITE,1003) LMIN,LMAX END IF C RETURN END ********************************************************************** SUBROUTINE DIRANG C TO CALCULATE THE DIRECT ANGULAR INTEGRAL OVER TARGET C CONFIGURATIONS. THE CONFIGURATIONS ARE ARRANGED IN C SETS ACCORDING TO L,S AND PI C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(ILDIM3=MZLR4) PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) PARAMETER(LBUFFV=MZBUF) PARAMETER(ILDIM4=ILDIM3+ILDIM3) PARAMETER(ISDIM3=(ISDIM1*(ISDIM1+1))/2 +1) C COMMON/ANGBUF/BUFV1(LBUFFV),BUFV2(LBUFFV), 1 IBUFV1(LBUFFV),IBUFV2(LBUFFV) COMMON/ANGPNT/LAMIJ(ISDIM1,ISDIM1),IVCONT(ISDIM3),KRECZ(0:ILDIM4) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/DISC/JBUFF1,JBUFF2,JBUFIR,JBUFFV,JBUFFZ,JBUFD COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/SETS/NSET,LSET(ISDIM1),ISPSET(ISDIM1),IPISET(ISDIM1), 1 NCSET(ISDIM1),NCFGSE(ISDIM1,ISDIM2) C 1000 FORMAT(/,28X,'SUBROUTINE DIRANG'/28X,'-----------------'/) 1001 FORMAT(4(4X,I8)) 1002 FORMAT(' IS JS IVCONT LAMIJ') C IF (NBUG7 .EQ. 1) THEN WRITE(IWRITE,1000) END IF C C SET COUNTER FOR THE STORAGE ARRAY VSH(ICOUNT) C ICOUNT=1 C C SET INITIAL RECORD NUMBER AND BUFFER INDICATOR FOR C DISC STORAGE OF THE VSH ARRAY C NRECV=3 NB=0 C C LOOP OVER SETS C ISJS=1 IVCONT(ISJS)=NRECV*LBUFFV + ICOUNT DO 1 IS=1,NSET LCFG=LSET(IS) ISPIN=ISPSET(IS) IPI=IPISET(IS) C DO 2 JS=IS,NSET C C SET LAMIJ = -999 TO INDICATE IS,JS NOT COMPATIBLE C LAMIJ WILL BE RESET IF IS,JS CAN INTERACT C TO STORE LAMBDA LIMITS C LAMIJ(IS,JS)=-999 C IF (IS .NE. JS) THEN LCFGP=LSET(JS) JSPIN=ISPSET(JS) JPI=IPISET(JS) C C IF TARGET SPINS UNEQUAL IS,JS DO NOT CONTRIBUTE C IF (ISPIN .NE. JSPIN) GO TO 21 C C CALCULATE LAMBDA LIMITS USING TRIANGULAR RELATION C AND PARITY RULE C LAMLO=ABS(LCFG - LCFGP) LAMUP=LCFG + LCFGP IF(MOD(LAMLO + IPI + JPI,2) .NE. 0) THEN LAMLO=LAMLO + 1 C C IF LAMBDA LIMITS IMPOSSIBLE IS,JS DO NOT CONTRIBUTE C IF(LAMLO .GT. LAMUP) GO TO 21 C END IF C C WHEN IS EQUALS JS THERE MUST BE A CONTRIBUTION C ELSE LAMLO=0 LAMUP=LCFG + LCFG END IF C C CALL CUPSET TO CALCULATE INTERACTION BETWEEN EACH C CONFIGURATION IN SET IS WITH EACH IN JS C KCOUNT=ICOUNT KB=NB KRECV=NRECV CALL CUPSET(IS,JS,LAMLO,LAMUP,KCOUNT,KB,KRECV) C C ON EXIT LAMLO IS RESET TO THE MINIMUM LAMLO USED C LAMUP IS RESET TO THE MAXIMUM LAMUP USED C ICOUNT IS THE NEW POSITION IN THE RESULT FILE C LAMLO SET 999 IF NO CONFIGS INTERACTED C IF (LAMLO .NE. 999) THEN C C RECORD CURRENT ICOUNT, NB, NRECV AND LAMBDA LIMITS C ICOUNT=KCOUNT NB=KB NRECV=KRECV C LAMIJ(IS,JS)=LAMLO*100 + LAMUP ELSE ! NRB 25/10/99 IF(KRECV.GT.NRECV+1)THEN WRITE(IWRITE,*)' *** ATTENTION: TO REDUCE I/O, INCREASE MZBUF' X ,' TO AT LEAST ',2*LBUFFV IF(NB.EQ.0)THEN READ(JBUFIR,REC=NRECV)IBUFV1 READ(JBUFFV,REC=NRECV)BUFV1 ELSE READ(JBUFIR,REC=NRECV)IBUFV2 READ(JBUFFV,REC=NRECV)BUFV2 ENDIF ENDIF END IF C C RECORD STARTING POSITION OF NEXT SET PAIR C 21 ISJS=ISJS+1 IVCONT(ISJS)=NRECV*LBUFFV + ICOUNT C IF (NBUG7 .EQ. 1) THEN WRITE(IWRITE,1002) WRITE(IWRITE,1001)IS,JS,IVCONT(ISJS-1),LAMIJ(IS,JS) ENDIF C 2 CONTINUE C 1 CONTINUE C WRITE REMAINING PARTLY FILLED BUFFERS TO DISC C FIRST COMPLETING THEM WITH ZEROS C IF (ICOUNT .GT. 1) THEN IF (NB .EQ. 0) THEN DO 31 I=ICOUNT,LBUFFV IBUFV1(I)=0 BUFV1(I)=ZERO 31 CONTINUE WRITE (JBUFIR, REC=NRECV) IBUFV1 WRITE (JBUFFV, REC=NRECV) BUFV1 ELSE DO 32 I=ICOUNT,LBUFFV IBUFV2(I)=0 BUFV2(I)=ZERO 32 CONTINUE WRITE (JBUFIR, REC=NRECV) IBUFV2 WRITE (JBUFFV, REC=NRECV) BUFV2 END IF END IF C C C WRITE POINTER ARRAYS TO BLOCK 2 C WRITE(JBUFIR,REC=2)NSET,((LAMIJ(IS,JS),IS=1,NSET),JS=1,NSET), 1 (IVCONT(I),I=1,ISJS) RETURN END ********************************************************************** SUBROUTINE FACTT C C CALCULATES THE LOGS OF FACTORIALS REQUIRED BY THE RACAH C COEFFICIENT ROUTINE DRACAH C WRITTEN BY N.S. SCOTT C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' COMMON /FACTS / GAM(500) DATA FIFTY,ONE,TWO/50.0D0,1.0D0,2.0D0/ GAM(1)=ONE GAM(2)=ONE X=TWO DO 10 I=3,25 GAM(I)=GAM(I-1)*X X=X+ONE 10 CONTINUE DO 20 I=1,25 GAM(I)=LOG(GAM(I)) 20 CONTINUE X=FIFTY/TWO DO 30 I=26,500 GAM(I)=GAM(I-1)+LOG(X) X=X+ONE 30 CONTINUE RETURN END C*********************************************************************** SUBROUTINE DRACAH(I,J,K,L,M,N,RAC) C C SUBROUTINE TO CALCULATE RACAH COEFFICIENTS C THE ARGUMENTS I,J,K,L,M,N SHOULD BE TWICE THEIR ACTUAL VALUE C WORKS FOR INTEGER AND HALF-INTEGER VALUES OF ANGULAR MOMENTA. C THE ROUTINE MAKES USE OF THE GAM ARRAY, THUS SUBROUTINE FACTT C MUST BE CALLED BEFORE THIS ROUTINE IS USED. C WRITTEN BY N S SCOTT. C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' COMMON/FACTS/ GAM(500) C DATA ZERO,ONE,TWO/0.0D0,1.0D0,2.0D0/ C C J1=I+J+M J2=K+L+M J3=I+K+N J4=J+L+N IF((2*MAX0(I,J,M)-J1).GT.0.OR.MOD(J1,2).NE.0) GO TO 2 IF((2*MAX0(K,L,M)-J2).GT.0.OR.MOD(J2,2).NE.0) GO TO 2 IF((2*MAX0(I,K,N)-J3).GT.0.OR.MOD(J3,2).NE.0) GO TO 2 IF((2*MAX0(J,L,N)-J4).GT.0.OR.MOD(J4,2).NE.0) GO TO 2 GO TO 1 2 RAC=ZERO RETURN 1 CONTINUE J1=J1/2 J2=J2/2 J3=J3/2 J4=J4/2 J5=(I+J+K+L)/2 J6=(I+L+M+N)/2 J7=(J+K+M+N)/2 NUMIN=MAX0(J1,J2,J3,J4)+1 NUMAX=MIN0(J5,J6,J7)+1 RAC=ONE ICOUNT=0 IF(NUMIN.EQ.NUMAX) GO TO 4 NUMIN=NUMIN+1 DO 3 KK=NUMIN,NUMAX KI=NUMAX-ICOUNT RAC=ONE -(RAC*DBLE((KI*(J5-KI+2)*(J6-KI+2)*(J7-KI+2)))/ * DBLE((KI-1-J1)*(KI-1-J2)*(KI-1-J3)*(KI-1-J4))) ICOUNT=ICOUNT+1 3 CONTINUE NUMIN=NUMIN-1 4 RAC=RAC*((-ONE )**(J5+NUMIN+1))*EXP((GAM(NUMIN+1)-GAM(NUMIN-J1) * -GAM(NUMIN -J2)-GAM(NUMIN -J3)-GAM(NUMIN -J4)-GAM(J5+2-NUMIN) * -GAM(J6+2-NUMIN)-GAM(J7+2-NUMIN))+((GAM(J1+1-I)+GAM(J1+1-J) * +GAM(J1+1-M)-GAM(J1+2)+GAM(J2+1-K)+GAM(J2+1-L)+GAM(J2+1-M) * -GAM(J2+2)+GAM(J3+1-I)+GAM(J3+1-K)+GAM(J3+1-N)-GAM(J3+2) * +GAM(J4+1-J)+GAM(J4+1-L)+GAM(J4+1-N)-GAM(J4+2))/TWO )) RETURN END ********************************************************************** SUBROUTINE GENCCZ(LRGLLO) C C TO GENERATE Z COEFFICIENTS IN THE DIRECT CASE FOR GIVEN LRGL C SPIN AND PARITY C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(ILDIM1=MZLR3,ILDIM3=MZLR4) PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) C PARAMETER(LBUFFZ=MZBUF) C PARAMETER(ILDIM2=ILDIM1+ILDIM1-1) PARAMETER(ILDIM4=ILDIM3+ILDIM3) PARAMETER(ISDIM3=(ISDIM1*(ISDIM1+1))/2 +1) COMMON/ANGPNT/LAMIJ(ISDIM1,ISDIM1),IVCONT(ISDIM3),KRECZ(0:ILDIM4) COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/DISC/JBUFF1,JBUFF2,JBUFIR,JBUFFV,JBUFFZ,JBUFD COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/SETL/LRGL,NPTY,LTOT,LVAL(ILDIM2),NSCOL(ILDIM2), 1 NSETL(ISDIM1,ILDIM2) COMMON/SETS/NSET,LSET(ISDIM1),ISPSET(ISDIM1),IPISET(ISDIM1), 1 NCSET(ISDIM1),NCFGSE(ISDIM1,ISDIM2) C COMMON/NRBPTY/NPTYMN,NPTYMX,NPTYIN C DIMENSION BUFFZ(LBUFFZ) C 1000 FORMAT(' ',10X,'SUBROUTINE GENCCZ LRGL=',I3,'NPTY=',I3) 1001 FORMAT(' IZCONT LCFG LCFGP L LP LAM LRGL RAC'/) 1002 FORMAT(' ',7I6,3X,E13.5) C IF (NBUG9 .EQ. 1) THEN WRITE(IWRITE,1000) LRGL,NPTY WRITE(IWRITE,1001) END IF C C SET COUNT FOR Z COEFFICIENTS C IZCONT=0 C LRGL2=LRGL+LRGL C C CALCULATE FACTOR IN Z-COEFFICIENT C MINUS=(-1)**(LRGL+NPTY) C C FIND RECORD NUMBER OF LAST FILLED BLOCK READY TO SEND C A BLOCK OF Z TO DISC C IF(NPTYIN.LT.0)THEN IRECZ=LRGL2+NPTY IF (IRECZ .EQ. LRGLLO+LRGLLO) KRECZ(IRECZ)=3 ELSE IRECZ=LRGL IF(IRECZ.EQ.LRGLLO)KRECZ(IRECZ)=3 ENDIF NRECZ=KRECZ(IRECZ) C C LOOP OVER CONTINUUM ANGULAR MOMENTUM IN THE RANGE ALLOWED C BY LRGL AND MAXIMUM TARGET LCFG C DO 1 KL=1,LTOT L=LVAL(KL) L2=L+L C DO 2 KLP=KL,LTOT LP=LVAL(KLP) LP2=LP+LP C C LOOP OVER THE SETS COUPLED TO L AND LP C DO 3 I=1,NSCOL(KL) IS=NSETL(I,KL) LCFG=LSET(IS) LCFG2=LCFG+LCFG C C LIMITS FOR J C JLO=1 IF(L .EQ. LP) JLO=I C DO 4 J=JLO,NSCOL(KLP) JS=NSETL(J,KLP) C C THE SYMMETRIC MATRIX LAMIJ(IS,JS) SET IN DIRANG ASSUMES C THAT JS ALWAYS .GE. IS C WHEN IS .GT. JS THE SETS MUST BE REVERSED C IF(IS .GT. JS) THEN KIS=JS KJS=IS ELSE KIS=IS KJS=JS END IF C LAMLU=LAMIJ(KIS,KJS) IF(LAMLU .EQ. -999) GO TO 4 C C CALCULATE LAMBDA LIMITS CONSISTENT WITH TARGET AND C CONTINUUM ANGULAR MOMENTUM C LAMLO=LAMLU/100 LAMUP=MOD(LAMLU,100) LAMMIN=MAX(ABS(L-LP),LAMLO) LAMMAX=MIN(L+LP,LAMUP) IF(LAMMIN .GT. LAMMAX) GO TO 4 LCFGP=LSET(JS) LCFGP2=LCFGP+LCFGP C C LOOP OVER LAMBDA C DO 5 LAM=LAMMIN,LAMMAX,2 LAM2=LAM+LAM IZCONT=IZCONT+1 CALL DRACAH(LCFG2,LCFGP2,L2,LP2,LAM2,LRGL2,RAC) ZCOEFF=RAC * RME (L,LP,LAM) * MINUS BUFFZ(IZCONT)=ZCOEFF IF (IZCONT .EQ. LBUFFZ) THEN WRITE (JBUFFZ, REC=NRECZ) BUFFZ NRECZ=NRECZ+1 IZCONT=0 END IF IF (NBUG9 .EQ. 1) THEN WRITE(IWRITE,1002)IZCONT,LCFG,LCFGP,L,LP,LAM,LRGL,ZCOEFF END IF 5 CONTINUE C 4 CONTINUE C 3 CONTINUE C 2 CONTINUE C 1 CONTINUE C IF (IZCONT .NE. 0) THEN IZCONT=IZCONT+1 C C COMPLETE BUFFER WITH ZEROS C DO 6 IZ=IZCONT,LBUFFZ BUFFZ(IZ)=ZERO 6 CONTINUE WRITE(JBUFFZ, REC=NRECZ) BUFFZ NRECZ=NRECZ+1 END IF C KRECZ(IRECZ+1)=NRECZ C RETURN END ********************************************************************** SUBROUTINE SETUPD(JA,JB,ICOMP) C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) C COMMON/MEDEFN/IHSH,NJ(ICDIM2),LJ(ICDIM2),NOSH(ICDIM2,2), 1 J1QN(ICDIM3,3,2) COMMON/STATES/NCFG,NOCCSH(ICDIM1),NOCORB(ICDIM2,ICDIM1), 1 NELCSH(ICDIM2,ICDIM1),J1QNRD(ICDIM3,3,ICDIM1), 2 MAXORB,NJCOMP(ICDIM2),LJCOMP(ICDIM2) C DIMENSION ICOMP(ICDIM2) C C NOTICE THE DIFFERENT NAMES IN THE COMMON BLOCK MEDEFN - WE C STORE NOSH1(I=1,10) AS NOSH((I=1,10),1) AND NOSH2(I=1,10) AS C NOSH((I=1,10),2) AND USE THE FACT THAT NOSH1 AND NOSH2 WILL THEN C BE EQUIVALENT TO THE SINGLE 2-DIMENSIONAL ARRAY NOSH. SIMILARLY C FOR J1QN C C === GENERATES THE ARRAYS NJ,LJ - DEFINING THE QUANTUM NUMBERS OF THE C SHELLS, NOSH - DEFINING THE OCCUPATION OF THE SHELLS, J1QN - C DEFINING THE COUPLING OF THE SHELLS, FOR EACH OF THE TWO C CONFIGURATIONS CONSIDERED. ONLY THOSE SHELLS OCCURRING IN AT C LEAST ONE CONFIGURATION ARE INCLUDED. C AT LEAST TWO SHELLS MUST BE CONSIDERED OCCUPIED. C THUS (1S)**2 HELIUM MUST BE TREATED AS ,E.G., (1S)**2(2S)**0 C THE SIZE OF THE ARRAYS HERE CALCULATED IS ARRANGED TO BE NO C GREATER THAN IS NECESSARY TO INCLUDE ALL ORBITALS WHICH ARE C DEEMED TO BE OCCUPIED IN EITHER OR BOTH OF THE CONFIGURATIONS C JA,JB C C --- INITIALIZE BASIC QUANTITIES - (I1+1) RUNS OVER 1,MAXORB, IHSH IS C THE CURRENT VALUE OF THE HIGHEST OCCUPIED SHELL YET CONSIDERED, C WHILE I2HSH=2*IHSH-1 C I1=0 IHSH=0 I2HSH=-1 IA=NOCCSH(JA) IB=NOCCSH(JB) C C --- TEST ON WHETHER LIMIT OF I1 HAS BEEN REACHED C 1 IF(I1-MAXORB) 101,100,100 C C --- INCREASE BASIC QUANTITIES C 101 I1=I1+1 I3=IHSH+1 I5=I2HSH+I3 C C --- IS THE SHELL I1 OCCUPIED IN JA C DO 2 J=1,IA IF(I1-NOCORB(J,JA)) 2,3,2 2 CONTINUE NA=1 GO TO 4 3 NA=2 J1=J C C --- IS THE SHELL I1 OCCUPIED IN JB C 4 DO 5 J=1,IB IF(I1-NOCORB(J,JB)) 5,6,5 5 CONTINUE NB=1 GO TO 7 6 NB=2 J2=J C C IF THE SHELL I1 IS NOT OCCUPIED IN EITHER JA OR JB, IGNORE THE C SHELL, DO NOT INCREASE IHSH, AND CONSIDER NEXT SHELL BY INCREASING C I1 C 7 IF(NA-1) 8,8,9 8 IF(NB-1) 1,1,9 C C --- IF THE SHELL I1 IS OCCUPIED IN EITHER JA OR JB - C (1) IF IHSH.GT.1, THEN ALREADY AT LEAST TWO SHELLS AND THE C RESULTING COUPLINGS HAVE BEEN STORED. WE MUST THUS MAKE ROOM FOR C THE QUANTUM NUMBERS OF THIS NEW SHELL BETWEEN THE QUANTUM NUMBERS C OF THE PREVIOUS SHELLS AND THE QUANTUM NUMBERS OF THE INTERMEDIATE C COUPLINGS OF THE CONFIGURATIONS. THUS THE LATTER SET ARE =MOVED C ALONG= TO MAKE ROOM FOR THE NEW SHELL C (2) IF IHSH.LE.1, THERE ARE NO INTERMEDIATE COUPLING QUANTUM C NUMBERS, AND SO THERE IS NOTHING TO MOVE C 9 IF(IHSH-1) 11,11,10 10 DO 12 I=1,2 DO 13 J=I3,I2HSH I4=I5-J DO 14 K=1,3 J1QN(I4+1,K,I)=J1QN(I4,K,I) 14 CONTINUE 13 CONTINUE 12 CONTINUE 11 IHSH=I3 I2HSH=I2HSH+2 NC=NA I=1 IC=J1 JC=JA C C --- FIRST CONSIDER THE L.H.S. (I=1) OF THE MATRIX ELEMENT. NC=1 MEANS C UNOCCUPIED, REPRESENTED BY A DUMMY SINGLET S SHELL, AND THE C ADDITIONAL SET OF COUPLING QUANTUM NUMBERS WILL BE THE SAME AS THE C LAST SET OF COUPLING QUANTUM NUMBERS ALREADY OBTAINED. C NC=2 MEANS OCCUPIED. THEN ALL THE NEW QUANTUM NUMBERS (BOTH FOR C THE SHELL AND FOR THE COUPLING OF THIS SHELL TO THE RESULTANT OF C THE PREVIOUS ONES) ARE DEFINED IN THE CORRESPONDING J1QNRD ARRAY. C NOSH - THE NUMBER OF ELECTRONS IN THIS SHELL, IS DEFINED BY THE C APPROPRIATE ENTRY IN NELCSH . THE R.H.S. IS THEN CONSIDERED C SIMILARLY (I=2) C 25 GO TO (15,16),NC 15 NOSH(IHSH,I)=0 J1QN(IHSH,1,I)=0 J1QN(IHSH,2,I)=1 J1QN(IHSH,3,I)=1 IF(IHSH-2) 22,18,19 18 J1QN(3,1,I)=0 J1QN(3,2,I)=J1QN(1,2,I) J1QN(3,3,I)=J1QN(1,3,I) GO TO 22 19 DO 27 K=1,3 J1QN(I2HSH,K,I)=J1QN(I2HSH-1,K,I) 27 CONTINUE GO TO 22 16 IF(I.GE.2) GO TO 38 NOSH(IHSH,I)=NELCSH(IC,JC) DO 20 K=1,3 J1QN(IHSH,K,I)=J1QNRD(IC,K,JC) C C IS THIS THE FIRST OCCUPIED SHELL OF EITHER CONFIGURATION. IF SO, C THEN THERE ARE NO INTERMEDIATE COUPLINGS TO CONSIDER AT THIS STAGE C IF(IHSH-1) 20,20,21 C C IS THIS THE FIRST OCCUPIED SHELL OF THIS CONFIGURATION, THOUGH NOT C THE FIRST OF THE OTHER CONFIGURATION. IF SO, THE INTERMED9ATE C COUPLING FORMED HAS THE SAME L,S VALUES AS THIS OCCUPIED SHELL, C SINCE WE COUPLE THE SHELL TO A DUMMY SINGLET S. C 21 IF(IC-1) 26,26,29 26 I2=1 IF(K-1) 28,17,28 C C SENIORITY SET (ARBITRARILY) ZERO FOR INTERMEDIATE COUPLING C 17 J1QN(I2HSH,1,I)=0 GO TO 20 29 I2=NOCCSH(JC)+IC-1 28 J1QN(I2HSH,K,I)=J1QNRD(I2,K,JC) 20 CONTINUE GO TO 22 38 NOSH(IHSH,I)=NELCSH(ICE,JCE) DO 30 K=1,3 J1QN(IHSH,K,I)=J1QNRD(ICE,K,JCE) IF(IHSH.LE.1) GO TO 30 C C IS THIS THE FIRST OCCUPIED SHELL OF THIS CONFIGURATION, THOUGH NOT C THE FIRST OF THE OTHER CONFIGURATION. IF SO, THE INTERMEDIATE C COUPLING FORMED HAS THE SAME L,S VALUES AS THIS OCCUPIED SHELL, C SINCE WE COUPLE THE SHELL TO A DUMMY SINGLET S. C IF(ICE.GT.1) GO TO 31 I2=1 IF(K.NE.1) GO TO 32 J1QN(I2HSH,1,I)=0 GO TO 30 31 I2=NOCCSH(JCE)+ICE-1 32 J1QN(I2HSH,K,I)=J1QNRD(I2,K,JCE) 30 CONTINUE 22 IF(I-2) 23,24,24 23 NC=NB I=2 ICE=J2 JCE=JB GO TO 25 C C --- SET THE NJ AND LJ VALUES OF THE OCCUPIED SHELLS C 24 NJ(IHSH)=NJCOMP(I1) LJ(IHSH)=LJCOMP(I1) C C --- SET UP THE ARRAY ICOMP TO RELATE ARRAYS NJ AND NJCOMP C ICOMP(IHSH)=I1 C C --- RETURN TO 1 TO SEE IF MAXORB HAS BEEN REACHED C GO TO 1 100 RETURN END C*********************************************************************** SUBROUTINE STGARD(LRGLLO,LRGLUP) C C READ IN AND WRITE OUT THE INPUT DATA C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C CHARACTER*8 FILEA,FILEB,FILEC,FILED CHARACTER*1 LVALUE,PAR CHARACTER*4 CONT,TITLE C CHARACTER*4 PARITY C CHARACTER*8 SPIN C PARAMETER(MACDIM=MZMAC) C PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) PARAMETER(ILDIM3=MZLR4) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) C PARAMETER(LBUFFV=MZBUF,LBUFFZ=MZBUF) C COMMON/BNDCON/NCFGP,IOCCSH(ICDIM1),IOCORB(ICDIM2,ICDIM1), 1 IELCSH(ICDIM2,ICDIM1),I1QNRD(ICDIM3,3,ICDIM1) COMMON/CUPPLE/NOPTN,MNAL(ICDIM2),MXAL(ICDIM2), 1 IBASSH(5,ICDIM2),NXCITE(5),IXCITE(2,6),JREAD COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/DISC/JBUFF1,JBUFF2,JBUFIR,JBUFFV,JBUFFZ,JBUFD COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/OCCSH /NOCC,NOCSH(ICDIM1),NOCOR(ICDIM2,ICDIM1), 1 NELSH(ICDIM2,ICDIM1) COMMON/STATES/NCFG,NOCCSH(ICDIM1),NOCORB(ICDIM2,ICDIM1), 1 NELCSH(ICDIM2,ICDIM1),J1QNRD(ICDIM3,3,ICDIM1), 2 MAXORB,NJCOMP(ICDIM2),LJCOMP(ICDIM2) C COMMON/NRBPTY/NPTYMN,NPTYMX,NPTYIN C DIMENSION TITLE(18) DIMENSION LVALUE(5),PAR(2) C DIMENSION PARITY(2),SPIN(6) DIMENSION NORDER(ICDIM2) DATA LVALUE(1),LVALUE(2),LVALUE(3),LVALUE(4),LVALUE(5)/ 1 'S', 'P', 'D', 'F', '*'/ C DATA PARITY(1)/'EVEN'/, PARITY(2)/' ODD'/ C DATA SPIN(1)/' SINGLET'/, SPIN(2)/' DOUBLET'/, SPIN(3)/' TRIPLET'/ C 1 ,SPIN(4)/' QUARTET'/, SPIN(5)/' QUINTET'/, SPIN(6)/' 2S+1=**'/ DATA PAR(1)/'E'/, PAR(2)/'O'/ C 1000 FORMAT(/,28X,'SUBROUTINE STGARD'/28X,'-----------------'/) 1001 FORMAT (TR31,'***********'/TR31,'** **'/TR31,'** NXANG **'/ 1 TR31,'** **'/TR31,'***********'//) 1002 FORMAT( /8X, 1'----------------------------------------------------------------' 2// 8X,18A4//8X, 3'----------------------------------------------------------------' 4////) 1003 FORMAT(//' OUTPUT CHANNEL UNIT NUMBER=',I3/ 1 ' INPUT CHANNEL UNIT NUMBER=',I3/ 2 ' TARGET ANGULAR FILE--INTEGER UNIT NUMBER=',I3, 3 ' NAME= ',A8/ 4 ' REAL UNIT NUMBER=',I3, 5 ' NAME= ',A8/ 6 ' RACAH ANGULAR FILE UNIT NUMBER=',I3, 7 ' NAME= ',A8) 1004 FORMAT(' DEBUG PARAMETERS'/12I5) 1005 FORMAT(' ANGULAR COEFFICIENTS ARE TO BE CALCULATED OVER VALUES' 1 /' OF THE TOTAL ANGULAR MOMENTUM FROM ',I3,' TO ',I3/ 2 ' AND TOTAL PARITY EVEN AND ODD IN EACH CASE'/) 1006 FORMAT(8H ORBITAL,I3,2H =,I2,A1) 1007 FORMAT(1X,30I3) 1008 FORMAT(///' NUMBER OF CONFIGURATIONS =',I5) 1009 FORMAT(' NUMBER OF OCCUPIED SHELLS IN THESE CONFIGURATIONS') 1010 FORMAT(' CONFIGURATION',I3/6X,' OCCUPIED ORBITALS ARE',32X,10I3) 1011 FORMAT(5X,' NUMBER OF ELECTRONS IN RESPECTIVE OCCUPIED SHELLS', 15X,10I3) 1012 FORMAT(5X,' COUPLING SCHEME') 1013 FORMAT(5X,3I3,6(I10,2I3)) 1015 FORMAT(/' NUMBER OF ORBITALS=',I3,' NKEY CHOSEN ',I3) 1023 FORMAT(/' **** ALLOWED VALUES OF NKEY ARE -2, 0 OR 2') 1024 FORMAT(/' **** ALLOWED VALUES OF NOPTN ARE 0,1,2,3,4,5') 1025 FORMAT(' NUMBER OF ELECTRONS IN THE TARGET=',I3, 1 ' NUMBER OF DIFFERENT TARGET SYMMETRIES=',I3) 1026 FORMAT(/5X,23H OPTION CHOSEN, NOPTN =,I3) 1027 FORMAT( ' THE MINIMUM NUMBER OF ELECTRONS ALLOWED IN EACH SHELL 1IS ',(20I3)) 1028 FORMAT( ' THE MAXIMUM NUMBER OF ELECTRONS ALLOWED IN EACH SHELL 1IS ',(20I3)) 1029 FORMAT( ' BASIC CONFIGURATION',I2,37X,(20I3)) 1030 FORMAT(' THE MAXIMUM NUMBER OF ELECTRON EXCITATIONS REQUIRED =', 1 I3) 1032 FORMAT(' OPTION CHOSEN IS TO READ SHELL OCCUPATIONS'/ 1 ' NUMBER OF OCCUPATIONS=',I3) 1033 FORMAT(' NUMBER OF OCCUPIED SHELLS IN EACH'/30I3) 1034 FORMAT(' OCCUPATION',I3/6X,'OCCUPIED ORBITALS ARE',32X,10I3) 1035 FORMAT(5X,' NUMBER OF ELECTRONS IN RESPECTIVE OCCUPIED SHELLS', 1 15X,10I3) 1036 FORMAT(/' TOTAL NUMBER OF CONFIGURATIONS =',I5) 1038 FORMAT(' TOTAL NUMBER OF ELECTRONS =',I3,13X,' ORBITALS ARE',2X, 1 (20I3)) 1039 FORMAT(/I3,1X,A1/3X,A1) C C THE FOLLOWING FORMAT STATEMENTS ARE TO READ THE CARD INPUT DATA. C 2000 FORMAT(12I5) 2001 FORMAT(18A4) C DATA CONT/'CONT'/ C C NRB NPTYMN=0 NPTYMX=1 NPTYIN=-1 C C JREAD=0 !FOR NX CODE IREAD=5 IWRITE=6 JBUFIR=20 JBUFFV=21 JBUFFZ=22 FILEA='ANG1.DAT' FILEB='ANG2.DAT' FILEC='ANG3.DAT' OPEN(UNIT=IREAD,FILE='dstgnx',STATUS='UNKNOWN') OPEN(UNIT=IWRITE,FILE='rout1nx',STATUS='UNKNOWN') REWIND (IREAD) C OPEN DIRECT ACCESS FILES C OPEN(UNIT=JBUFIR,FILE=FILEA,ACCESS='DIRECT',STATUS='UNKNOWN', 1 RECL=MACDIM*LBUFFV) OPEN(UNIT=JBUFFV,FILE=FILEB,ACCESS='DIRECT',STATUS='UNKNOWN', 1 RECL=MACDIM*LBUFFV) OPEN(UNIT=JBUFFZ,FILE=FILEC,ACCESS='DIRECT',STATUS='UNKNOWN', 1 RECL=MACDIM*LBUFFZ) C READ(IREAD,2001) (TITLE(I),I=1,18) WRITE(IWRITE,1002)(TITLE(I),I=1,18) WRITE(IWRITE,1001) C C CHECK WHETHER THIS IS A CONTINUATION RUN FROM RMATRX IN C WHICH CASE READ DATA FROM RMATRX FILE C IF (TITLE(1) .EQ. CONT) THEN CALL STGARX(LRGLLO,LRGLUP) RETURN END IF C WRITE(IWRITE,1000) WRITE(IWRITE,1003)IWRITE,IREAD,JBUFIR,FILEA,JBUFFV,FILEB, 1 JBUFFZ,FILEC READ(IREAD,*) NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 WRITE(IWRITE,1004)NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 READ(IREAD,*)LRGLLO,LRGLUP WRITE(IWRITE,1005)LRGLLO,LRGLUP IF (ILDIM3 .LE. LRGLUP) CALL RECOV1(16,LRGLUP+1,ILDIM3) LBLIM=2+2*LRGLUP IF (LBUFFZ .LT. LBLIM) CALL RECOV1(27,LBLIM,LBUFFZ) C C READ AND WRITE BASIC DATA. C C MAXORB ..... THE TOTAL NUMBER OF POSSIBLE SHELLS. C NELC ....... THE TOTAL NUMBER OF ELECTRONS. C NSET ....... THE NUMBER OF DIFFERENT ATOMIC OR IONIC SYMMETRIES. C NKEY ....... =-2 FOR GENERATION OF THE CONFIGURATION DATA, C READING ALL POSSIBLE SHELL OCCUPATIONS. C = 0 FOR GENERATION OF THE CONFIGURATION DATA, C READING MIN AND MAX SHELL OCCUPATIONS AND C EXCITATION FROM BASIC CONFIGURATIONS. C = 2 FOR READING THE CONFIGURATION DATA. C NJCOMP(I),LJCOMP(I) ..... THE N,L VALUES FOR THE I-TH SHELL. C READ(IREAD,*) MAXORB,NELC,NSET,NKEY WRITE(IWRITE,1015)MAXORB,NKEY IF (NKEY .NE. 2) THEN WRITE(IWRITE,1025)NELC,NSET IPUNCH=36 FILED='CONF.DAT' OPEN(UNIT=IPUNCH,FILE=FILED,STATUS='UNKNOWN', 1 FORM='UNFORMATTED') END IF IF (ICDIM2 .LT. MAXORB) CALL RECOV1(25,MAXORB,ICDIM2) IF (ABS(NKEY) .NE. 2 .AND. NKEY .NE. 0) THEN WRITE(IWRITE,1023) CALL EXIT (0) END IF C READ(IREAD,*)(NJCOMP(I),LJCOMP(I),I=1,MAXORB) DO 7 I=1,MAXORB L1=LJCOMP(I)+1 L1=MIN0(L1,5) WRITE(IWRITE,1006)I,NJCOMP(I),LVALUE(L1) NORDER(I)=I 7 CONTINUE C C READ DATA INTO THE COMMON BLOCKS /CUPPLE/ AND /OCCSH/. C FOR NKEY=-2 C NOCC ....... THE NUMBER OF SHELL OCCUPATIONS C NOCSH(I).... THE NUMBER OF OCCUPIED SHELLS IN THE ITH OCCUPATION C NOCOR(J,I).. THE INDEX OF THE JTH OCCUPIED SHELL IN THE ITH C OCCUPATION. C NELSH(J,I).. THE NUMBER OF ELECTRONS IN THE JTH OCCUPIED SHELL C IN THE ITH OCCUPATION. C FOR NKEY=0 C NOPTN ...... = 0 FOR NO RESTRICTION ON THE NUMBER OF ELECTRONS C EXCITED. C 1 TO 5 FOR A RESTRICTION ON THE NUMBER OF ELECTRONS C EXCITED FROM GIVEN BASIC CONFIGURATIONS. C THE VALUE OF NOPTN IS THE TOTAL NUMBER OF SUCH C BASIC CONFIGURATIONS. C OTHER VALUES OF NOPTN USED IN CONFIG C NOPTN ...... =-3 FOR SHELL OCCUPATIONS IN /OCCSH/. C =-2 FOR NO CONFIGURATIONS FOR THIS STATE. C =-1 FOR MINIMUM CARD INPUT DATA. AS FOR NOPTN=0 C BUT THE ARRAY MXAL(I) IS NOT READ IN. C MNAL(I) .... THE MINIMUM NUMBER OF ELECTRONS IN THE I-TH SHELL. C MXAL(I) .... THE MAXIMUM NUMBER OF ELECTRONS IN THE I-TH SHELL. C IBASSH(M,I) THE NUMBER OF ELECTRONS IN THE I-TH SHELL OF THE C M-TH BASIC CONFIGURATION. C NXCITE(M) .. THE MAXIMUM NUMBER OF ELECTRONS TO BE EXCITED FROM C THE M-TH BASIC CONFIGURATION - .LE. 6. C IF (NKEY .NE. 2) THEN IF (NKEY .EQ. -2) THEN NOPTN=-3 READ(IREAD,*) NOCC WRITE(IWRITE,1032)NOCC IF (NOCC .GT. ICDIM1) CALL RECOV1(24,NOCC,ICDIM1) READ(IREAD,*) (NOCSH(I),I=1,NOCC) WRITE(IWRITE,1033) (NOCSH(I),I=1,NOCC) DO 91 I=1,NOCC JACT=NOCSH(I) READ(IREAD,*)(NOCOR(J,I),J=1,JACT) WRITE(IWRITE,1034)I,(NOCOR(J,I),J=1,JACT) READ(IREAD,*)(NELSH(J,I),J=1,JACT) WRITE(IWRITE,1035)(NELSH(J,I),J=1,JACT) 91 CONTINUE ELSE READ(IREAD,*) NOPTN WRITE(IWRITE,1026)NOPTN IF (NOPTN .LT. 0 .OR. NOPTN .GT. 5) THEN WRITE(IWRITE,1024) CALL EXIT (0) END IF WRITE(IWRITE,1038)NELC,(NORDER(I),I=1,MAXORB) READ(IREAD,*) (MNAL(I),I=1,MAXORB) WRITE(IWRITE,1027)(MNAL(I),I=1,MAXORB) READ(IREAD,*) (MXAL(I),I=1,MAXORB) WRITE(IWRITE,1028)(MXAL(I),I=1,MAXORB) DO 15 M=1,NOPTN READ(IREAD,*) (IBASSH(M,I),I=1,MAXORB),NXCITE(M) WRITE(IWRITE,1029)M,(IBASSH(M,I),I=1,MAXORB) WRITE(IWRITE,1030)NXCITE(M) 15 CONTINUE END IF C C LL ......... THE TOTAL ANGULAR MOMENTUM OF THE STATE. C LSPN ....... = 2S+1, WHERE S IS THE TOTAL SPIN. C LPTY ....... THE PARITY, = 0 IF EVEN, = 1 IF ODD. C NCFGP=0 IPUNCH=36 NCFGT=-1 IF (NSET .EQ. 1) NCFGT=-3 DO 16 N=1,NSET IF (N .EQ. NSET .AND. N .GT. 1) NCFGT=-2 READ(IREAD,*) LL,LSPN,LPTY C LS=MIN0(LSPN,6) IF(LSPN.LT.1.OR.LPTY.LT.0.OR.LPTY.GT.1) CALL EXIT (0) L1=MIN0(LL+1,5) WRITE(IWRITE,1039)LSPN,PAR(LPTY+1),LVALUE(L1) CALL CONFIG(LL,LSPN,LPTY,MAXORB,NJCOMP,LJCOMP,NELC, 1 NBUG2,NCFGT) 16 CONTINUE C C STORE THE N-ELECTRON CONFIGURATION DATA IN /STATES/. C NCFG=NCFGP WRITE(IWRITE,1036)NCFG DO 24 I=1,NCFG JACT=IOCCSH(I) NOCCSH(I)=JACT DO 23 J=1,JACT NOCORB(J,I)=IOCORB(J,I) NELCSH(J,I)=IELCSH(J,I) J1=JACT+J DO 22 K=1,3 J1QNRD(J,K,I)=I1QNRD(J,K,I) IF (J .LT. JACT) THEN J1QNRD(J1,K,I)=I1QNRD(J1,K,I) END IF 22 CONTINUE 23 CONTINUE 24 CONTINUE ELSE C C READ IN THE QUANTUM NUMBERS DEFINING THE CONFIGURATIONS C READ(IREAD,*)NCFG WRITE(IWRITE,1008)NCFG IF (ICDIM1 .LT. NCFG) CALL RECOV1(24,NCFG,ICDIM1) READ(IREAD,*) (NOCCSH(I),I=1,NCFG) WRITE(IWRITE,1009) WRITE(IWRITE,1007) (NOCCSH(I),I=1,NCFG) DO 2 I=1,NCFG N=NOCCSH(I) READ(IREAD,*) (NOCORB(J,I),J=1,N) WRITE(IWRITE,1010) I,(NOCORB(J,I),J=1,N) READ(IREAD,*) (NELCSH(J,I),J=1,N) WRITE(IWRITE,1011) (NELCSH(J,I),J=1,N) M=N+N-1 READ(IREAD,*) ((J1QNRD(J,K,I),K=1,3),J=1,M) WRITE(IWRITE,1012) WRITE(IWRITE,1013)((J1QNRD(J,K,I),K=1,3),J=1,M) 2 CONTINUE END IF RETURN END C*********************************************************************** SUBROUTINE STGARX(LLLO,LLUP) C C READ IN AND WRITE OUT THE INPUT DATA C MOST OF THE DATA IS TRANSFERRED FROM THE RMATRX RUN C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C CHARACTER*8 FILEA,FILEB,FILEC CHARACTER*3 RELOP C PARAMETER(MACDIM=MZMAC) C PARAMETER(IDIM1=MZLR1,IDIM3=MZNR2,IDIM4=MZLMX, * IDIM6=MZNIX,IDIM7=MZPTS,IDIM12=MZNR1,IDIM13=MZORB) PARAMETER(ILDIM1=MZLR3,ILDIM3=MZLR4) PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) PARAMETER(ISDIM1=MZSET,ISDIM2=MZNCS) PARAMETER(IPDIM1=MZSPN) C PARAMETER(IRDIM1=MZMEG*1000000+MZKIL*1000+1) PARAMETER(ITDIM1=MZTAR,ITDIM2=MZNSS,ITDIM3=MZCHF,ITDIM6=MZCHS) C PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) C PARAMETER(LBUFFV=MZBUF,LBUFFZ=MZBUF) C COMMON/DEBUG / NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 COMMON/DISC/JBUFF1,JBUFF2,JBUFIR,JBUFFV,JBUFFZ,JBUFD COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/STATES/NCFG,NOCCSH(ICDIM1),NOCORB(ICDIM2,ICDIM1), 1 NELCSH(ICDIM2,ICDIM1),J1QNRD(ICDIM3,3,ICDIM1), 2 MAXORB,NJCOMP(ICDIM2),LJCOMP(ICDIM2) C COMMON/NRBPTY/NPTYMN,NPTYMX,NPTYIN C dimension iwave(128) C NAMELIST/STGNX/MINLT,MAXLT,LRGLLO,LRGLUP,MAXC,LFIXN,MJS,NPTYIN X ,RELOP,iwave X ,NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C 1000 FORMAT(/,28X,'SUBROUTINE STGARX'/28X,'-----------------'/) 1001 FORMAT(' DIMENSIONS REQUIRED FOR THIS RUN'// 1 ' THE NUMBER BELOW EACH ENTRY IS THE CURRENT DIMENSION'// 2 ' MZLR1=',I4,' MZNR2=',I4,' MZLMX=',I4,' MZNIX=',I4, 3 ' MZPTS=',I4,' MZMEG=',I4/6(7X,I4)// 4 ' MZNR1=',I4,' MZORB=',I4,' MZLR3=',I4,' MZSET=',I4, 5 ' MZNCS=',I4,' MZTAR=',I4/6(7X,I4)// 6 ' MZNSS=',I4,' MZCHF=',I4,' MZCHS=',I4,' MZSPN=',I4, 7 ' MZNCF=',I4,' MZLR4=',I4/6(7X,I4)// 8 ' CURRENT VALUE OF MAC=',I4/ 9 ' IT SHOULD BE 8 FOR THE CRAY, 1 FOR THE VAX.', A ' CURRENT VALUE OF BUF=',I4/ B ' IT SHOULD BE 256 OR 512 OR 1024'//) 1002 FORMAT( /8X, 1'----------------------------------------------------------------' 2// 8X,18A4//8X, 3'----------------------------------------------------------------' 4////) 1003 FORMAT(//' OUTPUT CHANNEL UNIT NUMBER=',I3/ 1 ' INPUT CHANNEL UNIT NUMBER=',I3/ 2 ' TARGET ANGULAR FILE--INTEGER UNIT NUMBER=',I3, 3 ' NAME= ',A8/ 4 ' REAL UNIT NUMBER=',I3, 5 ' NAME= ',A8/ 6 ' RACAH ANGULAR FILE UNIT NUMBER=',I3, 7 ' NAME= ',A8) 1004 FORMAT(' DEBUG PARAMETERS'/12I5) 1005 FORMAT(' ANGULAR COEFFICIENTS ARE TO BE CALCULATED OVER VALUES' 1 /' OF THE TOTAL ANGULAR MOMENTUM FROM ',I3,' TO',I3/ 2 ' AND TOTAL PARITY EVEN AND ODD IN EACH CASE'/) 1008 FORMAT(///' NUMBER OF CONFIGURATIONS =',I5) 1009 FORMAT(' NUMBER OF OCCUPIED SHELLS IN THESE CONFIGURATIONS'/30I3) 1010 FORMAT(' CONFIGURATION',I5/6X,' OCCUPIED ORBITALS ARE',32X,10I3) 1011 FORMAT(5X,' NUMBER OF ELECTRONS IN RESPECTIVE OCCUPIED SHELLS', 15X,10I3) 1012 FORMAT(5X,' COUPLING SCHEME') 1013 FORMAT(5X,3I3,6(I10,2I3)) 1014 FORMAT(/' THERE ARE',I3,' ORBITALS WHOSE N,L VALUES ARE'/ 1 6X,10(I8,I3)) C C THE FOLLOWING FORMAT STATEMENTS ARE TO READ THE CARD INPUT DATA. C 2000 FORMAT(12I5) 2001 FORMAT(18A4) C FILEA='ANG1.DAT' FILEB='ANG2.DAT' FILEC='ANG3.DAT' IWRITE=6 JBUFIR=20 JBUFFV=21 JBUFFZ=22 INX1=35 INX2=36 C C OPEN RMATRX FILES C OPEN(UNIT=INX1,FILE='NX1.DAT',STATUS='OLD',FORM='UNFORMATTED') OPEN(UNIT=INX2,FILE='NX2.DAT',STATUS='OLD',FORM='UNFORMATTED') C OPEN(UNIT=INX1,FILE='tapenx1',STATUS='OLD',FORM='UNFORMATTED') C OPEN(UNIT=INX2,FILE='tapenx2',STATUS='OLD',FORM='UNFORMATTED') WRITE(IWRITE,1000) WRITE(IWRITE,1003)IWRITE,IREAD,JBUFIR,FILEA,JBUFFV,FILEB, 1 JBUFFZ,FILEC READ(INX1)LRANG1,NRANG2,LAMAX,NIX,NPTS,NRKPTS READ(INX2)MAXN,MAXORB,LRANG3,NSETS1,MAXNCF,NAST,MAXNST, 1 NCHSUM,MAXNCH,ISRAN3,NCFG C NBUG1=0 NBUG2=0 NBUG3=0 NBUG4=0 NBUG5=0 NBUG7=0 NBUG8=0 NBUG9=0 C MINLT=0 MAXLT=0 LRGLLO=0 LRGLUP=0 C C READ(IREAD,STGNX) C C WRITE(IWRITE,1004)NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 IF(NPTYIN.EQ.0)NPTYMX=0 IF(NPTYIN.EQ.1)NPTYMN=1 IF(MINLT.GT.0)LRGLLO=MINLT IF(MAXLT.GT.0)LRGLUP=MAXLT LLLO=LRGLLO LLUP=LRGLUP C LRANG4=LRGLUP+1 IRDIM=MZMEG WRITE (IWRITE,1001)LRANG1,NRANG2,LAMAX,NIX,NPTS,NRKPTS, 1 IDIM1, IDIM3, IDIM4,IDIM6,IDIM7,IRDIM, 2 MAXN,MAXORB,LRANG3,NSETS1,MAXNCF,NAST, 3 IDIM12,IDIM13,ILDIM1,ISDIM1,ISDIM2,ITDIM1, 4 MAXNST,NCHSUM,MAXNCH,ISRAN3,NCFG,LRANG4, 5 ITDIM2,ITDIM3,ITDIM6,IPDIM1,ICDIM1,ILDIM3, 6 MACDIM,LBUFFV WRITE(IWRITE,1005)LRGLLO,LRGLUP IF (ILDIM3 .LE. LRGLUP) CALL RECOV1(16,LRGLUP+1,ILDIM3) LBLIM=2+2*LRGLUP IF (LBUFFZ .LT. LBLIM) CALL RECOV1(27,LBLIM,LBUFFZ) C C READ IN THE QUANTUM NUMBERS DEFINING THE CONFIGURATIONS C READ(INX2)(NOCCSH(I),I=1,NCFG) WRITE(IWRITE,1008)NCFG IF (ICDIM1 .LT. NCFG) CALL RECOV1(24,NCFG,ICDIM1) WRITE(IWRITE,1009) (NOCCSH(I),I=1,NCFG) DO 2 I=1,NCFG N=NOCCSH(I) READ (INX2) (NOCORB(J,I),J=1,N),(NELCSH(J,I),J=1,N) WRITE(IWRITE,1010) I,(NOCORB(J,I),J=1,N) WRITE(IWRITE,1011) (NELCSH(J,I),J=1,N) M=N+N-1 READ(INX2) ((J1QNRD(J,K,I),K=1,3),J=1,M) WRITE(IWRITE,1012) WRITE(IWRITE,1013)((J1QNRD(J,K,I),K=1,3),J=1,M) 2 CONTINUE READ(INX2)(NJCOMP(I),LJCOMP(I),I=1,MAXORB) WRITE(IWRITE,1014)MAXORB,(NJCOMP(I),LJCOMP(I),I=1,MAXORB) IF (ICDIM2 .LT. MAXORB) CALL RECOV1(25,MAXORB,ICDIM2) REWIND (INX1) REWIND (INX2) RETURN END ********************************************************************** SUBROUTINE STOREV(IRHVAL,VSHVAL,ICOUNT,NB,NRECV) C C TO ENTER CURRENT VALUES INTO THE VSHELL FILES C AND WRITE TO DISC USING DOUBLE BUFFERING C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER(LBUFFV=MZBUF) C COMMON/ANGBUF/BUFV1(LBUFFV),BUFV2(LBUFFV), 1 IBUFV1(LBUFFV),IBUFV2(LBUFFV) COMMON/DISC/JBUFF1,JBUFF2,JBUFIR,JBUFFV,JBUFFZ,JBUFD C IF (NB .EQ. 0) THEN IBUFV1(ICOUNT)=IRHVAL BUFV1(ICOUNT)=VSHVAL IF (ICOUNT .EQ. LBUFFV) THEN WRITE (JBUFIR, REC=NRECV)IBUFV1 WRITE (JBUFFV, REC=NRECV)BUFV1 NRECV=NRECV+1 NB=1 ICOUNT=0 END IF ELSE IBUFV2(ICOUNT)=IRHVAL BUFV2(ICOUNT)=VSHVAL IF (ICOUNT .EQ. LBUFFV) THEN WRITE (JBUFIR, REC=NRECV)IBUFV2 WRITE (JBUFFV, REC=NRECV)BUFV2 NRECV=NRECV+1 NB=0 ICOUNT=0 END IF END IF ICOUNT=ICOUNT+1 RETURN END C********************************************************************* BLOCK DATA BDONE IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/TERMS/ NROWS,I(18),J(18),N(189) C C --- READS IN QUANTUM NUMBERS OF TERMS WHICH CAN BE FORMED FROM C CONFIGURATIONS L**Q . ONLY THE FIRST HALF OF THAT PART OF THE C TABLE, CORRESPONDING TO A GIVEN L, IS INCLUDED, BECAUSE OF THE C SYMMETRY OF THE TABLE. E.G. D**7 FORMS THE SAME TERMS AS D**3 C C THE ARRAYS I,J,N CORRESPOND TO THE ARRAYS ITAB,JTAB,NTAB C DATA NROWS/18/ DATA I( 1),I( 2),I( 3),I( 4),I( 5),I( 6)/ 1, 1, 1, 3, 3, 1/ DATA I( 7),I( 8),I( 9),I(10),I(11),I(12)/ 5, 8,16,16, 1, 1/ DATA I(13),I(14),I(15),I(16),I(17),I(18)/ 1, 1, 1, 1, 1, 1/ DATA J( 1),J( 2),J( 3),J( 4),J( 5),J( 6)/ 0, 3, 6, 9, 18, 27/ DATA J( 7),J( 8),J( 9),J(10),J(11),J(12)/ 30, 45, 69,117,165,168/ DATA J(13),J(14),J(15),J(16),J(17),J(18)/171,174,177,180,183,186/ DATA N( 1),N( 2),N( 3),N( 4),N( 5),N( 6)/ 1, 1, 2, 0, 1, 1/ DATA N( 7),N( 8),N( 9),N( 10),N( 11),N( 12)/ 1, 3, 2, 0, 1, 1/ DATA N( 13),N( 14),N( 15),N( 16),N( 17),N( 18)/ 2, 5, 1, 2, 3, 3/ DATA N( 19),N( 20),N( 21),N( 22),N( 23),N( 24)/ 1, 3, 2, 3, 5, 2/ DATA N( 25),N( 26),N( 27),N( 28),N( 29),N( 30)/ 3, 1, 4, 1, 5, 2/ DATA N( 31),N( 32),N( 33),N( 34),N( 35),N( 36)/ 0, 1, 1, 2, 5, 1/ DATA N( 37),N( 38),N( 39),N( 40),N( 41),N( 42)/ 2, 9, 1, 2, 3, 3/ DATA N( 43),N( 44),N( 45),N( 46),N( 47),N( 48)/ 2, 7, 3, 1, 5, 2/ DATA N( 49),N( 50),N( 51),N( 52),N( 53),N( 54)/ 3, 3, 2, 3, 5, 2/ DATA N( 55),N( 56),N( 57),N( 58),N( 59),N( 60)/ 3, 7, 2, 3, 9, 2/ DATA N( 61),N( 62),N( 63),N( 64),N( 65),N( 66)/ 3,11, 2, 3, 3, 4/ DATA N( 67),N( 68),N( 69),N( 70),N( 71),N( 72)/ 3, 7, 4, 0, 1, 1/ DATA N( 73),N( 74),N( 75),N( 76),N( 77),N( 78)/ 2, 5, 1, 2, 9, 1/ DATA N( 79),N( 80),N( 81),N( 82),N( 83),N( 84)/ 2, 3, 3, 2, 7, 3/ DATA N( 85),N( 86),N( 87),N( 88),N( 89),N( 90)/ 4, 1, 1, 4, 5, 1/ DATA N( 91),N( 92),N( 93),N( 94),N( 95),N( 96)/ 4, 7, 1, 4, 9, 1/ DATA N( 97),N( 98),N( 99),N(100),N(101),N(102)/ 4,13, 1, 4, 3, 3/ DATA N(103),N(104),N(105),N(106),N(107),N(108)/ 4, 5, 3, 4, 7, 3/ DATA N(109),N(110),N(111),N(112),N(113),N(114)/ 4, 9, 3, 4,11, 3/ DATA N(115),N(116),N(117),N(118),N(119),N(120)/ 4, 5, 5, 1, 5, 2/ DATA N(121),N(122),N(123),N(124),N(125),N(126)/ 3, 3, 2, 3, 5, 2/ DATA N(127),N(128),N(129),N(130),N(131),N(132)/ 3, 7, 2, 3, 9, 2/ DATA N(133),N(134),N(135),N(136),N(137),N(138)/ 3,11, 2, 3, 3, 4/ DATA N(139),N(140),N(141),N(142),N(143),N(144)/ 3, 7, 4, 5, 1, 2/ DATA N(145),N(146),N(147),N(148),N(149),N(150)/ 5, 5, 2, 5, 7, 2/ DATA N(151),N(152),N(153),N(154),N(155),N(156)/ 5, 9, 2, 5,13, 2/ DATA N(157),N(158),N(159),N(160),N(161),N(162)/ 5, 5, 4, 5, 9, 4/ DATA N(163),N(164),N(165),N(166),N(167),N(168)/ 5, 1, 6, 1, 7, 2/ DATA N(169),N(170),N(171) / 1, 9, 2/ DATA N(172),N(173),N(174),N(175),N(176),N(177)/ 1,11, 2, 1,13, 2/ DATA N(178),N(179),N(180),N(181),N(182),N(183)/ 1,15, 2, 1,17, 2/ DATA N(184),N(185),N(186),N(187),N(188),N(189)/ 1,19, 2, 1,21, 2/ C C SET GLOBAL REAL CONSTANTS C DATA ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS/ 1 0.0E 00,0.1E 00,0.5E 00,1.0E 00,2.0E 00,3.0E 00,4.0E 00, 2 7.0E 00,1.1E 01,1.0E-05/ C END C*********************************************************************** SUBROUTINE CONFIG(LRGL,NSPN,NPTY,MAXORB,NJCOMP,LJCOMP,IELC,NBUG, 1 NCFGT) C INCLUDE 'PARAM' C C TO GENERATE OR READ CONFIGURATION DATA FOR A STATE WITH TOTAL C ANGULAR MOMENTUM, SPIN, PARITY OF LRGL, NSPN, NPTY. C C MAXORB IS THE TOTAL NUMBER OF SHELLS. C NJCOMP AND LJCOMP ARE THE N AND L VALUES FOR THE SHELLS. C IELC IS THE TOTAL NUMBER OF ELECTRONS. C NBUG IS GREATER THAN ZERO FOR A PRINTOUT OF THE CONFIGURATIONS. C C CONFIG CAN BE CALLED A NUMBER OF TIMES FOR A SERIES OF STATES, C AND THE CONFIGURATION DATA CORRESPONDING TO EACH STATE CAN BE C STORED SEQUENTIALLY IN /BNDCON/. C THE READING OF CONFIGURATION DATA FROM JREAD ONLY OCCURS ON THE C FIRST CALL TO CONFIG FOR A SERIES OF STATES. C THE PUNCHING OF CONFIGURATION DATA TO IPUNCH ONLY OCCURS ON THE C LAST CALL TO CONFIG FOR A SERIES OF STATES. C C NCFGT = -1 FOR THE FIRST OF A SERIES OF STATES, C = -2 FOR THE LAST OF A SERIES OF STATES. C = -3 IF THERE IS ONLY ONE STATE. C C ON RETURN, NCFGT CONTAINS THE NUMBER OF CONFIGURATIONS STORED C FOR THE CURRENT STATE. C LOGICAL FIRST C PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) DIMENSION NJCOMP(MAXORB),LJCOMP(MAXORB) DIMENSION NI(ICDIM2),NTOTI(ICDIM2) COMMON/CONACT/MACT(ICDIM2),MNT(ICDIM2),JACT,J1QN(ICDIM2,3) COMMON/CUPPLE/NOPTN,MNAL(ICDIM2),MXAL(ICDIM2), 1 IBASSH(5,ICDIM2),NXCITE(5),IXCITE(2,6),JREAD COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ(ICDIM2),LJ(ICDIM2),MN(ICDIM2),MXN(ICDIM2), 2 LA(ICDIM2),J1QN1(ICDIM2,3), 3 NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/OCCSH /NOCC,NOCSH(ICDIM1),NOCOR(ICDIM2,ICDIM1), 1 NELSH(ICDIM2,ICDIM1) COMMON /RECOV / IPLACE !NRB C 1000 FORMAT(/,28X,'SUBROUTINE CONFIG'/28X,'-----------------'/) 1001 FORMAT(12I5) 1002 FORMAT(/50H * WARNING * ONLY ONE ELECTRON IS ALLOWED IN SHELL,I3, 1 9H WITH L =,I3) 1003 FORMAT(//32H * PROGRAM STOPS IN CONFIG * L =,I5,8H 2S+1 =,I5, 1 10H PARITY =,I5/) 1004 FORMAT(//34H * PROGRAM STOPS IN CONFIG * SHELL,I5,8H HAS N =,I5, 1 4H L =,I5/) 1005 FORMAT(//64H * PROGRAM STOPS IN CONFIG * MXN(I) IS NOT SUFFICIENT 1FOR IELC =,I5/) 1006 FORMAT(//42H * PROGRAM STOPS IN CONFIG * CONFIGURATION,I5, 1 9H REQUIRES,I5,21H ELECTRON EXCITATIONS/) 1007 FORMAT(/50X,32H POSSIBLE ELECTRON DISTRIBUTIONS//) 1008 FORMAT(49H NUMBER OF CONFIGURATIONS STORED FOR THIS STATE =,I5) 1009 FORMAT(/24H CARD PUNCHING COMPLETED/) 1010 FORMAT(/' * OCCUPATION NUMBER',I3,' IS IDENTICAL TO',I3) C NREAD=0 NWRITE=0 IF(NBUG.GT.0) NWRITE=IWRITE NPUNCH=0 ICFGT=0 C C IF NCFGT = -1 OR -3, THIS IS THE FIRST OR ONLY CALL TO CONFIG. C IF JREAD.GT.0, CALL CONSTO TO READ CONFIGURATION DATA FROM JREAD. C FIRST=.FALSE. IF(NCFGT.NE.(-1).AND.NCFGT.NE.(-3)) GO TO 1 FIRST=.TRUE. NCUP=0 ICFG=0 NCON=0 IF(JREAD.EQ.0) GO TO 1 NREAD=JREAD CALL CONSTO NREAD=0 NOPTN=-2 C C SET AND CHECK THE INPUT DATA C 1 ITOTL=LRGL ITOTS=NSPN IPTY=NPTY NSHELL=MAXORB NELC=IELC IF(ITOTL.LT.0.OR.ITOTS.LT.1) GO TO 2 IF(IPTY.EQ.0.OR.IPTY.EQ.1) GO TO 3 2 WRITE(IWRITE,1003)ITOTL,ITOTS,IPTY CALL EXIT (0) 3 NSPARE=NELC DO 5 I=1,NSHELL NJ(I)=NJCOMP(I) L=LJCOMP(I) LJ(I)=L IF(L.GE.0.AND.L.LT.NJ(I)) GO TO 4 WRITE(IWRITE,1004)I,NJ(I),L CALL EXIT (0) 4 IF(NOPTN.LE.(-2)) GO TO 5 C NSPARE=NSPARE-MNAL(I) IF(NSPARE.GE.0) GO TO 5 WRITE(IWRITE,1005)NELC CALL EXIT (0) 5 CONTINUE C C CHECK TO SEE IF CONFIGURATIONS CORRESPONDING TO THE CURRENT L,S, C AND PARITY HAVE ALREADY BEEN STORED. C IOPTN=-2 IF(.NOT.FIRST) CALL CONSTO IF(ICFGT.GT.0.OR.JREAD.GT.0) GO TO 17 IOPTN=NOPTN C C FOR INPUT SHELL OCCUPATIONS, CALL CONQN FOR ALL ELECTRON C DISTRIBUTIONS WITH THE RIGHT PARITY. C IF(NOPTN.EQ.(-3)) THEN IF(FIRST) THEN C C CHECK FOR REPEATED SHELL OCCUPATIONS C IERR=0 DO 51 K=1,NOCC JACT=NOCSH(K) DO 52 K1=1,K-1 JACT1=NOCSH(K1) IF(JACT1.NE.JACT) GO TO 52 DO 53 J=1,JACT IF(NOCOR(J,K).NE.NOCOR(J,K1) .OR. 1 NELSH(J,K).NE.NELSH(J,K1)) GO TO 51 53 CONTINUE WRITE(IWRITE,1010)K1,K IERR=IERR+1 GO TO 51 52 CONTINUE 51 CONTINUE IF (IERR .GT. 0) CALL EXIT (0) END IF C DO 54 K=1,NOCC LPTY=0 JACT=NOCSH(K) DO 55 J=1,JACT I=NOCOR(J,K) L=LJ(I) M=NELSH(J,K) LPTY=LPTY+L*M MACT(J)=I MNT(J)=M 55 CONTINUE IF(MOD(LPTY,2).EQ.IPTY) THEN CALL CONQN END IF 54 CONTINUE GO TO 17 END IF C C ONLY 2 ELECTRONS ARE ALLOWED IN SHELLS WITH L.GE.3 C IF(IOPTN.EQ.(-2)) GO TO 17 DO 7 I=1,NSHELL L=LJ(I) NE=MXAL(I) NE=MIN0(NE,4*L+2) NE=MIN0(NE,MNAL(I)+NSPARE) IF(L.LT.3) GO TO 6 IF(NE.GT.2) WRITE(IWRITE,1002)I,L NE=MIN0(1,NE) 6 MXAL(I)=NE MXN (I)=NE+1 7 CONTINUE C C THE NUMBER OF ELECTRONS EXCITED FROM A GIVEN BASIC CONFIGURATION C IS LIMITED TO 6 C IF(IOPTN.LE.0) GO TO 10 DO 9 M=1,IOPTN NX=NXCITE(M) IF(NX.LE.0) GO TO 9 DO 8 IX=1,NX IXCITE(M,IX)=IX IF(IXCITE(M,IX).LE.6) GO TO 8 WRITE(IWRITE,1006)M,IXCITE(M,IX) CALL EXIT (0) 8 CONTINUE 9 CONTINUE C C TO GENERATE THE CONFIGURATIONS, CALL CONPED. C C LOOP OVER ALL POSSIBLE ELECTRON DISTRIBUTIONS C 10 I=0 11 I=I+1 NI(I)=0 12 NI(I)=NI(I)+1 NSTOP=I MI=MXN(I)-NI(I) IF(MI.LT.MNAL(NSTOP)) GO TO 15 NTOT=MI IF(I.GT.1) NTOT=NTOT+NTOTI(I-1) NTOTI(I)=NTOT MN(I)=MI IF(NTOT-NELC) 14,13,15 13 CALL CONPED 14 IF(I-NSHELL) 11,15,17 15 IF(NI(I).LT.MXN(I)) GO TO 12 16 I=I-1 IF(I) 17,17,15 C C IF NCFGT = -2 OR -3, THIS IS THE LAST OR ONLY CALL TO CONFIG. C CHECK DIMENSIONS. C IF IPUNCH.GT.0, CALL CONSTO TO PUNCH CONFIGURATION DATA TO IPUNCH C 17 WRITE(IWRITE,1008)ICFGT IF(NCFGT.NE.(-2).AND.NCFGT.NE.(-3)) GO TO 18 IF(IPLACE.EQ.0) IPLACE=-1 IF(ICFG.GT.ICDIM1) CALL RECOV1(24,ICFG,ICDIM1) IF(NCUP.GT.ICDIM1) CALL RECOV1(24,NCUP,ICDIM1) IF(IPLACE.EQ.-1) IPLACE=0 IF(IPUNCH.LE.0) GO TO 18 NPUNCH=IPUNCH CALL CONSTO WRITE(IWRITE,1009) C 18 NCFGT=ICFGT RETURN END C*********************************************************************** SUBROUTINE CONPED C C TO DETERMINE THE POSSIBLE ELECTRON DISTRIBUTIONS CONSISTENT WITH C PARITY ETC. C INCLUDE 'PARAM' C PARAMETER(ICDIM2=MZORB) COMMON/CONACT/MACT(ICDIM2),MNT(ICDIM2),JACT,J1QN(ICDIM2,3) COMMON/CUPPLE/NOPTN,MNAL(ICDIM2),MXAL(ICDIM2), 1 IBASSH(5,ICDIM2),NXCITE(5),IXCITE(2,6),JREAD COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ(ICDIM2),LJ(ICDIM2),MN(ICDIM2),MXN(ICDIM2), 2 LA(ICDIM2),J1QN1(ICDIM2,3), 3 NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/INFORM/IREAD,IWRITE,IPUNCH C 1000 FORMAT(//48H *** PROGRAM STOP IN SUBROUTINE CONPED - NCON =,I10, 1 5H ***//) C LPTY=0 JACT=0 C C TEST FOR EMPTY EXCITED SHELLS AND PARITY C DO 3 I=1,NSTOP L=LJ(I) M=MN(I) LPTY=LPTY+L*M IF(M.LT.MNAL(I)) GO TO 13 1 IF(M) 3,3,2 2 JACT=JACT+1 MACT(JACT)=I MNT(JACT)=M 3 CONTINUE IF(MOD(LPTY,2)-IPTY) 13,4,13 4 IF(MN(NSTOP)) 5,13,5 C C TEST FOR EXCITATION ALLOWED FROM THE BASIC CONFIGURATIONS C 5 IF(NOPTN) 11,11,6 6 DO 10 M=1,NOPTN NEX=0 DO 7 I=1,NSTOP MB=IBASSH(M,I) MA=MN(I) NEX=NEX+IABS(MA-MB) 7 CONTINUE NEX=NEX/2 IF(NEX) 8,11,8 8 NX=NXCITE(M) IF(NX.LE.0) GO TO 10 DO 9 IX=1,NX IF(NEX-IXCITE(M,IX)) 9,11,9 9 CONTINUE 10 CONTINUE GO TO 13 C C LIMIT SET ON NCON TO AVOID POSSIBLE RUN-AWAY C 11 NCON=NCON+1 IF(NCON.LE.1000) GO TO 12 WRITE(IWRITE,1000)NCON CALL EXIT (0) C 12 CALL CONQN 13 RETURN END C*********************************************************************** SUBROUTINE CONQN C C TO DETERMINE THE QUANTUM NUMBERS FOR EACH SHELL C INCLUDE 'PARAM' C PARAMETER(ICDIM2=MZORB) C C FOLLOWING DIMENSION IS FOR DATA STATEMENT. BOTH WILL NEED C EXTENDING IF ICDIM2 > 11 DIMENSION LS(11) DIMENSION IFSH(ICDIM2),MXS(ICDIM2),MCS(ICDIM2),NI(ICDIM2) COMMON/CONACT/MACT(ICDIM2),MNT(ICDIM2),JACT,J1QN(ICDIM2,3) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ(ICDIM2),LJ(ICDIM2),MN(ICDIM2),MXN(ICDIM2), 2 LA(ICDIM2),J1QN1(ICDIM2,3), 3 NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/TERMS/ NROWS,L(18),J(18),N(189) DATA LS(1),LS(2),LS(3),LS(4),LS(5)/1,3,6,11,12/ DATA LS(6),LS(7),LS(8),LS(9),LS(10),LS(11)/13,14,15,16,17,18/ C C--------------------------------------------------------------------- C C EXTENDED TO COPE WITH 2 ELECTRONS IN L>2 SHELLS. C C (NO NEED TO EXTEND THE /TERMS/ ARRAYS, SINCE THESE ARE USED IN THE C FANO PACKAGE BY FUNCTION NTAB1, WHERE ONLY PARENTS ARE CONSIDERED, C AND PARENTS WILL STILL HAVE NO MORE THAN 1 ELECTRON IN L>2 SHELLS. C C---------------------------------------------------------------------- C C DO 3 I=1,JACT NN=MACT(I) LL=LJ(NN) LL1=LL+LL+1 LK1=LL+1 M=MNT(I) K=M IF(M.GT.LL1) K=2*LL1-M IF(K.EQ.0) GO TO 1 C-------------------------------------------------------------------- IF(LL.GE.3.AND.K.EQ.2) THEN MXS(I)=LL1 MCS(I)=-1 GO TO 3 ENDIF C------------------------------------------------------------------- IF(LK1.GT.11)THEN WRITE(6,111)LK1 111 FORMAT(//' ****SR.CONQN, DIMENSION EXCEEDED....',I3,' .GT. 11') STOP 11 ENDIF IFSH(I)=LS(LK1)+K-1 GO TO 2 1 IFSH(I)=2 2 KI=IFSH(I) MXS(I)=L(KI) MCS(I)=J(KI) 3 CONTINUE C C LOOP OVER THE ALLOWED QUANTUM NUMBERS FOR EACH SHELL C I=0 4 I=I+1 NI(I)=0 5 NI(I)=NI(I)+1 C------------------------------------------------------------------ IF(MCS(I).EQ.-1) THEN J1QN(I,1)=2 IF(NI(I).EQ.1) J1QN(I,1)=0 J1QN(I,2)=2*NI(I)-1 J1QN(I,3)=1 IF(MOD(NI(I),2).EQ.0) J1QN(I,3)=3 IF(I-JACT) 4,6,8 ENDIF C---------------------------------------------------------------- MI=MCS(I)+(NI(I)-1)*3 J1QN(I,1)=N(MI+1) J1QN(I,2)=N(MI+2) J1QN(I,3)=N(MI+3) IF(I-JACT) 4,6,8 6 CALL CONSH 7 IF(NI(I).LT.MXS(I)) GO TO 5 I=I-1 IF(I) 8,8,7 C 8 RETURN END C*********************************************************************** SUBROUTINE CONSH C C TO DETERMINE THE COUPLING BETWEEN THE SHELLS C LOGICAL OK C INCLUDE 'PARAM' C PARAMETER(ICDIM2=MZORB) C DIMENSION LI(ICDIM2),LLL(ICDIM2),LLH(ICDIM2),LSP(ICDIM2), 1 LSL(ICDIM2),LSH(ICDIM2) COMMON/CONACT/MACT(ICDIM2),MNT(ICDIM2),JACT,J1QN(ICDIM2,3) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ(ICDIM2),LJ(ICDIM2),MN(ICDIM2),MXN(ICDIM2), 2 LA(ICDIM2),J1QN1(ICDIM2,3), 3 NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C JACTM1=JACT-1 IF(JACTM1.GT.0) GO TO 1 CALL CONTST(OK) IF(OK) CALL CONSTO RETURN C 1 DO 2 I=1,JACTM1 J1QN1(I,1)=0 2 CONTINUE LS0=J1QN(1,3)-1 LL0=(J1QN(1,2)-1)/2 LLL(1)=IABS(LL0-(J1QN(2,2)-1)/2) LLH(1)=LL0+(J1QN(2,2)-1)/2+1 LSL(1)=IABS(LS0-J1QN(2,3)+1)-1 LSH(1)=LS0+J1QN(2,3) C C LOOP OVER ALL POSSIBLE COUPLINGS BETWEEN THE SHELLS C I=0 3 I=I+1 LI(I)=LLL(I) 4 LI(I)=LI(I)+1 LLI=LI(I)-1 J1QN1(I,2)=2*LLI+1 IF(I-JACTM1) 5,6,6 5 LLL(I+1)=IABS(LLI-(J1QN(I+2,2)-1)/2) LLH(I+1)=LLI+(J1QN(I+2,2)-1)/2+1 6 LSP(I)=LSL(I) 7 LSP(I)=LSP(I)+2 LSI=LSP(I)-1 J1QN1(I,3)=LSI+1 IF(I-JACTM1) 9,8,11 8 CALL CONTST(OK) IF(OK) CALL CONSTO GO TO 10 9 LSL(I+1)=IABS(LSI-J1QN(I+2,3)+1)-1 LSH(I+1)=LSI+J1QN(I+2,3) GO TO 3 10 IF(LSP(I).LT.LSH(I)) GO TO 7 IF(LI(I).LT.LLH(I)) GO TO 4 I=I-1 IF(I) 11,11,10 C 11 RETURN END C*********************************************************************** SUBROUTINE CONTST(OK) C C OK IS SET .TRUE. ONLY IF THE CONFIGURATION HAS THE TOTAL C ANGULAR MOMENTUM AND SPIN OF THE GIVEN STATE. C LOGICAL OK C INCLUDE 'PARAM' C PARAMETER(ICDIM2=MZORB) C COMMON/CONACT/MACT(ICDIM2),MNT(ICDIM2),JACT,J1QN(ICDIM2,3) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ(ICDIM2),LJ(ICDIM2),MN(ICDIM2),MXN(ICDIM2), 2 LA(ICDIM2),J1QN1(ICDIM2,3), 3 NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT C OK=.FALSE. JACTM1=JACT-1 IF(JACTM1) 1,1,2 1 LL=(J1QN(JACT,2)-1)/2 LS= J1QN(JACT,3) GO TO 3 2 LL=(J1QN1(JACTM1,2)-1)/2 LS= J1QN1(JACTM1,3) 3 IF(LL-ITOTL) 6,4,6 4 IF(LS-ITOTS) 6,5,6 5 OK=.TRUE. 6 RETURN END C*********************************************************************** SUBROUTINE CONSTO C C TO READ/WRITE/STORE/PUNCH THE CONFIGURATION DATA. C LOGICAL OK,OMIT,AGREE C INCLUDE 'PARAM' C PARAMETER(ICDIM1=MZNCF,ICDIM2=MZORB) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1) C COMMON/BNDCON/NCFGP,IOCCSH(ICDIM1),IOCORB(ICDIM2,ICDIM1), 1 IELCSH(ICDIM2,ICDIM1),I1QNRD(ICDIM3,3,ICDIM1) COMMON/CONACT/MACT(ICDIM2),MNT(ICDIM2),JACT,J1QN(ICDIM2,3) COMMON/CUT/ NCUT,IKIP(ICDIM1),JOCCSH(ICDIM1) COMMON/DISTIB/NELC,IPTY,ITOTL,ITOTS,NTOT,NSHELL,NSTOP,NCON,NCUP, 1 NJ(ICDIM2),LJ(ICDIM2),MN(ICDIM2),MXN(ICDIM2), 2 LA(ICDIM2),J1QN1(ICDIM2,3), 3 NREAD,NWRITE,NPUNCH,IOPTN,ICFG,ICFGT COMMON/TYPE/ ITYP(ICDIM1) C 1001 FORMAT(/14H CONFIGURATION,I4) 1002 FORMAT(5X,22H OCCUPIED ORBITALS ARE,32X,20I3) 1003 FORMAT(5X,50H NUMBER OF ELECTRONS IN RESPECTIVE OCCUPIED SHELLS, 1 4X,20I3) 1004 FORMAT(5X,16H COUPLING SCHEME) 1005 FORMAT(1X,9(3X,3I3)) 1006 FORMAT(7X,8(3X,3I3)) 1007 FORMAT(/25H CONFIGURATION NOT STORED) C C THE FOLLOWING FORMAT STATEMENT IS USED TO READ/PUNCH CARD DATA C 2000 FORMAT(12I5) C NCUT=0 !FOR NX CODE C C IF NREAD.GT.0 READ THE COUPLING SCHEME DATA FROM NREAD C IF(NPUNCH.GT.0) GO TO 21 IF(NREAD.EQ.0) GO TO 5 READ(NREAD,2000) JCFG IF(JCFG) 19,19,1 1 IF(JCFG.GT.ICDIM1) CALL RECOV1(24,JCFG,ICDIM1) READ(NREAD,2000) (JOCCSH(I),I=1,JCFG) 2 IF(NCUP.GE.JCFG) GO TO 21 NCUP=NCUP+1 JACT=JOCCSH(NCUP) JACTM1=JACT-1 READ(NREAD,2000) (MACT(J),J=1,JACT) READ(NREAD,2000) (MNT (J),J=1,JACT) IF(JACTM1) 3,3,4 3 READ(NREAD,2000) ((J1QN(J,K),K=1,3),J=1,JACT) GO TO 6 4 READ(NREAD,2000) ((J1QN(J,K),K=1,3),J=1,JACT), 1 ((J1QN1(J,K),K=1,3),J=1,JACTM1) GO TO 6 C C IF NCUT.GT.0 STORE ONLY THOSE CONFIGURATIONS WITH IKIP(NCUP)=1 C NCUT NOT READ/INPUT IN NX CODE C 5 IF(IOPTN.EQ.(-2)) GO TO 21 NCUP=NCUP+1 6 IF(NCUT.LE.0) GO TO 9 7 IF(NCUP.GT.NCUT) GO TO 8 IF(IKIP(NCUP).EQ.1) GO TO 9 8 OMIT=.TRUE. GO TO 10 9 OMIT=.FALSE. ICFG=ICFG+1 ICFGT=ICFGT+1 C C IF NWRITE.GT.0 PRINT THE COUPLING SCHEME DATA C 10 IF(NWRITE.LE.0) GO TO 15 11 IF(OMIT) GO TO 12 WRITE(NWRITE,1001)ICFG GO TO 13 12 WRITE(NWRITE,1007) 13 WRITE(NWRITE,1002)(MACT(J),J=1,JACT) WRITE(NWRITE,1003)(MNT (J),J=1,JACT) JACTM1=JACT-1 WRITE(NWRITE,1004) WRITE(NWRITE,1005)((J1QN(J,K),K=1,3),J=1,JACT) IF(JACTM1) 15,15,14 14 WRITE(NWRITE,1006)((J1QN1(J,K),K=1,3),J=1,JACTM1) C C IF OMIT=.FALSE. STORE THE COUPLING SCHEME DATA IN /BNDCON/ C 15 IF(OMIT) GO TO 19 JOCCSH(ICFG)=JACT C IF(ICFG.LE.ICDIM1) JOCCSH(ICFG)=JACT C IF(ICFG.GT.IDMTST(12)) GO TO 19 ITYP(ICFGT)=ICFG IOCCSH(ICFG)=JACT DO 18 J=1,JACT IOCORB(J,ICFG)=MACT(J) IELCSH(J,ICFG)=MNT (J) J1=JACT+J DO 17 K=1,3 I1QNRD(J,K,ICFG)=J1QN(J,K) IF(J-JACT) 16,17,17 16 I1QNRD(J1,K,ICFG)=J1QN1(J,K) 17 CONTINUE 18 CONTINUE C 19 NCFGP=ICFG 20 IF(NREAD) 30,30,2 C C IF NPUNCH.GT.0 OR IOPTN=-2, FIND COUPLING SCHEME DATA IN /BNDCON/ C 21 IF(NPUNCH.GT.0) WRITE(NPUNCH,2000)ICFG IF(ICFG) 30,30,22 22 IF(NPUNCH.GT.0) WRITE(NPUNCH,2000)(JOCCSH(I),I=1,ICFG) DO 29 I=1,ICFG JACT=IOCCSH(I) JACTM1=JACT-1 LP=0 DO 25 J=1,JACT MACT(J)=IOCORB(J,I) MNT (J)=IELCSH(J,I) J1=JACT+J DO 24 K=1,3 J1QN(J,K)=I1QNRD(J,K,I) IF(J-JACT) 23,24,24 23 J1QN1(J,K)=I1QNRD(J1,K,I) 24 CONTINUE M=MACT(J) LP=LP+LJ(M)*MNT(J) 25 CONTINUE C IF(NPUNCH.GT.0) GO TO 26 CALL CONTST(OK) AGREE=OK.AND.(MOD(LP,2).EQ.IPTY) IF(AGREE) ICFGT=ICFGT+1 IF(AGREE) ITYP(ICFGT)=I GO TO 29 26 WRITE(NPUNCH,2000)(MACT(J),J=1,JACT) WRITE(NPUNCH,2000)(MNT(J),J=1,JACT) IF(JACTM1) 27,27,28 27 WRITE(NPUNCH,2000)((J1QN(J,K),K=1,3),J=1,JACT) GO TO 29 28 WRITE(NPUNCH,2000)((J1QN(J,K),K=1,3),J=1,JACT), 1 ((J1QN1(J,K),K=1,3),J=1,JACTM1) 29 CONTINUE C 30 RETURN END C*********************************************************************** BLOCK DATA BDTWO C COMMON/FRPAR2/I(719) C C BLOCK DATA FOR CFPD SUBROUTINE C DATA I( 1),I( 2),I( 3),I( 4),I( 5),I( 6),I( 7),I( 8), 1 I( 9),I( 10),I( 11),I( 12),I( 13),I( 14),I( 15),I( 16), 1 I( 17),I( 18),I( 19),I( 20),I( 21),I( 22),I( 23),I( 24), 2 I( 25),I( 26),I( 27),I( 28),I( 29),I( 30),I( 31),I( 32), 3 I( 33),I( 34),I( 35),I( 36),I( 37),I( 38),I( 39),I( 40), 4 I( 41),I( 42),I( 43),I( 44),I( 45),I( 46),I( 47),I( 48), 5 I( 49),I( 50),I( 51),I( 52),I( 53),I( 54),I( 55),I( 56), 6 I( 57),I( 58),I( 59),I( 60),I( 61),I( 62),I( 63),I( 64), 7 I( 65),I( 66),I( 67),I( 68),I( 69),I( 70),I( 71),I( 72), 8 I( 73),I( 74),I( 75),I( 76),I( 77),I( 78),I( 79),I( 80)/ 1 1, 5, 8, 16, 16, 1, 2, 3, 1 4, 5, 0, 2, 3, 4, 5, 0, 1 2, 3, 4, 3, 0, 2, 3, 2, 2 5, 0, 0, 3, 4, 3, 0, 0, 3 1, 4, 5, 0, 0, 3, 2, 3, 4 0, 0, 3, 4, 3, 0, 0, 0, 5 4, 5, 0, 0, 0, 2, 3, 0, 6 0, 0, 4, 5, 0, 0, 0, 4, 7 1, 0, 0, 0, 2, 3, 0, 0, 8 0, 4, 5, 0, 0, 0, 0, 3/ DATA I( 81),I( 82),I( 83),I( 84),I( 85),I( 86),I( 87),I( 88), 1 I( 89),I( 90),I( 91),I( 92),I( 93),I( 94),I( 95),I( 96), 1 I( 97),I( 98),I( 99),I(100),I(101),I(102),I(103),I(104), 2 I(105),I(106),I(107),I(108),I(109),I(110),I(111),I(112), 3 I(113),I(114),I(115),I(116),I(117),I(118),I(119),I(120), 4 I(121),I(122),I(123),I(124),I(125),I(126),I(127),I(128), 5 I(129),I(130),I(131),I(132),I(133),I(134),I(135),I(136), 6 I(137),I(138),I(139),I(140),I(141),I(142),I(143),I(144), 7 I(145)/ 1 0, 0, 0, 4, 5, 2, 3, 3, 1 2, 0, 0, 1, 1, 5, 4, 0, 1 4, 5, 4, 3, 0, 2, 4, 3, 2 2, 0, 0, 3, 3, 1, 0, 0, 3 2, 2, 6, 0, 0, 2, 1, 5, 4 0, 0, 1, 1, 4, 0, 0, 0, 5 6, 4, 0, 0, 0, 4, 3, 0, 6 0, 0, 4, 3, 0, 0, 0, 3, 7 2/ DATA I(146),I(147),I(148),I(149),I(150),I(151),I(152),I(153), 1 I(154),I(155),I(156),I(157),I(158),I(159),I(160),I(161), 1 I(162),I(163),I(164),I(165),I(166),I(167),I(168),I(169), 2 I(170),I(171),I(172),I(173),I(174),I(175),I(176),I(177), 3 I(178),I(179),I(180),I(181),I(182),I(183),I(184),I(185), 4 I(186),I(187),I(188),I(189),I(190),I(191),I(192),I(193), 5 I(194),I(195),I(196),I(197),I(198),I(199),I(200),I(201), 6 I(202),I(203),I(204),I(205),I(206),I(207),I(208),I(209), 7 I(210),I(211),I(212),I(213),I(214),I(215),I(216),I(217), 8 I(218),I(219),I(220),I(221),I(222),I(223),I(224),I(225)/ 1 0, 0, 0, 2, 2, 0, 0, 0, 1 2, 2, 0, 0, 0, 0, 1, 0, 1 0, 0, 0, 0, 2, 3, 4, 5, 2 6, 0, 3, 4, 3, 4, 0, 1, 3 2, 3, 4, 0, 1, 2, 3, 4, 4 0, 1, 2, 3, 4, 0, 0, 2, 5 3, 2, 0, 0, 2, 3, 2, 0, 6 0, 2, 3, 2, 0, 0, 0, 1, 7 2, 0, 0, 0, 1, 2, 0, 0, 8 0, 1, 2, 0, 0, 0, 1, 2/ DATA I(226),I(227),I(228),I(229),I(230),I(231),I(232),I(233), 1 I(234),I(235),I(236),I(237),I(238),I(239),I(240),I(241), 1 I(242),I(243),I(244),I(245),I(246),I(247),I(248),I(249), 2 I(250),I(251),I(252),I(253),I(254),I(255),I(256),I(257), 3 I(258),I(259),I(260),I(261),I(262),I(263),I(264),I(265), 4 I(266),I(267),I(268),I(269),I(270),I(271),I(272),I(273), 5 I(274),I(275),I(276),I(277),I(278),I(279),I(280),I(281), 6 I(282),I(283),I(284),I(285),I(286),I(287),I(288),I(289), 7 I(290)/ 1 0, 0, 0, 1, 2, 0, 0, 0, 1 1, 2, 0, 0, 0, 1, 2, 0, 1 0, 0, 1, 2, 1, 1, 1, 1, 2 1, 4, -7, -1, 21, 7, -21, 21, 3 -8, -1, -8, 0, 0, 28, -9, -49, 4 7, 0, 0, 1, 11, -25, -9, -25, 5 0, 0, 0, 0, -10, -10, -5, 45, 6 15, 0, 0, 0, 0, 0, 16, 0, 7 0/ DATA I(291),I(292),I(293),I(294),I(295),I(296),I(297),I(298), 1 I(299),I(300),I(301),I(302),I(303),I(304),I(305),I(306), 1 I(307),I(308),I(309),I(310),I(311),I(312),I(313),I(314), 2 I(315),I(316),I(317),I(318),I(319),I(320),I(321),I(322), 3 I(323),I(324),I(325),I(326),I(327),I(328),I(329),I(330), 4 I(331),I(332),I(333),I(334),I(335),I(336),I(337),I(338), 5 I(339),I(340),I(341),I(342),I(343),I(344),I(345),I(346), 6 I(347),I(348),I(349),I(350),I(351),I(352),I(353),I(354), 7 I(355),I(356),I(357),I(358),I(359),I(360),I(361),I(362), 8 I(363),I(364),I(365),I(366),I(367),I(368),I(369),I(370)/ 1 7, 20, -560, 224, -112, -21, -56, 16, 1 0, 0, 0, 0, 0, 0, 0, 0, 1 3, 0, 0, -56, -448, 49, -64, -14, 2 0, 0, 0, 0, 0, 0, 0, 0, 3 0, 26, 308, 110, 220, 0, 0, 0, 4 7, -154, -28, -132, 0, 0, 0, 0, 5 0, -9, 297, 90, -405, 45, 0, 0, 6 3, 66, -507, -3, -60, 15, 0, 0, 7 0, 5, 315, -14, -175, -21, -56, -25, 8 0, 70, 385, -105, 28, 63, 0, 0/ DATA I(371),I(372),I(373),I(374),I(375),I(376),I(377),I(378), 1 I(379),I(380),I(381),I(382),I(383),I(384),I(385),I(386), 1 I(387),I(388),I(389),I(390),I(391),I(392),I(393),I(394), 2 I(395),I(396),I(397),I(398),I(399),I(400),I(401),I(402), 3 I(403),I(404),I(405),I(406),I(407),I(408),I(409),I(410), 4 I(411),I(412),I(413),I(414),I(415),I(416),I(417),I(418), 5 I(419),I(420),I(421),I(422),I(423),I(424),I(425),I(426), 6 I(427),I(428),I(429),I(430),I(431),I(432),I(433),I(434), 7 I(435)/ 1 0, 0, 0, 315, 0, 0, 135, 0, 1 0, 189, 0, 0, 105, 0, 1, 0, 1 0, 0, 200, 15, 120, 60, -35, 10, 2 0, -25, 88, 200, 45, 20, 0, 1, 3 0, 0, 0, 16, -200, -14, -14, 25, 4 0, 0, 0, 120, -42, 42, 0, 0, 5 1, -105, -175, -175, -75, 0, 0, 0, 6 0, 0, 0, 0, 0, 0, 0, 0, 7 0/ DATA I(436),I(437),I(438),I(439),I(440),I(441),I(442),I(443), 1 I(444),I(445),I(446),I(447),I(448),I(449),I(450),I(451), 1 I(452),I(453),I(454),I(455),I(456),I(457),I(458),I(459), 2 I(460),I(461),I(462),I(463),I(464),I(465),I(466),I(467), 3 I(468),I(469),I(470),I(471),I(472),I(473),I(474),I(475), 4 I(476),I(477),I(478),I(479),I(480),I(481),I(482),I(483), 5 I(484),I(485),I(486),I(487),I(488),I(489),I(490),I(491), 6 I(492),I(493),I(494),I(495),I(496),I(497),I(498),I(499), 7 I(500),I(501),I(502),I(503),I(504),I(505),I(506),I(507), 8 I(508),I(509),I(510),I(511),I(512),I(513),I(514),I(515)/ 1 154, -110, 0, 0, 231, 286, 924, -308, 1 220, -396, 0, 0, 0, 0, 0, 0, 1 -66, -90, 180, 0, 99, -99, 891,-5577, 2 -405, -9, 0, 45, 45, 0, 0, 0, 3 0, 224, 0, -56, 0, -220, 1680, 0, 4 112, 0, -21, 21, 0, -16, 0, 0, 5 -70, 14, -84, 56, 0, 55, 945, 4235, 6 -175, -315, 0, -21, 189, -25, 0, 0, 7 25, -15, -135, 35, 0, 0, 600, 968, 8 120, 600, 0, 60, 60, 10, 3, 0/ DATA I(516),I(517),I(518),I(519),I(520),I(521),I(522),I(523), 1 I(524),I(525),I(526),I(527),I(528),I(529),I(530),I(531), 1 I(532),I(533),I(534),I(535),I(536),I(537),I(538),I(539), 2 I(540),I(541),I(542),I(543),I(544),I(545),I(546),I(547), 3 I(548),I(549),I(550),I(551),I(552),I(553),I(554),I(555), 4 I(556),I(557),I(558),I(559),I(560),I(561),I(562),I(563), 5 I(564),I(565),I(566),I(567),I(568),I(569),I(570),I(571), 6 I(572),I(573),I(574),I(575),I(576),I(577),I(578),I(579), 7 I(580)/ 1 0, -56, 0, -64, 0, 0, 0, 0, 1 448, 0, -9, -49, 0, 14, 0, 0, 1 0, -16, 126, 14, 0, 0, 0, 0, 2 -200, 360, 0, -14, 126, 25, 0, 0, 3 0, 0, 0, 0, -175, 182, -728,-2184, 4 0, 0, 0, 0, 0, 0, 0, 0, 5 0, 0, 0, 0, 0, 220, 880, 0, 6 -400, 0, -9, -25, 0, 0, 0, 0, 7 0/ DATA I(581),I(582),I(583),I(584),I(585),I(586),I(587),I(588), 1 I(589),I(590),I(591),I(592),I(593),I(594),I(595),I(596), 1 I(597),I(598),I(599),I(600),I(601),I(602),I(603),I(604), 2 I(605),I(606),I(607),I(608),I(609),I(610),I(611),I(612), 3 I(613),I(614),I(615),I(616),I(617),I(618),I(619),I(620), 4 I(621),I(622),I(623),I(624),I(625),I(626),I(627),I(628), 5 I(629),I(630),I(631),I(632),I(633),I(634),I(635),I(636), 6 I(637),I(638),I(639),I(640),I(641),I(642),I(643),I(644), 7 I(645),I(646),I(647),I(648),I(649),I(650),I(651),I(652), 8 I(653),I(654),I(655),I(656),I(657),I(658),I(659),I(660)/ 1 0, 0, 0, -45, -5, 845,-1215, 275, 1 495, 0, -11, 99, 0, 0, 0, 0, 1 0, 0, 0, 0, 33, -7,-2541, 105, 2 -525, 0, 35, 35, -15, 0, 0, 0, 3 0, 0, 0, 0, 0, -800, 0, -160, 4 0, -5, 45, 0, 30, 0, 0, 0, 5 0, 0, 0, 0, 0, -100, 1452, 180, 6 -100, 0, -10, 90, 15, -2, 0, 0, 7 0, 0, 0, 0, 0, 0, 0, 0, 8 0, 6, 0, 0, 0, 0, 0, 0/ DATA I(661),I(662),I(663),I(664),I(665),I(666),I(667),I(668), 1 I(669),I(670),I(671),I(672),I(673),I(674),I(675),I(676), 1 I(677),I(678),I(679),I(680),I(681),I(682),I(683),I(684), 2 I(685),I(686),I(687),I(688),I(689),I(690),I(691),I(692), 3 I(693),I(694),I(695),I(696),I(697),I(698),I(699),I(700), 4 I(701),I(702),I(703),I(704),I(705),I(706),I(707),I(708), 5 I(709),I(710),I(711),I(712),I(713),I(714),I(715),I(716), 6 I(717),I(718),I(719)/ 1 0, 0, 0, 0, 0, 0, 0, 0, 1 0, 0, -14, -56, 0, 0, 1, 1, 1 1, 1, 1, 5, 15, 2, 42, 70, 2 60, 140, 30, 10, 60, 1680, 840, 1680, 3 210, 360, 90, 10, 504, 1008, 560, 280, 4 140, 1, 1, 1, 420, 700, 700, 300, 5 550, 1100, 8400,18480, 2800, 2800, 50, 350, 6 700, 150, 5/ C END C*********************************************************************** SUBROUTINE CFP(LIJ,N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/DEBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C C === CHOOSES APPROPRIATE FRACTIONAL PARENTAGE SUBROUTINE C 9 FORMAT(' UNNECESSARY ATTEMPT TO FORM CFP OF AN S-ELECTRON 1E IS AN ERROR') 10 FORMAT(8H COEFP =,F15.9) K=LIJ+1 C C IF F-SHELL OR G-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINES C ARE INCLUDED, THIS COMPUTED GO TO NEEDS MODIFYING TO ACCOUNT FOR C THIS C GO TO (1,2,3,4,4,4,4,4,4,4,4),K C C --- FALSE CALL FOR S-SHELLS C 1 COEFP=1.0D0 GO TO 5 C C --- P-SHELLS C 2 CALL CFPP(N,ILI,ISI,ILJ,ISJ,COEFP) GO TO 5 C C --- D-SHELLS C 3 CALL CFPD(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) GO TO 5 C C --- F-SHELLS, G-SHELLS ETC. WITH UP TO TWO ELECTRONS C 4 CALL CFPF(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) 5 IF(NBUG1-1) 6,6,7 7 WRITE(IWRITE,10) COEFP 6 RETURN END C*********************************************************************** SUBROUTINE CFPD(N,IVI,LI,ISI,IVJ,LJ,ISJ,COEFP) C C C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE C FOR EQUIVALENT D SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER C QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960) C IN THE SUBROUTINE LIST N,THE NO.OF ELECTRONS,V THE SENIORITY QUAN C TUM NO.,L THE ANGULAR MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM C NO. OF BOTH THE STATE IN QUESTION AND ITS PARENT STATE ARE INPUT C PARAMETERS THE RESULT IS OUTPUT AS COEFP C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' COMMON/FRPAR2/K(5),IV(5,16),IL(5,16),IS(5,16),ITAB1(5,1),ITAB2(8,5 1 ),ITAB3(16,8),ITAB4(16,16),NORM1(5),NORM2(8),NORM3(16),NORM4(16) C C C TEST IF N IS IN THE FIRST HALF OF SHELL C 99 IF(N-6) 40,103,103 C C TEST IF STATE IN QUESTION IS ALLOWED C IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1 C 40 J = 0 101 J = J+1 IF(J-17) 41,11,11 41 IF(IV(N,J)-IVI) 101,42,101 42 IF(IL(N,J)-LI) 101,43,101 43 IF(IS(N,J)-ISI) 101,44,101 44 J1=J C C TEST IF PARENT STATE IS ALLOWED C IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2 C IF(N-1) 45,30,45 30 IF(IVJ) 11,31,11 31 IF(LJ) 11,32,11 32 IF(ISJ-1) 11,1,11 45 J = 0 102 J = J+1 IF(J-17) 46,11,11 46 IF(IV(N-1,J)-IVJ) 102,47,102 47 IF(IL(N-1,J)-LJ) 102,48,102 48 IF(IS(N-1,J)-ISJ) 102,49,102 49 J2=J GO TO 100 C C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL C 103 M = 10-N IF(M) 36,33,36 33 IF(IVI) 11,34,11 34 IF(LI) 11,35,11 35 IF(ISI-1) 11,37,11 36 J = 0 104 J = J+1 IF(J-17) 50,11,11 50 IF(IV(M,J)-IVI) 104,51,104 51 IF(IL(M,J)-LI) 104,52,104 52 IF(IS(M,J)-ISI) 104,53,104 53 J1=J 37 J = 0 105 J = J+1 IF(J-17) 54,11,11 54 IF(IV(M+1,J)-IVJ) 105,55,105 55 IF(IL(M+1,J)-LJ) 105,56,105 56 IF(IS(M+1,J)-ISJ) 105,57,105 57 J2=J C C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2) C 100 GO TO (1,2,3,4,5,12,12,12,12,1),N 1 COEFP = 1.0D0 GO TO 10 2 COEFP = ITAB1(J1,J2) IF(COEFP) 60,10,81 60 COEFP = - SQRT(-COEFP/NORM1(J1)) GO TO 10 81 COEFP = SQRT(COEFP/NORM1(J1)) GO TO 10 3 COEFP = ITAB2(J1,J2) IF(COEFP) 61,10,82 61 COEFP = -SQRT(-COEFP/NORM2(J1)) GO TO 10 82 COEFP = SQRT(COEFP/NORM2(J1)) GO TO 10 4 COEFP = ITAB3(J1,J2) IF(COEFP) 62,10,83 62 COEFP = -SQRT(-COEFP/NORM3(J1)) GO TO 10 83 COEFP = SQRT(COEFP/NORM3(J1)) GO TO 10 5 COEFP = ITAB4(J1,J2) IF(COEFP) 63,10,84 63 COEFP = -SQRT(-COEFP/NORM4(J1)) GO TO 10 84 COEFP = SQRT(COEFP/NORM4(J1)) GO TO 10 C C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF C SHELL C 12 ISIGN = (-1)**((ISI+ISJ-7)/2 +LI +LJ) FACTOR = SQRT(((11.0D0-N)*ISJ*(2*LJ+1.0D0))/(N*ISI*(2*LI+1.0D0))) M1 =N-5 GO TO(6,7,8,9),M1 6 COEFP = ITAB4(J2,J1) IF(COEFP) 64,10,85 64 COEFP = -SQRT(-COEFP/NORM4(J2)) GO TO 86 85 COEFP = SQRT(COEFP/NORM4(J2)) 86 COEFP = COEFP*ISIGN*FACTOR IF(MOD((IVJ-1)/2,2)) 87,10,87 87 COEFP = -COEFP GO TO 10 7 COEFP = ITAB3(J2,J1) IF(COEFP) 65,10,88 65 COEFP = -SQRT(-COEFP/NORM3(J2)) GO TO 89 88 COEFP = SQRT(COEFP/NORM3(J2)) 89 COEFP = COEFP * ISIGN * FACTOR GO TO 10 8 COEFP = ITAB2(J2,J1) IF(COEFP) 66,10,90 66 COEFP = -SQRT(-COEFP/NORM2(J2)) GO TO 91 90 COEFP = SQRT(COEFP/NORM2(J2)) 91 COEFP = COEFP * ISIGN * FACTOR GO TO 10 9 COEFP = ITAB1(J2,J1) IF(COEFP) 67,10,92 67 COEFP = -SQRT(-COEFP/NORM1(J2)) GO TO 93 92 COEFP = SQRT(COEFP/NORM1(J2)) 93 COEFP = COEFP * ISIGN * FACTOR GO TO 10 C C AN UNALLOWED STATE C FOR AN UNALLOWED STATE THE F.P. COEFFICIENT IS SET EQUAL TO AN C ERRONEOUS VALUE.BY REPLACING THE 11 COEFP=9.9 STATEMENT BY THE C FOLLWING 3 CARDS THE USER CAN TERMINATE THE RUN WHEN AN C UNALLOWED STATE OCCURS C 106 FORMAT(37H FAIL IN CFPD AT 11 UNALLOWED STATE) C 11 WRITE(IWRITE,106) C PAUSE C 11 COEFP=9.9D0 10 CONTINUE RETURN END C*********************************************************************** SUBROUTINE CFPF(N,IVI,ILI,ISI,IVJ,ILJ,ISJ,COEFP) IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS C C THIS IS A DUMMY SUBROUTINE TO CALCULATE CFP OF F-ELECTRONS. IT IS C VALID ONLY FOR ONE OR TWO ELECTRONS IN THE F-SHELL UNDER C CONSIDERATION. C COEFP=ONE RETURN END C*********************************************************************** C SUBROUTINE CFPP(N,LI,ISI,LJ,ISJ,COEFP) C C THIS SUBROUTINE EVALUATES THE COEFFICIENTS OF FRACTIONAL PARENTAGE C FOR EQUIVALENT P SHELL ELECTRONS FROM TABLES GIVEN IN J.C.SLATER C QUANTUM THEORY OF ATOMIC STRUCTURE,VOLUME2,P350(1960) C IN THE SUBROUTINE LIST N,THE NO. OF ELECTRONS,L THE ANGULAR C MOMENTUM QUANTUM NO.,(2S+1) THE SPIN QUANTUM NO. OF BOTH THE STATE C IN QUESTION AND ITS PARENT STATE ARE INPUT PARAMETERS.THE RESULT C IS OUTPUT AS COEFP C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' DIMENSION IL(3,3),IS(3,3),ITAB1(3,1),ITAB2(3,3),NORM1(3),NORM2(3) C C C SET UP P SHELL PARAMETERS AND TABLES C DATA IL(1,1),IL(2,1),IL(2,2),IL(2,3),IL(3,1),IL(3,2),IL(3,3)/1,1,2 1 ,0,0,2,1/ DATA IS(1,1),IS(2,1),IS(2,2),IS(2,3),IS(3,1),IS(3,2),IS(3,3)/2,3,1 1 ,1,4,2,2/ DATA ITAB1(1,1),ITAB1(2,1),ITAB1(3,1)/1,1,1/ DATA ITAB2(1,1),ITAB2(1,2),ITAB2(1,3),ITAB2(2,1),ITAB2(2,2),ITAB2( 1 2,3),ITAB2(3,1),ITAB2(3,2),ITAB2(3,3)/1,0,0,1,-1,0,-9,-5,4/ DATA NORM1(1),NORM1(2),NORM1(3)/1,1,1/ DATA NORM2(1),NORM2(2),NORM2(3)/1,2,18/ C C TEST IF N IS IN THE FIRST HALF OF SHELL C 99 IF(N-4) 40,103,103 C C TEST IF STATE IN QUESTION IS ALLOWED C IF IT IS, IDENTIFY THE ROW OF THE TABLE BY J1 C 40 J = 0 101 J = J+1 IF(J-4) 41,8,8 41 IF(IL(N,J)-LI) 101,42,101 42 IF(IS(N,J)-ISI) 101,43,101 43 J1 = J C C TEST IF PARENT STATE IS ALLOWED C IF IT IS, IDENTIFY THE COLUMN OF THE TABLE BY J2 C IF(N-1) 44,70,44 70 IF(LJ) 8,71,8 71 IF(ISJ-1) 8,1,8 44 J = 0 102 J = J+1 IF(J-4) 45,8,8 45 IF(IL(N-1,J)-LJ) 102,46,102 46 IF(IS(N-1,J)-ISJ) 102,47,102 47 J2=J GO TO 100 C C SIMILAR SETTING OF J1 AND J2 IF N IS IN SECOND HALF OF SHELL C 103 M =6-N IF(M) 72,73,72 73 IF(LI) 8,74,8 74 IF(ISI-1) 8,75,8 72 J = 0 104 J = J+1 IF(J-4) 48,8,8 48 IF(IL(M,J)-LI) 104,49,104 49 IF(IS(M,J)-ISI) 104,50,104 50 J1 = J 75 J = 0 105 J = J+1 IF(J-4) 51,8,8 51 IF(IL(M+1,J)-LJ) 105,52,105 52 IF(IS(M+1,J)-ISJ) 105,53,105 53 J2 = J C C C IDENTIFY THE F.P.C AS A UNIQUE ELEMENT OF ITABN(J1,J2) C 100 GO TO (1,2,3,4,4,1),N 1 COEFP = 1.0D0 GO TO 10 2 COEFP = ITAB1(J1,J2) IF(COEFP) 54,10,31 54 COEFP = -SQRT(-COEFP/NORM1(J1)) GO TO 10 31 COEFP = SQRT(COEFP/NORM1(J1)) GO TO 10 3 COEFP = ITAB2(J1,J2) IF(COEFP) 55,10,32 55 COEFP = -SQRT(-COEFP/NORM2(J1)) GO TO 10 32 COEFP =SQRT(COEFP/NORM2(J1)) GO TO 10 C C USE RECURRENCE RELATION EQUATION (19) OF RACAH FOR SECOND HALF OF C SHELL C 4 ISIGN = (-1)**((ISI+ISJ-5)/2+LI+LJ) FACTOR = ((7.0D0-N)*ISJ*(2*LJ+1.0D0))/(N*ISI*(2*LI+1.0D0)) IF(N-5) 56,5,8 56 COEFP = ITAB2(J2,J1) IF(COEFP) 57,10,33 57 COEFP = -SQRT(-COEFP/NORM2(J2)) GO TO 34 33 COEFP = SQRT(COEFP/NORM2(J2)) 34 COEFP = COEFP * ISIGN * SQRT(FACTOR) IF(LJ-1) 35,10,35 35 COEFP = -COEFP GO TO 10 5 COEFP = ITAB1(J2,J1) IF(COEFP) 58,10,36 58 COEFP = -SQRT(-COEFP/NORM1(J2)) GO TO 37 36 COEFP = SQRT(COEFP/NORM1(J2)) 37 COEFP = COEFP * ISIGN * SQRT(FACTOR) GO TO 10 C C FOR AN UNALLOWED STATE THE F.P.COEFFICIENT IS SET EQUAL TO AN C ERRONEOUS VALUE. THIS STATEMENT COULD BE REPLACED BY AN ERROR C STATEMENT C 8 COEFP = 9.9D0 10 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C SUBROUTINE NJSYM (J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP) C C GENERAL RECOUPLING PROGRAMME C EVALUATES THE RECOUPLING COEFFICIENT RECUP BETWEEN TWO COUPLING C SCHEMES C C C J6C THE NUMBER OF ELEMENTS IN THE K6 ARRAY C J7C THE NUMBER OF ELEMENTS IN THE K7 ARRAY C J8C THE NUMBER OF ELEMENTS IN THE K8 ARRAY C JWC THE NUMBER OF COLUMNS IN THE KW ARRAY C K6(I),I=1,J6C. EACH ENTRY CORRESPONDS TO A FACTOR SQRT(2J+1) IN C RECUP. THE VALUE OF K6 GIVES POSITION IN J1 ARRAY C WHERE J VALUE IS FOUND C K7(I),I=1,J7C. EACH ENTRY CORRESPONDS TO A FACTOR (-1)**J IN C RECUP C K8(I),I=1,J8C. EACH ENTRY CORRESPONDS TO A FACTOR (-1)**(-J) IN C RECUP C KW(I,J),I=1,6,J=1,JWC. EACH COLUMN CORRESPONDS TO A RACAH C COEFFICIENT IN RECUP C RECUP THE RESULTANT RECOUPLING COEFFICIENT EVALUATED C AND STORED IN RECUP C C C THE ARRAYS K6,K7,K8 AND KW ARE EVALUATED BY NJSYM. THE ENTRY IN C EACH CASE CORRESPONDS TO A POSITION IN THE J1 ARRAY WHERE THE C 2J+1 VALUE IS FOUND IF LESS THAN OR EQUAL TO M,OR TO A SUMMATION C VARIABLE IF GREATER THAN M C C THE SUMMATION OVER THE VARIABLES IN K6,K7,K8 AND KW AND THE C EVALUATION OF RECUP IS CARRIED OUT IN GENSUM C C GENSUM CAN BE RE-ENTERED DIRECTLY TO EVALUATE DIFFERENT C RECOUPLING COEFFICIENTS WITH THE SAME STRUCTURE BY JUST ALTERING C THE NUMBERS IN THE J1 ARRAY C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (KFL2=19,KFL3=20,KFL4=100,KFL5=200,KFL7=100) C DIMENSION K6(KFL4),K7(KFL5),K8(KFL4),KW(6,KFL3) C COMMON/COUPLE/M,N,J1(KFL7),J2(KFL2,3),J3(KFL2,3) COMMON/DEBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20 DATA ZERO/0.0D0/ C C FORMAT STATEMENTS USED IN NJSYM C 50 FORMAT(' RECOUPLING COEFFICIENT SET ZERO AS TRIANGLE DOES 1NOT MATCH') 65 FORMAT(29H FAIL IN RECOUPLING PROGRAMME) 107 FORMAT(4H J1=,20I5) 108 FORMAT(23H J2 J3) 110 FORMAT(3I5,I10,2I5) 111 FORMAT(3H KW) 112 FORMAT(6I5) 113 FORMAT(4H K6=,38I3) 114 FORMAT(4H K7=,38I3) 115 FORMAT(4H K8=,38I3) 145 FORMAT(8H JWC = 0,8H J6C = 0,8H J7C = 0,8H J8C = 0) 204 FORMAT(' KFL2 DIMENSION FAILURE IN NJSYM PACKAGE') 207 FORMAT(' KFL3 DIMENSION FAILURE IN NJSYM PACKAGE') 208 FORMAT(' KFL4 DIMENSION FAILURE IN NJSYM PACKAGE') 209 FORMAT(' KFL5 DIMENSION FAILURE IN NJSYM PACKAGE') 221 FORMAT(17H NO KW ARRAYS SET) 226 FORMAT(17H NO K6 ARRAYS SET) 230 FORMAT(17H NO K7 ARRAYS SET) 233 FORMAT(17H NO K8 ARRAYS SET) 1208 FORMAT(' KFL7 DIMENSION FAILURE IN NJSYM PACKAGE') C C SET DIMENSIONVARIABLES AND TEST SOME OF DIMENSIONS C 201 IF(KFL2-N+1) 202,203,203 202 WRITE(IWRITE,204) CALL EXIT (0) 203 IF(KFL7-M)205,206,206 205 WRITE(IWRITE,1208) CALL EXIT (0) C C IP IS THE NUMBER OF INEQUIVALENT TRIADS WHICH HAVE TO BE C RECOUPLED. IT IS SET INITIALLY TO THE TOTAL NUMBER OF TRIADS AND C THEN DECREASED IN SECTION 1 BELOW AS THE RECOUPLING PROCEEDS C UNTIL EVENTUALLY IT REACHES ZERO C 206 IP=N-1 C C DEBUG PRINTS C IF(NBUG3-1)124,123,124 123 WRITE(IWRITE,108) DO 125 I=1,IP WRITE(IWRITE,110) (J2(I,J),J=1,3),(J3(I,J),J=1,3) 125 CONTINUE C C SET COUNTS ZERO. MP IS COUNT ON THE J VALUES WHICH ARE SUMMED C OVER. C 124 J6C=0 J7C=0 J8C=0 JWC=0 MP=M C C C C C C S E C T I O N 1 C C THE FOLLOWING SECTION SEARCHES THE J2 AND J3 ARRAYS TO SEE IF C ANY TRIADS ARE EQUIVALENT. IF SO IT PUTS THEM AT END OF J2 AND J3 C ARRAYS AND SETS IP EQUAL TO THE NUMBER OF INEQUIVALENT TRIADS C REMAINING. IF IP=0 THEN THE RECOUPING HAS BEEN COMPLETED AND EXIT C IS MADE TO GENSUM TO CARRY OUT THE SUMMATIONS C 117 I1=1 16 DO 1 I2=1,IP IF(J2(I2,1)-J3(I1,1)) 2,3,2 2 IF(J2(I2,2)-J3(I1,1))1,4,1 1 CONTINUE C C NO EQUIVALENT TRIADS WITH THIS VALUE OF I1. INCREASE I1 AND TRY C AGAIN C GO TO 5 3 IF(J2(I2,2)-J3(I1,2))5,6,5 4 IF(J2(I2,1)-J3(I1,2))5,6,5 6 IF(I2-IP)7,8,8 C C REARRANGE SO THAT EQUIVALENT TRIADS OCCUR AT THE END OF J2 AND C J3 ARRAYS C 7 I3=J2(I2,1) I4=J2(I2,2) I5=J2(I2,3) I6=I2+1 DO 9 I7=I6,IP DO 10 I8=1,3 J2(I7-1,I8)=J2(I7,I8) 10 CONTINUE 9 CONTINUE J2(IP,1)=I3 J2(IP,2)=I4 J2(IP,3)=I5 8 IF(I1-IP)11,14,14 11 I3=J3(I1,1) I4=J3(I1,2) I5=J3(I1,3) I6=I1+1 DO 12 I7=I6,IP DO 13 I8=1,3 J3(I7-1,I8)=J3(I7,I8) 13 CONTINUE 12 CONTINUE J3(IP,1)=I3 J3(IP,2)=I4 J3(IP,3)=I5 C C IS THE THIRD ELEMENT IN J2 SUMMED OVER. IF SO REPLACE BY THIRD C ELEMENT IN J3 ARRAY C 14 IF(J2(IP,3)-M)47,47,44 44 J=J3(IP,3) JP=J2(IP,3) J2(IP,3)=J IF(IP-2)101,18,18 C C NOW REPLACE ALL OTHER ELEMENTS IN J2,KW,K7,K8 AND K6 WHICH ARE C SUMMED OVER AT THE SAME TIME BY THE SAME QUANTITY J C 18 IQ=IP-1 DO 19 I3=1,IQ DO 20 I4=1,3 IF(J2(I3,I4)-JP) 20,21,20 21 J2(I3,I4)=J 20 CONTINUE 19 CONTINUE 101 IF(JWC)38,38,39 39 DO 23 I=1,6 DO 22 I3=1,JWC IF(KW(I,I3)-JP) 22,25,22 25 KW(I,I3)=J 22 CONTINUE 23 CONTINUE 38 IF(J7C)87,87,41 41 DO 34 I3=1,J7C IF(K7(I3)-JP)34,35,34 35 K7(I3)=J 34 CONTINUE 87 IF(J8C)40,40,86 86 DO 88 I3=1,J8C IF(K8(I3)-JP)88,89,88 89 K8(I3)=J 88 CONTINUE 40 IF(J6C)42,42,43 43 DO 36 I3=1,J6C IF(K6(I3)-JP)36,37,36 37 K6(I3)=J 36 CONTINUE C C SET I1 BACK TO 1 IN ORDER TO START SEARCH FOR EQUIVALENT TRIADS C AGAIN SINCE SOME ELEMENTS MAY HAVE BEEN ALTERED C 42 I1=1 C C TEST WHETHER TRIANGLE MATCHES C 47 JJ2=J2(IP,3) JJ3=J3(IP,3) IF(JJ2-JJ3) 148,49,148 148 IF(J1(JJ2)-J1(JJ3)) 48,44,48 C C RECOUPLING COEFFICIENT SET ZERO WHEN TRIAD IN INITIAL AND FINAL C STATES DO NOT MATCH. IN THIS CASE, GENSUM IS NOT CALLED AND THE C ARRAYS K6,K7,K8,KW ARE NOT SET UP, READY FOR FURTHER DIRECT C ENTRIES TO GENSUM. C 48 IF(NBUG3-1) 150,151,150 151 WRITE(IWRITE,50) 150 RECUP=ZERO RETURN C C IF J2 ANGULAR MOMENTA ARE IN OPPOSITE ORDER TO J3 ANGULAR C MOMENTA INTERCHANGE THEM AND STORE SIGN CHANGES IN K7 AND K8. C CHECK DIMENSIONS C 49 IF(J2(IP,1)-J3(IP,1))100,99,100 100 J=J2(IP,1) J2(IP,1)=J2(IP,2) J2(IP,2)=J K7(J7C+1)=J2(IP,1) K7(J7C+2)=J2(IP,2) J7C=J7C+2 K8(J8C+1)=J2(IP,3) J8C=J8C+1 IF(KFL5-J7C) 210,220,220 220 IF(KFL4-J8C) 212,99,99 C C DECREASE IP AND RETURN TO LOOK FOR FURTHER EQUIVALENT TRIADS C 99 IP=IP-1 GO TO 15 5 I1=I1+1 15 IF(I1-IP)16,16,17 C C IF IP = 0 THIS MEANS THAT ALL TRIADS HAVE BEEN TRANSFORMED TO BE C EQUIVALENT. NOW EXIT TO SUM OVER RACAH COEFFICIENTS C 17 IF(IP)126,126,46 C C C C C C S E C T I O N 2 C C ITEST = 0 DETERMINES THE MIMIMUM RECOUPLING OF J2 ARRAY TO C OBTAIN AN EQUIVALENT TRIAD TO ONE IN J3 ARRAY. STORE ROW OF J3 C ARRAY IN ITEST1. C ITEST = 1 DETERMINE RECOUPLING OF J2 ARRAY TO OBTAIN AN C EQUIVALENT TRIAD OF ITEST1 ROW OF J3 ARRAY. C IN BOTH CASES STORE INFORMATION ON RECOUPLING C 46 I10=9999 ITEST=0 I1=1 C C GENJ45 DETERMINES THE LEVEL OF EACH J IN THE COUPLING TREE OF J2 C AND J3 AND STORES THE RESULT IN THE J4 AND J5 ARRAYS RESPECTIVELY C 96 CALL GENJ45(IP) C C LOOK FOR J IN J2 ARRAY WHICH IS SAME AS FIRST ELEMENT IN J3 ARRAY C 95 DO 52 I2=1,IP IF(J2(I2,1)-J3(I1,1))53,54,53 53 IF(J2(I2,2)-J3(I1,1))52,55,52 52 CONTINUE GO TO 51 C C I3 AND I5 DENOTES POSITION IN J2 ARRAY OF COMMON J C 54 I3=1 GO TO 60 55 I3=2 60 I5=I2 C C NOW LOOK FOR J IN J2 ARRAY WHICH IS SAME AS OTHER ELEMENT IN J3 C ARRAY C DO 56 I2=1,IP IF(J2(I2,1)-J3(I1,2))57,58,57 57 IF(J2(I2,2)-J3(I1,2))56,59,56 56 CONTINUE GO TO 51 C C I4 AND I6 DENOTES POSITION IN J2 ARRAY OF COMMON J C 58 I4=1 GO TO 61 59 I4=2 61 I6=I2 C C I7 AND I8 DENOTE THE POSITION IN THE J1 ARRAY OF THE TWO COMMON J C VALUES IN J2 AND J3 C I7=J2(I5,I3) I8=J2(I6,I4) C C GENI9 DETERMINES THE NUMBER OF RECOUPLINGS OF TWO ELEMENTS OF J2 C NECESSARY TO OBTAIN IDENTICAL TRIADS IN J2 AND J3 ARRAYS. THIS C NUMBER PLUS TWO IS STORED IN I9 C CALL GENI9(IP) IF(I9-I10)62,51,51 C C A SMALLER RECOUPLING PAIR FOUND. STORE LOWEST AS J2(I13,I14) AND C HIGHEST AS J2(I11,I12). I15 AND I16 CONTAIN LEVEL OF THESE BELOW C COMMON TRIADS. FINALLY ITEST1 DENOTES TRIAD IN J3 FOR NEXT ENTRY C TO SECTION 2 AND IS REQUIRED IF MORE THAN ONE RECOUPLING C 62 I10=I9 I11 = I17 I12 = I19 I13 = I18 I14 = I20 I15=I7 I16=I8 ITEST1=I1 51 IF(ITEST) 98,97,98 C C I1 IS ONLY INCREASED IF SEARCHING FOR SMALLEST RECOUPLING PAIR C 97 I1=I1+1 IF(I1-IP)95,95,98 98 IF(I10-9999)63,64,64 C C FAIL BECAUSE NO PAIR IN J2 AND J3 FOUND WHICH COULD BE RECOUPLED C 64 WRITE(IWRITE,65) CALL EXIT (0) C C C C C C S E C T I O N 3 C C THE PAIR OF J VALUES THAT REQUIRE THE SMALLEST NUMBER OF C RECOUPLINGS OF J2 TO BRING INTO THE SAME ORDER AS J3 HAS NOW C BEEN FOUND. THIS SECTION NOW CARRIES OUT ONE RECOUPLING C 63 IF(I15-I16) 67,68,68 C C I1 AND I2 DENOTES THE LEVEL ABOVE THE GIVEN LEVELS OF THE TRIAD C OF ELEMENTS TO BE RECOUPLED C 67 I1=I15-1 I2=I16-2 GO TO 69 68 I1=I16-1 I2=I15-2 69 I3 = I11 I4 = I13 I5 = I12 I6 = I14 IF(I1)70,70,71 C C FIND FIRST ELEMENT TO BE RECOUPLED C 71 DO 72 I=1,I1 DO 73 I7=1,IP IF(J2(I7,1)-J2(I3,3))74,75,74 74 IF(J2(I7,2)-J2(I3,3)) 73,76,73 73 CONTINUE 75 I5=1 GO TO 77 76 I5=2 77 I3=I7 72 CONTINUE C C FIRST ELEMENT TO BE RECOUPLED IS J2(I3,I5) C NOW FIND SECOND ELEMENT TO BE RECOUPLED C 70 IF(I2)78,78,79 79 DO 80 I=1,I2 DO 81 I7=1,IP IF(J2(I7,1)-J2(I4,3))82,83,82 82 IF(J2(I7,2)-J2(I4,3))81,84,81 81 CONTINUE 83 I6=1 GO TO 85 84 I6=2 85 I4=I7 80 CONTINUE C C SECOND ELEMENT TO BE RECOUPLED IS J2(I4,I6) C 78 IF(I6-1)90,90,91 C C INTERCHANGE ELEMENTS OF I4 ROW OF J2 IF NECESSARY AND INCLUDE C SIGNS IN K7 AND K8 ARRAYS C 90 K7(J7C+1)=J2(I4,1) K7(J7C+2)=J2(I4,2) J7C=J7C+2 K8(J8C+1)=J2(I4,3) J8C=J8C+1 I=J2(I4,1) J2(I4,1)=J2(I4,2) J2(I4,2)=I 91 IF(I5-1) 92,92,93 C C INTERCHANGE ELEMENTS OF I3 ROW OF J2 IF NECESSARY AND STORE SIGNS C IN K7 AND K8 ARRAYS C 92 K7(J7C+1)=J2(I3,1) K7(J7C+2)=J2(I3,2) J7C=J7C+2 K8(J8C+1)=J2(I3,3) J8C=J8C+1 I=J2(I3,1) J2(I3,1)=J2(I3,2) J2(I3,2)=I C C NOW RECOUPLE THE TWO ELEMENTS OF J2 AND STORE SQUARE ROOTS IN K6 C AND RACAH COEFFICIENT IN KW ARRAYS. MP DENOTES A J WHICH WILL BE C SUMMED OVER C 93 K6(J6C+1)=J2(I4,3) MP=MP+1 K6(J6C+2)=MP J6C=J6C+2 JWC=JWC+1 KW(1,JWC)=J2(I4,1) KW(2,JWC)=J2(I4,2) KW(3,JWC)=J2(I3,3) KW(4,JWC)=J2(I3,2) KW(5,JWC)=J2(I3,1) KW(6,JWC)=MP J2(I3,1)=J2(I4,1) J2(I4,1)=J2(I4,2) J2(I4,2)=J2(I3,2) J2(I4,3)=MP J2(I3,2)=MP C C TEST DIMENSIONS AND EXIT IF FAILURE C IF(KFL5-J7C)210,211,211 210 WRITE(IWRITE,209) CALL EXIT (0) 211 IF(KFL4-J8C) 212,213,213 212 WRITE(IWRITE,208) CALL EXIT (0) 213 IF(KFL7-MP)212,215,215 215 IF(KFL4-J6C) 212,217,217 217 IF(KFL3-JWC) 218,219,219 218 WRITE(IWRITE,207) CALL EXIT (0) 219 IF(I1+I2) 117,117,94 C C MORE THAN ONE RECOUPLING REQUIRED. RETURN TO SECTION 2 TO DECIDE C WHICH ELEMENTS OF J2 TO RECOUPLE IN NEXT STEP. IF ALL RECOUPLINGS C OF A PARTICULAR PAIR HAVE BEEN CARRIED OUT THEN IDENTICAL PAIRS C ARE NOW PRESENT IN J2 AND J3 ARRAYS. RETURN TO SECTION 1 TO SEE C IF ANY MORE RECOUPLING REQUIRED C 94 ITEST=1 I1=ITEST1 I10=9999 GO TO 96 C C DEBUG PRINTS C 126 IF(NBUG3-1) 105,104,105 104 WRITE(IWRITE,107) (J1(I),I=1,M) WRITE(IWRITE,111) IF(JWC) 127,127,128 128 DO 116 J=1,JWC WRITE(IWRITE,112) (KW(I,J),I=1,6) 116 CONTINUE GO TO 224 127 WRITE(IWRITE,221) 224 IF(J6C) 222,222,223 223 WRITE(IWRITE,113) (K6(J),J=1,J6C) GO TO 225 222 WRITE(IWRITE,226) 225 IF(J7C) 227,227,228 228 WRITE(IWRITE,114) (K7(J),J=1,J7C) GO TO 229 227 WRITE(IWRITE,230) 229 IF(J8C) 231,231,232 232 WRITE(IWRITE,115) (K8(J),J=1,J8C) GO TO 105 231 WRITE(IWRITE,233) C C CARRY OUT SUMMATIONS C 105 CALL GENSUM(J6C,J7C,J8C,JWC,K6,K7,K8,KW,RECUP) RETURN END C*********************************************************************** SUBROUTINE GENI9(IP) C C DETERMINES THE NUMBER OF RECOUPLING NECESSARY TO BRING J2(I5,I3) C AND J2(I6,I4) INTO THE SAME TRIAD. THIS WILL GIVE A TRIAD C IDENTICAL WITH ONE IN J3. ON EXIT I9 CONTAINS THE NUMBER OF C RECOUPLINGS PLUS TWO,I7 CONTAINS THE LEVEL OF THE I5 TRIAD BELOW C THE COMMON TRIAD AND I8 CONTAINS THE LEVEL OF THE I6 TRIAD BELOW C THE COMMON TRIADS C SEE DESCRIPTION OF COMMON BLOCK WCOMI9 FOR FURTHER DETAILS C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (KFL2=19,KFL7=100) C COMMON/COUPLE/M,N,J1(KFL7),J2(KFL2,3),J3(KFL2,3) COMMON/DEPTHS/J4(KFL7),J5(KFL7) COMMON/WCOMI9/I3,I4,I5,I6,I7,I8,I9,I17,I18,I19,I20 C C C I1 = J4(I7) I2 = J4(I8) C C DETERMINES WHICH J OF J2(I5,I3) AND J2(I6,I4) LIES LOWEST, STORE C LOWEST AS J2(I18,I20) AND HIGHEST AS J2(I17,I19) C IF (I1-I2) 1,1,3 1 I17 = I5 I18 = I6 I19 = I3 I20 = I4 I3 = I2-I1 I7 = 0 I8 = I3 I4 = I1 IF (I3) 8,8,2 C C I6 DENOTES THE LOWEST TRIAD,SCAN TRIADS TO FIND NEW TRIAD I6 AT C SAME LEVEL AS I5 C 2 DO 4 I = 1,I3 DO 5 J = 1,IP IF (J2(J,1)-J2(I6,3)) 7,6,7 7 IF (J2(J,2)-J2(I6,3)) 5,6,5 5 CONTINUE J=IP 6 I6 = J 4 CONTINUE GO TO 8 3 I17 = I6 I18 = I5 I19 = I4 I20 = I3 I3 = I1-I2 I7 = I3 I8 = 0 C C I5 DENOTES THE LOWEST TRIADS. SCAN TRIADS TO FIND NEW TRIAD I6 AT C SAME LEVEL I5 C DO 9 I = 1,I3 DO 12 J = 1,IP IF (J2(J,1)-J2(I5,3)) 10,11,10 10 IF (J2(J,2)-J2(I5,3)) 12,11,12 12 CONTINUE J=IP 11 I5 = J 9 CONTINUE I4 = I2 C C I5 AND I6 NOW DENOTES TRIADS AT SAME LEVEL. I4 CONTAINS THE C COMMON LEVEL C 8 DO 13 I = 1,I4 I1 = I IF (I5-I6) 14,21,14 C C I5 AND I6 DENOTE DIFFERENT TRIADS SCAN TO FIND TRIADS AT NEXT C LEVEL WHICH REPLACE I5 AND I6 C 14 DO 15 J = 1,IP IF (J2(J,1)-J2(I5,3)) 16,17,16 16 IF (J2(J,2)-J2(I5,3)) 15,17,15 15 CONTINUE J=IP 17 I5 = J DO 18 J = 1,IP IF (J2(J,1)-J2(I6,3)) 19,20,19 19 IF (J2(J,2)-J2(I6,3)) 18,20,18 18 CONTINUE J=IP 20 I6 = J 13 CONTINUE C C I5 AND I6 NOW BOTH DENOTE THE COMMON TRIAD C 21 I9 = I3+2*I1 I8 = I8+I1 I7 = I7+I1 RETURN END C*********************************************************************** SUBROUTINE GENJ45(IP) C C FIND THE LEVEL OF EACH J IN THE COUPLING TREES OF J2 AND J3 AND C STORE IN THE J4 AND J5 ARRAYS RESPECTIVELY. IF AN ELEMENT OF J1 C DOES NOT OCCUR IN J2 THE J4 ENTRY IS -1 AND IF AN ELEMENT DOES C NOT OCCUR IN J3 THE J5 ENTRY IS -1 C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C PARAMETER (KFL2=19,KFL7=100) C COMMON/COUPLE/M,N,J1(KFL7),J2(KFL2,3),J3(KFL2,3) COMMON/DEPTHS/J4(KFL7),J5(KFL7) C C C DO 1 I=1,M DO 2 I2=1,IP C C STORE LEVEL OF EACH J IN J2 ARRAY IN J4 C IF (J2(I2,1)-I) 3,4,3 3 IF (J2(I2,2)-I) 2,4,2 2 CONTINUE DO 17 I2 = 1,IP IF (J2(I2,3)-I) 17,18,17 17 CONTINUE J4(I) = -1 GO TO 5 18 J4(I) = 0 GO TO 5 4 I3 = 1 9 DO 6 I4 = 1,IP IF (J2(I4,1)-J2(I2,3)) 7,8,7 7 IF (J2(I4,2)-J2(I2,3)) 6,8,6 6 CONTINUE J4(I) = I3 GO TO 5 8 I3 = I3+1 I2 = I4 GO TO 9 C C STORE LEVEL OF EACH J IN J3 ARRAY IN J5 C 5 DO 10 I2 = 1,IP IF (J3(I2,1)-I) 11,12,11 11 IF (J3(I2,2)-I) 10,12,10 10 CONTINUE DO 19 I2 = 1,IP IF (J3(I2,3)-I) 19,20,19 19 CONTINUE J5(I) = -1 GO TO 1 20 J5(I) = 0 GO TO 1 C 12 I3 = 1 16 DO 13 I4 = 1,IP IF (J3(I4,1)-J3(I2,3)) 14,15,14 14 IF (J3(I4,2)-J3(I2,3)) 13,15,13 13 CONTINUE J5(I) = I3 GO TO 1 15 I3 = I3+1 I2 = I4 GO TO 16 1 CONTINUE RETURN END C*********************************************************************** SUBROUTINE GENSUM(J6C,J7C,J8C,JWC,J6,J7,J8,JW,RECUP) IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C C CARRIES OUT THE SUMMATION OVER COEFFICIENTS DEFINED BY THE ARRAYS C J6,J7,J8 AND JW TO GIVE RECUP C THE ENTRY IS EITHER MADE FROM NJSYM OR DIRECTLY ASSUMING THAT THE C ARRAYS J6,J7,J8 AND JW HAVE ALREADY BEEN DETERMINED BY A PREVIOUS C ENTRY TO NJSYM AND THAT THE SUMMATION IS REQUIRED FOR ANOTHER SET C OF J VALUES DEFINED BY THE ARRAY J1 C THE DEFINITION OF THE ARGUMENT LIST IS GIVEN AT BEGINNING OF C NJSYM C PARAMETER (KFL2=19,KFL3=20,KFL4=100,KFL5=200,KFL6=12,KFL7=100) DIMENSION IST(6),JWORD(6,KFL3),J6P(KFL4),J7P(KFL5),J8P(KFL4), 1 JSUM1(KFL6),JSUM2(KFL6), ! JSUM4(KFL6,KFL3), 2 JSUM5(KFL6,KFL3),JSUM3(KFL6),JSUM6(KFL6),JSUM7(KFL6), 3 JSUM8(KFL6),JSUM(2,KFL3),JWTEST(KFL3),WSTOR(KFL3), 4 IPAIR(2,2) DIMENSION J6(KFL4),J7(KFL5),J8(KFL4),JW(6,KFL3) COMMON/COUPLE/M,N,J1(KFL7),J2(KFL2,3),J3(KFL2,3) COMMON/DEBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/INFORM/IREAD,IWRITE,IPUNCH DATA ZERO,ONE /0.0D0,1.0D0/ C C FORMAT STATEMENTS USED IN GENSUM C 35 FORMAT (21H FAIL IN GENSUM AT 35) 36 FORMAT (21H FAIL IN GENSUM AT 36) 42 FORMAT (21H FAIL IN GENSUM AT 42) 63 FORMAT (21H FAIL IN GENSUM AT 63) 169 FORMAT(22H 169... RECUP =,F12.8,7H STOR =,F12.8,8H STOR1 =, 1F12.8) 170 FORMAT(18H 170... IST ,6I4) 190 FORMAT(8H WSTOR =,10F10.6) 308 FORMAT(' KFL6 DIMENSION FAILURE IN NJSYM PACKAGE') 311 FORMAT(22H FAIL IN GENSUM AT 310) C C C C C C S E C T I O N 1 C C EVALUATES ALL TERMS IN J6,J7,J8 AND JW WHICH DO NOT INVOLVE A C SUMMATION AND FORM MODIFIED ARRAYS J6P,J7P,J8P AND JWORD WHICH DO C THE RESULT OF THE EVALUATION IS STORED IN RECUP AND AISTOR C RECUP=ONE MAXJWE=M JWRD = 0 IF(JWC)302,302,185 C C MULTIPLY RECUP BY ALL RACAH COEFFICIENTS WHICH DO NOT INVOLVE A C SUMMATION C 185 DO 1 I=1,JWC DO 2 J=1,6 IF(JW(J,I)-M) 2,2,3 2 CONTINUE DO 4 J=1,6 I1=JW(J,I) IST(J) = J1(I1) - 1 4 CONTINUE CALL DRACAH(IST(1),IST(2),IST(3),IST(4),IST(5),IST(6),X1) RECUP = RECUP*X1 GO TO 1 C C JWRD IS THE NUMBER OF RACAH COEFFICIENTS WHICH INVOLVE A C SUMMATION C JWORD(I,J),I=1,6,J=1,JWRD CONTAINS THE NUMBER WHICH GIVE THE C LOCATION OF THE J VALUES FOR THE RACAH COEFFICIENTS EITHER IN THE C J1 LIST OR IN THE JSUM1 LIST C 3 JWRD = JWRD+1 DO 5 J=1,6 JWORD(J,JWRD)=JW(J,I) C C MAXJWE CONTAINS THE MAXIMUM J IN THE LIST OF VARIABLES TO BE C SUMMED OVER C IF(MAXJWE-JW(J,I)) 215,5,5 215 MAXJWE=JW(J,I) 5 CONTINUE 1 CONTINUE 302 J6CP=0 IF(J6C)300,300,301 C C J6P(I),I=1,J6CP CONTAINS ALL J6 WHICH INVOLVE A SUMMATION C MULTIPLY RECUP BY ALL THOSE WHICH DO NOT C 301 DO 6 I=1,J6C IF(J6(I)-M) 7,7,21 7 I1=J6(I) RECUP = RECUP*SQRT(DBLE(J1(I1))) GO TO 6 21 J6CP = J6CP+1 J6P(J6CP)=J6(I) 6 CONTINUE 300 IASTOR = 0 J7CP = 0 IF(J7C) 303,303,304 C C J7P(I),I=1,J7CP CONTAINS ALL J7 WHICH INVOLVE A SUMMATION. C MULTIPLY RECUP BY ALL THOSE WHICH DO NOT C 304 DO 8 I=1,J7C IF(J7(I)-M) 9,9,22 9 I1=J7(I) IASTOR = IASTOR + J1(I1) -1 GO TO 8 22 J7CP = J7CP+1 J7P(J7CP)=J7(I) 8 CONTINUE 303 J8CP=0 IF(J8C) 305,305,306 C C J8CP(I),I=1,J8CP CONTAINS ALL J8 WHICH INVOLVE A SUMMATION C MULTIPLY RECUP BY ALL THOSE WHICH DO NOT C 306 DO 10 I=1,J8C IF(J8(I)-M) 11,11,23 11 I1=J8(I) IASTOR = IASTOR - J1(I1) + 1 GO TO 10 23 J8CP=J8CP+1 J8P(J8CP)=J8(I) 10 CONTINUE C C NO RACAH COEFFICIENTS REMAINING AND THUS NO SUMMATIONS TO BE C CARRIED OUT IF JWRD=0. JUMP TO END TO INCLUDE (-1) FACTORS IN C RECUP AND THEN EXIT C 305 IF(JWRD) 12,12,13 C C C C C C S E C T I O N 2 C C SEARCH THROUGH THE JWORD LIST TO FIND ALL THE SUMMATION VARIABLES C NSUM IS THE NUMBER OF SUMMATION VARIABLES C JSUM1(I),I=1,NSUM CONTAINS A LIST OF ALL SUMMATION VARIABLES IN C THE SAME NOTATION AS IN JW LIST C 13 NSUM=0 MAXSUM=MAXJWE-M DO 24 I=1,MAXSUM JSUM6(I)=0 JSUM7(I)=0 24 CONTINUE C C FIND SUMMATION VARIABLES C DO 14 I=1,JWRD DO 15 J=1,6 IF(JWORD(J,I)-M) 15,15,16 16 NSUM=NSUM+1 IF(NSUM-1) 17,17,18 C C HAS THE SUMMATION VARIABLE OCCURED BEFORE. IF NOT INCLUDE IN C JSUM1 LIST C 18 NSUM1 = NSUM-1 DO 19 I1=1,NSUM1 IF(JWORD(J,I)-JSUM1(I1)) 19,20,19 19 CONTINUE 17 JSUM1(NSUM)=JWORD(J,I) I1=NSUM GO TO 25 20 NSUM =NSUM1 C C JSUM6(I),I=1,NSUM IS THE NUMBER OF TIMES EACH SUMMATION VARIABLE C OCCURS IN JWORD C 25 JSUM6(I1)=JSUM6(I1)+1 I2=JSUM6(I1) C C JSUM4(I,J),JSUM5(I,J),I=1,NSUM,J=1,JSUM6(I) IS THE POSITION IN C THE JWORD LIST WHERE THE JSUM1 ELEMENT OCCURS C C JSUM4(I1,I2)=J !NOT USED JSUM5(I1,I2)=I C C (JWORD-M) GIVES LOCATION IN JSUM1 LIST IF A SUMMATION VARIABLE C JWORD(J,I)=M+I1 15 CONTINUE 14 CONTINUE IF(KFL6-NSUM) 312,307,307 312 WRITE(IWRITE,308) CALL EXIT (0) 307 IF(J6CP) 26,26,27 C C CHECK THAT NO EXTRA SUMMATION VARIABLES OCCUR IN J6P. SET J6P C EQUAL TO THE LOCATION IN JSUM1 LIST OF SUMMATION VARIABLE C 27 DO 28 I=1,J6CP DO 29 J=1,NSUM IF(J6P(I)-JSUM1(J)) 29,30,29 29 CONTINUE WRITE(IWRITE,35) CALL EXIT (0) 30 J6P(I)=J 28 CONTINUE 26 IF(J7CP) 130,130,31 C C CHECK THAT NO EXTRA SUMMATION VARIABLES OCCUR IN J7P, SET J7P C EQUAL TO THE LOCATION IN JSUM1 LIST OF SUMMATION VARIABLE C 31 DO 32 I=1,J7CP DO 33 J=1,NSUM IF(J7P(I)-JSUM1(J)) 33,34,33 33 CONTINUE WRITE(IWRITE,36) CALL EXIT (0) 34 J7P(I)=J 32 CONTINUE 130 IF(J8CP) 37,37,38 C C CHECK THAT NO EXTRA SUMMATION VARIABLES OCCUR IN J8P. SET J8P C EQUAL TO THE LOCATION IN JSUM1 LIST OF SUMMATION VARIABLE C 38 DO 39 I=1,J8CP DO 40 J=1,NSUM IF(J8P(I)-JSUM1(J)) 40,41,40 40 CONTINUE WRITE(IWRITE,42) CALL EXIT (0) 41 J8P(I)=J 39 CONTINUE C C C C C C S E C T I O N 3 C C ORDERS THE SUMMATION VARIABLES SO THAT THE RANGE OF EACH C SUMMATION HAS BEEN PREVIOUSLY DEFINED C 37 NCT =0 NCT1 = 0 64 DO 43 I=1,JWRD DO 44 J=1,6 I1=JWORD(J,I)-M IF(I1) 44,44,45 C C JSUM7(I),I=1,NSUM IS THE ORDER OF THE SUMMATIONS OVER THE J C VARIABLES. INITIALLY THIS ARRAY IS ZERO C 45 IF(JSUM7(I1)) 46,46,44 46 GO TO (47,48,49,50,51,52),J C C THE ROWS OF THE IPAIR ARRAYS GIVE LIMITS OF SUMMATION IMPOSED C BY THE TRIANGULAR CONDITION C 47 IPAIR(1,1) = JWORD(2,I) IPAIR(1,2) = JWORD(5,I) IPAIR(2,1) = JWORD(3,I) IPAIR(2,2) = JWORD(6,I) GO TO 53 48 IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(5,I) IPAIR(2,1) = JWORD(4,I) IPAIR(2,2) = JWORD(6,I) GO TO 53 49 IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(6,I) IPAIR(2,1) = JWORD(4,I) IPAIR(2,2) = JWORD(5,I) GO TO 53 50 IPAIR(1,1) = JWORD(2,I) IPAIR(1,2) = JWORD(6,I) IPAIR(2,1) = JWORD(3,I) IPAIR(2,2) = JWORD(5,I) GO TO 53 51 IPAIR(1,1)= JWORD(1,I) IPAIR(1,2) = JWORD(2,I) IPAIR(2,1) = JWORD(3,I) IPAIR(2,2) = JWORD(4,I) GO TO 53 52 IPAIR(1,1) = JWORD(1,I) IPAIR(1,2) = JWORD(3,I) IPAIR(2,1) = JWORD(2,I) IPAIR(2,2) = JWORD(4,I) C C TEST WHETHER RANGE OF SUMMATION HAS BEEN DEFINED. WE CHOOSE THE C FIRST PAIR OF J VALUES THAT DEFINE THE RANGE AND STORE IN JSUM C 53 DO 54 I2=1,2 DO 55 I3=1,2 IF(IPAIR(I2,I3)-M) 55,55,56 56 I4 = IPAIR(I2,I3)-M C C JSUM7 GREATER THAN ZERO MEANS THAT LIMIT IS DEFINED PREVIOUSLY C IF(JSUM7(I4)) 54,54,55 55 CONTINUE GO TO 57 54 CONTINUE GO TO 44 C C NCT IS COUNT ON ORDER OF SUMMATION C 57 NCT = NCT+1 JSUM7(I1)=NCT C C JSUM(I,J),I=1,2,J=1,NSUM CONTAINS THE POSITION OF THE J VALUES C THAT DEFINE THE RANGE OF EACH VARIABLE. THE FIRST ROW CORRESPONDS C TO THE FIRST J AND THE SECOND ROW TO THE SECOND J DEFINING RANGE. C IF VALUE IN RANGE 1 TO M THEN CORRESPONDS TO AN ELEMENT IN J1. C IF VALUE GREATER THAN M THEN CORRESPONDS TO A SUMMATION VARIABLE C IN JSUM1 LIST. NOTE THAT JSUM DOES NOT NECESSARILY CONTAIN THE C MOST RESTRICTIVE RANGES SINCE ONLY ONE OF TWO POSSIBLE PAIRS FROM C THE RACAH COEFFICIENT IS TAKEN C DO 58 I3=1,2 JSUM(I3,I1)=IPAIR(I2,I3) 58 CONTINUE 44 CONTINUE 43 CONTINUE C C CHECK WHETHER THE RANGE OF ALL SUMMATIONS SET. FAIL IF NOT C POSSIBLE TO SET ALL RANGES C IF(NCT-NSUM) 59,60,60 59 IF(NCT-NCT1) 61,61,62 61 WRITE(IWRITE,63) CALL EXIT (0) 62 NCT1=NCT GO TO 64 C C JSUM8(I),I=1,NSUM IS THE POSITION IN THE JSUM7 LIST WHERE THE ITH C SUMMATION IS FOUND C 60 DO 65 J=1,NSUM DO 66 I1=1,NSUM IF(JSUM7(I1)-J) 66,67,66 66 CONTINUE I1=NSUM 67 JSUM8(J)=I1 65 CONTINUE C C C C C C S E C T I O N 4 C C CARRY OUT THE SUMMATIONS. C I6 DENOTES THE FIRST J THAT REQUIRES TO BE SET TO THE LOWEST C VALUE IN THE RANGE C I7 = 0 THE FIRST TIME THE JS ARE SET BUT BUT IS SET EQUAL TO 1 C ON SUBSEQUENT TIMES C I6=1 I7=0 100 IF(I6-NSUM) 105,105,104 C C JSUM2(I),I=1,NSUM CONTAINS CURRENT VALUE OF (2J+1) IN THE SAME C ORDER AS JSUM1 LIST. SET JSUM2 EQUAL TO LOWEST VALUE IN EACH C RANGE C 105 DO 68 J=I6,NSUM I1=JSUM8(J) IF(JSUM(1,I1)-M) 69,69,70 C C FIRST J DEFINING RANGE FIXED C 69 I2=JSUM(1,I1) I3=J1(I2) GO TO 71 C C FIRST J DEFINING RANGE VARIABLE C 70 I2=JSUM(1,I1)-M I3=JSUM2(I2) 71 IF(JSUM(2,I1)-M) 72,72,73 C C SECOND J DEFINING RANGE FIXED C 72 I2=JSUM(2,I1) I4=J1(I2) GO TO 74 C C SECOND J DEFINING RANGE VARIABLE C 73 I2=JSUM(2,I1)-M I4=JSUM2(I2) C C SET LOWER LIMIT OF RANGE IN JSUM2 C 74 JSUM2(I1)=IABS(I3-I4)+1 68 CONTINUE C C JSUM3(I),I=1,NSUM IS 1 IF J HAS ALTERED FROM ITS PREVIOUS VALUE C AND IS 0 IF IT IS STILL THE SAME C DO 77 I=I6,NSUM JSUM3(I)=1 77 CONTINUE IF(I7) 103,103,104 103 I7=1 C C JWTEST(I),I=1,JWRD IS 1 IF REQUIRED TO EVALUATE RACAH COEFFICIENT C AND IS 0 IF VALUE THE SAME AS BEFORE.JWTEST IS SET ZERO THE FIRST C TIME THROUGH AND LATER SET 1 IF NECESSARY C DO 78 I=1,JWRD JWTEST(I)=0 78 CONTINUE C C STOR1 WILL CONTAIN THE PRODUCT OF RACAH COEFFICIENTS TIMES C (2J+1) FACTORS C STOR WILL CONTAIN SUMS OF THE STOR1 C STOR1=ONE STOR=ZERO C C CHECK THE TRIANGULAR RELATION FOR ALL J VALUES IN JWORD LIST. IF C A SUMMATION VARIABLE THEN VALUE TAKEN FROM JSUM2 LIST C 104 DO 79 J=1,JWRD DO 80 I=1,6 IF(JWORD(I,J)-M) 81,81,82 81 I1=JWORD(I,J) IST(I) = J1(I1) - 1 GO TO 80 82 I1=JWORD(I,J)-M IST(I) = JSUM2(I1) - 1 80 CONTINUE IF(IST(1)+IST(2)-IST(5)) 83,84,84 84 IF(IABS(IST(1)-IST(2))-IST(5)) 85,85,83 85 IF(IST(3)+IST(4)-IST(5)) 83,86,86 86 IF(IABS(IST(3)-IST(4))-IST(5)) 87,87,83 87 IF(IST(1)+IST(3)-IST(6)) 83,88,88 90 IF(IABS(IST(2)-IST(4))-IST(6)) 79,79,83 89 IF(IST(2)+IST(4)-IST(6)) 83,90,90 88 IF(IABS(IST(1)-IST(3))-IST(6))89,89,83 79 CONTINUE GO TO 91 C C FAIL ONE OF THE TRIANGULAR RELATIONS. INCREASE THE J VALUES C 83 I2=NSUM 203 I1 = JSUM8(I2) C C INCREASE A SUMMATION J VALUE WHICH IS IN JSUM2 AND SET JSUM3 TO C SHOW VALUE CHANGED C JSUM2(I1)=JSUM2(I1)+2 JSUM3(I1)=1 C C NOW STORE J VALUE DEFINING RANGE OF THIS J IN I3 AND I4. C IF(JSUM(1,I1)-M) 92,92,93 92 I20 = JSUM(1,I1) I3 = J1(I20) GO TO 94 93 I20 = JSUM(1,I1)-M I3 = JSUM2(I20) 94 IF(JSUM(2,I1)-M)95,95,96 95 I20 = JSUM(2,I1) I4 = J1(I20) GO TO 97 96 I20 = JSUM(2,I1)-M I4 = JSUM2(I20) 97 I5=I3+I4-1 98 I6=I2+1 C C NOW TEST J VALUES AGAINST MAXIMUM IN RANGE. IF SATISFIED RETURN C TO SET REMAINING J VALUES WHICH DEPEND ON THIS J TO THEIR C LOWEST VALUES. IF NOT RETURN TO INCREASE PRECEDING J VALUE C IF(JSUM2(I1)-I5) 100,100,101 101 I2=I2-1 IF(I2) 102,102,203 C C NO MORE J VALUES TO SUM OVER. THE SUMMATION IS THEREFORE COMPLETE C MULTIPLY BY COMMON FACTOR AND EXIT C 102 RECUP=RECUP*STOR IF(NBUG3-1) 131,230,131 230 WRITE(IWRITE,169) RECUP,STOR,STOR1 131 RETURN C C SEE TRIANGULAR RELATIONS ARE SATISFIED. NOW PROCEED TO EVALUATE C RACAH COEFFICIENTS C FIRST DETERMINE WHICH RACAH COEFFICIENTS NEED RE-EVALUATING AND C SET JWTEST APPROPRIATELY C 91 DO 106 J=1,NSUM IF(JSUM3(J)) 106,106,107 107 I2=JSUM6(J) DO 108 I1=1,I2 I3=JSUM5(J,I1) JWTEST(I3)=1 108 CONTINUE 106 CONTINUE C C NOW EVALUATE ALL JWRD RACAH COEFFICIENTS WHICH HAVE NOT ALREADY C BEEN EVALUATED C DO 109 I=1,JWRD IF(JWTEST(I)) 109,109,110 110 DO 111 I1=1,6 IF(JWORD(I1,I)-M) 112,112,113 112 I2=JWORD(I1,I) IST(I1) = J1(I2) - 1 GO TO 111 113 I2=JWORD(I1,I)-M IST(I1) = JSUM2(I2) - 1 111 CONTINUE IF(NBUG3-1) 132,133,132 133 WRITE (IWRITE,170) (IST(J), J=1,6) 132 CALL DRACAH(IST(1),IST(2),IST(3),IST(4),IST(5),IST(6),X1) WSTOR(I)=X1 109 CONTINUE C C WSTOR(I),I=1,JWRD CONTAINS THE EVALUATED RACAH COEFFICIENTS C IF(NBUG3-1) 134,135,134 135 WRITE(IWRITE,190) (WSTOR(J),J=1,JWRD) C C SET JSUM3 AND JWTEST TO ZERO TO INDICATE THAT RACAH COEFFICIENTS C NEED NOT BE EVALUATED UNLESS J VALUE CHANGES C 134 DO 114 J=1,NSUM JSUM3(J)=0 114 CONTINUE DO 115 J=1,JWRD JWTEST(J)=0 115 CONTINUE C C FORM PRODUCT OF RACAH COEFFICIENTS,(2J+1) FACTORS AND (-1) C FACTORS IN STOR1 C DO 116 I=1,JWRD STOR1 = STOR1*WSTOR(I) 116 CONTINUE C C IASTOR CONTAINS THE POWER OF (-1)WHICH IS COMMON TO ALL TERMS C IX2 = IASTOR IF(J6CP) 117,117,118 118 DO 119 I=1,J6CP I1=J6P(I) STOR1 = STOR1*SQRT(DBLE(JSUM2(I1))) 119 CONTINUE 117 IF(J7CP) 120,120,121 121 DO 122 I=1,J7CP I1=J7P(I) IX2 = IX2 + JSUM2(I1) - 1 122 CONTINUE 120 IF(J8CP) 123,123,124 124 DO 125 I=1,J8CP I1=J8P(I) IX2 = IX2 - JSUM2(I1) + 1 125 CONTINUE 123 IX2 = IX2/2 C C ADD TERM INTO STOR AND RESET STOR1 TO 1 READY FOR NEXT TERM C IF (MOD(IX2,2) .EQ. 1) STOR1 = -STOR1 STOR = STOR + STOR1 STOR1=ONE GO TO 83 C C NO SUMMATIONS. CHECK THAT THERE ARE NO INCONSISTENCIES. THEN C MULTIPLY BY (-1) FACTOR AND EXIT C 12 IF(J6CP+J7CP+J8CP) 309,309,310 310 WRITE(IWRITE,311) CALL EXIT (0) 309 IX2 = IASTOR/2 IF (MOD(IX2,2) .EQ. 1) RECUP = -RECUP 186 RETURN END C*********************************************************************** INTEGER FUNCTION NTAB1(NELCTS,K) COMMON/INFORM/IREAD,IWRITE,IPUNCH C C THIS SUBROUTINE CALCULATES THE ROW OF NTAB CORRESPONDING TO THE C PARENTS WHICH MAY GIVE RISE TO THE TERM ASSOCIATED WITH SHELL C LAMBDA . E.G. IF WE SEEK THE ROW OF NTAB CONTAINING THE PARENTS C OF ONE OF THE P**3 TERMS, THE ROW = VALUE OF NTAB1 IS THAT C CONTAINING THE P**2 TERMS C C USE IS MADE OF THE FACT THAT THE LIST OF POSSIBLE PARENTS (SEE C WHITE - ATOMIC SPECTRA - APPENDIX) IS SYMMETRICAL ABOUT THE C CONFIGURATION L**(2L+1) C C C --- FOR ONE ELECTRON IN A TERM, THE PARENT IS ALWAYS A SINGLET S TERM C IF(NELCTS-1) 1,2,1 2 NTAB1=2 RETURN C C OTHERWISE THE VALUE OF NTAB1 DEPENDS ON THE L VALUE OF THE C ELECTRONS C 1 GO TO (3,4,5,6,14,25,26,27,28,29,30),K C C --- FOR S ELECTRONS, THE ONLY OTHER POSSIBILITY IS THAT NELCTS=2 C 3 NTAB1=1 RETURN C C --- P ELECTRONS - ARE WE BEYOND P**4 C 4 IF(NELCTS-4) 7,7,8 8 NELCTS=8-NELCTS 7 NTAB1=1+NELCTS RETURN C C --- D ELECTRONS - ARE WE BEYOND D**6 C 5 IF(NELCTS-6) 9,9,10 10 NELCTS=12-NELCTS 9 NTAB1=4+NELCTS RETURN C C --- F ELECTRONS - ARE THERE MORE THAN TWO. IF SO, THE PROGRAMME NEEDS C AN F-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINE, AND THE C ARRAYS IN /TERMS/ NEED EXTENDING C 6 IF(NELCTS-2) 2,11,12 11 NTAB1 = 11 RETURN C C C L?3 ELECTRONS SHOULD NOT BE MORE THAN TWO C C 25 IF(NELCTS-2)2,35,45 35 NTAB1=13 RETURN C 26 IF(NELCTS-2)2,36,45 36 NTAB1=14 RETURN C 27 IF(NELCTS-2)2,37,45 37 NTAB1=15 RETURN C 28 IF(NELCTS-2)2,38,45 38 NTAB1=16 RETURN C 29 IF(NELCTS-2)2,39,45 39 NTAB1=17 RETURN C 30 IF(NELCTS-2)2,40,45 40 NTAB1=18 RETURN 45 STOP ' ERROR IN FUNCTION NTAB1, .GT. 2 ELECTRONS!' C C --- G ELECTRONS - ARE THERE MORE THAN TWO. IF SO, THE PROGRAMME C NEEDS A G-SHELL COEFFICIENT-OF-FRACTIONAL-PARENTAGE ROUTINE, AND C THE ARRAYS IN /TERMS/ NEED EXTENDING C 14 IF(NELCTS-2) 2,15,16 15 NTAB1=12 RETURN 12 WRITE(IWRITE,13) 13 FORMAT(////' STOP AND EXTEND THE NTAB AND ITAB ARRAYS TO ALLOW 1MORE F-ELECTRONS/'/' YOU WILL ALSO REQUIRE A COMPLETE FRACTIONAL 2PARENTAGE ROUTINE FOR F-ELECTRONS'//) GO TO 17 16 WRITE(IWRITE,18) 18 FORMAT(////' STOP AND EXTEND THE NTAB AND ITAB ARRAYS TO ALLAW 1MORE G-ELECTRONS'/ ' YOU WILL ALSO REQUIRE A COMPLETE FRACTIONAL 2PARENTAGE ROUTINE FOR G-ELECTRONS'//) 17 STOP END C*********************************************************************** SUBROUTINE RECOV1(I,IDAT,ICURR) * * THIS ROUTINE IS CALLED ONLY IN THE CASE OF ARRAY OVERFLOW. * IF IPLACE=0 THE PROGRAM STOPS HERE, OTHERWISE THE PROGRAM RETURNS * TO THE CALLING ROUTINE AFTER SETTING IPLACE=I. * * I IS THE POSITION IN THE IDRAY AND IPRAY LISTS HOLDING * THE NAME OF THE RELEVANT DIMENSION PARAMETER AND * PREPROCESSOR PARAMETER. * IDAT IS THE ARRAY SIZE REQUIRED BY THE DATA * ICURR IS THE CURRENT ARRAY SIZE * IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' CHARACTER*6 IDRAY CHARACTER*3 IPRAY C PARAMETER(IDIM1=MZLR1,IDIM3=MZNR2,IDIM4=MZLMX,IDIM5=MZNPO, C * IDIM6=MZNIX,IDIM7=MZPTS,IDIM8=MZAMP,IDIM9=MZLAG,IDIM10=MZSHM, C * IDIM11=MZSLT,IDIM12=MZNR1,IDIM13=MZORB,IDIM14=MZFAC) C PARAMETER(ILDIM1=MZLR3,ILDIM3=MZLR4,ISDIM1=MZSET, C 1 ISDIM2=MZNCS,ITDIM1=MZTAR,ITDIM2=MZNSS,ITDIM3=MZCHF, C 2 ITDIM6=MZCHS,IPDIM1=MZSPN,ICDIM1=MZNCF,ICDIM2=MZORB, C 3 LBUFF1=MZBUF) C PARAMETER(IRDIM1=MZMEG*1000000+MZKIL*1000+1) COMMON /INFORM/ IREAD,IWRITE,IPUNCH COMMON /RECOV / IPLACE DIMENSION IDRAY(27),IPRAY(27) DATA IDRAY/'IDIM1','IDIM2','IDIM3','IDIM4','IDIM5','IDIM6', 1 'IDIM7','IDIM8','IDIM9','IDIM10','IDIM11','IDIM12', 2 'IDIM13','IDIM14','ILDIM1','ILDIM3','ISDIM1', 3 'ISDIM2','ITDIM1','ITDIM2','ITDIM3','ITDIM6', 4 'IPDIM1','ICDIM1','ICDIM2','IRDIM1','LBUFF1'/ DATA IPRAY/'LR1','LR2','NR2','LMX','NPO','NIX', 1 'PTS','AMP','LAG','SHM','SLT','NR1', 2 'ORB','FAC','LR3','LR4','SET', 3 'NCS','TAR','NSS','CHF','CHS', 4 'SPN','NCF','ORB','MEG','BUF'/ 1000 FORMAT(/' * ARRAY OVERFLOW *'/ 1 /1X,A6,' (MZ',A3,') SHOULD BE INCREASED FROM', 2 I7,' TO AT LEAST ',I7) * 1001 FORMAT(/' PROGRAM TERMINATES IN RECOV1'/) 1002 FORMAT(/' CHECK TO SEE IF OTHER ARRAYS ARE GOING TO BE EXCEEDED') WRITE(IWRITE,1000)IDRAY(I),IPRAY(I),ICURR,IDAT IF(IPLACE) 2,1,3 1 WRITE(IWRITE,1001) CALL EXIT (0) C 2 WRITE(IWRITE,1002) 3 IPLACE=I RETURN END C*********************************************************************** FUNCTION RME(L,LP,K) IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/DEBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/FACTS/ GAM(500) C C --- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP) - SEE FANO C AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81 C 200 FORMAT(//' L =',I3,' LP =',I3,' K =',I3,' RME SET ZERO SINCE 1ANGLE DOES NOT MATCH') 201 FORMAT(25X,29H PROGRAM STOPS IN RME IMAXF =,I3) IF(K.GT.(L+LP).OR.K.LT.IABS(L-LP)) GO TO 100 I2G=L+LP+K IG=I2G/2 IF(I2G-2*IG) 1,2,1 1 RME=ZERO RETURN 100 IF(NBUG1-1) 1,1,3 3 WRITE(IWRITE,200) L,LP,K GO TO 1 2 IF(IG) 100,13,12 13 RME=ONE RETURN 12 I1=IG-L I2=IG-LP I3=IG-K IMAX=MAX0(IG+1,I2G+2,2*I3+1,2*I2+1,2*I1+1) IF(IMAX.LE.500) GO TO 14 WRITE(IWRITE,201) IMAX STOP 14 CONTINUE AL1=GAM(I1+1) AL2=GAM(2*I1+1) ALP1=GAM(I2+1) ALP2=GAM(2*I2+1) AK1=GAM(I3+1) AK2=GAM(2*I3+1) EL1=2*L+1 ELP1=2*LP+1 QUSQRT=LOG(EL1)+LOG(ELP1)+AL2+ALP2+AK2-GAM(I2G+2) RME=EXP(HALF*QUSQRT+GAM(IG+1)-AL1-ALP1-AK1) RETURN END C*********************************************************************** C SUBROUTINE TENSOR(KA,ISPIN,IRHO,ISIG,VSHELL) IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C C W. D. ROBB - NOVEMBER 1971 C C ********************************************************************** C C A ROUTINE FOR THE EVALUATION OF ANGULAR AND SPIN FACTORS IN THE C REDUCED MATRIX ELEMENT OF ANY ONE-ELECTRON TENSOR OPERATOR BETWEEN C ARBITRARILY COUPLED L-S CONFIGURATIONS C C*********************************************************************** C C ** NOTE THAT THE DEFINITIONS OF TENSOR OPERATORS USED ARE THOSE C OF FANO AND RACAH, IRREDUCIBLE TENSORIAL SETS, ACADEMIC PRESS 1959 C C*********************************************************************** C C DIMENSION STATEMENTS C PARAMETER (KFL2=19,KFL3=20,KFL4=100,KFL5=200,KFL7=100) PARAMETER(ICDIM2=MZORB) PARAMETER(ICDIM3=ICDIM2+ICDIM2-1,ICDIM4=ICDIM2+1) DIMENSION L6(KFL4),L7(KFL5),L8(KFL4),LW(6,KFL3),J2STO(ICDIM4,3), 1 J3STO(ICDIM4,3),JMEM(18),VSHELL(ICDIM2) C C COMMON BLOCKS C COMMON/COUPLE/MN1,M0,J1(KFL7),J2(KFL2,3),J3(KFL2,3) COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/MEDEFN/IHSH,NJ(ICDIM2),LJ(ICDIM2),NOSH1(ICDIM2), 1 NOSH2(ICDIM2),J1QN1(ICDIM3,3),J1QN2(ICDIM3,3) COMMON/DEBUG/NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/TERMS/ NROWS,ITAB(18),JTAB(18),NTAB(189) C 203 FORMAT(//7H NJ,LJ ,(I6,I3)) 204 FORMAT(//6H NOSH ,10I4) 205 FORMAT(//6H J1QN ,30I3) 207 FORMAT(8F15.8) 208 FORMAT(// 23H PARENT TERMS NOT FOUND//) 209 FORMAT(//3H J1) 210 FORMAT(24I5) 211 FORMAT(24H J2 J3) 212 FORMAT(3I5,I10,2I5) 213 FORMAT(///26H ORBITAL RECOUPLING COEFF=,E20.8) 214 FORMAT(///23H SPIN RECOUPLING COEFF=,E20.8//) 215 FORMAT(/28H THE CONTRIBUTION FROM SHELL,I2,3H IS,F15.8) 216 FORMAT(//21H THIS IS NOT A PARENT) 217 FORMAT(///8H VSHELL=,8F15.8) 218 FORMAT(//24H FRACTIONAL PARENT TERMS,I2) 219 FORMAT(//49H THE CONTRIBUTION FROM FRACTIONAL PARENTAGE TERMS,I2, 1 3H IS,F15.8) 220 FORMAT(//6H SHELL,I2) C AJF=1.0D0 RML = 0.0D0 RPL = 0.0D0 NTOT=0 DO 100 IS=1,IHSH VSHELL(IS)=0.0D0 100 CONTINUE IHSHP1=IHSH+1 I2HSH=IHSH*2-1 C C PRINT OUT THE OCCUPATION AND COUPLING ARRAYS C IF(NBUG6-1) 101,2,101 2 WRITE(IWRITE,203) (NJ(I),LJ(I),I=1,IHSH) WRITE(IWRITE,204)(NOSH1(J),J=1,IHSH) WRITE(IWRITE,204)(NOSH2(J),J=1,IHSH) WRITE(IWRITE,205) ((J1QN1(J,K),K=1,3),J=1,I2HSH) WRITE(IWRITE,205) ((J1QN2(J,K),K=1,3),J=1,I2HSH) C C TEST FOR AT MOST ONE ELECTRON DIFFERENCE IN CONFIGURATIONS C 101 NOSHUM=0 DO 102 K=1,IHSH NOSHUM=NOSHUM+IABS(NOSH1(K)-NOSH2(K)) 102 CONTINUE IF(NOSHUM-2) 103,103,183 C C TEST FOR TRIANGLE RELATION BETWEEN KA AND TOTAL ANGULAR MOMENTA C 103 IF(ISPIN.EQ.0) GO TO 198 K=3 IF(J1QN1(I2HSH,2).NE.J1QN2(I2HSH,2)) GO TO 183 GO TO 199 198 K=2 IF(J1QN1(I2HSH,3).NE.J1QN2(I2HSH,3)) GO TO 183 199 LB=J1QN1(I2HSH,K)-1 NB=J1QN2(I2HSH,K)-1 MB=KA+KA BTST=TRITST(MB,LB,NB) IF(BTST) 183,104,183 C C DETERMINE IRHO AND ISIGMA, THE NUMBERS OF THE OCCUPIED SHELLS C 104 IRHO=0 ISIG=0 DO 105 J=1,IHSH NX=NOSH1(J)-NOSH2(J)+2 GO TO (107,105,106),NX 107 ISIG=J GO TO 105 106 IRHO=J 105 CONTINUE IF(IRHO.NE.0 ) GO TO 108 IRHO=1 ISIG=1 108 CONTINUE C 108 MEMR = IRHO C C THE BEGINNING OF THE LOOP OVER ALL SHELLS C 109 IF(IRHO.NE.ISIG) GO TO 309 IF(NBUG6-1) 309,4,309 4 WRITE(IWRITE,220) IRHO 309 NTOT=NTOT+1 L1=LJ(IRHO)+1 L2=LJ(ISIG)+1 AJF=DBLE(J1QN1(I2HSH,2))/DBLE(2*LJ(IRHO)+1) IF(ISPIN.NE.0) AJF=DBLE(J1QN1(I2HSH,3))*0.5D0 IF(IRHO-ISIG) 120,111,120 C C FIND THE PARENT TERMS GIVEN BY ALLOWED J VALUES IN NTAB WITH IRHO C 111 NELCTS=NOSH1(IRHO) K1=NTAB1(NELCTS,L1) KK1=ITAB(K1) DO 112 JJ1=1,KK1 IJK1=3*(JJ1-1)+JTAB(K1) DO 113 K=2,3 IJKK=IJK1+K IF(K.EQ.3) GO TO 114 LA=NTAB(IJKK) MA=2*LJ(IRHO)+1 NA=J1QN1(IRHO,K) GO TO 115 114 LA=NTAB(IJKK)-1 MA=1 NA=J1QN1(IRHO,K)-1 115 ATST=TRITST(LA,MA,NA) IF(ATST) 116,117,116 117 IF(K-3) 113,118,113 116 JMEM(JJ1)=0 GO TO 112 118 JMEM(JJ1)=1 113 CONTINUE 112 CONTINUE C C PARENTAGE CHECK C 120 IF(IRHO-ISIG) 121,127,121 121 NELCTS=NOSH1(IRHO) K1=NTAB1(NELCTS,L1) NELCTS=NOSH2(ISIG) K2=NTAB1(NELCTS,L2) KK1=ITAB(K1) KK2=ITAB(K2) DO 122 JJ1=1,KK1 IJK1=3*(JJ1-1)+JTAB(K1) DO 123 K=2,3 IJKK=IJK1+K MSAM1=NTAB(IJKK)-J1QN2(IRHO,K) IF(MSAM1.NE.0) GO TO 122 IF(K.EQ.3) GO TO 124 123 CONTINUE 122 CONTINUE IF(NBUG6-1) 192,7,192 7 WRITE(IWRITE,208) GO TO 192 124 DO 125 JJ2=1,KK2 IJK2=3*(JJ2-1)+JTAB(K2) DO 126 K=2,3 IJKK=IJK2+K MSAM2=NTAB(IJKK)-J1QN1(ISIG,K) IF(MSAM2.NE.0) GO TO 125 IF(K.EQ.3) GO TO 127 126 CONTINUE 125 CONTINUE IF(NBUG6-1) 192,8,192 8 WRITE(IWRITE,208) GO TO 192 C C SET J2 AND J3 . SAME FOR L AND S C 127 M1=IHSH-2 M2=2*M1+1 M3=3*IHSH-1 M4=M3+1 M5=M3+2 M10=M5+1 MN1=M10+1 J2(1,1)=M10 J2(1,2)=MN1 J2(1,3)=M5 J2(2,1)=IRHO J2(2,2)=M5 J2(2,3)=M3 J3(1,1)=ISIG J3(1,2)=M10 J3(1,3)=M4 IF(IRHO-1) 128,129,128 129 J2(3,1)=M3 GO TO 130 128 J2(3,1)=1 130 IF(IRHO-2) 131,132,131 132 J2(3,2)=M3 GO TO 133 131 J2(3,2)=2 133 J2(3,3)=IHSHP1 IF(ISIG-1) 134,135,134 135 J3(2,1)=M4 GO TO 136 134 J3(2,1) = 1 136 IF(ISIG-2) 137,138,137 138 J3(2,2)=M4 GO TO 139 137 J3(2,2)=2 139 J3(2,3)=2*IHSH IF(IHSH-3) 149,140,140 140 DO 148 J=4,IHSHP1 L=J-1 J2(J,1)=M1+L J2(J,3)=M1+J J3(L,1)=M2+L J3(L,3)=M2+J 141 IF(IRHO-L) 142,143,142 143 J2(J,2)=M3 GO TO 144 142 J2(J,2)=L 144 IF(ISIG-L) 145,146,145 146 J3(L,2)=M4 GO TO 148 145 J3(L,2)=L 148 CONTINUE 149 M6=IHSHP1 J3(M6,1)=M3-1 J3(M6,2)=MN1 J3(M6,3)=I2HSH IF(IHSH-1) 450,451,450 451 J3(M6,1) = M4 J3(M6,3) = M3 450 DO 150 J=1,IHSHP1 DO 151 K=1,3 J2STO(J,K)=J2(J,K) J3STO(J,K)=J3(J,K) 151 CONTINUE 150 CONTINUE C C RECOUPLING COEFFICIENTS C JMEM1=J1QN1(IRHO,1) JMEM2=J1QN1(IRHO,2) JMEM3=J1QN1(IRHO,3) JMEM4=J1QN2(ISIG,1) JMEM5=J1QN2(ISIG,2) JMEM6=J1QN2(ISIG,3) IF(IRHO-ISIG) 154,152,154 C C BEGINNING OF LOOP OVER ALL PARENT TERMS C 152 JJ1=1 1152 IF(NBUG6-1) 12,11,12 11 WRITE(IWRITE,218) JJ1 12 IF(JMEM(JJ1).EQ.1) GO TO 153 IF(NBUG6-1) 186,16,186 16 WRITE(IWRITE,216) GO TO 186 153 IJK1=3*(JJ1-1)+JTAB(K1) NI1=NTAB(IJK1+1) NI2=NTAB(IJK1+2) NI3=NTAB(IJK1+3) J1QN2(IRHO,1)=NI1 J1QN1(ISIG,1)=NI1 J1QN2(IRHO,2)=NI2 J1QN1(ISIG,2)=NI2 J1QN2(IRHO,3)=NI3 J1QN1(ISIG,3)=NI3 154 K=2 M7=M3-IHSH M9=M7+1 M11=M3-1 M12=IHSH-1 RECUPS=1.0D0 M0=M6+1 C C SET UP THE J1 ARRAY FOR THE ANGULAR AND SPIN RECOUPLING C COEFFICIENTS C 155 DO 2155 J=1,IHSH IF(J.EQ.IRHO.OR.J.EQ.ISIG) GOTO 2155 DO 2150 KK=1,3 IF(J1QN1(J,KK).NE.J1QN2(J,KK)) GOTO 1183 2150 CONTINUE 2155 CONTINUE GOTO 1155 1183 RECUPS=0.0D0 IF(IRHO.NE.ISIG) GOTO 183 GOTO 185 1155 IF(K-3) 156,157,156 156 J1(M5)=2*LJ(IRHO)+1 J1(M10)=2*LJ(ISIG)+1 J1(MN1)=2*KA+1 IF(ISPIN.NE.0) J1(MN1)=1 J1(M3)=JMEM2 J1(M4)=JMEM5 IF(IRHO.EQ.ISIG) GO TO 158 J1(M3)=J1QN1(IRHO,K) J1(M4)=J1QN2(ISIG,K) GO TO 158 157 J1(M5)=2 J1(M10)=2 J1(MN1)=1 IF(ISPIN.NE.0) J1(MN1)=2*KA+1 J1(M3)=JMEM3 J1(M4)=JMEM6 IF(IRHO.EQ.ISIG) GO TO 158 J1(M3)=J1QN1(IRHO,K) J1(M4)=J1QN2(ISIG,K) 158 DO 161 J=1,IHSH IF(IRHO-J) 160,159,160 159 J1(J)=J1QN2(IRHO,K ) GO TO 161 160 J1(J)=J1QN1(J,K) 161 CONTINUE IF(IHSH.EQ.1) GO TO 197 DO 162 J=M6,M7 J1(J)=J1QN1(J,K) 162 CONTINUE DO 163 J=M9,M11 JM12=J-M12 J1(J)=J1QN2(JM12,K) 163 CONTINUE C C PRINT OUT THE J1,J2 AND J3 ARRAYS C 197 IF(NBUG6-1) 304,9,304 9 IF(K-3) 165,164,164 165 IF(NBUG6-1) 304,17,304 17 WRITE(IWRITE,209) WRITE(IWRITE,210) (J1(J),J=1,MN1) WRITE(IWRITE,211) DO 166 I=1,IHSHP1 WRITE(IWRITE,212) (J2(I,J),J=1,3),(J3(I,J),J=1,3) 166 CONTINUE 304 CONTINUE C C EVALUATE ORBITAL AND SPIN RECOUPLING COEFFICIENTS C 164 CALL NJSYM(J6C,J7C,J8C,JWC,L6,L7,L8,LW,RECUP) RECUPS=RECUPS*RECUP IF(K-3) 167,170,170 167 IF(NBUG6-1) 305,18,305 18 WRITE(IWRITE,213) RECUP 305 CONTINUE 170 K=K+1 DO 168 J=1,IHSHP1 DO 169 KK=1,3 J2(J,KK)=J2STO(J,KK) J3(J,KK)=J3STO(J,KK) 169 CONTINUE 168 CONTINUE IF(K.EQ.3) GO TO 155 IF(NBUG6-1) 306,19,306 19 WRITE(IWRITE,214) RECUP C C FIRST FRACTIONAL PARENTAGE COEFFICIENT C 306 LIJ=LJ(IRHO) COEFP=1.0D0 IF(LIJ) 171,272,171 171 N=NOSH1(IRHO) IV1=JMEM1 IL1=(JMEM2-1)/2 IS1= JMEM3 IV2=J1QN2(IRHO,1) IL2=(J1QN2(IRHO,2)-1 )/2 IS2=J1QN2(IRHO,3) CALL CFP(LIJ,N,IV1,IL1,IS1,IV2,IL2,IS2,COEFP) RECUPS=RECUPS*COEFP 272 IF(IRHO-ISIG) 172,173,172 172 IF(ABS(RECUPS).LT.1.0E-5)GO TO 183 C C SECOND FRACTIONAL PARENTAGE COEFFICIENT C 173 LIJ=LJ(ISIG) COEFP=1.0D0 IF(LIJ) 176,176,174 174 N=NOSH2(ISIG) IV1=JMEM4 IL1=(JMEM5-1)/2 IS1=JMEM6 IV2=J1QN1(ISIG,1) IL2=(J1QN1(ISIG,2)-1)/2 IS2=J1QN1(ISIG,3) CALL CFP(LIJ,N,IV1,IL1,IS1,IV2,IL2,IS2,COEFP) 176 RECUPS=RECUPS*COEFP IF(ABS(RECUPS).LT.1.0E-8.AND.IRHO.NE.ISIG)GO TO 183 C C PERMUTATION FACTOR C 175 IDELP=2 IF(IRHO-ISIG) 177,181,179 177 JRHO = IRHO+1 DO 178 J=JRHO,ISIG 178 IDELP=IDELP+NOSH1(J) GO TO 181 179 JSIG = ISIG+1 DO 180 J=JSIG,IRHO 180 IDELP = IDELP+NOSH2(J) 181 MINUS=(-1)**IDELP C C MULTIPLICATIVE FACTOR C IF(IRHO-ISIG) 182,185,182 182 SQRN=SQRT(DBLE(NOSH1(IRHO)*NOSH2(ISIG))) VALML=SQRN*RECUPS*DBLE(MINUS) GO TO 184 183 VALML = 0.0D0 184 RML = RML+VALML C RESULT STORED IN VSHELL IF(NTOT.EQ.0) NTOT=1 VSHELL(NTOT)=RML*SQRT(AJF) GO TO 190 185 VALUML=RECUPS IF(NBUG6.NE.0) WRITE(IWRITE,219) JJ1,VALUML RPL = RPL+VALUML 186 IF(IRHO.NE.ISIG)GO TO 1186 JJ1=JJ1+1 IF(JJ1.LE.KK1)GO TO 1152 1186 J1QN1(IRHO,1)=JMEM1 J1QN1(IRHO,2)=JMEM2 J1QN1(IRHO,3)=JMEM3 J1QN2(ISIG,1)=JMEM4 J1QN2(ISIG,2)=JMEM5 J1QN2(ISIG,3)=JMEM6 ANL=DBLE(NOSH1(IRHO))*RPL C C RESULTS STORED IN VSHELL C IF(NTOT.EQ.0) NTOT=1 VSHELL(NTOT)=ANL*SQRT(AJF) 194 IF(NBUG6-1) 189,196,189 196 WRITE(IWRITE,215) IRHO,ANL 189 IRHO=IRHO+1 ISIG=ISIG+1 RPL=0.0D0 IF(IRHO-IHSH) 109,109,190 190 IF(NBUG6-1) 192,13,192 13 WRITE(IWRITE,217) (VSHELL(N),N=1,NTOT) 192 RETURN END C*********************************************************************** FUNCTION TRITST(L,M,N) IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'PARAM' C C IF TRITST=1.0 THE TRIANGLE RELATION IS NOT SATISFIED C IF TRITST=0.0 THE TRIANGLE RELATION IS SATISFIED C LMN=IABS(L-M) LM=L+M IF(N-LMN) 1,2,2 2 IF(LM-N) 1,3,3 3 TRITST=0.0D0 RETURN 1 TRITST=1.0D0 RETURN END C***********************************************************************