CFTN7X,L,Q,S
C$CDS ON
C$FILES(0,3,24)
C$MSEG 6
      PROGRAM STRCULL
C
C     PROGRAM TO CULL STRENGTH OUTPUT
C
C     MASTER INPUT: NUMBER OF DIPOLE TYPES, NUMBER OF QUANTA, POSITION of J
C                   FILES FOR INPUT
C                   INITIAL VALUES AND A PRIORI ERRORS FOR PARAMETERS
C     EXPTL DATA INPUT: DATA TYPE IDENTIFIER, QUANTA,EXPTL VAL & ERR,
C                       ADDL. PARAMTERS
C     STRENGTH INPUT: STR, FREQ, QN
C
C     HIGH LEVEL PDL:
C         read master input
C         read in exptl data and fill quantum number list
C         DO FOR each dipole type
C             read strength file record
C             store if quantum number is in the list
C         END DO
C************************************************************************
C   DATA DEFINITIONS:
C         XTYP = EXPERIMENATL DATA SET (0=Stark)
C         PQNU,PQNL = POINTERS TO EXPERIMENTAL QUANTA FOR UPPER, LOWER STATE
C         XFQ = EXPERIMENTAL FREQUENCY (NOT USED IN CALCULATIONS)
C         EXVAL = EXPERIMENTAL INTENSITY OR STARK SHIFT
C         EXERR = EXPERIMENTAL ERROR IN EXVAL
C         EXPAR = INITIAL INTENSITY OR STARK FIELD
C         MQN = STARK M QUANTUM NUMBER
C         SVAL = DIRECTION COSINE MATRIX ELEMENTS
C************************************************************************
      IMPLICIT INTEGER*2 (I-N),REAL*8 (A-H,O-Z)
      PARAMETER (NDEXP=600,NDMU=4,NDPAR=NDMU+9,NDQN=999)
      PARAMETER (LUIN=90,LUOUT=91,LUAUX=92)
      INTEGER*2 PQNU(NDEXP),PQNL(NDEXP),
     +      QN(7,NDQN),QNX(12)
      CHARACTER*64 FNAME
      LOGICAL INSRT,NOSTARK
      INTEGER*2 FINDQN,IQNFMT
C READ FIRST CARD
      NQNF=3
      WRITE(*,*) ' Enter number of quanta per state '
      READ(*,*) NQNF
      NQNF1=NQNF+1
      NQNF2=NQNF+NQNF
C READ FILE FOR EXPTL DATA AND GET QUANTA
      WRITE(*,*) ' Enter input file for exptl. data',CHAR(7)
      READ(*,100) FNAME
 100  FORMAT(A)
      WRITE(*,*) 'OPENING: ',FNAME
      OPEN(LUAUX,FILE=FNAME,STATUS='OLD')
      NQN=0
      INSRT=.TRUE.
      NOSTARK=.TRUE.
      DO 10 NEXP=1,NDEXP
          READ(LUAUX,*,END=20) ITYP,(QNX(I),I=1,NQNF2)
          PQNU(NEXP)=FINDQN(INSRT,NQN,QNX,QN,NQNF)
          PQNL(NEXP)=FINDQN(INSRT,NQN,QNX(NQNF1),QN,NQNF)
          IF(ITYP.EQ.0) NOSTARK=.FALSE.
          WRITE(*,'(20I4)') NEXP,ITYP,
     +       PQNU(NEXP),PQNL(NEXP),(QNX(K),K=1,NQNF2)
  10      CONTINUE
      NEXP=NDEXP+1
C END FILE JUMP TARGET
  20  NEXP=NEXP-1
C READ FILE FOR DIRECTION COSINES
      INSRT=.FALSE.
 50       WRITE(*,*) ' Enter input file',CHAR(7)
          READ(*,100) FNAME
          OPEN(LUAUX,FILE=FNAME,STATUS='OLD',ERR=200)
          WRITE(*,*) 'OPENING: ',FNAME
          WRITE(*,*) ' Enter output file'
          READ(*,100) FNAME
          WRITE(*,*) 'OPENING: ',FNAME
          OPEN(LUOUT,FILE=FNAME,STATUS='UNKNOWN')
          LKTR=0
          NSVAL=0
C         while input available
   60         READ(LUAUX,'(2E15.4,I5,1X,12I2)',END=50)
     :               FQTMP,STMP,IQNFMT,QNX
              LKTR=LKTR+1
              IF(MOD(LKTR,100).EQ.0) THEN
                  WRITE(*,*) 'reading #',LKTR,' # SVAL =',NSVAL
                  IF(LKTR.GE.32000) LKTR=0
              ENDIF
              IPOS=FINDQN(INSRT,NQN,QNX,QN,NQNF)
              JPOS=FINDQN(INSRT,NQN,QNX(7),QN,NQNF)
              IF(IPOS+JPOS.EQ.0) GO TO 60
              IF(NOSTARK) THEN
                  IF(IPOS.EQ.0) GO TO 60
                  IF(JPOS.EQ.0) GO TO 60
                  DO 70 I=1,NEXP
                      IF(IPOS.NE.PQNU(I)) GO TO 70
                      IF(JPOS.EQ.PQNL(I)) GO TO 75
  70                  CONTINUE
                  GO TO 60
              ENDIF
  75          NSVAL=NSVAL+1
              WRITE(LUOUT,'(F15.4,E15.6,I5,1X,12I2)')
     :                 FQTMP,STMP,IQNFMT,QNX
              GO TO 60
 200  STOP
      END
      INTEGER*2 FUNCTION FINDQN(INSRT,NQN,QNX,QN,NQNF)
      IMPLICIT INTEGER*2 (A-Z)
      INTEGER*2 QNX(*),QN(7,*),JHASH(0:99)
      LOGICAL INSRT
      SAVE JHASH
      DATA JHASH/100*0/
C  JHASH points to the first element of QN with a given first quanta
C   subsequent elements pointed to by QN(7,..)
C
      INOW=JHASH( QNX(1) )
      IPREV=0
  5   IF(INOW.GT.0) THEN
          DO 20 K=2,NQNF
              IF(QN(K,INOW).NE.QNX(K)) THEN
                  IPREV=INOW
                  INOW=QN(7,IPREV)
                  GO TO 5
              ENDIF
  20          CONTINUE
C             match found
          FINDQN=INOW
          RETURN
      ENDIF
      IF(INSRT) THEN
          NQN=NQN+1
          IF(IPREV.EQ.0) THEN
              JHASH(QNX(1))=NQN
          ELSE
              QN(7,IPREV)=NQN
          ENDIF
          DO 40 K=1,NQNF
   40         QN(K,NQN)=QNX(K)
          QN(7,NQN)=0
          FINDQN=NQN
      ELSE
          FINDQN=0
      ENDIF
      RETURN
      END