program graspadf04
C
C      Written by T G Lee and Connor Ballance
C
C
C      Utility code for the generation of type3 Maxwellian 
C      averaged effective collsions strengths. To be subsequently 
C      used by grasprad 
C
C
C      Assuming that grasp0 has been run with IOP=3
C      to produce configs and term specification. A
C      adasexj.in file is produced for adaexj.f
C
C      Then ANG 6 10
C
C
C      NAMELIST OPTIONS:  NLEV   (number of levels)
C                         NRCSF  (number of non-relativistic configurations)
C                         NORB   ( Number of highest orbitals if listed in 
C                                  increasing n and l. Not necessarily 
C                                  the highest orbital in your model)
C
C      KOUNT= number of closed orbitals
C
C
C	  
	  implicit real*8(a-h,o-z)
	  character*32 COREORB
	  CHARACTER*1 BIGL(0:14),SMAL(0:14),NUMB(0:14),CHAR1,CHAR1B
	  CHARACTER*2 ORBS(1:45),BORBS(1:45),NUMB2(0:15)
	  CHARACTER*2 CHAR2A,CHAR2B,CHAR2C,CHAR2D,CHAR2E,CTMP
          CHARACTER*3 A3A,A3B,A3C,A3D,A3E,CONF1
	  CHARACTER*4 CFOUR,CHAR4
	  CHARACTER*5 CFIVE
          CHARACTER*6 CONF2
          CHARACTER*9 CONF3
          CHARACTER*10 CHAR10
          CHARACTER*12 CONF4
          CHARACTER*14 COREORBB
          CHARACTER*15 CHA,BLANKS,CHA1
	  CHARACTER*15,allocatable :: CONF(:)
	  CHARACTER*37 MARKER1
          CHARACTER*44 MARKERLS
	  INTEGER :: IFILLOPEN(45)
	  INTEGER :: IFILLED(40),IOPEN(120)
	  INTEGER :: JPAR(2000),NUMCSF(2000)
      INTEGER,allocatable :: NDOMSPIN(:),kount1array(:),iopenarray(:,:)
     X                       ,iorbmap(:,:),icsf(:) 
      REAL*8,allocatable :: ENAT(:),LSMIX(:)
          REAL*8 :: JLEVEL(2000)
	  CHARACTER*1,allocatable :: DOMTERM(:)
      NAMELIST/GRASPINP/NLEV,NRCSF,NORB	  
C
      DATA  convcm/1.097373d+05/
      DATA (SMAL(I),I=0,14)/'s','p','d','f','g','h','i','k'
     X                         ,'l','m','n','o','p','q','*'/
      DATA (BIGL(I),I=0,14)/'S','P','D','F','G','H','I','K'
     X                         ,'L','M','N','O','P','Q','*'/
      DATA (NUMB(I),I=0,14)/'0','1','2','3','4','5','6','7'
     X                         ,'8','9','A','B','C','D','E'/
      DATA (NUMB2(I),I=0,15)/'0 ','1 ','2 ','3 ','4 ','5 ','6 ','7 '
     X                      ,'8 ','9 ','10','11','12','13','14','15'/
      DATA (ORBS(i),i=1,45)/'1s','2s','2p','3s','3p','3d','4s'
     X                     ,'4p','4d','4f','5s','5p','5d','5f'
     X                     ,'5g','6s','6p','6d','6f','6g','6h'		     
     X                     ,'7s','7p','7d','7f','7g','7h','7i'
     X			   ,'8s','8p','8d','8f','8g','8h','8i'
     X			   ,'8j','9s','9p','9d','9f','9g','9h'
     X			   ,'9i','9j','9k'/
      DATA(BORBS(I),I=1,45)/'1S','2S','2P','3S','3P','3D','4S'
     X                     ,'4P','4D','4F','5S','5P','5D','5F'
     X                     ,'5G','6S','6P','6D','6F','6G','6H'		     
     X                     ,'7S','7P','7D','7F','7G','7H','7I'
     X			   ,'8S','8P','8D','8F','8G','8H','8I'
     X			   ,'8J','9S','9P','9D','9F','9G','9H'
     X			   ,'9J','9I','9K'/
      DATA(IFILLOPEN(I),I=1,45)/2,2,6,2,6,10,2,6,10,14,2,6,10,14,18,
     X                           2,6,10,14,18,22,2,6,10,14,18,22,26,
     X                           2,6,10,14,18,22,26,30,2,6,10,14,18,
     X                           22,26,30,34/  
