! N. R. BADNELL   OMADD    UoS   v1.14                          18/06/19
!
! PROCESS/ADD/COMPARE TWO OMEGA FILES
!
!
      PROGRAM MAIN
!
      IMPLICIT REAL*8 (A-H,O-Z)
!
      LOGICAL BTWO,BMULT,BFORM,BBORN
!
      CHARACTER ELAS*3
!
      PARAMETER (ZERO=0.0D0)
!
      ALLOCATABLE :: ENAT1(:),LAT1(:),ISAT1(:),OMEG1(:,:)
      ALLOCATABLE :: ENAT2(:),LAT2(:),ISAT2(:),OMEG2(:,:)
      ALLOCATABLE :: EMESH1(:),NRD1(:),NWRITE(:)
      ALLOCATABLE :: EMESH2(:),NRD2(:)
      ALLOCATABLE :: IT(:),JT(:)
      ALLOCATABLE :: ITRAN(:),RMAX(:),JEMAX(:),OMGINF(:),OMT(:)
!
      NAMELIST/SADD/YMULT,YHIGH,YFAIL,IFAIL,NOMWRT,IBIGE,EHIGH,IOMSET   &
     &,ITOP,TOPR,TOPR1,TOPR2,ETOP,ELAS,YEND,ELOW,YLOW,IBORN,YMAX        &
     &,iemin,iemax,idrop                                      !,IONE
