      PROGRAM TESTCC                                  !NRB  20/04/05
      IMPLICIT REAL*8 (A-H,O-Z)
C
C ANALYSE TCCS WHEN LS CI EXPANSION .GT. LS CC EXPANSION.
C
C
      INCLUDE 'PARAM.IC'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
      PARAMETER (TWO=2.0)
C
      COMMON/BLOK2/LT(NMTM),LST(NMTM),LPT(NMTM),ENT(NMTM),
     1 FLT(NMTM),FST(NMTM),NJV(NMTM),FJT(NMTM,NMLV)
      COMMON/BLOK10/JLEV(NMLT),JPLEV(NMLT),ELEV(NMLT),EINL(NMLT),NLEV
      COMMON/BLOK11/ NVEC(NMLT),IVEC(NMTM,NMLT),CVEC(NMTM,NMLT)
      COMMON/NRBORD/LORDER(NMTM),JORDER(NMLT),NORDER(NMLT),IORDER
     X,ICORR(NMTM)
C
      NAMELIST/TCC/ESKPL,ESKPH,ECORR,NTLS
C
C STANDALONE OPERATION:
C
C USE ESKPL,ESKPH,ECORR TO INVESTIGATE THE EFFECT OF OMITTING TERMS,
C FROM THE LS CLOSE-COUPLING EXPANSION, ON THE IC CLOSE-COUPLING LEVEL
C EXPANSION THAT YOU HAVE ALREADY DEFINED (IN TCCDW.DAT) BY A STGJK RUN.
C TAG ANY ADDITIONAL TERMS NEGATIVE (COLUMN 1 OF TERM LIST) TO OMIT AS WELL.
C NTLS CAN BE USED INSTEAD OF ECOR TO DROP ALL TERMS ABOVE NTLS.
C THE TCCDW.DAT FILE READ BY STGICF WILL NORMALLY BE UNTOUCHED BY THE USER.
C IT WILL DETERMINE THE TERMS YOU OMITTED FROM THE LS CC EXPANSION SIMPLY
C BY COMPARING THE TERM ENERGIES IN TCCDW.DAT AGAINST THOSE IN TERM.DAT.
C
C ************* THE COMMENTS BELOW APPLY TO STGICF OPERATION ****************
C
C     READ THE NUMBER OF LS TERMS (NTLS) FROM UNIT5 AND, IF ITCC.NE.0,
C     READ THE NUMBER OF LS TERMS (NTLSTCC) INCLUDED IN THE TCCDW.DAT FILE.  
C     IF NTLSTCC IS GREATER THAN NTLS THEN, AFTER THE TCCS ARE
C     READ, ELIMINATE THOSE COMPONENTS ARISING FROM TERMS ABOVE THOSE
C     INCLUDED IN NTLS AND RENORMALIZE THE TERM-COUPLING
C     COEFFICIENTS - THIS IS THE DEFAULT OPERATION, NTLSRD0.EQ.0.
C
C     TO ALLOW FOR THE CASE OF CI TERMS INTERSPERSED WITH CC TERMS, THE
C     FOLLOWING OPTIONS FOR NTLSRD0 ARE SUPPORTED (THE USER MUST ADD
C     THIS TO LINE 1 OF THE TCCDW.DAT FILE FORMAT I5 AFTER 'LS TERMS').
C     NTLSRD=IABS(NTLSRD0) TERM ENERGIES ETC ARE READ FROM TCCDW.DAT.
C     NTLSRD MUST BE LARGE ENOUGH TO COVER ALL OF THE CC TERMS.
C     IF NTLSRD0 .GT. 0 THESE ENERGIES ARE COMPARED (AFTER BEING PUT
C     INTO ENERGY ORDER) WITH THOSE IN TERM.DAT. THOSE THAT DO NOT
C     MATCH ARE ASSUMED TO BE CORRELATION AND THE TERM NUMBER IS TAGGED 
C     NEGATIVE SO THAT THESE TCC COMPONENTS CAN BE ELIMINATED.
C     IF NTLSRD0 .LT. 0 THEN IT IS ASSUMED THAT THE USER HAS ALREADY
C     TAGGED THE (COLUMN 1) TERM NUMBERS NEGATIVE FOR THE CORRELATION 
C     TERMS WITHIN THE FIRST NTLSRD TERMS.
C     FOR NON-ZERO NTLSRD0 IT IS ASSUMED THAT ALL TERMS ABOVE NTLSRD
C     ARE CORRELATION AND THERE IS NO NEED TO TAG THEM SO.
C
C****************************************************************************
C
      OPEN(5,FILE='dtcc')
      OPEN(6,FILE='otcc',STATUS='UNKNOWN')
      OPEN(7,FILE='TCCDW.DAT',STATUS='OLD')