C
C
C
        OPEN(9,file='dgrasp',form='formatted',status='unknown')
        OPEN(10,file='GRASP.OUT',form='formatted',status='unknown')
	OPEN(11,file='adasexj.in',form='formatted',status='unknown')
        OPEN(12,file='table.tex',form='formatted',status='unknown')
C
C
        BLANKS='               '
        NLEV=0
	NRCSF=0
        NORB=0
C
C       READ NAMELIST .... EVERYTHING NEEDS TO BE SET
C
C
        READ(9,graspinp)
C
        if((NLEV.eq.0).or.(NRCSF.eq.0).or.(NORB.eq.0))then
        write(0,*)'NAMELIST VARIABLES MUST BE SET !!!!!!'
        stop
        endif
C
C       HEADER FOR ADASEXJ.IN file
C
        REWIND(11)
	WRITE(11,222)' &ADASEX NLEVS=',NLEV,'/'
 222    FORMAT(A15,I4,A1)	
C
C
C
C	
C
C       MAIN ALLOCATES for ARRAYS
C	
	allocate(NDOMSPIN(nlev),domterm(nlev))
	allocate(kount1array(nlev),iopenarray(nlev,norb))
	allocate(iorbmap(nlev,norb))
        allocate(ENAT(nlev))
        allocate(ICSF(nlev))
	allocate(CONF(nlev))
C
C
C       Initialise
C
C
        DO III=1,NLEV
        NDOMSPIN(III)=0
        kount1array(III)=0
        ICSF(III)=0
         DO IIJ=1,norb
         iopenarray(III,IIJ)=0
         iorbmap(III,IIJ)=0
         ENDDO
        ENAT(III)=0.0d0
       ENDDO
C
C       ASSUMING THAT INSTRUCTIONS HAVE BEEN FOLLOWED AND 
C       THE IOP=3 OPTION INVOKED  ... LOOKING FOR CLOSED 
C       SHELL LINE
C
C       Look for NFOUT output
C       
C       
  20    READ(10,1005)COREORBB
        IF(COREORBB.eq.' routine NROUT')THEN
	WRITE(0,*)'FOUND NON REL CONFIGS'
        READ(10,1005)COREORBB
        READ(10,1005)
        READ(10,1005)COREORBB
        READ(10,1005)COREORBB    !Dummy reads to position file
	ELSE
C        WRITE(0,*)COREORBB
	GOTO 20
	ENDIF
C
C
C
	KOUNT=0
	do II=1,40
  	READ(10,1010)(IFILLED(I),I=1,II)
	KOUNT=KOUNT+1
C	write(0,1010)KOUNT,(IFILLED(I),I=1,II)
	if(IFILLED(KOUNT).eq.0)then
	KOUNT=KOUNT-1
	goto 30
        endif
C
       IF((KOUNT.eq.10).and.(IFILLED(10).ne.0))then
       goto 31
       endif
	BACKSPACE(10)
	enddo
C
C      For the really heavy systems in which the 4f is filled
C      start at the 5s to see if it is filled
C
  31   CONTINUE
C
        do II=11,40
        READ(10,1015)(IFILLED(I),I=11,II)
        KOUNT=KOUNT+1
C        write(0,1015)KOUNT,(IFILLED(I),I=11,II)
        if(IFILLED(KOUNT).eq.0)then
        KOUNT=KOUNT-1
        READ(10,1000)COREORB          ! extra  dummy line
        goto 30
        endif
        BACKSPACE(10)
        enddo
C
  30    continue
C         write(0,*)KOUNT,(IFILLED(I),I=1,KOUNT)
C         write(0,1020)'NON REL. CLOSED SHELLS = ',(ORBS(I),I=1,KOUNT)
C
C       CLOSED SHELLS IDENTIFIED  ... DEFINE OPEN
C
C
        DO JJ=1,5
	READ(10,1000)COREORB
	ENDDO          ! 5 dummy reads to start of CSF term spec
