      SUBROUTINE PHO_EVENT(Nev,P1,P2,Fac,Irej)
C********************************************************************
C
C     main subroutine to manage simulation processes
C
C     input: NEV       -1   initialization
C                       1   generation of events
C                       2   generation of events without rejection
C                           due to energy dependent cross section
C                       3   generation of events without rejection
C                           using initialization energy
C                      -2   output of event generation statistics
C            P1(4)     momentum of particle 1 (internal TARGET)
C            P2(4)     momentum of particle 2 (internal PROJECTILE)
C            FAC       used for initialization:
C                      contains cross section the events corresponds to
C                      during generation: current cross section
C
C     output: IREJ     0: event accepted
C                      1: event rejected
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION DEPS , DT_RNDM , ecmsum , Fac , fac1 , fac2 ,
     &                 P1 , P2 , sqs , TINY , wg, initsqs
      INTEGER i , idia , idis , idna , idns , idpa , idps , ienacc ,
     &        ihpa , ihps , ipracc , iprsam , Irej , isla , isls ,
     &        ispa , isps , isra , isrs , ista
      INTEGER ists , itry1 , itry2 , jm1 , jm2 , k , kevgen , m , Nev ,
     &        nevhep
      SAVE

      PARAMETER (TINY=1.D-10)

      DIMENSION P1(4) , P2(4)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  current beam selection
      INCLUDE 'inc/pobeam'
C  general process information
      INCLUDE 'inc/poprcs'
C  internal rejection counters
      INCLUDE 'inc/poloop'
C  gamma-lepton or gamma-hadron vertex information
      INCLUDE 'inc/pofsrc'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C  cross sections
      INCLUDE 'inc/pocsec'
C  event weights and generated cross section
      INCLUDE 'inc/powght'
C  names of hard scattering processes
      INCLUDE 'inc/pohpro'
C  hard cross sections and MC selection weights
      INCLUDE 'inc/pohrcs'
C  table of particle indices for recursive PHOJET calls
      INCLUDE 'inc/porecu'
Cf2py intent(out) fac, irej

      DIMENSION iprsam(10) , ipracc(10) , ienacc(10) , idns(4) , idna(4)

      PARAMETER (DEPS=1.D-14)
      LOGICAL init
      DATA init/.FALSE./

      Irej = 0
      Fac = 0.D0
C  initializations
      IF ( Nev.EQ.-1 ) THEN
         IF ( init ) THEN
            WRITE (LO,'(/1X,2A)') 'PHO_EVENT: Error, initialzation' ,
     &             ' (-1) called twice.'
            CALL PHO_ABORT
         END IF

         IF ( LPRi.GT.4 ) WRITE (LO,'(/3(/1X,A))')
     &         '======================================================='
     &        , '  ------- initialization of event generation --------'
     &        ,
     &        '======================================================='

C**anfe Safety margin for initialization energy is 20%

         initsqs = 1.2D0*SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))
     &                **2-(P1(2)+P2(2))**2-(P1(3)+P2(3))**2)
         IF (SQSGlobMax.LE.initsqs) SQSGlobMax = initsqs

         CALL PHO_SETMDL(0,0,-2)

         CALL PHO_REJSTA(-1)
C  cross section
         Fac = SIGgen(4)
         DO i = 1 , 10
            iprsam(i) = 0
            ipracc(i) = 0
            ienacc(i) = 0
         END DO
         isps = 0
         ispa = 0
         isrs = 0
         isra = 0
         ihps = 0
         ihpa = 0
         ists = 0
         ista = 0
         isls = 0
         isla = 0
         idis = 0
         idia = 0
         idps = 0
         idpa = 0
         idns(1) = 0
         idns(2) = 0
         idns(3) = 0
         idns(4) = 0
         idna(1) = 0
         idna(2) = 0
         idna(3) = 0
         idna(4) = 0
         KACcep = 0
         KEVent = 0
         kevgen = 0
         ecmsum = 0.D0

         init = .TRUE.

      ELSE IF ( Nev.GT.0 ) THEN
         nevhep = KACcep
         sqs = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))
     &         **2-(P1(3)+P2(3))**2)
         IF ( (sqs.GT.DEPS) .AND. (sqs.GE.SQSglobmax) ) THEN
            WRITE (LO,*)
     &      'PHO_EVENT: Error: Higher energy requested then sqsglobmax.'
     &      , sqs , '>' , SQSglobmax
            CALL PHO_ABORT
         END IF
C
C  -------------- begin event generation ---------------
C
         IPAmdl(13) = 0
         IF ( Nev.EQ.3 ) IPAmdl(13) = 1
         KEVent = KEVent + 1
C  enable debugging
         CALL PHO_TRACE(0,0,0)
         IF ( IDEb(68).GE.2 ) THEN
            IF ( (MOD(KEVent,50).EQ.0) .OR. (IDEb(68).GE.3) .AND.
     &           LPRi.GT.4 ) WRITE (LO,'(1X,A,2I12)')
     &            'call to PHO_EVENT no' , KEVent , KACcep
         END IF
C  initialize MC package
         CALL PHO_SETPCOMB
         CALL PHO_EVEINI(0,P1,P2,jm1,jm2)

C  cross section calculation
         Fac = SIGgen(3)
         IF ( Nev.EQ.1 ) THEN
            IF ( IVWght(1).EQ.1 ) THEN
               wg = EVWght(1)*SIGgen(3)/SIGgen(4)
            ELSE
               wg = SIGgen(3)/SIGgen(4)
            END IF
            IF ( DT_RNDM(Fac).GT.wg ) THEN
               Irej = 1
               IF ( IDEb(68).GE.6 ) THEN
                  IF ( LPRi.GT.4 )
     &                  WRITE (LO,'(1X,2A,/5X,2I10,6X,1P3E10.3)')
     &                  'PHO_EVENT: rejection due to cross section' ,
     &                 ' (CALL/ACC/EVWGHT(1)/SIG/SIGMAX)' , KEVent ,
     &                 KACcep , EVWght(1) , SIGgen(3) , SIGgen(4)
                  CALL PHO_PREVNT(-1)
               END IF
               RETURN
            END IF
         END IF
         kevgen = kevgen + 1
         SIGgen(1) = SIGgen(4)*DBLE(kevgen)/DBLE(KEVent)
         HSWght(0) = MAX(1.D0,wg)

         itry1 = 0
 50      itry1 = itry1 + 1
         IF ( itry1.GT.1 ) CALL PHO_EVEINI(2,P1,P2,jm1,jm2)

C  sample process
         IPRoce = 0
         CALL PHO_SAMPRO(1,IFPap(1),IFPap(2),ECM,PVIrt(1),PVIrt(2),1.D0,
     &                   IPRoce)
         IF ( IPRoce.EQ.0 ) THEN
            IF ( LPRi.GT.4 .AND. IDEb(68).GE.4 ) WRITE (LO,'(1X,A)')
     &            'PHO_EVENT: ' , 'rejection by PHO_SAMPRO (call,Ecm)' ,
     &           KEVent , ECM
            Irej = 50
            RETURN
         END IF
C  sampling statistics
         iprsam(IPRoce) = iprsam(IPRoce) + 1

         itry2 = 0
 100     itry2 = itry2 + 1
         IF ( itry2.GT.1 ) CALL PHO_EVEINI(2,P1,P2,jm1,jm2)
C  sample number of cut graphs according to IPROCE and
C  generate parton configurations+strings
         CALL PHO_PARTON(IPRoce,jm1,jm2,P1,P2,Irej)
C  collect statistics
         isps = isps + KSPom
         ihps = ihps + KHPom
         isrs = isrs + KSReg
         ists = ists + KSTrg + KHTrg
         isls = isls + KSLoo + KHLoo
         idis = idis + MIN(KHDir,1)
         idps = idps + KHDpo + KSDpo
         IF ( (IDIfr1+IDIfr2+IDDpom.EQ.0) .AND. (KHDir.GT.0) )
     &        idns(KHDir) = idns(KHDir) + 1
