C RSTG2HALF -LAST UPDATE '88JULY KAB; - '90MAR/APR/JUL WE, '95OCT+ZHL C RUB'95NOV15-6: CAN PROCESS BP TYPE STG2-FILES. LATEST'99MAR16TH C*********************************************************************** C C A NEW NEW VERSION OF C C THE THIRD PART OF C C A GENERAL PROGRAM TO CALCULATE ATOMIC CONTINUUM PROCESSES C C USING THE R-MATRIX METHOD IN BREIT-PAULI APPROXIMATION C C R M A T R X S T G 3 C C BY C C K.A.BERRINGTON, P.G.BURKE, M.LE DOURNEUF, W.D.ROBB, C C K.T.TAYLOR AND VO KY LAN C C*********************************************************************** C C DIAGONALIZES THE HAMILTONIANS AND PROCESSES DIPOLE MATRIX C ELEMENTS USING AS INPUT THE H (AND PERHAPS THE D) FILES C CREATED IN PART RSTG2 OR (RSTG2+RECUPD) OF THE CODE C NEW'91APR: FILES DXY OF DATASET D=D00++D01++... NO LONGER CONCATENATED C C*********************************************************************** C C ROUTINES USED IN RMATRX RSTGH C C*********************************************************************** C C STG3 DIRECTING ROUTINE C BLOCK DATA C DMAT C RECOV1 C RSCT C STG3RD C TAPERD C WRITAP C VMUL C ORDER C FROM STGLIB: C BAKSUB C EIGEN C EIGVEC C HOUSE C HSLDR C NORM C VECTOR C C*********************************************************************** C C COMMON BLOCKS OCCURRING IN RMATRX STGH C C*********************************************************************** C C ROUTINES IN WHICH THEY ARE USED C C BASIC DMAT,RSCT,STG3RD,TAPERD,WRITAP C BASIN RSCT,TAPERD C CASES STG3,DMAT,RSCT,STG3RD,TAPERD,WRITAP C CROSEC RSCT,TAPERD,WRITAP C CUPINT STG3,RSCT,TAPERD,WRITAP C DISTAP STG3,DMAT,RSCT,STG3RD,TAPERD,WRITAP C INFORM STG3,DMAT,RECOV1,RSCT,STG3RD,TAPERD CC MATRIX = // DMAT,RSCT,TAPERD C NBUG STG3,DMAT,RSCT,STG3RD,TAPERD C RADIAL TAPERD,WRITAP C RCASES STG3,DMAT,RSCT,STG3RD,TAPERD,WRITAP C RECORD STG3,DMAT,RSCT C RECOV STG3,BLOCKDATA,DMAT,RECOV1,RSCT,STG3RD,TAPERD CC SPACES DMAT,RSCT C TARGET STG3RD,TAPERD,WRITAP C C*********************************************************************** C C INPUT/OUTPUT CHANNELS USED IN RMATRX STGH C C*********************************************************************** C C IREAD CARD READER - SET IN THE DIRECTING ROUTINE C IWRITE OUTPUT TO LINE PRINTER C IDISC1 TEMPORARY STORE FOR BOUND ORBITALS AND THE H-MATRIX C IDISC2 TEMPORARY DIRECT ACCESS STORE OF H EIGENVECTORS C IDISC3 TEMPORARY DIRECT ACCESS STORE OF PARTIALLY C PROCESSED DIPOLE MATRIX ELEMENTS C ITAPE1 PERMANENT STORE OF RMATRX STG2 DIPOLE MATRICES(INPUT) C ITAPE2 PERMANENT STORE OF RMATRX STG2 H-MATRICES (INPUT), C ITAPE3 PERMANENT STORE OF STG3 DIAGONALIZED H-MATRIX(OUTPUT) C ITAPE4 PERMANENT STORE OF PROCESSED DIPOLE M. E. S(OUTPUT). C C*********************************************************************** C C STGH DIRECTING ROUTINE C C*********************************************************************** C LOGICAL NBUG10 COMMON/CASES/ MORE,MSKIP,IPOLPH,ICODE,INAST, LRECW2,LRECW3,LWORD COMMON/CUPINT/MNP1,NCONHP,NCHAN, LAMAX,LAM COMMON/DISTAP/IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2,ITAPE3,ITAPE4 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 CC COMMON/RCASES/WENRGY(3,10),NENRGS, c * following inconsistent common statement is corrected below it. snn,Dec09 c * /RCASES/NOT1,NOT2,NOT3,NCFGP COMMON/RCASES/NOT1,NOT2,NOT3,NCFGP c * end of correction CC * ,NPROG,NUMS,MEN,NOMB,IXGA,IDIAG,KSTORE,ISTATE,ICHAN,IEST,IENS,KT COMMON/RECORD/ IREC1,IREC2,IREC3,ILSPI(4, 40),IORDER( 500, 40) COMMON/RECOV/ IPLACE,IDMTST(30) C 1000 FORMAT(/1X,71(1H*)) 1001 FORMAT(//' REPEAT STGH WITH NEW DATA') 1002 FORMAT(//' READ NEW DATA DEFINING A FINAL STATE FOR A PHOTOIONISAT *ION'/39X,'OR POLARIZABILITY CALCULATION') 1003 FORMAT(/55X,11HEND OF STGH/55X,11(1H-)) 1004 FORMAT(/' SYMMETRY NUMBER',I4,' COMPLETE.') 1005 FORMAT(/' **ERROR** H SCRATCH FILE (IDISC2=',I2,') REQUIRES RECORD *S',I7,' WORDS LONG'/11X,'WHEREAS LRECW2 =',I7,' ONLY; EVASIVE ACTI *ON TAKEN.') 1006 FORMAT(/S' SUMMARY ON RECORD LENGTH REQUIREMENTS FOR SCRATCH DISK *S 2 (H) AND 3 (D):'/9X,'ALLOCATED',I7,' AND',I7,' WORDS OF LENGTH' *,I3,' BYTES/WORD,'/14X,'USED',I7,' AND',I7,' WORDS.') C C SET UP DIMENSION TEST INDICES AND COUNTERS: C C CALL SETDIM -- MERGED INTO BLOCK DATA - WE'90MAR19 C KT=KSTORE=0 -- NOT USED c c open files c open(5,file='stgh.inp',status='old') open(6,file='stgh.out',status='unknown') c open(2,file='s2ham',status='old',form='unformatted') c open(1,file='s2dip',status='old',form='unformatted') open(2,file='srham',status='old',form='unformatted') open(1,file='srdip',status='old',form='unformatted') open(3,file='H.DAT',status='unknown',form='unformatted') open(8,file='ft8',status='unknown',form='unformatted') c MSKIP=1 IREAD=5 NSYM=0 C C INITIALISE DIRECT ACCESS RECORD POSITIONS C C IREC1 = / -- SEQUENTIAL FILE IREC2 = 1 C IREC3 = 1 - MUST BE SET IN DMAT; AUXILIARY SIZE VARIABLE FOR OPEN: MXNCFG = 0 MXREC2 = 0 C C READ THE DATA SPECIFYING THE CASE C 1 CALL STG3RD NBUG10 = NBUG5.NE.0.OR.NBUG6.NE.0.OR.NBUG7.NE.0.OR.NBUG8.NE.0 IF(NBUG10 .AND. INAST.NE.0) WRITE(IWRITE,1000) C C READ THE BASIC DATA AND THE HAMILTONIAN MATRIX FROM THE C TAPE PRODUCED BY STG2 (NB: ON RETURN NOT2=MIN(NOT2,NRANG2)) C IF(IPLACE.NE.0) GO TO 10 3 CALL TAPERD IF(IPLACE.NE.0) GO TO 9 CALL WRITAP IF(NBUG7.EQ.3) WRITE(IWRITE,1000) C C OPEN FILES IDISC2=9, IDISC3=10 -- SEE COMMENTS IN STG3RD! IF(IPOLPH.LT.2) GO TO 6 IF(NSYM.NE.0) GO TO 5 LREC=NOT2*IDMTST(6) IF(LRECW2.GT.0) LREC = LRECW2 IF(LRECW3.GT.0 .AND. LRECW2.EQ.0) LREC = MIN(LRECW3,LREC) OPEN(UNIT=9,ACCESS='DIRECT',STATUS='SCRATCH',FORM='UNFORMATTED', * RECL=LREC*LWORD) LRECW2 = LREC 5 IF(LRECW3.NE.0) GO TO 6 MXREC2 = MAX(NOT2*NOT3,MXREC2) IF(MXREC2.LE.LRECW2) GO TO 6 WRITE(IWRITE,1005) IDISC2, MXREC2,LRECW2 IF(NSYM-1) 10,12,11 C C---- DIAGONALISE THE HAMILTONIAN (NB: RSCT RETURNS NOT1=MIN(=,NRANG2)) C 6 CALL RSCT MXNCFG=MAX(NCFGP,MXNCFG) NSYM=NSYM+1 WRITE(IWRITE,1004) NSYM IF(NBUG10) WRITE(IWRITE,1000) C C IF MORE.GT.0 THERE IS MORE DATA, INCREASE MSKIP BY 1, C IF MORE=0 THERE IS NO MORE DATA. C 9 IF(MORE.EQ.0) GO TO 11 IF(NBUG10) THEN IF(IPOLPH.LE.1) WRITE(IWRITE,1001) IF(IPOLPH.GE.2) WRITE(IWRITE,1002) ENDIF MSKIP=MSKIP+1 GO TO 1 C C---- PROCESS THE DIPOLE MATRIX ELEMENTS IF IPOLPH GE 2 11 IF(IPOLPH.LT.2) GO TO 12 IF(LAM.EQ.1) WRITE(6,'(/15X,20HTROUBLE AHEAD: LAM=1,2X,3(3H=!=))') C OUT LREC=2*NOT2*IDMTST(13)+1 -- IBM3090 FIX WE'90MAR17/APR10: LREC=MAX(NOT1,MXNCFG)*NOT1*2+1 MXREC3 = LREC IF(LRECW3.GT.0) LREC=MIN(LRECW3,LREC) OPEN(UNIT=10,ACCESS='DIRECT',STATUS='SCRATCH',FORM='UNFORMATTED', * RECL=LREC*LWORD) LTEMP = LRECW3 LRECW3 = LREC INAST = NSYM CALL DMAT IF(LTEMP.EQ.0) WRITE(IWRITE,1006)LRECW2,LRECW3,LWORD,MXREC2,MXREC3 12 WRITE(IWRITE,1003) 10 STOP END BLOCK DATAH c BLOCK DATA -- stgt'00Feb15; C COMMON/RECOV/ IPLACE,IDMTST(30) C C THIS SECTION SETS THE IDMTST ARRAY. THE ELEMENTS OF THIS ARRAY C CONTAIN THE ARRAY SIZES IN THE PROGRAM AND ARE USED TO TEST C DIMENSION OVERFLOW. THEY ARE SET ON PRE-PROCESSING. C C ONLY THOSE ARRAYS WHICH APPEAR IN STGH ARE SPECIFIED HERE; C N.B.: NUMBER IMPLIES MAXIMUM. C C IDMTST(5) = NUMBER OF CHANNELS, AFFECTING /CROSEC/, MATRIX=//: DATA IDMTST(5)/ 500/, C C IDMTST(6) = ORDER OF THE HAMILTONIAN MATRIX, AFFECTING COMMON C BLOCKS MATRIX=//, SAVE1, SAVE2, SAVE3. NOTE THAT THE LENGTH OF C HNP1 IN /MATRIX/ IS DEFINED BY IDMTST(6)*(IDMTST(6)+1)/2, AND C H IN /MATRIX/ IN RSCT BY IDMTST(7)*(2*IDMTST(6)-IDMTST(7)+1)/2 * IDMTST(6)/18000/, C C IDMTST(7) = NUMBER OF BASIS FUNCTIONS FOR EACH ANGULAR L C IN /BASIN/. ALSO SEE COMMENTS FOR IDMTST 6 AND 13: * IDMTST(7)/ 60/, C C IDMTST(13) = SIZE OF THE ARRAY STORE IN /MATRIX/=// IN ROUTINE C TAPERD, WHICH IS DEFINED BY THE LARGER OF IDMTST(13) AND C IDMTST(7) AND IS THE MAXIMUM NUMBER OF (N+1)-ELECTRN BOUND TERMS: * IDMTST(13)/4000/, C C IDMTST(14) SPECIFIES THE LENGTH OF ARRAYS AS LONG AS THE C NUMBER OF ATOMIC STATES IN /CROSEC/ AND /TARGET/ AND IN C IN DIMENSION STATEMENTS: * IDMTST(14)/ 200/, C C IDMTST(15) = NUMBER OF CONTINUUM AND TARGET ANGULAR MOMENTA, C AFFECTING ARRAYS IN /BASIN/ AND /RADIAL/: * IDMTST(15)/ 61/, C C IDMTST(18) CONTAINS THE ARRAY PARAMETER DEFINING THE NUMBER C OF MULTIPOLES IN THE POTENTIAL IN /CROSEC/ * IDMTST(18)/ 8/, C C IDMTST(29) = NUMBER OF (N+1) ELECTRON SYMMETRIES (J PI) * IDMTST(29)/ 40/ C END C*********************************************************************** SUBROUTINE DMAT C*********************************************************************** C C WRITES 'D FILE' FOR INTERMEDIATE COUPLING ONTO TAPE4, C===> ACCEPTING SPANNED DIRECT ACCESS DATA ON DISC2 (AND DISC3) C !!!!!!! -- WE'90EASTER. C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER FILNAM*3,NUM(0:9)*1 C LOGICAL SKIP(99) PARAMETER(L30=99, C AS FILES DXX CARRY ONLY 2 DIGITS XX * L62L63=((18000+1)*18000)/2, L90L91=((2*18000- 60+1)* 60)/2) C PARAMETER(LDMT= 500*1800*3+(1800+ 60)*4000*2 + 500* 500*2, C * LSCT=L62L63+L90L91, LTRD= 60*4000+L62L63) C PARAMETER(IKAB=LSCT/LTRD,JKAB=LTRD/LSCT,LKAB=LSCT/LTRD+LTRD/LSCT) C PARAMETER(LTMP=LSCT*IKAB/LKAB+LTRD*JKAB/LKAB) C PARAMETER(IKB=LTMP/LDMT,JKB=LDMT/LTMP,KAB=LTMP/LDMT+LDMT/LTMP) C PARAMETER(LDUM=LTMP*IKB/KAB+LDMT*JKB/KAB - LDMT+ 500* 500) C THUS PADDING // IF LONGER IN ROUTINES RSCT OR TAPERD. C DIMENSION IPRE(4000), CGC( 61), IMEM(2,L30), XX( 60,18000), * AC( 500, 500),BLC( 500, 500),BVC( 500, 500), CBUTV( 500, 500) EQUIVALENCE (BLC(1,1),CBUTL(1,1)), * (BVC(1,1),CBUTV(1,1) ),(AC(1,1),CGC(1),XX(1,1)) C * ,DUMY(1) C COMMON // DML(1800,4000), DMV(1800,4000), DIMENSION DML(18000,4000), DMV(18000,4000), * DKL( 60,4000), DKV( 60,4000), * ABUTL(18000, 500),ABUTV(18000, 500), * BBUTL(18000, 500),BBUTV(18000, 500), + CBUTL( 500, 500) C * , DUMY(LDUM) COMMON/BASIC/ BSTO,RA,LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CASES/ MORE,MSKIP,IPOLPH,ICODE,INAST, LRECW2,LRECW3,LWORD COMMON/DISTAP/IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2,ITAPE3,ITAPE4 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 c * following common statement contains NCFGX instead of NCFGP used in others COMMON/RCASES/NOT1,NOT2,NOT3,NCFGX c COMMON/RCASES/NOT1,NOT2,NOT3,NCFGP c * end of correction COMMON/RECOV/ IPLACE,IDMTST(30) COMMON/RECORD/ IREC1,IREC2,IREC3,ILSPI(4, 40),IORDER( 500, 40) C COMMON/SPACES/ XX( 60,1800) C ASSUMING XX TO BE BIGGER THAN THE EQUIVALENCED ARRAYS. C 1000 FORMAT(//21X,51(1H*)//21X,51H**** DEBUGGING PRINT **** FROM SUBROU *TINE DMAT ****//21X,51(1H*)) 1002 FORMAT(/' DMAT HAS NOT ENCOUNTERED ANY PERMITTED TRANSITION!') 1004 FORMAT(I5,(T6,5E15.7)) DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ C C FUNCTIONS PROVIDING FOR SPANNED DIRECT ACCESS RECORDS (ON IBM): KSTEP(LL) = (LL*NOTERM-1)/LRECW2+1 KINIT(LL) = ((LL*NOTERM-1)/LRECW2+1) * ((LL-1)/NOTERM) C RECORDS/BLOCK * BLOCKS/EIGENVECTOR C C INITIALIZE C NOTERM=MIN(NOT1,NRANG2) -- NOT1 RESET IN RSCT, HENCE NOTERM=NOT1 NDIF=NRANG2-NOTERM C IF(INAST.EQ.0) INAST=MSKIP - NOW SEE $MAIN: INAST=NSYM (.LE.MSKIP) IF(NBUG6.EQ.3) WRITE(IWRITE,1000) KOUNT = 0 C C-----DETERMINE THE NUMBER OF RADIATIVE MATRICES DO 600 MJ = 1, INAST C-----FINAL STATE DATA IG = ILSPI(1,MJ) JPTY = SIGN(1,IG) ITEMP = ABS(IG) JLRGL = MOD(ITEMP,100)-1 JSPN = ITEMP/ 100 C DO 560 MI = 1, MJ C-----INITIAL STATE DATA IG = ILSPI(1,MI) IPTY = SIGN(1,IG) ITEMP = ABS(IG) ILRGL = MOD(ITEMP,100)-1 ISPN = ITEMP / 100 C C-----CHECK IF MULTIPOLE SELECTION RULES ARE SATISFIED IF (ISPN.NE.JSPN) GO TO 560 ML=1 IF (JPTY.EQ.IPTY) THEN IF(ICODE.GT.0) GO TO 560 ML=2 ENDIF IF(ISPN.EQ.0) ML=2*ML IF(ABS(JLRGL-ILRGL).GT.ML) GO TO 560 IF(ILRGL+JLRGL.LT.ML) GO TO 560 IF(KOUNT.LT.99) GO TO 800 WRITE(IWRITE,"(//' IT IS IMPOSSIBLE TO CREATE D-FILES BEYOND D99.' * /1X,45('*'))") GO TO 810 800 KOUNT = KOUNT + 1 IMEM(1,KOUNT) = MI IMEM(2,KOUNT) = MJ C SKIP(KOUNT) = IPOLPH.LE.2 .AND. ML.EQ.2 560 CONTINUE 600 CONTINUE C C-----WRITE THE HEADER D00 TO OUTPUT TAPE 810 OPEN(ITAPE4,FILE='D00',STATUS='UNKNOWN',FORM='UNFORMATTED') WRITE(ITAPE4) KOUNT IF(KOUNT.EQ.0) WRITE(IWRITE,1002) DO 480 IH = 1,KOUNT ITEMP = ILSPI(1,IMEM(1,IH)) IPTY = 0 IF(ITEMP.LT.0) IPTY = 1 ITEMP = ABS(ITEMP) ILRGL = MOD(ITEMP,100)-1 ISPN = ITEMP/100 ITEMP = ILSPI(1,IMEM(2,IH)) JPTY = 0 IF(ITEMP.LT.0) JPTY = 1 ITEMP = ABS(ITEMP) JLRGL = MOD(ITEMP,100)-1 JSPN = ITEMP/100 480 WRITE(ITAPE4) ISPN,ILRGL,IPTY, JSPN,JLRGL,JPTY C OUT ENDFILE(ITAPE4) CLOSE(ITAPE4) C --- *=*=*=*=*=*=*=* ITAPE=ITAPE1 C C C THE DIPOLE MATRIX ELEMENTS ARE READ FROM THE STG2 OUTPUT TAPE C DO 100 IH=1,KOUNT C C-----READ INITIAL STATE DATA IN = IMEM(1,IH) ILRGL = MOD(ABS(ILSPI(1,IN)),100)-1 MMNP2 = ILSPI(2,IN) MCFF = MOD(MMNP2,NOTERM) IF(MCFF.EQ.0) MCFF = NOTERM MCHAN = ILSPI(3,IN) MCONHP = NOTERM * MCHAN MCFGP = MMNP2 - MCONHP MLSPI4 = ILSPI(4,IN) C C-----READ FINAL STATE DATA JN = IMEM(2,IH) JPTY = 0 ITEMP = ILSPI(1,JN) IF(ITEMP.LT.0) JPTY = 1 ITEMP = ABS(ITEMP) JLRGL = MOD(ITEMP,100)-1 JSPN = ITEMP/100 MNP2 = ILSPI(2,JN) NCFF = MOD(MNP2,NOTERM) IF(NCFF.EQ.0) NCFF = NOTERM NCHAN = ILSPI(3,JN) NCONHP = NOTERM * NCHAN NCFGP = MNP2 - NCONHP NLSPI4 = ILSPI(4,JN) C C-----WRITE TO OUTPUT TAPE DATA DEFINING THE S L PI - S LP PIP C-----COMBINATION SATISFYING THE DIPOLE SELECTION RULES IF(IH.EQ.1 .OR. NBUG6.GT.0) WRITE(6,'(//)') WRITE(6,"(I5,': INITIAL SYMMETRY NUMBER',I3, * 6X,'FINAL SYMMETRY NUMBER',I3)") IH, IN,JN IREC3 = 1 FILNAM = 'D'//NUM(IH/10)//NUM(MOD(IH,10)) OPEN(ITAPE4,FILE=FILNAM,STATUS='UNKNOWN',FORM='UNFORMATTED') WRITE(ITAPE4) NOTERM,MNP2,NCHAN,JLRGL,JPTY,JSPN,MMNP2,MCHAN,ILRGL C C C------MULTIPLY BY EIGENVECTORS OF LHS HAMILTONIAN LAST = NOTERM C print "(' NR2,(nch,ncb) =',5I5)", NRANG2, MCHAN,MCFGP, NCHAN,NCFGP ML = NDIF 2 NL = 0 MK = ML+1-NDIF ML = ML+NOTERM C 3 NK = NL + 1 NL = NL + NOTERM 4 READ(ITAPE) (( DML(I,J), J=1,NRANG2), I= NK, NL) READ(ITAPE) (( DMV(I,J), J=1,NRANG2), I= NK, NL) IF(NBUG6.EQ.3) PRINT *,' DM READ FOR NK,NL= ',NK,NL C C------READ IN MATRIX ELEMENTS INVOLVING THE BUTTLE CORRECTION IN C------INITIAL STATE IF(NL-MCONHP) 3,7,41 7 IF( MCFGP .EQ. 0 ) GO TO 41 NK = MCONHP + 1 NL = MMNP2 GO TO 4 C C-----GIVE JREC THE LOCATION OF FIRST EIGENVECTOR RECORD CW==> JREC = ILSPI( 4, IN) - ( MMNP2 - 1 ) / NOTERM 41 JREC = MLSPI4 - KINIT(MMNP2) READ(ITAPE) ((ABUTL(J,I),J=MK,ML),I=1,MCHAN) READ(ITAPE) ((ABUTV(J,I),J=MK,ML),I=1,MCHAN) IF(NBUG6.EQ.3) PRINT *,' AB READ FOR MK,ML= ',MK,ML C C----- BEGIN PROCESSING OF DIPOLE MATRIX ELEMENTS C C----- READ IN A BLOCK OF EIGENVECTORS KR = 0 C ETC IF(MMNP2.LT.NOTERM) GO TO 300 -- CASE OF NO CHANNELS RULED OUT. KNT = NOTERM 250 READ(IDISC2,REC=JREC) ((XX(J,I),I=1,MMNP2),J=1,KNT) C C------FORM THE BLOCK (SQUARE AS LONG AS LAST=KNT) CALL VMUL(XX,DML,DKL,KNT,MMNP2,LAST) CALL VMUL(XX,DMV,DKV,KNT,MMNP2,LAST) KR = KR + 1 IF(MK.EQ.1) IPRE(KR) = 0 C TST print *,' 250+: IREC3= ',irec3 WRITE(IDISC3,REC=IREC3) ((DKL(I,J),I=1,KNT),J=1,LAST), * ((DKV(I,J),I=1,KNT),J=1,LAST),IPRE(KR) IPRE(KR) = IREC3 C print "(' mk,knt,ml,jrec,KR =',6I5)", mk,knt,ml,jrec,KR C ==> IREC3 = IREC3 + 1 IREC3 = (KNT*LAST*2)/LRECW3 + IREC3 + 1 C TST print *,' 300-: IREC3= ',irec3 CW==> JREC = JREC + 1 JREC = JREC + KSTEP(MMNP2) IF(JREC-MLSPI4) 250,300,350 C 300 KNT = MCFF C------READ LAST BLOCK OF EIGENVECTORS, FORM LAST RECTANGULAR BLOCK GO TO 250 C C-----GO BACK UP TO READ MORE DIPOLE MATRIX ELEMENTS (CYCLING NCHAN X) 350 IF(MK-1+NOTERM-NCONHP) 2,450,81 C C 450 IRE = NCHAN IF( NCFGP .EQ . 0) GO TO 81 IRE = IRE + 1 LOW = 1 LUP = NCFGP NL = 0 43 NK = NL + 1 NL = NL + NOTERM IF(NBUG6.EQ.3) PRINT *,' NOW DM FOR NK,NL= ',NK,NL 80 READ(ITAPE) ((DML(J,I),I=LOW,LUP),J=NK,NL) READ(ITAPE) ((DMV(J,I),I=LOW,LUP),J=NK,NL) IF(NL-MCONHP) 43,82,850 82 IF(MCFGP .EQ. 0) GO TO 449 NK = MCONHP + 1 NL = MMNP2 LUP = 0 850 LOW = LUP + 1 LUP = MIN(LUP+NRANG2,NCFGP) IF(LOW.LE.NCFGP) GO TO 80 C C------READ IN SOME MORE MATRIX ELEMENTS INVOLVING BUTTLE CORRECTION IN C INITIAL STATE 449 MK = NCONHP + 1 ML = MNP2 LAST = NCFGP GO TO 41 C C C C------NOW MULTIPLY ELEMENTS INVOLVING INITIAL STATE BUTTLE CORRECTION C BY EIGENVECTORS OF THE RHS FINAL STATE HAMILTONIAN C C CW==> IREC = ILSPI(4,JN) - (MNP2-1)/ NOTERM 81 IREC = NLSPI4 - KINIT(MNP2) C C------READ IN A BLOCK OF EIGENVECTORS IG = 0 KNT = NOTERM 950 READ(IDISC2,REC=IREC) ((XX(J,I),I=1,MNP2),J=1,KNT) C C------FORM THE PROCESSED BLOCK CALL VMUL(XX,ABUTL,DKL,KNT,MNP2,MCHAN) CALL VMUL(XX,ABUTV,DKV,KNT,MNP2,MCHAN) DO 960 J=1,MCHAN DO 960 I=1,KNT BBUTL(I+IG,J) = DKL(I,J) 960 BBUTV(I+IG,J) = DKV(I,J) IG = IG + NOTERM CW==> IREC = IREC + 1 IREC = IREC + KSTEP(MNP2) IF(IREC-NLSPI4) 950,988,970 C 988 KNT = NCFF C------READ LAST BLOCK OF EIGENVECTORS, FORM PROCESSED BLOCKS GO TO 950 C C------NOW READ IN AND PROCESS WITH EIGENVECTORS OF THE LHS INITIAL C STATE HAMILTONIAN THE ELEMENTS INVOLVING BUTTLE CORRECTION C TO THE FINAL STATE C 970 NL = 0 CW==> JREC = ILSPI(4,IN) - (MMNP2-1)/ NOTERM JREC = MLSPI4 - KINIT(MMNP2) 430 NK = NL + 1 NL = NL + NOTERM IF(NBUG6.EQ.3) PRINT *,' AND DM FOR NK,NL= ',NK,NL 789 READ(ITAPE) ((DML(I,J),J=1,NCHAN),I=NK,NL) READ(ITAPE) ((DMV(I,J),J=1,NCHAN),I=NK,NL) IF(NL-MCONHP) 430,790,489 790 IF(NL.EQ.MMNP2) GO TO 489 NK = MCONHP + 1 NL = MMNP2 GO TO 789 C C------READ IN A BLOCK OF EIGENVECTORS 489 IG = 0 KNT = NOTERM 840 READ(IDISC2,REC=JREC) ((XX(J,I),I=1,MMNP2),J=1,KNT) C C------FORM THE BLOCK CALL VMUL(XX,DML,DKL,KNT,MMNP2,NCHAN) CALL VMUL(XX,DMV,DKV,KNT,MMNP2,NCHAN) DO 860 J=1,NCHAN DO 860 I=1,KNT ABUTL(I+IG,J) = DKL(I,J) 860 ABUTV(I+IG,J) = DKV(I,J) IG = IG + NOTERM CW==> JREC = JREC + 1 JREC = JREC + KSTEP(MMNP2) IF(JREC-MLSPI4) 840,898,870 C 898 KNT = MCFF C------READ LAST BLOCK OF EIGENVECTORS, FORM LAST BLOCK GO TO 840 C C------READ IN ELEMENTS INVOLVING BUTTLE CORRECTION TO BOTH C INITIAL AND FINAL STATES 870 READ(ITAPE) ((CBUTL(I,J),J=1,NCHAN),I=1,MCHAN) READ(ITAPE) ((CBUTV(I,J),J=1,NCHAN),I=1,MCHAN) C C C------NOW MULTIPLY BY EIGENVECTORS OF RHS HAMILTONIAN C LAST = NOTERM C NB: KR = ( MMNP2-1) / NOTERM + 1 DO 700 IK=1,KR CW==> IREC = ILSPI(4,JN) - (MNP2-1)/ NOTERM IREC = NLSPI4 - KINIT(MNP2) IPR = IPRE( IK ) C C----- SPECIAL TREATMENT FOR LAST PART LUP = MNP2 LOW = NCONHP + 1 IF(NCFGP.EQ.0) LOW = LUP+1-NOTERM C----- TREAT THE LAST BLOCK OF DIPOLE MATRIX ELEMENTS: IF(IK.EQ.KR) LAST=MCFF DO 650 JK = 1, IRE C TST print *,' 650-IPR = ',ipr READ(IDISC3,REC=IPR) ((DML(I,J),J=1,LAST),I=LOW,LUP), * ((DMV(I,J),J=1,LAST),I=LOW,LUP),IPR LUP = LOW-1 650 LOW = LOW-NOTERM C C----- READ IN A BLOCK OF EIGENVECTORS KNT = NOTERM 750 READ(IDISC2,REC=IREC) ((XX(J,I),I=1,MNP2),J=1,KNT) C C----- FORM A SQUARE PROCESSED BLOCK CALL VMUL(XX,DML,DKL,KNT,MNP2,LAST) CALL VMUL(XX,DMV,DKV,KNT,MNP2,LAST) WRITE(ITAPE4) ((DKL(J,I),J=1,KNT),I=1,LAST), * ((DKV(J,I),J=1,KNT),I=1,LAST) CW==> IREC = IREC + 1 IREC = IREC + KSTEP(MNP2) IF(IREC-NLSPI4) 750,769,700 C 769 KNT = NCFF C------READ LAST BLOCK OF EIGENVECTORS, FORM LAST RECTANGULAR BLOCK GO TO 750 C 700 CONTINUE C C-----WRITE OUT BLOCKS INVOLVING BUTTLE CORRECTIONS (KAB'92JUL: IORDER!) WRITE(ITAPE4) ((BBUTL(I,IORDER(J,IN)),J=1,MCHAN),I=1,MNP2), 1 ((BBUTV(I,IORDER(J,IN)),J=1,MCHAN),I=1,MNP2) WRITE(ITAPE4) ((ABUTL(I,IORDER(J,JN)),J=1,NCHAN),I=1,MMNP2), 1 ((ABUTV(I,IORDER(J,JN)),J=1,NCHAN),I=1,MMNP2) WRITE(ITAPE4) * ((CBUTL(IORDER(I,IN),IORDER(J,JN)),J=1,NCHAN),I=1,MCHAN), 1 ((CBUTV(IORDER(I,IN),IORDER(J,JN)),J=1,NCHAN),I=1,MCHAN) C C READ IN THE CLEBSCH GORDAN COEFFICIENTS FOR THE POLARIZABILITY C CALCULATION, WRITE THESE TO THE OUTPUT TAPE: C READ(ITAPE) MAXM1,(CGC(M),M=1,MAXM1) WRITE(ITAPE4) MAXM1,(CGC(M),M=1,MAXM1) C C-----READ IN THE ANGULAR INTEGRALS, NEEDED FOR OUTER REGION INTEGRATION READ(ITAPE) ((AC(I,J),J=1,MCHAN),I=1,NCHAN) READ(ITAPE) ((BLC(I,J),J=1,MCHAN),I=1,NCHAN) READ(ITAPE) ((BVC(I,J),J=1,MCHAN),I=1,NCHAN) C-----WRITE COEFFICIENTS TO OUTPUT TAPE (KAB'92JUL2: USE IORDER!) WRITE(ITAPE4) * ((AC(IORDER(I,JN),IORDER(J,IN)),J=1,MCHAN),I=1,NCHAN), 1 ((BLC(IORDER(I,JN),IORDER(J,IN)),J=1,MCHAN),I=1,NCHAN), 2 ((BVC(IORDER(I,JN),IORDER(J,IN)),J=1,MCHAN),I=1,NCHAN) IF(NBUG6.EQ.3) THEN WRITE(6,'(//23H THE A COEFFICIENTS ARE)') DO 703 I=1,NCHAN 703 WRITE(6,1004) I,(AC(I,J),J=1,MCHAN) WRITE(6,'(/24H THE BL COEFFICIENTS ARE)') DO 704 I=1,NCHAN 704 WRITE(6,1004) I,(BLC(I,J),J=1,MCHAN) WRITE(6,'(/24H THE BV COEFFICIENTS ARE)') DO 705 I=1,NCHAN 705 WRITE(6,1004) I,(BVC(I,J),J=1,MCHAN) ENDIF IF(ISPN.NE.0) GO TO 899 READ(ITAPE,END=897,ERR=896) ((AC(I,J),J=1,MCHAN),I=1,NCHAN) print *,' RSTGH-test: AC2 successfully read!' WRITE(ITAPE4) * ((AC(IORDER(I,JN),IORDER(J,IN)),J=1,MCHAN),I=1,NCHAN) GO TO 899 896 BACKSPACE ITAPE 897 print *,' NO AYMPTOTIC BP-VELOCITY ARRAY FOUND -- DOING WITHOUT' C OUT ENDFILE(ITAPE4) 899 CLOSE(ITAPE4) C --- *=*=*=*=*=*=*=* C 100 CONTINUE RETURN END C*********************************************************************** SUBROUTINE RECOV1(I,ID) C C THIS ROUTINE IS CALLED ONLY IN THE CASE OF ARRAY OVERFLOW. C IF IPLACE=0 THE PROGRAM STOPS HERE, OTHERWISE THE PROGRAM RETURNS C TO THE CALLING ROUTINE AFTER SETTING IPLACE=I. C C I IS THE POSITION IN THE IDMTST ARRAY, WHICH HOLDS THE CURRENT C ARRAY DIMENSIONS C ID IS THE ARRAY SIZE REQUIRED BY THE DATA C COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/RECOV/ IPLACE,IDMTST(30) C 1000 FORMAT(//19H * ARRAY OVERFLOW */36H MUST INCREASE SIZE GIVEN BY ID *MTST(,I2,2H)=,I5,20H TO AT LEAST IDMTST(,I2,2H)=,I5) 1001 FORMAT(/29H PROGRAM TERMINATES IN RECOV1/) 1002 FORMAT(/54H CHECK TO SEE IF OTHER ARRAYS ARE GOING TO BE EXCEEDED) C WRITE(IWRITE,1000) I,IDMTST(I),I,ID IF(IPLACE) 2,1,3 1 WRITE(IWRITE,1001) STOP C 2 WRITE(IWRITE,1002) 3 IPLACE=I ID=IDMTST(I) RETURN END C*********************************************************************** SUBROUTINE RSCT C*********************************************************************** C C SETS UP AND DIAGONALIZES THE HAMILTONIAN MATRIX C AND DETERMINES THE SURFACE AMPLITUDES FROM THE EIGENVECTORS. C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*6 FL8(8),FO8(2) PARAMETER(L62L63=((18000+1)*18000)/2, L71= 60+1, C * L90L91=((2*1800- 60+1)* 60)/2, * L90L91= 18000 * 60 , EPSI=1.0E-9, ZERO=0.0) DIMENSION XX(18000, 60), * NORDER( 500),X(18000),VALUE(18000),AUX(18000,9), H(L90L91), * WTEM( 500,18000),CFTEM( 500, 500, 8), WMAT( 500,18000) C COMMON // WMAT( 500,1800),HNP1(L62L63), H(L90L91) COMMON/BASIC/ BSTO,RA,LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/ EIGENS( 60, 61),ENDS( L71, 61), HNP1(L62L63) COMMON/CASES/ MORE,MSKIP,IPOLPH,ICODE,INAST, LRECW2,LRECW3,LWORD COMMON/CROSEC/CF( 500, 500, 8),ET( 500),ENAT( 200), * ISAT( 200),LAT( 200),L2P( 500) COMMON/CUPINT/MNP1,NCONHP,NCHAN, LAMAX,LAM COMMON/DISTAP/IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2,ITAPE3,ITAPE4 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 c * following inconsistent common statement is corrected below it. snn,Dec09 c * /RCASES/NOT1,NOT2,NOT3,NCFGP COMMON/RCASES/NOT1,NOT2,NOT3,NCFGP c * end of correction COMMON/RECORD/ IREC1,IREC2,IREC3,ILSPI(4, 40),IORDER( 500, 40) COMMON/RECOV/ IPLACE,IDMTST(30) C COMMON/SPACES/ XX(1800, 60) C EQUIVALENCE (WTEM(1,1),HNP1(1)), (CFTEM(1,1,1),H(1)) C DATA FL8/' (8', '(14X,7', '(28X,6', '(42X,5', * '(56X,4', '(70X,3', '(84X,2', ' (98X,'/, FO8(2)/'F14.7)'/ 1005 FORMAT(/' HAMILTONIAN EIGENVECTOR',I6 * /22H TO EIGENVALUE/2RY =,F14.6/1P,(1X,12E10.3)) 1006 FORMAT(44H SURFACE AMPLITUDES FOR EACH CHANNEL AT NO =,I6 */1P,(8E10.3)) 1009 FORMAT(/51H ENERGY LEVELS WITH RESPECT TO THE GROUND STATE (AT, * F12.5,' RYDBERGS)'/(1X,10F12.5)) 1010 FORMAT(/' ** WARNING ** NOT1.LT.NRANG2',5X,6(4H -!-)/16X,43(1H=) * /28H HAMILTONIAN MATRIX - SIZE =,I5,I10,' CHANNELS'/) C WRITE(IWRITE,'(/53X,15HSUBROUTINE RSCT/53X,15(1H-))') C NOMB=1 -- NOT USED IF(NOT1.GT.NRANG2) NOT1=NRANG2 NOTERM=NOT1 C NUMS=0 -- NOT USED C C SET THE ASYMPTOTIC COEFFICIENT MATRIX CF, AND THE E2P ARRAY. C CALL ORDER(ET,NORDER,NCHAN,-1) IF(LAMAX.EQ.0) GO TO 4 DO 3 K=1,LAMAX DO 2 J=1,NCHAN J1 = NORDER(J) DO 1 I=J1,NCHAN 1 CF(I,J1,K) = CF(J1,I,K) DO 2 I=1,NCHAN I1 = NORDER(I) 2 CFTEM(I,J,K) = CF(I1,J1,K) C if(nbug8.ne.2) go to 3 C write(6,'(/14H ARRAY CF': K=,i2)') C do 6 j=1,nchan C 6 write(6,'(i5,(t7,8f9.5))') j,(cftem(i,j,k),i=1,nchan) 3 CONTINUE WRITE(ITAPE3) (((CFTEM(I,J,K),I=1,NCHAN),J=1,NCHAN),K=1,LAMAX) C C USE THE NUMBER OF CONTINUUM TERMS TO BE RETAINED IN C THE EXPANSION. THIS WILL REDUCE THE SIZE OF THE C HAMILTONIAN MATRIX FROM MNP1 TO MNP2. C 4 MNP2=NOTERM*NCHAN+NCFGP MN4=2*MNP2 IF(NOT1.EQ.NRANG2) GO TO 14 WRITE(IWRITE,1010) MNP2,NCHAN MN2=2*MNP1 C C READ THE FULL HAMILTONIAN MATRIX FROM SCRATCH DISC, C AND PUT THE UPPER TRIANGLE OF THE HAMILTONIAN MATRIX REQUIRED C INTO A ONE DIMENSIONAL ARRAY, HNP1; LOOP OVER EACH CHANNEL: C REWIND IDISC1 C DO 12 M=1,NCHAN MO=(M-1)*NOTERM MH=MN2-2*(M-1)*NRANG2 ML=((MH-NRANG2+1)*NRANG2)/2 MN=NCHAN-M+1 READ(IDISC1) (H(I),I=1,ML) C C LOOP OVER THE NUMBER OF TERMS REQUIRED IN EACH CHANNEL C DO 11 I=1,NOTERM IA=NOTERM-I+1 IK=((MO+I-1)*(MN4-MO-I+2))/2 IL=IK-I+1 IG=((I-1)*(MH-I+2))/2 IP=IG-I+1 C C THE CONTINUUM-CONTINUUM TERMS C LO=IK LP=IG I1=IA DO 8 L=1,MN DO 5 K=1,I1 5 HNP1(LO+K)=H(LP+K) I1=NOTERM LO=L*NOTERM+IL 8 LP=L*NRANG2+IP IF(NCFGP.EQ.0) GO TO 11 C C THE BOUND-CONTINUUM TERMS C DO 10 K=1,NCFGP 10 HNP1(LO+K)=H(LP+K) 11 CONTINUE 12 CONTINUE C C THE BOUND-BOUND TERMS C IF(NCFGP.EQ.0) GO TO 14 N=NOTERM*NCHAN M=(N*(MN4-N+1))/2 J=M+1 K=M + (MNP1*(MNP1+1) - NCONHP*(MN2-NCONHP+1))/2 READ(IDISC1)(HNP1(I),I=J,K) C C IF NBUG6=2 WRITE OUT THE HAMILTONIAN MATRIX WHICH IS TO BE C DIAGONALIZED IN THIS LOOP OF RSCT C 14 IF(NBUG6.NE.2) GO TO 20 WRITE(IWRITE,'(/28H HAMILTONIAN MATRIX - SIZE =,I5/)') MNP2 C *** 14 STATEMENTS FROM OP-STGHS REPLACING 39 PREVIOUS STATEMENTS: M=0 15 K=M L=M+1 M=MIN(M+8,MNP2) FO8(1)=FL8(1) DO 18 I=1,M IF(I.LE.K) GO TO 17 FO8(1)=FL8(I-K) L=I 17 MO=((I-1)*(MN4-I))/2+L MH=MO+M-L 18 WRITE(IWRITE,FO8) (HNP1(J),J=MO,MH) WRITE(IWRITE,'()') IF(M.LT.MNP2) GO TO 15 C C DIAGONALIZE THE HAMILTONIAN MATRIX AND STORE ITS EIGENVALUES IN C THE VALUE ARRAY AND ONE EIGENVECTOR IN THE VECTOR ARRAY. C EACH CALL TO HSLDR PRODUCES ONE EIGENVECTOR, FROM WHICH WE C CALCULATE THE SURFACE AMPLITUDES AND THE DIPOLE MATRIX ELEMENTS. C 20 LENGTH=(MNP2*(MNP2+1))/2 WRITE(IWRITE,'(37H DIAGONALIZING THE HAMILTONIAN MATRIX)') C IF(MSKIP.EQ.1) IREC2 = 1 -- SET IN $MAIN IF(IPOLPH.LT.2) GO TO 21 ILSPI( 1, MSKIP) = ( 100 * NSPN +LRGL+1) * (1-2*MOD(NPTY,2)) ILSPI( 2, MSKIP) = MNP2 ILSPI( 3, MSKIP) = NCHAN KOUNT = 0 21 DO 41 NO=1,MNP2 CALL HSLDR(MNP2,HNP1,LENGTH,EPSI,VALUE,X,NO,AUX,IDMTST(6)) IF(IPOLPH.LT.2) GO TO 30 C MOVE THE EIGENVECTORS OUT TO DISC IN BLOCKS: KOUNT = KOUNT + 1 DO 22 I=1,MNP2 22 XX(I,KOUNT) = X(I) IF(NO.EQ.MNP2) GO TO 25 IF(KOUNT.NE.NOTERM) GO TO 30 25 ILSPI( 4, MSKIP) = IREC2 WRITE(IDISC2,REC=IREC2) ((XX( I, J), I =1, MNP2), J=1, KOUNT) CW==> IREC2 = IREC2 + 1 -- 90'APR8: IREC2 = (MNP2*KOUNT-1)/LRECW2 + IREC2+1 KOUNT = 0 30 IF(NBUG8.NE.2) GO TO 31 WRITE(IWRITE,1005) NO, VALUE(NO), (X(I),I=1,MNP2) C C DETERMINE THE SURFACE AMPLITUDES WMAT C 31 M=0 DO 33 J=1,NCHAN L=L2P(J)+1 SUM=ZERO DO 32 I=1,NOTERM 32 SUM=SUM+X(I+M)*ENDS(I,L) M=M+NOTERM 33 WMAT(J,NO) = SUM IF(NBUG8.EQ.2) WRITE(IWRITE,1006) NO,(WMAT(K,NO),K=1,NCHAN) 41 CONTINUE M=0 IF(NBUG8.EQ.1) M=MNP2 IF(NBUG8.NE.2) WRITE(6,1005) MNP2, VALUE(MNP2), (X(I),I=1,M) C IF(NBUG8.GE.1) THEN ELOW=ENAT(1)*2. DO 42 I=1,MNP2 42 X(I) = VALUE(I)*2.-ELOW WRITE(IWRITE,1009) ELOW, (X(I),I=1,MNP2) ENDIF C C WRITE THESE QUANTITIES TO ITAPE3 (KAB'92JUL2: ADD IORDER!) C WRITE(ITAPE3) (VALUE(I),I=1,MNP2) DO 45 I=1,NCHAN I1 = NORDER(I) IF(IPOLPH.GE.2) IORDER(I,MSKIP)=I1 C IF-PROTECTED RUB'96APR12. DO 44 K=1,MNP2 44 WTEM(I,K) = WMAT(I1,K) if(nbug8.ne.2) go to 45 write(6,'(6h wtem:,I4/1p,(8e10.3))') i,(wtem(i,k),k=1,mnp2) 45 CONTINUE WRITE(ITAPE3)((WTEM(K,I),K=1,NCHAN),I=1,MNP2) RETURN END C*********************************************************************** SUBROUTINE STG3RD C C READS THE DATA SPECIFYING THE CASE C C IMPLICIT REAL*8(A-H,O-Z) CHARACTER*4 TITLE(18),PARITY(2), SPIN(0:8)*8 DIMENSION NTAPE(5) COMMON/BASIC/ BSTO,RA,LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CASES/ MORE,MSKIP,IPOLPH,ICODE,INAST, LRECW2,LRECW3,LWORD COMMON/DISTAP/IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2,ITAPE3,ITAPE4 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 COMMON/RCASES/NOT1,NOT2,NOT3,NCFGP COMMON/RECOV/ IPLACE,IDMTST(30) COMMON/TARGET/EST( 200),AST( 200), COEFF(3, 61),NEST,NCONAT( 200) DATA NTAPE/1,2,3,4,5/, PARITY/'EVEN',' ODD'/, O1/1.0/, * SPIN/'(= 2J) ',' SINGLET',' DOUBLET',' TRIPLET', * ' QUARTET',' QUINTET',' SEXTET ',' SEPTET ',' 2S+1>7 '/ C 1000 FORMAT(//10X,'COMPILED FOR DIMENSIONS -'/ +/15X,'MAX. NUMBER OF CHANNELS (AMP)L.5 = 500' +/15X,'MAX. DEGREE OF HAMILTONIAN MATRIX 10*(AMP)L.6 = 1800''0' +/15X,'MAXIMUM VALUE OF NRANG2 (AMP)L.7 = 60' +/15X,'SIZE OF STORE IN SR STG3RD (AMP)L13 = 4000' +/15X,'NO OF TARGET STATES IN /CROSEC/ ETC (AMP)L14 = 200' +/15X,'NO OF CONTINUUM AND TARGET ANGULAR MOM. (AMP)L15 = 61' +/15X,'NO. OF MULTIPOLES IN POTENTIALS (AMP)L18 = 8' */15X,'NO OF (N+1) ELECTRON SYMMETRIES (AMP)L29 = 40'/// */52X,17HSUBROUTINE STG3RD/52X,17(1H-) */29H INPUT-OUTPUT CHANNEL NUMBERS/12I5) 1001 FORMAT( 1 24X,55H SSSSSSSS TTTTTTTTTT GGGGGGGG HH HH 2/24X,55HSSSSSSSSSS TTTTTTTTTT GGGGGGGGGG HH HH 3/24X,55HSS TT GG GG HH HH 4/24X,55HSS TT GG HH HH 5/24X,55HSS TT GG HH HH 6/24X,55HSSSSSSSSS TT GG HHHHHHHHHH 7/24X,55H SSSSSSSSS TT GG GGGG HHHHHHHHHH 8/24X,55H SS TT GG GGGG HH HH 9/24X,55H SS TT GG GG HH HH A/24X,55H SS TT GG GG HH HH B/24X,55HSSSSSSSSSS TT GGGGGGGGGG HH HH C/24X,55H SSSSSSSS TT GGGGGGGG HH HH) 1002 FORMAT(//8X,72(1H-)//8X,18A4//8X,72(1H-)////) 1003 FORMAT(16H NBUG PARAMETERS/9I5) 1004 FORMAT(/11H BASIC DATA) 1005 FORMAT(8H ICOPY =,I3,10H ITOTAL =,I3,10H IPOLPH =,I3) 1008 FORMAT(/4H L =,I3,3X,A8,3X,A4/1X,24(1H-)) 1010 FORMAT(51X,20H INPUT CHANNEL ITAPE,I1,2H =,I5) 1011 FORMAT(51X,20HOUTPUT CHANNEL ITAPE,I1,2H =,I5) 1012 FORMAT(//52X,17HSUBROUTINE STG3RD/52X,17(1H-)) 1013 FORMAT(/80H OBSERVED ENERGIES FOR EACH STATE (N.B. IF NEGATIVE & E *1=.0 THEN -WAVENUMBER*CM)/(5F16.6)) 1014 FORMAT(/7H NBUT =,I3,8H NOT1 =,I3,8H NOT2 =,I3,9H IDIAG =,I3, * 8H NAST =,I3,9H INAST =,I3) 1017 FORMAT(//' *** ATTENTION *** WORDS/RECORD=',2I8,' FOR DIRECT ACCESWE88AP24 *S UNITS'/24X,'9 AND 10 READ BECAUSE NEGATIVE IPOLPH SPECIFIED!'/) 1018 FORMAT(1H+,19X,'AND WORD LENGTH SPECIFIED AS',I3,' BYTES!!'/) C C THE FOLLOWING FORMAT STATEMENTS ARE TO READ THE CARD INPUT DATA C C2000 FORMAT(12I5) C2001 FORMAT(5F14.7) 2002 FORMAT(18A4) C C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM DATA, CALL RECOV1 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C IPLACE=0 C ISTATE=0 -- NOT USED C C IF MSKIP.GT.1, STG3 IS BEING REPEATED FOR NEW (N+1)-ELECTRON DATA C SO IT IS NOT NECESSARY TO READ IN THIS FIRST SET OF DATA AGAIN. C IF(MSKIP.GT.1) GO TO 4 MORE=1 READ(IREAD,2002) TITLE CC READ(IREAD,2000) IWRITE,... READ(IREAD,*) IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3, * ITAPE1,ITAPE2,ITAPE3,ITAPE4 WRITE(IWRITE,1002) TITLE WRITE(IWRITE,1001) WRITE(IWRITE,1000)IWRITE,IPUNCH,IDISC1,IDISC2,IDISC3, * ITAPE1,ITAPE2,ITAPE3,ITAPE4 CC READ(IREAD,2000) NBUG1,... READ(IREAD,*)NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 WRITE(IWRITE,1003)NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8, 1 NBUG9 CC READ(IREAD,2000) ICOPY,ITOTAL,IPOLPH READ(IREAD,*) ICOPY,ITOTAL,IPOLPH ICOPY=0 ITOTAL=0 WRITE(IWRITE,1005)ICOPY,ITOTAL,IPOLPH ICOPY1=1 ICOPY2=ICOPY LRECW2 = 0 LRECW3 = 0 LWORD = 4 O0 = O1+1.E-9 IF(O0.GT.O1) LWORD = 8 IF(IPOLPH.GE.0) GO TO 2 C---> DIRECT ACCESS RECORD LENGTH SPECIFIED -- E.G. 0 4095 0 FOR IBM: C---> LRECW2= 0 OR UNSPECIFIED UNLESS IDMTST(6) IS INFLATED - WE'90MAR18 C---> LRECW3= 0 OR " UNLESS THE MACHINE ALLOWS ONLY LRECW3 WORDS/RECORD C---> =4095 FOR IBM (ASSUMING LWORD = 8 BYTES/WORD): READ(IREAD,*) LRECW2,LRECW3,LS WRITE(IWRITE,1017) LRECW2,LRECW3 IPOLPH=-IPOLPH IF(LS.LE.0) GO TO 2 WRITE(IWRITE,1018) LS LWORD=LS 2 IF(IPOLPH.LT.2) ITAPE1=0 IF(ITAPE1.GT.0) WRITE(IWRITE,1010)NTAPE(1),ITAPE1 WRITE(IWRITE,1010)NTAPE(2),ITAPE2 IF(ITAPE3.GT.0) WRITE(IWRITE,1011)NTAPE(3),ITAPE3 IF(ITAPE4.GT.0) WRITE(IWRITE,1011)NTAPE(4),ITAPE4 WRITE(IWRITE,1004) GO TO 5 C 4 IF(INAST.NE.0) WRITE(IWRITE,1012) IF(INAST) 5,9,8 C C READ AND WRITE BASIC DATA. C C NOT1 THE NUMBER OF CONTINUUM TERMS TO BE USED C IDIAG = 1 IF ITAPE2 CONTAINS STG2 HAMILTONIAN MATRICES, C AND THE DIAGONALIZATION DATA IS TO BE STORED ON ITAPE3 C NAST = 0 IF THE ENERGIES OF THE ATOMIC OR IONIC STATES ARE NOT C TO BE CHANGED C .GT.0 IF THE ENERGIES ARE TO BE CHANGED. C THE VALUE OF NAST IS THEN THE TOTAL NUMBER OF C N-ELECTRON STATES C INAST .GE.0 IF STG3 IS TO BE RECYCLED WITH THE SAME BASIC DATA C FOR DIFFERENT (N+1)-ELECTRON SYMMETRIES (FOR ALL IF C .EQ.0, FOR INAST SPECIFIED SYMMETRIES IF .GT.0). C CC 5 READ(IREAD,2000) NBUT,... 5 READ(IREAD,*) NBUT,NOT1,NOT2,IDIAG,NAST,INAST WRITE(IWRITE,1014)NBUT,NOT1,NOT2,IDIAG,NAST,INAST CW NOT3=1 C C READ THE OBSERVED ENERGY OF THE ATOMIC OR IONIC TARGET STATES C NEST=NAST IF(NAST.EQ.0) GO TO 7 CC READ(IREAD,2001) (EST(N)... READ(IREAD,*) (EST(N),N=1,NAST) WRITE(IWRITE,1013)(EST(N),N=1,NAST) C C C READ THE TOTAL ANGULAR MOMENTUM, SPIN, PARITY; C N.B. DO SET INAST=0 WHEN PROCESSING ALL SYMMETRIES! C C CC 7 READ(IREAD,2000) LRGL,... 7 IF(INAST.EQ.0) GO TO 9 8 READ(IREAD,*) LRGL,NSPN,NPTY LS=MIN(NSPN,8) WRITE(IWRITE,1008) LRGL,SPIN(LS),PARITY(NPTY+1) IF(NSPN.LT.0.OR.NPTY.LT.0.OR.NPTY.GT.1) STOP IF(MSKIP.EQ.INAST) MORE=0 9 RETURN END C*********************************************************************** SUBROUTINE TAPERD C C READS THE INPUT DATA FROM STG2 CORRESPONDING TO THE REQUIRED C VALUES OF LRGL, NSPN, NPTY, NCFGP. C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL BP,FIRST CHARACTER*6 FL8(8),FO8(2) PARAMETER(L62L63=((18000+1)*18000)/2, L71= 60+1) DIMENSION JRELOP(3),MAXNC( 61),IPTY( 200), STORE(4000, 60) C COMMON // WMAT( 500,1800),HNP1(L62L63), STORE COMMON/BASIC/ BSTO,RA,LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/BASIN/ EIGENS( 60, 61),ENDS( L71, 61), HNP1(L62L63) COMMON/CASES/ MORE,MSKIP,IPOLPH,ICODE,INAST, LRECW2,LRECW3,LWORD COMMON/CROSEC/CF( 500, 500, 8),ET( 500),ENAT( 200), * ISAT( 200),LAT( 200),L2P( 500) COMMON/CUPINT/MNP1,NCONHP,NCHAN, LAMAX,LAM COMMON/DISTAP/IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2,ITAPE3,ITAPE4 COMMON/INFORM/IREAD,IWRITE,IPUNCH COMMON/NBUG/ NBUG1,NBUG2,NBUG3,NBUG4,NBUG5,NBUG6,NBUG7,NBUG8,NBUG9 C COMMON/RADIAL/C(&L27),ZE(&L27),IRAD(&L27),NCO(&L26), COMMON/RADIAL/LRANG1,LRANG2,MAXNHF( 61),MAXNLG( 61),NCOEFF,NZ COMMON/RCASES/NOT1,NOT2,NOT3,NCFGP COMMON/RECOV/ IPLACE,IDMTST(30) COMMON/TARGET/EST( 200),AST( 200), COEFF(3, 61),NEST,NCONAT( 200) C AND SAVE ICODE (KAB AT CODES MEETING QUB'92NOV20): ->/CASES/'96OCT1 SAVE BP, FIRST DATA FL8/' (8', '(14X,7', '(28X,6', '(42X,5', * '(56X,4', '(70X,3', '(84X,2', ' (98X,'/, FO8(2)/'F14.7)'/ 1002 FORMAT(43H CANNOT FIND ON TAPE ANY DATA FOR THIS CASE, * 9X,'MSKIP,INAST =',2I5/) 1003 FORMAT(/26H TARGET OR CORE STATE DATA/71H ANG. MOM. SPIN NO. OF * CHAN. ENERGY, AFTER CORRECTING BY, I.E. FROM */(I6,2I9,F16.7,3H AU)) 1004 FORMAT(/' ABORTING: IRREGULAR END OF H FILE FROM STG2'/' ********' *,' PERHAPS CAUSED BY SYMMETRIES LS WITH NCHAN=0 -- RERUN!'/) 1005 FORMAT(I6,2I9,2X,2(F14.7,3H AU),F9.4,3H RY) 1008 FORMAT(7H NELC =,I3,6H NZ =,I3,10H LRANG1 =,I3,10H LRANG2 =,I3/ * 9H NRANG2 =,I3,9H LAMAX =,I3,7H LAM =,I2,11H BPSKIP = ,L1/ * 17H MASS-CORRECTION(,I1,15H), DARWIN-TERM(,I1, * 14H), SPIN-ORBIT(,I2,2H);,7X,7HIZESP =,I3/9H MAXNHF =,20I3) 1009 FORMAT(/6H L2P =,(T7,24I3)) 1010 FORMAT(/28H HAMILTONIAN MATRIX - SIZE =,I5,I10,' CHANNELS') 1020 FORMAT(5H RA =,F10.5,9H, BSTO =,E10.3,'; NIX =',I2/ * I9,26H TARGET STATES ENCOUNTERED/) 1021 FORMAT(/4H L =,I3,3X,A8,3X,A4/1X,24(1H-)) 1023 FORMAT(7H LRGL =,I3,8H NSPN =,I3,8H NPTY =,I2,9H NCFGP =,I5) 1024 FORMAT(/' SPECIFIED CASE OUT OF STEP WITH THIS CASE WHILE IPOLPH.G *T.1'/' REMAINING CASES SKIPPED') C C IF ANY DIMENSION IS EXCEEDED WHEN READING FROM DATA, CALL RECOV1 C WITH IPLACE=0 TO TERMINATE THE PROGRAM C IPLACE=0 NDIAG=0 WRITE(IWRITE,'(//52X,17HSUBROUTINE TAPERD/52X,17(1H-))') ITAPE=ITAPE2 IF(MSKIP.GT.1.AND.(INAST.EQ.0.OR.IPOLPH.GE.2)) GO TO 9 C N.B. IPOLPH=2: SO THAT H FILE STAYS IN STEP WITH D FILE. REWIND ITAPE FIRST=.TRUE. IF(ITAPE1.GT.0) REWIND ITAPE1 C C READ THE BASIC DATA FROM TAPE C READ(ITAPE) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,ICODE,LAM,IZESP, * JRELOP BP = JRELOP(3).NE.0 .AND. ABS(ICODE).EQ.21 READ(ITAPE) (MAXNHF(L),L=1,LRANG1),(MAXNLG(L),L=1,LRANG1) *,(MAXNC(L),L=1,LRANG1) WRITE(IWRITE,1008) NELC,NZ,LRANG1,LRANG2,NRANG2,LAMAX,LAM, BP, * JRELOP,IZESP, (MAXNHF(L),L=1,LRANG1) WRITE(IWRITE,'(9H MAXNLG =,20I3)') (MAXNLG(L),L=1,LRANG1) L = MAX(LRANG1,LRANG2) IF(L.GT.IDMTST(15)) CALL RECOV1(15,L) IF(NRANG2.GT.IDMTST(7)) CALL RECOV1(7,NRANG2) IF(LAMAX.GT.IDMTST(18)) CALL RECOV1(18,LAMAX) NOT2 = MIN(NRANG2,NOT2) DO 1 L=1,LRANG2 READ(ITAPE) (EIGENS(N,L),N=1,NRANG2) 1 READ(ITAPE) (ENDS(N,L),N=1,NRANG2) READ(ITAPE) RA,BSTO,HINT,DELTA,ETA,NIX C C SKIP OVER REDUNDANT INTERVAL AND POTENTIAL DATA (NIX...POVALU): IF(NIX.LE.0) GO TO 4 READ(ITAPE) C * (IRX,I=1,NIX*2) READ(ITAPE) C * (POVALU,I=1,IRX*2) DO 3 LP=1,LRANG1 NBT=MAXNLG(LP)-LP+1 IF(NBT.LE.0) GO TO 3 DO 2 K=1,NBT 2 READ(ITAPE) 3 CONTINUE C C-----READ IN THE BUTTLE CORRECTION COEFFICIENTS 4 READ(ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) READ(ITAPE) NAST IF(NAST.LT.0) THEN NDIAG=1 NAST=-NAST ENDIF WRITE(IWRITE,1020) RA,BSTO, NIX, NAST IF(NAST.GT.IDMTST(14)) CALL RECOV1(14,NAST) READ(ITAPE) (ENAT(I),I=1,NAST),(LAT(I),I=1,NAST), * (ISAT(I),I=1,NAST),(IPTY(I),I=1,NAST) C C SKIP OVER BP INPUT WHEN READING SUCH DATA FROM RSTG2 - RUB'95NOV15 C IF(.NOT.BP) GO TO 9 READ(ITAPE) L DO 5 I=1,L+2+NAST 5 READ(ITAPE) C - SKIPPED OVER NTCON, THEN NAST TIMES NTYP AND DUMMY AIJ. C C THE FOLLOWING DATA DEPENDS ON LRGL, NSPN ETC. C 9 READ(ITAPE,END=22) LRGL2,NSPN2,NPTY2,NCFGP2,IPOL2 WRITE(IWRITE,1023)LRGL2,NSPN2,NPTY2,NCFGP2 READ(ITAPE) MNP1,NCONHP,NCHAN IF(NCHAN.GT.IDMTST(5)) CALL RECOV1(5,NCHAN) C NB: MNP1 = NCFGP2 + NCONHP(=NCHAN*NRANG2), NCFGP2='N+1'-B-CHANNELS. IF(MNP1.GT.IDMTST(6)) CALL RECOV1(6,MNP1) L=NCFGP2 C SECURE SPACE FOR B-CHANNELS IN IPRE OF SR DMAT (ZHL/'99MAR16): IF(IPOLPH.GT.1) L=MAX((NCFGP2-1)/NRANG2+NCHAN+1,NCFGP2) IF(L.GT.IDMTST(13)) CALL RECOV1(13,L) READ(ITAPE) (NCONAT(I),I=1,NAST) READ(ITAPE) (L2P(I),I=1,NCHAN) READ(ITAPE) MORE2 C IF(BP) THEN L=1 IF(NCFGP2.GT.0) L=-NCFGP2 M=0 IF(FIRST) M=(LRANG2+1)*2 FIRST=.FALSE. if(nbug6.eq.3) print *,' test: MSKIP,M,NCFGP = ',MSKIP,M,ncfgp2 DO 6 I=L,M 6 READ(ITAPE) IF(NDIAG.EQ.0) GO TO 10 READ(ITAPE) L if(nbug6.eq.3) print *,' BP-test: BNDJ-INAST = ',L DO 8 I=1,L READ(ITAPE) J,JJ,LP,MO if(nbug6.eq.3) print *,' ------- L,M,LP,NTC = ',J,JJ,LP,MO IF(MO.GE.0) GO TO 8 DO 7 K=1,-MO READ(ITAPE) NQ,M,TEMP ENAT(M)=TEMP IPTY(M)=LP ISAT(M)=JJ 7 LAT(M)=J 8 READ(ITAPE) C ELSE IF(NDIAG.EQ.0) GO TO 10 READ(ITAPE) NAST READ(ITAPE)(ENAT(I),I=1,NAST),(LAT(I),I=1,NAST),(ISAT(I),I=1,NAST) ENDIF C C READ THE UPPER TRIANGLE OF THE HAMILTONIAN MATRIX INTO HNP1 C NDIAG=0 10 MN2=2*MNP1 CW MSIZE=(MNP1*(MNP1+1))/2 DO 19 M=1,NCHAN MP=(M*(M+1))/2 MO=MP-M+1 NQ=(M-1)*NRANG2 NBT=1 DO 18 L=MO,MP C ---> READ CONTINUUM-CONTINUUM BLOCKS INTO STORE IN TURN IF(ABS(ICODE).NE.21) GO TO 12 IF (BP) GO TO 12 IF (L.EQ.MP) GO TO 11 IF (L2P(M).EQ.L2P(L-MO+1)) GO TO 12 11 READ(ITAPE) ((STORE(I,J),I=1,NRANG2),J=1,NRANG2) C SO AS TO PATCH UP ACCIDENTAL TRANSPOSITIONS IN STG2 IF(L-MP) 13,14,14 12 READ(ITAPE) ((STORE(J,I),I=1,NRANG2),J=1,NRANG2) 13 KP = (L-MO)*NRANG2 KN = ((MN2-KP+1)*KP)/2 + NQ-KP C =((KM-1)*NRANG2*(MN2-(KM-1)*NRANG2+1))/2+NRANG2*(M-KM) BEFORE.88AP24WE C ---> TRANSFER CONTINUUM-CONTINUUM BLOCKS INTO HNP1 FROM STORE 14 DO 17 J=1,NRANG2 IF(L.EQ.MP) GO TO 15 JJ = (J-1)*(MNP1-KP) - ((J-1)*J)/2 + KN GO TO 16 15 NBT=J JJ=((NQ+J-1)*(MN2-NQ-J+2))/2-J+1 16 DO 17 I=NBT,NRANG2 17 HNP1(I+JJ)=STORE(I,J) 18 CONTINUE 19 CONTINUE C C C READ BOUND-CONTINUUM BLOCKS INTO STORE C IF(NCFGP2.EQ.0) GO TO 25 DO 21 M=1,NCHAN READ(ITAPE) ((STORE(I,J),I=1,NCFGP2),J=1,NRANG2) KP=(M-1)*NRANG2 KQ=(KP*(MN2-KP+1))/2+NCONHP DO 21 J=1,NRANG2 JJ=(J-1)*MNP1-(J*(J-1))/2-J*KP+KQ DO 21 I=1,NCFGP2 21 HNP1(I+JJ)=STORE(I,J) C C READ BOUND-BOUND ELEMENTS INTO HNP1 C MP=(NCONHP*(MN2-NCONHP+1))/2 DO 24 I=1,NCFGP2 MO=MP+1 MP=MO+NCFGP2-I 24 READ(ITAPE) (HNP1(J),J=MO,MP) C C READ THE ASYMPTOTIC COEFFICIENTS (ARRAY CF EXPANDED IN RSCT) C 25 IF(LAMAX.EQ.0) GO TO 27 DO 26 I=1,NCHAN 26 READ(ITAPE2) ((CF(I,J,K),K=1,LAMAX),J=I,NCHAN) C N.B. OSU'95OCT8: IF(ICODE=23) K=1,MAX(LAMAX,3) C C CHECK THAT LRGL,NSPN,NPTY,NCFGP HAVE THE REQUIRED VALUES. C IF NOT, READ IN MORE DATA FROM TAPE OR CARDS. C 27 IF(MORE2.EQ.0) MORE=0 IF(INAST.NE.0) GO TO 28 LRGL=LRGL2 NSPN=NSPN2 NPTY=NPTY2 28 IF(LRGL.EQ.LRGL2.AND.NSPN.EQ.NSPN2.AND.NPTY.EQ.NPTY2) GO TO 30 IF(IPOLPH.LE.1) GO TO 29 WRITE(IWRITE,1024) MORE=0 23 IPLACE=-1 GO TO 64 29 IF(MORE2.GT.0) GO TO 9 22 WRITE(IWRITE,1002) MSKIP,INAST IF(INAST.NE.0) GO TO 23 WRITE(IWRITE,1004) STOP C C C PRINT TARGET STATE DETAILS C 30 NCFGP=NCFGP2 IF(NBUG5.EQ.0) GO TO 31 WRITE(IWRITE,1003) (LAT(I),ISAT(I),NCONAT(I),ENAT(I),I=1,NAST) WRITE(IWRITE,1009) (L2P(I),I=1,NCHAN) C C IF NEST=NAST, ADD ON THE EXTRA ENERGY TO EACH STATE AND TO THE C ASSOCIATED DIAGONAL ELEMENTS OF THE HAMILTONIAN MATRIX. C 31 IF(NEST.EQ.0) GO TO 40 WRITE(IWRITE,1003) MP=0 E0=ENAT(1) DO 39 I=1,NAST C IF (MSKIP.GT.1) GO TO 37 -- '95Nov18 (HES' EARLIER OWN GOAL): IF (MSKIP.GT.1 .AND. INAST.LE.0) GO TO 37 TEMP=(ENAT(I)-E0)*2. AST(I)=EST(I)-ENAT(I) C EXTENSION '90JUL1/5: OBS.ENERGY INPUT IN RYD ABOVE 1 OR IN CM**-1 IF(EST(1).NE.0.) GO TO 35 AST(I) = EST(I)/2. IF(EST(I)) 33,36,34 C .EQ.0 ENSURES UNCORRECTED TERM ENERGY IF NO OBS.DATA AVAILABLE 33 AST(I) =-AST(I)/109737.3 34 AST(I) = AST(I)-ENAT(I)+E0 35 ENAT(I)=ENAT(I)+AST(I) 36 WRITE(IWRITE,1005) LAT(I),ISAT(I),NCONAT(I),ENAT(I),AST(I),TEMP 37 IF(NCONAT(I).LE.0) GO TO 39 MO=MP+1 MP=MP+NCONAT(I) C LOOP OVER CHANNELS ASSOCIATED WITH EACH STATE IN THE H-MATRIX DO 38 M=MO,MP NQ=(M-1)*NRANG2 DO 38 J=1,NRANG2 JJ=((NQ+J-1)*(MN2-NQ-J+2))/2+1 38 HNP1(JJ)=HNP1(JJ)+AST(I) 39 CONTINUE C C C WRITE OUT FULL HAMILTONIAN MATRIX TO SCRATCH DISC C 40 IF(NOT1.GE.NRANG2) GO TO 50 REWIND IDISC1 DO 45 M=1,NCHAN MO=((M-1)*NRANG2*(2*MNP1-(M-1)*NRANG2+1))/2+1 MP=(M*NRANG2*(2*MNP1-M*NRANG2+1))/2 45 WRITE(IDISC1) (HNP1(I),I=MO,MP) MO=(NCONHP*(MN2-NCONHP+1))/2+1 MP=(MNP1*(MNP1+1))/2 WRITE(IDISC1) (HNP1(I),I=MO,MP) C C PRINT THE HAMILTONIAN MATRIX IF NBUG6=1 C 50 WRITE(IWRITE,1010) MNP1,NCHAN IF(NBUG6.NE.1) GO TO 62 C 15 STATEMENTS FROM OP-STGHS REPLACING 38 PREVIOUS STATEMENTS: M=0 51 K=M L=M+1 M=M+8 JJ=MIN(M,MNP1) FO8(1)=FL8(1) WRITE(IWRITE,1005) DO 53 I=1,JJ IF(I.LE.K) GO TO 52 FO8(1)=FL8(I-K) L=I 52 MO=((I-1)*(MN2-I))/2+L MP=MO+JJ-L 53 WRITE(IWRITE,FO8) (HNP1(J),J=MO,MP) IF(M.LT.MNP1) GO TO 51 C 62 WRITE(IWRITE,'(/28H CORRECT DATA READ FROM STG2)') IF (IPOLPH.GE.2) GO TO 63 IF(MORE.LT.2.AND.INAST.NE.0) REWIND ITAPE GO TO 64 63 IF(MSKIP.GT.IDMTST(29)) CALL RECOV1(29,MSKIP) C 64 RETURN END C*********************************************************************** SUBROUTINE WRITAP C C WRITES THE BASIC QUANTITIES TO THE STG3 TAPE C C IMPLICIT REAL*8(A-H,O-Z) DIMENSION ETEM( 200),NTEM( 200),KTEM( 500),NORDER( 500) COMMON/BASIC/ BSTO,RA,LRGL,NAST,NELC,NPTY,NRANG2,NSPN COMMON/CASES/ MORE,MSKIP,IPOLPH,ICODE,INAST, LRECW2,LRECW3,LWORD COMMON/CROSEC/CF( 500, 500, 8),ET( 500),ENAT( 200), * ISAT( 200),LAT( 200),L2P( 500) COMMON/CUPINT/MNP1,NCONHP,NCHAN, LAMAX,LAM COMMON/DISTAP/IDISC1,IDISC2,IDISC3,ITAPE1,ITAPE2,ITAPE3,ITAPE4 COMMON/RADIAL/LRANG1,LRANG2,MAXNHF( 61),MAXNLG( 61),NCOEFF,NZ COMMON/RCASES/NOT1,NOT2,NOT3,NCFGP COMMON/TARGET/EST( 200),AST( 200), COEFF(3, 61),NEST,NCONAT( 200) C C IF MSKIP.GT.1, STG32 IS BEING REPEATED WITH NEW LRGL, NSPN, ETC. C SO IT IS UNNECESSARY TO WRITE OUT THIS FIRST SET OF DATA AGAIN. C CALL ORDER(ENAT,NORDER,NAST,1) ITAPE=ITAPE3 IF(MSKIP.GT.1) GO TO 5 REWIND ITAPE WRITE(ITAPE) NELC,NZ,LRANG2,LAMAX,NAST,RA,BSTO DO 20 I=1,NAST I1 = NORDER(I) ETEM(I) = ENAT(I1) KTEM(I) = LAT (I1) 20 NTEM(I) = ISAT(I1) WRITE(ITAPE) (ETEM(I),I=1,NAST) WRITE(ITAPE) (KTEM(I),I=1,NAST) WRITE(ITAPE) (NTEM(I),I=1,NAST) WRITE(ITAPE) ((COEFF(I,L),I=1,3),L=1,LRANG2) C C THE FOLLOWING DATA DEPENDS ON LRGL, NSPN, NPTY C 5 ETOT = 0.0 NF = 0 DO 47 I=1,NAST I1 = NORDER(I) NTEM(I) = NCONAT(I1) IF(NCONAT(I).LE.0) GO TO 47 NS = NF + 1 NF = NF + NCONAT(I) DO 46 K=NS,NF 46 ET(K) = (ETOT-ENAT(I))*2. 47 CONTINUE CALL ORDER(ET,NORDER,NCHAN,-1) DO 50 I=1,NCHAN I1 = NORDER(I) 50 KTEM(I) = L2P(I1) C NB: MNP2 PASSED AS NOT3 THROUGH /RCASES/ TO $MAIN -- WE'90APR27: NOT3 = MIN(NOT1,NRANG2)*NCHAN + NCFGP WRITE(ITAPE) LRGL,NSPN,NPTY,NCHAN,NOT3,MORE WRITE(ITAPE) (NTEM(I),I=1,NAST) WRITE(ITAPE) (KTEM(I),I=1,NCHAN) RETURN END C*********************************************************************** SUBROUTINE VMUL(A,B,C,L,M,N) C C MATRIX MULTIPLICATION A*B = C, C OUTPUTS RESULTS FOR C(1:L,1:N) C C IMPLICIT REAL*8(A-C) DIMENSION A( 60,18000),B(18000,4000),C( 60,4000) CW--> IBM XA VERSION (INCIDENTALLY BANK CONFLICT FREE ON CRAY) DO 30 J=1,N DO 25 I=1,L 25 C(I,J) = 0.0 DO 30 K=1,M DO 30 I=1,L 30 C(I,J) = A(I,K)*B(K,J) + C(I,J) RETURN END C SUBROUTINE ORDER(EN,NORDER,NDIM,IUP) C IUP=1 FOR ASCENDING ENERGIES, IUP=-1 FOR DESCENDING ENERGIES C IMPLICIT REAL*8(A,E) DIMENSION EN(NDIM),NORDER(NDIM) A=1.E-9 2 A=A*10. E=A+1. IF(E.EQ.1.) GO TO 2 DO 7 K=1,NDIM J=K IF(K.EQ.1) GO TO 7 C E=EN(J)+IUP*1.0E-7 -- RUB'96AUG26 WHEN FAILING FOR -R4: C E=EN(J)*A(OLD) -- RUB'98NOV05 WHEN FAILING DEGENERACY: E = (SIGN(A,IUP*EN(K))+1.) * EN(K) DO 5 I=1,J-1 IF(J.LT.K) GO TO 3 N=NORDER(I) IF(IUP.GT.0.AND.E.GT.EN(N)) GO TO 5 IF(IUP.LT.0.AND.E.LT.EN(N)) GO TO 5 3 NORDER(J)=NORDER(J-1) J=J-1 5 CONTINUE 7 NORDER(J)=K RETURN END