C
C
        DO JJ=1,NLEV
	READ(10,1030)CFOUR,IDUM
	READ(10,1000)COREORB                 ! dummy read
C
C      The following section is a pretty ugly hack
C      where i diliberately keep re-reading till 
C      i fall off the end of the line, as I do not 
C      know in advance how many open shells a printed 
C      configuration will have.
C
C
        KOUNT1=0
	do II=3,120,3   !hopefully never more than 40 open shells
  	READ(10,*,iostat=ios)(IOPEN(I),I=1,II)
C	write(0,*)'ios=',ios
	if(ios.ne.0)goto 50
C 	write(0,*)(IOPEN(III),III=1,II)
	KOUNT1=KOUNT1+1                 ! number of open shells
	NDOMSPIN(JJ)=IOPEN(II)
C        write(0,*)'NUMBER OF OPEN SHELLS=',KOUNT1
	BACKSPACE(10)
	enddo
  50    continue
C
C
C
        BACKSPACE(10)
        kount1array(JJ)=KOUNT1	
C
C       Now  i know ......
C       
C
C       GRASP only outputs the last 4 open shells
C
C       IDENTIFY THE OPEN ORBITALS
C
C    
C
C        BACKSPACE(10)
	if(KOUNT1.eq.0)READ(10,1000)COREORB      
        if(KOUNT1.eq.1)READ(10,2000)DOMTERM(JJ)
        if(KOUNT1.eq.2)READ(10,2010)DOMTERM(JJ)
        if(KOUNT1.eq.3)READ(10,2020)DOMTERM(JJ)
        if(KOUNT1.eq.4)READ(10,2030)DOMTERM(JJ)
	if(KOUNT1.eq.5)READ(10,2040)DOMTERM(JJ)
C
c         write(0,*)JJ,NDOMSPIN(JJ),DOMTERM(JJ),KOUNT1
C
C
        BACKSPACE(10)
C
        if(KOUNT1.eq.0)then
	 READ(10,1000)COREORB      ! dummy read  only core
	endif
C	 
        if(KOUNT1.eq.1)then
	READ(10,5000)CHAR2A
	 DO KK=1,NORB
	 IF(CHAR2A.eq.BORBS(KK))then
	 IORBMAP(JJ,1)=KK
	 ENDIF
	 ENDDO
C
	INDEX=IORBMAP(JJ,1)
	iopenarray(JJ,INDEX)=IOPEN(1)
c        write(0,*)JJ,KOUNT1,(iopenarray(JJ,IIII),IIII=1,NORB)	 
	endif
C	
        if(KOUNT1.eq.2)then
	READ(10,5010)CHAR2A,CHAR2B
	 DO KK=1,NORB
	 IF(CHAR2A.eq.BORBS(KK))then
	 IORBMAP(JJ,1)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,1)
        iopenarray(JJ,INDEX)=IOPEN(1)
C	 
	 DO KK=1,NORB
	 IF(CHAR2B.eq.BORBS(KK))then
	 IORBMAP(JJ,2)=KK
	 ENDIF
         ENDDO
	INDEX=IORBMAP(JJ,2)
	iopenarray(JJ,INDEX)=IOPEN(4)
c        write(0,*)JJ,KOUNT1,(iopenarray(JJ,IIII),IIII=1,NORB)	
C        write(0,*)JJ,IORBMAP(JJ,1),IORBMAP(JJ,2)
	endif
C	
        if(KOUNT1.eq.3)then
	READ(10,5020)CHAR2A,CHAR2B,CHAR2C
C	write(0,5020)CHAR2A,CHAR2B,CHAR2C
	 DO KK=1,NORB
	 IF(CHAR2A.eq.BORBS(KK))then
	 IORBMAP(JJ,1)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,1)
        iopenarray(JJ,INDEX)=IOPEN(1)
C	 
	 DO KK=1,NORB
	 IF(CHAR2B.eq.BORBS(KK))then
	 IORBMAP(JJ,2)=KK
	 ENDIF
	 ENDDO	
        INDEX=IORBMAP(JJ,2)
        iopenarray(JJ,INDEX)=IOPEN(4)