C
      NTLS=0
      ECORR=9999999.
      ESKPL=9999999.
      ESKPH=-1
C
      READ(5,TCC,END=1)
C
   1    IORDER=0
        DO I=1,NMTM
          LORDER(I)=I
        ENDDO
        DO I=1,NMLT
          JORDER(I)=I
        ENDDO
C
        READ(7,113) NTLSTCC,NTLSRD0
C
        NTLSRD=IABS(NTLSRD0)
        IF(NTLSRD.EQ.0)THEN
          IF(NTLS.EQ.0)THEN
            NTLS=NTLSTCC
            WRITE(6,206)
C            WRITE(*,206)
          ENDIF
          NTLSRD=NTLS
        ENDIF
        IF(NTLSRD.GT.NMTM) THEN
          WRITE(6,207) NMTM,NTLSRD
          STOP 'STOP TO INCREASE THE PARAMETER NMTM'
        END IF
C
C     READ INFORMATION ON TARGET LS TERMS & J LEVELS FROM UNIT 7
C
C     LST(I)--2S+1 FOR THE ITH TARGET TERM
C     LT(I)--TOTAL ANGULAR MOMENTUM OF ITH TARGET TERM
C     LPT(I)--PARITY OF ITH TARGET TERM (0-EVEN, 1-ODD)
C     ENT(I)--ENERGY OF ITH TARGET TERM IN RYDBERGS
C
C     JLEV--2J FOR LEVEL
C     JPLEV--PARITY OF LEVEL (0-EVEN,1-ODD)
C     ELEV--ENERGY OF LEVEL IN RYDBERGS
C
  202   READ(7,*)
        READ(7,*)
        DO I=1,NTLSRD
          READ(7,*) ICORR(LORDER(I)),LST(LORDER(I)),LT(LORDER(I))
     X             ,LPT(LORDER(I)),ENT(LORDER(I))
        END DO
        DO I=NTLSRD+1,NTLSTCC
          READ(7,*)
        ENDDO
        READ(7,*)
        READ(7,*) NLEV
        IF(NLEV.GT.NMLT) THEN
          WRITE(6,205) NMLT,NLEV
          STOP 'STOP TO INCREASE THE PARAMETER NMLT'
        END IF
        READ(7,*)
        READ(7,*)
        DO I=1,NLEV
          READ(7,*) IX,JLEV(JORDER(I)),JPLEV(JORDER(I))
     X             ,ELEV(JORDER(I))
        ENDDO
        IF(IORDER.EQ.0)THEN
          CALL ORDER(ENT,NORDER,NTLSRD,1)
          DO I=1,NTLSRD
            LORDER(NORDER(I))=I                      !REVERSE INDEX
          ENDDO
          CALL ORDER(ELEV,NORDER,NLEV,1)
          DO I=1,NLEV
            JORDER(NORDER(I))=I                      !REVERSE INDEX
          ENDDO
          REWIND(7)
          READ(7,*)
          IORDER=1
          GO TO 202
        ENDIF
C
        J=0
        DO I=1,NTLSRD
          IF(ENT(I).GT.ESKPL.AND.ENT(I).LT.ESKPH.OR.ENT(I).GT.ECORR)
     X       ICORR(I)=-IABS(ICORR(I))                 !TAG
          IF(ICORR(I).GT.0)THEN
            J=J+1
            ICORR(I)=J
          ENDIF
        ENDDO
C
C READ TCCS AND WRITE DIAGNOSTIC INFO
C
        CALL RDVEC(NTLSRD)
C
C
      STOP