C  rejection?
         IF ( Irej.NE.0 ) THEN
            IF ( IDEb(68).GE.4 ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2I5)')
     &               'PHO_EVENT: rejection by PHO_PARTON' , itry2 , Irej
               CALL PHO_PREVNT(-1)
            END IF
            IF ( (Irej.EQ.50) .AND. (Nev.EQ.1) ) RETURN
            IFAil(1) = IFAil(1) + 1
            IF ( itry1.GT.5 ) RETURN
            IF ( Irej.GE.5 ) THEN
               IF ( ISWmdl(2).EQ.0 ) RETURN
               GOTO 50
            END IF
            IF ( itry2.LT.5 ) GOTO 100
            GOTO 50
         END IF
C  fragmentation of strings

C  fragmentation of strings
C  In DPMJET case FSR and string fragmentation is done separately
         IF ( IPAmdl(13).EQ.0 ) THEN
            CALL PHO_STRFRA(Irej)
            IF ( Irej.NE.0 ) THEN
               IFAil(23) = IFAil(23) + 1
               IF ( (LPRi.GT.4) .AND. (IDEb(68).GE.4) ) THEN
                  WRITE (LO,'(/1X,A,2I5)')
     &                    'PHO_EVENT: rejection by PHO_STRFRA' , itry2 ,
     &                   Irej
                  CALL PHO_PREVNT(-1)
               END IF
               GOTO 50
            END IF
         END IF

C  check of conservation of quantum numbers
         IF ( IDEb(68).GE.-5 ) THEN
            CALL PHO_CHECK(-1,Irej)
            IF ( Irej.NE.0 ) GOTO 50
         END IF
C  event now completely processed and accepted
C  acceptance statistics
         ipracc(IPRoce) = ipracc(IPRoce) + 1
         ispa = ispa + KSPom
         ihpa = ihpa + KHPom
         isra = isra + KSReg
         ista = ista + (KSTrg+KHTrg)
         isla = isla + (KSLoo+KHLoo)
         idia = idia + MIN(KHDir,1)
         idpa = idpa + KHDpo + KSDpo
         IF ( (IDIfr1+IDIfr2.EQ.0) .AND. (KHDir.GT.0) ) idna(KHDir)
     &        = idna(KHDir) + 1
         DO i = 1 , IPOix2
            IF ( IPOres(i).EQ.0 ) THEN
               IF ( (LPRi.GT.4) .AND. (IDEb(67).GE.10) ) WRITE (6,*)
     &               'PHO_EVENT: diffraction statistics problem'
               GOTO 150
            END IF
            ienacc(IPOres(i)) = ienacc(IPOres(i)) + 1
 150     END DO
         KACcep = KACcep + 1

C  debug output (partial / full event listing)
         IF ( (IDEb(68).EQ.1) .AND. (MOD(KACcep,50).EQ.0) .AND.
     &        LPRi.GT.4 ) WRITE (LO,'(1X,A,2I12)')
     &         'call to PHO_EVENT no' , KEVent , KACcep
         IF ( IDEb(67).GE.10 ) THEN
            IF ( IDEb(67).LE.15 ) THEN
               CALL PHO_PREVNT(-1)
            ELSE IF ( IDEb(67).LE.20 ) THEN
               CALL PHO_PREVNT(0)
            ELSE IF ( IDEb(67).LE.25 ) THEN
               CALL PHO_PREVNT(1)
            ELSE
               CALL PHO_PREVNT(2)
            END IF
         END IF
C
C  effective weight
         DO i = 1 , 10
            IF ( IPOwgc(i).GT.0 ) HSWght(0) = HSWght(0)*HSWght(i)
         END DO
         IF ( IVWght(1).EQ.1 ) THEN
            wg = HSWght(0)
            IF ( wg.GT.1.01D0 ) THEN
               IF ( EVWght(1).LT.1.01D0 ) THEN
                  IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2I12,1PE12.3)')
     &                  'PHO_EVENT: cross section weight > 1' , KEVent ,
     &                 KACcep , wg
                  IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,1P3E11.3)')
     &                  'SIGCUR,SIGMAX,EVWGHT(1):' , SIGgen(3) ,
     &                 SIGgen(4) , EVWght(1)
               END IF
               EVWght(1) = HSWght(0)
               HSWght(0) = 1.D0
            ELSE
               EVWght(1) = 1.D0
            END IF
         END IF

C  effective cross section
         SIGgen(2) = SIGgen(4)*DBLE(KACcep)/DBLE(KEVent)
         ecmsum = ecmsum + ECM
         SIGgen(3) = SIGgen(3)*HSWght(0)
      ELSE IF ( Nev.EQ.-2 ) THEN

C  ---------------- end of event generation ----------------------

         IF ( LPRi.GT.4 )
     &         WRITE (LO,'(/3(/1X,A),//1X,A,3I12,/1X,A,F12.1)')
     &         '====================================================' ,
     &        '  --------- summary of event generation ----------' ,
     &        '====================================================' ,
     &        'called,generated,accepted events:' , KEVent , kevgen ,
     &        KACcep , 'average CMS energy:' ,
     &        ecmsum/DBLE(MAX(1,KACcep))

C  write out statistics
         IF ( KACcep.GT.0 ) THEN

            fac1 = SIGgen(4)/DBLE(KEVent)
            fac2 = Fac/DBLE(KACcep)
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,/1X,A)')
     &            'PHO_EVENT: generated and accepted events' ,
     &           '----------------------------------------'
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A)')
     &   'process, sampled, accepted, cross section (internal/external)'
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'non.diff.' , iprsam(1) , ipracc(1) , DBLE(ipracc(1))
     &           *fac1 , DBLE(ipracc(1))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'elas sca.' , iprsam(2) , ipracc(2) , DBLE(ipracc(2))
     &           *fac1 , DBLE(ipracc(2))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'qela sca.' , iprsam(3) , ipracc(3) , DBLE(ipracc(3))
     &           *fac1 , DBLE(ipracc(3))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'doub.pom.' , iprsam(4) , ipracc(4) , DBLE(ipracc(4))
     &           *fac1 , DBLE(ipracc(4))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'diff.par1' , iprsam(5) , ipracc(5) , DBLE(ipracc(5))
     &           *fac1 , DBLE(ipracc(5))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'diff.par2' , iprsam(6) , ipracc(6) , DBLE(ipracc(6))
     &           *fac1 , DBLE(ipracc(6))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'doub.dif.' , iprsam(7) , ipracc(7) , DBLE(ipracc(7))
     &           *fac1 , DBLE(ipracc(7))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'dir all  ' , iprsam(8) , ipracc(8) , DBLE(ipracc(8))
     &           *fac1 , DBLE(ipracc(8))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'dir X res' , idns(1) , idna(1) , DBLE(idna(1))*fac1 ,
     &           DBLE(idna(1))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'res X dir' , idns(2) , idna(2) , DBLE(idna(2))*fac1 ,
     &           DBLE(idna(2))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'dir X dir' , idns(3) , idna(3) , DBLE(idna(3))*fac1 ,
     &           DBLE(idna(3))*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'soft pom.' , isps , ispa , DBLE(ispa)*fac1 ,
     &           DBLE(ispa)*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'hard pom.' , ihps , ihpa , DBLE(ihpa)*fac1 ,
     &           DBLE(ihpa)*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'soft reg.' , isrs , isra , DBLE(isra)*fac1 ,
     &           DBLE(isra)*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'enh. trg.' , ists , ista , DBLE(ista)*fac1 ,
     &           DBLE(ista)*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'enh. log.' , isls , isla , DBLE(isla)*fac1 ,
     &           DBLE(isla)*fac2
            IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,2I12,1P2E13.3)')
     &            'doub.pom.' , idps , idpa , DBLE(idpa)*fac1 ,
     &           DBLE(idpa)*fac2
            IF ( ISWmdl(14).GT.0 ) THEN
               IF ( LPRi.GT.4 ) WRITE (LO,'(3X,A,I3)')
     &               'recursive pomeron splitting:' , ISWmdl(14)
               IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,I12)')
     &              '1->2pom-cut :' , ienacc(8)
               IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,I12)')
     &              '1->doub-pom :' , ienacc(4)
               IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,I12)')
     &              '1->diff-dis1:' , ienacc(5)
               IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,I12)')
     &              '1->diff-dis2:' , ienacc(6)
               IF ( LPRi.GT.4 ) WRITE (LO,'(5X,A,I12)')
     &              '1->doub-diff:' , ienacc(7)
            END IF
            IF ( LPRi.GT.4 ) WRITE (LO,'(2(/1X,A,1PE12.3)/)')
     &            ' sampled cross section (mb)' , SIGgen(1) ,
     &           'accepted cross section (mb)' , SIGgen(2)

            CALL PHO_REJSTA(-2)
            CALL PHO_SAMPRO(1,IFPap(1),IFPap(2),ECM,PVIrt(1),PVIrt(2),
     &                      0.D0,-2)
            CALL PHO_PARTON(-2,0,0,P1,P2,Irej)