C
	 DO KK=1,NORB
	 IF(CHAR2C.eq.BORBS(KK))then
	 IORBMAP(JJ,3)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,3)
        iopenarray(JJ,INDEX)=IOPEN(7)
C
c        write(0,*)JJ,KOUNT1,(iopenarray(JJ,IIII),IIII=1,NORB)
	endif
C	
        if(KOUNT1.eq.4)then
	READ(10,5030)CHAR2A,CHAR2B,CHAR2C,CHAR2D
	 DO KK=1,NORB
	 IF(CHAR2A.eq.BORBS(KK))then
	 IORBMAP(JJ,1)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,1)
        iopenarray(JJ,INDEX)=IOPEN(1)
C	 
	 DO KK=1,NORB
	 IF(CHAR2B.eq.BORBS(KK))then
	 IORBMAP(JJ,2)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,2)
        iopenarray(JJ,INDEX)=IOPEN(4)	
C
	 DO KK=1,NORB
	 IF(CHAR2C.eq.BORBS(KK))then
	 IORBMAP(JJ,3)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,3)
        iopenarray(JJ,INDEX)=IOPEN(7)
C
	 DO KK=1,NORB
	 IF(CHAR2D.eq.BORBS(KK))then
	 IORBMAP(JJ,4)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,4)
        iopenarray(JJ,INDEX)=IOPEN(10)
C
c        write(0,*)JJ,KOUNT1,(iopenarray(JJ,IIII),IIII=1,NORB)
	endif
C
        if(KOUNT1.eq.5)then
	READ(10,5040)CHAR2A,CHAR2B,CHAR2C,CHAR2D,CHAR2E
	 DO KK=1,NORB
	 IF(CHAR2A.eq.BORBS(KK))then
	 IORBMAP(JJ,1)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,1)
        iopenarray(JJ,INDEX)=IOPEN(1)
C	 
	 DO KK=1,NORB
	 IF(CHAR2B.eq.BORBS(KK))then
	 IORBMAP(JJ,2)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,2)
        iopenarray(JJ,INDEX)=IOPEN(4)	
C
	 DO KK=1,NORB
	 IF(CHAR2C.eq.BORBS(KK))then
	 IORBMAP(JJ,3)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,3)
        iopenarray(JJ,INDEX)=IOPEN(7)
C
	 DO KK=1,NORB
	 IF(CHAR2D.eq.BORBS(KK))then
	 IORBMAP(JJ,4)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,4)
        iopenarray(JJ,INDEX)=IOPEN(10)
C
	 DO KK=1,NORB
	 IF(CHAR2E.eq.BORBS(KK))then
	 IORBMAP(JJ,5)=KK
	 ENDIF
	 ENDDO
        INDEX=IORBMAP(JJ,5)
        iopenarray(JJ,INDEX)=IOPEN(13)	
C
c        write(0,*)JJ,KOUNT1,(iopenarray(JJ,IIII),IIII=1,NORB)
	endif
C       A couple of dummy reads to position ourselves
C		
	READ(10,1000)COREORB
	READ(10,1000)COREORB  
C
        ENDDO
C
C
C
C       FINISHED extracting CSF configs, & dominant TERM info
C
C       Next section extracts energy levels, and J values
C       for a non QED/Breit DF case  
C
C       the mapping in ICSF  is important
C
        do II=1,10000000
	read(10,2222,end=51)marker1
C        write(0,*)marker1
        if(marker1.eq.' eigenenergies relative to the lowest')then
	write(0,*)' FOUND ENERGY LEVELS'
	  do III=1,4
	  read(10,2223)char1
	  enddo              ! should be at top of energy levels
	goto 52
	endif
	if(II.eq.10000000)then
	write(0,*)'over 10000000 lines of input and cannot find levels?'
	stop
	endif
	enddo
C
  51    continue
C
        write(0,*)'Ran off end of file while looking for ENERGY LEVELS'
        write(0,*)'stopping ........................'
        stop  
C
  52    continue