!
! IF ITOP.GE.0  (DEFAULT, SEE BELOW)
!
! FILE1 CAN BE PROCESSED TO ELIMINATE "FALSE" RESONANCES - omadd1
! FILE2 (OPTIONAL) IS ADDED TO FILE1 -  FILE2=omadd2
!      IT IS ASSUMED THAT FILE2 CONTAINS NO RESONANCES, IT CAN BE A
!      COARSE ENERGY TABULATION OF OMEGA WHICH IS THEN INTERPOLATED
!      ONTO THE FINE MESH OF FILE1.
!
! IF ITOP.LT.0 THE OMEGA RATIOS OF FILE1 (=OMEGA) TO FILE2 (=OMEGANOTOP)
! ARE DETERMINED.
!
! THE DEFAULT OPTIONS SUFFICE FOR THE SIMPLEST OPERATION OF ADDING TWO
! OMEGA FILES TOGETHER, BY INTERPOLATING ON A COARSE TO FINE ENERGY MESH
!
!
!
! NOMWRT--  WRITE ONLY THE FIRST NOMWRT COLLISION STRENGTHS.
!           THE DEFAULT SETTING GIVES ALL. (CURRENTLY, THERE IS NO
!           OPTION TO SWITCH BETWEEN COLUMNWISE AND ROWWISE SEQUENCING.)
! YMULT --  IF AN OMEGA IS GREATER THAN A FACTOR YMULT LARGER THAN
!           THE ONES ONE ENERGY STEP LOWER & HIGHER, RESET TO THE
!           SMALLER ONE. DEFAULT 1.0E24 - NO RESET.
! YLOW  --  AS YMULT BUT APPLIED BELOW ELOW.
! ELOW  --  ENERGY BELOW WHICH YLOW IS USED RATHER THAN YMULT.
! YHIGH --  AS YMULT BUT APPLIED ABOVE THE HIGHEST EXCITATION ENERGY,
!           WHERE OMEGA'S ARE SMOOTH IN PRINCIPLE....
! YEND  --  AS YMULT/YHIGH BUT APPLIED TO THE FIRST AND LAST POINTS
!           WHEN IE=1/MXE IS COMPARED ONLY AGAINST 2/MXE-1.
! YMAX  --  IF OMEGA AT A SINGLE POINT, TEST AGAINST YMAX.
! EHIGH --  WHEN PSUEDO-STATES ARE IN USE THE HIGHEST THRESHOLD IS
!           VERY HIGH, SET EHIGH TO THE ENERGY RELATIVE TO THE GROUND
!           THAT YOU WANT TO START USING YHIGH RATHER THAN YMULT.
!           IT IS RESET TO MIN(EHIGH, ENAT(NAST1))
!           (DEFAULT=999999. Z-SCALED RYD)
! YFAIL --  IF AN OMEGA IS GREATER THAN YFAIL ASSUME NUMERICAL FAILURE
!           AND RESET TO PREVIOUS ENERGY VALUE. DITTO IF OMEGA NEGATIVE.
!           THIS CAN HANDLE FAILURES AT SUCCESSIVE ENERGIES UNLIKE YMULT
!           BUT SHOULD ONLY BE USED WITH CARE TO ELIMINATE CATASTROPHIC
!           FAILURES I.E. DO NOT SET IT TOO LOW.
! IFAIL = 0 NUMERICAL FAILURE FOR A TRANSITION APPLIES TO THAT
!           TRANSITION ONLY (DEFAULT).
!       = 1 ASSUME ALL TRANSITIONS AFFECTED, RESET THEM ALL.
! ITOP  --  .GE. 0, FILES 1 AND 2 ADDED.
!       = 1 CHECK FOR NEGATIVE OMEGAS ON FILE 2 AND RESET.
!       = 0 JUST ADD (DEFAULT).
!       =-1 THEN FILE1 OPENS OMEGA ,I.E. WITH TOP-UP, AND FILE2 OPENS
!           OMEGANOTOP. (MXE1 MUST EQUAL MXE2, EXCEPT FOR OMGINF) THEN:
! TOPR,1,2  ARE THE RATIO OF OMEGA/OMEGANOTOP ABOVE WHICH DETAILS
!           ARE LOGGED. TOPR APPLIES TO ALL TRANSITIONS WHILE TOPR1 IS
!           APPLIED TO DIPOLE TRANSITIONS ONLY AND TOPR2 IS APPLIED
!           TO NON-DIPOLE TRANSITIONS. USE TOPR OR TOPR1 AND TOPR2.
!           DIPOLE TRANSITIONS CAN ONLY BE DISTINGUISHED IF THE DIPOLE
!           IBIGE.NE.0 (SEE BELOW) INFO IS AT THE END OF OMEGANOTOP.
!           (DEFAULT: -1.3,-2.0,-1.3 OFF)
! ETOP  --  MINIMUM ENERGY AT WHICH THE ITOP=-1 TOP-UP TESTS ARE APPLIED
!           IN AN NX RUN THE TOP-UP MAY BE A LARGE FRACTION OF THE NX
!           TOTAL BUT "SMALL" WHEN THE EXCHANGE CONTRIBUTION IS ADDED-IN
!           ESPECIALLY AT LOW ENERGIES, SO IT MAY BE PREFERABLE TO SKIP
!           THE TEST THEN.
!           (DEFAULT=-1.)
! IOMSET -- IF .EQ. 1 THEN OMEGA(TOT) IS RESET TO SATISFY TOPR1,2 TESTS
!           AND A NEW omaddt FILE IS WRITTEN.
!           (DEFAULT=1, RESET OMEGAS, BUT YOU DON'T HAVE TO USE omaddt!)
! IBIGE  -- TELLS CODE WHERE INFINITE ENERGY OMEGAS CAN BE FOUND.
!      ITOP.GE.0 THEN
!       = 1 THE LAST ENERGY POINT IN omadd1 CONTAINS INFINITE ENERGY
!           OMEGAS.
!       =-1 THE LAST ENERGY POINT IN omadd2 CONTAINS INFINITE ENERGY
!           OMEGAS.
!           THIS ENERGY POINT WILL NOT BE CHANGED BY ADDING FILE 1 TO
!           FILE 2.  ***N.B. IT SHOULD NOT BE IN BOTH FILES.
!       = 0 NO INFINITE ENERGY INFO (DEFAULT).
!      ITOP.LT.0 THEN
!       = 1 ASSUMES THAT BOTH OMEGA AND OMEGANOTOP CONTAIN INFINITE
!           ENERGY OMEGAS. IT *WILL* BE WRITTEN TO omaddt.
!       =-1 ASSUMES THAT ONLY OMEGANOTOP CONTAINS INFINITE ENERGY OMEGAS
!           (DEFAULT). ***THIS IS THE DEFAULT OPERATION OF STGICF.
!           IT WILL NOT BE WRITTEN TO omaddt AS AUTOSTRUCTURE INFINITE
!           ENERGY FILE IS PREFEREABLE - IT INCLUDES BORN LIMIT AS WELL.
!       = 0 NO INFINITE ENERGY INFO. ***NOT RECOMMENDED AS DIPOLE
!           TRANSITIONS CANNOT BE DISTINGUISHED FROM NON-DIPOLE. MUCH
!           LARGER TOP-UP RATIOS ARE ACCEPTABLE FOR DIPOLE TRANSITIONS
!           THAN NON-DIPOLE.
! IBORN = 1 THEN BORN LIMITS ARE PRESENT IN INFINITE ENERGY OMEGAS, DEF.
!       = 0 DIPOLE ONLY PRESENT.
! ELAS  =' 'ELASTIC TRANSITIONS NOT PRESENT FOR IONS
!           ELASTIC TRANSITIONS ARE PRESENT FOR NEUTRALS.
!           OVERRIDE BY SETTING TO 'YES' TO INCLUDE ELASTIC
!           OVERRIDE BY SETTING TO  'NO' TO EXCLUDE ELASTIC
! IEMIN  -- ONLY WRITE OMEGAS FOR ENERGIES INDEXES IEMIN THRU IEMAX, SO
! IEMAX  -- MXE=IEMAX-IEMIN+1, ALSO
!           MXE=MXE+1 IF IBIGE.NE.0, I.E. ANY INFINITE ENERGY POINT
!           FLAGGED IN FILE1 OR 2 IS RETAINED.
!           NOTE: IF IBIGE.LT/EQ.0 THEN ANY INFINITE ENERGY POINT
!           IN FILE1 IS IGNORED/DROPPED IF IEMAX.LT.MXE1.
! IDROP  -- .GT. 0 FINAL POINTS ARE DROPPED, IN *ADDITION* TO ANY IEMAX.
!           ANY INFINITE ENERGY POINT IS HANDLED AS ABOVE FOR IEMAX.
!           .LT. 0 ALLOWS THE CODE TO DROP AS MANY POINTS AS IT NEEDS,
!           BUT DO NOT EXCEED -IDROP, FOR CASE OF EMESH2.LT.EMESH1.
!           THIS IS SLOWER THAN .GT. 0  AS FILE1 HAS TO BE READ TWICE.
!
!
      call cpu_time(timei)
!
      OPEN(5,FILE='dadd',STATUS='UNKNOWN')
      OPEN(6,FILE='oadd',STATUS='UNKNOWN')
      OPEN(7,FILE='oadd2',STATUS='UNKNOWN')
      OPEN(99,STATUS='SCRATCH',FORM='FORMATTED')
!
      BTWO=.FALSE.
      EINF=1.0E06
!
! SET NAMELIST DEFAULTS
!
      YMULT=1.0E24
      YHIGH=-1.0E24
      YEND=-1.0E24
      YFAIL=1.0E24
      IFAIL=0
      NOMWRT=999999
      IBIGE=9999
      EHIGH=9999999.
      ITOP=0
      ETOP=-1.
      TOPR=-1.3
      TOPR1=-2.
      TOPR2=-1.3
      ELAS='   '
      IOMSET=1
      ELOW=0.
      YLOW=1.0E24
      IBORN=1
      YMAX=0.0
      iemin=1
      iemax=9999999           !nmxe1           !now allocatable
      idrop=-1
!
      READ(5,SADD,END=1)                       !READ NAMELIST
!
   1  BBORN=IBORN.EQ.1
      IF(YHIGH.LT.0.)YHIGH=YMULT
      IF(YEND.LT.0.)YEND=YMULT
      BMULT=YMULT.LT.1.0E10
      IF(ITOP.LT.0.AND.TOPR1.LT.0.)THEN        !SWITCH-ON DEFAULT RATIOS
        IF(TOPR.GT.0.)THEN
          TOPR1=TOPR
        ELSE
          TOPR1=-TOPR1
        ENDIF
      ELSEIF(TOPR.GT.0.)THEN
        ITOP=-1
        TOPR1=TOPR
      ENDIF
      IF(ITOP.LT.0.AND.TOPR2.LT.0.)THEN
        IF(TOPR.GT.0.)THEN
          TOPR2=TOPR
        ELSE
          TOPR2=-TOPR2
        ENDIF
      ELSEIF(TOPR.GT.0.)THEN
        ITOP=-1
        TOPR2=TOPR
      ENDIF
      IF(IOMSET.EQ.1)THEN
        IF(TOPR1.LT.ZERO)THEN
          IF(ITOP.LT.0)                                                 &
     &    WRITE(6,*)'*** ATTENTION, IOMSET RESET TO ZERO AS TOPR1,2'    &
     &              ,' ARE NEGATIVE ***'
          IOMSET=0
        ELSE
          WRITE(6,195)TOPR1,TOPR2
        ENDIF
      ENDIF
!
      WRITE(6,100)YLOW,ELOW,YMULT,YHIGH,EHIGH,YEND,YFAIL,IFAIL          &
     &           ,IOMSET,ITOP,ETOP,TOPR1,TOPR2,iemin,iemax,idrop
!
! SET-UP I/O FILES
!
      IF(ITOP.LT.0)THEN
        INQUIRE (FILE='OMEGA',EXIST=BFORM)
        IF(BFORM)THEN      
          OPEN(1,FILE='OMEGA',STATUS='OLD')              !FILE1
          OPEN(2,FILE='OMEGANOTOP',STATUS='OLD')         !FILE2
        ELSE
          OPEN(1,FILE='OMEGAU',STATUS='OLD',FORM='UNFORMATTED')   !FILE1
          OPEN(2,FILE='OMEGANOTOPU',STATUS='OLD',FORM='UNFORMATTED') !F2
        ENDIF
        OPEN(8,FILE='top1info',STATUS='UNKNOWN')        !DIPOLE LOG
        OPEN(9,FILE='top2info',STATUS='UNKNOWN')        !NON-DIPOLE LOG
        WRITE(8,801)
        WRITE(9,802)
      ELSE
        INQUIRE (FILE='omadd1',EXIST=BFORM)
        IF(BFORM)THEN      
          OPEN(1,FILE='omadd1',STATUS='OLD')          !FILE1
          OPEN(2,FILE='omadd2',STATUS='UNKNOWN')      !FILE2
        ELSE
          OPEN(1,FILE='omadd1u',STATUS='OLD',FORM='UNFORMATTED')  !FILE1
          OPEN(2,FILE='omadd2u',STATUS='UNKNOWN',FORM='UNFORMATTED') !F2
        ENDIF
      ENDIF
!
      IF(BFORM)THEN
        WRITE(6,*)'*** USING FORMATTED OMEGA FILES'
        OPEN(3,FILE='omaddt',STATUS='UNKNOWN')              !TOTAL OMEGA
      ELSE
        WRITE(6,*)'*** USING UNFORMATTED OMEGA FILES'
        OPEN(3,FILE='omaddtu',STATUS='UNKNOWN',FORM='UNFORMATTED') !T OM
      ENDIF
!
! re-entry point case of dropping last "few" energies...
!
 1000 continue
!
! READ START OF FILES 1 AND 2 (SET FLAG IF FILE 2 DOES NOT EXIST)
!
      IF(BFORM)THEN
        READ(1,*)NZED1,NELC1
        READ(2,*,END=2)NZED2,NELC2
      ELSE
        READ(1)NZED1,NELC1
        READ(2,END=2)NZED2,NELC2
      ENDIF
      BTWO=.TRUE.
!
      IF(NZED1.NE.NZED2.OR.NELC1.NE.NELC2)THEN
        WRITE(6,*)' ELEMENTAL MIS-MATCH OF OMEGA FILES'
        WRITE(6,*)NZED1,NZED2
        WRITE(6,*)NELC1,NELC2
        STOP ' ELEMENTAL MIS-MATCH OF OMEGA FILES'
      ENDIF
!
   2  IF(BFORM)READ(1,*)NAST1,MXE1,NOMT1
      IF(.NOT.BFORM)READ(1)NAST1,MXE1,NOMT1
!
      IF(ITOP.GE.0)THEN
        IF(IBIGE.EQ.9999)IBIGE=0
      ELSE
        IF(IBIGE.EQ.9999)IBIGE=-1
      ENDIF
      IF(IBIGE.NE.0)IBIGE=ISIGN(1,IBIGE)
      IF(IBIGE.GT.0) MXE1=MXE1-1
!
      MXE2=0
      NOMT2=0
      NAST=NAST1
      IF(BTWO)THEN
        IF(BFORM)READ(2,*)NAST2,MXE2,NOMT2
        IF(.NOT.BFORM)READ(2)NAST2,MXE2,NOMT2
!
        IF(NAST1.NE.NAST2)THEN
          IF(NOMT1.GE.0)THEN
            WRITE(6,*)' MIS-MATCH OF OMEGA FILES ON NAST'
            WRITE(6,*)NAST1,NAST2
            STOP ' MIS-MATCH OF OMEGA FILES ON NAST'
          ELSE
            NAST=MIN(NAST1,NAST2)
            WRITE(6,*)' NOTE: REDUCING NAST TO',NAST
            WRITE(*,*)' NOTE: REDUCING NAST TO',NAST
          ENDIF
        ENDIF
!
        IF(ITOP.GE.0) THEN
          IF(IBIGE.LT.0) MXE2=MXE2-1
          IF(MXE2.GT.MXE1)THEN
            WRITE(6,*)' FIRST FILE MUST HAVE GREATER NUMBER OF ENERGIES'
            WRITE(6,*)  MXE1,MXE2
            STOP 'FILE1 MUST BE THE RESONANCE FILE'
          ENDIF
        ELSE
          IF(IBIGE.NE.0) MXE2=MXE2-1
          IF(MXE1.NE.MXE2) THEN
            WRITE(6,*)' TO COMPARE TOP-UP RATIOS MXE1 MUST EQUAL MXE2'
            WRITE(6,*)  MXE1,MXE2
            STOP ' TO COMPARE TOP-UP RATIOS MXE1 MUST EQUAL MXE2'
          ENDIF
        ENDIF
!
        IF(NOMT1.NE.NOMT2)THEN
          WRITE(*,*)' WARNING: MIS-MATCH OF OMEGA FILES ON NOMWRT'
          WRITE(6,*)' WARNING: MIS-MATCH OF OMEGA FILES ON NOMWRT'
          WRITE(6,*)NOMT1,NOMT2
          IF(NOMT1*NOMT2.LE.0)STOP 'NOMT1, NOMT2 MUST BE THE SAME SIGN'
          IHOLD=MIN(IABS(NOMWRT),IABS(NOMT2))
          IF(NOMT2.LT.0)IHOLD=-IHOLD
          NOMWRT=IHOLD
        ENDIF
!
      ELSE
        IF(ITOP.LT.0)THEN
          WRITE(6,*)' MISSING FILE 2, CASE ITOP=-1'
          STOP' MISSING FILE 2, CASE ITOP=-1'
        ENDIF
!
      ENDIF
!
      IF(ELAS.EQ.'  ')THEN
        IF(NZED1.EQ.NELC1)ELAS='YES'
        IF(NZED1.NE.NELC1)ELAS='NO'
      ENDIF
      IF(ELAS.EQ.'YES')THEN
        IONE=0
      ELSEIF(ELAS.EQ.'NO')THEN
        IONE=1
      ELSE
        WRITE(6,*)' UNRECOGNIZED OPTION ELAS=',ELAS
        STOP ' UNRECOGNIZED ELAS OPTION'
      ENDIF
!
      IHOLD=MIN(IABS(NOMWRT),IABS(NOMT1))
      IF(NOMT1.LT.0)IHOLD=-IHOLD
      NOMWRT=IHOLD
      NOMT1=ABS(NOMT1)
      NOMT2=ABS(NOMT2)
!
      IF(ITOP.GE.0)MXE0=MXE1+IABS(IBIGE)
      IF(ITOP.LT.0)MXE0=MXE1+(IBIGE+1)/2
!
      idrop0=idrop
      iemax=min(mxe1,iemax)
      if(idrop0.gt.0)iemax=iemax-idrop
      mxe0=iemax-iemin+1+mxe0-mxe1
      iemx=MXE1
      if(ibige.le.0)iemx=iemax
!
! ALLOCATE FOR FILE1
!
      ALLOCATE (ENAT1(NAST1),LAT1(NAST1),ISAT1(NAST1),OMEG1(0:3,NOMT1)  &
     &         ,IT(NOMT1),JT(NOMT1),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(0,*)'ALLOCATION FAILS FOR NAST1,NOMT1=',NAST1,NOMT1
        STOP 'ABORT'
      ENDIF
!
      ALLOCATE (EMESH1(MXE1),NRD1(iemx),NWRITE(iemx+1),STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(0,*)'ALLOCATION FAILS FOR MXE1=',MXE1
        STOP 'ABORT'
      ENDIF
!
! READ TARGET INFO
!
      IF(BFORM)THEN
        READ(1,*)(ISAT1(I),LAT1(I),I=1,NAST1)
        READ(1,*)(ENAT1(I),I=1,NAST1)
      ELSE
        READ(1)(ISAT1(I),LAT1(I),I=1,NAST1)
        READ(1)(ENAT1(I),I=1,NAST1)
      ENDIF
!
      EHIGH=MIN(EHIGH,ENAT1(NAST1))
!      IF(ETOP.LT.ZERO)ETOP=ENAT1(NAST1)
!
      IF(NOMWRT.GT.0)THEN
        DO I=1,iemx
          NRD1(I)=NOMT1
          NWRITE(I)=NOMWRT
        ENDDO
      ELSE
        IF(BFORM)READ(1,*)E01                 !CHECK FIRST E
        IF(.NOT.BFORM)READ(1)E01                 !CHECK FIRST 
        BACKSPACE(1)
        I=1
        IF(E01.GE.ENAT1(NAST1))GO TO 3    !ALL OPEN - EARLY EXIT
        I0=1
        NO=NOPEN(E01,ENAT1,NAST1,IONE,I0)
        NO=MIN(NO,NOMT1)
        IF(MXE1.EQ.1)THEN
          NRD1(1)=NO
          NWRITE(1)=MIN(-NOMWRT,NRD1(1))
          GO TO 7
        ENDIF
        IF(BFORM)THEN
          READ(1,*)E01,(DUM,N=1,NO)
          READ(1,*)E                  !=E0+EINCR
          EINCR1=E-E01
          E01=E01-EINCR1
          EINCH1=EINCR1*0.5
          NREC=2+(NO-1)/6
          DO N=1,NREC
            BACKSPACE(1)
          ENDDO
        ENDIF
        I0=1
        DO I=1,iemx
          IF(BFORM)THEN
            E=E01+I*EINCR1
            WRITE(99,700)E
            BACKSPACE(99)
            READ(99,700)E
            BACKSPACE(99)
          ELSE
            READ(1)E
          ENDIF
          IF(E.GE.ENAT1(NAST1))GO TO 3
          NRD1(I)=NOPEN(E,ENAT1,NAST1,IONE,I0)
          NRD1(I)=MIN(NRD1(I),NOMT1)
          NWRITE(I)=MIN(-NOMWRT,NRD1(I))
        ENDDO
        I=iemx+1
   3    I0=I
        DO I=I0,iemx
          NRD1(I)=NOMT1
          NWRITE(I)=MIN(-NOMWRT,NRD1(I))
        ENDDO
        IF(.NOT.BFORM)THEN
          REWIND(1)
          NREC=4
          DO N=1,NREC
            READ(1)
          ENDDO
        ENDIF
      ENDIF
   7  IF(IBIGE.GT.0)NWRITE(iemx+1)=IABS(NOMWRT)
!
      IF(BTWO)THEN
!
        IF(ITOP.GE.0)THEN
          MOO=MXE2
          NOO=1
          LOO=NOMT2
        ELSE
          MOO=1
          NOO=NOMT2
          LOO=1
        ENDIF
!
        ALLOCATE (ENAT2(NAST2),LAT2(NAST2),ISAT2(NAST2),OMEG2(MOO,NOMT2)&
     &           ,ITRAN(NOMT2),RMAX(NOO),JEMAX(NOO),OMGINF(NOO),OMT(LOO)&
     &           ,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(0,*)'ALLOCATION FAILS FOR NAST2,NOMT2=',NAST2,NOMT2
          STOP 'ABORT'
        ENDIF
!
        ALLOCATE (EMESH2(MXE2),NRD2(MXE2+1),STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(0,*)'ALLOCATION FAILS FOR MXE2=',MXE2
          STOP 'ABORT'
        ENDIF
!
        IF(BFORM)THEN
          READ(2,*)(ISAT2(I),LAT2(I),I=1,NAST2)
          READ(2,*)(ENAT2(I),I=1,NAST2)
        ELSE
          READ(2)(ISAT2(I),LAT2(I),I=1,NAST2)
          READ(2)(ENAT2(I),I=1,NAST2)
        ENDIF
        DO I=1,NAST          !CHECK CONSISTENCY
          IF(IABS(ISAT1(I)).NE.IABS(ISAT2(I)).OR.LAT1(I).NE.LAT2(I))THEN
            WRITE(6,*)' MIS-MATCH OF OMEGA FILES'
            WRITE(6,*)I,ISAT1(I),ISAT2(I)
            WRITE(6,*)I,LAT1(I),LAT2(I)
            STOP ' MIS-MATCH OF OMEGA FILES'
          ENDIF
! MIS-MATCH OF ENERGY O.K. IF ORDER DOESN'T CHANGE E.G. OBS VS. THEORY.
          IF(ABS(ENAT1(I)-ENAT2(I)).GT.1.0E-4*ENAT1(I))THEN
            WRITE(6,*)'ATTENTION:  MIS-MATCH OF OMEGA FILES'
            WRITE(6,*)I,ENAT1(I),ENAT2(I)
          ENDIF
        ENDDO
!
      IF(NOMWRT.GT.0)THEN
        DO I=1,MXE2
          NRD2(I)=NOMT2
        ENDDO
      ELSE
        IF(BFORM)READ(2,*)E02                 !CHECK FIRST E
        IF(.NOT.BFORM)READ(2)E02                 !CHECK FIRST E
        BACKSPACE(2)
        I=1
        IF(E02.GE.ENAT2(NAST2))GO TO 4    !ALL OPEN - EARLY EXIT
        I0=1
        NO=NOPEN(E02,ENAT2,NAST2,IONE,I0)
        NO=MIN(NO,NOMT2)
        IF(MXE2.EQ.1)THEN
          NRD2(1)=NO
          GO TO 6
        ENDIF
        IF(BFORM)THEN
          READ(2,*)E02,(DUM,N=1,NO)
          READ(2,*)E                  !=E0+EINCR
          EINCR2=E-E02
          E02=E02-EINCR2
          EINCH2=EINCR2*0.5
          NREC=2+(NO-1)/6
          DO N=1,NREC
            BACKSPACE(2)
          ENDDO
        ENDIF
        I0=1
        DO I=1,MXE2
          IF(BFORM)THEN
            E=E02+I*EINCR2
            WRITE(99,700)E
            BACKSPACE(99)
            READ(99,700)E
            BACKSPACE(99)
          ELSE
            READ(2)E
          ENDIF
          IF(E.GE.ENAT2(NAST2))GO TO 4
          NRD2(I)=NOPEN(E,ENAT2,NAST2,IONE,I0)
          NRD2(I)=MIN(NRD2(I),NOMT2)
        ENDDO
        I=MXE2+1
   4    I0=I
        DO I=I0,MXE2
          NRD2(I)=NOMT2
        ENDDO
        IF(.NOT.BFORM)THEN
          REWIND(2)
          NREC=4
          DO N=1,NREC
            READ(2)
          ENDDO
        ENDIF
      ENDIF
   6  IF(IBIGE.NE.0)NRD2(MXE2+1)=IABS(NOMT2)
!
      ENDIF
!
      IF(BFORM)THEN
        WRITE(3,*)NZED1,NELC1                      !WRITE TO OMADDT
        WRITE(3,*)NAST,MXE0,NOMWRT     !WRITE TO OMADDT
        WRITE(3,*)(ISAT1(I),LAT1(I),I=1,NAST)     !WRITE TO OMADDT
        WRITE(3,710)(ENAT1(I),I=1,NAST)           !WRITE TO OMADDT
      ELSE
        WRITE(3)NZED1,NELC1                      !WRITE TO OMADDT
        WRITE(3)NAST,MXE0,NOMWRT     !WRITE TO OMADDT
        WRITE(3)(ISAT1(I),LAT1(I),I=1,NAST)     !WRITE TO OMADDT
        WRITE(3)(ENAT1(I),I=1,NAST)           !WRITE TO OMADDT
      ENDIF
!
! READ ENTIRE SET OF OMEGAS FROM  FILE 2
!
      IF(BTWO.AND.ITOP.GE.0)THEN
!
        DO N=1,NOMT2                !INITIALIZE
          ITRAN(N)=0
        ENDDO
!
        DO I=1,MXE2
!
          IF(BFORM)READ(2,*) EMESH2(I),(OMEG2(I,N),N=1,NRD2(I))
          IF(.NOT.BFORM)READ(2,err=21)EMESH2(I),(OMEG2(I,N),N=1,NRD2(I))
  21      IF(NOMWRT.LT.0.AND.BFORM)THEN
            ET=E02+I*EINCR2
            IF(ABS(EMESH2(I)-ET).GT.EINCH2)THEN
              IF(NRD2(I).LT.NOMT2)THEN
              WRITE(6,*)'*** MIS-MATCH DURING READ2 OF FORMATTED OMEGAS'
              WRITE(6,*)I,NRD2(I),ET,EMESH2
              STOP'*** MIS-MATCH DURING READ2 OF FORMATTED OMEGAS'
              ENDIF
            ENDIF
          ENDIF
!
          IF(ITOP.GT.0)THEN        !CHECK FOR NEGATIVE OMEGAS
            DO N=1,NWRITE(I)
              IF(OMEG2(I,N).LT.ZERO.AND.EMESH2(I).GT.ETOP)THEN  !FAILURE
                OMEG2(I,N)=OMEG2(I-1,N)
                IF(ITRAN(N).EQ.0)ITRAN(N)=I
              ENDIF
            ENDDO
          ENDIF
        ENDDO
!
      ENDIF    
!
!     INITIALIZE FOR ITOP=-1 AND READ OMGINF
!
      IF(ITOP.LT.0)THEN             !IMPLIES BTWO=.T.
        DO N=1,NOMT2                !INITIALIZE
          ITRAN(N)=0
          RMAX(N)=ZERO
          JEMAX(N)=0
        ENDDO
        IE2=0
  10    IE2=IE2+1
        IF(BFORM)READ(2,*,END=11)EEE,(OMGINF(N),N=1,NRD2(IE2))
        IF(.NOT.BFORM)READ(2,END=11)EEE,(OMGINF(N),N=1,NRD2(IE2))
        GO TO 12
  11    WRITE(6,*)'INFINITE ENERGY OMEGAS NOT FOUND IN FILE OMEGANOTOP'
        WRITE(6,*)'NON-DIPOLE RATIOS USED FOR ALL TRANSITIONS'
        DO N=1,NOMT2
          OMGINF(N)=ZERO
        ENDDO
        GO TO 14
!        STOP 'INFINITE ENERGY OMEGAS REQUIRED IN FILE OMEGANOTOP'
  12    IF(EEE.LT.EINF) THEN
          IF(NOMWRT.LT.0.AND.BFORM)THEN
            ET=E02+IE2*EINCR2
            IF(ABS(EEE-ET).GT.EINCH2)THEN
              IF(NRD2(IE2).LT.NOMT2)THEN
              WRITE(6,*)'*** MIS-MATCH DURING READ2 OF FORMATTED OMEGAS'
              WRITE(6,*)IE2,NRD2(IE2),ET,EEE
              STOP'*** MIS-MATCH DURING READ2 OF FORMATTED OMEGAS'
              ENDIF
            ENDIF
          ENDIF
          GO TO 10
        ENDIF 
  14    REWIND(2)
        IF(BFORM)THEN
          READ(2,*) NDUM1,NDUM2
          READ(2,*) NDUM1,NDUM2,NDUM3
          READ(2,*)(ISAT2(I),LAT2(I),I=1,NAST2)
          READ(2,*)(ENAT2(I),I=1,NAST2)
        ELSE
          READ(2) NDUM1,NDUM2
          READ(2) NDUM1,NDUM2,NDUM3
          READ(2)(ISAT2(I),LAT2(I),I=1,NAST2)
          READ(2)(ENAT2(I),I=1,NAST2)
        ENDIF
      ENDIF
!
!     DETERMINE DIPOLE-ALLOWED TRANSITIONS AND FLAG THEM
!
      IF(NOMWRT.GT.0)THEN           !NAST1=NAST2
        N=0
        DO I=1,NAST1
          DO J=I+IONE,NAST1
            N=N+1
            IT(N)=I
            JT(N)=J
           IF(ITOP.LT.0)THEN
            IF(BBORN.AND.OMGINF(N).LT.ZERO.OR.                          &
     &        .NOT.BBORN.AND.OMGINF(N).GT.ZERO)THEN
              IT(N)=-I
              JT(N)=-J
            ENDIF
           ENDIF
          ENDDO
        ENDDO
      ELSE                         !NAST=MIN(NAST1,NAST2)
        N=0
        DO J=1+IONE,NAST
          DO I=1,J-IONE
            N=N+1
            IT(N)=I
            JT(N)=J
           IF(ITOP.LT.0)THEN
            IF(BBORN.AND.OMGINF(N).LT.ZERO.OR.                          &
     &        .NOT.BBORN.AND.OMGINF(N).GT.ZERO)THEN
              IT(N)=-I
              JT(N)=-J
            ENDIF
           ENDIF
          ENDDO
        ENDDO
      ENDIF
!
! READ AND TEST OMEGA FROM FILE 1 ONE ENERGY AT A TIME
!
      WRITE(6,103)
      WRITE(7,104)
      JHOLD=2
      IF(BFORM)READ(1,*)EMESH1(1),(OMEG1(2,N),N=1,NRD1(1))
      IF(.NOT.BFORM)READ(1,err=22)EMESH1(1),(OMEG1(2,N),N=1,NRD1(1))
  22  IF(NOMWRT.LT.0.AND.BFORM)THEN
        ET=E01+1*EINCR1
        IF(ABS(EMESH1(1)-ET).GT.EINCH1)THEN
          IF(NRD1(1).LT.NOMT1)THEN
          WRITE(6,*)'*** MIS-MATCH DURING READ1 OF FORMATTED OMEGAS'
          WRITE(6,*)'1',NRD1(1),ET,EMESH1(1)
          STOP'*** MIS-MATCH DURING READ1 OF FORMATTED OMEGAS'
          ENDIF
        ENDIF
      ENDIF
      DO N=1,NRD1(1)
        OMEG1(2,N)=ABS(OMEG1(2,N))
      ENDDO
!
      if(btwo)then
       if(emesh2(1).gt.emesh1(1))then
        if(omeg2(2,1).ne.dzero)then      !not safe, we could be anywhere
          write(6,*)                                                    &
     &          '***ERROR: LOWEST FILE2 ENERGY EXCEEDS LOWEST ON FILE1:'&
     &          ,emesh1(1),emesh2(1)
           stop '***ERROR: LOWEST FILE2 ENERGY EXCEEDS LOWEST ON FILE1:' 
        else  !assume at threshold, file2 contrib. small, safe extrap...
          write(0,*)                                                    &
     &        '***WARNING: LOWEST FILE2 ENERGY EXCEEDS LOWEST ON FILE1:'&
     &        ,emesh1(1),emesh2(1)
          write(6,*)                                                    &
     &        '***WARNING: LOWEST FILE2 ENERGY EXCEEDS LOWEST ON FILE1:'&
     &        ,emesh1(1),emesh2(1)
        endif
       endif
      endif
!
! START LOOP OVER FILE 1 ENERGY
!
      DO 15 I=1,iemx
!
        IF(ITOP.LT.0)THEN               !CAN READ FILE 2 ONE E AT A TIME
!
          IF(BFORM)READ(2,*) EEE,(OMEG2(1,N),N=1,NRD2(I)) !SAME MESH 1&2
          IF(.NOT.BFORM)READ(2) EEE,(OMEG2(1,N),N=1,NRD2(I))      !DITTO
          IF(NOMWRT.LT.0.AND.BFORM)THEN
            ET=E02+I*EINCR2
            IF(ABS(EEE-ET).GT.EINCH2)THEN
              IF(NRD2(I).LT.NOMT2)THEN
              WRITE(6,*)'*** MIS-MATCH DURING READ2 OF FORMATTED OMEGAS'
              WRITE(6,*)I,NRD2(I),ET,EEE
              STOP'*** MIS-MATCH DURING READ2 OF FORMATTED OMEGAS'
              ENDIF
            ENDIF
          ENDIF
!
          IF(EEE.GT.ETOP)THEN         !CHECK TOP-UP RATIO
            DO N=1,NWRITE(I)
              IF(OMEG2(1,N).NE.ZERO)THEN
                R=OMEG1(2,N)/OMEG2(1,N)
                TOPR=TOPR2
                IF(IT(N).LT.0)THEN
                  TOPR=TOPR1
                  IF(R.LT.0.999)THEN
                    WRITE(6,711)I,N,-IT(N),-JT(N),OMEG2(1,N),OMEG1(2,N)
                    OMEG1(2,N)=OMEG2(1,N)
                  ENDIF
                ENDIF
                IF(R.GT.TOPR)THEN
                  IF(ITRAN(N).EQ.0)ITRAN(N)=I
                  IF(R.GT.RMAX(N))THEN
                    RMAX(N)=R
                    JEMAX(N)=I
                  ENDIF
                  IF(IT(N).GT.0)THEN
                    WRITE(9,803)I,N,IT(N),JT(N),OMEG2(1,N),OMEG1(2,N),R
                  ELSE
                    WRITE(8,803)I,N,-IT(N),-JT(N),OMEG2(1,N),OMEG1(2,N) &
     &                          ,R
                  ENDIF
                  IF(IOMSET.EQ.1)OMEG1(2,N)=OMEG2(1,N)*TOPR
                ENDIF
              ENDIF
            ENDDO
          ENDIF
        ENDIF
!
! GET NEXT ENERGY FOR OMEG1
!
      IF(I.LT.iemx)THEN
        IF(BFORM)READ(1,*) EMESH1(I+1),(OMEG1(3,N),N=1,NRD1(I+1))
        IF(.NOT.BFORM)READ(1,err=23) EMESH1(I+1)                        &
     &                                ,(OMEG1(3,N),N=1,NRD1(I+1))
  23    IF(NOMWRT.LT.0.AND.BFORM)THEN
          ET=E01+(I+1)*EINCR1
          IF(ABS(EMESH1(I+1)-ET).GT.EINCH1)THEN
            IF(NRD1(I+1).LT.NOMT1)THEN
            WRITE(6,*)'*** MIS-MATCH DURING READ1 OF FORMATTED OMEGAS'
            WRITE(6,*)I+1,NRD1(I+1),ET,EMESH1(I+1)
            STOP'*** MIS-MATCH DURING READ1 OF FORMATTED OMEGAS'
            ENDIF
          ENDIF
        ENDIF
      ELSE
        if(emesh1(iemx).gt.0.99*einf)then
          write(6,*)'*** unflagged infinite energy point found in file1'&
     &              ,iemx,emesh1(iemx)
          write(6,*)                                                    &
     &         '***set ibige=1 to include it or iemax=mxe1-1 to drop it'
          stop'***error: unflagged infinite energy point found in file1'
        endif
        IF(iemx.EQ.1)THEN
          DO N=1,NWRITE(I)
            OMEG1(3,N)=OMEG1(2,N)
          ENDDO
        ELSE
          DO N=1,NWRITE(I)
            OMEG1(3,N)=OMEG1(1,N)
          ENDDO
        ENDIF
      ENDIF
!
      IF(I.EQ.1)THEN
        DO N=1,NWRITE(I)
          OMEG1(1,N)=OMEG1(3,N)
        ENDDO
      ENDIF
!
      if(i.lt.iemin.or.i.gt.iemax)go to 16
!
! TRY AN ELIMINATE UNRESOLVED NARROW RESONANCES
! AND RESULTS OF NUMERICAL FAILURE.
!
      IFAIL0=0
      DO 5 N=1,NWRITE(I)
!
! ELIMINATE NEGATIVE OMEGA, NUMERICAL FAILURE.
!
        IF(OMEG1(2,N).LT.ZERO)THEN
          WRITE(6,102)I,N,IT(N),JT(N),EMESH1(I),OMEG1(2,N)
          OMEG1(2,N)=OMEG1(1,N)
          IFAIL0=IFAIL0+1
        ENDIF
!
        IF(.NOT.BMULT)GO TO 5
!
! ELIMINATE FALSE/UNRESOLVED RESONANCE
!
        TEST=YMULT
        IF(EMESH1(I)-ENAT1(JT(N)).LT.ELOW)TEST=YLOW
        IF(EMESH1(I).GT.EHIGH)TEST=YHIGH
        IF(I.EQ.1.OR.I.EQ.MXE1.OR.OMEG1(1,N).EQ.0.)TEST=YEND
        OMN=MIN(OMEG1(1,N),ABS(OMEG1(3,N)))
        OMX=MAX(OMEG1(1,N),ABS(OMEG1(3,N)))
        IF(OMX.EQ.ZERO)OMX=YMAX
        IF(OMEG1(2,N).GT.OMX*TEST)THEN
          WRITE(6,101)I,N,IT(N),JT(N),EMESH1(I),OMEG1(1,N),OMEG1(2,N)   &
     &   ,OMEG1(3,N)
          IF(OMN.GT.ZERO)THEN
            OMEG1(2,N)=OMN*1.0001
          ELSE
            OMEG1(2,N)=OMX*0.9999
          ENDIF
        ENDIF
        IF(EMESH1(I).GT.EHIGH.AND.OMEG1(2,N).LT.OMN/TEST)THEN
          IF(I.GT.1.AND.I.LT.MXE1)THEN
            WRITE(6,101)I,-N,IT(N),JT(N),EMESH1(I),OMEG1(1,N),OMEG1(2,N)&
     &     ,OMEG1(3,N)
            OMEG1(2,N)=OMN*0.9999          !OMX -> OMN
          ENDIF
        ENDIF
        IF(I.GT.2)THEN
          IF(OMEG1(0,N).EQ.0.)TEST=YEND
          OMN=MIN(OMEG1(1,N),OMEG1(2,N))
          OMX=MAX(OMEG1(0,N),OMEG1(3,N))
          IF(OMN.GT.OMX*TEST)THEN
            WRITE(7,712)I,N,IT(N),JT(N),EMESH1(I),OMEG1(0,N),OMEG1(1,N) &
     &                  ,OMEG1(2,N),OMEG1(3,N)
            OMEG1(1,N)=OMX
            OMEG1(2,N)=OMX
          ENDIF
        ENDIF
!
! ELIMINATE NUMERICAL FAILURES
!
        IF(OMEG1(2,N).GT.YFAIL)THEN
          WRITE(6,102)I,N,IT(N),JT(N),EMESH1(I),OMEG1(2,N)
          OMEG1(2,N)=OMEG1(1,N)
          IFAIL0=IFAIL0+1
        ENDIF
!
   5  CONTINUE
!
! RESET ALL (IFAIL'S .GT. 0)
!
      IF(IFAIL*IFAIL0.GT.0)THEN
        DO N=1,NWRITE(I)
          OMEG1(2,N)=OMEG1(1,N)
        ENDDO
      ENDIF
!
! ADD TWO FILES TOGETHER
!
      IF(ITOP.GE.0)THEN
       IF(BTWO)THEN
!
        IF(MXE1.GT.MXE2)THEN
!
          DO J=JHOLD,MXE2
            IF(EMESH2(J).GE.EMESH1(I))THEN
              T1=(EMESH2(J)-EMESH1(I))/(EMESH2(J)-EMESH2(J-1))
              T2=(EMESH1(I)-EMESH2(J-1))/(EMESH2(J)-EMESH2(J-1))
              DO N=1,NWRITE(I)
                IF(OMEG1(2,N).GT.ZERO)THEN
                  IF(OMEG2(J-1,N).GT.ZERO)THEN
                    OMT(N)=OMEG1(2,N)+OMEG2(J,N)*T2+OMEG2(J-1,N)*T1
                  ELSE
                    OMT(N)=OMEG1(2,N)+OMEG2(J,N)
                  ENDIF
                ELSE
                  OMT(N)=ZERO
                ENDIF
              ENDDO
              GO TO 60
            ENDIF
          ENDDO
!
!t          if(idrop0.eq.0)go to 60            !regenerate faulty omaddt
!
          iemax=i-1
          idrop=mxe1-iemax
          if(idrop.gt.-idrop0)then             !not safe
            write(0,2000)idrop,emesh2(mxe2),iemax
            write(6,2000)idrop,emesh2(mxe2),iemax
            stop                                                        &
     &       '***ERROR: HIGHEST FILE1 ENERGIES EXCEED HIGHEST ON FILE2'
          else      !inf. exists, assume o.k. to drop last few points...
            write(0,2001)idrop,emesh2(mxe2)
            write(6,2001)idrop,emesh2(mxe2)
            do k=1,3
              rewind(k)
            enddo
            deallocate (enat1,lat1,isat1,omeg1,it,jt,stat=ierr)
            if(ierr.ne.0)then
              write(0,*)'de-allocation fails for nast1,nomt1'
              stop 'abort'
            endif
            if(ierr.ne.0)then
              write(0,*)'de-allocation fails for mxe1'
              stop 'abort'
            endif
            deallocate (emesh1,nrd1,nwrite,stat=ierr)
            if(btwo)then
              deallocate (enat2,lat2,isat2,omeg2,itran,rmax,jemax,omginf&
     &                   ,omt,stat=ierr)
              if(ierr.ne.0)then
                write(0,*)'de-allocation fails for nast2,nomt2'
                stop 'abort'
              endif
              deallocate (emesh2,nrd2,stat=ierr)
              if(ierr.ne.0)then
                write(0,*)'de-allocation fails for mxe2'
                stop 'abort'
              endif
            endif
            go to 1000
          endif
!
  60      JHOLD=J
!
          IF(BFORM)WRITE(3,705)EMESH1(I),(OMT(N),N=1,NWRITE(I))  !OMADDT
          IF(.NOT.BFORM)WRITE(3)EMESH1(I),(OMT(N),N=1,NWRITE(I))  !DITTO
!
        ELSE
!
! ASSUME ENERGY MESHES IDENTICAL FOR MXE1=MXE2
!
          DO N=1,NWRITE(I)
            OMT(N)=OMEG1(2,N)+OMEG2(I,N)
          ENDDO
          IF(BFORM)WRITE(3,705)EMESH1(I),(OMT(N),N=1,NWRITE(I))  !OMADDT
          IF(.NOT.BFORM)WRITE(3)EMESH1(I),(OMT(N),N=1,NWRITE(I))  !DITTO
!
        ENDIF
!
       ELSE
!
! NO FILE2
!
        IF(BFORM)WRITE(3,705)EMESH1(I),(OMEG1(2,N),N=1,NWRITE(I))!OMADDT
        IF(.NOT.BFORM)WRITE(3)EMESH1(I),(OMEG1(2,N),N=1,NWRITE(I))!DITTO
!
       ENDIF
      ELSE
!
! ITOP=-1 : FILE 1 (OMEGA) POSSIBLY MODIFIED BY IOMSET
!
       IF(BFORM)WRITE(3,705)EMESH1(I),(OMEG1(2,N),N=1,NWRITE(I)) !OMADDT
       IF(.NOT.BFORM)WRITE(3)EMESH1(I),(OMEG1(2,N),N=1,NWRITE(I)) !DITTO
      ENDIF
!
! RE-INDEX OMEG1
!
  16  IF(I.GT.1)THEN
        DO N=1,NWRITE(I-1)
          OMEG1(0,N)=OMEG1(1,N)
        ENDDO
        DO N=NWRITE(I-1)+1,NWRITE(I)
          OMEG1(0,N)=ZERO
        ENDDO
      ENDIF
      DO N=1,NWRITE(I)
        OMEG1(1,N)=OMEG1(2,N)
      ENDDO
      DO N=NWRITE(I)+1,NWRITE(I+1)
        OMEG1(1,N)=ZERO
      ENDDO
      DO N=1,NWRITE(I+1)
        OMEG1(2,N)=OMEG1(3,N)
      ENDDO
!
! END ENERGY LOOP
!
  15  CONTINUE
!
! WRITE SUMMARY OF FAILURES
!
      IF(BTWO)THEN
        JTR=9999999
        NMIN=0
        DO N=1,NOMT2
          IF(ITRAN(N).NE.0.AND.ITRAN(N).LT.JTR)THEN
            NMIN=N
            JTR=ITRAN(N)
          ENDIF
        ENDDO
        IF(NMIN.GT.0)THEN
          IF(ITOP.LT.0)THEN
            WRITE(6,706)NMIN,IT(NMIN),JT(NMIN),JTR,EMESH1(JTR)
            DO N=1,NOMT2
              IF(ITRAN(N).NE.0)THEN
                IE=ITRAN(N)
                WRITE(6,707)IE,N,IT(N),JT(N),JEMAX(N),RMAX(N)
              ENDIF
            ENDDO
          ELSE
            WRITE(6,708)NMIN,IT(NMIN),JT(NMIN),JTR,EMESH1(JTR)
            DO N=1,NOMT2
              IF(ITRAN(N).NE.0)THEN
                IE=ITRAN(N)
                WRITE(6,707)IE,N,IT(N),JT(N)
              ENDIF
            ENDDO
          ENDIF
        ENDIF
      ENDIF
!
! INFINITE ENERGY
!
      IF(IBIGE.GT.0)THEN
        IF(BFORM)READ(1,*)EMESH1(1),(OMEG1(2,N),N=1,NOMT1)
        IF(.NOT.BFORM)READ(1)EMESH1(1),(OMEG1(2,N),N=1,NOMT1)
        IF(EMESH1(1).LT.EINF)THEN
          WRITE(6,*)'INFINITE ENERGY OMEGA NOT FOUND FOR IBIGE=',IBIGE
          STOP 'INFINITE ENERGY OMEGA NOT FOUND'
        ENDIF
        IF(BFORM)WRITE(3,705)EMESH1(1),(OMEG1(2,N),N=1,NWRITE(MXE1+1))
        IF(.NOT.BFORM)WRITE(3)EMESH1(1),(OMEG1(2,N),N=1,NWRITE(MXE1+1))
      ENDIF
      IF(IBIGE.LT.0.AND.ITOP.GE.0)THEN
        IF(BTWO)THEN
          IF(BFORM)READ(2,*)EMESH2(1),(OMEG2(2,N),N=1,NOMT2)
          IF(.NOT.BFORM)READ(2)EMESH2(1),(OMEG2(2,N),N=1,NOMT2)
          IF(EMESH2(1).LT.EINF)THEN
            WRITE(6,*)'INFINITE ENERGY OMEGA NOT FOUND FOR IBIGE=',IBIGE
            STOP 'INFINITE ENERGY OMEGA NOT FOUND'
          ENDIF
          IF(BFORM)WRITE(3,705)EMESH2(1),(OMEG2(2,N),N=1,NWRITE(MXE1+1))
         IF(.NOT.BFORM)WRITE(3)EMESH2(1),(OMEG2(2,N),N=1,NWRITE(MXE1+1))
        ELSE
          WRITE(6,709)IBIGE
        ENDIF
      ENDIF
!
      DEALLOCATE (ENAT1,LAT1,ISAT1,OMEG1,IT,JT,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(0,*)'DE-ALLOCATION FAILS FOR NAST1,NOMT1'
        STOP 'ABORT'
      ENDIF
      DEALLOCATE (EMESH1,NRD1,NWRITE,STAT=IERR)
      IF(IERR.NE.0)THEN
        WRITE(0,*)'DE-ALLOCATION FAILS FOR MXE1'
        STOP 'ABORT'
      ENDIF
      IF(BTWO)THEN
        DEALLOCATE (ENAT2,LAT2,ISAT2,OMEG2,ITRAN,RMAX,JEMAX,OMGINF      &
     &             ,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(0,*)'DE-ALLOCATION FAILS FOR NAST2,NOMT2'
          STOP 'ABORT'
        ENDIF
        DEALLOCATE (EMESH2,NRD2,STAT=IERR)
        IF(IERR.NE.0)THEN
          WRITE(0,*)'DE-ALLOCATION FAILS FOR MXE2'
          STOP 'ABORT'
        ENDIF
      ENDIF
!
      call cpu_time(timef)
!
      time=(timef-timei)/60.
      write(*,777)time
 777  format(' CPU TIME=',f9.3,' MIN')
!
      STOP 'NORMAL FINISH TO OMADD'
!
  100 FORMAT(' YLOW=',1PE7.1,3X,'ELOW=',E7.1,3X,'YMULT=',E7.1,3X        &
     &,'YHIGH',E7.1,3X,'EHIGH=',E7.1,3X//'  YEND=',E7.1,3X              &
     &,'YFAIL=',E7.1,3X,'IFAIL=',I3//' IOMSET=',I3,3X,'ITOP='           &
     &,I3,3X,'ETOP=',E10.3,3X,'TOPR1=',0PF5.1,3X,'TOPR2=',0PF5.1//      &
     &' IEMIN=',I6,3X,'IEMAX=',I6,3X,'IDROP=',I6//)
  101 FORMAT(I7,3I6,F12.5,3(1PE16.4))
  102 FORMAT(I7,3I6,F12.5,16X,1PE16.4)
  103 FORMAT(//'     IE','     N','    IT',                             &
     &'    JT',3X,' EMESH(IE) ',3X,' OMEGA(IE-1) ',4X,' OMEGA(IE) '     &
     &,4X,' OMEGA(IE+1)')
  104 FORMAT(//'     IE','     N','    IT',                             &
     &'    JT',3X,' EMESH(IE) ',3X,' OMEGA(IE-2) ',4X,' OMEGA(IE-1) '   &
     &,4X,' OMEGA(IE)',4X,' OMEGA(IE+1)')
  195 FORMAT(/'*** ATTENTION: IOMSET=1, TOP-UP RATIO LIMITED BY: '      &
     &,' TOPR1=',F4.1,3X,'TOPR2=',F4.1,' ***'/)
  700 FORMAT(1PE14.8,6(1PE11.3)/(14X,6(E11.3)))
  705 FORMAT(1PE14.8,6(E11.3)/(14X,6(E11.3)))
  706 FORMAT(/'THE FIRST TRANSITION AND ENERGY TO FAIL TOP-UP TEST IS:' &
     &' N=',I4,2X,'IT=',I4,2X,'JT=',I4,2X,'AT',2X,'IE=',I5              &
     &,'  ENERGY=',F8.5//'FOR EACH TRANSITION: ENERGY AT WHICH IT '     &
     &,'FIRST FAILED TOP-UP AND ENERGY AND VALUE OF WORST FAILURE'      &
     &//'     IE','    N','   IT','   JT','  IEMAX','    RMAX')
  707 FORMAT(I7,3I5,I7,F8.3)
  708 FORMAT(/'THE FIRST TRANSITION AND ENERGY TO GO NEGATIVE IS:'      &
     &' N=',I4,2X,'IT=',I4,2X,'JT=',I4,2X,'AT',2X,'IE=',I5              &
     &,'  ENERGY=',F8.5//'FOR EACH TRANSITION: ENERGY AT WHICH IT '     &
     &,'FIRST FAILED'                                                   &
     &//'     IE','    N','   IT','   JT')
  709 FORMAT(/'IBIGE=',I3,' BUT NO FILE2 PRESENT: INFINITE ENERGY ',    &
     &        'OMEGA NOT WRITTEN')
  710 FORMAT(1P5E16.6)
  711               FORMAT('***ATTENTION: NEGATIVE DIPOLE TOP-UP RESET:'&
     &                    ,2I7,2I5,1PE12.4,E12.4)
  712       FORMAT(I7,3I6,F12.5,4(1PE16.4))
  801 FORMAT(' TOP-UP RATIOS FOR DIPOLE TRANSITIONS:'//                 &
     &'    IE','     N','   IT','   JT','     NO-TOP  ','     TOP   ',  &
     &'  RATIO  '/)
  802 FORMAT(' TOP-UP RATIOS FOR NON-DIPOLE TRANSITIONS:'/              &
     &' (ALSO DIPOLE, IF DIPOLE TRANSITIONS COULD NOT BE DETERMINED)'// &
     &'    IE','     N','   IT','   JT','     NO-TOP  ','     TOP   ',  &
     &'  RATIO  '/)
  803 FORMAT(I7,3I5,1PE12.3,E12.3,0PF7.2)
 2000 FORMAT(/'***ERROR: HIGHEST',I5,' FILE1 ENERGIES EXCEED HIGHEST',  &
     &' ENERGY ON FILE2= ',1PE14.8/' RE-RUN OMADD WITH IEMAX=',I7,      &
     &' IF SAFE TO DROP THEM. ELSE EXTEND FILE2 ENERGY RANGE, AS ABOVE')
 2001 FORMAT(/'***WARNING: HIGHEST',I5,' FILE1 ENERGIES EXCEED HIGHEST' &
     &,' ENERGY ON FILE2= ',1PE14.8,' SO DROPPING THEM...')
!
      END
!
!************************************************
!
      INTEGER FUNCTION NOPEN(E,ENAT,NAST,IONE,I0)
      IMPLICIT REAL*8 (A-H,O-Z)
!
      DIMENSION ENAT(NAST)
!
      DO I=I0,NAST
        IF(E.LT.ENAT(I))GO TO 1
      ENDDO
      I=NAST+1
   1  I0=I-1
      NOPEN=(I0*(I0-2*IONE+1))/2
!
      RETURN
      END