C  statistics of hard scattering processes
            IF ( LPRi.GT.4 ) WRITE (LO,'(2(/1X,A))')
     &            'PHO_EVENT: statistics of hard scattering processes' ,
     &           '--------------------------------------------------'
            DO k = 1 , 4
               IF ( MH_tried(0,k,IDXmpar).GT.0 ) THEN
                  IF ( LPRi.GT.4 ) WRITE (LO,'(/5X,A,I3)')
     &          'process (accepted,x-section internal/external) for IP:'
     &          , k
                  DO m = 0 , MAX_PRO_2
                     IF ( LPRi.GT.4 )
     &                     WRITE (LO,'(1X,I3,1X,A,2X,2I12,1P2E13.3)')
     &                    m , PROc(m) , MH_tried(m,k,IDXmpar) ,
     &                    MH_acc_1(m,k,IDXmpar) ,
     &                    DBLE(MH_acc_1(m,k,IDXmpar))*fac1 ,
     &                    DBLE(MH_acc_2(m,k,IDXmpar))*fac2
                  END DO
               END IF
            END DO

         ELSE
            IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I4,/)')
     &            'no output of statistics' , KEVent
         END IF
         IF ( LPRi.GT.4 ) WRITE (LO,'(/3(/1X,A)/)')
     &         '======================================================'
     &        , '   ------- end of event generation summary --------' ,
     &        '======================================================'
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I7)')
     &         'PHO_EVENT:ERROR: unsupported NEV' , Nev
      END IF

      END SUBROUTINE


      SUBROUTINE dmoex(buf,lbuf,ibuf,scr,lscr,iscr)
c-------------------------------------------------------------------------------
c       DMOEX is the execution phase of the sioseis process DMO. DMOEX is a single
c  trace process that applies the phase shift to produce the DMO ellipse. Input data
c  must be in the FK domain (i.e. must have been through process TX2FK).
c
c       DMOEX  is called once for each input k domain complex frequency trace.
c  The wavenumbers of the input traces are from 0 to +k Nyquist (The negative
c  wavenumbers are not needed since they can be inferred from the positive
c  ones). The frequencies (OMEGA) of the input trace are from -Nyq -> 0 -> +Nyq.
C
C      DMOEX calculates the frequency (OMEGA) and wavenumber phase shift for each trace
C  by applying the phase factor developed by Liner (SEE GEOPHYSICS, 1990). PROCESS uses
c  only rect coordinates for f-k.

c
c Inputs:
c    BUF - The complex frequency trace to be DMOed
c   IBUF - The integer*2 equivalent of buf. Used to pass trace header info
c   LBUF - The integer*4 equivalent of buf. Used to pass trace header info
c   SCR/ISCR/LSCR/ - Scratch array and its integer equivalents.
c
c Outputs:
c    BUF - contains the migrated trace.
c
c Called from : CONTRO
c
c Externals :
c  PODISC, RDDISC    : Disk i/o routines
c                               INCLUDE FILES

c-------------------------------------------------------------------------------

c*GMK THESE ARE THE INCLUDE FILE WHICH HAVE BEEN PASTED INTO THE EXECUTABLE CODE
c*    MANY OF THESE VARIABLES ARE NOT USED FOR DMO BUT I WON'T GO CRAZY AND CHOP
c     OUT THE UNNECESSARY ONES - JUST IN CASE I NEED THEM LATER!
c INCLUDE FILES
c.. Include file defining constants of use globally throughout SIOSEIS
c
c Modified 11/11/88     added DATINAP
c 8 Apr 09 - Use common numdat rather than segy header word ISAMPPTR
c Define the sizes of some Large common blocks

      integer SZAPMEM, SZTRANP
      parameter (SZAPMEM = 65537)                                       ! Size of /APMEM/ : AP memory
      parameter (SZTRANP = 262144)                                      ! Size of /TRANP/: Transpose array at 512x512
c parameter definitions for the stop signal istop
      integer STOPNOTR, STOPTR, NOSTOP
      parameter (STOPNOTR  = -1)                                        ! last call but no trace passed
      parameter (STOPTR    =  1)                                        ! last call and a trace passed
      parameter (NOSTOP    =  0)                                        ! normal call to the routine
c
c parameter for AP
      integer CLEARAP, USEAP, NOAP
      integer DATINAP
      parameter (USEAP    = 1)                                          ! There is an AP available
      parameter (NOAP     = 0)                                          ! No AP available
      parameter (CLEARAP  = 0)                                          ! Get data out of AP simulator
      parameter (DATINAP   = 1)                                         ! Data is in the AP
c This include file include all (?) of the parameters needed to define SIOSEIS
c I/O routines. In particular it defines positions of objects in the SEGY
c headers & constants for these values
c
c EBCDIC HEADER
c Declare Header lengths. These are the length of the EXTERNAL disk image in
c host words.
      integer     CRAYEBC, NORMEBC
      parameter ( CRAYEBC  = 400)
      parameter ( NORMEBC  = 2*CRAYEBC)
c
c BINARY HEADER
      integer     CRAYBIN, NORMBIN
      parameter ( CRAYBIN  =  50)                                       ! length of external disk image
      parameter ( NORMBIN  = 2*CRAYBIN)
c
c  The position of objects in the Binary header
      integer    NTRCPTR,IFMTPTR, IDTYPPTR, INKPTR, ITSIPTR
      integer    ITDELPTR
      parameter (NTRCPTR  =  7)                                         ! No of traces / gather
      parameter (IFMTPTR  = 13)                                         ! The SEGY Format of the data
      parameter (IDTYPPTR = 31)                                         ! The Domain/ID of the data e.q. T-X data
      parameter (INKPTR   = 32)                                         ! The No. of wavenumbers in an f-k dataset
      parameter (ITSIPTR  = 33)                                         ! Record of tx sample interval in us
      parameter (ITDELPTR = 34)                                         ! Record of tx time delay in ms.
c
c..Constants for SEGY Format (IFMTPTR)
      integer IBMFP, INT16, INT32, HOSTFP
      parameter (IBMFP  = 1)                                            ! IBM floating point
      parameter (INT32  = 2)
      parameter (INT16  = 3)
      parameter (HOSTFP = 5)                                            ! Host FP. In actuality Host FP >= 5
c
c.. Data Domains/Types (IDTYPPTR)
      integer    IDTX, IDFKRCT, IDFKPLR, IDFKPLRU
      parameter (IDTX     = 1)
      parameter (IDFKRCT  = 2)
      parameter (IDFKPLR  = 3)
      parameter (IDFKPLRU = 8)
c
c TRACE HEADER
c.. Declare header length on external disk files. Internal length is given by
c Numhdr in common block READT.
      integer  CRAYTHDR, NORMTHDR
      parameter ( CRAYTHDR =  30)                                       ! Length of external disk image
      parameter ( NORMTHDR = 2*CRAYTHDR)
c
      common /SEGYPTR/ LLSEQPTR, LRSEQPTR, LSHOTPTR, LSHTRPTR, LRPNPTR,
     *                 LRPTRPTR, ITRIDPTR, LDISTPTR, LWBDPTR,  LSXCOPTR,
     *                 LRXCOPTR, IDELMPTR, ISTMPTR,  IENDMPTR, ISAMPPTR,
     *                 ISIPTR,   IYRPTR,   IDAYPTR,  IHRPTR,   IMINPTR,
     *                 ISECPTR,  IGMTPTR,  LDELSPTR, LSMUSPTR, LEMUSPTR,
     *                 LSISPTR,  LWBTSPTR, LGATPTR,  LSSMSPTR, LESMSPTR,
     *                 LSBPTR