C
C  
          do II=1,nlev
	  read(10,2224)idum1,idum2,char1,char4,idum3,tmp1,tmp2,tmp3
C	  write(0,2224)idum1,idum2,char1,char4,idum3,tmp1,tmp2,tmp3
          NUMCSF(II)=idum3
C
C	  
	  if(char4.eq.'even')then
	  JPAR(II)=0
	  else
	  JPAR(II)=1
	  endif
C
          JLEVEL(II)=dble(idum2)
          if(char1.eq.'/')JLEVEL(II)=JLEVEL(II)/2.0d0
          ICSF(II)=idum3
C
          ENAT(II)=tmp3
C	  write(0,*)NUMCSF(II),JLEVEL(II),JPAR(II),ENAT(II)         	  	  
	  enddo	 
C
          allocate(LSMIX(NLEV))
C
C
C         Start to look for LS CSF mapping 
C
  54      READ(10,2225)MARKERLS
C          write(20,*)MARKERLS
      if(markerls.eq.' >>>> eigenvectors transformed from jj to LS')then
           DO II=1,6
            READ(10,2225)MARKERLS
           ENDDO
          continue
          else
          goto 54
          endif
C
          DO II=1,NLEV
 55        READ(10,*)idumz
c           write(0,*)'idumz=',idumz,II
           if(idumz.eq.II)then
           backspace(10)
        READ(10,2226)idumz,NDOMSPIN(II),DOMTERM(II),idum1,char4,ICSF(II)
C        write(0,2226)idumz,NDOMSPIN(II),DOMTERM(II),idum1,char4,ICSF(II)
C        READ(10,2226)idumz,NDOMSPIN(II),DOMTERM(II),char10
C     X               ,ICSF(II)
C     X               ,LSMIX(II)
c        write(0,2226)idumz,NDOMSPIN(II),DOMTERM(II),char10
c     X               ,ICSF(II)
c     X               ,LSMIX(II)
            else
            goto 55
           endif
          ENDDO
C 2226     FORMAT(1X,I3,2X,I1,2X,A1,A10,2X,I3,2X,F6.3) 
 2226     FORMAT(I5,I3,2X,1A,I2,4X,A4,I6)
C

C         START TO FORM configurations for adasexj.in
C
C         Only 5 possible cases
C
          DO I=1,NLEV
C            write(0,*)'kount1array',kount1array(ICSF(I))
C
            if(kount1array(ICSF(I)).eq.0)then
            write(0,*)'NO OPEN SHELLS'
            endif
C
            if(kount1array(ICSF(I)).eq.1)then
            CTMP=ORBS(IORBMAP(ICSF(I),1))
            A3A=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
            CONF1=A3A
C            write(0,FMT='A8,I4,1X,A3')'get here',ICSF(I),CONF1
C         write(0,*)IORBMAP(ICSF(I)),iopenarray(icsf(I),IORBMAP(ICSF(I)))
C            write(0,FMT='I4,1X,A3')I,A3A
            CHAR1=NUMB(NDOMSPIN(I))	    
	    CONF(ICSF(I))=trim(CONF1)//'('//CHAR1//DOMTERM(I)//')'   
C         write(11,4000)trim(CONF1)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
            endif
C
            if(kount1array(ICSF(I)).eq.2)then
            CTMP=ORBS(IORBMAP(ICSF(I),1))
            A3A=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
            CTMP=ORBS(IORBMAP(ICSF(I),2))
            A3B=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)))
            CONF2=A3A//A3B
C             write(0,*)'get here2',ICSF(I)
C             write(0,FMT='I4,2(A3,1X)')I,A3A,A3B
            CHAR1=NUMB(NDOMSPIN(I))
	    CONF(ICSF(I))=trim(CONF2)//'('//CHAR1//DOMTERM(I)//')'
C         write(11,4000)trim(CONF2)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
            endif
C
            if(kount1array(ICSF(I)).eq.3)then
            CTMP=ORBS(IORBMAP(ICSF(I),1))
            A3A=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
            CTMP=ORBS(IORBMAP(ICSF(I),2))
            A3B=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)))
            CTMP=ORBS(IORBMAP(ICSF(I),3))
            A3C=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),3)))
            CONF3=A3A//A3B//A3C