C
  113 FORMAT(I5,9X,I5)
  205 FORMAT(/'****   THE PARAMETER NMLT MUST BE INCREASED FROM ',
     1       I3,' TO ',I3,'   ****')
  206  FORMAT('*** WARNING: NTLS RESET TO NTLSTCC; THIS IS *NOT* THE'
     X        ,' DEFAULT BEHAVIOUR OF STGICF ***'/'*** IF YOU USE ESKPL'
     X        ,', ESKPH YOU WILL NEED TO SET NTLSRD IN TCCDW.DAT ***')
  207 FORMAT(/'****   THE PARAMETER NMTM MUST BE INCREASED FROM ',
     1       I3,' TO ',I3,'   ****')
  208 FORMAT(/'****   THE PARAMETER NMLV MUST BE INCREASED FROM ',
     1       I3,' TO ',I3,'   ****')
  209 FORMAT(/'****   THE PARAMETER INJM MUST BE INCREASED FROM ',
     1       I3,' TO ',I3,'   ****')
  220 FORMAT(12X,'LS TERMS INCLUDED IN K-MATRICES')
  230 FORMAT(3X,I2,'.',3X,'2S+1=',I2,3X,'L=',I2,3X,'PARITY=',
     1       I2,3X,'ENERGY(RY)=',1PE15.6)
  250 FORMAT(///5X,'J-VALUES FOR EACH TERM')
  260 FORMAT(5X,'TERM ',I3,'.',7(5X,F5.1))
C
      END

C
C     ******************************************************************
C
      SUBROUTINE RDVEC(NTLSRD)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     READ THE TERM-COUPLING CONSTANTS AND STORE THEM
C
C
      INCLUDE 'PARAM.IC'
C
      PARAMETER (TZERO=0.0)
      PARAMETER (ONE=1.0)
C
      COMMON/BLOK2/LT(NMTM),LST(NMTM),LPT(NMTM),ENT(NMTM),
     1 FLT(NMTM),FST(NMTM),NJV(NMTM),FJT(NMTM,NMLV)
      COMMON/BLOK10/JLEV(NMLT),JPLEV(NMLT),ELEV(NMLT),EINL(NMLT),NLEV
      COMMON/BLOK11/ NVEC(NMLT),IVEC(NMTM,NMLT),CVEC(NMTM,NMLT)
      COMMON/NRBORD/LORDER(NMTM),JORDER(NMLT),NORDER(NMLT),IORDER
     X,ICORR(NMTM)
C
      DIMENSION IVECRD(NMTM),CVECRD(NMTM)
      DIMENSION CVMAXJ(NMLT),ICVMAXJ(NMLT),FNORM(NMLT)
C
C
      DO I=1,4
        READ(7,*)
      ENDDO
C
      ICVMAX=0
      JCVMAX=0
      CVMAX=TZERO
      JFMIN=0
      FNMIN=ONE
C
C     READ TERM COUPLING COEFFICIENTS
C
      DO 20 J=1,NLEV
C
      READ(7,*)
      READ(7,*) JX,NVECRD,(IVECRD(I),CVECRD(I),I=1,MIN(4,NVECRD))
C  130 FORMAT(2I5,4(I4,F11.7))
      IF(NVECRD.GT.NMTM)THEN
        WRITE(6,207) NMTM,NVECRD
        STOP 'STOP TO INCREASE THE PARAMETER NMTM'
      ENDIF
      IF(NVECRD.GT.4) THEN
        IMIN=1
   19   IMIN=IMIN+4
        IMAX=IMIN+3
        IF(IMAX.GT.NVECRD) IMAX=NVECRD
        READ(7,*) (IVECRD(I),CVECRD(I),I=IMIN,IMAX)
C  140   FORMAT(10X,4(I4,F11.7))
        IF(IMAX.LT.NVECRD) GO TO 19
      END IF
C
C     TEST TO DETERMINE IF ANY COMPONENTS OF THE TERM COUPLING
C     COEFFICIENT FOR THIS LEVEL ARISE FROM TERMS ABOVE NTLS.
C     IF NOT, SIMPLY STORE THE TERM-COUPLING COEFFIECIENTS; IF SO,
C     ELIMINATE THOSE COMPONENTS AND THEN RENORMALIZE THE TERM-
C     COUPLING COEFFICIENTS.
C
      JJ=JORDER(J)
      CVMAXJ(JJ)=TZERO
      ICVMAXJ(JJ)=0
C
          NVEC(JJ)=0
          FNORM(JJ)=TZERO
          DO 10 I=1,NVECRD
            IV=IVECRD(I)
            IF(IV.LE.NTLSRD) THEN
              IF(ICORR(LORDER(IV)).GT.0)THEN
                NVEC(JJ)=NVEC(JJ)+1
                IVEC(NVEC(JJ),JJ)=ICORR(LORDER(IV))
                FNORM(JJ)=FNORM(JJ)+CVECRD(I)**2
                CVEC(NVEC(JJ),JJ)=CVECRD(I)
                GO TO 10
              ENDIF
            END IF
                IF(ABS(CVECRD(I)).GT.CVMAXJ(JJ))THEN
                  CVMAXJ(JJ)=ABS(CVECRD(I))
                  ICVMAXJ(JJ)=IVECRD(I)
                ENDIF
                IF(ABS(CVECRD(I)).GT.CVMAX)THEN
                  CVMAX=ABS(CVECRD(I))
                  JCVMAX=JJ
                  ICVMAX=IVECRD(I)
                ENDIF
   10     CONTINUE
          FNORM(JJ)=SQRT(FNORM(JJ))
          IF(FNORM(JJ).LT.FNMIN)THEN
            FNMIN=FNORM(JJ)
            JFMIN=JJ
          ENDIF
          DO I=1,NVEC(JJ)
            CVEC(I,JJ)=CVEC(I,JJ)/FNORM(JJ)
          END DO
   20 CONTINUE
C
C     PRINT THE LEVEL ENERGIES AND TERM COUPLING COEFFICIENTS
C
        IF(JCVMAX.NE.0)WRITE(6,220)CVMAX,JCVMAX,ICVMAX
        IF(JFMIN.NE.0)WRITE(6,225)JFMIN,ONE/FNMIN
        DO J=1,NLEV
          IF(ICVMAXJ(J).NE.0)
     X       WRITE(6,235) J,ICVMAXJ(J),CVMAXJ(J),ONE/FNORM(J)
        ENDDO
        WRITE(6,200) NLEV
        WRITE(6,210)
        DO J=1,NLEV
          WRITE(6,230) J,JLEV(J),JPLEV(J),ELEV(J)
          WRITE(6,240) (IVEC(I,J),CVEC(I,J),I=1,NVEC(J))
        ENDDO
C
C     WRITE NEW TERM LIST AND OLD TERM NUMBER
C
        WRITE(6,245)
        DO I=1,NTLSRD
          IF(ICORR(I).GT.0)WRITE(6,250)ICORR(I),I
        ENDDO
C
      RETURN
C
  200 FORMAT(//5X,'NLEV=',I5)
  207 FORMAT(/'****   THE PARAMETER NMTM MUST BE INCREASED FROM ',
     1       I3,' TO ',I3,'   ****')
  210 FORMAT(/'THE LEVELS ARE:')
  220 FORMAT(/'THE ABS LARGEST TCC COMPONENT ZEROED-OUT IS:',F10.6/
     X'THIS OCCURRED FOR LEVEL',I4,'   FOR ORIGINAL TERM NO. CPT',I4)
  225 FORMAT(/'THE LARGEST RENORMALIZATION OF TCCS OCCURRED FOR'
     X,' LEVEL',I4,'   THE FACTOR BEING:',F10.6/)
  230 FORMAT(/I5,5X,'2J=',I5,5X,'PIE=',I5,5X,'ELEV=',F16.7,' RY')
  235 FORMAT('LEVEL',I4,':  LARGEST TCC ZEROED',I4,':  ',F10.6
     X       ,3X,'FNORM=',F10.6)
  240 FORMAT(4(I5,F11.7))
  245 FORMAT(//' TNEW',2X,' TOLD')
  250 FORMAT(I5,2X,I5)
C
      END
C
C     ******************************************************************
C
      SUBROUTINE ORDER(EN,NORDER,NDIM,IUP)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C
C     ------------------------------------------------------------------
C
C      RETURNS NORDER(I)=POINTER TO I-TH ENERGY IN EN ARRAY,
C      IUP=1 FOR ASCENDING ENERGIES, IUP=-1 FOR DESCENDING ENERGIES
C
C     ------------------------------------------------------------------
      DIMENSION EN(NDIM),NORDER(NDIM)
C     ------------------------------------------------------------------
      DO 40 K = 1,NDIM
        J = K
        J1 = J - 1
        IF (J1.EQ.0) GOTO 30
        E = EN(J) + IUP*1.0D-7
        DO 20 I = 1,J1
          IF (J.LT.K) GOTO 10
          N = NORDER(I)
          IF (IUP.GT.0 .AND. E.GT.EN(N)) GOTO 20
          IF (IUP.LT.0 .AND. E.LT.EN(N)) GOTO 20
   10     CONTINUE
          NORDER(J) = NORDER(J-1)
          J = J - 1
   20   CONTINUE
   30   NORDER(J) = K
   40 CONTINUE
C
      END