c
c.. Define Constants for Trace Header
c
c.. Constants for Trace ID (ITRIDPTR)
      integer    LIVETR, DEADTR                                         ! Parameters for trace Type
      parameter (LIVETR  = 1)
      parameter (DEADTR  = 2)
c
c.. Define constants for use with the DISKIO subroutines getfil, frefil,
c podisc
c GETFIL constants
      integer    CREATTMP, CREATNEW
      parameter (CREATTMP   = 1)                                        ! Create a temporary file
      parameter (CREATNEW   = 3)                                        ! Create a new named file
c FREFIL constants
      integer    RLDLCLS
      parameter (RLDLCLS = 3)
c PODISC constants
      integer    POSABS, POSREL, DSKSTRT
      parameter (POSABS     = 1)
      parameter (POSREL     = 2)
      parameter (DSKSTRT    = 0)                                        ! The starting position on the disk
c Include file TXFK.INC
c include file for the sioseis 2D FFT and fk migration routines
c
c
c Parameters for coord type
      integer CDRECT, CDPOLAR, CDPOLARU
      parameter ( CDRECT   = 1)
      parameter ( CDPOLAR  = 2)
      parameter ( CDPOLARU = 3)
c
c parameters for Windows
      integer BoxCar
      parameter (BoxCar = 5)
c PROGRAM
      Parameter (NSCLRS = 7)
      Parameter (PI = 3.141592654)

C
      common /SIOAP/ iasgnd,irelse,in,iout,nextad,lapsiz,ifree,iuseap,
     *               idecim
      common /READT/ilun,numhdr,numdat,iunhdr,ireelm,intrcs,ifmt,nskip,
     *               secs,lrenum,isrcf,idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc
      COMMON /dmocom/ idmounit, ndmolists, ndmowrds
      common /TXFKE/ txinit, fkinit, txed, fked, txunit,
     $               ltxunt1, ltxunt2, lfkunt1, lfkunt2,
     $               ohdrtxfk, tmptxhdr, txprestk, ntx2fk, nfk2tx, range
      common /APMEM/ a(SZAPMEM)
C
      dimension lbuf(1),buf(1), scr(1),lscr(1)
      integer*2 ibuf(1),iscr(1)
      integer   txsius
      integer   LocCoord
      logical   first
      save
C
      dimension params1(5), lparams1(5)
      equivalence (params1(1),lparams1(1))

      data first /.true./, hold /-1.0/, zerotol /0.00001/

c**************************************************************************************
c                                  PROCESS DMOEX
c**************************************************************************************
C
c*GMK Hopefully resets wavenumk when new offset panel is processed

      if (first) then                                                   ! DMO Initialization
        first = .false.

c*GMK Checks logstretch and reads appropriate disk file
        CALL podisc( idmounit, 1, 0 )
        CALL rddisc( idmounit, params1, ndmowrds, istat )
          ifiltype  = lparams1(1)
          dx        = params1(2)
          lprint    = lparams1(3)
          rdtl      = params1(4)
          roffset   = params1(5)
c       write(*,*) 'ifiltype;', ifiltype,'dx:', dx,'lprint:', lprint,
c     &'rtdl:', rdtl, 'ndmowrds:', ndmowrds, 'idmounit:', idmounit,
c     &'offset: ', roffset
c
c*GMK Checks to see if coordinates are rect. polar or non-FK
        if (idtype.eq.IDFKRCT) then
           LocCoord = CDRECT
        else if ((idtype.eq.IDFKPLR).OR.(idtype.eq.IDFKPLRU)) then
           LocCoord = CDPOLAR
               print *, ' *** DMO Error *** ',
     *           ' PROCESS DMO dose not accept data
     *in  POLAR COORDINATES.'
               STOP
             else
               print *, ' *** DMO Error *** ',
     *           ' The input data is not in the FK domain.'
               STOP
        endif

c..                       Read the time delay/sample interval from READT common
c*GMK   Imtialize various f-k parametrs
        if (roffset .ne. 999999.0) then
           hosr = roffset/2.0
        else
           hosr = range / 2.0
        endif
        txsius = itxsi                                                  ! t-x sample interval in us
        delay  = itxdel/1000.                                           ! & time delay in secs.
        nx     = 2* (nfktrc-1)                                          ! Calcalate no. of output traces
        dt     = FLOAT(txsius)/1.0E6                                    ! Delta t
        dk     = 2.*pi/(float(nx)*dx)                                   ! Delta k (distance between wavenumbers)
c        nw     = ibuf(ISAMPPTR)/2                                       ! The number of frequencies
        nw = numdat / 2
        dw     = 2.*pi/(float(nw)*dt)                                   ! Delta w (distance between frequencies)
c        nwrds  = ibuf(ISAMPPTR)                                         ! No. of 32 bit words in the complex trace
        nwrds = numdat
        nt     = nwrds / 2                                              ! No. of time samples
        realk  = 0.                                                     ! Wavenumber of the initial input trace

        wnyqneg = (-2.0*pi) * ( 1.0/(2.0*dt) )
        wavenumk = realk
        numleft = nfktrc

        if ( IAND(lprint,1).ne.0) then
          print *,'EXECUTE DMO'
          print *,'Number of fk traces:', nfktrc, 'Output traces:', nx
          print *,'Delta T:', dt,' delta k:', dk,'Delta w:', dw
          print *,'No of w (nw):', nw,' No of time samps (nt):', nt
          print *,'Number wrds:', nwrds, 'tx samp int:', txsius
          print *,'half-offset:', hosr, 'Delay: ', delay
          print *,'in ap', in
        endif

      endif

c*GMK What type of filter do you want ?
       if (ifiltype .eq. 0 .or. ifiltype .eq. 999) then
          goto 30
       else
           print*, 'ifiltype: ', ifiltype, ' not supported yet'
          goto 40
       endif

c***********************                                ***********************
*                     Loop over Wavenumer for each FK Trace
c***********************                                ***********************
c*GMK Start at k=0, and w = -nyquist to +nyquist-dw (padded to power of 2**n (even) whereas -nqy to nyq (odd)
c*    thus +nyquist sample is omitted
c
30     continue

C*GMK If half-offset equal to zero, skip phase shift...already at zero-offset
       if (hosr .eq. 0.0) then
          if (first) print*, 'Zero-offset data, no phase shift applied'
          goto 40
       endif

c*GMK  loop over complex trace samples
          Do 20 j = 1, nwrds,  2
             wfreq = wnyqneg + float( (j+1)/2 - 1)*dw
c*GMK  Break phase shift into real and imaginary parts (preal pimag)

c*     Stationary point ys --> 0 as ky --> 0 expand (1+e)**.5 for small e
             if (wavenumk .eq. 0.) then
               ys = 0.
             else
               if (abs(wfreq).lt.zerotol) then
                  ys = -1.0*hosr
               else
                 subys = wfreq/(2.0*wavenumk)
                 ys =  subys * (1.0  - (1.0 + (hosr**2/subys**2) )**0.5)
               endif
             endif
             betas = ys/hosr

c*GMK  If wfreq is equal to zero, don't take log (0), expand later
             if ( abs(wfreq).gt.zerotol) then
                 deltas = 0.5*log(1.0-betas**2)
             endif

             denom = (1.0+betas**2)**0.5

c*GMK  If wfreq is equal to zero, the phase term goes to zero, although it asymptotes
c      to +/- wavenumk*ys in the positive or negative limit (THANKS AJH)

             if (abs(wfreq).gt.zerotol) then
                aphase = wfreq*deltas-wavenumk*ys
             else
                aphase = 0.0
             endif

c*GMK Take the real and imaginary parts of the phase term (complex conjugate
c* due to fk sign convention e(-iwt) --> forward e(+iwt) --> inverse in sioseis
             preal = cos(aphase)/denom
             pimag = -1.0*sin(aphase)/denom

c*GMK     Is data in AP
c*        Either way, multiply the complex phase term * complex trace and not screw
c*        up like I did (GMK)
          if (in.eq.0) then
            tempbj = buf(j+numhdr)*preal -  pimag*buf(j+numhdr+1)
            tempbj1 = buf(j+1+numhdr)*preal + buf(j+numhdr)*pimag
            buf(j+numhdr) = tempbj
            buf(j+numhdr+1) = tempbj1
          else
            tempaj  = a(j)*preal-pimag*a(j+1)
            tempaj1 = a(j+1)*preal+a(j)*pimag
            a(j) = tempaj
            a(j+1) = tempaj1
          endif
20        continue

c*GMK     SAVE saves wavenumk and it is advanced to next wavenumber trace if it exists
          wavenumk  = wavenumk + dk
40    continue

c*GMK Count number of traces for a given offset panel until done
c*    Reset first to .true. which allows new offset to be read correctly
      numleft = numleft - 1
      if (numleft.eq.0) then
         first = .true.
      endif

      return
      end


      SUBROUTINE MG5_1_LOOP_CT_CALLS_1(P,NHEL,H,IC)
C
C     Modules
C
      USE MG5_1_POLYNOMIAL_CONSTANTS
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=4)
      INTEGER    NCOMB
      PARAMETER (NCOMB=16)
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=2)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=22, NLOOPGROUPS=13, NCTAMPS=54)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=76)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=8,NLOOPWAVEFUNCS=50)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      REAL*16     MP__ZERO
      PARAMETER (MP__ZERO=0.0E0_16)
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=1, NSQUAREDSO=1, NAMPSO=2)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*16 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)

      LOGICAL DUMMYFALSE
      DATA DUMMYFALSE/.FALSE./
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
      INCLUDE 'mp_coupl.inc'

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/MG5_1_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      LOGICAL CHECKPHASE
      LOGICAL HELDOUBLECHECKED
      COMMON/MG5_1_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER SQSO_TARGET
      COMMON/MG5_1_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/MG5_1_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      INTEGER I_SO
      COMMON/MG5_1_I_SO/I_SO
      INTEGER I_LIB
      COMMON/MG5_1_I_LIB/I_LIB

      COMPLEX*16 AMP(NBORNAMPS)
      COMMON/MG5_1_AMPS/AMP
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMMON/MG5_1_W/W

      COMPLEX*16 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,
     $ -1:NLOOPWAVEFUNCS)
      COMPLEX*16 PL(0:3,-1:NLOOPWAVEFUNCS)
      COMMON/MG5_1_WL/WL,PL

      COMPLEX*16 AMPL(3,NCTAMPS)
      COMMON/MG5_1_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.CTCALL_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