C            write(0,3335)CONF3
            CHAR1=NUMB(NDOMSPIN(I))
	    CONF(ICSF(I))=trim(CONF3)//'('//CHAR1//DOMTERM(I)//')'
C	 write(11,4000)trim(CONF3)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
            endif
C
C           IN THE CASE OF 4 OPEN SHELLS, SOME ATTEMPT IS MADE 
C           TO REDUCE CONFIGURATION definition size.
C
C           1.  if only 1 electron     3p  instead of 3p1
C
C           2.  remove first orbital from description if full 
C
C
            if(kount1array(ICSF(I)).eq.4)then
C            if(iopenarray(ICSF(I),1).eq.1)A3A=ORBS(IORBMAP(ICSF(I),1))
C       if(iopenarray(ICSF(I),1).eq.ifillopen(iopenarray(ICSF(I),1)))then
C            A3A='   '
C        endif
            CTMP=ORBS(IORBMAP(ICSF(I),1))
            A3A=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)).eq.1)then
            A3A=CTMP
            endif
C
C            write(0,*)I,iopenarray(ICSF(I),IORBMAP(ICSF(I),1))
C          write(0,*)I,ifillopen(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)).eq.
     X    ifillopen(iopenarray(ICSF(I),IORBMAP(ICSF(I),1))))then
            A3A='   '
            endif
C 
            CTMP=ORBS(IORBMAP(ICSF(I),2))
            A3B=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)).eq.1)then
            A3B=CTMP
            endif
C
            CTMP=ORBS(IORBMAP(ICSF(I),3))
            A3C=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),3)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),3)).eq.1)then
            A3C=CTMP
            endif
C
            CTMP=ORBS(IORBMAP(ICSF(I),4))
            A3D=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),4)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),4)).eq.1)then
            A3D=CTMP
            endif
C
C
C
C
C
            CONF4=TRIM(A3A)//TRIM(A3B)//TRIM(A3C)//TRIM(A3D)        !only 15 char space
C            CONF3=A3B//A3C//A3D
            CHAR1=NUMB(NDOMSPIN(I))
	    CONF(ICSF(I))=trim(CONF4)//'('//CHAR1//DOMTERM(I)//')'    
C         write(11,4000)trim(CONF4)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
C	 write(11,4000)trim(CONF3)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
            endif
C
            if(kount1array(ICSF(I)).eq.5)then
C            if(iopenarray(ICSF(I),1).eq.1)A3A=ORBS(IORBMAP(ICSF(I),1))
C       if(iopenarray(ICSF(I),1).eq.ifillopen(iopenarray(ICSF(I),1)))then
C            A3A='   '
C        endif
            CTMP=ORBS(IORBMAP(ICSF(I),1))
            A3A=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)).eq.1)then
            A3A=CTMP
            endif
C
C            write(0,*)I,iopenarray(ICSF(I),IORBMAP(ICSF(I),1))
C          write(0,*)I,ifillopen(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)))
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),1)).eq.
     X    ifillopen(iopenarray(ICSF(I),IORBMAP(ICSF(I),1))))then
            A3A='   '
            endif
C 
            CTMP=ORBS(IORBMAP(ICSF(I),2))
            A3B=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)).eq.1)then
            A3B=CTMP
            endif
C
C         write(0,*)IORBMAP(ICSF(I),2)
C         write(0,*)IFILLOPEN(I),iopenarray(ICSF(I),IORBMAP(ICSF(I),2))
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),2)).eq.
     X         IFILLOPEN(IORBMAP(ICSF(I),2)))then
            A3B='   '
            endif

C
            CTMP=ORBS(IORBMAP(ICSF(I),3))
            A3C=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),3)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),3)).eq.1)then
            A3C=CTMP
            endif
C
            CTMP=ORBS(IORBMAP(ICSF(I),4))
            A3D=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),4)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),4)).eq.1)then
            A3D=CTMP
            endif
C
            CTMP=ORBS(IORBMAP(ICSF(I),5))
            A3E=CTMP//NUMB(iopenarray(ICSF(I),IORBMAP(ICSF(I),5)))
