PROGRAM XTRCTUPS                                        ! 27/10/04
      IMPLICIT REAL*8(A-H,O-Z)
C
C     EXTRACT AN UPSILON FROM A STANDARD ADAS ADF04 FILE (TYPE 1 or 3)
C     N.B. A STANDARD FILE HAS .LE. 20 TEMPS.
C 
      PARAMETER (NTMP=20)
      PARAMETER (RYD=.15789E6)
      REAL*8 MANT(NTMP+1)
      DIMENSION IEXP(NTMP+1),TEMP(NTMP)
C
      OPEN(1,FILE='adf04',STATUS='OLD')
c     OPEN(7,FILE='upsout',STATUS='UNKNOWN')
C
      WRITE(*,*)'ENTER TRANSITION REQUIRED'
      READ(*,*)IT1,IT2
C
      READ(1,*)
      DO I=1,10000
        READ(1,101)LEV,E
 101    FORMAT(I5,30X,F16.0)
        IF(LEV.EQ.-1)GO TO 20
        NLEV=LEV
        IF(I.EQ.ABS(IT1))E1=E
        IF(I.EQ.ABS(IT2))E2=E
      ENDDO
C
  20  DE=(E2-E1)/109737.43
      WRITE(6,100)IT1,ABS(IT2),DE
 100  FORMAT('#',I3,' -',I4,' TRANSITION, ENERGY=',F12.6)
C
      IF(IT2.GT.0)READ(1,200)DUM,ITYPE,(MANT(I),IEXP(I),I=1,NTMP)
 200  FORMAT(F5.2,I5,6X,21(F5.2,I3))
      IF(IT2.LT.0)READ(1,201)(MANT(I),I=1,NTMP)
 201  FORMAT(17X,21(E9.2))
C
      DO I=1,NTMP
        TEMP(I)=MANT(I)
        IF(IT2.GT.0)TEMP(I)=TEMP(I)*10**IEXP(I)
        IF(MANT(I).EQ.0.0)THEN
          NTEMP=I-1
          GO TO 30
        ENDIF
      ENDDO
      NTEMP=NTMP
C
  30  N=0             !LAZY
      IF(IT1.LT.0)THEN
        IT1=-IT1
        IELAS=0
      ELSE
        IELAS=1
      ENDIF
      DO I=1,IT1-IELAS
        DO J=I+IELAS,NLEV
          N=N+1
        ENDDO
      ENDDO
      DO J=IT1+1,ABS(IT2)
        N=N+1
      ENDDO
      N=N-1
C
 35   DO NN=1,N
        READ(1,*,END=500)J,I
        IF(I.EQ.IT1.AND.J.EQ.ABS(IT2))THEN
          BACKSPACE(1)
          GO TO 40
        ENDIF
        IF(J.LE.0)GO TO 36
      ENDDO
C
  36  IF(J.LE.0)THEN
        WRITE(*,*)'REQUESTED TRANSITION NOT FOUND ON FILE...'
        STOP
      ENDIF
C
      N=(NLEV*(NLEV+1))/2              !NOT FOUND, MAYBE NON-STANDARD
      GO TO 35
C
  40  NTEMP=NTEMP+1                    !ALLOW FOR INFINITE TEMP BORN
      TEMP(NTEMP)=1.D99
C
      IF(IT2.GT.0)READ(1,300)IF,II,DUM,IDUM,(MANT(I),IEXP(I),I=1,NTEMP)
 300  FORMAT(2I4,F5.2,I3,21(F5.2,I3))
      IF(IT2.LT.0)READ(1,301)IF,II,(MANT(I),I=1,NTEMP)
 301  FORMAT(2I4,9X,21(E9.2))
C
      IF(II.NE.IT1.OR.IF.NE.ABS(IT2))then
        write(*,*)ii,if
        STOP 'OOPS!'
      endif
C
      IF(ITYPE.EQ.3)THEN
        DO I=1,NTEMP
          UPS=MANT(I)
          IF(IT2.GT.0)UPS=UPS*10.**IEXP(I)
          WRITE(6,400)LOG10(TEMP(I)),TEMP(I),TEMP(I)/RYD,UPS
 400      FORMAT(F5.2,1PE10.2,2E10.2)
        ENDDO
      ELSEIF(ITYPE.EQ.1)THEN
        DO I=1,NTEMP
          UPS=MANT(I)
          IF(IT2.GT.0)UPS=UPS*10.**IEXP(I)
          IF(TEMP(I).GT.1.D20)THEN
            X=1
            XX=1
            XUPS=ABS(UPS)
          ELSE
            X=TEMP(I)-1.D0
            IF(MANT(NTEMP).LT.0)THEN         !DIPOLE
              XX=LOG(X+EXP(1.0D0))
              XUPS=UPS/XX
              XX=1.0D0-1.0D0/XX
           ELSE                              !NON-DIPOLE
            XX=X/(X+3.0D0)
            XUPS=UPS
           ENDIF
          ENDIF
          WRITE(6,401)XX,XUPS
 401      FORMAT(2(1PE10.2))
        ENDDO
      ENDIF
      STOP 'UPSILON IN upsout'
C
 500  WRITE(*,*)'TRANSITION',IT1,IT2,' NOT FOUND'
C
      END