C     CutTools call for loop numbers 1,19,21
      CALL MG5_1_LOOP_2(5,7,DCMPLX(ZERO),DCMPLX(ZERO),2,I_SO,1)
C     CutTools call for loop numbers 2,20,22
      CALL MG5_1_LOOP_2(6,8,DCMPLX(ZERO),DCMPLX(ZERO),2,I_SO,2)
C     CutTools call for loop numbers 3,4
      CALL MG5_1_LOOP_3(3,4,5,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO),2
     $ ,I_SO,3)
C     CutTools call for loop numbers 5,6
      CALL MG5_1_LOOP_3(2,4,6,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO),2
     $ ,I_SO,4)
C     CutTools call for loop numbers 7,8
      CALL MG5_1_LOOP_3(1,3,8,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO),2
     $ ,I_SO,5)
C     CutTools call for loop numbers 9,13
      CALL MG5_1_LOOP_4(1,2,4,3,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO)
     $ ,DCMPLX(ZERO),2,I_SO,6)
C     CutTools call for loop numbers 10
      CALL MG5_1_LOOP_4(1,2,3,4,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO)
     $ ,DCMPLX(ZERO),2,I_SO,7)
C     CutTools call for loop numbers 11,12
      CALL MG5_1_LOOP_3(1,2,7,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO),2
     $ ,I_SO,8)
C     CutTools call for loop numbers 14
      CALL MG5_1_LOOP_4(1,3,2,4,DCMPLX(ZERO),DCMPLX(ZERO),DCMPLX(ZERO)
     $ ,DCMPLX(ZERO),2,I_SO,9)
C     CutTools call for loop numbers 15
      CALL MG5_1_LOOP_2(5,7,DCMPLX(MDL_MB),DCMPLX(MDL_MB),2,I_SO,10)
C     CutTools call for loop numbers 16
      CALL MG5_1_LOOP_2(6,8,DCMPLX(MDL_MB),DCMPLX(MDL_MB),2,I_SO,11)
C     CutTools call for loop numbers 17
      CALL MG5_1_LOOP_2(5,7,DCMPLX(MDL_MT),DCMPLX(MDL_MT),2,I_SO,12)
C     CutTools call for loop numbers 18
      CALL MG5_1_LOOP_2(6,8,DCMPLX(MDL_MT),DCMPLX(MDL_MT),2,I_SO,13)
C     At this point, all reductions needed for (QCD=6), i.e. of split
C      order ID=1, are computed.
      IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 5000

      GOTO 1001
 5000 CONTINUE
      CTCALL_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END


MODULE module_data_rrtmgaeropt

      IMPLICIT NONE
      INTEGER nswbands,nlwbands
      PARAMETER (nswbands =4,nlwbands=16)
      real,dimension(1:nswbands),save :: refrwsw,refiwsw
      real,dimension(1:nlwbands),save :: refrwlw,refiwlw
      data refrwsw /1.35,1.34,1.33,1.33/
      data refiwsw /1.524e-8,2.494e-9,1.638e-9,3.128e-6/
      data refrwlw /1.532,1.524,1.420,1.274,1.161,1.142,1.232,1.266,1.296, &
      1.321,1.342,1.315,1.330,1.339,1.350,1.408/
      data refiwlw / 0.336,0.360,0.426,0.403,0.321,0.115,0.0471,0.039,0.034, &
      0.0344,0.092,0.012,0.013,0.01,0.0049,0.0142/
      real,dimension(1:nswbands),save :: refrsw_dust,refisw_dust
      real,dimension(1:nlwbands),save :: refrlw_dust,refilw_dust
      data refrsw_dust /nswbands*1.550/
      data refisw_dust /nswbands*0.003/
      data refrlw_dust /2.340,2.904,1.748,1.508,1.911,1.822,2.917,1.557, &
      1.242,1.447,1.432,1.473,1.495,1.5,1.5,1.51/
      data refilw_dust /0.7,0.857,0.462,0.263,0.319,0.26,0.65,0.373,0.093, &
      0.105,0.061,0.0245,0.011,0.008,0.0068,0.018/
      real,dimension(1:nswbands),save :: refrsw_bc,refisw_bc
      real,dimension(1:nlwbands),save :: refrlw_bc,refilw_bc
      data refrsw_bc /nswbands*1.95/
      data refisw_bc /nswbands*0.79/
      data refrlw_bc /nlwbands*1.95/
      data refilw_bc /nlwbands*0.79/
      real,dimension(1:nswbands),save :: refrsw_oc,refisw_oc
      real,dimension(1:nlwbands),save :: refrlw_oc,refilw_oc
      data refrsw_oc /nswbands*1.45/
      data refisw_oc /nswbands*0.0/
      data refrlw_oc /1.86,1.91,1.988,1.439,1.606,1.7,1.888,2.489,1.219, &
      1.419,1.426,1.446,1.457,1.458,1.455,1.443/
      data refilw_oc /0.5,0.268,0.185,0.198,0.059,0.0488,0.11,0.3345,0.065, &
      0.058,0.0261,0.0142,0.013,0.01,0.005,0.0057/
      real,dimension(1:nswbands),save :: refrsw_seas,refisw_seas
      real,dimension(1:nlwbands),save :: refrlw_seas,refilw_seas
      data refrsw_seas /1.51,1.5,1.5,1.47/
      data refisw_seas /0.866e-6,7.019e-8,1.184e-8,0.00015/
      data refrlw_seas /1.74,1.76,1.78,1.456,1.41,1.48,1.56,1.63,1.4,1.43, &
      1.56,1.45,1.485,1.486,1.48,1.48 /
      data refilw_seas /0.1978,0.1978,0.129,0.038,0.019,0.014,0.016,0.03,0.012, &
      0.0064,0.0196,0.0029,0.0017,0.0014,0.0014,0.00176/
      real,dimension(1:nswbands),save :: refrsw_sulf,refisw_sulf
      real,dimension(1:nlwbands),save :: refrlw_sulf,refilw_sulf
      data refrsw_sulf /nswbands*1.52/
      data refisw_sulf /3*1.0e-9,1.75e-6/
      data refrlw_sulf /1.89,1.91,1.93,1.586,1.678,1.758,1.855,1.597,1.15, &
      1.26,1.42,1.35,1.379,1.385,1.385,1.367/
      data refilw_sulf /0.22,0.152,0.0846,0.2225,0.195,0.441,0.696,0.695, &
      0.459,0.161,0.172,0.14,0.12,0.122,0.126,0.158/
      real, save :: wavmin(nswbands)
      data wavmin /0.25,0.35,0.55,0.998/
      real, save :: wavmax(nswbands)
      data wavmax/0.35,0.45,0.65,1.000/
      real, save :: wavenumber1_longwave(nlwbands)
      data wavenumber1_longwave /10.,350.,500.,630.,700.,820.,980.,1080.,1180.,1390.,1480.,1800.,2080.,2250.,2390.,2600./
      real, save :: wavenumber2_longwave(nlwbands)
      data wavenumber2_longwave /350.,500.,630.,700.,820.,980.,1080.,1180.,1390.,1480.,1800.,2080., 2250.,2390.,2600.,3250./
      integer,parameter :: maxd_amode=3
      integer,parameter :: ntot_amode=3
      integer,parameter :: maxd_bin=8
      integer,parameter :: ntot_bin=8
      integer,parameter :: prefr=7,prefi=7
      integer,parameter :: ncoef=50
      real,parameter :: rmmin=0.005e-4,rmmax=50.e-4
      real,save:: refrtabsw(prefr,nswbands)
      real,save:: refitabsw(prefi,nswbands)
      real,save:: refrtablw(prefr,nlwbands)
      real,save:: refitablw(prefi,nlwbands)
      real,save:: extpsw(ncoef,prefr,prefi,nswbands)
      real,save:: abspsw(ncoef,prefr,prefi,nswbands)
      real,save:: ascatpsw(ncoef,prefr,prefi,nswbands)
      real,save:: asmpsw(ncoef,prefr,prefi,nswbands)
      real,save:: sbackpsw(ncoef,prefr,prefi,nswbands)
      real,save:: pmom2psw(ncoef,prefr,prefi,nswbands)
      real,save:: pmom3psw(ncoef,prefr,prefi,nswbands)
      real,save:: pmom4psw(ncoef,prefr,prefi,nswbands)
      real,save:: pmom5psw(ncoef,prefr,prefi,nswbands)
      real,save:: pmom6psw(ncoef,prefr,prefi,nswbands)
      real,save:: pmom7psw(ncoef,prefr,prefi,nswbands)
      real,save:: extplw(ncoef,prefr,prefi,nlwbands)
      real,save:: absplw(ncoef,prefr,prefi,nlwbands)
      real,save:: ascatplw(ncoef,prefr,prefi,nlwbands)
      real,save:: asmplw(ncoef,prefr,prefi,nlwbands)
      real,save :: wavmidsw(nswbands)
      data wavmidsw / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 /
      real,save :: wavmidlw(nlwbands)
      complex, save :: crefwsw(nswbands)
      complex, save :: crefwlw(nlwbands)