C
            if(iopenarray(ICSF(I),IORBMAP(ICSF(I),5)).eq.1)then
            A3E=CTMP
            endif
C
C
C
C
            CONF4=TRIM(A3A)//TRIM(A3B)//TRIM(A3C)//TRIM(A3D)//TRIM(A3E)        !only 15 char space
C            CONF3=A3B//A3C//A3D
            CHAR1=NUMB(NDOMSPIN(I))
	    CONF(ICSF(I))=trim(CONF4)//'('//CHAR1//DOMTERM(I)//')'    
C         write(11,4000)trim(CONF4)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
C	 write(11,4000)trim(CONF3)//'('//CHAR1//DOMTERM(I)//')',
C     X                 REAL(JLEVEL(I)),ENAT(I)*convcm,I
            endif
C
C
            ENDDO
C
C
           DO III=1,NLEV
           CHAR1=NUMB(NDOMSPIN(III))
           CHAR1B=DOMTERM(III)
           CHA=trim(CONF(ICSF(III))//'('//CHAR1//CHAR1B//')')
           ITMP=15-LEN(trim(CHA))
      write(11,4000)BLANKS(1:ITMP)//trim(CHA)
     X                 ,JLEVEL(III),ENAT(III)*convcm,III
C
C
C      I have been kind and produced a table for your paper.
C      (see table.tex)   uncomment for use
C
c      write(12,4005)III,BLANKS(1:ITMP+4)//trim(CHA(1:11))
c     X                 ,NDOMSPIN(III)
c     X                 ,DOMTERM(III),LSMIX(III)
c     X                 ,JLEVEL(III),ENAT(III)
	   ENDDO          
C
C
C          CREDITS and DETAILS of the CALCULATION
C
          write(11,FMT='(A5)')'NAME:'
          write(11,FMT='(A5)')'DATE:'
          write(11,FMT='(A72)')
          write(11,FMT='(A72)')
          write(11,FMT='(A72)')
          write(11,FMT='(A50)')'ENTER DETAILS OF CALCULATION'
          write(11,FMT='(A72)')
          write(11,FMT='(A72)')
          write(11,FMT='(A72)')
          write(11,FMT='(A1)')'.'
C
          write(0,*)'successful run ... i hope'
C	
C
 1000   FORMAT(A32)
 1005   FORMAT(A14)
 1010   FORMAT(5I6,1I7,2I6,2I7)
 1015   FORMAT(I4,I6,4I7,2I6,4I7,2I6,5I7,2I6,6I7,2I6,7I7)
 1020   FORMAT(A25,44(A2,1X))
 1030   FORMAT(A4,I5)
 1050   FORMAT (/1X,4(6X,A2,10X))
 1040   FORMAT(1X,3I4,4X)
 2000   FORMAT(13X,A1)
 2010   FORMAT(29X,A1)
 2020   FORMAT(45X,A1)
 2030   FORMAT(61X,A1)
 2040   FORMAT(77X,A1)
C
 2222   FORMAT(A37)
 2223   FORMAT(A72)
 2224   FORMAT(I5,1X,I5,1A,3X,A4,I7,2X,F5.3,3X,E16.9,E16.9) 
 2225   FORMAT(A44)
C
 3333   FORMAT(A5)
 3334   FORMAT(A10)
 3335   FORMAT(A15)
 3336   FORMAT(A20)
 3337   FORMAT(A25)
C
 4000 format(a15,f5.1,f11.0,i5)
 4005 format(I5,'  & $',a15,'$ & $','^',I1,A1,'(',F5.3,')',
     X       '$ &  ',F3.1,'  &  ',
     X       f11.3,'  ','/','/')
 4010 format(I4,5X,a16,f5.1,f11.3,i5) 
C
 5000   FORMAT(2X,A2)
 5010   FORMAT(2X,A2,14X,A2)
 5020   FORMAT(2X,A2,14X,A2,14X,A2)
 5030   FORMAT(2X,A2,14X,A2,14X,A2,14X,A2)
 5040   FORMAT(2X,A2,14X,A2,14X,A2,14X,A2,14X,A2)		  
        end