END MODULE module_data_rrtmgaeropt


! MinimalDX version 0.1.4 (https://www.github.com/dmey/minimal-dx).
! Copyright 2018-2020 D. Meyer and R. Raustad. Licensed under MIT.

module EPlusWrapperCooling
  !+ Initialise CalcDoe2DXCoil from EnergyPlusFortran and CalcDXCoolingCoil

  implicit none

  private
  public :: SimCalcDoe2DXCoil

  contains

  subroutine  SimCalcDoe2DXCoil(OutdoorTDryBulb, OutdoorHumRatio, OutdoorPressure,                & ! I
                                InletTDryBulb, InletHumRatio,                                     & ! I
                                RatedCOP, RatedTotCap, SensibleCoolingLoad, RatedAirMassFlowRate, & ! I
                                COP, TotalCoolingCapacity,                                        & ! O
                                OutletTemperature, OutletHumRatio,                                & ! O
                                ElecCoolingPower, LatCoolingEnergyRate,    & ! O
                                TotalCoolingEnergyRate, TotalSensibleHeatOut)

    use DXCoils,        only:  CalcDoe2DXCoil, DXCoil, DXCoilFullLoadOutAirTemp,                 &
                                DXCoilFullLoadOutAirHumRat, DXCoilOutletTemp, DXCoilOutletHumRat, &
                                DXCoilPartLoadRatio, DXCoilFanOpMode
    use DataHeatBalance,only:  HeatReclaimDXCoil
    use DataEnvironment,only:  OutBaroPress, OutDryBulbTemp, OutHumRat, OutWetBulbTemp
    use Psychrometrics, only:  PsyTwbFnTdbWPb,  PsyHFnTdbW
    use CurveManager,   only:  NumCurves, PerfCurve
    use ScheduleManager,only:  Schedule

    integer, parameter :: r64=kind(1.0d0)

    ! Subroutine arguments
    ! The number one ('1') next to the variable description denotes that the variable is dimensionless - e.g.   COP [1]
    real(r64), intent(in)    :: OutdoorTDryBulb
        !+ Outdoor dry bulb air temperature `[°C]`
    real(r64), intent(in)    :: OutdoorHumRatio
        !+ Outdoor air humidity ratio `[kgH₂O kgAIR⁻¹]`
    real(r64), intent(in)    :: OutdoorPressure
        !+ Outdoor barometric pressure `[Pa]`
    real(r64), intent(in)    :: InletTDryBulb
        !+ Indoor (inlet) dry bulb air temperature `[°C]`
    real(r64), intent(in)    :: InletHumRatio
        !+ Indoor (inlet) air humidity ratio `[kgH₂O kgAIR⁻¹]`
    real(r64), intent(in)    :: RatedCOP
        !+ Rated Coefficient Of Performance (COP) `[1]`
    real(r64), intent(in)    :: RatedTotCap
        !+ Rated (total) system capacity `[W]`
    real(r64), intent(in)    :: SensibleCoolingLoad
    !+ Building sensible load to be met `[W]`
    real(r64), intent(in)    :: RatedAirMassFlowRate
        !+ Rated air mass flow rate `[kg s⁻¹]`
    real(r64), intent(out)   :: COP
        !+ Actual (calculated) Coefficient Of Performance (COP) `[1]`
    real(r64), intent(out)   :: TotalCoolingCapacity
        !+ Actual (calculated) total system capacity `[W]`
    real(r64), intent(out)   :: OutletTemperature
        !+ Actual (calculated) outlet air dry bulb temperature existing the cooling coil `[°C]`
    real(r64), intent(out)   :: OutletHumRatio
        !+ Actual (calculated) outlet air humidity ratio existing the cooling coil `[kgH₂O kgAIR⁻¹]`
    real(r64), intent(out)   :: ElecCoolingPower
        !+ Calculated electrical power consumed by the DX unit `[W]`
    real(r64), intent(out)   :: LatCoolingEnergyRate
    ! Total latent cooling energy rate extracted by the coil from the indoor environment `[J kg⁻¹]`
    real(r64), intent(out)   :: TotalCoolingEnergyRate
        !+ Total cooling power of the DX unit (energy rate extracted by DX unit from the indoor environment) `[W]`
    real(r64), intent(out)   :: TotalSensibleHeatOut
        !+ Total power rejected by the evaporator into the outdoor environment
        !+ i.e. TotalCoolingEnergyRate + ElecCoolingPower `[W]`

    ! Local variables
    real(r64)              :: PartLoadRatio                     ! Part load ratio                                   [1]
    integer,   parameter   :: DXCoilNum           = 1           ! The number of the DX coil to be simulated         [1]
    integer,   parameter   :: CompOp              = 1           ! Compressor operation; 1=on, 0=off                 [1]
    logical,   parameter   :: FirstHVACIteration  = .TRUE.      ! True if this is the first iteration of HVAC       [1]
    integer,   parameter   :: FanOpMode           = 2           ! Allows parent obj to control fan operation        [1]

    ! Allocate other arrays used within CalcDoe2DXCoil
    ! from DataHeatBalance
    allocate(HeatReclaimDXCoil(1))
    allocate(Schedule(-1:1))
    Schedule(1)%CurrentValue = 1.0

    ! Initialize EnergyPlus global variables
    OutDryBulbTemp  = OutdoorTDryBulb
    OutHumRat       = OutdoorHumRatio
    OutBaroPress    = OutdoorPressure
    OutWetBulbTemp  = PsyTwbFnTdbWPb(OutDryBulbTemp, OutHumRat, OutBaroPress)

    ! Set up the DX coil and initialize data
    allocate(DXCoil(1))
    allocate(DXCoilFullLoadOutAirTemp(1))
    allocate(DXCoilFullLoadOutAirHumRat(1))
    allocate(DXCoilOutletTemp(1))
    allocate(DXCoilOutletHumRat(1))
    allocate(DXCoilPartLoadRatio(1))
    allocate(DXCoilFanOpMode(1))

    DXCoil(1)%SchedPtr                      = 1
    DXCoil(1)%RatedTotCap(1)                = RatedTotCap
    DXCoil(1)%RatedSHR(1)                   = 0.8d0                 ! FIXME: find correct value for RatedSHR
    DXCoil(1)%RatedCBF(1)                   = 0.1d0                 ! FIXME: find correct value for RatedCBF
    DXCoil(1)%RatedEIR(1)                   = 1.0d0 / RatedCOP
    DXCoil(1)%BypassedFlowFrac              = 0.0d0
    DXCoil(1)%RatedAirMassFlowRate          = RatedAirMassFlowRate
    DXCoil(1)%InletAirMassFlowRate          = RatedAirMassFlowRate
    DXCoil(1)%InletAirTemp                  = InletTDryBulb
    DXCoil(1)%InletAirHumRat                = InletHumRatio

    DXCoil(1)%InletAirEnthalpy = PsyHFnTdbW(InletTDryBulb, InletHumRatio)

    ! Performance Curves
    NumCurves = 5
    allocate(PerfCurve(NumCurves))
    ! Capacity as a function of temperature
    DXCoil(1)%CCapFTemp(1)                  = 1
    DXCoil(1)%TotCapTempModFacCurveType(1)  = 4                 ! BiQuadratic curve
    PerfCurve(1)%InterpolationType          = 3                 ! EvaluateCurveToLimits
    PerfCurve(1)%CurveType                  = 4                 ! BiQuadratic
    PerfCurve(1)%Var1Min                    = -10.0d0           ! min inlet air WB temp limit
    PerfCurve(1)%Var2Min                    = -10.0d0           ! min outdoor air DB temp limit
    PerfCurve(1)%Var1Max                    = 50.0d0            ! max inlet air WB temp limit
    PerfCurve(1)%Var2Max                    = 50.0d0            ! max outdoor air DB temp limit
    PerfCurve(1)%CurveMin                   = 0.63d0             ! min value of curve output
    PerfCurve(1)%CurveMax                   = 1.57d0             ! max value of curve output
    PerfCurve(1)%Coeff1                     = 1.5509d0          !- Coefficient1 Constant
    PerfCurve(1)%Coeff2                     = -0.07505d0        !- Coefficient2 x
    PerfCurve(1)%Coeff3                     = 0.0031d0          !- Coefficient3 x2
    PerfCurve(1)%Coeff4                     = 0.0024d0          !- Coefficient4 y
    PerfCurve(1)%Coeff5                     = -0.00005d0        !- Coefficient5 y2
    PerfCurve(1)%Coeff6                     = -0.00043d0        !- Coefficient6 x*y
    PerfCurve(1)%CurveMaxPresent = .TRUE.
    PerfCurve(1)%CurveMinPresent = .TRUE.

    ! Capacity as a function of flow fraction
    DXCoil(1)%CCapFFlow(1)                  = 2
    PerfCurve(2)%InterpolationType          = 3                 ! EvaluateCurveToLimits
    PerfCurve(2)%CurveType                  = 3                 ! Quadratic
    PerfCurve(2)%Var1Min                    = 0.0d0             ! min flow fraction limit
    PerfCurve(2)%Var1Max                    = 1.5d0             ! max flow fraction limit
    PerfCurve(2)%CurveMin                   = 0.0d0             ! min value of curve output
    PerfCurve(2)%CurveMax                   = 2.0d0             ! max value of curve output
    PerfCurve(2)%Coeff1                     = 0.718605468d0     !- Coefficient1 Constant
    PerfCurve(2)%Coeff2                     = 0.410099989d0     !- Coefficient2 x
    PerfCurve(2)%Coeff3                     = -0.128705457d0    !- Coefficient3 x2

    ! EIR as a function of temperature
    DXCoil(1)%EIRFTemp(1)                   = 3
    DXCoil(1)%EIRTempModFacCurveType(1)     = 4                 ! BiQuadratic curve
    PerfCurve(3)%InterpolationType          = 3                 ! EvaluateCurveToLimits
    PerfCurve(3)%CurveType                  = 4                 ! BiQuadratic
    PerfCurve(3)%Var1Min                    = -10.0d0           ! min inlet air WB temp limit
    PerfCurve(3)%Var2Min                    = -10.0d0           ! min outdoor air DB temp limit
    PerfCurve(3)%Var1Max                    = 50.0d0            ! max inlet air WB temp limit
    PerfCurve(3)%Var2Max                    = 50.0d0            ! max outdoor air DB temp limit
    PerfCurve(3)%CurveMin                   = 0.83d0             ! min value of curve output
    PerfCurve(3)%CurveMax                   = 1.21d0             ! max value of curve output
    PerfCurve(3)%Coeff1                     = -0.30428d0        !- Coefficient1 Constant
    PerfCurve(3)%Coeff2                     = 0.11805d0         !- Coefficient2 x
    PerfCurve(3)%Coeff3                     = -0.00342d0        !- Coefficient3 x2
    PerfCurve(3)%Coeff4                     = -0.00626d0        !- Coefficient4 y
    PerfCurve(3)%Coeff5                     = 0.0007d0          !- Coefficient5 y2
    PerfCurve(3)%Coeff6                     = -0.00047d0        !- Coefficient6 x*y
    PerfCurve(3)%CurveMaxPresent = .TRUE.
    PerfCurve(3)%CurveMinPresent = .TRUE.

    ! EIR as a function of flow fraction
    DXCoil(1)%EIRFFlow(1)                   = 4
    PerfCurve(4)%InterpolationType          = 3                 ! EvaluateCurveToLimits
    PerfCurve(4)%CurveType                  = 3                 ! Quadratic
    PerfCurve(4)%Var1Min                    = 0.0d0             ! min flow fraction limit
    PerfCurve(4)%Var1Max                    = 1.5d0             ! max flow fraction limit
    PerfCurve(4)%CurveMin                   = 0.0d0             ! min value of curve output
    PerfCurve(4)%CurveMax                   = 2.0d0             ! max value of curve output
    PerfCurve(4)%Coeff1                     = 1.32299905d0      !- Coefficient1 Constant
    PerfCurve(4)%Coeff2                     = -0.477711207d0    !- Coefficient2 x
    PerfCurve(4)%Coeff3                     = 0.154712157d0     !- Coefficient3 x2

    ! Part load fraction as a function of part load ratio
    DXCoil(1)%PLFFPLR(1)                    = 5
    PerfCurve(5)%InterpolationType          = 3                 ! EvaluateCurveToLimits
    PerfCurve(5)%CurveType                  = 1                 ! Linear
    PerfCurve(5)%Var1Min                    = 0.0d0             ! min inlet air WB temp limit
    PerfCurve(5)%Var1Max                    = 1.0d0             ! max inlet air WB temp limit
    PerfCurve(5)%Coeff1                     = 0.90d0            !- Coefficient1 Constant
    PerfCurve(5)%Coeff2                     = 0.10d0            !- Coefficient2 x
    PerfCurve(5)%CurveMin                   = 0.0d0             ! min value of curve output
    PerfCurve(5)%CurveMax                   = 1.0d0             ! max value of curve output

    ! Run initial case with PartLoadRatio = 1 to get SensibleCoolingLoad and
    ! SensCoolingEnergyRates to calculate actual PartLoadRatio
    PartLoadRatio = 1.0d0
    call CalcDoe2DXCoil(DXCoilNum, CompOp, FirstHVACIteration, PartLoadRatio, FanOpMode)

    ! Calculate PartLoadRatio from previous call
    PartLoadRatio = SensibleCoolingLoad / DXCoil(1)%SensCoolingEnergyRate

    ! Keep PartLoadRatio  bounded between 0 and 1
    if ( PartLoadRatio < 0.0d0 ) PartLoadRatio = 0.0d0
    if ( PartLoadRatio > 1.0d0 ) PartLoadRatio = 1.0d0

    ! Call CalcDoe2DXCoil again with correct part load ratio
    call CalcDoe2DXCoil(DXCoilNum, CompOp, FirstHVACIteration, PartLoadRatio ,FanOpMode)

    ! Assign return variables of interest
    COP = DXCoil(1)%TotalCoolingEnergyRate / DXCoil(1)%ElecCoolingPower
    TotalCoolingCapacity = DXCoil(1)%TotalCoolingEnergyRate / DXCoil(1)%PartLoadRatio
    OutletTemperature = DXCoil(1)%OutletAirTemp
    OutletHumRatio = DXCoil(1)%OutletAirHumRat
    ElecCoolingPower = DXCoil(1)%ElecCoolingPower
    LatCoolingEnergyRate = DXCoil(1)%LatCoolingEnergyRate
    TotalCoolingEnergyRate = DXCoil(1)%TotalCoolingEnergyRate
    TotalSensibleHeatOut = DXCoil(1)%TotalCoolingEnergyRate + DXCoil(1)%ElecCoolingPower

    deallocate(HeatReclaimDXCoil)
    deallocate(Schedule)
    deallocate(DXCoil)
    deallocate(DXCoilFullLoadOutAirTemp)
    deallocate(DXCoilFullLoadOutAirHumRat)
    deallocate(DXCoilOutletTemp)
    deallocate(DXCoilOutletHumRat)
    deallocate(DXCoilPartLoadRatio)
    deallocate(DXCoilFanOpMode)
    deallocate(PerfCurve)

  end subroutine SimCalcDoe2DXCoil
end module EPlusWrapperCooling


  subroutine paulip (sDCM, clientTarg, partin, ipatin, v, mv, np, irefl, &
       & ipa, pauliData, results)

! ======================================================================
!
!     Pauli principle subroutine. Converts momenta from interaction
!     CM frame to lab frame, and determines if any nucleon final
!     state is Pauli blocked.
!
!    Called by: CASCAD
!
!    Calls: KINEMA
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!    More editing, AJS  July, 1997.
!    Modified by AJS, August, 2002.
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================
!
!   The C. M. momentum components are initially stored in pmemo(1:3).
!   They are transformed into the lab frame in KINEMA; then tested to
!   see if the lab kinetic energies are greater than the Fermi kinetic
!   energy.
!
!  Definition of partin:
!                       partin(1); x coordinate of particle
!                       partin(2); y coordinate of particle
!                       partin(3); z coordinate of particle
!                       partin(4); sin(theta), direction of momentum
!                       partin(5); cos(theta), direction of momentum
!                       partin(6); sin(phi), direction of momentum
!                       partin(7); cos(phi), direction of momentum
!                       partin(8); kinetic energy of particle
!                       partin(9); rest mass of particle
!
!  Definition of ipatin:
!                       ipatin(1); charge of particle
!                       ipatin(2); non-zero for photon
!                       ipatin(3); strangeness of particle
!                       ipatin(4); particle baryon number
!                       ipatin(5); zone number of nucleus where particle
!                                  is located.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: one, massPiPM
    use standardDCMDataClass, only: StandardDCMData

    implicit none
    class(StandardDCM),       intent(inout) :: sDCM
    class(StandardDCMData),   intent(inout) :: clientTarg
    real(real64),             intent(inout) :: partin(9)
    integer(int32),           intent(inout) :: ipatin(5)
    real(real64),             intent(in   ) :: v(3)
    integer(int32),           intent(inout) :: mv
    integer(int32),           intent(in   ) :: np
    integer(int32),           intent(inout) :: irefl
    integer(int32),           intent(inout) :: ipa
    type(sDCMPauliInfo),      intent(inout) :: pauliData
    type(StandardDCMResults), intent(inout) :: results

    integer(int32) :: j1, l, mtemp, ntemp
    real(real64)   :: cfi, ct, sfi, st, t, temp, tf
    real(real64)   :: p(3), pstar(3)

! ======================================================================

    j1 = ipatin(5)
    l = 1
10  if (np == 2 .and. l == 2) l = l + 1
    mtemp = mv + l
    pstar(1) = results%pmemo(1,mtemp)
    pstar(2) = results%pmemo(2,mtemp)
    pstar(3) = results%pmemo(3,mtemp)
    call sDCM%kinema (pstar, v, p, ct, st, cfi, sfi, t, results%pmemo(9,mtemp))
    results%pmemo(1,mtemp) = partin(1)
    results%pmemo(2,mtemp) = partin(2)
    results%pmemo(3,mtemp) = partin(3)
    results%pmemo(4,mtemp) = st
    results%pmemo(5,mtemp) = ct
    results%pmemo(6,mtemp) = sfi
    results%pmemo(7,mtemp) = cfi
    results%pmemo(8,mtemp) = t
    results%imemo(5,mtemp) = ipatin(5)
    pauliData%ngen(mtemp) = pauliData%ing + 1
    if (results%imemo(4,mtemp).ne.1 .or. results%imemo(3,mtemp).ne.0) then
!  Not a baryon:
       if (l < np) then
          l = l + 1
          go to 10
       elseif (l >= np .and. ipa == 0) then
          ipa = 2
          return
       else
          go to 20
       endif
    else
!  A baryon:
       temp = results%imemo(1,mtemp)
       tf = clientTarg%protFermiMom(j1) * temp + &
            & clientTarg%neutFermiMom(j1) * (one - temp)
       if (results%pmemo(8,mtemp) > tf) then
          if (l < np) then
!   If all particles haven't been checked, go back.
             l = l + 1
             go to 10
          elseif (l >= np .and. ipa == 0) then
!   Energy was less than cutof3 in CASCAD, the 2 imaginary
!   potentials were more than 30% different, and both nucleons
!   exceeded the Fermi energy:
             ipa = 2
             return
          endif
       else
!   Kinetic energy <= Fermi energy; return to CASCAD with ipa unchanged.
          return
       endif
    endif
20  if (l >= np .and. ipa.ne.0) then
       if ((abs(partin(9)-massPiPM) < 0.01d0 .and. np == 2) .and. &
            & (results%pmemo(9,mv+1) > 0.9d0 .and. &
            & results%pmemo(9,mv+3) > 0.9d0)) pauliData%indi = 3
       partin(4) = results%pmemo(4,mv+3)
       partin(5) = results%pmemo(5,mv+3)
       partin(6) = results%pmemo(6,mv+3)
       partin(7) = results%pmemo(7,mv+3)
       partin(8) = results%pmemo(8,mv+3)
       partin(9) = results%pmemo(9,mv+3)
       ipatin(1) = results%imemo(1,mv+3)
       ipatin(2) = results%imemo(2,mv+3)
       ipatin(3) = results%imemo(3,mv+3)
       ipatin(4) = results%imemo(4,mv+3)
       pauliData%ing = pauliData%ngen(mv+3)
       results%excitons%numExcHoles = results%excitons%numExcHoles + 1
       if (np > 2) then
          ntemp = mv + np
          results%pmemo(4,mv+3) = results%pmemo(4,ntemp)
          results%pmemo(5,mv+3) = results%pmemo(5,ntemp)
          results%pmemo(6,mv+3) = results%pmemo(6,ntemp)
          results%pmemo(7,mv+3) = results%pmemo(7,ntemp)
          results%pmemo(8,mv+3) = results%pmemo(8,ntemp)
          results%pmemo(9,mv+3) = results%pmemo(9,ntemp)
          results%imemo(1,mv+3) = results%imemo(1,ntemp)
          results%imemo(2,mv+3) = results%imemo(2,ntemp)
          results%imemo(3,mv+3) = results%imemo(3,ntemp)
          results%imemo(4,mv+3) = results%imemo(4,ntemp)
          pauliData%meso = 1
       endif
       mv = mv + np - 1
       irefl = 0
    endif
    return

! ======================================================================
  end subroutine paulip